open import Nat
open import Prelude
open import contexts
open import core

module canonical-value-forms where
  canonical-value-forms-b : ∀{Δ d} →
                            Δ , ∅ ⊢ d :: b →
                            d val →
                            d == c
  canonical-value-forms-b TAConst VConst = refl
  canonical-value-forms-b (TAVar x₁) ()
  canonical-value-forms-b (TAAp wt wt₁) ()
  canonical-value-forms-b (TAEHole x x₁) ()
  canonical-value-forms-b (TANEHole x wt x₁) ()
  canonical-value-forms-b (TACast wt x) ()
  canonical-value-forms-b (TAFailedCast wt x x₁ x₂) ()
  canonical-value-forms-b (TAFst wt) ()
  canonical-value-forms-b (TASnd wt) ()

  canonical-value-forms-arr : ∀{Δ d τ1 τ2} →
                              Δ , ∅ ⊢ d :: (τ1 ==> τ2) →
                              d val →
                              Σ[ x ∈ Nat ] Σ[ d' ∈ iexp ]
                                ((d == (·λ x [ τ1 ] d')) ×
                                 (Δ , ■ (x , τ1) ⊢ d' :: τ2))
  canonical-value-forms-arr (TAVar x₁) ()
  canonical-value-forms-arr (TALam _ wt) VLam = _ , _ , refl , wt
  canonical-value-forms-arr (TAAp wt wt₁) ()
  canonical-value-forms-arr (TAEHole x x₁) ()
  canonical-value-forms-arr (TANEHole x wt x₁) ()
  canonical-value-forms-arr (TACast wt x) ()
  canonical-value-forms-arr (TAFailedCast x x₁ x₂ x₃) ()
  canonical-value-forms-arr (TAFst wt) ()
  canonical-value-forms-arr (TASnd wt) ()

  canonical-value-forms-prod : ∀{Δ d τ1 τ2} →
                               Δ , ∅ ⊢ d :: (τ1 ⊗ τ2) →
                               d val →
                               Σ[ d1 ∈ iexp ] Σ[ d2 ∈ iexp ]
                                 ((d == ⟨ d1 , d2 ⟩ ) ×
                                  (Δ , ∅ ⊢ d1 :: τ1) ×
                                  (Δ , ∅ ⊢ d2 :: τ2))
  canonical-value-forms-prod (TAVar x₁) ()
  canonical-value-forms-prod (TAAp wt wt₁) ()
  canonical-value-forms-prod (TAEHole x x₁) ()
  canonical-value-forms-prod (TANEHole x wt x₁) ()
  canonical-value-forms-prod (TACast wt x) ()
  canonical-value-forms-prod (TAFailedCast wt x x₁ x₂) ()
  canonical-value-forms-prod (TAFst wt) ()
  canonical-value-forms-prod (TASnd wt) ()
  canonical-value-forms-prod (TAPair wt wt₁) (VPair dv dv₁) = _ , _ , refl , wt , wt₁

  -- this argues (somewhat informally, because you still have to inspect
  -- the types of the theorems above and manually verify this property)
  -- that we didn't miss any cases above; this intentionally will make this
  -- file fail to typecheck if we added more types, hopefully forcing us to
  -- remember to add canonical forms lemmas as appropriate
  canonical-value-forms-coverage1 : ∀{Δ d τ} →
                                   Δ , ∅ ⊢ d :: τ →
                                   d val →
                                   τ ≠ b →
                                   ((τ1 : typ) (τ2 : typ) → τ ≠ (τ1 ==> τ2)) →
                                   ((τ1 : typ) (τ2 : typ) → τ ≠ (τ1 ⊗ τ2)) →
                                   ⊥
  canonical-value-forms-coverage1 TAConst VConst = λ z _ _ → z refl
  canonical-value-forms-coverage1 (TAVar x₁) ()
  canonical-value-forms-coverage1 (TALam _ wt) VLam = λ _ z _ → z _ _ refl
  canonical-value-forms-coverage1 (TAAp wt wt₁) ()
  canonical-value-forms-coverage1 (TAEHole x x₁) ()
  canonical-value-forms-coverage1 (TANEHole x wt x₁) ()
  canonical-value-forms-coverage1 (TACast wt x) ()
  canonical-value-forms-coverage1 (TAFailedCast wt x x₁ x₂) ()
  canonical-value-forms-coverage1 (TAFst wt) ()
  canonical-value-forms-coverage1 (TASnd wt) ()
  canonical-value-forms-coverage1 (TAPair wt wt₁) (VPair dv dv₁) ne h = λ z → z _ _ refl

  canonical-value-forms-coverage2 : ∀{Δ d} →
                                   Δ , ∅ ⊢ d :: ⦇·⦈ →
                                   d val →
                                   ⊥
  canonical-value-forms-coverage2 (TAVar x₁) ()
  canonical-value-forms-coverage2 (TAAp wt wt₁) ()
  canonical-value-forms-coverage2 (TAEHole x x₁) ()
  canonical-value-forms-coverage2 (TANEHole x wt x₁) ()
  canonical-value-forms-coverage2 (TACast wt x) ()
  canonical-value-forms-coverage2 (TAFailedCast wt x x₁ x₂) ()
  canonical-value-forms-coverage2 (TAFst wt) ()
  canonical-value-forms-coverage2 (TASnd wt) ()


{-# OPTIONS --cubical --no-import-sorts --safe #-}
module Cubical.Structures.Group where

open import Cubical.Structures.Group.Base public
open import Cubical.Structures.Group.Properties public
open import Cubical.Structures.Group.Morphism public
open import Cubical.Structures.Group.MorphismProperties public


open import Relation.Unary
open import Relation.Ternary.Separation

module Relation.Ternary.Separation.Monad.Free {ℓ} {A : Set ℓ}
  {{r : RawSep A}}
  (Cmd : Pred A ℓ)
  (δ   : ∀ {Φ} → Cmd Φ → Pred A ℓ)
  where

open import Level
open import Function
open import Data.Unit
open import Data.Product
open import Relation.Unary.PredicateTransformer using (PT)
open import Relation.Ternary.Separation.Morphisms
open import Relation.Ternary.Separation.Monad
open import Relation.Binary.PropositionalEquality

mutual
  Cont : ∀ {Δ} → Cmd Δ → Pred A ℓ → Pred A ℓ
  Cont c P = δ c ─✴ Free P

  data Free : PT A A ℓ ℓ where
    pure   : ∀ {P}   → ∀[ P ⇒ Free P ]
    impure : ∀ {P}   → ∀[ ∃[ Cmd ]✴ (λ c → Cont c P) ⇒ Free P ]

module _ {u} {{_ : IsUnitalSep r u}} where
  open Monads
  instance
    free-monad : Monad ⊤ ℓ (λ _ _ → Free)
    Monad.return free-monad = pure
    app (Monad.bind free-monad f) (pure x) σ = app f x σ
    app (Monad.bind free-monad f) (impure (cmd ×⟨ σ₁ ⟩ κ)) σ =
      let _ , σ₂ , σ₃ = ⊎-assoc σ₁ (⊎-comm σ) in
      impure (cmd ×⟨ σ₂ ⟩ wand λ resp σ₄ →
        let _ , τ₁ , τ₂ = ⊎-assoc (⊎-comm σ₃) σ₄ in
        app (bind f) (app κ resp τ₂) τ₁)

  ⟪_⟫ : ∀ {Φ} → (c : Cmd Φ) → Free (δ c) Φ
  ⟪_⟫ c =
    impure (c ×⟨ ⊎-idʳ ⟩
      wand λ r σ → case ⊎-id⁻ˡ σ of λ where refl → return r  )

module _ {B : Set ℓ} {M : PT A B ℓ ℓ} {P : Pred A ℓ}
  {{rb : RawSep B}} {u} {{_ : IsUnitalSep r u}}
  {{jm : Morphism A B}}
  {{_ : IsUnitalSep rb (Morphism.j jm u)}}
  {{ monad : Monads.Monad {{jm = jm}} ⊤ ℓ (λ _ _ → M) }}
  where

  open Morphism jm
  open Monads.Monad {{jm = jm}} monad
  open Monads {{jm = jm}} using (str; typed-str)

  open import Data.Nat

  -- Unfolding a command tree one step
  step : (cmd : ∀ {Φ} → (c : Cmd Φ) → M (δ c) (j Φ)) → ∀[ Free P ⇒ⱼ M (Free P) ]
  step cmd (pure px) = return (pure px)
  step cmd (impure (c ×⟨ σ ⟩ κ)) = do
    r ×⟨ σ ⟩ κ ← cmd c &⟨ Cont c P ∥ j-⊎ σ ⟩ κ
    return (app κ r (⊎-comm σ))

  -- A fueled generic interpreter for command trees in Free
  interpret : ℕ → ∀[ M P ] → (cmd : ∀ {Φ} → (c : Cmd Φ) → M (δ c) (j Φ)) → ∀[ Free P ⇒ⱼ M P ]
  interpret zero    def cmd f = def
  interpret (suc n) def cmd f = do
    impure f ← step cmd f
      where
        (pure v) → return v
    interpret n def cmd (impure f)


{-# OPTIONS --without-K #-}
module Util.HoTT.Univalence.Statement where

open import Util.HoTT.Equiv
open import Util.Prelude

Univalence : ∀ α → Set (lsuc α)
Univalence α = {A B : Set α} → IsEquiv (≡→≃ {A = A} {B = B})


{-# OPTIONS --show-implicit #-}
-- {-# OPTIONS -v tc.polarity:10 -v tc.inj:40 -v tc.conv.irr:20 #-}  -- -v tc.mod.apply:100 #-}
module Issue168 where

postulate X : Set

open import Issue168b
open Membership X

postulate
  P : Nat → Set
  lemma : ∀ n → P (id n)

foo : P zero
foo = lemma _


module Proof where

open import Agda.Primitive hiding (_⊔_)
open import Reflection
open import Data.Fin hiding (_+_)
open import Data.Fin.Properties using (eq? ; _≟_ )
open import Data.Nat hiding (eq? ; _⊔_)
open import Data.Nat.Properties
open import Data.List
open import Data.String hiding (setoid)
open import Data.Bool
open import Data.Vec
open import Relation.Binary
open import Relation.Binary.EqReasoning
open import Relation.Binary.PropositionalEquality using (_≡_ ; refl ; cong ; setoid )
import Relation.Binary.Indexed as I
open import Function using (_∘_ ; _$_ ; _∋_ ; id ; const)
open import Function.Equality using (_⟶_ ;  _⟨$⟩_ ; Π )
open import Function.LeftInverse hiding (_∘_)
open import Function.Injection using (_↣_ ; Injective ; Injection )
open import Function.Surjection using (_↠_ ; Surjective ; Surjection)
open import Function.Bijection using (Bijection ; Bijective ; id )
open import Relation.Nullary
open import Relation.Nullary.Negation

open import Helper.Fin
open import Serializer
open import Serializer.Fin
open import Serializer.Bool

data Test : Set where
  A : Bool -> Test
  B : Fin 2 -> Bool -> Test
  C : Fin 2 -> Test

open Serializer.Serializer {{...}}

fromTest : Test -> Fin 8
fromTest (A x) = +₁ 6 2 (+₁ 2 4 (from x))
fromTest (B x x₁) = +₁ 6 2 (+₂ 2 4 (× 2 2 (from x) (from x₁)))
fromTest (C x) = +₂ 6 2 (from x)

test : Fin 4 -> Test
test x with ⨂ 2 2 x
test .(× 2 2 i j) | is× i j = B (to i) (to j)

toTest : Fin 8 -> Test
toTest x = [ (\y -> [ (\z -> A $ to z) , test ] (⨁ 2 4 y) ) , (\y -> C $ to y) ] (⨁ 6 2 x)

--from-cong : Setoid._≈_ (setoid Test) I.=[ fromTest ]⇒ Setoid._≈_ (setoid (Fin 8))
--from-cong refl = refl

from-preserves-eq : setoid Test ⟶ setoid (Fin 8)
from-preserves-eq = record { _⟨$⟩_ = fromTest ; cong = (\{ {i} {.i} refl → refl }) }

from-injective : Injective from-preserves-eq
from-injective {A x} {A x₁} p with from-bool-injective ∘ +-eq₁ ∘ +-eq₁ $ p
from-injective {A x} {A .x} p | refl = refl
from-injective {A x} {B x₁ x₂} p = contradiction (+-eq₁ p) ¬+-eq₁
from-injective {A x} {C x₁} p = contradiction p ¬+-eq₁
from-injective {B x x₁} {A x₂} p = contradiction (+-eq₁ p) ¬+-eq₂
from-injective {B x x₁} {B y y₁} p with +-eq₂ {2} {4} ∘ +-eq₁ $ p
... | p2 with from-bool-injective (×-equal₁ {x₁ = x} {x₂ = y} p2) | ×-equal₂ {x₁ = x} {x₂ = y} p2
from-injective {B x x₁} {B .x .x₁} p | p2 | refl | refl = refl
from-injective {B x x₁} {C x₂} p = contradiction p ¬+-eq₁
from-injective {C x} {A x₁} p = contradiction p ¬+-eq₂
from-injective {C x} {B x₁ x₂} p = contradiction p ¬+-eq₂
from-injective {C x} {C .x} refl = refl

from-surjective : Surjective from-preserves-eq
from-surjective = record { from = preserves-eq-inv ; right-inverse-of = inv }
  where
--    cong-inverse : Setoid._≈_ (setoid (Fin 8)) I.=[ toTest ]⇒ Setoid._≈_ (setoid Test)
--    cong-inverse refl = refl

    preserves-eq-inv : setoid (Fin 8) ⟶ setoid Test
    preserves-eq-inv = record { _⟨$⟩_ = toTest ; cong = (\{ {i} {.i} refl → refl }) }

    inv : preserves-eq-inv RightInverseOf from-preserves-eq
    inv x with ⨁ 6 2 x
    inv .(+₁ 6 2 i) | is+₁ i with ⨁ 2 4 i
    inv ._ | is+₁ ._ | is+₁ i
      rewrite (Surjective.right-inverse-of (Bijective.surjective (Bijection.bijective (bijection {Bool})))) i = refl
    inv ._ | is+₁ ._ | is+₂ j with ⨂ 2 2 j
    inv ._ | is+₁ ._ | is+₂ ._ | is× i j
      rewrite (Surjective.right-inverse-of (Bijective.surjective (Bijection.bijective (bijection {Fin 2})))) i
        | (Surjective.right-inverse-of (Bijective.surjective (Bijection.bijective (bijection {Bool})))) j = refl
    inv ._ | is+₂ j = refl

from-injection : Test ↣ Fin 8
from-injection = record { to = from-preserves-eq ; injective = from-injective }

from-surjection : Test ↠ Fin 8
from-surjection = record { to = from-preserves-eq ; surjective = from-surjective }

from-bijection : Bijection (setoid Test) (setoid (Fin 8))
from-bijection = record { to = from-preserves-eq ; bijective = record { injective = from-injective ; surjective = from-surjective } }

instance
  serializerTest : Serializer Test
  serializerTest = record {
    size = 8 ;
    from = fromTest ;
    to = toTest ;
    bijection = from-bijection
    }


open import Function using (_$_)

open import Relation.Nullary using (yes; no)
open import Relation.Binary using (Decidable; Irrelevant; Antisymmetric; Setoid)
open import AKS.Algebra.Bundles using (NonZeroCommutativeRing; Field)

module AKS.Algebra.Consequences {c ℓ} (R : NonZeroCommutativeRing c ℓ) where

open import AKS.Nat using (ℕ)

open import Algebra.Bundles using (CommutativeRing)

open NonZeroCommutativeRing R using (_+_; _*_; -_; _-_; 0#; 1#) renaming (Carrier to C)
open NonZeroCommutativeRing R using (_≈_; _≉_; setoid)
open Setoid setoid using (refl; sym)
open import Relation.Binary.Reasoning.Setoid setoid
open NonZeroCommutativeRing R using (isNonZeroCommutativeRing; commutativeRing)
open CommutativeRing commutativeRing using (+-identityʳ; +-assoc; +-comm; +-congʳ; +-congˡ; +-cong; -‿cong; -‿inverseʳ)
open CommutativeRing commutativeRing using (*-identityˡ; *-cong; *-congʳ; *-congˡ; *-assoc; *-comm; zeroʳ; zeroˡ; commutativeSemiring)
open import AKS.Algebra.Structures C _≈_ using (IsField; IsEuclideanDomain; module Modulus; module Divisibility; IsIntegralDomain; IsGCDDomain; IsUniqueFactorizationDomain)
open import AKS.Algebra.Divisibility commutativeSemiring using (module Euclidean)
open Modulus using (Remainder; 0≈)
open Divisibility _*_ using (_∣_; divides)

module Division⇒EuclideanDomain
  (_≈?_ : Decidable _≈_)
  (≈-irrelevant : Irrelevant _≈_)
  (≉-irrelevant : Irrelevant _≉_)
  (∣_∣ : ∀ n {n≉0 : n ≉ 0#} → ℕ)
  (_div_ : ∀ (n m : C) {m≉0 : m ≉ 0#} → C)
  (_mod_ : ∀ (n m : C) {m≉0 : m ≉ 0#} → C)
  (division : ∀ n m {m≉0 : m ≉ 0#} → n ≈ m * (n div m) {m≉0} + (n mod m) {m≉0})
  (modulus : ∀ n m {m≉0 : m ≉ 0#} → Remainder 0# ∣_∣ _mod_ n m {m≉0})
  (div-cong : ∀ {x₁ x₂} {y₁ y₂} → x₁ ≈ x₂ → y₁ ≈ y₂ → ∀ {y₁≉0 y₂≉0} → (x₁ div y₁) {y₁≉0} ≈ (x₂ div y₂) {y₂≉0})
  (mod-distribʳ-* : ∀ c a b {b≉0} {b*c≉0} → ((a * c) mod (b * c)) {b*c≉0} ≈ (a mod b) {b≉0} * c)
  (*-cancelˡ : ∀ x {y z} → x ≉ 0# → x * y ≈ x * z → y ≈ z)
  where

  private
    remainder : ∀ n m {m≉0 : m ≉ 0#} → (n mod m) {m≉0} ≈ n - m * (n div m) {m≉0}
    remainder n m {m≉0} = begin
      n mod m                               ≈⟨ sym (+-identityʳ (n mod m)) ⟩
      n mod m + 0#                          ≈⟨ +-congˡ (sym (-‿inverseʳ (m * n div m))) ⟩
      n mod m + (m * n div m - m * n div m) ≈⟨ sym (+-assoc (n mod m) (m * n div m) (- (m * n div m))) ⟩
      (n mod m + m * n div m) - m * n div m ≈⟨ +-congʳ (+-comm (n mod m) (m * n div m)) ⟩
      (m * n div m + n mod m) - m * n div m ≈⟨ +-congʳ (sym (division n m {m≉0})) ⟩
      n - m * n div m                       ∎

    mod-cong : ∀ {x₁ x₂} {y₁ y₂} → x₁ ≈ x₂ → y₁ ≈ y₂ → ∀ {y₁≉0 y₂≉0} → (x₁ mod y₁) {y₁≉0} ≈ (x₂ mod y₂) {y₂≉0}
    mod-cong {x₁} {x₂} {y₁} {y₂} x₁≈x₂ y₁≈y₂ {y₁≉0} {y₂≉0} = begin
      x₁ mod y₁           ≈⟨ remainder x₁ y₁ {y₁≉0} ⟩
      x₁ - y₁ * x₁ div y₁ ≈⟨ +-cong x₁≈x₂ (-‿cong (*-cong y₁≈y₂ (div-cong x₁≈x₂ y₁≈y₂))) ⟩
      x₂ - y₂ * x₂ div y₂ ≈⟨ sym (remainder x₂ y₂ {y₂≉0}) ⟩
      x₂ mod y₂           ∎

  open Euclidean ∣_∣ _div_ _mod_ _≈?_ ≈-irrelevant ≉-irrelevant division modulus mod-cong mod-distribʳ-* using (gcd; gcd-isGCD) public

  isIntegralDomain : IsIntegralDomain _+_ _*_ -_ 0# 1#
  isIntegralDomain = record { isNonZeroCommutativeRing = isNonZeroCommutativeRing; *-cancelˡ = *-cancelˡ }

  isGCDDomain : IsGCDDomain _+_ _*_ -_ 0# 1# gcd
  isGCDDomain = record { isIntegralDomain = isIntegralDomain; gcd-isGCD = gcd-isGCD }

  isUniqueFactorizationDomain : IsUniqueFactorizationDomain _+_ _*_ -_ 0# 1# gcd
  isUniqueFactorizationDomain = record { isGCDDomain = isGCDDomain }

  isEuclideanDomain : IsEuclideanDomain _+_ _*_ -_ 0# 1# ∣_∣ _div_ _mod_ gcd
  isEuclideanDomain = record
    { isUniqueFactorizationDomain = isUniqueFactorizationDomain
    ; division = division
    ; modulus = modulus
    ; div-cong = div-cong
    ; mod-cong = mod-cong
    }

module Inverse⇒Field
  (_≈?_ : Decidable _≈_)
  (≈-irrelevant : Irrelevant _≈_)
  (≉-irrelevant : Irrelevant _≉_)
  (_/_ : ∀ (n m : C) {m≉0 : m ≉ 0#} → C)
  (inverse : ∀ (n m : C) {m≉0 : m ≉ 0#} → n ≈ m * (n / m) {m≉0})
  where

  private
    ∣_∣ : ∀ n {n≉0 : n ≉ 0#} → ℕ
    ∣ _ ∣ = 0

    _mod_ : ∀ (n m : C) {m≉0 : m ≉ 0#} → C
    _ mod _ = 0#

    division : ∀ n m {m≉0 : m ≉ 0#} → n ≈ m * (n / m) {m≉0} + (n mod m) {m≉0}
    division n m {m≉0} = begin
      n ≈⟨ inverse  n m {m≉0} ⟩
      m * (n / m) ≈⟨ sym (+-identityʳ (m * (n / m))) ⟩
      m * (n / m) {m≉0} + (n mod m) {m≉0} ∎

    modulus : ∀ n m {m≉0 : m ≉ 0#} → Remainder 0# ∣_∣ _mod_ n m {m≉0}
    modulus _ _ = 0≈ refl

    *-cancelˡ : ∀ x {y z} → x ≉ 0# → x * y ≈ x * z → y ≈ z
    *-cancelˡ x {y} {z} x≢0 x*y≡x*z = begin
      y                  ≈⟨ sym (*-identityˡ y) ⟩
      1# * y             ≈⟨ *-congʳ (inverse 1# x {x≢0}) ⟩
      (x * (1# / x)) * y ≈⟨ *-congʳ (*-comm x (1# / x)) ⟩
      ((1# / x) * x) * y ≈⟨ *-assoc _ _ _ ⟩
      (1# / x) * (x * y) ≈⟨ *-congˡ x*y≡x*z ⟩
      (1# / x) * (x * z) ≈⟨ sym (*-assoc _ _ _) ⟩
      ((1# / x) * x) * z ≈⟨ *-congʳ (*-comm (1# / x) x) ⟩
      (x * (1# / x)) * z ≈⟨ *-congʳ (sym (inverse 1# x {x≢0})) ⟩
      1# * z             ≈⟨ *-identityˡ z ⟩
      z ∎

    div-cong : ∀ {x₁ x₂} {y₁ y₂} → x₁ ≈ x₂ → y₁ ≈ y₂ → ∀ {y₁≉0 y₂≉0} → (x₁ / y₁) {y₁≉0} ≈ (x₂ / y₂) {y₂≉0}
    div-cong {x₁} {x₂} {y₁} {y₂} x₁≈x₂ y₁≈y₂ {y₁≉0} {y₂≉0} = *-cancelˡ y₁ y₁≉0 $ begin
      y₁ * (x₁ / y₁) ≈⟨ sym (inverse x₁ y₁) ⟩
      x₁             ≈⟨ x₁≈x₂ ⟩
      x₂             ≈⟨ inverse x₂ y₂ ⟩
      y₂ * (x₂ / y₂) ≈⟨ *-congʳ (sym y₁≈y₂) ⟩
      y₁ * (x₂ / y₂) ∎

    mod-distribʳ-* : ∀ c a b {b≉0} {b*c≉0} → ((a * c) mod (b * c)) {b*c≉0} ≈ (a mod b) {b≉0} * c
    mod-distribʳ-* c a b = sym (zeroˡ c)

  open Division⇒EuclideanDomain _≈?_ ≈-irrelevant ≉-irrelevant ∣_∣ _/_ _mod_ division modulus div-cong mod-distribʳ-* *-cancelˡ using (gcd; isEuclideanDomain) public

  isField : IsField _+_ _*_ -_ 0# 1# _/_ gcd
  isField = record { isEuclideanDomain = isEuclideanDomain }

  [field] : Field c ℓ
  [field] = record { isField = isField }


module Sized.SimpleCell where

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

open import SizedIO.Object
open import SizedIO.IOObject
open import SizedIO.ConsoleObject

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

open import NativeIO

open import Size

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

CellResult : ∀{A} → CellMethod A → Set
CellResult {A} get = A
CellResult (put _) = Unit

-- cellJ is the interface of the object of a simple cell
cellJ : (A : Set) → Interface
Method  (cellJ A)    =  CellMethod A
Result  (cellJ A) m  =  CellResult m

cell : {A : Set} → A → Object (cellJ A)
objectMethod (cell a) get = a , (cell a)
objectMethod (cell a) (put a') = _ , (cell a')

-- cellC is the type of consoleObjects with interface (cellJ String)
CellC : (i : Size) → Set
CellC i = ConsoleObject i (cellJ String)

-- cellO is a program for a simple cell which
-- when get is called writes "getting s" for the string s of the object
-- and when putting s writes "putting s" for the string

-- cellP is constructor for the consoleObject for interface (cellJ String)
cellP : ∀{i} (s : String) → CellC i
force (method (cellP s) get) =
  exec' (putStrLn ("getting (" ++ s ++ ")")) λ _ →
  return (s , cellP s)
force (method (cellP s) (put x)) =
  exec' (putStrLn ("putting (" ++ x ++ ")")) λ _ →
  return (_ , (cellP x))

-- Program is another program
program : String → IOConsole ∞ Unit
program arg =
  let c₀ = cellP "Start" in
  method c₀ get       >>= λ{ (s , c₁) →
  exec1 (putStrLn s)         >>
  method c₁ (put arg) >>= λ{ (_ , c₂) →
  method c₂ get       >>= λ{ (s' , c₃) →
  exec1 (putStrLn s')
  }}}

main : NativeIO Unit
main = translateIOConsole (program "hello")


{-A
Polynomials over commutative rings
==================================
-}
{-# OPTIONS --safe #-}

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

module Cubical.Algebra.Polynomials.Univariate.Properties where

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

open import Cubical.Data.Sigma
open import Cubical.Data.Nat renaming (_+_ to _+n_; _·_ to _Nat·_) hiding (·-comm)
open import Cubical.Data.Nat.Order
open import Cubical.Data.Empty.Base renaming (rec to ⊥rec )
open import Cubical.Data.Bool

open import Cubical.Algebra.Group hiding (Bool)
open import Cubical.Algebra.Ring
open import Cubical.Algebra.CommRing

open import Cubical.Algebra.Polynomials.Univariate.Base

private
  variable
    ℓ ℓ' : Level

module PolyModTheory (R' : CommRing ℓ) where
  private
    R = fst R'

  open PolyMod R'
  open CommRingTheory R'
  open RingTheory (CommRing→Ring R')
  open GroupTheory (Ring→Group (CommRing→Ring R'))

  pattern [_] x = x ∷ []

---------------------------------------
-- Definition
-- Identity for addition of polynomials
---------------------------------------
  0P : Poly
  0P = []

  --ReplicatePoly(n,p) returns 0 ∷ 0 ∷ ... ∷ [] (n zeros)
  ReplicatePoly0 : (n : ℕ)  → Poly
  ReplicatePoly0 zero  = 0P
  ReplicatePoly0 (suc n) = 0r ∷ ReplicatePoly0 n

  --The empty polynomial has multiple equal representations on the form 0 + 0x + 0 x² + ...
  replicatePoly0Is0P : ∀ (n : ℕ) → ReplicatePoly0 n ≡ 0P
  replicatePoly0Is0P zero = refl
  replicatePoly0Is0P (suc n) = (cong (0r ∷_) (replicatePoly0Is0P n)) ∙ drop0

-----------------------------
-- Definition
-- subtraction of polynomials
-----------------------------
  Poly- : Poly → Poly
  Poly- [] = []
  Poly- (a ∷ p) = (- a) ∷ (Poly- p)
  Poly- (drop0 i) = (cong (_∷ []) (inv1g) ∙ drop0) i

  -- Double negation (of subtraction of polynomials) is the identity mapping
  Poly-Poly- : (p : Poly) → Poly- (Poly- p) ≡ p
  Poly-Poly- = ElimProp.f (λ x → Poly- (Poly- x) ≡ x)
                          refl
                          (λ a p e → cong (_∷ (Poly- (Poly- p)))
                                          (-Idempotent a) ∙ cong (a ∷_ ) (e))
                          (isSetPoly _ _)

---------------------------
-- Definition
-- addition for polynomials
---------------------------
  _Poly+_ : Poly → Poly → Poly
  p Poly+ [] = p
  [] Poly+ (drop0 i) = drop0 i
  [] Poly+ (b ∷ q) = b ∷ q
  (a ∷ p) Poly+ (b ∷ q) = (a + b) ∷ (p Poly+ q)
  (a ∷ p) Poly+ (drop0 i) = +Rid a i ∷ p
  (drop0 i) Poly+ (a ∷ q) = lem q i  where
                                 lem : ∀ q → (0r + a) ∷ ([] Poly+ q) ≡ a ∷ q
                                 lem = ElimProp.f (λ q → (0r + a) ∷ ([] Poly+ q) ≡ a ∷ q)
                                                  (λ i → (+Lid a i ∷ []))
                                                  (λ r p _ → λ i → +Lid a i ∷ r ∷ p )
                                                  (isSetPoly _ _)
  (drop0 i) Poly+ (drop0 j) =  isSet→isSet' isSetPoly  (cong ([_] ) (+Rid 0r)) drop0
                                                       (cong ([_] ) (+Lid 0r)) drop0 i j

  -- [] is the left identity for Poly+
  Poly+Lid : ∀ p → ([] Poly+ p ≡ p)
  Poly+Lid =  ElimProp.f (λ p → ([] Poly+ p ≡ p) )
                         refl
                         (λ r p prf → refl)
                         (λ x y → isSetPoly _ _ x y)

  -- [] is the right identity for Poly+
  Poly+Rid : ∀ p → (p Poly+ [] ≡ p)
  Poly+Rid p = refl

  --Poly+ is Associative
  Poly+Assoc : ∀ p q r → p Poly+ (q Poly+ r) ≡ (p Poly+ q) Poly+ r
  Poly+Assoc =
    ElimProp.f (λ p → (∀ q r → p Poly+ (q Poly+ r) ≡ (p Poly+ q) Poly+ r))
               (λ q r → Poly+Lid (q Poly+ r) ∙ cong (_Poly+ r)  (sym (Poly+Lid q)))
               (λ a p prf → ElimProp.f ((λ q → ∀ r → ((a ∷ p) Poly+ (q Poly+ r)) ≡
                                                   (((a ∷ p) Poly+ q) Poly+ r)))
                                       (λ r → cong ((a ∷ p) Poly+_) (Poly+Lid r))
                                       (λ b q prf2 →
                                       ElimProp.f
                                         (λ r → ((a ∷ p) Poly+ ((b ∷ q) Poly+ r)) ≡
                                                 ((a + b ∷ (p Poly+ q)) Poly+ r))
                                         refl
                                         (λ c r prfp → cong ((a + (b + c))∷_)
                                                            (prf q r) ∙
                                                            (cong (_∷ ((p Poly+ q) Poly+ r))
                                                                  (+Assoc a b c)))
                                         (isSetPoly _ _))
                                       λ x y i r → isSetPoly (x r i0) (y r i1) (x r) (y r) i)
                λ x y i q r  → isSetPoly _ _ (x q r) (y q r) i

  -- for any polynomial, p, the additive inverse is given by Poly- p
  Poly+Inverses : ∀ p → p Poly+ (Poly- p) ≡ []
  Poly+Inverses = ElimProp.f ( λ p → p Poly+ (Poly- p) ≡ [])
                             refl --(Poly+Lid (Poly- []))
                             (λ r p prf → cong (r + - r ∷_) prf ∙
                                          (cong (_∷ [])  (+Rinv r) ∙ drop0))
                             (isSetPoly _ _)

  --Poly+ is commutative
  Poly+Comm : ∀ p q → p Poly+ q ≡ q Poly+ p
  Poly+Comm = ElimProp.f (λ p → (∀ q → p Poly+ q ≡ q Poly+ p))
                         (λ q → Poly+Lid q)
                         (λ a p prf → ElimProp.f (λ q → ((a ∷ p) Poly+ q) ≡ (q Poly+ (a ∷ p)))
                                                 refl
                                                 (λ b q prf2 → cong (_∷ (p Poly+ q)) (+Comm a b) ∙
                                                               cong ((b + a) ∷_) (prf q))
                                                 (isSetPoly _ _)
                         )
                         (λ {p} → isPropΠ (λ q → isSetPoly (p Poly+ q) (q Poly+ p)))

--------------------------------------------------------------
-- Definition
-- multiplication of a polynomial by a (constant) ring element
--------------------------------------------------------------
  _PolyConst*_ : (R) → Poly → Poly
  r PolyConst* [] = []
  r PolyConst* (a ∷ p) = (r · a) ∷ (r PolyConst* p)
  r PolyConst* (drop0 i) = lem r i where
                                 lem : ∀ r → [ r · 0r ] ≡ []
                                 lem =  λ r → [ r · 0r ] ≡⟨ cong (_∷ []) (0RightAnnihilates r) ⟩
                                        [ 0r ] ≡⟨ drop0 ⟩
                                        [] ∎

  -- For any polynomial p we have: 0 _PolyConst*_ p = []
  0rLeftAnnihilatesPoly : ∀ q → 0r PolyConst* q ≡ [ 0r ]
  0rLeftAnnihilatesPoly = ElimProp.f (λ q → 0r PolyConst* q ≡ [ 0r ])
                                         (sym drop0)
                                         (λ r p prf → cong ((0r · r) ∷_) prf ∙
                                                      cong (_∷ [ 0r ]) (0LeftAnnihilates r) ∙
                                                      cong (0r ∷_) drop0 )
                                         λ x y → isSetPoly _ _ x y

  -- For any polynomial p we have: 1 _PolyConst*_ p = p
  PolyConst*Lid : ∀ q → 1r PolyConst* q ≡ q
  PolyConst*Lid = ElimProp.f (λ q → 1r PolyConst* q ≡ q ) refl
                             (λ a p prf → cong (_∷ (1r PolyConst* p)) (·Lid a) ∙
                                          cong (a ∷_) (prf) )
                             λ x y → isSetPoly _ _ x y

--------------------------------
-- Definition
-- Multiplication of polynomials
--------------------------------
  _Poly*_ : Poly → Poly → Poly
  [] Poly* q = []
  (a ∷ p) Poly* q = (a PolyConst* q) Poly+ (0r ∷ (p Poly* q))
  (drop0 i) Poly* q = lem q i where
                               lem : ∀ q → (0r PolyConst* q) Poly+ [ 0r ] ≡ []
                               lem = λ q → ((0r PolyConst* q) Poly+ [ 0r ]) ≡⟨ cong ( _Poly+ [ 0r ] ) (0rLeftAnnihilatesPoly q)⟩
                                           ([ 0r ] Poly+ [ 0r ]) ≡⟨ cong (_∷ []) 0Idempotent  ∙ drop0 ⟩
                                           [] ∎

--------------------
--Definition
--Identity for Poly*
--------------------
  1P : Poly
  1P = [ 1r ]

  -- For any polynomial p we have: p Poly* [] = []
  0PRightAnnihilates : ∀ q → 0P Poly* q ≡ 0P
  0PRightAnnihilates = ElimProp.f (λ q → 0P Poly* q ≡ 0P)
                                  refl
                                  (λ r p prf → prf)
                                  λ x y → isSetPoly _ _ x y

  -- For any polynomial p we have: [] Poly* p = []
  0PLeftAnnihilates : ∀ p → p Poly* 0P ≡ 0P
  0PLeftAnnihilates = ElimProp.f (λ p → p Poly* 0P ≡ 0P )
                                 refl
                                 (λ r p prf → cong (0r ∷_) prf ∙ drop0)
                                 λ x y → isSetPoly _ _ x y

  -- For any polynomial p we have: p Poly* [ 1r ] = p
  Poly*Lid : ∀ q → 1P Poly* q ≡ q
  Poly*Lid =
    ElimProp.f (λ q → 1P Poly* q ≡ q)
               drop0
               (λ r p prf → lemma r p)
               (λ x y → isSetPoly _ _ x y)
                 where
                 lemma : ∀ r p → 1r · r + 0r ∷ (1r PolyConst* p) ≡ r ∷ p
                 lemma =
                   λ r p → 1r · r + 0r ∷ (1r PolyConst* p) ≡⟨ cong (_∷ (1r PolyConst* p) )
                                                                   (+Rid (1r · r)) ⟩
                           1r · r ∷ (1r PolyConst* p) ≡⟨ cong (_∷ 1r PolyConst* p) (·Lid r) ⟩
                           r ∷ (1r PolyConst* p) ≡⟨ cong (r ∷_) (PolyConst*Lid p) ⟩
                           r ∷ p ∎

  -- Distribution of indeterminate: (p + q)x = px + qx
  XLDistrPoly+ : ∀ p q → (0r ∷ (p Poly+ q)) ≡ ((0r ∷ p) Poly+ (0r ∷ q))
  XLDistrPoly+ =
    ElimProp.f (λ p → ∀ q → (0r ∷ (p Poly+ q)) ≡ ((0r ∷ p) Poly+ (0r ∷ q)) )
               (λ q → (cong (0r ∷_) (Poly+Lid q)) ∙
                      cong (0r ∷_) (sym (Poly+Lid q)) ∙
                      sym (cong (_∷ [] Poly+ q) (+Lid 0r)))
               (λ a p prf → ElimProp.f (λ q → 0r ∷ ((a ∷ p) Poly+ q) ≡
                                         ((0r ∷ a ∷ p) Poly+ (0r ∷ q)))
                                       (cong (_∷ a ∷ p ) (sym (+Lid 0r)))
                                       (λ b q prf2 → cong (_∷ a + b ∷ (p Poly+ q)) (sym (+Lid 0r)))
                                       (λ x y i → isSetPoly (x i0) (x i1) x y i))
               (λ x y i q → isSetPoly (x q i0) (x q i1) (x q) (y q) i)

  -- Distribution of a constant ring element over added polynomials p, q: a (p + q) = ap + aq
  PolyConst*LDistrPoly+ : ∀ a p q → a PolyConst* (p Poly+ q) ≡
                                    (a PolyConst* p) Poly+ (a PolyConst* q)
  PolyConst*LDistrPoly+ =
    λ a → ElimProp.f (λ p → ∀ q → a PolyConst* (p Poly+ q) ≡
                                  (a PolyConst* p) Poly+ (a PolyConst* q))
                     (λ q → cong (a PolyConst*_) (Poly+Lid q) ∙
                            (sym (Poly+Lid (a PolyConst* q))))
                     (λ b p prf → ElimProp.f (λ q → (a PolyConst* ((b ∷ p) Poly+ q)) ≡
                                                    (a PolyConst* (b ∷ p)) Poly+ (a PolyConst* q))
                                             refl
                                             (λ c q prf2  → cong (_∷ (a PolyConst* (p Poly+ q)))
                                                                 (·Rdist+ a b c) ∙
                                                            cong (a · b + a · c ∷_) (prf q))
                                             (isSetPoly _ _))
                     (λ x y i q  → isSetPoly (x q i0) (x q i1) (x q) (y q) i)

  --Poly* left distributes over Poly+
  Poly*LDistrPoly+ : ∀ p q r → p Poly* (q Poly+ r) ≡ (p Poly* q) Poly+ (p Poly* r)
  Poly*LDistrPoly+ =
    ElimProp.f
      (λ p → ∀ q r → p Poly* (q Poly+ r) ≡ (p Poly* q) Poly+ (p Poly* r))
      (λ _ _ → refl)
      (λ a p prf q r → ((a PolyConst* (q Poly+ r)) Poly+
                        (0r ∷(p Poly*(q Poly+ r)))) ≡⟨
                                                      cong (_Poly+ (0r ∷ (p Poly* (q Poly+ r))))
                                                           (PolyConst*LDistrPoly+ a q r)
                                                     ⟩
      (((a PolyConst* q) Poly+ (a PolyConst* r)) Poly+
        (0r ∷ (p Poly* (q Poly+ r)))) ≡⟨
                                        cong (((a PolyConst* q) Poly+ (a PolyConst* r)) Poly+_)
                                             (cong (0r ∷_) (prf q r))
                                       ⟩
      (((a PolyConst* q) Poly+ (a PolyConst* r)) Poly+
        (0r ∷ ((p Poly* q) Poly+ (p Poly* r)))) ≡⟨
                                                  cong (((a PolyConst* q) Poly+
                                                         (a PolyConst* r)) Poly+_)
                                                  (XLDistrPoly+ (p Poly* q) (p Poly* r))
                                                 ⟩
      (((a PolyConst* q) Poly+ (a PolyConst* r)) Poly+
        ((0r ∷ (p Poly* q)) Poly+ (0r ∷ (p Poly* r)))) ≡⟨
                                                         Poly+Assoc ((a PolyConst* q) Poly+
                                                                      (a PolyConst* r))
                                                                    (0r ∷ (p Poly* q))
                                                                    (0r ∷ (p Poly* r))
                                                        ⟩
      (((a PolyConst* q) Poly+ (a PolyConst* r)) Poly+
        (0r ∷ (p Poly* q))) Poly+ (0r ∷ (p Poly* r)) ≡⟨ cong (_Poly+ (0r ∷ (p Poly* r)))
                                                             (sym (Poly+Assoc (a PolyConst* q)
                                                                              (a PolyConst* r)
                                                                              (0r ∷ (p Poly* q))))
                                                    ⟩
      (((a PolyConst* q) Poly+ ((a PolyConst* r) Poly+
        (0r ∷ (p Poly* q)))) Poly+ (0r ∷ (p Poly* r))) ≡⟨
                                                         cong (_Poly+ (0r ∷ (p Poly* r)))
                                                              (cong ((a PolyConst* q) Poly+_)
                                                                    (Poly+Comm (a PolyConst* r)
                                                                               (0r ∷ (p Poly* q))))
                                                         ⟩
      (((a PolyConst* q) Poly+ ((0r ∷ (p Poly* q)) Poly+
        (a PolyConst* r))) Poly+ (0r ∷ (p Poly* r))) ≡⟨
                                                       cong (_Poly+ (0r ∷ (p Poly* r)))
                                                            (Poly+Assoc (a PolyConst* q)
                                                                        (0r ∷ (p Poly* q))
                                                                        (a PolyConst* r))
                                                            ⟩
      ((((a PolyConst* q) Poly+ (0r ∷ (p Poly* q))) Poly+
        (a PolyConst* r)) Poly+ (0r ∷ (p Poly* r))) ≡⟨
                                                      sym (Poly+Assoc ((a PolyConst* q) Poly+
                                                                         (0r ∷ (p Poly* q)))
                                                                      ((a PolyConst* r))
                                                                      ((0r ∷ (p Poly* r))))
                                                     ⟩
      ((a PolyConst* q) Poly+ (0r ∷ (p Poly* q))) Poly+
        ((a PolyConst* r) Poly+ (0r ∷ (p Poly* r))) ∎)
      (λ x y i q r → isSetPoly _ _ (x q r) (y q r) i)

  -- The constant multiplication of a ring element, a, with a polynomial, p, can be
  -- expressed by polynomial multiplication with the singleton polynomial [ a ]
  PolyConst*r=Poly*[r] : ∀ a p → a PolyConst* p ≡ p Poly* [ a ]
  PolyConst*r=Poly*[r] =
    λ a → ElimProp.f (λ p → a PolyConst* p ≡ p Poly* [ a ])
                     refl
                     ( λ r p prf →  a · r ∷ (a PolyConst* p) ≡⟨
                                                              cong (a · r ∷_) prf
                                                             ⟩
                       a · r ∷ (p Poly* [ a ]) ≡⟨
                                                 cong (a · r ∷_)
                                                      (sym (Poly+Lid (p Poly* [ a ])))
                                                ⟩
                       a · r ∷ ([] Poly+ (p Poly* [ a ])) ≡⟨
                                                            cong (_∷ ([] Poly+ (p Poly* [ a ])))
                                                                 (·Comm a r )
                                                           ⟩
                       r · a ∷ ([] Poly+ (p Poly* [ a ])) ≡⟨
                                                            cong (_∷ ([] Poly+ (p Poly* [ a ])))
                                                                 (sym (+Rid (r · a)))
                                                           ⟩
                       r · a + 0r ∷ ([] Poly+ (p Poly* [ a ])) ∎)
                     ( λ x y i → isSetPoly (x i0) (x i1) x y i)

  -- Connection between the constant multiplication and the multiplication in the ring
  PolyConst*Nested· : ∀ a b p → a PolyConst* (b PolyConst* p) ≡ (a · b) PolyConst* p
  PolyConst*Nested· =
    λ a b → ElimProp.f (λ p → a PolyConst* (b PolyConst* p) ≡ (a · b) PolyConst* p)
                       refl
                       (λ c p prf → cong ((a · (b · c)) ∷_) prf ∙
                                    cong (_∷ ((a · b) PolyConst* p)) (·Assoc a b c))
                       (isSetPoly _ _)

  -- We can move the indeterminate from left to outside: px * q = (p * q)x
  0r∷LeftAssoc : ∀ p q → (0r ∷ p) Poly* q ≡ 0r ∷ (p Poly* q)
  0r∷LeftAssoc =
    ElimProp.f (λ p → ∀ q → (0r ∷ p) Poly* q ≡ 0r ∷ (p Poly* q))
               (λ q → cong (_Poly+ [ 0r ])((cong (_Poly+ []) (0rLeftAnnihilatesPoly q))) ∙
                      cong (_∷ []) (+Lid 0r))
               (λ r p b q → cong (_Poly+ (0r ∷ ((r PolyConst* q) Poly+ (0r ∷ (p Poly* q)))))
                                 ((0rLeftAnnihilatesPoly q) ∙ drop0))
               (λ x y i q → isSetPoly _ _ (x q) (y q) i)

  --Associativity of constant multiplication in relation to polynomial multiplication
  PolyConst*AssocPoly* : ∀ a p q → a PolyConst* (p Poly* q) ≡ (a PolyConst* p) Poly* q
  PolyConst*AssocPoly* =
    λ a → ElimProp.f (λ p → ∀ q → a PolyConst* (p Poly* q) ≡ (a PolyConst* p) Poly* q)
                     (λ q → refl)
                     (λ b p prf q → a PolyConst* ((b PolyConst* q) Poly+
                                    (0r ∷ (p Poly* q))) ≡⟨
                                                          PolyConst*LDistrPoly+ a
                                                                                (b PolyConst* q)
                                                                                (0r ∷ (p Poly* q))
                                                         ⟩
                     (a PolyConst* (b PolyConst* q)) Poly+
                      (a PolyConst* (0r ∷ (p Poly* q))) ≡⟨
                                             cong (_Poly+ (a · 0r ∷ (a PolyConst* (p Poly* q))))
                                                  (PolyConst*Nested· a b q)
                                                         ⟩
                     ((a · b) PolyConst* q) Poly+
                      (a PolyConst* (0r ∷ (p Poly* q))) ≡⟨
                                                    cong (((a · b) PolyConst* q) Poly+_)
                                                         (cong (a · 0r  ∷_)
                                                               (PolyConst*r=Poly*[r] a
                                                                                (p Poly* q)))
                                                         ⟩
                     ((a · b) PolyConst* q) Poly+
                      (a · 0r ∷ ((p Poly* q) Poly* [ a ])) ≡⟨
                                                         cong (((a · b) PolyConst* q) Poly+_)
                                                              (cong (_∷ ((p Poly* q) Poly* [ a ]))
                                                                    (0RightAnnihilates a))  ⟩
                     ((a · b) PolyConst* q) Poly+
                      (0r ∷ ((p Poly* q) Poly* [ a ])) ≡⟨
                                            cong (((a · b) PolyConst* q) Poly+_)
                                                 (cong (0r ∷_)
                                                       (sym (PolyConst*r=Poly*[r] a (p Poly* q))))
                                                        ⟩
                     ((a · b) PolyConst* q) Poly+
                      (0r ∷ (a PolyConst* (p Poly* q))) ≡⟨
                                                         cong (((a · b) PolyConst* q) Poly+_)
                                                              (cong (0r ∷_) (prf q))
                                                         ⟩
                     ((a · b) PolyConst* q) Poly+
                      (0r ∷ ((a PolyConst* p) Poly* q)) ∎)
                     (λ x y i q → isSetPoly (x q i0) (x q i1) (x q) (y q) i)

  -- We can move the indeterminate from left to outside: p * qx = (p * q)x
  0r∷RightAssoc : ∀ p q → p Poly* (0r ∷  q) ≡ 0r ∷ (p Poly* q)
  0r∷RightAssoc =
    ElimProp.f (λ p → ∀ q → p Poly* (0r ∷  q) ≡ 0r ∷ (p Poly* q))
               (λ q → sym drop0)
               (λ a p prf q → ((a ∷ p) Poly* (0r ∷ q)) ≡⟨
                                                        cong ( a · 0r + 0r ∷_)
                                                             (cong ((a PolyConst* q) Poly+_ )
                                                                   (prf q))
                                                        ⟩
               a · 0r + 0r ∷ ((a PolyConst* q) Poly+
                 (0r ∷ (p Poly* q))) ≡⟨
                                       cong (_∷ ((a PolyConst* q) Poly+ (0r ∷ (p Poly* q))))
                                            ((+Rid (a · 0r)))
                                      ⟩
               a · 0r ∷ ((a PolyConst* q) Poly+
                 (0r ∷ (p Poly* q))) ≡⟨
                                      cong (_∷ ((a PolyConst* q) Poly+ (0r ∷ (p Poly* q))))
                                           (0RightAnnihilates a) ⟩
               0r ∷ ((a PolyConst* q) Poly+ (0r ∷ (p Poly* q))) ∎)
               (λ x y i q  → isSetPoly (x q i0) (x q i1) (x q) (y q) i)

  -- We can move the indeterminate around: px * q = p * qx
  0r∷Comm : ∀ p q → (0r ∷ p) Poly* q ≡ p Poly* (0r ∷ q)
  0r∷Comm = ElimProp.f (λ p → ∀ q → (0r ∷ p) Poly* q ≡ p Poly* (0r ∷ q))
                         (λ q → (cong ((0r PolyConst* q) Poly+_) drop0) ∙
                                                0rLeftAnnihilatesPoly q ∙
                                                                 drop0  )
                         (λ a p prf q → ((0r ∷ a ∷ p) Poly* q) ≡⟨ 0r∷LeftAssoc (a ∷ p) q ⟩
                                        0r ∷ ((a ∷ p) Poly* q) ≡⟨ sym (0r∷RightAssoc (a ∷ p) q) ⟩
                                      ((a ∷ p) Poly* (0r ∷ q)) ∎
                       )
                       λ x y i q → isSetPoly (x q i0) (x q i1) (x q) (y q) i

  --Poly* is commutative
  Poly*Commutative : ∀ p q → p Poly* q ≡ q Poly* p
  Poly*Commutative =
    ElimProp.f (λ p → ∀ q → p Poly* q ≡ q Poly* p)
               (λ q → sym (0PLeftAnnihilates q))
               (λ a p prf q → (a PolyConst* q) Poly+ (0r ∷ (p Poly* q)) ≡⟨
                                       cong ((a PolyConst* q) Poly+_)
                                            (cong (0r ∷_) (prf q)) ⟩
               ((a PolyConst* q) Poly+ (0r ∷ (q Poly* p))) ≡⟨
                                                            cong ((a PolyConst* q) Poly+_)
                                                            (sym (0r∷LeftAssoc q p))
                                                            ⟩
               ((a PolyConst* q) Poly+ ((0r ∷ q) Poly* p)) ≡⟨
                                      cong (_Poly+ ((0r PolyConst* p) Poly+ (0r ∷ (q Poly* p))))
                                           (PolyConst*r=Poly*[r] a q) ⟩
               ((q Poly* [ a ]) Poly+ ((0r ∷ q) Poly* p)) ≡⟨
                                                           cong ((q Poly* [ a ]) Poly+_)
                                                                (0r∷Comm q p)
                                                           ⟩
               ((q Poly* [ a ]) Poly+ (q Poly* (0r ∷ p))) ≡⟨
                                                           sym (Poly*LDistrPoly+ q [ a ] (0r ∷ p))
                                                           ⟩
               (((q Poly* ([ a ] Poly+ (0r ∷ p))))) ≡⟨
                                                     cong (q Poly*_)
                                                          (Poly+Comm [ a ] (0r ∷ p))
                                                     ⟩
               ((q Poly* ((0r ∷ p) Poly+ [ a ]))) ≡⟨
                                                   refl
                                                   ⟩
               (q Poly* ((0r + a) ∷ p)) ≡⟨ cong (q Poly*_)
                                                (cong (_∷ p) (+Lid a))
                                         ⟩
               (q Poly* (a ∷ p)) ∎)
               (λ x y i q → isSetPoly _ _ (x q ) (y q) i)

  --1P is the right identity of Poly*.
  Poly*Rid : ∀ p → p Poly* 1P ≡ p
  Poly*Rid = λ p → (Poly*Commutative p 1P ∙ Poly*Lid p)

  --Polynomial multiplication right distributes over polynomial addition.
  Poly*RDistrPoly+ : ∀ p q r → (p Poly+ q) Poly* r ≡ (p Poly* r) Poly+ (q Poly* r)
  Poly*RDistrPoly+ = λ p q r → sym (Poly*Commutative r (p Poly+ q)) ∙
                                       Poly*LDistrPoly+ r p q ∙
                                       cong (_Poly+ (r Poly* q)) (Poly*Commutative r p) ∙
                                       cong ((p Poly* r) Poly+_) (Poly*Commutative r q)

  --Polynomial multiplication is associative
  Poly*Associative : ∀ p q r → p Poly* (q Poly* r) ≡  (p Poly* q) Poly* r
  Poly*Associative =
    ElimProp.f (λ p → ∀ q r → p Poly* (q Poly* r) ≡  (p Poly* q) Poly* r )
               (λ _ _ → refl)
               (λ a p prf q r  →
                 ((a ∷ p) Poly* (q Poly* r)) ≡⟨
                                               cong (_Poly+ (0r ∷ (p Poly* (q Poly* r))))
                                                    (PolyConst*AssocPoly* a q r)
                                              ⟩
                 (((a PolyConst* q) Poly* r) Poly+
                  (0r ∷ (p Poly* (q Poly* r)))) ≡⟨
                                                 sym (cong (((a PolyConst* q) Poly* r) Poly+_)
                                                           (cong (_∷ (p Poly* (q Poly* r)))
                                                                 (+Lid 0r)))
                                                 ⟩
                 (((a PolyConst* q) Poly* r) Poly+
                  (0r + 0r ∷ (p Poly* (q Poly* r)))) ≡⟨
                                                 cong (((a PolyConst* q) Poly* r) Poly+_)
                                                      (cong (0r + 0r ∷_)
                                                            (sym (Poly+Lid (p Poly* (q Poly* r)))))
                                                      ⟩
                 (((a PolyConst* q) Poly* r) Poly+
                  (0r + 0r ∷ ([] Poly+ (p Poly* (q Poly* r))))) ≡⟨
                                                         cong (((a PolyConst* q) Poly* r) Poly+_)
                                                              (cong (0r + 0r ∷_)
                                                                    (cong ([] Poly+_)
                                                                          (prf q r)))
                                                                 ⟩
                 (((a PolyConst* q) Poly* r) Poly+
                  (0r + 0r ∷ ([] Poly+ ((p Poly* q) Poly* r)))) ≡⟨
                                                  cong (((a PolyConst* q) Poly* r) Poly+_)
                                                       (cong (_Poly+ (0r ∷ ((p Poly* q) Poly* r)))
                                                             (sym (0rLeftAnnihilatesPoly r)))
                                                                 ⟩
                 (((a PolyConst* q) Poly* r) Poly+
                  ((0r PolyConst* r) Poly+ (0r ∷ ((p Poly* q) Poly* r)))) ≡⟨
                                                     sym (Poly*RDistrPoly+ (a PolyConst* q)
                                                                           (0r ∷ (p Poly* q)) r)
                                                                           ⟩
                 ((((a ∷ p) Poly* q) Poly* r)) ∎)
               (λ x y i q r  → isSetPoly _ _ (x q r) (y q r) i)

-----------------------------------------------------------------------------
-- Product by Xn and operationsproperties on it

  prod-Xn : (n : ℕ) → Poly → Poly
  prod-Xn zero x = x
  prod-Xn (suc n) x = 0r ∷ (prod-Xn n x)

  prod-Xn-0P : (n : ℕ) → prod-Xn n 0P ≡ 0P
  prod-Xn-0P zero = refl
  prod-Xn-0P (suc n) = cong (λ X → 0r ∷ X) (prod-Xn-0P n) ∙ drop0

  prod-Xn-sum : (n : ℕ) → (x y : Poly) → (prod-Xn n x) Poly+ (prod-Xn n y) ≡ prod-Xn n (x Poly+ y)
  prod-Xn-sum zero x y = refl
  prod-Xn-sum (suc n) x y = cong₂ _∷_ (+Rid 0r) (prod-Xn-sum n x y)

  prod-Xn-comp : (n m : ℕ) → (x : Poly) → prod-Xn n (prod-Xn m x) ≡ prod-Xn (n +n m) x
  prod-Xn-comp zero m x = refl
  prod-Xn-comp (suc n) m x = cong (λ X → 0r ∷ X) (prod-Xn-comp n m x)

  prod-Xn-∷ : (n : ℕ) → (r : R) → (x : Poly) → (prod-Xn n (r ∷ [])) Poly+ (0r ∷ prod-Xn n x) ≡ prod-Xn n (r ∷ x)
  prod-Xn-∷ zero r x = cong₂ _∷_ (+Rid r) (Poly+Lid x)
  prod-Xn-∷ (suc n) r x = cong₂ _∷_ (+Lid 0r) (prod-Xn-∷ n r x)

  prod-Xn-prod-0 : (m : ℕ) → (x y : Poly) → x Poly* (prod-Xn m y) ≡ prod-Xn m (x Poly* y)
  prod-Xn-prod-0 zero x y = refl
  prod-Xn-prod-0 (suc m) x y = ((x Poly* (0r ∷ prod-Xn m y)))
                                   ≡⟨ Poly*Commutative x (prod-Xn (suc m) y) ⟩
                               ((0r PolyConst* x) Poly+ (0r ∷ (prod-Xn m y Poly* x)))
                                  ≡⟨ cong (λ X → X Poly+ (0r ∷ ((prod-Xn m y) Poly* x))) ((0rLeftAnnihilatesPoly x) ∙ drop0) ⟩
                               ((0r ∷ (prod-Xn m y Poly* x)))
                                  ≡⟨ cong (λ X → 0r ∷ X) (Poly*Commutative (prod-Xn m y) x) ⟩
                               (0r ∷ (x Poly* prod-Xn m y))
                                  ≡⟨ cong (λ X → 0r ∷ X) (prod-Xn-prod-0 m x y) ⟩
                               (0r ∷ prod-Xn m (x Poly* y))  ∎

  prod-Xn-prod : (n m : ℕ) → (x y : Poly) → (prod-Xn n x) Poly* (prod-Xn m y) ≡ prod-Xn (n +n m) (x Poly* y)
  prod-Xn-prod zero m x y = prod-Xn-prod-0 m x y
  prod-Xn-prod (suc n) m x y = cong₂ _Poly+_ ((0rLeftAnnihilatesPoly (prod-Xn m y)) ∙ drop0) (cong (λ X → 0r ∷ X) (prod-Xn-prod n m x y))

----------------------------------------------------------------------------------------------
-- An instantiation of Polynomials as a commutative ring can be found in CommRing/Instances --
----------------------------------------------------------------------------------------------


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

open import Data.Bool using (Bool ; true ; false ; not)
open import Data.Empty using (⊥)
open import Data.Product using (_,_ ; proj₁ ; proj₂) renaming (_×_ to _×T_)
open import Level

open import Cats.Category.Base
open import Cats.Category.Constructions.Terminal as Terminal using (HasTerminal)
open import Cats.Functor using (Functor)
open import Cats.Util.Conv

import Cats.Category.Constructions.Iso as Iso
import Cats.Category.Constructions.Unique as Unique

Bool-elim : ∀ {a} {A : Bool → Set a} → A true → A false → (i : Bool) → A i
Bool-elim x y true = x
Bool-elim x y false = y

module Build {lo la l≈} (Cat : Category lo la l≈) where

  private open module Cat = Category Cat
  open Cat.≈-Reasoning
  open Iso.Build Cat
  open Unique.Build Cat
  open Terminal.Build Cat
  open _≅_

  IsProduct : ∀ {li} {I : Set li} (O : I → Obj) P → (∀ i → P ⇒ O i)
    → Set (lo ⊔ la ⊔ l≈ ⊔ li)
  IsProduct O P proj
      = ∀ {X} (x : ∀ i → X ⇒ O i) → ∃![ u ] (∀ i → x i ≈ proj i ∘ u)

  -- TODO The types of the equalities in IsBinaryProducts are backwards, since
  -- we want the RHS to be simpler than the LHS. So, projl ∘ u ≈ xl instead
  -- of xl ≈ projl ∘ u.
  IsBinaryProduct : ∀ {A B} P → (P ⇒ A) → (P ⇒ B) → Set (lo ⊔ la ⊔ l≈)
  IsBinaryProduct {A} {B} P projl projr
      = ∀ {X} (xl : X ⇒ A) (xr : X ⇒ B)
        → ∃![ u ] (xl ≈ projl ∘ u ×T xr ≈ projr ∘ u)

  IsBinaryProduct→IsProduct : ∀ {A B P} {pl : P ⇒ A} {pr : P ⇒ B}
    → IsBinaryProduct P pl pr
    → IsProduct (Bool-elim A B) P (Bool-elim pl pr)
  IsBinaryProduct→IsProduct isBinProd x = record
      { arr = f ⃗
      ; prop = Bool-elim (proj₁ (∃!′.prop f)) (proj₂ (∃!′.prop f))
      ; unique = λ eq → ∃!′.unique f (eq true , eq false)
      }
    where
      f = isBinProd (x true) (x false)

  record Product {li} {I : Set li} (O : I → Obj) : Set (lo ⊔ la ⊔ l≈ ⊔ li) where
    field
      prod : Obj
      proj : ∀ i → prod ⇒ O i
      isProduct : IsProduct O prod proj

  open Product using (proj ; isProduct)

  instance
    HasObj-Product : ∀ {li} {I : Set li} {O : I → Obj}
      → HasObj (Product O) lo la l≈
    HasObj-Product = record { Cat = Cat ; _ᴼ = Product.prod }

  BinaryProduct : Obj → Obj → Set (lo ⊔ la ⊔ l≈)
  BinaryProduct A B = Product (Bool-elim A B)

  mkBinaryProduct : ∀ {A B P} (pl : P ⇒ A) (pr : P ⇒ B)
    → IsBinaryProduct P pl pr
    → BinaryProduct A B
  mkBinaryProduct {P = P} pl pr isBinProd = record
      { isProduct = IsBinaryProduct→IsProduct isBinProd }

  nullaryProduct-Terminal : (P : Product {I = ⊥} (λ())) → IsTerminal (P ᴼ)
  nullaryProduct-Terminal P X with isProduct P {X = X} λ()
  ... | ∃!-intro arr _ unique = ∃!-intro arr _ (λ _ → unique λ())

  module _ {li} {I : Set li} {O : I → Obj} (P : Product O) where

    factorizer : ∀ {X} → (∀ i → X ⇒ O i) → X ⇒ P ᴼ
    factorizer proj = isProduct P proj ⃗

    factorizer-unique : ∀ {X} (fact : X ⇒ P ᴼ)
      → {x : ∀ i → X ⇒ O i}
      → (∀ i → x i ≈ proj P i ∘ fact)
      → factorizer x ≈ fact
    factorizer-unique fact {x} eq = ∃!′.unique (isProduct P x) eq

    factorizer-proj : ∀ {X} {x : ∀ i → X ⇒ O i} {i}
      → proj P i ∘ factorizer x ≈ x i
    factorizer-proj {x = x} {i} = ≈.sym (∃!′.prop (isProduct P x) i)

    factorizer-resp : ∀ {X} {x y : ∀ i → X ⇒ O i}
      → (∀ i → x i ≈ y i)
      → factorizer x ≈ factorizer y
    factorizer-resp {x = x} {y} eq = factorizer-unique (factorizer y)
      λ i → ≈.trans (eq _) (≈.sym factorizer-proj)

    factorizer-∘ : ∀ {X} {x : ∀ i → X ⇒ O i} {Z} {f : Z ⇒ X}
      → factorizer x ∘ f ≈ factorizer (λ i → x i ∘ f)
    factorizer-∘ {x = x} {f = f} = ≈.sym
      (factorizer-unique (factorizer x ∘ f)
        λ _ → ≈.sym (≈.trans unassoc (∘-resp-l factorizer-proj)))

    factorizer-id : factorizer (proj P) ≈ id
    factorizer-id = factorizer-unique id λ i → ≈.sym id-r

  module _ {li} {I : Set li}
    {O : I → Obj}  (P : Product O)
    {O′ : I → Obj} (P′ : Product O′)
    where

    times : (∀ i → O i ⇒ O′ i) → P ᴼ ⇒ P′ ᴼ
    times x = factorizer P′ (λ i → x i ∘ proj P i)

    times-proj : ∀ {x : ∀ i → O i ⇒ O′ i} {i}
      → proj P′ i ∘ times x ≈ x i ∘ proj P i
    times-proj = factorizer-proj P′

    times-resp : {x y : ∀ i → O i ⇒ O′ i}
      → (∀ i → x i ≈ y i)
      → times x ≈ times y
    times-resp {x} {y} eq = factorizer-resp P′ (λ i → ∘-resp-l (eq i))

  times-id : ∀ {li} {I : Set li} {O : I → Obj} (P : Product O)
    → times P P (λ _ → id) ≈ id
  times-id P = factorizer-unique P id λ _ → ≈.trans id-l (≈.sym id-r)

  times-∘ : ∀ {li} {I : Set li}
    → {O O′ O″ : I → Obj}
    → (P : Product O) (P′ : Product O′) (P″ : Product O″)
    → {x : ∀ i → O i ⇒ O′ i} {y : ∀ i → O′ i ⇒ O″ i}
    → times P′ P″ y ∘ times P P′ x ≈ times P P″ (λ i → y i ∘ x i)
  times-∘ P P′ P″ {x} {y} =
    begin
      times P′ P″ y ∘ times P P′ x
    ≈⟨ factorizer-∘ P″ ⟩
      factorizer P″ (λ i → (y i ∘ proj P′ i) ∘ times P P′ x)
    ≈⟨ factorizer-resp P″ (λ i → assoc) ⟩
      factorizer P″ (λ i → y i ∘ proj P′ i ∘ times P P′ x)
    ≈⟨ factorizer-resp P″ (λ i → ∘-resp-r (times-proj P P′)) ⟩
      factorizer P″ (λ i → y i ∘ x i ∘ proj P i)
    ≈⟨ factorizer-resp P″ (λ i → unassoc) ⟩
      times P P″ (λ i → y i ∘ x i)
    ∎

  times-factorizer : ∀ {li} {I : Set li}
    → {O O′ : I → Obj}
    → (P : Product O) (P′ : Product O′)
    → ∀ {X} {x : ∀ i → X ⇒ O i} {y : ∀ i → O i ⇒ O′ i}
    → times P P′ y ∘ factorizer P x ≈ factorizer P′ (λ i → y i ∘ x i)
  times-factorizer P P′
    = ≈.trans (factorizer-∘ P′)
        (factorizer-resp P′ λ i → ≈.trans assoc (∘-resp-r (factorizer-proj P)))

  proj-cancel : ∀ {li} {I : Set li} {O : I → Obj} {P proj}
    → IsProduct O P proj
    → ∀ {X} {f g : X ⇒ P}
    → (∀ i → proj i ∘ f ≈ proj i ∘ g)
    → f ≈ g
  proj-cancel {proj = proj} prod {f = f} {g} eq with prod (λ i → proj i ∘ g)
  ... | ∃!-intro u _ u-uniq
      = begin
          f
        ≈⟨ ≈.sym (u-uniq (λ i → ≈.sym (eq i))) ⟩
          u
        ≈⟨ u-uniq (λ i → ≈.refl) ⟩
          g
        ∎

  Product-resp-≅ : ∀ {li} {I : Set li} {O O′ : I → Obj}
    → (∀ i → O i ≅ O′ i)
    → (P : Product O) (P′ : Product O′)
    → P ᴼ ≅ P′ ᴼ
  Product-resp-≅ O≅O′ P P′ = record
    { forth = factorizer P′ (λ i → O≅O′ i .forth ∘ proj P i)
    ; back = factorizer P (λ i → O≅O′ i .back ∘ proj P′ i)
    ; back-forth = ≈.trans (factorizer-∘ P)
        (factorizer-unique P id λ i →
          ≈.trans assoc (≈.trans (∘-resp-r (factorizer-proj P′))
            (≈.trans unassoc (≈.trans (∘-resp-l (O≅O′ i .back-forth))
              (≈.trans id-l (≈.sym id-r))))))
    ; forth-back = ≈.trans (factorizer-∘ P′)
        (factorizer-unique P′ id λ i →
          ≈.trans assoc (≈.trans (∘-resp-r (factorizer-proj P))
            (≈.trans unassoc (≈.trans (∘-resp-l (O≅O′ i .forth-back))
              (≈.trans id-l (≈.sym id-r))))))
    }

open Build public using
  (IsProduct ; IsBinaryProduct ; Product ; BinaryProduct ; HasObj-Product)

record HasProducts {lo la l≈} li (C : Category lo la l≈)
  : Set (suc li ⊔ lo ⊔ la ⊔ l≈ )
  where
  private module Bld = Build C
  open Category C
  open Iso.Build C

  field
    Π′ : {I : Set li} (O : I → Obj) → Product C O

  module _ {I : Set li} where

    Π : ∀ (O : I → Obj) → Obj
    Π O = Product.prod (Π′ O)

    syntax Π (λ i → O) = Π[ i ] O

    proj : ∀ {O : I → Obj} i → Π O ⇒ O i
    proj {O} = Bld.Product.proj (Π′ O)

    factorizer : ∀ {O : I → Obj} {X} → (∀ i → X ⇒ O i) → X ⇒ Π O
    factorizer {O} = Bld.factorizer (Π′ O)

    times : ∀ {O O′ : I → Obj} → (∀ i → O i ⇒ O′ i) → Π O ⇒ Π O′
    times {O} {O′} = Bld.times (Π′ O) (Π′ O′)

    factorizer-proj : ∀ {O : I → Obj} {X} {x : ∀ i → X ⇒ O i} {i}
      → proj i ∘ factorizer x ≈ x i
    factorizer-proj {O} = Bld.factorizer-proj (Π′ O)

    factorizer-resp : ∀ {O : I → Obj} {X} {x y : ∀ i → X ⇒ O i}
      → (∀ i → x i ≈ y i)
      → factorizer x ≈ factorizer y
    factorizer-resp {O} = Bld.factorizer-resp (Π′ O)

    factorizer-unique : ∀ {O : I → Obj} {X} {x : ∀ i → X ⇒ O i} {u}
      → (∀ i → x i ≈ proj i ∘ u)
      → factorizer x ≈ u
    factorizer-unique {O} eq = Bld.factorizer-unique (Π′ O) _ eq

    factorizer-∘ : ∀ {O : I → Obj} {X} {x : ∀ i → X ⇒ O i} {Z} {f : Z ⇒ X}
      → factorizer x ∘ f ≈ factorizer (λ i → x i ∘ f)
    factorizer-∘ {O} = Bld.factorizer-∘ (Π′ O)

    factorizer-id : ∀ {O} → factorizer {O} proj ≈ id
    factorizer-id {O} = Bld.factorizer-id (Π′ O)

    times-proj : ∀ {O O′ : I → Obj} {x : ∀ i → O i ⇒ O′ i} {i}
      → proj i ∘ times x ≈ x i ∘ proj i
    times-proj {O} {O′} = Bld.times-proj (Π′ O) (Π′ O′)

    times-resp : ∀ {O O′ : I → Obj} {x y : ∀ i → O i ⇒ O′ i}
      → (∀ i → x i ≈ y i)
      → times x ≈ times y
    times-resp {O} {O′} = Bld.times-resp (Π′ O) (Π′ O′)

    times-id : ∀ {O : I → Obj} → times {O} (λ _ → id) ≈ id
    times-id {O} = Bld.times-id (Π′ O)

    times-∘ : ∀ {O O′ O″ : I → Obj} {x : ∀ i → O i ⇒ O′ i} {y : ∀ i → O′ i ⇒ O″ i}
      → times y ∘ times x ≈ times (λ i → y i ∘ x i)
    times-∘ {O} {O′} {O″} = Bld.times-∘ (Π′ O) (Π′ O′) (Π′ O″)

    times-factorizer : ∀ {O O′ : I → Obj} {X}
      → {x : ∀ i → X ⇒ O i} {y : ∀ i → O i ⇒ O′ i}
      → times y ∘ factorizer x ≈ factorizer (λ i → y i ∘ x i)
    times-factorizer {O} {O′} = Bld.times-factorizer (Π′ O) (Π′ O′)

    Π-resp-≅ : ∀ {O O′ : I → Obj}
      → (∀ i → O i ≅ O′ i)
      → Π O ≅ Π O′
    Π-resp-≅ {O} {O′} O≅O′ = Bld.Product-resp-≅ O≅O′ (Π′ O) (Π′ O′)

HasProducts→HasTerminal : ∀ {lo la l≈} {C : Category lo la l≈}
  → HasProducts zero C
  → HasTerminal C
HasProducts→HasTerminal {C = C} record { Π′ = Π }
    = let P = Π {I = ⊥} λ() in
      record
        { ⊤ = Product.prod P
        ; isTerminal = Build.nullaryProduct-Terminal C P
        }

record HasBinaryProducts {lo la l≈} (C : Category lo la l≈)
  : Set (lo ⊔ la ⊔ l≈)
  where
  private module Bld = Build C
  open Category C
  open Iso.Build C
  open ≈-Reasoning

  infixr 2 _×_ _×′_ ⟨_×_⟩ ⟨_,_⟩

  field
    _×′_ : ∀ A B → BinaryProduct C A B

  _×_ : Obj → Obj → Obj
  A × B = (A ×′ B) ᴼ

  projl : ∀ {A B} → A × B ⇒ A
  projl {A} {B} = Product.proj (A ×′ B) true

  projr : ∀ {A B} → A × B ⇒ B
  projr {A} {B} = Product.proj (A ×′ B) false

  ⟨_,_⟩ : ∀ {A B Z} → Z ⇒ A → Z ⇒ B → Z ⇒ A × B
  ⟨_,_⟩ {A} {B} f g
      = Bld.factorizer (A ×′ B) (Bool-elim f g)

  ⟨_×_⟩ : ∀ {A B A′ B′} → A ⇒ A′ → B ⇒ B′ → A × B ⇒ A′ × B′
  ⟨_×_⟩ {A} {B} {A′} {B′} f g
      = Bld.times (A ×′ B) (A′ ×′ B′) (Bool-elim f g)

  first : ∀ {A A′ B} → A ⇒ A′ → A × B ⇒ A′ × B
  first f = ⟨ f × id ⟩

  second : ∀ {A B B′} → B ⇒ B′ → A × B ⇒ A × B′
  second f = ⟨ id × f ⟩

  swap : ∀ {A B} → A × B ⇒ B × A
  swap = ⟨ projr , projl ⟩

  ⟨,⟩-resp : ∀ {A B Z} {f f′ : Z ⇒ A} {g g′ : Z ⇒ B}
    → f ≈ f′
    → g ≈ g′
    → ⟨ f , g ⟩ ≈ ⟨ f′ , g′ ⟩
  ⟨,⟩-resp {A} {B} f≈f′ g≈g′
      = Bld.factorizer-resp (A ×′ B) (Bool-elim f≈f′ g≈g′)

  ⟨,⟩-projl : ∀ {A B Z} {f : Z ⇒ A} {g : Z ⇒ B} → projl ∘ ⟨ f , g ⟩ ≈ f
  ⟨,⟩-projl {A} {B} = Bld.factorizer-proj (A ×′ B)

  ⟨,⟩-projr : ∀ {A B Z} {f : Z ⇒ A} {g : Z ⇒ B} → projr ∘ ⟨ f , g ⟩ ≈ g
  ⟨,⟩-projr {A} {B} = Bld.factorizer-proj (A ×′ B)

  ⟨,⟩-unique : ∀ {A B Z} {f : Z ⇒ A} {g : Z ⇒ B} {u}
    → f ≈ projl ∘ u
    → g ≈ projr ∘ u
    → ⟨ f , g ⟩ ≈ u
  ⟨,⟩-unique {A} {B} eql eqr
    = Bld.factorizer-unique (A ×′ B) _ (Bool-elim eql eqr)

  ⟨,⟩-∘ : ∀ {A B Y Z} {f : Y ⇒ Z} {g : Z ⇒ A} {h : Z ⇒ B}
    → ⟨ g , h ⟩ ∘ f ≈ ⟨ g ∘ f , h ∘ f ⟩
  ⟨,⟩-∘ {A} {B} {Y} {Z} {f} {g} {h}
      = begin
          ⟨ g , h ⟩ ∘ f
        ≈⟨ Bld.factorizer-∘ (A ×′ B) ⟩
          Bld.factorizer (A ×′ B)
            (λ i → Bool-elim {A = λ i → Z ⇒ Bool-elim A B i} g h i ∘ f)
        ≈⟨ Bld.factorizer-resp (A ×′ B) (Bool-elim ≈.refl ≈.refl) ⟩
          ⟨ g ∘ f , h ∘ f ⟩
        ∎

  ⟨,⟩-id : ∀ {A B} → ⟨ projl , projr ⟩ ≈ id {A × B}
  ⟨,⟩-id {A} {B} = ⟨,⟩-unique (≈.sym id-r) (≈.sym id-r)

  ⟨×⟩-resp : ∀ {A A′ B B′} {f f′ : A ⇒ A′} {g g′ : B ⇒ B′}
    → f ≈ f′
    → g ≈ g′
    → ⟨ f × g ⟩ ≈ ⟨ f′ × g′ ⟩
  ⟨×⟩-resp {A} {A′} {B} {B′} f≈f′ g≈g′
      = Bld.times-resp (A ×′ B) (A′ ×′ B′) (Bool-elim f≈f′ g≈g′)

  ⟨×⟩-projl : ∀ {A A′ B B′} {f : A ⇒ A′} {g : B ⇒ B′}
    → projl ∘ ⟨ f × g ⟩ ≈ f ∘ projl
  ⟨×⟩-projl {A} {A′} {B} {B′} = Bld.times-proj (A ×′ B) (A′ ×′ B′)

  ⟨×⟩-projr : ∀ {A A′ B B′} {f : A ⇒ A′} {g : B ⇒ B′}
    → projr ∘ ⟨ f × g ⟩ ≈ g ∘ projr
  ⟨×⟩-projr {A} {A′} {B} {B′} = Bld.times-proj (A ×′ B) (A′ ×′ B′)

  ⟨×⟩-id : ∀ {A B} → ⟨ id {A} × id {B} ⟩ ≈ id
  ⟨×⟩-id {A} {B} = Bld.factorizer-unique (A ×′ B) id
    (Bool-elim (≈.trans id-l (≈.sym id-r)) (≈.trans id-l (≈.sym id-r)))

  ⟨×⟩-∘ : ∀ {A A′ A″ B B′ B″}
    → {f : A′ ⇒ A″} {f′ : A ⇒ A′} {g : B′ ⇒ B″} {g′ : B ⇒ B′}
    → ⟨ f × g ⟩ ∘ ⟨ f′ × g′ ⟩ ≈ ⟨ f ∘ f′ × g ∘ g′ ⟩
  ⟨×⟩-∘ {A} {A′} {A″} {B} {B′} {B″} {f} {f′} {g} {g′} = ≈.trans
    (Bld.times-∘ (A ×′ B) (A′ ×′ B′) (A″ ×′ B″))
    (Bld.times-resp (A ×′ B) (A″ ×′ B″) (Bool-elim ≈.refl ≈.refl))

  ⟨×⟩-⟨,⟩ : ∀ {A B C B′ C′} {f : A ⇒ B} {g : A ⇒ C} {f′ : B ⇒ B′} {g′ : C ⇒ C′}
    → ⟨ f′ × g′ ⟩ ∘ ⟨ f , g ⟩ ≈ ⟨ f′ ∘ f , g′ ∘ g ⟩
  ⟨×⟩-⟨,⟩ {A} {B} {C} {B′} {C′} = ≈.trans
    (Bld.times-factorizer (B ×′ C) (B′ ×′ C′))
    (Bld.factorizer-resp (B′ ×′ C′) (Bool-elim ≈.refl ≈.refl))

  ×-resp-≅ : ∀ {A A′ B B′}
    → A ≅ A′
    → B ≅ B′
    → (A × B) ≅ (A′ × B′)
  ×-resp-≅ {A} {A′} {B} {B′} A≅A′ B≅B′
    = Bld.Product-resp-≅ (Bool-elim A≅A′ B≅B′) (A ×′ B) (A′ ×′ B′)

-- The following is conceptually trivial, but we have to dig quite deep to
-- avoid level-related nonsense.
HasProducts→HasBinaryProducts : ∀ {lp lo la l≈} {C : Category lo la l≈}
  → HasProducts lp C
  → HasBinaryProducts C
HasProducts→HasBinaryProducts {lp} {C = C} record { Π′ = Π }
    = record { _×′_ = _×_ }
  where
    open Category C
    open Unique.Build C
    open Product using (proj)
    open ∃!′ using (arr ; prop ; unique)

    _×_ : ∀ A B → Build.BinaryProduct C A B
    A × B = record
        { prod = prod′
        ; proj = proj′
        ; isProduct = isProduct′
        }
      where
        O : Lift lp Bool → _
        O (lift true) = A
        O (lift false) = B

        prod′ = Product.prod (Π O)

        proj′ = Bool-elim (proj (Π O) (lift true)) (proj (Π O) (lift false))

        isProduct′ : IsProduct C (Bool-elim A B) prod′ proj′
        isProduct′ {X} x = record
            { arr = arr′ ⃗
            ; prop = Bool-elim (prop arr′ (lift true)) (prop arr′ (lift false))
            ; unique = λ eq → unique arr′
                (λ { (lift true) → eq true ; (lift false) → eq false})
            }
          where
            arr′ = Product.isProduct (Π O)
              λ { (lift true) → x true ; (lift false) → x false}

record HasFiniteProducts {lo la l≈} (Cat : Category lo la l≈)
  : Set (lo ⊔ la ⊔ l≈)
  where

  field
    {{hasTerminal}} : HasTerminal Cat
    {{hasBinaryProducts}} : HasBinaryProducts Cat

  open HasTerminal hasTerminal public
  open HasBinaryProducts hasBinaryProducts public

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

  open Category C
  open Functor

  PreservesBinaryProducts : (F : Functor C D) → Set _
  PreservesBinaryProducts F
    = ∀ {A B A×B} {projl : A×B ⇒ A} {projr : A×B ⇒ B}
    → IsBinaryProduct C A×B projl projr
    → IsBinaryProduct D (fobj F A×B) (fmap F projl) (fmap F projr)

  PreservesProducts : ∀ {i} (I : Set i) (F : Functor C D) → Set _
  PreservesProducts I F
    = ∀ {O : I → Obj} {P} {proj : ∀ i → P ⇒ O i}
    → IsProduct C O P proj
    → IsProduct D (λ i → fobj F (O i)) (fobj F P) (λ i → fmap F (proj i))


{-

Definition of a homogeneous pointed type, and proofs that pi, product, path, and discrete types are homogeneous

Portions of this file adapted from Nicolai Kraus' code here:
  https://bitbucket.org/nicolaikraus/agda/src/e30d70c72c6af8e62b72eefabcc57623dd921f04/trunc-inverse.lagda

-}
{-# OPTIONS --cubical --safe #-}
module Cubical.Foundations.Pointed.Homogeneous where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Equiv
open import Cubical.Foundations.Isomorphism
open import Cubical.Foundations.Univalence
open import Cubical.Foundations.Path
open import Cubical.Data.Prod
open import Cubical.Data.Empty
open import Cubical.Relation.Nullary

open import Cubical.Foundations.Pointed.Base
open import Cubical.Foundations.Pointed.Properties

isHomogeneous : ∀ {ℓ} → Pointed ℓ → Type (ℓ-suc ℓ)
isHomogeneous {ℓ} (A , x) = ∀ y → Path (Pointed ℓ) (A , x) (A , y)

isHomogeneousPi : ∀ {ℓ ℓ'} {A : Type ℓ} {B∙ : A → Pointed ℓ'}
                 → (∀ a → isHomogeneous (B∙ a)) → isHomogeneous (Π∙ A B∙)
isHomogeneousPi h f i = (∀ a → typ (h a (f a) i)) , (λ a → pt (h a (f a) i))

isHomogeneousProd : ∀ {ℓ ℓ'} {A∙ : Pointed ℓ} {B∙ : Pointed ℓ'}
                   → isHomogeneous A∙ → isHomogeneous B∙ → isHomogeneous (A∙ ×∙ B∙)
isHomogeneousProd hA hB (a , b) i = (typ (hA a i)) × (typ (hB b i)) , (pt (hA a i) , pt (hB b i))

isHomogeneousPath : ∀ {ℓ} (A : Type ℓ) {x y : A} (p : x ≡ y) → isHomogeneous ((x ≡ y) , p)
isHomogeneousPath A {x} {y} p q i
  = ua eqv i , ua-gluePath eqv (compPathr-cancel p q) i
  where eqv : (x ≡ y) ≃ (x ≡ y)
        eqv = ((q ∙ sym p) ∙_) , compPathl-isEquiv (q ∙ sym p)

module HomogeneousDiscrete {ℓ} {A∙ : Pointed ℓ} (dA : Discrete (typ A∙)) (y : typ A∙) where

  -- switches pt A∙ with y
  switch : typ A∙ → typ A∙
  switch x with dA x (pt A∙)
  ...         | yes _ = y
  ...         | no _ with dA x y
  ...                | yes _  = pt A∙
  ...                | no  _  = x

  switch-ptA∙ : switch (pt A∙) ≡ y
  switch-ptA∙ with dA (pt A∙) (pt A∙)
  ...         | yes _ = refl
  ...         | no ¬p = ⊥-elim (¬p refl)

  switch-idp : ∀ x → switch (switch x) ≡ x
  switch-idp x with dA x (pt A∙)
  switch-idp x | yes p with dA y (pt A∙)
  switch-idp x | yes p | yes q = q ∙ sym p
  switch-idp x | yes p | no  _ with dA y y
  switch-idp x | yes p | no  _ | yes _ = sym p
  switch-idp x | yes p | no  _ | no ¬p = ⊥-elim (¬p refl)
  switch-idp x | no ¬p with dA x y
  switch-idp x | no ¬p | yes p with dA y (pt A∙)
  switch-idp x | no ¬p | yes p | yes q = ⊥-elim (¬p (p ∙ q))
  switch-idp x | no ¬p | yes p | no  _ with dA (pt A∙) (pt A∙)
  switch-idp x | no ¬p | yes p | no  _ | yes _ = sym p
  switch-idp x | no ¬p | yes p | no  _ | no ¬q = ⊥-elim (¬q refl)
  switch-idp x | no ¬p | no ¬q with dA x (pt A∙)
  switch-idp x | no ¬p | no ¬q | yes p = ⊥-elim (¬p p)
  switch-idp x | no ¬p | no ¬q | no  _ with dA x y
  switch-idp x | no ¬p | no ¬q | no  _ | yes q = ⊥-elim (¬q q)
  switch-idp x | no ¬p | no ¬q | no  _ | no  _ = refl

  switch-eqv : typ A∙ ≃ typ A∙
  switch-eqv = isoToEquiv (iso switch switch switch-idp switch-idp)

isHomogeneousDiscrete : ∀ {ℓ} {A∙ : Pointed ℓ} (dA : Discrete (typ A∙)) → isHomogeneous A∙
isHomogeneousDiscrete {ℓ} {A∙} dA y i
  = ua switch-eqv i , ua-gluePath switch-eqv switch-ptA∙ i
  where open HomogeneousDiscrete {ℓ} {A∙} dA y


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

module Relation.Binary where

open import Level
open import Relation.Nullary
open import Path as ≡ hiding (sym; refl)
open import Data.Sum
open import Function
open import Data.Bool as Bool using (Bool; true; false; T; bool)
open import Relation.Nullary.Decidable
open import Relation.Nullary.Discrete

module _ (_~_ : A → A → Type b) where
  Reflexive : Type _
  Reflexive = ∀ {x} → x ~ x

  Transitive : Type _
  Transitive = ∀ {x y z} → x ~ y → y ~ z → x ~ z

  Symmetric : Type _
  Symmetric = ∀ {x y} → x ~ y → y ~ x

  Decidable : Type _
  Decidable = ∀ x y → Dec (x ~ y)

  Antisymmetric : Type _
  Antisymmetric = ∀ {x y} → x ~ y → y ~ x → x ≡ y

  Total : Type _
  Total = ∀ x y → (x ~ y) ⊎ (y ~ x)

data Tri {a r₁ r₂ r₃} {A : Type a} (R₁ : A → A → Type r₁) (R₂ : A → A → Type r₂) (R₃ : A → A → Type r₃) (x y : A) : Type (a ℓ⊔ r₁ ℓ⊔ r₂ ℓ⊔ r₃) where
  lt : (x<y : R₁ x y) → Tri R₁ R₂ R₃ x y
  eq : (x≡y : R₂ x y) → Tri R₁ R₂ R₃ x y
  gt : (x>y : R₃ x y) → Tri R₁ R₂ R₃ x y

record PartialOrder {ℓ₁} (𝑆 : Type ℓ₁) ℓ₂ : Type (ℓ₁ ℓ⊔ ℓsuc ℓ₂) where
  infix 4 _≤_
  field
    _≤_ : 𝑆 → 𝑆 → Type ℓ₂
    refl : Reflexive _≤_
    antisym : Antisymmetric _≤_
    trans : Transitive _≤_

record TotalOrder {ℓ₁} (𝑆 : Type ℓ₁) ℓ₂ : Type (ℓ₁ ℓ⊔ ℓsuc ℓ₂) where
  field
    partialOrder : PartialOrder 𝑆 ℓ₂
  open PartialOrder partialOrder public

  infix 4 _≤ᵇ_ _≤?_
  field
    _≤?_ : Total _≤_

  _≤ᵇ_ : 𝑆 → 𝑆 → Bool
  x ≤ᵇ y = is-l (x ≤? y)

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

  total⇒discrete : Discrete 𝑆
  total⇒discrete x y with x ≤? y | inspect (x ≤?_) y | y ≤? x | inspect (y ≤?_) x
  total⇒discrete x y | inl x₁ | 〖 xy 〗 | inl x₂ | 〖 yx 〗 = yes (antisym x₁ x₂)
  total⇒discrete x y | inr x₁ | 〖 xy 〗 | inr x₂ | 〖 yx 〗 = yes (antisym x₂ x₁)
  total⇒discrete x y | inl x₁ | 〖 xy 〗 | inr x₂ | 〖 yx 〗 = no (λ p → subst (bool ⊥ ⊤) (cong is-l (≡.sym xy) ; cong₂ _≤ᵇ_ p (≡.sym p) ; cong is-l yx) tt)
  total⇒discrete x y | inr x₁ | 〖 xy 〗 | inl x₂ | 〖 yx 〗 = no (λ p → subst (bool ⊤ ⊥) (cong is-l (≡.sym xy) ; cong₂ _≤ᵇ_ p (≡.sym p) ; cong is-l yx) tt)

  infix 4 _<_
  _<_ : 𝑆 → 𝑆 → Type (ℓ₁ ℓ⊔ ℓ₂)
  x < y = (x ≢ y) × (x ≤ y)

  Ordering : 𝑆 → 𝑆 → Type (ℓ₁ ℓ⊔ ℓ₂)
  Ordering = Tri _<_ _≡_ (flip _<_)

  compare : ∀ x y → Ordering x y
  compare x y with x ≤? y | inspect (x ≤?_) y | y ≤? x | inspect (y ≤?_) x
  compare x y | inl x₁ | 〖 xy 〗 | inl x₂ | 〖 yx 〗 = eq (antisym x₁ x₂)
  compare x y | inr x₁ | 〖 xy 〗 | inr x₂ | 〖 yx 〗 = eq (antisym x₂ x₁)
  compare x y | inl x₁ | 〖 xy 〗 | inr x₂ | 〖 yx 〗 = lt ((λ p → subst (bool ⊥ ⊤) (cong is-l (≡.sym xy) ; cong₂ _≤ᵇ_ p (≡.sym p) ; cong is-l yx) tt) , x₁)
  compare x y | inr x₁ | 〖 xy 〗 | inl x₂ | 〖 yx 〗 = gt ((λ p → subst (bool ⊤ ⊥) (cong is-l (≡.sym xy) ; cong₂ _≤ᵇ_ (≡.sym p) p ; cong is-l yx) tt) , x₁)

record Equivalence {ℓ₁} (𝑆 : Type ℓ₁) ℓ₂ : Type (ℓ₁ ℓ⊔ ℓsuc ℓ₂) where
  infix 4 _≋_
  field
    _≋_ : 𝑆 → 𝑆 → Type ℓ₂
    sym   : ∀ {x y} → x ≋ y → y ≋ x
    refl  : ∀ {x} → x ≋ x
    trans : ∀ {x y z} → x ≋ y → y ≋ z → x ≋ z

≡-equivalence : ∀ {a} {A : Set a} → Equivalence A a
≡-equivalence = record
  { _≋_ = _≡_
  ; sym = ≡.sym
  ; refl = ≡.refl
  ; trans = _;_
  }


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

open import lib.Basics
open import lib.types.Coproduct
open import lib.types.Fin
open import lib.types.Pi
open import lib.types.Truncation

module lib.types.Choice where

unchoose : ∀ {i j} {n : ℕ₋₂} {A : Type i} {B : A → Type j}
  → Trunc n (Π A B) → Π A (Trunc n ∘ B)
unchoose = Trunc-rec (λ f → [_] ∘ f)

has-choice : ∀ {i} (n : ℕ₋₂) (A : Type i) j → Type (lmax i (lsucc j))
has-choice {i} n A j = (B : A → Type j) → is-equiv (unchoose {n = n} {A} {B})

Empty-has-choice : ∀ {n} {j} → has-choice n Empty j
Empty-has-choice {n} B = is-eq to from to-from from-to where
  to = unchoose {n = n} {Empty} {B}

  from : Π Empty (Trunc n ∘ B) → Trunc n (Π Empty B)
  from _ = [ (λ{()}) ]

  abstract
    to-from : ∀ f → to (from f) == f
    to-from _ = λ= λ{()}

    from-to : ∀ f → from (to f) == f
    from-to = Trunc-elim (λ _ → ap [_] (λ= λ{()}))

Unit-has-choice : ∀ {n} {j} → has-choice n Unit j
Unit-has-choice {n} B = is-eq to from to-from from-to where
  to = unchoose {n = n} {Unit} {B}

  Unit-elim' : B unit → Π Unit B
  Unit-elim' u unit = u

  from : Π Unit (Trunc n ∘ B) → Trunc n (Π Unit B)
  from f = Trunc-fmap Unit-elim' (f unit)

  abstract
    to-from : ∀ f → to (from f) == f
    to-from f = λ= λ{unit →
      Trunc-elim
        {P = λ f-unit → to (Trunc-fmap Unit-elim' f-unit) unit == f-unit}
        (λ _ → idp)
        (f unit)}

    from-to : ∀ f → from (to f) == f
    from-to = Trunc-elim (λ f → ap [_] (λ= λ{unit → idp}))

Coprod-has-choice : ∀ {i j} {n} {A : Type i} {B : Type j} {k}
  → has-choice n A k → has-choice n B k
  → has-choice n (A ⊔ B) k
Coprod-has-choice {n = n} {A} {B} A-hc B-hc C = is-eq to from to-from from-to where
  A-unchoose = unchoose {n = n} {A} {C ∘ inl}
  B-unchoose = unchoose {n = n} {B} {C ∘ inr}
  module A-unchoose = is-equiv (A-hc (C ∘ inl))
  module B-unchoose = is-equiv (B-hc (C ∘ inr))

  to = unchoose {n = n} {A ⊔ B} {C}

  from : Π (A ⊔ B) (Trunc n ∘ C) → Trunc n (Π (A ⊔ B) C)
  from f = Trunc-fmap2 Coprod-elim (A-unchoose.g (f ∘ inl)) (B-unchoose.g (f ∘ inr))

  abstract
    to-from-inl' : ∀ f a → to (from f) (inl a) == A-unchoose (A-unchoose.g (f ∘ inl)) a
    to-from-inl' f a = Trunc-elim
      {P = λ f-inl → to (Trunc-fmap2 Coprod-elim f-inl (B-unchoose.g (f ∘ inr))) (inl a) == A-unchoose f-inl a}
      (λ f-inl → Trunc-elim
        {P = λ f-inr → to (Trunc-fmap2 Coprod-elim [ f-inl ] f-inr) (inl a) == [ f-inl a ]}
        (λ f-inr → idp)
        (B-unchoose.g (f ∘ inr)))
      (A-unchoose.g (f ∘ inl))

    to-from-inl : ∀ f a → to (from f) (inl a) == f (inl a)
    to-from-inl f a = to-from-inl' f a ∙ app= (A-unchoose.f-g (f ∘ inl)) a

    to-from-inr' : ∀ f b → to (from f) (inr b) == B-unchoose (B-unchoose.g (f ∘ inr)) b
    to-from-inr' f b = Trunc-elim
      {P = λ f-inr → to (Trunc-fmap2 Coprod-elim (A-unchoose.g (f ∘ inl)) f-inr) (inr b) == B-unchoose f-inr b}
      (λ f-inr → Trunc-elim
        {P = λ f-inl → to (Trunc-fmap2 Coprod-elim f-inl [ f-inr ]) (inr b) == [ f-inr b ]}
        (λ f-inl → idp)
        (A-unchoose.g (f ∘ inl)))
      (B-unchoose.g (f ∘ inr))

    to-from-inr : ∀ f b → to (from f) (inr b) == f (inr b)
    to-from-inr f b = to-from-inr' f b ∙ app= (B-unchoose.f-g (f ∘ inr)) b

    to-from : ∀ f → to (from f) == f
    to-from f = λ= λ{(inl a) → to-from-inl f a; (inr b) → to-from-inr f b}

    from-to : ∀ f → from (to f) == f
    from-to = Trunc-elim
      (λ f →
        Trunc-fmap2 Coprod-elim (A-unchoose.g (λ a → [ f (inl a)])) (B-unchoose.g (λ b → [ f (inr b)]))
          =⟨ ap2 (Trunc-fmap2 Coprod-elim) (A-unchoose.g-f [ f ∘ inl ]) (B-unchoose.g-f [ f ∘ inr ]) ⟩
        [ Coprod-elim (f ∘ inl) (f ∘ inr) ]
          =⟨ ap [_] $ λ= (λ{(inl _) → idp; (inr _) → idp}) ⟩
        [ f ]
          =∎)

equiv-preserves-choice : ∀ {i j} {n} {A : Type i} {B : Type j} (e : A ≃ B) {k}
  → has-choice n A k → has-choice n B k
equiv-preserves-choice {n = n} {A} {B} (f , f-ise) A-hc C = is-eq to from to-from from-to where
  module f = is-equiv f-ise

  A-unchoose = unchoose {n = n} {A} {C ∘ f}
  module A-unchoose = is-equiv (A-hc (C ∘ f))

  to = unchoose {n = n} {B} {C}

  from' : Trunc n (Π A (C ∘ f)) → Trunc n (Π B C)
  from' = Trunc-fmap (λ g' b → transport C (f.f-g b) (g' (f.g b)))

  from : Π B (Trunc n ∘ C) → Trunc n (Π B C)
  from g = from' (A-unchoose.g (g ∘ f))

  abstract
    to-from''' : ∀ (g-f' : Π A (C ∘ f)) {a a'} (path : f.g (f a) == a')
      → transport C (ap f path) (g-f' (f.g (f a))) == g-f' a'
    to-from''' g-f' idp = idp

    to-from'' : ∀ (g-f' : Π A (C ∘ f)) a
      → transport C (f.f-g (f a)) (g-f' (f.g (f a))) == g-f' a
    to-from'' g-f' a =
      transport C (f.f-g (f a)) (g-f' (f.g (f a)))
        =⟨ ! $ ap (λ p → transport C p (g-f' (f.g (f a)))) (f.adj a) ⟩
      transport C (ap f (f.g-f a)) (g-f' (f.g (f a)))
        =⟨ to-from''' g-f' (f.g-f a) ⟩
      g-f' a
        =∎

    to-from' : ∀ g a → to (from g) (f a) == A-unchoose (A-unchoose.g (g ∘ f)) a
    to-from' g a =
      Trunc-elim
        {P = λ g-f → to (from' g-f) (f a) == A-unchoose g-f a}
        (λ g-f' → ap [_] $ to-from'' g-f' a)
        (A-unchoose.g (g ∘ f))

    to-from : ∀ g → to (from g) == g
    to-from g = λ= λ b → transport
      (λ b → to (from g) b == g b)
      (f.f-g b)
      ( to (from g) (f (f.g b))
          =⟨ to-from' g (f.g b) ⟩
        A-unchoose (A-unchoose.g (g ∘ f)) (f.g b)
          =⟨ app= (A-unchoose.f-g (g ∘ f)) (f.g b) ⟩
        g (f (f.g b))
          =∎)

    from-to' : ∀ g {b b'} (path : f (f.g b) == b')
      → transport C path (g (f (f.g b))) == g b'
    from-to' g idp = idp

    from-to : ∀ g → from (to g) == g
    from-to = Trunc-elim
      {P = λ g → from (to g) == g}
      (λ g →
        from' (A-unchoose.g (λ a → [ g (f a) ]))
          =⟨ ap from' (A-unchoose.g-f [ (g ∘ f) ]) ⟩
        from' [ (g ∘ f) ]
          =⟨ ap [_] $ λ= (λ b → from-to' g (f.f-g b)) ⟩
        [ g ]
          =∎)

Fin-has-choice : ∀ (n : ℕ₋₂) {m} l → has-choice n (Fin m) l
Fin-has-choice _ {O} _ = equiv-preserves-choice
  (Fin-equiv-Empty ⁻¹) Empty-has-choice
Fin-has-choice n {S m} l = equiv-preserves-choice
  (Fin-equiv-Coprod ⁻¹) (Coprod-has-choice (Fin-has-choice n l) Unit-has-choice)


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

module Algebra.Construct.Dyck where

open import Prelude
open import Algebra
open import Data.Nat using (_+_)
import Data.Nat.Properties as ℕ
open import Agda.Builtin.Nat using (_-_)

record Bal : Type₀ where
  constructor _⟩⟨_
  field
    left  : ℕ
    right : ℕ
open Bal public

infix 4.5 _⟩-⟨_ _⟩⟨_ _+⟨_⟩+_ _+⟨⟩+_

_⟩-⟨_ : ℕ → ℕ → Bal
zero  ⟩-⟨ m     = zero  ⟩⟨ m
suc n ⟩-⟨ zero  = suc n ⟩⟨ zero
suc n ⟩-⟨ suc m = n ⟩-⟨ m

_+⟨_⟩+_ : ℕ → Bal → ℕ → Bal
x +⟨ z ⟩+ y = right z + x ⟩⟨ left z  + y

_+⟨⟩+_ : Bal → Bal → Bal
x +⟨⟩+ y = left x +⟨ right x ⟩-⟨ left y ⟩+ right y

mempty : Bal
mempty = 0 ⟩⟨ 0

diff-zeroʳ : ∀ n → n ⟩-⟨ zero ≡ n ⟩⟨ zero
diff-zeroʳ zero    = refl
diff-zeroʳ (suc n) = refl

invert : Bal → Bal
invert (x ⟩⟨ y) = y ⟩⟨ x

diff-inv : ∀ x y → invert (x ⟩-⟨ y) ≡ y ⟩-⟨ x
diff-inv zero  zero = refl
diff-inv zero (suc y) = refl
diff-inv (suc x) zero = refl
diff-inv (suc x) (suc y) = diff-inv x y

open import Path.Reasoning

add-inv : ∀ x y → (x +⟨⟩+ y) ≡ invert (invert y +⟨⟩+ invert x)
add-inv (xl ⟩⟨ xr) (yl ⟩⟨ yr) = cong₂ _⟩⟨_ (cong (_+ xl) (cong left (diff-inv xr yl))) (cong (_+ yr) (cong right (diff-inv xr yl)))

0+⟨⟩ : ∀ x → mempty +⟨⟩+ x ≡ x
0+⟨⟩ (zero   ⟩⟨ xr) i = zero ⟩⟨ xr
0+⟨⟩ (suc xl ⟩⟨ xr) i = suc (ℕ.+-idʳ xl i) ⟩⟨ xr

⟨⟩+0 : ∀ x → x +⟨⟩+ mempty ≡ x
⟨⟩+0 (xl ⟩⟨ zero  ) i = xl ⟩⟨ zero
⟨⟩+0 (xl ⟩⟨ suc xr) i = xl ⟩⟨ suc (ℕ.+-idʳ xr i)

diff-sub : ∀ x y → left (x ⟩-⟨ y) ≡ x - y
diff-sub zero zero = refl
diff-sub zero (suc y) = refl
diff-sub (suc x) zero = refl
diff-sub (suc x) (suc y) = diff-sub x y

diff-subʳ : ∀ x y → right (x ⟩-⟨ y) ≡ y - x
diff-subʳ zero zero = refl
diff-subʳ zero (suc y) = refl
diff-subʳ (suc x) zero = refl
diff-subʳ (suc x) (suc y) = diff-subʳ x y

minus-plus : ∀ x y z → x - y - z ≡ x - (y + z)
minus-plus x zero z = refl
minus-plus zero (suc y) zero = refl
minus-plus zero (suc y) (suc z) = refl
minus-plus (suc x) (suc y) z = minus-plus x y z

lhs″ : ∀ zl xr yl yr → (zl - ((xr - yl) + yr)) + (yl - xr) ≡ ((zl - yr) + yl) - xr
lhs″ zl zero zero yr = refl
lhs″ zl zero (suc yl) yr = refl
lhs″ zl (suc xr) zero yr = ℕ.+-idʳ _ ; (cong (zl -_) (ℕ.+-comm (suc xr) yr) ; sym (minus-plus zl yr (suc xr))) ; sym (cong (_- suc xr) (ℕ.+-idʳ (zl - yr)))
lhs″ zero (suc xr) (suc yl) zero = lhs″ zero xr yl zero
lhs″ zero (suc xr) (suc yl) (suc yr) = lhs″ zero xr yl (suc yr)
lhs″ (suc zl) (suc xr) (suc yl) zero = lhs″ (suc zl) xr yl zero ; cong (_- xr) (sym (ℕ.+-suc zl yl))
lhs″ (suc zl) (suc xr) (suc yl) (suc yr) = cong (_+ (yl - xr)) (cong (suc zl -_) (ℕ.+-suc (xr - yl) yr)) ; lhs″ zl (suc xr) (suc yl) yr

rhs‴ : ∀ x y z → x + y - z ≡ x - (z - y) + (y - z)
rhs‴ zero zero zero = refl
rhs‴ zero zero (suc z) = refl
rhs‴ zero (suc y) zero = refl
rhs‴ (suc x) zero zero = refl
rhs‴ (suc x) (suc y) zero = refl
rhs‴ zero (suc y) (suc z) = rhs‴ zero y z
rhs‴ (suc x) zero (suc z) = cong (_- z) (ℕ.+-idʳ x) ; sym (ℕ.+-idʳ (x - z))
rhs‴ (suc x) (suc y) (suc z) = cong (_- z) (ℕ.+-suc x y) ; rhs‴ (suc x) y z

rhs″ : ∀ xr yl yr zl → ((xr - yl) + yr) - zl ≡ xr - (zl - yr + yl) + (yr - zl)
rhs″ (suc xr) (suc yl) yr zl = rhs″ xr yl yr zl ; cong (λ zy → suc xr - zy + (yr - zl)) (sym (ℕ.+-suc (zl - yr) yl))
rhs″ zero zero zero zero = refl
rhs″ zero zero zero (suc zl) = refl
rhs″ zero zero (suc yr) zero = refl
rhs″ zero zero (suc yr) (suc zl) = rhs″ zero zero yr zl
rhs″ zero (suc yl) zero zero = refl
rhs″ zero (suc yl) zero (suc zl) = refl
rhs″ zero (suc yl) (suc yr) zero = refl
rhs″ zero (suc yl) (suc yr) (suc zl) = rhs″ zero (suc yl) yr zl
rhs″ (suc xr) zero zero zero = refl
rhs″ (suc xr) zero (suc yr) zero = refl
rhs″ (suc xr) zero zero     (suc zl) = cong (_- zl) (ℕ.+-idʳ xr) ; cong (xr -_) (sym (ℕ.+-idʳ zl)) ; sym (ℕ.+-idʳ (xr - (zl + zero)))
rhs″ (suc xr) zero (suc yr) (suc zl) = cong (_- zl) (ℕ.+-suc xr yr) ;  rhs‴ (suc xr) yr zl ; sym (cong (λ zy → suc xr - zy + (yr - zl)) (ℕ.+-idʳ (zl - yr)))

⟨⟩-assoc : Associative _+⟨⟩+_
⟨⟩-assoc (xl ⟩⟨ xr ) (yl ⟩⟨ yr ) (zl ⟩⟨ zr) = cong₂ _⟩⟨_ lhs rhs
  where

  lhs′ : ∀ xr yl yr zl → right (left (xr ⟩-⟨ yl) + yr ⟩-⟨ zl) + right (xr ⟩-⟨ yl) ≡ right (xr ⟩-⟨ right (yr ⟩-⟨ zl) + yl)
  lhs′ xr yl yr zl =
    right (left (xr ⟩-⟨ yl) + yr ⟩-⟨ zl) + right (xr ⟩-⟨ yl) ≡⟨ cong₂ _+_ (diff-subʳ (left (xr ⟩-⟨ yl) + yr) zl) (diff-subʳ xr yl) ⟩
    (zl - (left (xr ⟩-⟨ yl) + yr)) + (yl - xr) ≡⟨ cong (λ xy → (zl - (xy + yr)) + (yl - xr)) (diff-sub xr yl) ⟩
    (zl - ((xr - yl) + yr)) + (yl - xr) ≡⟨ lhs″ zl xr yl yr ⟩
    ((zl - yr) + yl) - xr ≡˘⟨ cong (λ yz → (yz + yl) - xr) (diff-subʳ yr zl) ⟩
    (right (yr ⟩-⟨ zl) + yl) - xr ≡˘⟨ diff-subʳ xr _ ⟩
    right (xr ⟩-⟨ right (yr ⟩-⟨ zl) + yl) ∎

  lhs : right (left (xr ⟩-⟨ yl) + yr ⟩-⟨ zl) + (right (xr ⟩-⟨ yl) + xl) ≡ right (xr ⟩-⟨ right (yr ⟩-⟨ zl) + yl) + xl
  lhs = sym (ℕ.+-assoc _ (right (xr ⟩-⟨ yl)) xl) ; cong (_+ xl) (lhs′ xr yl yr zl)

  rhs′ : ∀ xr yl yr zl → left (left (xr ⟩-⟨ yl) + yr ⟩-⟨ zl) ≡ left (xr ⟩-⟨ right (yr ⟩-⟨ zl) + yl) + left (yr ⟩-⟨ zl)
  rhs′ xr yl yr zl =
    left (left (xr ⟩-⟨ yl) + yr ⟩-⟨ zl) ≡⟨ diff-sub _ zl ⟩
    left (xr ⟩-⟨ yl) + yr - zl ≡⟨ cong (_- zl) (cong (_+ yr) (diff-sub xr yl)) ⟩
    (xr - yl) + yr - zl ≡⟨ rhs″ xr yl yr zl ⟩
    (xr - ((zl - yr) + yl)) + (yr - zl) ≡˘⟨ cong (λ yz → (xr - (yz + yl)) + (yr - zl)) (diff-subʳ yr zl) ⟩
    (xr - (right (yr ⟩-⟨ zl) + yl)) + (yr - zl) ≡˘⟨ cong₂ _+_ (diff-sub xr _) (diff-sub yr zl) ⟩
    left (xr ⟩-⟨ right (yr ⟩-⟨ zl) + yl) + left (yr ⟩-⟨ zl) ∎

  rhs : left (left (xr ⟩-⟨ yl) + yr ⟩-⟨ zl) + zr ≡ left (xr ⟩-⟨ right (yr ⟩-⟨ zl) + yl) + (left (yr ⟩-⟨ zl) + zr)
  rhs = cong (_+ zr) (rhs′ xr yl yr zl) ; ℕ.+-assoc (left (xr ⟩-⟨ right (yr ⟩-⟨ zl) + yl)) (left (yr ⟩-⟨ zl)) zr

semigroupBal : Semigroup _
semigroupBal .Semigroup.𝑆 = Bal
semigroupBal .Semigroup._∙_ = _+⟨⟩+_
semigroupBal .Semigroup.assoc = ⟨⟩-assoc

monoidBal : Monoid _
Monoid.𝑆 monoidBal = Bal
Monoid._∙_ monoidBal = _+⟨⟩+_
Monoid.ε monoidBal = mempty
Monoid.assoc monoidBal = ⟨⟩-assoc
Monoid.ε∙ monoidBal = 0+⟨⟩
Monoid.∙ε monoidBal = ⟨⟩+0


module UnequalRelevance where

postulate
  A : Set
  f : .A -> A
  g : (A -> A) -> A -> A

-- this should fail because
-- cannot use irrelevant function where relevant is needed
h : A -> A
h = g f  -- error: function types are not equal because one is relevant and the other not


------------------------------------------------------------------------
-- The Agda standard library
--
-- Consequences of a monomorphism between orders
------------------------------------------------------------------------

-- See Data.Nat.Binary.Properties for examples of how this and similar
-- modules can be used to easily translate properties between types.

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

open import Function
open import Relation.Binary
open import Relation.Binary.Morphism

module Relation.Binary.Morphism.OrderMonomorphism
  {a b ℓ₁ ℓ₂ ℓ₃ ℓ₄} {A : Set a} {B : Set b}
  {_≈₁_ : Rel A ℓ₁} {_≈₂_ : Rel B ℓ₃}
  {_∼₁_ : Rel A ℓ₂} {_∼₂_ : Rel B ℓ₄}
  {⟦_⟧ : A → B}
  (isOrderMonomorphism : IsOrderMonomorphism _≈₁_ _≈₂_ _∼₁_ _∼₂_ ⟦_⟧)
  where

open import Data.Product using (map)
import Relation.Binary.Morphism.RelMonomorphism as RawRelation

open IsOrderMonomorphism isOrderMonomorphism

------------------------------------------------------------------------
-- Re-export equivalence proofs

module EqM = RawRelation Eq.isRelMonomorphism

open RawRelation isRelMonomorphism public

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

reflexive : _≈₂_ ⇒ _∼₂_ → _≈₁_ ⇒ _∼₁_
reflexive refl x≈y = cancel (refl (cong x≈y))

irrefl : Irreflexive _≈₂_ _∼₂_ → Irreflexive _≈₁_ _∼₁_
irrefl irrefl x≈y x∼y = irrefl (cong x≈y) (mono x∼y)

antisym : Antisymmetric _≈₂_ _∼₂_ → Antisymmetric _≈₁_ _∼₁_
antisym antisym x∼y y∼x = injective (antisym (mono x∼y) (mono y∼x))

compare : Trichotomous _≈₂_ _∼₂_ → Trichotomous _≈₁_ _∼₁_
compare compare x y with compare ⟦ x ⟧ ⟦ y ⟧
... | tri< a ¬b ¬c = tri< (cancel a) (¬b ∘ cong) (¬c ∘ mono)
... | tri≈ ¬a b ¬c = tri≈ (¬a ∘ mono) (injective b) (¬c ∘ mono)
... | tri> ¬a ¬b c = tri> (¬a ∘ mono) (¬b ∘ cong) (cancel c)

respˡ : _∼₂_ Respectsˡ _≈₂_ → _∼₁_ Respectsˡ _≈₁_
respˡ resp x≈y x∼z = cancel (resp (cong x≈y) (mono x∼z))

respʳ : _∼₂_ Respectsʳ _≈₂_ → _∼₁_ Respectsʳ _≈₁_
respʳ resp x≈y y∼z = cancel (resp (cong x≈y) (mono y∼z))

resp : _∼₂_ Respects₂ _≈₂_ → _∼₁_ Respects₂ _≈₁_
resp = map respʳ respˡ

------------------------------------------------------------------------
-- Structures

isPreorder : IsPreorder _≈₂_ _∼₂_ → IsPreorder _≈₁_ _∼₁_
isPreorder O = record
  { isEquivalence = EqM.isEquivalence O.isEquivalence
  ; reflexive     = reflexive O.reflexive
  ; trans         = trans O.trans
  } where module O = IsPreorder O

isPartialOrder : IsPartialOrder _≈₂_ _∼₂_ → IsPartialOrder _≈₁_ _∼₁_
isPartialOrder O = record
  { isPreorder = isPreorder O.isPreorder
  ; antisym    = antisym O.antisym
  } where module O = IsPartialOrder O

isTotalOrder : IsTotalOrder _≈₂_ _∼₂_ → IsTotalOrder _≈₁_ _∼₁_
isTotalOrder O = record
  { isPartialOrder = isPartialOrder O.isPartialOrder
  ; total          = total O.total
  } where module O = IsTotalOrder O

isDecTotalOrder : IsDecTotalOrder _≈₂_ _∼₂_ → IsDecTotalOrder _≈₁_ _∼₁_
isDecTotalOrder O = record
  { isTotalOrder = isTotalOrder O.isTotalOrder
  ; _≟_          = EqM.dec O._≟_
  ; _≤?_         = dec O._≤?_
  } where module O = IsDecTotalOrder O

isStrictPartialOrder : IsStrictPartialOrder _≈₂_ _∼₂_ →
                       IsStrictPartialOrder _≈₁_ _∼₁_
isStrictPartialOrder O = record
  { isEquivalence = EqM.isEquivalence O.isEquivalence
  ; irrefl        = irrefl O.irrefl
  ; trans         = trans O.trans
  ; <-resp-≈      = resp O.<-resp-≈
  } where module O = IsStrictPartialOrder O

isStrictTotalOrder : IsStrictTotalOrder _≈₂_ _∼₂_ →
                     IsStrictTotalOrder _≈₁_ _∼₁_
isStrictTotalOrder O = record
  { isEquivalence = EqM.isEquivalence O.isEquivalence
  ; trans         = trans O.trans
  ; compare       = compare O.compare
  } where module O = IsStrictTotalOrder O


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

-- Nils' idea about databases in the Agda mailing list.
-- http://thread.gmane.org/gmane.comp.lang.agda/2911/focus=2917

module DataBase where

infixr 7 _,_ _,′_
infixr 5 _∧_

data _∧_ (A B : Set) : Set where
  _,_ : A → B → A ∧ B

_,′_ : ∀ {A B} → A → B → A ∧ B
_,′_ = _,_

postulate
  P Q R S : Set
  h₁      : P → Q
  h₂      : Q → R
  h₃      : R → S

postulate thm₁ : P → S
{-# ATP prove thm₁ h₁ h₂ h₃ #-}

db = h₁ ,′ h₂ ,′ h₃

postulate thm₂ : P → S
{-# ATP prove thm₂ db #-}


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

  postulate
    bla : {x : A} {{_ : P x}} → Set → Set

  test :  {x : A} {{_ : P x}} → Set → Set
  test B = bla B


------------------------------------------------------------------------
-- A tiny library of derived combinators
------------------------------------------------------------------------

module TotalRecognisers.LeftRecursion.Lib (Tok : Set) where

open import Codata.Musical.Notation
open import Data.Bool hiding (_∧_; _≤_)
open import Data.Bool.Properties
open import Function hiding (_∋_)
open import Function.Equality using (_⟨$⟩_)
open import Function.Equivalence using (module Equivalence)
open import Data.List
open import Data.Nat using (ℕ; zero; suc)
open import Data.Product as Prod
open import Relation.Binary
open import Relation.Binary.PropositionalEquality hiding ([_])
open import Relation.Nullary.Decidable

import TotalRecognisers.LeftRecursion
open TotalRecognisers.LeftRecursion Tok

------------------------------------------------------------------------
-- Kleene star

-- The intended semantics of the Kleene star.

infixr 5 _∷_
infix  4 _∈[_]⋆

data _∈[_]⋆ {n} : List Tok → P n → Set where
  []  : ∀ {p}       → [] ∈[ p ]⋆
  _∷_ : ∀ {s₁ s₂ p} → s₁ ∈ p → s₂ ∈[ p ]⋆ → s₁ ++ s₂ ∈[ p ]⋆

module KleeneStar₁ where

  infix 15 _⋆ _+

  -- This definition requires that the argument recognisers are not
  -- nullable.

  mutual

    _⋆ : P false → P true
    p ⋆ = empty ∣ p +

    _+ : P false → P false
    p + = p · ♯ (p ⋆)

  -- The definition of _⋆ above is correct.

  ⋆-sound : ∀ {s p} → s ∈ p ⋆ → s ∈[ p ]⋆
  ⋆-sound (∣-left  empty)       = []
  ⋆-sound (∣-right (pr₁ · pr₂)) = pr₁ ∷ ⋆-sound pr₂

  ⋆-complete : ∀ {s p} → s ∈[ p ]⋆ → s ∈ p ⋆
  ⋆-complete []                    = ∣-left empty
  ⋆-complete (_∷_ {[]}    pr₁ pr₂) = ⋆-complete pr₂
  ⋆-complete (_∷_ {_ ∷ _} pr₁ pr₂) =
    ∣-right {n₁ = true} (pr₁ · ⋆-complete pr₂)

module KleeneStar₂ where

  infix 15 _⋆

  -- This definition works for any argument recogniser.

  _⋆ : ∀ {n} → P n → P true
  _⋆ = KleeneStar₁._⋆ ∘ nonempty

  -- The definition of _⋆ above is correct.

  ⋆-sound : ∀ {s n} {p : P n} → s ∈ p ⋆ → s ∈[ p ]⋆
  ⋆-sound (∣-left  empty)                = []
  ⋆-sound (∣-right (nonempty pr₁ · pr₂)) = pr₁ ∷ ⋆-sound pr₂

  ⋆-complete : ∀ {s n} {p : P n} → s ∈[ p ]⋆ → s ∈ p ⋆
  ⋆-complete []                    = ∣-left empty
  ⋆-complete (_∷_ {[]}    pr₁ pr₂) = ⋆-complete pr₂
  ⋆-complete (_∷_ {_ ∷ _} pr₁ pr₂) =
    ∣-right {n₁ = true} (nonempty pr₁ · ⋆-complete pr₂)

  -- Note, however, that for actual parsing the corresponding
  -- definition would not be correct. The reason is that p would give
  -- a result also when the empty string was accepted, and these
  -- results are ignored by the definition above. In the case of
  -- actual parsing the result of p ⋆, when p is nullable, should be a
  -- stream and not a finite list.

------------------------------------------------------------------------
-- A simplified sequencing operator

infixl 10 _⊙_

_⊙_ : ∀ {n₁ n₂} → P n₁ → P n₂ → P (n₁ ∧ n₂)
_⊙_ {n₁ = n₁} p₁ p₂ = ♯? p₁ · ♯? {b = n₁} p₂

module ⊙ where

  complete : ∀ {n₁ n₂ s₁ s₂} {p₁ : P n₁} {p₂ : P n₂} →
             s₁ ∈ p₁ → s₂ ∈ p₂ → s₁ ++ s₂ ∈ p₁ ⊙ p₂
  complete {n₁} {n₂} s₁∈p₁ s₂∈p₂ = add-♭♯ n₂ s₁∈p₁ · add-♭♯ n₁ s₂∈p₂

  infixl 10 _⊙′_
  infix   4 _⊙_∋_

  data _⊙_∋_ {n₁ n₂} (p₁ : P n₁) (p₂ : P n₂) : List Tok → Set where
    _⊙′_ : ∀ {s₁ s₂} (s₁∈p₁ : s₁ ∈ p₁) (s₂∈p₂ : s₂ ∈ p₂) →
           p₁ ⊙ p₂ ∋ s₁ ++ s₂

  sound : ∀ {n₁} n₂ {s} {p₁ : P n₁} {p₂ : P n₂} →
          s ∈ p₁ ⊙ p₂ → p₁ ⊙ p₂ ∋ s
  sound {n₁} n₂ (s₁∈p₁ · s₂∈p₂) = drop-♭♯ n₂ s₁∈p₁ ⊙′ drop-♭♯ n₁ s₂∈p₂

------------------------------------------------------------------------
-- A combinator which repeats a recogniser a fixed number of times

⟨_^_⟩-nullable : Bool → ℕ → Bool
⟨ n ^ zero  ⟩-nullable = true
⟨ n ^ suc i ⟩-nullable = n ∧ ⟨ n ^ i ⟩-nullable

infixl 15 _^_

_^_ : ∀ {n} → P n → (i : ℕ) → P ⟨ n ^ i ⟩-nullable
p ^ 0     = empty
p ^ suc i = p ⊙ p ^ i

-- Some lemmas relating _^_ to _⋆.

open KleeneStar₂

^≤⋆ : ∀ {n} {p : P n} i → p ^ i ≤ p ⋆
^≤⋆ {n} {p} i s∈ = ⋆-complete $ helper i s∈
  where
  helper : ∀ i {s} → s ∈ p ^ i → s ∈[ p ]⋆
  helper zero    empty          = []
  helper (suc i) (s₁∈p · s₂∈pⁱ) =
    drop-♭♯ ⟨ n ^ i ⟩-nullable s₁∈p ∷ helper i (drop-♭♯ n s₂∈pⁱ)

⋆≤^ : ∀ {n} {p : P n} {s} → s ∈ p ⋆ → ∃ λ i → s ∈ p ^ i
⋆≤^ {n} {p} s∈p⋆ = helper (⋆-sound s∈p⋆)
  where
  helper : ∀ {s} → s ∈[ p ]⋆ → ∃ λ i → s ∈ p ^ i
  helper []             = (0 , empty)
  helper (s₁∈p ∷ s₂∈p⋆) =
    Prod.map suc (λ {i} s₂∈pⁱ → add-♭♯ ⟨ n ^ i ⟩-nullable s₁∈p ·
                                add-♭♯ n                  s₂∈pⁱ)
             (helper s₂∈p⋆)

------------------------------------------------------------------------
-- A recogniser which only accepts a given token

module Tok (dec : Decidable (_≡_ {A = Tok})) where

  tok : Tok → P false
  tok t = sat (⌊_⌋ ∘ dec t)

  sound : ∀ {s t} → s ∈ tok t → s ≡ [ t ]
  sound (sat ok) = cong [_] $ sym $ toWitness ok

  complete : ∀ {t} → [ t ] ∈ tok t
  complete = sat (fromWitness refl)

------------------------------------------------------------------------
-- A recogniser which accepts the empty string iff the argument is
-- true (and never accepts non-empty strings)

accept-if-true : ∀ b → P b
accept-if-true true  = empty
accept-if-true false = fail

module AcceptIfTrue where

  sound : ∀ b {s} → s ∈ accept-if-true b → s ≡ [] × T b
  sound true  empty = (refl , _)
  sound false ()

  complete : ∀ {b} → T b → [] ∈ accept-if-true b
  complete ok with Equivalence.to T-≡ ⟨$⟩ ok
  ... | refl = empty


--------------------------------------------------------------------------------
-- This is part of Agda Inference Systems

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

open import Data.Nat
open import Data.Vec
open import Data.Product
open import Data.Sum
open import Data.Fin
open import Relation.Binary.PropositionalEquality
open import Data.Unit
open import Data.Bool
open import Data.Empty
open import Codata.Colist
open import Codata.Thunk
open import Size
open import Examples.Colists.Auxiliary.Colist_member
open import Examples.Colists.Auxiliary.MaxOf

open import is-lib.InfSys

module Examples.Colists.Max where

  U = ℕ × Colist ℕ ∞

  data maxElemRN : Set where
    max-h max-t : maxElemRN

  data maxElemCoRN : Set where
    co-max-h : maxElemCoRN

  max-h-r : FinMetaRule U
  max-h-r .Ctx = Σ[ (_ , xs) ∈ ℕ × Thunk (Colist ℕ) ∞ ] xs .force ≡ []
  max-h-r .comp ((x , xs) , _) =
    [] ,
    --------------
    (x , x ∷ xs)

  max-t-r : FinMetaRule U
  max-t-r .Ctx = Σ[ (x , y , z , _) ∈ ℕ × ℕ × ℕ × Thunk (Colist ℕ) ∞ ] z ≡ max x y
  max-t-r .comp ((x , y , z , xs) , _) =
    (x , xs .force) ∷ [] ,
    --------------
    (z , y ∷ xs)

  co-max-h-r : FinMetaRule U
  co-max-h-r .Ctx = ℕ × Thunk (Colist ℕ) ∞
  co-max-h-r .comp (x , xs) =
    [] ,
    --------------
    (x , x ∷ xs)

  maxElemIS : IS U
  maxElemIS .Names = maxElemRN
  maxElemIS .rules max-h = from max-h-r
  maxElemIS .rules max-t = from max-t-r

  maxElemCoIS : IS U
  maxElemCoIS .Names = maxElemCoRN
  maxElemCoIS .rules co-max-h = from co-max-h-r

  _maxElem_ : ℕ → Colist ℕ ∞ → Set
  x maxElem xs = FCoInd⟦ maxElemIS , maxElemCoIS ⟧ (x , xs)

  _maxElemᵢ_ : ℕ → Colist ℕ ∞ → Set
  x maxElemᵢ xs = Ind⟦ maxElemIS ∪ maxElemCoIS ⟧ (x , xs)

  maxSpec inSpec geqSpec : U → Set
  inSpec (x , xs) = x ∈ xs
  geqSpec (x , xs) = ∀{n} → n ∈ xs → x ≡ max x n
  maxSpec u = inSpec u × geqSpec u

  maxElemSound-in-ind : ∀{x xs} → x maxElemᵢ xs → inSpec (x , xs)
  maxElemSound-in-ind (fold (inj₁ max-h , _ , refl , _)) = here
  maxElemSound-in-ind (fold (inj₁ max-t , (_ , eq) , refl , prem)) with max-refl-eq eq
  maxElemSound-in-ind (fold (inj₁ max-t , (_ , eq) , refl , prem)) | inj₁ refl = there (maxElemSound-in-ind (prem zero))
  maxElemSound-in-ind (fold (inj₁ max-t , (_ , eq) , refl , prem)) | inj₂ refl = here
  maxElemSound-in-ind (fold (inj₂ co-max-h , _ , refl , _)) = here

  maxElemSound-in : ∀{x xs} → x maxElem xs → inSpec (x , xs)
  maxElemSound-in max = maxElemSound-in-ind (fcoind-to-ind max)

  maxElemSound-gr : ∀{x xs} → x maxElem xs → geqSpec (x , xs)
  maxElemSound-gr max here with max .CoInd⟦_⟧.unfold
  maxElemSound-gr max here | max-h , _ , refl , _ = max-self
  maxElemSound-gr max here | max-t , ((_ , eq) , _) , refl , _ with max-refl-eq eq
  ... | inj₁ refl = eq
  ... | inj₂ refl = max-self
  maxElemSound-gr max (there mem) with max .CoInd⟦_⟧.unfold
  maxElemSound-gr max (there mem) | max-h , ((_ , eq) , _) , refl , _ = ⊥-elim (mem-abs mem eq)
  maxElemSound-gr max (there mem) | max-t , ((_ , eq) , _) , refl , pr with max-refl-eq eq
  ... | inj₁ refl = maxElemSound-gr (pr zero) mem
  ... | inj₂ refl =
    let rec = maxElemSound-gr (pr zero) mem in
    max-trans rec (max-comm eq)

  maxElemSound : ∀{x xs} → x maxElem xs → maxSpec (x , xs)
  maxElemSound max = maxElemSound-in max , maxElemSound-gr max

  maxSpecBounded : ∀{x xs} → inSpec (x , xs) → geqSpec (x , xs) → x maxElemᵢ xs
  maxSpecBounded here _ = apply-ind (inj₂ co-max-h) _ λ ()
  maxSpecBounded (there mem) gr = apply-ind (inj₁ max-t) (_ , gr here) λ{zero → maxSpecBounded mem λ m → gr (there m)}

  postulate
    old-max : ∀{n x y xs ys} → Thunk.force xs ≡ (y ∷ ys) →
                    maxSpec (n , (x ∷ xs)) → Σ[ m ∈ ℕ ] maxSpec (m , (y ∷ ys))

  maxSpecCons : ∀{x xs} → inSpec (x , xs) → geqSpec (x , xs) → ISF[ maxElemIS ] maxSpec (x , xs)
  maxSpecCons {x} {x ∷ xs} here gr with xs .force | inspect (λ t → t .force) xs
  maxSpecCons {x} {x ∷ xs} here gr | [] | [ eq ] = max-h , (_ , eq) , refl , λ ()
  maxSpecCons {x} {x ∷ xs} here gr | _ ∷ _ | [ eq ] =
    let old , mem , gr' = old-max eq (here , gr) in
    let mem-xs = subst (λ xs → old ∈ xs) (sym eq) mem in
    max-t , (_ , max-comm (gr (there mem-xs))) , refl , λ{zero → mem-xs , λ m → gr' (subst (λ xs → _ ∈ xs) eq m)}
  maxSpecCons {x} {.(_ ∷ _)} (there mem) gr = max-t , (_ , gr here) , refl , λ{zero → mem , λ m → gr (there m)}

  maxElemComplete : ∀{x xs} → maxSpec (x , xs) → x maxElem xs
  maxElemComplete =
    bounded-coind[ maxElemIS , maxElemCoIS ] maxSpec (λ{(x , xs) → maxSpecBounded x xs}) λ{(x , xs) → maxSpecCons x xs}