open import Sec2
data Vec (A : Set) : ℕ → Set where
  [] : Vec A Z
  _∷_ : {n : ℕ} → A → Vec A n → Vec A (S n)

head : {A : Set} → {n : ℕ} → Vec A (S n) → A
head (x ∷ vs) = x

tail : {A : Set} → {n : ℕ} → Vec A (S n) → Vec A n
tail (x ∷ vs) = vs

map : {A B : Set} → {n : ℕ} → (f : A → B) → Vec A n → Vec B n
map f [] = []
map f (x ∷ vs) = f x ∷ map f vs

zip : {A B : Set} → {n : ℕ} → Vec A n → Vec B n → Vec (A Π B) n
zip [] [] = []
zip (x ∷ xs) (x₁ ∷ ys) = < x , x₁ > ∷ zip xs ys


module _ where

open import Function.Iteration using (repeatᵣ ; repeatₗ)

[+]-repeatᵣ-𝐒 : ∀{x y z : ℕ} → (x + y ≡ repeatᵣ y (const 𝐒) z x)
[+]-repeatᵣ-𝐒 {x} {𝟎}       = [≡]-intro
[+]-repeatᵣ-𝐒 {x} {𝐒 y} {z} = congruence₁(𝐒) ([+]-repeatᵣ-𝐒 {x} {y} {z})

[+]-repeatₗ-𝐒 : ∀{x y z : ℕ} → (x + y ≡ repeatₗ y (const ∘ 𝐒) x z)
[+]-repeatₗ-𝐒 {x} {𝟎}       = [≡]-intro
[+]-repeatₗ-𝐒 {x} {𝐒 y} {z} = congruence₁(𝐒) ([+]-repeatₗ-𝐒 {x} {y} {z})

[⋅]-repeatᵣ-[+] : ∀{x y} → (x ⋅ y ≡ repeatᵣ y (_+_) x 0)
[⋅]-repeatᵣ-[+] {x} {𝟎}   = [≡]-intro
[⋅]-repeatᵣ-[+] {x} {𝐒 y} = congruence₁(x +_) ([⋅]-repeatᵣ-[+] {x} {y})

[^]-repeatᵣ-[⋅] : ∀{x y} → (x ^ y ≡ repeatᵣ y (_⋅_) x 1)
[^]-repeatᵣ-[⋅] {x} {𝟎}   = [≡]-intro
[^]-repeatᵣ-[⋅] {x} {𝐒 y} = congruence₁(x ⋅_) ([^]-repeatᵣ-[⋅] {x} {y})


module type-level where

open import bool
open import level
open import nat

{- multiApply{n} applies a sequence f1, f2, ..., f_n of functions
   to a starting point a:

   multiApply{n} a f1 f2 ... f_n = f_n (... (f2 (f1 a)))
-}

multiApplyTh : ℕ → Set → Set lone
multiApplyTh 0 A = Lift A
multiApplyTh (suc n) A = ∀{B : Set} → (A → B) → multiApplyTh n B

multiApplyT : ℕ → Set lone
multiApplyT n = ∀{A : Set} → A → multiApplyTh n A

multiApply-testT = multiApplyT 2

multiApplyh : {A : Set}{n : ℕ} → A → multiApplyTh n A
multiApplyh {n = zero} a = lift a
multiApplyh {n = suc n} a f = multiApplyh{n = n} (f a)

multiApply : {n : ℕ} → multiApplyT n
multiApply{n} = λ{A : Set}(a : A) → multiApplyh{A}{n} a

multiApply-test1 : Lift 𝔹
multiApply-test1 = multiApply{3} 3 (_+_ 3) is-even ~_


module Issue558 where

data Nat : Set where
  Z : Nat
  S : Nat → Nat

data _≡_ {A : Set} (a : A) : A → Set where
  Refl : a ≡ a

plus : Nat → Nat → Nat
plus Z n = n
plus (S n) m = S (plus n m)

record Addable (τ : Set) : Set where
 constructor addable
 field
  _+_ : τ → τ → τ

open module AddableIFS {t : Set} {{r : Addable t}} = Addable {t} r

record CommAddable (τ : Set) : Set where
 constructor commAddable
 field
  foo : Addable τ
  comm : (a b : τ) → (a + b) ≡ (b + a)

natAdd : Addable Nat
natAdd = record {_+_ = plus}

postulate commPlus : (a b : Nat) → plus a b ≡ plus b a

commAdd : CommAddable Nat
commAdd = record {foo = natAdd; comm = commPlus}

open CommAddable {{...}}

test : (Z + Z) ≡ Z
test = comm Z Z

a : {x y : Nat} → (S (S Z) + (x + y)) ≡ ((x + y) + S (S Z))
a {x}{y} = comm (S (S Z)) (x + y) -- ERROR!


module Numeral.Integer.Relation.Order where

open import Functional
import      Lvl
import      Numeral.Natural.Relation.Order as ℕ
open import Numeral.Integer
open import Numeral.Integer.Oper
open import Relator.Ordering
open import Type

-- Inequalities/Comparisons
data _≤_ : ℤ → ℤ → Type{Lvl.𝟎} where
  neg-neg : ∀{a b} → (a ℕ.≤ b) → (−𝐒ₙ(b)) ≤ (−𝐒ₙ(a))
  neg-pos : ∀{a b} → (−𝐒ₙ(a)) ≤ (+ₙ b)
  pos-pos : ∀{a b} → (a ℕ.≤ b) → (+ₙ a)   ≤ (+ₙ b)

_<_ : ℤ → ℤ → Type
_<_ = (_≤_) ∘ 𝐒

open From-[≤][<] (_≤_)(_<_) public

module _ where
  open import Structure.Relator.Properties

  instance
    [≤][−𝐒ₙ]-sub : (swap(_≤_) on₂ (−𝐒ₙ_)) ⊆₂ (ℕ._≤_)
    _⊆₂_.proof [≤][−𝐒ₙ]-sub (neg-neg p) = p

  instance
    [≤][+ₙ]-sub : ((_≤_) on₂ (+ₙ_)) ⊆₂ (ℕ._≤_)
    _⊆₂_.proof [≤][+ₙ]-sub (pos-pos p) = p


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

open import Cubical.Core.Everything

open import Cubical.Data.Nat

data ℤ : Type₀ where
  pos    : (n : ℕ) → ℤ
  negsuc : (n : ℕ) → ℤ

neg : (n : ℕ) → ℤ
neg zero = pos zero
neg (suc n) = negsuc n

infix 100 -_
-_ : ℕ → ℤ
-_ = neg

{-# DISPLAY pos n = n #-}
{-# DISPLAY negsuc n = - (suc n) #-}

sucInt : ℤ → ℤ
sucInt (pos n)          = pos (suc n)
sucInt (negsuc zero)    = pos zero
sucInt (negsuc (suc n)) = negsuc n

predInt : ℤ → ℤ
predInt (pos zero)    = negsuc zero
predInt (pos (suc n)) = pos n
predInt (negsuc n)    = negsuc (suc n)

-- Natural number and negative integer literals for ℤ

open import Cubical.Data.Nat.Literals public

instance
  fromNatℤ : FromNat ℤ
  fromNatℤ = record { Constraint = λ _ → ⊤ ; fromNat = λ n → pos n }

instance
  negativeℤ : Negative ℤ
  negativeℤ = record { Constraint = λ _ → ⊤ ; fromNeg = λ n → neg n }


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

module Data.Tuple.UniverseMonomorphic where

open import Prelude
open import Data.Fin
Tuple : ∀ n → (Fin n → Type) → Type
Tuple zero     f = ⊤
Tuple (suc n)  f = f f0 × Tuple n (f ∘ fs)

private
  variable
    n : ℕ
    U : Fin n → Type

ind : Tuple n U → (i : Fin n) → U i
ind {n = suc n} (x , xs) f0     = x
ind {n = suc n} (x , xs) (fs i) = ind xs i

tab : ((i : Fin n) → U i) → Tuple n U
tab {n = zero}  f = tt
tab {n = suc n} f = f f0 , tab (f ∘ fs)

Π→Tuple→Π : ∀ {n} {U : Fin n → Type} (xs : (i : Fin n) → U i) i → ind (tab xs) i ≡ xs i
Π→Tuple→Π {n = suc n} f f0 = refl
Π→Tuple→Π {n = suc n} f (fs i) = Π→Tuple→Π (f ∘ fs) i

Tuple→Π→Tuple : ∀ {n} {U : Fin n → Type} (xs : Tuple n U) → tab (ind xs) ≡ xs
Tuple→Π→Tuple {n = zero} tt = refl
Tuple→Π→Tuple {n = suc n} (x , xs) i .fst = x
Tuple→Π→Tuple {n = suc n} (x , xs) i .snd = Tuple→Π→Tuple xs i

Tuple⇔ΠFin :
 Tuple n U ⇔ ((i : Fin n) → U i)
Tuple⇔ΠFin .fun = ind
Tuple⇔ΠFin .inv = tab
Tuple⇔ΠFin .leftInv = Tuple→Π→Tuple
Tuple⇔ΠFin .rightInv x = funExt (Π→Tuple→Π x)


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

module Categories.Category.Finite.Fin where

open import Level
open import Data.Nat using (ℕ)
open import Data.Vec as Vec using (Vec)
open import Data.List
open import Data.Fin
open import Data.Fin.Properties
open import Axiom.UniquenessOfIdentityProofs
open import Relation.Binary using (Rel ; Decidable)
open import Relation.Binary.PropositionalEquality as ≡

open import Categories.Category

record Arrow (n : ℕ) (∣_⇒_∣ : Fin n → Fin n → ℕ) : Set where
  field
    dom : Fin n
    cod : Fin n
    arr : Fin ∣ dom ⇒ cod ∣

-- a hasShape of a finite catgegory
--
-- Classically, a finite category has a finite number of objects and a finite number
-- of morphisms. However, in this library, we cannot conveniently count the number of
-- objects and morphisms, because morphisms are identified up to the underlying
-- equivalence and objects have no general notion of identity. As a result, the
-- classical definition fails.
--
-- Nevetheless, if we know precisely what the objects and morphisms are, then we might
-- be able to count them. As a result, finite categories are just adjoint equivalent
-- to some category with a finite hasShape. Motivated by this idea, we can consider a
-- category with both objects and morphisms represented by Fin. We know Fin has
-- decidable equality and consequently also UIP. This allows us to operate
-- classically. We additionally require categorical axioms and thus ensure all shapes
-- form categories.
record HasFinCatShape (n : ℕ) (∣_⇒_∣ : Fin n → Fin n → ℕ) : Set where
  infix  4 _⇒_
  infixr 9 _∘_

  _⇒_ : Rel (Fin n) 0ℓ
  a ⇒ b = Fin ∣ a ⇒ b ∣

  field
    id  : ∀ {a} → a ⇒ a
    _∘_ : ∀ {a b c} → b ⇒ c → a ⇒ b → a ⇒ c

  field
    assoc     : ∀ {a b c d} {f : a ⇒ b} {g : b ⇒ c} {h : c ⇒ d} → (h ∘ g) ∘ f ≡ h ∘ (g ∘ f)
    identityˡ : ∀ {a b} {f : a ⇒ b} → id ∘ f ≡ f
    identityʳ : ∀ {a b} {f : a ⇒ b} → f ∘ id ≡ f

  objects : List (Fin n)
  objects = allFin n

  wrap-arr : ∀ {d c} (f : Fin ∣ d ⇒ c ∣) → Arrow n ∣_⇒_∣
  wrap-arr f = record { arr = f }

  morphisms : List (Arrow n ∣_⇒_∣)
  morphisms = concatMap (λ d → concatMap (λ c → tabulate (wrap-arr {d} {c})) objects) objects

  Obj-≟ : Decidable {A = Fin n} _≡_
  Obj-≟ = _≟_

  objects-vec : Vec (Fin n) n
  objects-vec = Vec.allFin n

  ⇒-≟ : ∀ {a b} → Decidable {A = a ⇒ b} _≡_
  ⇒-≟ = _≟_

  Obj-UIP : UIP (Fin n)
  Obj-UIP = Decidable⇒UIP.≡-irrelevant Obj-≟

  ⇒-UIP : ∀ {a b} → UIP (a ⇒ b)
  ⇒-UIP = Decidable⇒UIP.≡-irrelevant ⇒-≟

record FinCatShape : Set where
  infix 9 ∣_⇒_∣

  field
    size     : ℕ
    ∣_⇒_∣    : Fin size → Fin size → ℕ
    hasShape : HasFinCatShape size ∣_⇒_∣

  open HasFinCatShape hasShape public

FinCategory : FinCatShape → Category 0ℓ 0ℓ 0ℓ
FinCategory s = record
  { Obj       = Fin size
  ; _⇒_       = _⇒_
  ; _≈_       = _≡_
  ; id        = id
  ; _∘_       = _∘_
  ; assoc     = assoc
  ; sym-assoc = sym assoc
  ; identityˡ = identityˡ
  ; identityʳ = identityʳ
  ; identity² = identityˡ
  ; equiv     = ≡.isEquivalence
  ; ∘-resp-≈  = cong₂ _∘_
  }
  where open FinCatShape s


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

module Data.Nat.Fold where

open import Prelude
open import Data.Nat

foldr-ℕ : (A → A) → A → ℕ → A
foldr-ℕ f b zero = b
foldr-ℕ f b (suc n) = f (foldr-ℕ f b n)

foldr-ℕ-universal : ∀ (h : ℕ → A) f x →
                   (h zero ≡ x) →
                   (∀ n → h (suc n) ≡ f (h n)) →
                   ∀ n → h n ≡ foldr-ℕ f x n
foldr-ℕ-universal h f x base step zero = base
foldr-ℕ-universal h f x base step (suc n) = step n ; cong f (foldr-ℕ-universal h f x base step n)

foldl-ℕ-go : (A → A) → ℕ → A → A
foldl-ℕ-go f zero    x = x
foldl-ℕ-go f (suc n) x = foldl-ℕ-go f n $! f x

foldl-ℕ : (A → A) → A → ℕ → A
foldl-ℕ f x n = foldl-ℕ-go f n $! x
{-# INLINE foldl-ℕ #-}

f-comm : ∀ (f : A → A) x n → f (foldr-ℕ f x n) ≡ foldr-ℕ f (f x) n
f-comm f x zero    i = f x
f-comm f x (suc n) i = f (f-comm f x n i)

foldl-ℕ-foldr : ∀ f (x : A) n → foldr-ℕ f x n ≡ foldl-ℕ f x n
foldl-ℕ-foldr f x zero    = sym ($!-≡ (foldl-ℕ-go f zero) x)
foldl-ℕ-foldr f x (suc n) = f-comm f x n ; foldl-ℕ-foldr f (f x) n ; sym ($!-≡ (foldl-ℕ-go f (suc n)) x)

foldl-ℕ-universal : ∀ (h : ℕ → A) f x →
                   (h zero ≡ x) →
                   (∀ n → h (suc n) ≡ f (h n)) →
                   ∀ n → h n ≡ foldl-ℕ f x n
foldl-ℕ-universal h f x base step n = foldr-ℕ-universal h f x base step n ; foldl-ℕ-foldr f x n


{-
This second-order signature was created from the following second-order syntax description:

syntax PCF

type
  N   : 0-ary
  _↣_ : 2-ary | r30
  B   : 0-ary

term
  app : α ↣ β  α  ->  β | _$_ l20
  lam : α.β  ->  α ↣ β | ƛ_ r10
  tr  : B
  fl  : B
  ze  : N
  su  : N  ->  N
  pr  : N  ->  N
  iz  : N  ->  B | 0?
  if  : B  α  α  ->  α
  fix : α.α  ->  α

theory
  (ƛβ) b : α.β  a : α |> app (lam(x.b[x]), a) = b[a]
  (ƛη) f : α ↣ β      |> lam (x. app(f, x))   = f
  (zz)       |> iz (ze)       = tr
  (zs) n : N |> iz (su (n)) = fl
  (ps) n : N |> pr (su (n)) = n
  (ift) t f : α |> if (tr, t, f) = t
  (iff) t f : α |> if (fl, t, f) = f
  (fix) t : α.α |> fix (x.t[x]) = t[fix (x.t[x])]
-}

module PCF.Signature where

open import SOAS.Context

-- Type declaration
data PCFT : Set where
  N   : PCFT
  _↣_ : PCFT → PCFT → PCFT
  B   : PCFT
infixr 30 _↣_

open import SOAS.Syntax.Signature PCFT public
open import SOAS.Syntax.Build PCFT public

-- Operator symbols
data PCFₒ : Set where
  appₒ lamₒ : {α β : PCFT} → PCFₒ
  trₒ flₒ zeₒ suₒ prₒ izₒ : PCFₒ
  ifₒ fixₒ : {α : PCFT} → PCFₒ

-- Term signature
PCF:Sig : Signature PCFₒ
PCF:Sig = sig λ
  { (appₒ {α}{β}) → (⊢₀ α ↣ β) , (⊢₀ α) ⟼₂ β
  ; (lamₒ {α}{β}) → (α ⊢₁ β) ⟼₁ α ↣ β
  ;  trₒ          → ⟼₀ B
  ;  flₒ          → ⟼₀ B
  ;  zeₒ          → ⟼₀ N
  ;  suₒ          → (⊢₀ N) ⟼₁ N
  ;  prₒ          → (⊢₀ N) ⟼₁ N
  ;  izₒ          → (⊢₀ N) ⟼₁ B
  ; (ifₒ  {α})    → (⊢₀ B) , (⊢₀ α) , (⊢₀ α) ⟼₃ α
  ; (fixₒ {α})    → (α ⊢₁ α) ⟼₁ α
  }

open Signature PCF:Sig public


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

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

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

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

open import Cubical.Data.Empty.Polymorphic
open import Cubical.Data.Prod

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

------------------------------------------------------------------------
-- The free magma type

data FreeM : Type ℓ where
  inj : A → FreeM
  _•_ : Op₂ FreeM

------------------------------------------------------------------------
-- Proof the free magma is a set

module FreeMPath where
  Cover : FreeM → FreeM → Type ℓ
  Cover (inj x) (inj y) = x ≡ y
  Cover (inj x) (y₁ • y₂) = ⊥
  Cover (x₁ • x₂) (inj y) = ⊥
  Cover (x₁ • x₂) (y₁ • y₂) = Cover x₁ y₁ × Cover x₂ y₂

  isPropCover : ∀ x y → isProp (Cover x y)
  isPropCover (inj x) (inj y) = isSetA x y
  isPropCover (inj x) (y₁ • y₂) = isProp⊥
  isPropCover (x₁ • x₂) (inj y) = isProp⊥
  isPropCover (x₁ • x₂) (y₁ • y₂) = isPropProd (isPropCover x₁ y₁) (isPropCover x₂ y₂)

  reflCover : ∀ x → Cover x x
  reflCover (inj x) = refl
  reflCover (x • y) = reflCover x , reflCover y

  encode : ∀ x y → x ≡ y → Cover x y
  encode x _ = J (λ y _ → Cover x y) (reflCover x)

  encodeRefl : ∀ x → encode x x refl ≡ reflCover x
  encodeRefl x = JRefl (λ y _ → Cover x y) (reflCover x)

  decode : ∀ x y → Cover x y → x ≡ y
  decode (inj x) (inj y) p = cong inj p
  decode (inj x) (y₁ • y₂) ()
  decode (x₁ • x₂) (inj y) ()
  decode (x₁ • x₂) (y₁ • y₂) (p , q) = cong₂ _•_ (decode x₁ y₁ p) (decode x₂ y₂ q)

  decodeRefl : ∀ x → decode x x (reflCover x) ≡ refl
  decodeRefl (inj x) = refl
  decodeRefl (x • y) i j = decodeRefl x i j • decodeRefl y i j

  decodeEncode : ∀ x y → (p : x ≡ y) → decode x y (encode x y p) ≡ p
  decodeEncode x _ =
    J (λ y p → decode x y (encode x y p) ≡ p)
      (cong (decode x x) (encodeRefl x) ? decodeRefl x)

isSetFreeM : isSet FreeM
isSetFreeM x y =
  isOfHLevelRetract 1
    (FreeMPath.encode x y)
    (FreeMPath.decode x y)
    (FreeMPath.decodeEncode x y)
    (FreeMPath.isPropCover x y)

------------------------------------------------------------------------
-- The free magma

FreeM-isMagma : IsMagma FreeM _•_
FreeM-isMagma = record { is-set = isSetFreeM }

FreeMagma : Magma ℓ
FreeMagma = record { isMagma = FreeM-isMagma }


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

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Equiv
open import Cubical.Foundations.HLevels
open import Cubical.Foundations.Isomorphism
open import Cubical.Functions.FunExtEquiv

open import Cubical.Homotopy.Base

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

open import Cubical.Relation.Binary

open import Cubical.DStructures.Base

private
  variable
    ℓA ℓ≅A : Level

-- observational equality on ℕ
ℕ-≅ : ℕ → ℕ → Type ℓ-zero
ℕ-≅ 0 0 = Unit
ℕ-≅ 0 (suc _) = ⊥
ℕ-≅ (suc _) 0 = ⊥
ℕ-≅ (suc n) (suc m) = ℕ-≅ n m

-- observational equality is reflexive
ℕ-≅-ρ : isRefl ℕ-≅
ℕ-≅-ρ 0 = tt
ℕ-≅-ρ (suc n) = ℕ-≅-ρ n

-- observational equality implies identity
ℕ-≅→≡ : {n m : ℕ} → ℕ-≅ n m → n ≡ m
ℕ-≅→≡ {0} {0} p = refl
ℕ-≅→≡ {0} {suc _} p = rec p
ℕ-≅→≡ {suc _} {0} p = rec p
ℕ-≅→≡ {suc n} {suc m} p = cong suc (ℕ-≅→≡ {n} {m} p)

-- observational equality is prop-valued
ℕ-≅-prop : (n m : ℕ) → isProp (ℕ-≅ n m)
ℕ-≅-prop 0 0 = isContr→isProp isContrUnit
ℕ-≅-prop 0 (suc _) = isProp⊥
ℕ-≅-prop (suc _) 0 = isProp⊥
ℕ-≅-prop (suc n) (suc m) = ℕ-≅-prop n m

-- This module contains the first half of the proof of
-- theorem 10.2.3 of Egbert Rijkes Intro to Hott
-- TODO: privatize
module _ {A : Type ℓA}
         (_≅_ : A → A → Type ℓ≅A)
         (ρ : (a : A) → a ≅ a)
         (prop : (a a' : A) → isProp (a ≅ a'))
         (f : (a a' : A) → (a ≅ a') → a ≡ a')
 where
    module _ (a : A) where
      φ : (a' : A) (p : a ≡ a') → a ≅ a'
      φ a' p = J (λ b q → a ≅ b) (ρ a) p

      tot-f : Σ[ a' ∈ A ] a ≅ a' → singl a
      tot-f (a' , p) = a' , f a a' p

      tot-φ : singl a → Σ[ a' ∈ A ] a ≅ a'
      tot-φ (a' , p) = a' , (φ a' p)

      ret-f-φ : (a' : A) → retract (f a a') (φ a')
      ret-f-φ a' p = prop a a' (φ a' (f a a' p)) p

      retract-totf-totφ : retract tot-f tot-φ
      retract-totf-totφ (a' , p) = ΣPathP (refl , ret-f-φ a' p)

      contr-singl-≅ : isContr (Σ[ a' ∈ A ] a ≅ a')
      contr-singl-≅ = isContrRetract tot-f tot-φ retract-totf-totφ (isContrSingl a)

ℕ-≅-contrSingl : (n : ℕ) → isContr (Σ[ m ∈ ℕ ] ℕ-≅ n m)
ℕ-≅-contrSingl n = contr-singl-≅ ℕ-≅ ℕ-≅-ρ ℕ-≅-prop (λ m m' → ℕ-≅→≡ {m} {m'}) n

𝒮-Nat : URGStr ℕ ℓ-zero
𝒮-Nat = make-𝒮 {_≅_ = ℕ-≅} ℕ-≅-ρ ℕ-≅-contrSingl


-- binary search trees (not balanced)

open import bool
open import bool-thms2
open import eq
open import maybe
open import product
open import product-thms
open import bool-relations using (transitive ; total)

module z05-01-bst (A : Set)                    -- type of elements
                  (_≤A_ : A → A → 𝔹)           -- ordering function
                  (≤A-trans : transitive _≤A_) -- proof of transitivity of given ordering
                  (≤A-total : total      _≤A_) -- proof of totality     of given ordering
                  where
{-
IAL
- relations.agda
  - models binary relation on A as functions from A to A to Set
- bool-relations.agda
  - models binary realtion on A as functions from A to A to 𝔹

Cannot use A→A→Set relations here because code cannot manipulate types.
But code can pattern match on values of type 𝔹, so boolean relations more useful.
-}
open import bool-relations _≤A_ hiding (transitive ; total)
open import minmax _≤A_ ≤A-trans ≤A-total

-- able to store values in bounds 'l' and 'u'
--         l(ower) bound
--         |   u(upper) bound
--         v   v
data bst : A → A → Set where
  bst-leaf : ∀ {l u : A}
           → l ≤A u ≡ tt
           → bst l u
  bst-node : ∀ {l l' u' u : A}
           → (d : A)      -- value stored in this node
           → bst l' d     -- left  subtree of values ≤ stored value
           → bst d u'     -- right subtree of values ≥ stored value
           → l ≤A l' ≡ tt
           → u' ≤A u ≡ tt
           → bst l u

------------------------------------------------------------------------------
bst-search : ∀ {l u : A}
           → (d : A)                             -- find a node that is isomorphic (_=A_) to d
           → bst l u
           → maybe (Σ A (λ d' → d iso𝔹 d' ≡ tt)) -- return that node or nothing
bst-search d (bst-leaf _) = nothing -- could return proof not in tree instead
-- compare given element with stored element
bst-search d (bst-node d' L R _ _) with keep (d ≤A d')
-- compare given element with stored element (other direction)
bst-search d (bst-node d' L R _ _) | tt , p1 with keep (d' ≤A d)
-- both are true implying iso, so return that element and proof
bst-search d (bst-node d' L R _ _) | tt , p1 | tt , p2 = just (d' , iso𝔹-intro p1 p2)
-- if either is false then search the appropriate branch
bst-search d (bst-node d' L R _ _) | tt , p1 | ff , p2 = bst-search d L -- search in left
bst-search d (bst-node d' L R _ _) | ff , p1           = bst-search d R -- search in right

------------------------------------------------------------------------------
-- change the lower bound from l' to l
bst-dec-lb : ∀ {l l' u' : A}
           → bst l' u'
           → l ≤A l' ≡ tt
           → bst l u'
bst-dec-lb (bst-leaf p)           q = bst-leaf       (≤A-trans q p)
bst-dec-lb (bst-node d L R p1 p2) q = bst-node d L R (≤A-trans q p1) p2

-- change the upper bound from u' to u
bst-inc-ub : ∀ {l' u' u : A}
           → bst l' u'
           → u' ≤A u ≡ tt
           → bst l' u
bst-inc-ub (bst-leaf p)           q = bst-leaf          (≤A-trans p q)
bst-inc-ub (bst-node d L R p1 p2) q = bst-node d L R p1 (≤A-trans p2 q)

bst-insert : ∀{l u : A}
           → (d : A)                 -- insert 'd'
           → bst l u                 -- into this 'bst'
           → bst (min d l) (max d u) -- type might change
bst-insert d (bst-leaf p) =
  bst-node d (bst-leaf ≤A-refl) (bst-leaf ≤A-refl) min-≤1 max-≤1

bst-insert d (bst-node d' L R p1 p2) with keep (d ≤A d')

bst-insert d (bst-node d' L R p1 p2) | tt , p with bst-insert d L

bst-insert d (bst-node d' L R p1 p2) | tt , p | L' rewrite p =
  bst-node d' L'                (bst-inc-ub R (≤A-trans p2 max-≤2))
           (min2-mono p1) ≤A-refl

bst-insert d (bst-node d' L R p1 p2) | ff , p with bst-insert d R

bst-insert d (bst-node d' L R p1 p2) | ff , p | R' rewrite p =
  bst-node d' (bst-dec-lb L p1) R'
           min-≤2         (max2-mono p2)


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

-- Based on (Vene, 2000).

module Functors where

infixr 1 _+_
infixr 2 _×_

data Bool : Set where
  false true : Bool

data _+_  (A B : Set) : Set where
  inl : A → A + B
  inr : B → A + B

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

-- The terminal object.
data ⊤ : Set where
   <> : ⊤

postulate
  -- The least fixed-point.

  -- Haskell definitions:

  -- data Mu f = In (f (Mu f))

  -- unIn :: Mu f → f (Mu f)
  -- unIn (In x) = x

  μ    : (Set → Set) → Set
  In   : {F : Set → Set} → F (μ F) → μ F
  unIn : {F : Set → Set} → μ F → F (μ F)

postulate
  -- The greatest fixed-point.

  -- Haskell definitions:

  -- data Nu f = Wrap (f (Nu f))

  -- out :: Nu f → (f (Nu f))
  -- out (Wrap x) = x

  ν    : (Set → Set) → Set
  Wrap : {F : Set → Set} → F (ν F) → ν F
  out  : {F : Set → Set} → ν F → F (ν F)

------------------------------------------------------------------------------
-- Functors

--  The identity functor (the functor for the empty and unit types).
IdF : Set → Set
IdF X = X

-- The (co)natural numbers functor.
NatF : Set → Set
NatF X = ⊤ + X

-- The (co)list functor.
ListF : Set → Set → Set
ListF A X = ⊤ + A × X

-- The stream functor.
StreamF : Set → Set → Set
StreamF A X = A × X

------------------------------------------------------------------------------
-- Types as least fixed-points

-- The empty type is a least fixed-point.
⊥ : Set
⊥ = μ IdF

-- The natural numbers type is a least fixed-point.
N : Set
N = μ NatF

-- The data constructors for the natural numbers.
zero : N
zero = In (inl <>)

succ : N → N
succ n = In (inr n)

-- The list type is a least fixed-point.
List : Set → Set
List A = μ (ListF A)

-- The data constructors for List.
nil : {A : Set} → List A
nil = In (inl <>)

cons : {A : Set} → A → List A → List A
cons x xs = In (inr (x , xs))

------------------------------------------------------------------------------
-- Types as greatest fixed-points

-- The unit type is a greatest fixed-point.
Unit : Set
Unit = ν IdF

-- Non-structural recursion
-- unit : Nu IdF
-- unit = Wrap IdF {!unit!}

-- The conat type is a greatest fixed-point.
Conat : Set
Conat = ν NatF

zeroC : Conat
zeroC = Wrap (inl <>)

succC : Conat → Conat
succC cn = Wrap (inr cn)

-- Non-structural recursion for the definition of ∞C.
-- ∞C : Conat
-- ∞C = succC {!∞C!}

-- The pred function is the conat destructor.
pred : Conat → ⊤ + Conat
pred cn with out cn
... | inl _ = inl <>
... | inr x = inr x

-- The colist type is a greatest fixed-point.
Colist : Set → Set
Colist A = ν (ListF A)

-- The colist data constructors.
nilCL : {A : Set} → Colist A
nilCL = Wrap (inl <>)

consCL : {A : Set} → A → Colist A → Colist A
consCL x xs = Wrap (inr (x , xs))

-- The colist destructors.
nullCL : {A : Set} → Colist A → Bool
nullCL xs with out xs
... | inl _ = true
... | inr _ = false

-- headCL : {A : Set} → Colist A → A
-- headCL {A} xs with out (ListF A) xs
-- ... | inl t       =  -- Impossible
-- ... | inr (x , _) = x

-- tailCL : {A : Set} → Colist A → Colist A
-- tailCL {A} xs with out (ListF A) xs
-- ... | inl t         =  -- Impossible
-- ... | inr (_ , xs') = xs'

-- The stream type is a greatest fixed-point.
Stream : Set → Set
Stream A = ν (StreamF A)

-- The stream data constructor.
consS : {A : Set} → A → Stream A → Stream A
consS x xs = Wrap (x , xs)

-- The stream destructors.
headS : {A : Set} → Stream A → A
headS xs with out xs
... | x , _ = x

tailS : {A : Set} → Stream A → Stream A
tailS xs with out xs
... | _ , xs' = xs'

-- From (Leclerc and Paulin-Mohring 1994, p. 195).
--
-- TODO (07 January 2014): Agda doesn't accept the definition of
-- Stream-build.
{-# TERMINATING #-}
Stream-build :
  {A X : Set} →
  (X → StreamF A X) →
  X → Stream A
Stream-build h x with h x
... | a , x' = Wrap (a , Stream-build h x')

-- From (Giménez, 1995, p. 40).
--
-- TODO (07 January 2014): Agda doesn't accept the definition of
-- Stream-corec.
{-# TERMINATING #-}
Stream-corec :
  {A X : Set} →
  (X → (A × (Stream A + X))) →
  X → Stream A
Stream-corec h x with h x
... | a , inl xs = Wrap (a , xs)
... | a , inr x' = Wrap (a , (Stream-corec h x'))

------------------------------------------------------------------------------
-- References
--
-- Giménez, E. (1995). Codifying guarded definitions with recursive
-- schemes. In: Types for Proofs and Programs (TYPES ’94). Ed. by
-- Dybjer, P., Nordström, B. and Smith, J. Vol. 996. LNCS. Springer,
-- pp. 39–59.
--
-- Leclerc, F. and Paulin-Mohring, C. (1994). Programming with Streams
-- in Coq. A case study : the Sieve of Eratosthenes. In: Types for
-- Proofs and Programs (TYPES ’93). Ed. by Barendregt, H. and Nipkow,
-- T. Vol. 806. LNCS. Springer, pp. 191–212.
--
-- Vene, Varmo (2000). Categorical programming with inductive and
-- coinductive types. PhD thesis. Faculty of Mathematics: University
-- of Tartu.


module IPL where

data _∧_ (P : Set) (Q : Set) : Set where
  ∧-intro : P → Q → (P ∧ Q)

proof₁ : {P Q : Set} → (P ∧ Q) → P
proof₁ (∧-intro p q) = p

proof₂ : {P Q : Set} → (P ∧ Q) → Q
proof₂ (∧-intro p q) = q

_⇔_ : (P : Set) → (Q : Set) → Set
a ⇔ b = (a → b) ∧ (b → a)

∧-comm′ : (P Q : Set) → (P ∧ Q) → (Q ∧ P)
∧-comm′ _ _ (∧-intro p q) = ∧-intro q p

∧-comm : (P Q : Set) → (P ∧ Q) ⇔ (Q ∧ P)
∧-comm P Q = ∧-intro (∧-comm′ P Q) (∧-comm′ Q P)

∧-comm1′ : {P Q : Set} → (P ∧ Q) → (Q ∧ P)
∧-comm1′ (∧-intro p q) = ∧-intro q p

data _∨_ (P Q : Set) : Set where
   ∨-intro₁ : P → P ∨ Q
   ∨-intro₂ : Q → P ∨ Q

∨-elim : {A B C : Set} → (A → C) → (B → C) → (A ∨ B) → C
∨-elim ac bc (∨-intro₁ a) = ac a
∨-elim ac bc (∨-intro₂ b) = bc b

∨-comm′ : {A B : Set} → (A ∨ B) → (B ∨ A)
∨-comm′ (∨-intro₁ a) = ∨-intro₂ a
∨-comm′ (∨-intro₂ b) = ∨-intro₁ b

∨-comm : {A B : Set} → (A ∨ B) ⇔ (B ∨ A)
∨-comm = ∧-intro ∨-comm′ ∨-comm′

data ⊥ : Set where

¬ : Set → Set
¬ A = A → ⊥


module All where

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

map : {A B : Set} -> (A -> B) -> List A -> List B
map f []        = []
map f (x :: xs) = f x :: map f xs

_++_ : {A : Set} -> List A -> List A -> List A
[]        ++ ys = ys
(x :: xs) ++ ys = x :: (xs ++ ys)

foldr : {A B : Set} -> (A -> B -> B) -> B -> List A -> B
foldr f z [] = z
foldr f z (x :: xs) = f x (foldr f z xs)

data All {A : Set}(P : A -> Set) : List A -> Set where
  ∅   : All P []
  _▹_ : {x : A}{xs : List A} -> P x -> All P xs -> All P (x :: xs)

data Some {A : Set}(P : A -> Set) : List A -> Set where
  hd : {x : A}{xs : List A} -> P x       -> Some P (x :: xs)
  tl : {x : A}{xs : List A} -> Some P xs -> Some P (x :: xs)

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

_∈_ : {A : Set} -> A -> List A -> Set
x ∈ xs = Some (_==_ x) xs

infixr 40 _,_

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

_∧_ : (A B : Set) -> Set
A ∧ B = A × \_ -> B

_!_ : {A : Set}{P : A -> Set}{Q : A -> Set}{xs : List A} ->
      All P xs -> Some Q xs -> A × (\x -> P x ∧ Q x)
ε ! ()
(p ▹ ps) ! hd q = _ , (p , q)
(p ▹ ps) ! tl q = ps ! q


-- Andreas, 2013-10-21
-- Test case for CheckInternal extracted from The Agda standard library
-- Propositional (intensional) equality

module FunExt where

open import Common.Level
open import Common.Equality

Extensionality : (a b : Level) → Set _
Extensionality a b =
  {A : Set a} {B : A → Set b} {f g : (x : A) → B x} →
  (∀ x → f x ≡ g x) → f ≡ g

-- Functional extensionality implies a form of extensionality for
-- Π-types.

∀-extensionality :
  ∀ {a b} →
  Extensionality a (lsuc b) →
  {A : Set a} (B₁ B₂ : A → Set b) →
  (∀ x → B₁ x ≡ B₂ x) → (∀ x → B₁ x) ≡ (∀ x → B₂ x)
∀-extensionality ext B₁ B₂ B₁≡B₂ with ext B₁≡B₂
∀-extensionality ext B .B  B₁≡B₂ | refl = refl


open import Relation.Binary.Core

module BubbleSort.Everything {A : Set}
                  (_≤_ : A → A → Set)
                  (tot≤ : Total _≤_)
                  (trans≤ : Transitive _≤_) where

open import BubbleSort.Correctness.Order _≤_ tot≤ trans≤
open import BubbleSort.Correctness.Permutation _≤_ tot≤


module Generic.Lib.Equality.Congn where

open import Generic.Lib.Intro
open import Generic.Lib.Equality.Propositional
open import Generic.Lib.Data.Product
open import Generic.Lib.Data.Nat
open import Generic.Lib.Data.Pow
open import Generic.Lib.Data.Sets

zip≡ : ∀ {n αs} {As : Sets {n} αs} -> HList As -> HList As -> Sets (replicatePow n lzero)
zip≡ {0}      tt       tt      = tt
zip≡ {suc _} (x , xs) (y , ys) = (x ≡ y) , zip≡ xs ys

congn : ∀ {β} {B : Set β} n {αs} {As : Sets {n} αs} {xs ys : HList As}
      -> (f : FoldSets As B) -> FoldSets (zip≡ xs ys) (applyFoldSets f xs ≡ applyFoldSets f ys)
congn  0      y      = refl
congn (suc n) f refl = congn n (f _)

private
  module Test where
    cong′ : ∀ {α β} {A : Set α} {B : Set β} {x y} -> (f : A -> B) -> x ≡ y -> f x ≡ f y
    cong′ = congn 1

    cong₂′ : ∀ {α β γ} {A : Set α} {B : Set β} {C : Set γ} {x₁ x₂ y₁ y₂}
           -> (g : A -> B -> C) -> x₁ ≡ x₂ -> y₁ ≡ y₂ -> g x₁ y₁ ≡ g x₂ y₂
    cong₂′ = congn 2


module Lib.Id where

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

cong : {A B : Set}(f : A -> B){x y : A} -> x ≡ y -> f x ≡ f y
cong f refl = refl

subst : {A : Set}(P : A -> Set){x y : A} -> x ≡ y -> P y -> P x
subst P refl px = px


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

module Examples.Gcd.Clocked where

open import Calf.CostMonoid
import Calf.CostMonoids as CM

open import Calf CM.ℕ-CostMonoid
open import Calf.Types.Nat
open import Data.Nat using (_≤_; z≤n)
open import Calf.Types.Unit
open import Calf.Types.Bounded CM.ℕ-CostMonoid
open import Calf.Types.BoundedFunction CM.ℕ-CostMonoid

open import Data.Nat.DivMod
open import Relation.Binary.PropositionalEquality as P
open import Data.Product

open import Examples.Gcd.Euclid

{- Alternative definition of gcd with an explicit clock parameter.
   It is easier to see the computational behavior of the code in this version:
   1) when the clock is nonzero: the algorithm proceeds as normal
   2) clock is zero: algorithm terminates
   Crucially, if the recursor is by-name, then the value of the clock does not
   affect asymptotic behavior of the algorithm.
   Two things one can do in calf:
   1) give a good characterization of the clock in terms of the input by refining the raw recurrence (see Refine.agda)
   2) give a good characterization for of the clock for running the code; this usually
   means finding a clock computation that is simpler to compute
   than the "good" upperbound. For gcd, one can reuse the argument as the clock (see Spec.agda)
-}
gcd/clocked : cmp (Π nat λ _ → Π gcd/i λ _ → F nat)
gcd/clocked zero (x , y , h) = ret x
gcd/clocked (suc k) (x , 0 , h) =  ret {nat} x
gcd/clocked (suc k) (x , suc y , h) =
  bind {mod-tp x (suc y) triv} (F nat) (mod x (suc y) triv)
  λ { (z , eqn2) →
  let h2 = P.subst (λ k → suc k ≤ suc y) (P.sym eqn2) (m%n<n' x _ triv) in
  gcd/clocked k (suc y , z , h2) }

gcd : cmp (Π gcd/i λ _ → F nat)
gcd i = gcd/clocked (gcd/depth i) i

-- cost of clocked gcd is bounded by for any (not necessarily safe)
-- instantiation of the clock
gcd/clocked≤gcd/depth : ∀ k i → IsBounded nat (gcd/clocked k i) (gcd/depth i)
gcd/clocked≤gcd/depth zero i = bound/relax (λ _ → z≤n) bound/ret
gcd/clocked≤gcd/depth (suc k) (x , zero , h) = bound/ret
gcd/clocked≤gcd/depth (suc k) (x , suc y , h) rewrite gcd/depth-unfold-suc {x} {y} {h} =
  bound/step 1 _ (gcd/clocked≤gcd/depth k (suc y , x % suc y , m%n<n' x _ triv))

gcd≤gcd/depth : ∀ i → IsBounded nat (gcd i) (gcd/depth i)
gcd≤gcd/depth i = gcd/clocked≤gcd/depth (gcd/depth i) i

gcd/bounded : cmp (Ψ gcd/i (λ { _ → nat }) gcd/depth)
gcd/bounded = gcd , gcd≤gcd/depth


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

open import Relation.Binary using (IsEquivalence)

open import Util.Prelude
open import Util.Relation.Binary.PropositionalEquality using (cong-app)

module _ {α β} {A : Set α} {B : A → Set β} where

  _~_ : (f g : ∀ a → B a) → Set (α ⊔ℓ β)
  f ~ g = ∀ a → f a ≡ g a

  ~-refl : ∀ {f} → f ~ f
  ~-refl a = refl

  ~-sym : ∀ {f g} → f ~ g → g ~ f
  ~-sym f~g a = sym (f~g a)

  ~-trans : ∀ {f g h} → f ~ g → g ~ h → f ~ h
  ~-trans f~g g~h a = trans (f~g a) (g~h a)

  ~-IsEquivalence : IsEquivalence _~_
  ~-IsEquivalence = record { refl = ~-refl ; sym = ~-sym ; trans = ~-trans }

  ≡→~ : ∀ {f g} → f ≡ g → f ~ g
  ≡→~ = cong-app


module PartiallyAppliedConstructorInIndex where

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

data D : (Nat -> Nat) -> Set where
  c : D suc
  d : (x : Nat) -> D (plus x)
  e : D (\ x -> suc x)

f : D suc -> Nat
f c = zero
f e = suc zero


module RandomAccessList.Zeroless.Core where

open import BuildingBlock.BinaryLeafTree using (BinaryLeafTree; Node; Leaf)

open import Data.Nat
open import Data.Nat.Etc

--  parameterized by the level of the least significant digit
data 1-2-RAL (A : Set) : ℕ → Set where
    []     : ∀ {n}                                                               → 1-2-RAL A n
    _1∷_   : ∀ {n} → BinaryLeafTree A n                      → 1-2-RAL A (suc n) → 1-2-RAL A n
    _,_2∷_ : ∀ {n} → BinaryLeafTree A n → BinaryLeafTree A n → 1-2-RAL A (suc n) → 1-2-RAL A n

infixr 2 _1∷_
infixr 2 _,_2∷_
--------------------------------------------------------------------------------
-- to ℕ

⟦_⟧ₙ : ∀ {A n} → 1-2-RAL A n → ℕ
⟦          [] ⟧ₙ = 0
⟦ x     1∷ xs ⟧ₙ = 1 + 2 * ⟦ xs ⟧ₙ
⟦ x , y 2∷ xs ⟧ₙ = 2 + 2 * ⟦ xs ⟧ₙ

⟦_⟧ : ∀ {n A} → 1-2-RAL A n → ℕ
⟦_⟧ {n} xs = 2 ^ n * ⟦ xs ⟧ₙ


module TerminationMixingTupledCurried where

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

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

good : Nat × Nat -> Nat -> Nat
good (succ x , y) z = good (x , succ y) (succ z)
good (x , succ y) z = good (x , y) x
good xy (succ z) = good xy z
good _ _ = zero


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

open import Cubical.Foundations.Prelude

open import Cubical.Algebra.Group
open import Cubical.Algebra.AbGroup

open import Cubical.Algebra.Direct-Sum.Base

private variable
  ℓ ℓ' : Level

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

  inv : ⊕ Idx P AGP → ⊕ Idx P AGP
  inv = DS-Rec-Set.f Idx P AGP (⊕ Idx P AGP) trunc
           -- elements
           neutral
           (λ r a → base r (AbGroupStr.-_ (AGP r) a))
           (λ xs ys → xs add ys)
           -- eq group
           (λ xs ys zs → addAssoc xs ys zs)
           (λ xs → addRid xs)
           (λ xs ys → addComm xs ys)
           -- eq base
           (λ r → let open AbGroupStr (AGP r) in
                   let open GroupTheory (P r , AbGroupStr→GroupStr (AGP r)) in
                   (cong (base r) inv1g) ∙ (base-neutral r))
           (λ r a b → let open AbGroupStr (AGP r) in
                       let open GroupTheory (P r , AbGroupStr→GroupStr (AGP r)) in
                       ((base r (- a) add base r (- b))   ≡⟨ (base-add r (- a) (- b)) ⟩
                       base r ((- a) + (- b))             ≡⟨ (cong (base r) (sym (invDistr b a))) ⟩
                       base r (- (b + a))                 ≡⟨ cong (base r) (cong (-_) (comm b a)) ⟩
                       base r (- (a + b)) ∎))

  rinv : (z : ⊕ Idx P AGP) → z add (inv z) ≡ neutral
  rinv = DS-Ind-Prop.f Idx P AGP (λ z → z add (inv z) ≡ neutral) (λ _ → trunc _ _)
         -- elements
         (addRid neutral)
         (λ r a → let open AbGroupStr (AGP r) in
                        ((base r a add base r (- a)) ≡⟨ base-add r a (- a) ⟩
                        base r (a + - a)             ≡⟨ cong (base r) (invr a) ⟩
                        base r 0g                    ≡⟨ base-neutral r ⟩
                        neutral ∎))
         (λ {x} {y} p q →
                        (((x add y) add ((inv x) add (inv y)))   ≡⟨ cong (λ X → X add ((inv x) add (inv y))) (addComm x y) ⟩
                        ((y add x) add (inv x add inv y))        ≡⟨ sym (addAssoc y x (inv x add inv y)) ⟩
                        (y add (x add (inv x add inv y)))        ≡⟨ cong (λ X → y add X) (addAssoc x (inv x) (inv y)) ⟩
                        (y add ((x add inv x) add inv y))        ≡⟨ cong (λ X → y add (X add (inv y))) (p) ⟩
                        (y add (neutral add inv y))              ≡⟨ cong (λ X → y add X) (addComm neutral (inv y)) ⟩
                        (y add (inv y add neutral))              ≡⟨ cong (λ X → y add X) (addRid (inv y)) ⟩
                        (y add inv y)                            ≡⟨ q ⟩
                        neutral ∎))


module Numeral.Natural.Oper.Proofs.Rewrite where

import Lvl
open import Numeral.Natural
open import Numeral.Natural.Oper
open import Numeral.Natural.Induction
open import Relator.Equals
open import Relator.Equals.Proofs
open import Syntax.Function

private variable x y : ℕ

[+]-baseₗ : 𝟎 + y ≡ y
[+]-baseₗ {x} = ℕ-elim [≡]-intro (x ↦ [≡]-with(𝐒) {𝟎 + x}{x}) x
{-# REWRITE [+]-baseₗ #-}

[+]-baseᵣ : x + 𝟎 ≡ x
[+]-baseᵣ = [≡]-intro

[+]-stepₗ : 𝐒(x) + y ≡ 𝐒(x + y)
[+]-stepₗ {x}{y} = ℕ-elim [≡]-intro (i ↦ [≡]-with(𝐒) {𝐒(x) + i} {x + 𝐒(i)}) y
{-# REWRITE [+]-stepₗ #-}

[+]-stepᵣ : x + 𝐒(y) ≡ 𝐒(x + y)
[+]-stepᵣ = [≡]-intro


module Cats.Category.Constructions.Iso where

open import Relation.Binary using (IsEquivalence ; Setoid)
open import Level

open import Cats.Category.Base
open import Cats.Util.Conv

import Relation.Binary.EqReasoning as EqReasoning

import Cats.Category.Constructions.Epi as Epi
import Cats.Category.Constructions.Mono as Mono

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

  private open module Cat = Category Cat
  open Cat.≈-Reasoning
  open Epi.Build Cat
  open Mono.Build Cat

  record _≅_ (A B : Obj) : Set (lo ⊔ la ⊔ l≈) where
    field
      forth : A ⇒ B
      back : B ⇒ A
      back-forth : back ∘ forth ≈ id
      forth-back : forth ∘ back ≈ id

  open _≅_

  instance
    HasArrow-≅ : ∀ {A B} → HasArrow (A ≅ B) lo la l≈
    HasArrow-≅ = record { Cat = Cat ; _⃗ = forth }

  ≅-equiv : IsEquivalence _≅_
  ≅-equiv = record { refl = refl ; sym = sym ; trans = trans }
    where
      refl : ∀ {A} → A ≅ A
      refl {A} = record
          { forth = id
          ; back = id
          ; back-forth = id-l
          ; forth-back = id-l
          }

      sym : ∀ {A B} → A ≅ B → B ≅ A
      sym iso = record
          { forth = back iso
          ; back = forth iso
          ; back-forth = forth-back iso
          ; forth-back = back-forth iso
          }

      trans : ∀ {A B C : Obj} → A ≅ B → B ≅ C → A ≅ C
      trans {A} {B} {C} A≅B B≅C = record
          { forth = forth B≅C ∘ forth A≅B
          ; back = back A≅B ∘ back B≅C
          ; back-forth
              = begin
                  (back A≅B ∘ back B≅C) ∘ forth B≅C ∘ forth A≅B
                ≈⟨ assoc ⟩
                  back A≅B ∘ back B≅C ∘ forth B≅C ∘ forth A≅B
                ≈⟨ ∘-resp-r (≈.trans unassoc (∘-resp-l (back-forth B≅C))) ⟩
                  back A≅B ∘ id ∘ forth A≅B
                ≈⟨ ∘-resp-r id-l ⟩
                  back A≅B ∘ forth A≅B
                ≈⟨ back-forth A≅B ⟩
                  id
                ∎
          ; forth-back
              = begin
                  (forth B≅C ∘ forth A≅B) ∘ back A≅B ∘ back B≅C
                ≈⟨ assoc ⟩
                  forth B≅C ∘ forth A≅B ∘ back A≅B ∘ back B≅C
                ≈⟨ ∘-resp-r (≈.trans unassoc (∘-resp-l (forth-back A≅B))) ⟩
                  forth B≅C ∘ id ∘ back B≅C
                ≈⟨ ∘-resp-r id-l ⟩
                  forth B≅C ∘ back B≅C
                ≈⟨ forth-back B≅C ⟩
                  id
                ∎
          }

  ≅-Setoid : Setoid lo (lo ⊔ la ⊔ l≈)
  ≅-Setoid = record
      { Carrier = Obj
      ; _≈_ = _≅_
      ; isEquivalence = ≅-equiv
      }

  module ≅ = IsEquivalence ≅-equiv
  module ≅-Reasoning = EqReasoning ≅-Setoid

  iso-mono : ∀ {A B} (iso : A ≅ B) → IsMono (forth iso)
  iso-mono iso {g = g} {h} iso∘g≈iso∘h
      = begin
          g
        ≈⟨ ≈.sym id-l ⟩
          id ∘ g
        ≈⟨ ∘-resp-l (≈.sym (back-forth iso)) ⟩
          (back iso ∘ forth iso) ∘ g
        ≈⟨ assoc ⟩
          back iso ∘ forth iso ∘ g
        ≈⟨ ∘-resp-r iso∘g≈iso∘h ⟩
          back iso ∘ forth iso ∘ h
        ≈⟨ unassoc ⟩
          (back iso ∘ forth iso) ∘ h
        ≈⟨ ∘-resp-l (back-forth iso) ⟩
          id ∘ h
        ≈⟨ id-l ⟩
          h
        ∎

  iso-epi : ∀ {A B} (iso : A ≅ B) → IsEpi (forth iso)
  iso-epi iso {g = g} {h} g∘iso≈h∘iso
      = begin
          g
        ≈⟨ ≈.sym id-r ⟩
          g ∘ id
        ≈⟨ ∘-resp-r (≈.sym (forth-back iso)) ⟩
          g ∘ forth iso ∘ back iso
        ≈⟨ unassoc ⟩
          (g ∘ forth iso) ∘ back iso
        ≈⟨ ∘-resp-l g∘iso≈h∘iso ⟩
          (h ∘ forth iso) ∘ back iso
        ≈⟨ assoc ⟩
          h ∘ forth iso ∘ back iso
        ≈⟨ ∘-resp-r (forth-back iso) ⟩
          h ∘ id
        ≈⟨ id-r ⟩
          h
        ∎


------------------------------------------------------------------------------
-- Distributive laws properties
------------------------------------------------------------------------------

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

module DistributiveLaws.PropertiesI where

open import DistributiveLaws.Base

------------------------------------------------------------------------------
-- Congruence properties

-- The propositional equality is compatible with the binary operation.

·-leftCong : ∀ {a b c} → a ≡ b → a · c ≡ b · c
·-leftCong refl = refl

·-rightCong : ∀ {a b c} → b ≡ c → a · b ≡ a · c
·-rightCong refl = refl


module MLib.Matrix.Core where

open import MLib.Prelude
open import MLib.Algebra.PropertyCode
open import MLib.Algebra.PropertyCode.Structures

import Relation.Binary.Indexed as I

Matrix : ∀ {a} → Set a → ℕ → ℕ → Set a
Matrix A m n = Fin m → Fin n → A

module _ {a} (A : Set a) where
  row : ∀ {m n} → Fin m → Matrix A m n → Table A n
  row i M .lookup j = M i j

  col : ∀ {m n} → Fin n → Matrix A m n → Table A m
  col j M .lookup i = M i j


{-# OPTIONS --without-K #-}
module combination where

open import Type
open import Data.Nat.NP
open import Data.Nat.DivMod
open import Data.Fin using (Fin; Fin′; zero; suc) renaming (toℕ to Fin▹ℕ)
open import Data.Zero
open import Data.One
open import Data.Two
open import Data.Sum
open import Data.Product
open import Data.Vec
open import Function.NP
open import Function.Related.TypeIsomorphisms.NP
import Function.Inverse.NP as Inv
open Inv using (_↔_; sym; inverses; module Inverse) renaming (_$₁_ to to; _$₂_ to from; id to idI; _∘_ to _∘I_)
open import Relation.Binary.Product.Pointwise
open import Relation.Binary.Sum
import Relation.Binary.PropositionalEquality as ≡

open import factorial

_/_ : ℕ → ℕ → ℕ
x / y = _div_ x y {{!!}}

module v0 where

  C : ℕ → ℕ → ℕ
  C n       zero    = 1
  C zero    (suc k) = 0
  C (suc n) (suc k) = C n k + C n (suc k)

  D : ℕ → ℕ → ★
  D n       zero    = 𝟙
  D zero    (suc k) = 𝟘
  D (suc n) (suc k) = D n k ⊎ D n (suc k)

  FinC≅D : ∀ n k → Fin (C n k) ↔ D n k
  FinC≅D n       zero    = Fin1↔𝟙
  FinC≅D zero    (suc k) = Fin0↔𝟘
  FinC≅D (suc n) (suc k) =  FinC≅D n k ⊎-cong FinC≅D n (suc k)
                         ∘I sym (Fin-⊎-+ (C n k) (C n (suc k)))

module v! where

  C : ℕ → ℕ → ℕ
  C n k = n ! / (k ! * (n ∸ k)!)

module v1 where

  C : ℕ → ℕ → ℕ
  C n 0 = 1
  C n (suc k) = (C n k * (n ∸ k)) / suc k

module v2 where

  C : ℕ → ℕ → ℕ
  C n       zero    = 1
  C zero    (suc k) = 0
  C (suc n) (suc k) = (C n k * suc n) / suc k

{- Σ_{0≤k<n} (C n k) ≡ 2ⁿ -}

Σ𝟙F↔F : ∀ (F : 𝟙 → ★) → Σ 𝟙 F ↔ F _
Σ𝟙F↔F F = inverses proj₂ ,_ (λ _ → ≡.refl) (λ _ → ≡.refl)

Bits = Vec 𝟚
Bits1↔𝟚 : Bits 1 ↔ 𝟚
Bits1↔𝟚 = {!!}

open v0
foo : ∀ n → Σ (Fin (suc n)) (D (suc n) ∘ Fin▹ℕ) ↔ Bits (suc n)
foo zero = ((sym Bits1↔𝟚 ∘I {!!}) ∘I Σ𝟙F↔F _) ∘I first-iso Fin1↔𝟙
foo (suc n) = {!!}


module Nats.Multiply.Assoc where

open import Nats
open import Equality
open import Function

open import Nats.Multiply.Comm
open import Nats.Multiply.Distrib

------------------------------------------------------------------------
-- internal stuffs

private

  a*1+b=a+a*b : ∀ a b → a * suc b ≡ a + a * b
  a*1+b=a+a*b a b
    rewrite nat-multiply-comm a $ suc b
          | nat-multiply-comm a b
            = refl

  a*/b*c/=/a*b/*c : ∀ a b c → a * b * c ≡ a * (b * c)
  a*/b*c/=/a*b/*c  zero   b c = refl
  a*/b*c/=/a*b/*c (suc a) b c
    rewrite a*/b*c/=/a*b/*c a b c
          | nat-multiply-comm a b
          | sym $ nat-multiply-distrib b (b * a) c
          | sym $ a*/b*c/=/a*b/*c a b c
          | nat-multiply-comm a b
            = refl

------------------------------------------------------------------------
-- public aliases

nat-multiply-assoc : ∀ a b c → a * b * c ≡ a * (b * c)
nat-multiply-assoc = a*/b*c/=/a*b/*c


-- {-# OPTIONS -v tc.cover.split.con:20 #-}

open import Common.Prelude renaming (Nat to ℕ)
open import Common.Equality

infix 3 ¬_

¬_ : Set → Set
¬ P = P → ⊥

-- Decidable relations.

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

_≟_ : (m n : ℕ) → Dec (m ≡ n)
zero  ≟ zero   = yes refl
zero  ≟ suc n  = no λ()
suc m ≟ zero   = no λ()
suc m ≟ suc n  with m ≟ n
suc m ≟ suc .m | yes refl = yes refl
suc m ≟ suc n  | no prf   = no (λ x → prf (cong pred x))

data Ty : Set where

data Cxt : Set where
  ε   : Cxt
  _,_ : (Γ : Cxt) (a : Ty) → Cxt

len : Cxt → ℕ
len ε       = 0
len (Γ , _) = suc (len Γ)

-- De Bruijn index

mutual
  Var : Cxt → Ty → Set
  Var Γ a = Var' a Γ

  data Var' (a : Ty) : (Γ : Cxt) → Set where
    zero : ∀ {Γ}                 → Var (Γ , a) a
    suc  : ∀ {Γ b} (x : Var Γ a) → Var (Γ , b) a

-- De Bruijn Level

Lev = ℕ

-- Valid de Bruijn levels.

data LookupLev : (x : Lev) (Γ : Cxt) (a : Ty) (i : Var Γ a) → Set where
  lookupZero : ∀ {Γ a} →
    LookupLev (len Γ) (Γ , a) a zero

  lookupSuc : ∀ {Γ a b x i} →
    LookupLev x Γ a i →
    LookupLev x (Γ , b) a (suc i)

record ValidLev (x : Lev) (Γ : Cxt) : Set where
  constructor validLev
  field
    {type } : Ty
    {index} : Var Γ type
    valid   : LookupLev x Γ type index

weakLev : ∀ {x Γ a} → ValidLev x Γ → ValidLev x (Γ , a)
weakLev (validLev d) = validLev (lookupSuc d)

-- Looking up a de Bruijn level.

lookupLev : ∀ (x : Lev) (Γ : Cxt) → Dec (ValidLev x Γ)
lookupLev x ε = no λ { (validLev ()) }
lookupLev x (Γ , a) with x ≟ len Γ
lookupLev ._ (Γ , a) | yes refl = yes (validLev lookupZero)
lookupLev x (Γ , a) | no _ with lookupLev x Γ
lookupLev x (Γ , a) | no ¬p | yes d = yes (weakLev d)
lookupLev x (Γ , a) | no ¬p | no ¬d = no contra
  where
    contra : ¬ ValidLev x (Γ , a)
    contra (validLev (lookupSuc valid)) = ?

{- Unbound indices showing up in error message:

I'm not sure if there should be a case for the constructor
lookupZero, because I get stuck when trying to solve the following
unification problems (inferred index ≟ expected index):
  len Γ ≟ @8
  Γ , a ≟ @7 , @4
  a ≟ type
  zero ≟ index
when checking the definition of contra -}


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

module Categories.Category.Regular where

-- https://ncatlab.org/nlab/show/regular+category
-- https://en.wikipedia.org/wiki/Regular_category

open import Level

open import Categories.Category.Core
open import Categories.Category.Complete.Finitely using (FinitelyComplete)
open import Categories.Diagram.Coequalizer
open import Categories.Diagram.KernelPair
open import Categories.Diagram.Pullback
open import Categories.Morphism.Regular

record Regular {o ℓ e : Level} (𝒞 : Category o ℓ e) : Set (suc (o ⊔ ℓ ⊔ e)) where
  open Category 𝒞
  open Pullback

  field
    finitely-complete : FinitelyComplete 𝒞
    coeq-of-kernelpairs : {A B : Obj} (f : A ⇒ B) (kp : KernelPair 𝒞 f) → Coequalizer 𝒞 (p₁ kp) (p₂ kp)
    pullback-of-regularepi-is-regularepi : {A B C : Obj} (f : B ⇒ A) {g : C ⇒ A} → RegularEpi 𝒞 f → (p : Pullback 𝒞 f g) → RegularEpi 𝒞 (p₂ p)


open import x1-Base
open import x4-Nat
open import x3-PropositionalEquality using (_≡_; refl; cong; equivalence)
open import x2-Sort _≤?_ totalOrder

module x5-Test where

empty : OList ⊥ ⊤
empty = nil ⊥≤̂

l-9 : OList ⊥ ⊤
l-9 = insert 9 empty ⊥≤̂ ≤̂⊤

_ : l-9 ≡ cons 9 (nil ≤̂⊤) ⊥≤̂
_ = refl

l-5-9 : OList ⊥ ⊤
l-5-9 = insert 5 l-9 ⊥≤̂ ≤̂⊤

_ : l-5-9 ≡ cons 5
                 (cons 9
                       (nil ≤̂⊤)
                       (≤-lift (s≤s (s≤s (s≤s (s≤s (s≤s z≤n)))))))
                 ⊥≤̂
_ = refl

l-1-5-9 : OList ⊥ ⊤
l-1-5-9 = insert 1 l-5-9 ⊥≤̂ ≤̂⊤

_ : l-1-5-9 ≡ cons 1
                   (cons 5
                         (cons 9
                               (nil ≤̂⊤)
                               (≤-lift (s≤s (s≤s (s≤s (s≤s (s≤s z≤n)))))))
                         (≤-lift (s≤s z≤n))) -- NOTE CHANGE
                   ⊥≤̂
_ = refl

sl : List ℕ
sl = t-sort (12 ∷ 3 ∷ 7 ∷ 4 ∷ 40 ∷ 5 ∷ 0 ∷ [])

_ : sl ≡ (0 ∷ 3 ∷ 4 ∷ 5 ∷ 7 ∷ 12 ∷ 40 ∷ [])
_ = refl


module Numeral.Integer where

import      Lvl
open import Numeral.Natural      as ℕ using (ℕ)
import      Numeral.Natural.Oper as ℕ
open import Syntax.Number
open import Type

-- Integers
data ℤ : Type{Lvl.𝟎} where
  +ₙ_  : ℕ → ℤ -- Positive integers including zero from the naturals (0,1,..).
  −𝐒ₙ_ : ℕ → ℤ -- Negative integers from the naturals (..,−2,−1).

{-# BUILTIN INTEGER        ℤ  #-}
{-# BUILTIN INTEGERPOS     +ₙ_ #-}
{-# BUILTIN INTEGERNEGSUC −𝐒ₙ_ #-}

------------------------------------------
-- Constructors and deconstructors

-- Constructing negative number from ℕ
−ₙ_ : ℕ → ℤ
−ₙ (ℕ.𝟎)    = +ₙ ℕ.𝟎
−ₙ (ℕ.𝐒(x)) = −𝐒ₙ(x)

-- Intuitive constructor patterns
pattern 𝟎      = +ₙ(ℕ.𝟎)    -- Zero (0).
pattern +𝐒ₙ_ n = +ₙ(ℕ.𝐒(n)) -- Positive integers from the naturals (1,2,..).
pattern 𝟏      = +ₙ(ℕ.𝟏)    -- One (1).
pattern −𝟏     = −𝐒ₙ(ℕ.𝟎)   -- Negative one (−1).
{-# DISPLAY ℤ.+ₙ_ ℕ.𝟎  = 𝟎 #-}
{-# DISPLAY ℤ.+ₙ_ ℕ.𝟏  = 𝟏 #-}
{-# DISPLAY ℤ.−𝐒ₙ_ ℕ.𝟎 = −𝟏 #-}
{-# DISPLAY ℤ.+ₙ_(ℕ.𝐒(n)) = +𝐒ₙ_ n #-}

-- Absolute value
absₙ : ℤ → ℕ
absₙ(+ₙ x)   = x
absₙ(−𝐒ₙ(x)) = ℕ.𝐒(x)

-- Syntax
instance
  ℤ-InfiniteNegativeNumeral : InfiniteNegativeNumeral(ℤ)
  ℤ-InfiniteNegativeNumeral = InfiniteNegativeNumeral.intro(−ₙ_)

instance
  ℤ-InfiniteNumeral : InfiniteNumeral(ℤ)
  ℤ-InfiniteNumeral = InfiniteNumeral.intro(+ₙ_)


module Prelude.Monoid where

open import Prelude.Function
open import Prelude.Maybe
open import Prelude.List
open import Prelude.Semiring
open import Prelude.Applicative
open import Prelude.Functor

record Monoid {a} (A : Set a) : Set a where
  infixr 6 _<>_
  field
    mempty : A
    _<>_   : A → A → A

open Monoid {{...}} public

{-# DISPLAY Monoid.mempty _ = mempty #-}
{-# DISPLAY Monoid._<>_ _ a b = a <> b #-}

mconcat : ∀ {a} {A : Set a} {{MonA : Monoid A}} → List A → A
mconcat = foldr _<>_ mempty

--- Instances ---

instance
  MonoidList : ∀ {a} {A : Set a} → Monoid (List A)
  mempty {{MonoidList}} = []
  _<>_   {{MonoidList}} = _++_

  MonoidFun : ∀ {a b} {A : Set a} {B : A → Set b} {{_ : ∀ {x} → Monoid (B x)}} → Monoid (∀ x → B x)
  mempty {{MonoidFun}}     _ = mempty
  _<>_   {{MonoidFun}} f g x = f x <> g x

  MonoidMaybe : ∀ {a} {A : Set a} → Monoid (Maybe A)
  mempty {{MonoidMaybe}} = nothing
  _<>_   {{MonoidMaybe}} nothing  y = y
  _<>_   {{MonoidMaybe}} (just x) _ = just x

record Sum {a} (A : Set a) : Set a where
  constructor mkSum
  field getSum : A

open Sum public

instance
  MonoidSum : ∀ {a} {A : Set a} {{_ : Semiring A}} → Monoid (Sum A)
  getSum (mempty {{MonoidSum}})     = zro
  getSum (_<>_   {{MonoidSum}} x y) = getSum x + getSum y

record Product {a} (A : Set a) : Set a where
  constructor mkProduct
  field getProduct : A

open Product public

instance
  MonoidProduct : ∀ {a} {A : Set a} {{_ : Semiring A}} → Monoid (Product A)
  getProduct (mempty {{MonoidProduct}})     = one
  getProduct (_<>_   {{MonoidProduct}} x y) = getProduct x * getProduct y

record Const {a b} (A : Set a) (B : Set b) : Set a where
  constructor mkConst
  field getConst : A

open Const public

module _ {a b} {A : Set a} {{MonA : Monoid A}} where
  instance
    FunctorConst : Functor {a = b} (Const A)
    getConst (fmap {{FunctorConst}} f x) = getConst x

    ApplicativeConst : Applicative (Const A)
    getConst (pure  {{ApplicativeConst}} x)     = mempty
    getConst (_<*>_ {{ApplicativeConst}} wf wx) = getConst wf <> getConst wx


module Structure.Function where

import Lvl
open import Lang.Instance
open import Logic.Predicate
open import Logic
open import Structure.Function.Names
open import Structure.Setoid
open import Type

private variable ℓ ℓₒ ℓₒ₁ ℓₒ₂ ℓₒ₃ ℓₗ ℓₗ₁ ℓₗ₂ ℓₗ₃ : Lvl.Level
private variable A B : Type{ℓ}

-- The function `f` "(behaves like)/is a function" in the context of `_≡_` from the Equiv instance.
-- `congruence` is the defining property of a function.
module _
  ⦃ equiv-A : Equiv{ℓₗ₁}(A) ⦄
  ⦃ equiv-B : Equiv{ℓₗ₂}(B) ⦄
  (f : A → B)
  where

  record Function : Stmt{Lvl.of(A) Lvl.⊔ ℓₗ₁ Lvl.⊔ ℓₗ₂} where
    constructor intro
    field congruence : Congruence₁(f)
  congruence₁ = inst-fn Function.congruence

_→ᶠⁿ_ : (A : Setoid{ℓₗ₁}{ℓₒ₁}) → (B : Setoid{ℓₗ₂}{ℓₒ₂}) → Type{ℓₒ₁ Lvl.⊔ ℓₒ₂ Lvl.⊔ ℓₗ₁ Lvl.⊔ ℓₗ₂}
([∃]-intro A) →ᶠⁿ ([∃]-intro B) = ∃(Function{A = A}{B = B})


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

open import Categories.Category

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

open import Level
open import Data.Product
open import Data.Unit

open import Relation.Binary using (Poset)

open import Categories.Functor
open import Categories.Category.Slice
open import Categories.Category.SubCategory
open import Categories.Category.Construction.Thin
import Categories.Morphism as Mor
import Categories.Morphism.Reasoning as MR
open import Categories.Morphism.Notation

private
  module 𝒞 = Category 𝒞

-- The Full Subcategory of the over category 𝒞/c on monomorphisms
slice-mono : 𝒞.Obj → Category _ _ _
slice-mono c = FullSubCategory (Slice 𝒞 c) {I = Σ[ α ∈ 𝒞.Obj ](α ↣ c)} λ (_ , i) → sliceobj (mor i)
  where open Mor 𝒞
        open _↣_

-- Poset of subobjects for some c ∈ 𝒞
Subobjects : 𝒞.Obj → Poset _ _ _
Subobjects c = record
  { Carrier = 𝒞ᶜ.Obj
  ; _≈_ = 𝒞ᶜ [_≅_]
  ; _≤_ = 𝒞ᶜ [_,_]
  ; isPartialOrder = record
    { isPreorder = record
      { isEquivalence = Mor.≅-isEquivalence 𝒞ᶜ
      ; reflexive = λ iso → Mor._≅_.from iso
      ; trans = λ {(α , f) (β , g) (γ , h)} i j → slicearr (chase f g h i j)
      }
    ; antisym = λ {(α , f) (β , g)} h i → record
      { from = h
      ; to = i
      ; iso = record
        { isoˡ = mono f _ _ (chase f g f h i ○ ⟺ 𝒞.identityʳ)
        ; isoʳ = mono g _ _ (chase g f g i h ○ ⟺ 𝒞.identityʳ)
        }
      }
    }
  }
  where
    𝒞ᶜ : Category _ _ _
    𝒞ᶜ = slice-mono c

    module 𝒞ᶜ = Category 𝒞ᶜ

    open Mor 𝒞 using (_↣_)
    open MR 𝒞
    open 𝒞.HomReasoning
    open _↣_

    chase : ∀ {α β γ : 𝒞.Obj} (f : 𝒞 [ α ↣ c ]) (g : 𝒞 [ β ↣ c ]) (h : 𝒞 [ γ ↣ c ])
            → (i : 𝒞ᶜ [ (α , f) , (β , g) ]) → (j : 𝒞ᶜ [ (β , g) , (γ , h) ])
            → 𝒞 [ 𝒞 [ mor h ∘ 𝒞 [ Slice⇒.h j ∘ Slice⇒.h i ] ] ≈ mor f ]
    chase f g h i j = begin
      𝒞 [ mor h ∘ 𝒞 [ Slice⇒.h j ∘ Slice⇒.h i ] ] ≈⟨ pullˡ (Slice⇒.△ j)  ⟩
      𝒞 [ mor g ∘ Slice⇒.h i ]                    ≈⟨ Slice⇒.△ i ⟩
      mor f ∎


{-# OPTIONS --safe #-}
module Cubical.Algebra.CommRing.Instances.Int where

open import Cubical.Foundations.Prelude

open import Cubical.Algebra.CommRing
open import Cubical.Data.Int as Int
  renaming ( ℤ to ℤType ; _+_ to _+ℤ_; _·_ to _·ℤ_; -_ to -ℤ_)

open CommRingStr

ℤ : CommRing ℓ-zero
fst ℤ = ℤType
0r (snd ℤ) = 0
1r (snd ℤ) = 1
_+_ (snd ℤ) = _+ℤ_
_·_ (snd ℤ) = _·ℤ_
- snd ℤ = -ℤ_
isCommRing (snd ℤ) = isCommRingℤ
  where
  abstract
    isCommRingℤ : IsCommRing 0 1 _+ℤ_ _·ℤ_ -ℤ_
    isCommRingℤ = makeIsCommRing isSetℤ Int.+Assoc (λ _ → refl)
                                 -Cancel Int.+Comm Int.·Assoc
                                 Int.·Rid ·DistR+ Int.·Comm


module Oscar.Class.Substitution where

open import Oscar.Data.Equality
open import Oscar.Function
open import Oscar.Relation
open import Oscar.Level

record Substitution {a} {A : Set a} {b} (B : A → Set b) {c} (C : A → Set c) : Set (a ⊔ b ⊔ c) where
  field
    ε : ∀ {m} → B m → C m
    _◇_ : ∀ {l m n} → (g : B m → C n) (f : B l → C m) → B l → C n
    ◇-left-identity : ∀ {m n} → (f : B m → C n) → ε ◇ f ≡̇ f
    ◇-right-identity : ∀ {m n} → (f : B m → C n) → f ◇ ε ≡̇ f
    ◇-associativity : ∀ {k l m n} (f : B k → C l) (g : B l → C m) (h : B m → C n) → h ◇ (g ◇ f) ≡̇ (h ◇ g) ◇ f

open Substitution ⦃ … ⦄ public

{-# DISPLAY Substitution._◇_ _ = _◇_ #-}

instance Substitution-id : ∀ {a} {A : Set a} {bc} {BC : A → Set bc} → Substitution BC BC
Substitution.ε Substitution-id = id
Substitution._◇_ Substitution-id g f = g ∘ f
Substitution.◇-left-identity Substitution-id _ _ = refl
Substitution.◇-right-identity Substitution-id _ _ = refl
Substitution.◇-associativity Substitution-id _ _ _ _ = refl


module BTree.Equality {A : Set} where

open import BTree {A}

data _≃_ : BTree → BTree → Set where
  ≃lf : leaf ≃ leaf
  ≃nd : {l r l' r' : BTree}
                    (x x' : A)
                   → l ≃ r
                   → l ≃ l'
                   → l' ≃ r'
                   → node x l r ≃ node x' l' r'


module Logic.Operations where

import Logic.Relations as Rel
import Logic.Equivalence as Eq
open Eq using (Equivalence; module Equivalence)

BinOp : Set -> Set
BinOp A = A -> A -> A

module MonoEq {A : Set}(Eq : Equivalence A) where

  module EqEq = Equivalence Eq
  open EqEq

  Commutative : BinOp A -> Set
  Commutative _+_ = (x y : A) -> (x + y) == (y + x)

  Associative : BinOp A -> Set
  Associative _+_ = (x y z : A) -> (x + (y + z)) == ((x + y) + z)

  LeftIdentity : A -> BinOp A -> Set
  LeftIdentity z _+_ = (x : A) -> (z + x) == x

  RightIdentity : A -> BinOp A -> Set
  RightIdentity z _+_ = (x : A) -> (x + z) == x

module Param where

  Commutative : {A : Set}(Eq : Equivalence A) -> BinOp A -> Set
  Commutative Eq = Op.Commutative
    where module Op = MonoEq Eq

  Associative : {A : Set}(Eq : Equivalence A) -> BinOp A -> Set
  Associative Eq = Op.Associative
    where module Op = MonoEq Eq

  LeftIdentity : {A : Set}(Eq : Equivalence A) -> A -> BinOp A -> Set
  LeftIdentity Eq = Op.LeftIdentity
    where module Op = MonoEq Eq

  RightIdentity : {A : Set}(Eq : Equivalence A) -> A -> BinOp A -> Set
  RightIdentity Eq = Op.RightIdentity
    where module Op = MonoEq Eq


module Data.List.First.Membership {ℓ}{A : Set ℓ} where

open import Data.Product
open import Data.List
open import Data.List.Relation.Unary.Any
open import Data.List.First hiding (find)
open import Relation.Nullary
open import Relation.Binary
open import Relation.Binary.PropositionalEquality
open import Level
open import Function
open import Data.Empty

_∈_ : A → List A → Set _
x ∈ l = first x ∈ l ⇒ (_≡_ x)

¬x∈[] : ∀ {x} → ¬ x ∈ []
¬x∈[] ()

find : Decidable (_≡_ {A = A}) → ∀ x l → Dec (x ∈ l)
find _≟_ x [] = no (λ ())
find _≟_ x (y ∷ l) with x ≟ y
... | yes refl = yes (here refl)
... | no  neq  with find _≟_ x l
... | yes p    = yes (there y neq p)
... | no  ¬p   = no (λ{ (here eq) → neq eq ; (there _ _ p) → ¬p p})


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

--  Restriction Functor
module Categories.Functor.Restriction where

open import Level using (Level; _⊔_)

open import Categories.Category using (Category; _[_,_]; _[_≈_])
open import Categories.Category.Restriction using (Restriction)
open import Categories.Functor using (Functor; _∘F_) renaming (id to idF)

private
  variable
    o ℓ e o′ ℓ′ e′ o″ ℓ″ e″ : Level
    C : Category o ℓ e
    D : Category o′ ℓ′ e′
    E : Category o″ ℓ″ e″

record RestrictionF {C : Category o ℓ e} {D : Category o′ ℓ′ e′}
  (RC : Restriction C) (RD : Restriction D) : Set (o ⊔ ℓ ⊔ e ⊔ o′ ⊔ ℓ′ ⊔ e′) where
  private
    module C = Category C using (Obj)
    module RC = Restriction RC
    module RD = Restriction RD
  field
    Func : Functor C D
  open Functor Func using (F₁)
  field
    F-resp-↓ : {A B : C.Obj} → (f : C [ A , B ]) → D [ F₁ (f RC.↓) ≈ (F₁ f) RD.↓ ]

id : {RC : Restriction C} → RestrictionF RC RC
id {C = C} = record { Func = idF ; F-resp-↓ = λ f → Category.Equiv.refl C }

_∘R_ : {RC : Restriction C} {RD : Restriction D} {RE : Restriction E} → RestrictionF RD RE → RestrictionF RC RD → RestrictionF RC RE
_∘R_ {C = C} {E = E} {RC} {RD} {RE} F G = record
  { Func = Func F ∘F Func G
  ; F-resp-↓ = resp
  }
  where
    open RestrictionF
    open Category E using (_≈_; module HomReasoning)
    open HomReasoning
    module F = Functor (Func F)
    module G = Functor (Func G)
    module RC = Restriction RC
    module RD = Restriction RD
    module RE = Restriction RE
    resp : ∀ {A B : Category.Obj C} → (f : C [ A , B ]) → F.₁ (G.₁ (f RC.↓)) ≈ F.₁ (G.₁ f) RE.↓
    resp f = begin
       F.₁ (G.₁ (f RC.↓)) ≈⟨ F.F-resp-≈ (F-resp-↓ G f) ⟩
       F.₁ ((G.₁ f) RD.↓) ≈⟨ F-resp-↓ F _ ⟩
       F.₁ (G.₁ f) RE.↓ ∎


------------------------------------------------------------------------------
-- Testing some inductive predicates for inequalities
------------------------------------------------------------------------------

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

module FOT.FOTC.Data.Nat.Inequalities.InductivePredicates where

open import FOTC.Base
open import FOTC.Data.Nat.Type
open import FOTC.Data.Nat.UnaryNumbers

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

module m₁ where
  data _≤_ : D → D → Set where
    z≤n : ∀ n → zero ≤ n
    s≤s : ∀ {m n} → m ≤ n → succ₁ m ≤ succ₁ n

  _<_ : D → D → Set
  m < n = succ₁ m ≤ n

  _≥_ : D → D → Set
  m ≥ n = n ≤ m

  _>_ : D → D → Set
  m > n = n < m

  x≤y→x≤Sy : ∀ {m n} → m ≤ n → m ≤ succ₁ n
  x≤y→x≤Sy {.zero} {n} (z≤n .n)  = z≤n (succ₁ n)
  x≤y→x≤Sy             (s≤s m≤n) = s≤s (x≤y→x≤Sy m≤n)

module m₂ where
  data _≤_ : D → D → Set where
    z≤n : ∀ {n} → N n → zero ≤ n
    s≤s : ∀ {m n} → N m → N n → m ≤ n → succ₁ m ≤ succ₁ n

  _<_ : D → D → Set
  m < n = succ₁ m ≤ n

  _≥_ : D → D → Set
  m ≥ n = n ≤ m

  _>_ : D → D → Set
  m > n = n < m

  x≤y→x≤Sy : ∀ {m n} → m ≤ n → m ≤ succ₁ n
  x≤y→x≤Sy (z≤n Nn)        = z≤n (nsucc Nn)
  x≤y→x≤Sy (s≤s Nm Nn m≤n) = s≤s Nm (nsucc Nn) (x≤y→x≤Sy m≤n)

  postulate
    lt    : D → D → D
    lt-00 : lt zero zero                   ≡ false
    lt-0S : ∀ n → lt zero (succ₁ n)        ≡ true
    lt-S0 : ∀ n → lt (succ₁ n) zero        ≡ false
    lt-SS : ∀ m n → lt (succ₁ m) (succ₁ n) ≡ lt m n

  le : D → D → D
  le m n = lt m (succ₁ n)

  ≤→le : ∀ {m n} → m ≤ n → le m n ≡ true
  ≤→le {n = n} (z≤n Nn) = lt-0S n
  ≤→le (s≤s nzero nzero h) = trans (lt-SS zero 1') (≤→le h)
  ≤→le (s≤s nzero (nsucc {n} Nn) h) = trans (lt-SS zero (succ₁ (succ₁ n))) (≤→le h)
  ≤→le (s≤s (nsucc {m} Nm) nzero h) = trans (lt-SS (succ₁ m) 1') (≤→le h)
  ≤→le (s≤s (nsucc {m} Nm) (nsucc {n} Nn) h) =
    trans (lt-SS (succ₁ m) (succ₁ (succ₁ n))) (≤→le h)

  le→≤ : ∀ {m n} → N m → N n → le m n ≡ true → m ≤ n
  le→≤ nzero Nn h = z≤n Nn
  le→≤ (nsucc nzero) nzero h =
    ⊥-elim (t≢f (trans (sym h) (trans (lt-SS zero zero) lt-00)))
  le→≤ (nsucc (nsucc {m} Nm)) nzero h =
    ⊥-elim (t≢f (trans (sym h) (trans (lt-SS (succ₁ m) zero) (lt-S0 m))))
  {-# CATCHALL #-}
  le→≤ (nsucc {m} Nm) (nsucc {n} Nn) h =
    s≤s Nm Nn (le→≤ Nm Nn (trans (sym (lt-SS m (succ₁ n))) h))

module m₃ where
  data _≤_ : ∀ {m n} → N m → N n → Set where
    z≤n : ∀ {n} → (Nn : N n)                          → nzero ≤ Nn
    s≤s : ∀ {m n} → (Nm : N m) → (Nn : N n) → Nm ≤ Nn → nsucc Nm ≤ nsucc Nn

  _<_ : ∀ {m n} → N m → N n → Set
  Nm < Nn = nsucc Nm ≤ Nn

  _≥_ : ∀ {m n} → N m → N n → Set
  Nm ≥ Nn = Nn ≤ Nm

  _>_ : ∀ {m n} → N m → N n → Set
  Nm > Nn = Nn < Nm

  x≤y→x≤Sy : ∀ {m n} → (Nm : N m) → (Nn : N n) → Nm ≤ Nn → Nm ≤ nsucc Nn
  x≤y→x≤Sy .nzero       Nn         (z≤n .Nn)         = z≤n (nsucc Nn)
  x≤y→x≤Sy .(nsucc Nm) .(nsucc Nn) (s≤s Nm Nn Nm≤Nn) =
    s≤s Nm (nsucc Nn) (x≤y→x≤Sy Nm Nn Nm≤Nn)


module plfa-code.Equality where

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

infix 4 _≡_

sym : ∀ {A : Set} {x y : A}
  → x ≡ y
    -------
  → y ≡ x
sym refl = refl

trans : ∀ {A : Set} {x y z : A}
  → x ≡ y
  → y ≡ z
    -------
  → x ≡ z
trans refl refl = refl

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

cong₂ : ∀ {A B C : Set} (f : A → B → C) {u x : A} {v y : B}
  → u ≡ x
  → v ≡ y
    ---------------
  → f u v ≡ f x y
cong₂ _ refl refl  =  refl

cong-app : ∀ {A B : Set} {f g : A → B}
  → f ≡ g
    ------------------------
  → ∀ (x : A) → f x ≡ g x
cong-app refl _ = refl

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

module ≡-Reasoning {A : Set} where

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

  begin_ : ∀ {x y : A}
    → x ≡ y
      -------
    → x ≡ y
  begin x≡y = x≡y

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

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

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

open ≡-Reasoning

trans′ : ∀ {A : Set} {x y z : A}
  → x ≡ y
  → y ≡ z
    -------
  → x ≡ z
trans′ {A} {x} {y} {z} x≡y y≡z =
  begin
    x
  ≡⟨ x≡y ⟩
    y
  ≡⟨ y≡z ⟩
    z
  ∎

data ℕ : Set where
  zero : ℕ
  suc  : ℕ → ℕ

infixl 6 _+_

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

-- use postulate
postulate
  +-identity : ∀ (m : ℕ) → m + zero ≡ m
  +-suc : ∀ (m n : ℕ) → m + suc n ≡ suc (m + n)

+-comm : ∀ (m n : ℕ) → m + n ≡ n + m
+-comm m zero =
  begin
    m + zero
  ≡⟨ +-identity m ⟩
    m
  ≡⟨⟩
    zero + m
  ∎
+-comm m (suc n) =
  begin
    m + suc n
  ≡⟨ +-suc m n ⟩
    suc (m + n)
  ≡⟨ cong suc (+-comm m n) ⟩
    suc (n + m)
  ≡⟨⟩
    suc n + m
  ∎

data _≤_ : ℕ → ℕ → Set where

  z≤n : ∀ {n : ℕ}
      ---------
    → zero ≤ n

  s≤s : ∀ {m n : ℕ}
    → m ≤ n
      --------------
    → suc m ≤ suc n

infix 4 _≤_

postulate
  ≤-trans : ∀ {m n p : ℕ} → m ≤ n → n ≤ p → m ≤ p
  ≤-refl : ∀ {n : ℕ} → n ≤ n

≡→≤ : ∀ {x y} → x ≡ y → x ≤ y
≡→≤ refl = ≤-refl

module ≤-Reasoning where

  infix  1 ≤begin_
  infixr 2 _≤⟨⟩_ _≤⟨_⟩_ _≤[_]_
  infix  3 _≤∎

  ≤begin_ : ∀ {x y} → x ≤ y → x ≤ y
  ≤begin x≤y  =  x≤y

  _≤⟨⟩_ : ∀ (x) {y : ℕ} → x ≤ y → x ≤ y
  _ ≤⟨⟩ x≤y  =  x≤y

  _≤⟨_⟩_ : ∀ (x) {y z : ℕ} → x ≤ y → y ≤ z → x ≤ z
  x ≤⟨ x≤y ⟩ y≤z  =  ≤-trans x≤y y≤z

  _≤[_]_ : ∀ (x) {y z : ℕ} → x ≡ y → y ≤ z → x ≤ z
  x ≤[ x≡y ] y≤z = ≤-trans (≡→≤ x≡y) y≤z

  _≤∎ : ∀ x → x ≤ x
  _ ≤∎ = ≤-refl

open ≤-Reasoning

+-monoʳ-≤ : ∀ (n p q : ℕ) → p ≤ q → (n + p) ≤ (n + q)

+-monoʳ-≤ zero p q p≤q =
  ≤begin
    (zero + p)
  ≤⟨⟩
    p
  ≤⟨ p≤q ⟩
    q
  ≤⟨⟩
    zero + q
  ≤∎
+-monoʳ-≤ (suc n) p q p≤q =
  ≤begin
    suc n + p
  ≤⟨⟩
    suc (n + p)
  ≤⟨ s≤s (+-monoʳ-≤ _ _ _ p≤q) ⟩
    suc (n + q)
  ≤⟨⟩
    suc n + q
  ≤∎

+-monoˡ-≤ : ∀ (m n p : ℕ) → m ≤ n → (m + p) ≤ (n + p)
+-monoˡ-≤ m n p m≤n =
  ≤begin
    m + p
  ≤[ +-comm m p ]
    p + m
  ≤⟨ +-monoʳ-≤ p _ _ m≤n ⟩
    p + n
  ≤[ +-comm p n ]
    n + p
  ≤∎

+-mono-≤ : ∀ (m n p q : ℕ) → m ≤ n → p ≤ q → m + p ≤ n + q
+-mono-≤ m n p q m≤n p≤q =
  ≤begin
    m + p
  ≤⟨ +-monoˡ-≤ _ _ _ m≤n ⟩
    n + p
  ≤⟨ +-monoʳ-≤ _ _ _ p≤q ⟩
    n + q
  ≤∎

data even : ℕ → Set
data odd  : ℕ → Set

data even where

  even-zero : even zero

  even-suc : ∀ {n : ℕ}
    → odd n
      -------------
    → even (suc n)

data odd where
  odd-suc : ∀ {n : ℕ}
    → even n
      ------------
    → odd (suc n)

{-# BUILTIN EQUALITY _≡_ #-}

even-comm : ∀ (m n : ℕ)
  → even (m + n)
    -------------
  → even (n + m)
even-comm m n ev rewrite +-comm n m = ev

+-comm′ : ∀ (m n : ℕ) → m + n ≡ n + m
+-comm′ zero    n  rewrite +-identity n             =  refl
+-comm′ (suc m) n  rewrite +-suc n m | +-comm′ m n  =  refl

even-comm′ : ∀ (m n : ℕ)
  → even (m + n)
    ------------
  → even (n + m)
even-comm′ m n ev with   m + n  | +-comm m n
...                  | .(n + m) | refl       = ev

_≐_ : ∀ {A : Set} (x y : A) → Set₁
_≐_ {A} x y = ∀ (P : A → Set) → P x → P y

refl-≐ : ∀ {A : Set} {x : A}
  → x ≐ x
refl-≐ P Px = Px

trans-≐ : ∀ {A : Set} {x y z : A}
  → x ≐ y
  → y ≐ z
    ------
  → x ≐ z
trans-≐ x≐y y≐z P Px  =  y≐z P (x≐y P Px)

sym-≐ : ∀ {A : Set} {x y : A}
  → x ≐ y
    ------
  → y ≐ x
sym-≐ {A} {x} {y} x≐y P  =  Qy
  where
    Q : A → Set
    Q z = P z → P x
    Qx : Q x
    Qx = refl-≐ P
    Qy : Q y
    Qy = x≐y Q Qx

≡-implies-≐ : ∀ {A : Set} {x y : A}
  → x ≡ y
    -------
  → x ≐ y
≡-implies-≐ x≡y P  =  subst P x≡y

≐-implies-≡ : ∀ {A : Set} {x y : A}
  → x ≐ y
    -------
  → x ≡ y
≐-implies-≡ {A} {x} {y} x≐y = Qy
  where
    Q : A → Set
    Q z = x ≡ z
    Qx : Q x
    Qx = refl
    Qy : Q y
    Qy = x≐y Q Qx

open import Level using (Level; _⊔_) renaming (zero to lzero; suc to lsuc)

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

sym′ : ∀ {ℓ : Level} {A : Set ℓ} {x y : A}
  → x ≡′ y
    --------
  → y ≡′ x
sym′ refl′ = refl′

_≐′_ : ∀ {ℓ : Level} {A : Set ℓ} (x y : A) → Set (lsuc ℓ)
_≐′_ {ℓ} {A} x y = ∀ (P : A → Set ℓ) → P x → P y


{-# OPTIONS --rewriting #-}

module NewEquations where

open import Common.Prelude hiding (map; _++_)
open import Common.Equality

infixr 5 _++_

map : ∀ {A B : Set} → (A → B) → List A → List B
map f [] = []
map f (x ∷ xs) = (f x) ∷ (map f xs)

_++_ : ∀ {A : Set} → List A → List A → List A
[] ++ ys = ys
(x ∷ xs) ++ ys = x ∷ (xs ++ ys)

fold : ∀ {A B : Set} → (A → B → B) → B → List A → B
fold f v [] = v
fold f v (x ∷ xs) = f x (fold f v xs)

++-[] : ∀ {A} {xs : List A} → xs ++ [] ≡ xs
++-[] {xs = []} = refl
++-[] {xs = x ∷ xs} = cong (_∷_ x) ++-[]

++-assoc : ∀ {A} {xs ys zs : List A} → (xs ++ ys) ++ zs ≡ xs ++ (ys ++ zs)
++-assoc {xs = []} = refl
++-assoc {xs = x ∷ xs} = cong (_∷_ x) (++-assoc {xs = xs})

map-id : ∀ {A} {xs : List A} → map (λ x → x) xs ≡ xs
map-id {xs = []} = refl
map-id {xs = x ∷ xs} = cong (_∷_ x) map-id

map-fuse : ∀ {A B C} {f : B → C} {g : A → B} {xs : List A} → map f (map g xs) ≡ map (λ x → f (g x)) xs
map-fuse {xs = []} = refl
map-fuse {xs = x ∷ xs} = cong (_∷_ _) map-fuse

map-++ : ∀ {A B} {f : A → B} {xs ys : List A} → map f (xs ++ ys) ≡ (map f xs) ++ (map f ys)
map-++ {xs = []} = refl
map-++ {xs = x ∷ xs} = cong (_∷_ _) (map-++ {xs = xs})

fold-map : ∀ {A B C} {f : A → B} {c : B → C → C} {n : C} {xs : List A} →
           fold c n (map f xs) ≡ fold (λ x → c (f x)) n xs
fold-map {xs = []} = refl
fold-map {c = c} {xs = x ∷ xs} = cong (c _) (fold-map {xs = xs})

fold-++ : ∀ {A B} {c : A → B → B} {n : B} {xs ys : List A} →
          fold c n (xs ++ ys) ≡ fold c (fold c n ys) xs
fold-++ {xs = []} = refl
fold-++ {c = c} {xs = x ∷ xs} = cong (c _) (fold-++ {xs = xs})

{-# BUILTIN REWRITE _≡_ #-}
{-# REWRITE ++-[] #-}
{-# REWRITE ++-assoc #-}
{-# REWRITE map-id #-}
{-# REWRITE map-fuse #-}
{-# REWRITE map-++ #-}
{-# REWRITE fold-map #-}
{-# REWRITE fold-++ #-}

record _×_ (A B : Set) : Set where
  constructor _,_
  field
    fst : A
    snd : B

swap : ∀ {A B} → A × B → B × A
swap (x , y) = y , x

test₁ : ∀ {A B} {xs : List (A × B)} → map swap (map swap xs) ≡ xs
test₁ = refl


{-# OPTIONS --without-K #-}
module Relation.Path.Operation where

open import Basics
open import Relation.Equality
open import Data.Product

infixr 4 _∙_
infix 9 _⁻¹

-- Path inversion
_⁻¹ : ∀ {a}{A : Set a}{x y : A} → (x ≡ y) → (y ≡ x)
_⁻¹ = ind₌ (λ x y _ → y ≡ x) (λ _ → refl) _ _

-- Composition of paths
_∙_ : ∀ {a}{A : Set a}{x y z : A} → (x ≡ y) → (y ≡ z) → (x ≡ z)
_∙_ {z = z} = ind₌ (λ x y _ → y ≡ z → x ≡ z) (λ _ p → p) _ _

-- Unit laws for Composition

rup : ∀ {i}{A : Set i}{a b : A} → (p : a ≡ b) → (p ∙ refl) ≡ p
rup = ind₌ (λ _ _ p → (p ∙ refl) ≡ p) (λ _ → refl) _ _

lup : ∀ {i}{A : Set i}{a b : A} → (p : a ≡ b) → (refl ∙ p) ≡ p
lup _ = refl

-- Associativity of path composition
assoc : ∀ {i}{A : Set i}{a b c d : A} → (p : a ≡ b) (q : b ≡ c) (r : c ≡ d) → (p ∙ (q ∙ r)) ≡ ((p ∙ q) ∙ r)
assoc {c = c} {d = d} = ind₌
  (λ _ b p → (q : b ≡ c) (r : c ≡ d) → (p ∙ q ∙ r) ≡ ((p ∙ q) ∙ r))
  (λ b → ind₌
    (λ _ c q → (r : c ≡ d) → (refl ∙ q ∙ r) ≡ ((refl ∙ q) ∙ r))
    (λ _ _ → refl) _ _)
    _ _

-- It is a familiar fact in topology that when we concatenate a path p with the
-- reversed path p ⁻¹, we don’t literally obtain a constant path (which
-- corresponds to the equality refl in type theory) — instead we have a
-- homotopy, or higher path, from p ∙ p ⁻¹ to the constant path.

there-and-back-again : ∀ {i} {A : Set i}{x y : A}{p : x ≡ y} → (p ∙ p ⁻¹) ≡ refl
there-and-back-again {i} {A} {x}{y} {p} = ind₌ D d _ _ p where
  D : (x y : A) → (x ≡ y) → Set i
  D x y p = (p ∙ p ⁻¹) ≡ refl

  d : (x₁ : A) → D x₁ x₁ refl
  d = λ x → refl

back-and-there-again : ∀ {i}{A : Set i}{x y : A}{p : x ≡ y} → (p ⁻¹ ∙ p) ≡ refl
back-and-there-again {i} {A} {x}{y} {p} = ind₌ D d _ _ p where
  D : (x y : A) → (p : x ≡ y) → Set i
  D x y p = (p ⁻¹ ∙ p) ≡ refl

  d : (x₁ : A) → D x₁ x₁ refl
  d = λ x → refl

-- Paths are functor looking things.
ap : ∀ {i j} {A : Set i}{B : Set j}{x y : A}{f : A → B} → (x ≡ y) → (f x ≡ f y)
ap {i}{j} {A}{B} {x}{y}{f} p = ind₌ D d x y p where
  D : (x y : A) → (p : x ≡ y) → Set j
  D x y p = f x ≡ f y

  d : (x : A) → D x x refl
  d = λ x → refl

--
ap₂ : ∀ {i j k} {A : Set i}{B : Set j}{C : Set k}{x x′ : A}{y y′ : B}(f : A → B → C) → (x ≡ x′) → (y ≡ y′) → (f x y ≡ f x′ y′)
ap₂ f p q = ap {f = λ _ → f _ _} p ∙ ap {f = f _} q

-- The dependently typed version of `ap` takes a type family and relates its instantiations with p
transport : ∀ {i j} {A : Set i}{P : A → Set j}{x y : A} → (p : x ≡ y) → P x → P y
transport {i}{j} {A}{P} {x}{y} p = ind₌ D d x y p where
    D : (x y : A) → (p : x ≡ y) → Set j
    D x y p = P x → P y

    d : (x : A) → D x x refl
    d = λ x → id

2-11-2 : ∀ {i} {A : Set i} → (a : A) {x₁ x₂ : A} (p : x₁ ≡ x₂) (q : a ≡ x₁) → (transport p q) ≡ (q ∙ p)
2-11-2 a = ind₌
  (λ x _ p → (q : a ≡ x) → (transport {P = (λ x → a ≡ x)} p q) ≡ (q ∙ p))
  (λ _ q → rup q ⁻¹)
  _ _

-- Basically, P respects equality
path-lifting : ∀ {a p}{A : Set a}{x y : A}{P : A → Set p} → (u : P x) → (p : x ≡ y) → (x , u) ≡ (y , u)
path-lifting u = cong (λ z → z , u)

-- Look, transport works in the "upper" space too!
apd : ∀ {i} {A : Set i}{P : A → Set i}{f : (x : A) → P x}{x y : A} → (p : x ≡ y) → (transport p (f x) ≡ f y)
apd {i} {A}{P} {f}{x}{y} p = ind₌ D d x y p where
  D : (x y : A) → (p : x ≡ y) → Set i
  D x y p = transport p (f x) ≡ f y

  d : (x : A) → D x x refl
  d = λ x → refl

-- We can also fix B and make transport work like fmap with equalities.
transportconst : ∀ {i} {A : Set i}{B : Set i}{P : A → B}{x y : A} → (p : x ≡ y) → (b : B) → transport p b ≡ b
transportconst {i} {A}{B}{P} {x}{y} p b = ind₌ D d x y p where
  D : (x y : A) → (x ≡ y) → Set i
  D x y p = transport p b ≡ b

  d : (x : A) → D x x refl
  d = λ x → refl

-- Path Structure for Product Types
split-path₌ : ∀ {a b}{A : Set a}{B : Set b} → (x y : (A × B)) → (x ≡ y) → (proj₁ x ≡ proj₁ y) × (proj₂ x ≡ proj₂ y)
split-path₌ xs ys p = ap {f = proj₁} p , ap {f = proj₂} p

{-
pair₌ : ∀ {a b}{A : Set a}{B : Set b} → (x y : (A × B)) → (proj₁ x ≡ proj₁ y) × (proj₂ x ≡ proj₂ y) → (x ≡ y)
pair₌ (a₁ , b₁) (a₂ , b₂) (p , q) = {!!}
-}


module Data.List.Size where

import      Lvl
open import Data.List
open import Logic.Predicate
open import Logic.Propositional
open import Numeral.Natural
open import Numeral.Natural.Oper
open import Relator.Equals
open import Relator.Equals.Proofs
open import Structure.Function.Domain
open import Type

open import Data.Boolean

private variable ℓ : Lvl.Level
private variable T : Type{ℓ}

-- TODO: For general types, not just Bool.
index : (T → ℕ) → (List(T) → ℕ)
index f ∅       = 1
index f (x ⊰ l) = (2 ^ 𝐒(f(x))) ⋅ index f l -- TODO: 2 is temporary. Use unique primes (does not have to include all or even be in order).

{-
index-injective : ∀{f : T → ℕ} → ⦃ Injective(f) ⦄ → Injective(index f)
index-injective = {!!}
-}


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

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Function
open import Cubical.HITs.PropositionalTruncation
open import Cubical.Data.Nat
open import Cubical.Data.Sigma

private
  variable
    ℓ : Level
    A B C : Type ℓ

Cost : (A : Type ℓ) → Type ℓ
Cost A = A × ∥ ℕ ∥

-- To compare two elements of Cost A we only need to look at the first parts
Cost≡ : (x y : Cost A) → x .fst ≡ y .fst → x ≡ y
Cost≡ _ _ = Σ≡Prop λ _ → squash

-- To make it easier to program with Cost A we prove that it forms a
-- monad which counts the number of calls to >>=. We could also turn
-- it into a proper state monad which tracks the cost, but for the
-- programs we write later this simple version suffices
_>>=_ : Cost A → (A → Cost B) → Cost B
(x , m) >>= g with g x
... | (y , n) = (y , map suc (map2 _+_ m n))

return : A → Cost A
return x = (x , ∣ 0 ∣)

-- The monad laws all hold by Cost≡

>>=-return : (f : Cost A) → f >>= return ≡ f
>>=-return f = Cost≡ _ _ refl

return->>= : (a : A) (f : A → Cost B) → return a >>= f ≡ f a
return->>= a f = Cost≡ _ _ refl

>>=-assoc : (f : Cost A) (g : A → Cost B) (h : B → Cost C)
          → (f >>= g) >>= h ≡ f >>= (λ x → g x >>= h)
>>=-assoc f g h = Cost≡ _ _ refl

-- An inefficient version of addition which recurses on both arguments
addBad : ℕ → ℕ → Cost ℕ
addBad 0 0       = return 0
addBad 0 (suc y) = do
  x ← addBad 0 y
  return (suc x)
addBad (suc x) y = do
  z ← addBad x y
  return (suc z)

-- More efficient addition which only recurse on the first argument
add : ℕ → ℕ → Cost ℕ
add 0       y = return y
add (suc x) y = do
  z ← add x y
  return (suc z)

private
  -- addBad x y will do x + y calls
  _ : addBad 3 5 ≡ (8 , ∣ 8 ∣)
  _ = refl

  -- add x y will only do x recursive calls
  _ : add 3 5 ≡ (8 , ∣ 3 ∣)
  _ = refl

-- Despite addBad and add having different cost we can still prove
-- that they are equal functions
add≡addBad : add ≡ addBad
add≡addBad i x y = Cost≡ (add x y) (addBad x y) (rem x y) i
  where
  rem : (x y : ℕ) → add x y .fst ≡ addBad x y .fst
  rem 0 0       = refl
  rem 0 (suc y) = cong suc (rem 0 y)
  rem (suc x) y = cong suc (rem x y)

-- Another example: computing Fibonacci numbers

fib : ℕ → Cost ℕ
fib 0 = return 0
fib 1 = return 1
fib (suc (suc x)) = do
  y ← fib (suc x)
  z ← fib x
  return (y + z)

fibTail : ℕ → Cost ℕ
fibTail 0       = return 0
fibTail (suc x) = fibAux x 1 0
  where
  fibAux : ℕ → ℕ → ℕ → Cost ℕ
  fibAux 0 res _          = return res
  fibAux (suc x) res prev = do
    r ← fibAux x (res + prev) res
    return r

private
  _ : fib 10 ≡ (55 , ∣ 176 ∣)
  _ = refl

  _ : fibTail 10 ≡ (55 , ∣ 9 ∣)
  _ = refl

  _ : fib 20 ≡ (6765 , ∣ 21890 ∣)
  _ = refl

  _ : fibTail 20 ≡ (6765 , ∣ 19 ∣)
  _ = refl

-- Exercise left to the reader: prove that fib and fibTail are equal functions
-- fib≡fibTail : fib ≡ fibTail
-- fib≡fibTail i x = Cost≡ (fib x) (fibTail x) (rem x) i
--   where
--   rem : (x : ℕ) → fib x .fst ≡ fibTail x .fst
--   rem zero = refl
--   rem (suc zero) = refl
--   rem (suc (suc x)) = {!!}


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

open import Relation.Binary using (Rel; Setoid; IsEquivalence)
module Structures
  {a ℓ} {A : Set a}  -- The underlying set
  (_≈_ : Rel A ℓ)    -- The underlying equality relation
  where

open import Algebra.Core
open import Level using (_⊔_)
open import Data.Product using (_,_; proj₁; proj₂)
open import Algebra.Definitions _≈_
open import Algebra.Structures _≈_
open import Definitions _≈_

------------------------------------------------------------------------
-- Structures with 1 binary operation
------------------------------------------------------------------------

record IsLatinQuasigroup (∙ : Op₂ A ) : Set (a ⊔ ℓ) where
  field
    isMagma     : IsMagma ∙
    latinSquare : LatinSquare ∙

  open IsMagma isMagma public

  latinSquare₁ : LatinSquare₁ ∙
  latinSquare₁ = proj₁ latinSquare

  latinSquare₂ : LatinSquare₂ ∙
  latinSquare₂ = proj₂ latinSquare

record IsIdempotentMagma (∙ : Op₂ A) : Set (a ⊔ ℓ) where
  field
    isMagma : IsMagma ∙
    idem    : Idempotent ∙

  open IsMagma isMagma public

record IsAlternateMagma (∙ : Op₂ A) : Set (a ⊔ ℓ) where
  field
    isMagma  : IsMagma ∙
    alter    : Alternative ∙

  open IsMagma isMagma public

record IsFlexibleMagma (∙ : Op₂ A) : Set (a ⊔ ℓ) where
  field
    isMagma  : IsMagma ∙
    flex     : Flexible ∙

  open IsMagma isMagma public

record IsMedialMagma (∙ : Op₂ A) : Set (a ⊔ ℓ) where
  field
    isMagma : IsMagma ∙
    medial  : Medial ∙

  open IsMagma isMagma public

record IsSemimedialMagma (∙ : Op₂ A) : Set (a ⊔ ℓ) where
  field
    isMagma : IsMagma ∙
    semiMedial  : Semimedial ∙

  open IsMagma isMagma public

record IsInverseSemigroup (∙ : Op₂ A) : Set (a ⊔ ℓ) where
  field
    isSemigroup     : IsSemigroup ∙
    pseudoInverse   : PseudoInverse ∙

  open IsSemigroup isSemigroup public

------------------------------------------------------------------------
-- Structures with 1 binary operation and 1 element
------------------------------------------------------------------------

record IsLeftUnitalMagma (∙ : Op₂ A) (ε : A) : Set (a ⊔ ℓ) where
  field
    isMagma  : IsMagma ∙
    identity : LeftIdentity ε ∙

  open IsMagma isMagma public

record IsRightUnitalMagma (∙ : Op₂ A) (ε : A) : Set (a ⊔ ℓ) where
  field
    isMagma  : IsMagma ∙
    identity : RightIdentity ε ∙

  open IsMagma isMagma public

------------------------------------------------------------------------
-- Structures with 2 binary operations, 1 unary operation & 1 element
------------------------------------------------------------------------

record IsNonAssociativeRing (+ * : Op₂ A) (-_ : Op₁ A) (0# 1# : A) : Set (a ⊔ ℓ) where
  field
    +-isAbelianGroup : IsAbelianGroup + 0# -_
    *-cong           : Congruent₂ *
    identity         : Identity 1# *
    distrib          : * DistributesOver +
    zero             : Zero 0# *

  open IsAbelianGroup +-isAbelianGroup public
    renaming
    ( assoc                   to +-assoc
    ; ∙-cong                  to +-cong
    ; ∙-congˡ                 to +-congˡ
    ; ∙-congʳ                 to +-congʳ
    ; identity                to +-identity
    ; identityˡ               to +-identityˡ
    ; identityʳ               to +-identityʳ
    ; inverse                 to -‿inverse
    ; inverseˡ                to -‿inverseˡ
    ; inverseʳ                to -‿inverseʳ
    ; ⁻¹-cong                 to -‿cong
    ; comm                    to +-comm
    ; isMagma                 to +-isMagma
    ; isSemigroup             to +-isSemigroup
    ; isMonoid                to +-isMonoid
    ; isUnitalMagma           to +-isUnitalMagma
    ; isCommutativeMagma      to +-isCommutativeMagma
    ; isCommutativeMonoid     to +-isCommutativeMonoid
    ; isCommutativeSemigroup  to +-isCommutativeSemigroup
    ; isInvertibleMagma       to +-isInvertibleMagma
    ; isInvertibleUnitalMagma to +-isInvertibleUnitalMagma
    ; isGroup                 to +-isGroup
    )

  *-isMagma : IsMagma *
  *-isMagma = record
    { isEquivalence = isEquivalence
    ; ∙-cong        = *-cong
    }

  *-identityˡ : LeftIdentity 1# *
  *-identityˡ = proj₁ identity

  *-identityʳ : RightIdentity 1# *
  *-identityʳ = proj₂ identity

------------------------------------------------------------------------
-- Structures with 3 binary operation and 1 element
------------------------------------------------------------------------

record IsLeftBolLoop (∙ \\ // : Op₂ A) (ε : A) : Set (a ⊔ ℓ) where
  field
    isLoop  : IsLoop ∙ \\ //  ε
    leftBol : LeftBol ∙

  open IsLoop isLoop public

record IsRightBolLoop (∙ \\ // : Op₂ A) (ε : A) : Set (a ⊔ ℓ) where
  field
    isLoop   : IsLoop ∙ \\ //  ε
    rightBol : RightBol ∙

  open IsLoop isLoop public

record IsMoufangLoop (∙ \\ // : Op₂ A) (ε : A) : Set (a ⊔ ℓ) where
  field
    isLoop           : IsLoop ∙ \\ // ε
    moufangIdentity  : MoufangIdentity₁ ∙
    moufangIdentity₂ : MoufangIdentity₂ ∙
    moufangIdentity₃ : MoufangIdentity₃ ∙
    moufangIdentity₄ : MoufangIdentity₄ ∙

  open IsLoop isLoop public

record IsPique (∙ \\ // : Op₂ A) (ε : A) : Set (a ⊔ ℓ) where
  field
    isQuasigroup : IsQuasigroup ∙ \\ //
    idem         : Idempotent ∙

  open IsQuasigroup isQuasigroup public


module *-example where

import Relation.Binary.PropositionalEquality as Eq
open Eq using (_≡_; refl)
open Eq.≡-Reasoning using (begin_; _≡⟨⟩_; _∎)

open import Naturals using (_*_)

*-example : 3 * 4 ≡ 12
*-example =
  begin
    3 * 4
  ≡⟨⟩
    4 + (2 * 4)
  ≡⟨⟩
    4 + (4 + (1 * 4))
  ≡⟨⟩
    4 + (4 + (4 + (0 * 4)))
  ≡⟨⟩
    4 + (4 + (4 + 0))
  ≡⟨⟩
    12
  ∎


-- an example showing how to use sigma types to define a type for non-zero natural numbers
module nat-nonzero where

open import bool
open import eq
open import nat
open import nat-thms
open import product

ℕ⁺ : Set
ℕ⁺ = Σ ℕ (λ n → iszero n ≡ ff)

suc⁺ : ℕ⁺ → ℕ⁺
suc⁺ (x , p) = (suc x , refl)

_+⁺_ : ℕ⁺ → ℕ⁺ → ℕ⁺
(x , p) +⁺ (y , q) = x + y , iszerosum2 x y p

_*⁺_ : ℕ⁺ → ℕ⁺ → ℕ⁺
(x , p) *⁺ (y , q) = (x * y , iszeromult x y p q)


open import Agda.Builtin.Nat renaming (Nat to ℕ)
open import Agda.Builtin.Equality

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

data All₂ {A : Set} {B : Set} (R : A → B → Set) : ∀ {k} → Vec A k → Vec B k → Set where
  []   :  All₂ R [] []
  _∷_  :  ∀ {k x y} {xs : Vec A k} {ys : Vec B k}
          (r : R x y) (rs : All₂ R xs ys) → All₂ R (x ∷ xs) (y ∷ ys)

Det : ∀ {A : Set} {B : Set} (R : A → B → Set) → Set
Det R = ∀{a b c} → R a b → R a c → b ≡ c

detAll₂ : ∀ {A : Set} {B : Set} (R : A → B → Set) (h : Det R) → Det (All₂ R)
detAll₂ R h rab rac = {!rab!}


module Oscar.Data.Vec.Injectivity where

open import Oscar.Data.Equality
open import Oscar.Data.Vec

Vec-head-inj : ∀ {a} {A : Set a} {x₁ x₂ : A} {N} {xs₁ xs₂ : Vec A N} → x₁ ∷ xs₁ ≡ x₂ ∷ xs₂ → x₁ ≡ x₂
Vec-head-inj refl = refl

Vec-tail-inj : ∀ {a} {A : Set a} {x₁ x₂ : A} {N} {xs₁ xs₂ : Vec A N} → x₁ ∷ xs₁ ≡ x₂ ∷ xs₂ → xs₁ ≡ xs₂
Vec-tail-inj refl = refl


module sets.nat.core where

open import level
open import decidable
open import equality.core
open import function.core
open import function.isomorphism.core
open import sets.empty

infixr 8 _^_
infixl 7 _*_
infixl 6 _+_

data ℕ : Set where
  zero : ℕ
  suc  : ℕ → ℕ

{-# BUILTIN NATURAL ℕ    #-}

pred : ℕ → ℕ
pred zero    = zero
pred (suc n) = n

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

_*_ : ℕ → ℕ → ℕ
0 * n = zero
suc m * n = n + m * n

_^_ : ℕ → ℕ → ℕ
n ^ 0 = 1
n ^ (suc m) = n * (n ^ m)

suc-inj : injective suc
suc-inj = ap pred

_≟_ : (a b : ℕ) → Dec (a ≡ b)
zero  ≟ zero  = yes refl
zero  ≟ suc _ = no (λ ())
suc _ ≟ zero  = no (λ ())
suc a ≟ suc b with a ≟ b
suc a ≟ suc b | yes a≡b = yes $ ap suc a≡b
suc a ≟ suc b | no ¬a≡b = no $ (λ sa≡sb → ¬a≡b (ap pred sa≡sb))


-- Andreas, 2015-03-12
-- Sizes should be irrelevant in terms, while they are relevant in types!

{-# OPTIONS --experimental-irrelevance #-}

open import Common.Size
open import Common.Equality

module IrrelevantSizes where

  -- Nat i is shape-irrelevant in i.

  data Nat ..(i : Size) : Set where
    zero : .(j : Size< i) → Nat i
    suc  : .(j : Size< i) → Nat j → Nat i

  add : .(i : Size) → Nat i → Nat ∞ → Nat ∞
  add i (zero j) y = y
  add i (suc j x) y = suc ∞ (add j x y)

  -- Proving this lemma is much easier with irrelevant sizes
  -- in constructors zero and suc

  plus0 : .(i : Size) (x : Nat i) → add ∞ x (zero ∞) ≡ x
  plus0 i (zero j) = refl                       -- Goal: zero ∞ = zero j
  plus0 i (suc j x) = cong (suc ∞) (plus0 j x)  -- Goal: suc ∞ (add j x (zero ∞)) ≡ suc j x


module Nat where

open import Data.Product
open import Data.Sum
open import Relation.Binary.PropositionalEquality as Eq
open import Data.Empty
open import Level hiding (zero)

data ℕ : Set where
    zero : ℕ
    succ : ℕ → ℕ

open Eq.≡-Reasoning

¬_ : { ℓ : Level} → Set ℓ → Set ℓ
¬ P = P → ⊥

≡-succ : (n m : ℕ) → succ n ≡ succ m → n ≡ m
≡-succ zero .zero refl = refl
≡-succ (succ n) .(succ n) refl = refl

sn≢0 : (n : ℕ) → ¬ (succ n ≡ zero)
sn≢0 _ ()

_+_ : ℕ → ℕ → ℕ
zero + m = m
succ n + m = succ (n + m)

_*_ : ℕ → ℕ → ℕ
zero * _ = zero
succ n * m = m + (n * m)

+-rUnit : (n : ℕ) → n + zero ≡ n
+-rUnit zero = refl
+-rUnit (succ n) = cong succ (+-rUnit n)

+-lUnit : (n : ℕ) → zero + n ≡ n
+-lUnit _ = refl

+-assoc : (n m l : ℕ) → n + (m + l) ≡ (n + m) + l
+-assoc zero m l = refl
+-assoc (succ n) m l = cong succ (+-assoc n m l)

+-right : (n m : ℕ) → n + succ m ≡ succ (n + m)
+-right zero m = refl
+-right (succ n) m = cong succ (+-right n m)

+-comm : (m n : ℕ) → m + n ≡ n + m
+-comm zero n = sym (+-rUnit n)
+-comm (succ m) n = begin
        succ (m + n)
    ≡⟨ cong succ (+-comm m n) ⟩
        succ (n + m)
    ≡⟨ sym (+-right n m) ⟩
        n + succ m
    ∎

+-lCancel : (n m l : ℕ) → l + n ≡ l + m → n ≡ m
+-lCancel n m zero p = p
+-lCancel n m (succ l) p = +-lCancel n m l (≡-succ (l + n) (l + m) p)

+-rCancel : (n m l : ℕ) → n + l ≡ m + l → n ≡ m
+-rCancel n m zero p =
    begin
        n
    ≡⟨ sym (+-rUnit n) ⟩
        n + zero
    ≡⟨ p ⟩
        m + zero
    ≡⟨ +-rUnit m ⟩
        m
    ∎
+-rCancel n m (succ l) n+sl≡m+sl = +-rCancel n m l (≡-succ (n + l) (m + l)
    (begin
        succ (n + l)
    ≡⟨ sym (+-right n l) ⟩
        n + succ l
    ≡⟨ n+sl≡m+sl ⟩
        m + succ l
    ≡⟨ +-right m l ⟩
        succ (m + l)
    ∎))

*-rAbsorp : (n : ℕ) → n * zero ≡ zero
*-rAbsorp zero = refl
*-rAbsorp (succ n) = begin
        succ n * zero
    ≡⟨ refl ⟩
        zero + (n * zero)
    ≡⟨ cong (λ x → zero + x) (*-rAbsorp n) ⟩
        zero + zero
    ≡⟨ refl ⟩
        zero
    ∎

*-right : (m n : ℕ) → m * succ n ≡ (m * n) + m
*-right zero n = begin
        zero * succ n
    ≡⟨ refl ⟩
        zero
    ≡⟨ refl ⟩
        zero * n
    ≡⟨ +-rUnit (zero * n) ⟩
        (zero * n) + zero
    ∎
*-right (succ m) n = begin
        succ m * succ n
    ≡⟨ refl ⟩
        succ n + (m * succ n)
    ≡⟨ cong (λ x → succ n + x) (*-right m n) ⟩
        succ n + ((m * n) + m)
    ≡⟨ refl ⟩
        succ (n + ((m * n) + m))
    ≡⟨ cong succ (+-assoc n (m * n) m) ⟩
        succ ((n + (m * n)) + m)
    ≡⟨ sym (+-right (n + (m * n)) m) ⟩
        (succ m * n) + succ m
    ∎

+*-rDist : (m n l : ℕ) → (m + n) * l ≡ (m * l) + (n * l)
+*-rDist m n zero = begin
        (m + n) * zero
    ≡⟨ *-rAbsorp (m + n) ⟩
        zero
    ≡⟨ sym (*-rAbsorp m) ⟩
        m * zero
    ≡⟨ sym (+-rUnit (m * zero)) ⟩
        (m * zero) + zero
    ≡⟨ cong (λ x → (m * zero) + x) (sym (*-rAbsorp n)) ⟩
        (m * zero) + (n * zero)
    ∎
+*-rDist m n (succ l) = begin
        (m + n) * succ l
    ≡⟨ *-right (m + n) l ⟩
        ((m + n) * l) + (m + n)
    ≡⟨ cong (λ x → x + (m + n)) (+*-rDist m n l) ⟩
        ((m * l) + (n * l)) + (m + n)
    ≡⟨ +-assoc ((m * l) + (n * l)) m n ⟩
        (((m * l) + (n * l)) + m) + n
    ≡⟨ cong (λ x → x + n) (sym (+-assoc (m * l) (n * l) m)) ⟩
        ((m * l) + ((n * l) + m)) + n
    ≡⟨ cong (λ x → x + n) (cong (λ x → (m * l) + x) (+-comm (n * l) m)) ⟩
        ((m * l) + (m + (n * l))) + n
    ≡⟨ cong (λ x → x + n) (+-assoc (m * l) m (n * l)) ⟩
        (((m * l) + m) + (n * l)) + n
    ≡⟨ sym (+-assoc ((m * l) + m) (n * l) n) ⟩
        ((m * l) + m) + ((n * l) + n)
    ≡⟨ cong (λ x → x + ((n * l) + n)) (sym (*-right m l)) ⟩
        (m * succ l) + ((n * l) + n)
    ≡⟨ cong (λ x → (m * succ l) + x) (sym (*-right n l)) ⟩
        (m * succ l) + (n * succ l)
    ∎

*-assoc : (m n l : ℕ) → m * (n * l) ≡ (m * n) * l
*-assoc zero n l = refl
*-assoc (succ m) n l = begin
        succ m * (n * l)
    ≡⟨ refl ⟩
        (n * l) + (m * (n * l))
    ≡⟨ cong (λ x → (n * l) + x) (*-assoc m n l) ⟩
        (n * l) + ((m * n) * l)
    ≡⟨ sym (+*-rDist n (m * n) l) ⟩
        (n + (m * n)) * l
    ≡⟨ refl ⟩
        (succ m * n) * l
    ∎

*-comm : (m n : ℕ) → m * n ≡ n * m
*-comm zero n = sym (*-rAbsorp n)
*-comm (succ m) n = begin
        succ m * n
    ≡⟨ refl ⟩
        n + (m * n)
    ≡⟨ +-comm n (m * n) ⟩
        (m * n) + n
    ≡⟨ cong (λ x → x + n) (*-comm m n) ⟩
        (n * m) + n
    ≡⟨ sym (*-right n m) ⟩
        n * succ m
    ∎

_≤_ : ℕ → ℕ → Set
n ≤ m = Σ ℕ (λ l → n + l ≡ m)

≤-refl : (n : ℕ) → n ≤ n
≤-refl zero = zero , refl
≤-refl (succ n) = zero ,
    (begin
        (succ n + zero)
    ≡⟨ +-rUnit (succ n) ⟩
        (succ n)
    ∎)

0≤n : (n : ℕ) → zero ≤ n
0≤n zero = ≤-refl zero
0≤n (succ n) = succ n , refl

≤-trans : (n m l : ℕ) → n ≤ m → m ≤ l → n ≤ l
≤-trans zero m l p q = l , refl
≤-trans (succ n) m l (a , succn+a≡m) (b , m+b≡l)
    = (a + b) , (begin
        succ n + (a + b)
    ≡⟨ +-assoc (succ n) a b ⟩
        (succ n + a) + b
    ≡⟨ cong (λ x → x + b) succn+a≡m ⟩
        m + b
    ≡⟨ m+b≡l ⟩
        l
    ∎)

+-lZero : (n m : ℕ) → n + m ≡ zero → n ≡ zero
+-lZero zero m = λ _ → refl
+-lZero (succ n) m ()

≤-antisym : (n m : ℕ) → n ≤ m → m ≤ n → n ≡ m
≤-antisym n m (c , n+c≡m) (d , m+d≡n) = trans (sym n+c≡n) n+c≡m
    where
        c≡0 : c ≡ zero
        c≡0 = +-lZero c d (+-lCancel (c + d) zero n (
            begin
                n + (c + d)
            ≡⟨ +-assoc n c d ⟩
                (n + c) + d
            ≡⟨ cong (λ x → x + d) n+c≡m ⟩
                m + d
            ≡⟨ m+d≡n ⟩
                n
            ≡⟨ sym (+-rUnit n) ⟩
                n + zero
            ∎))
        n+c≡n : n + c ≡ n
        n+c≡n = begin
                n + c
            ≡⟨ cong (λ x → n + x) c≡0 ⟩
                n + zero
            ≡⟨ +-rUnit n ⟩
                n
            ∎

n+s0≡sn : (n : ℕ) → n + succ zero ≡ succ n
n+s0≡sn n = begin
        n + succ zero
    ≡⟨ +-right n zero ⟩
        succ (n + zero)
    ≡⟨ cong succ (+-rUnit n) ⟩
        succ n
    ∎

n≤sn : (n : ℕ) → n ≤ succ n
n≤sn n = succ zero , n+s0≡sn n

ℕ-ω : (n : ℕ) → n ≡ zero ⊎ Σ ℕ (λ c → n ≡ succ c)
ℕ-ω zero = inj₁ refl
ℕ-ω (succ n) = inj₂ (n , refl)

m+sn≡sm+n : (m n : ℕ) → m + succ n ≡ succ m + n
m+sn≡sm+n m zero = begin
        m + succ zero
    ≡⟨ n+s0≡sn m ⟩
        succ m
    ≡⟨ sym (+-rUnit (succ m)) ⟩
        succ m + zero
    ∎
m+sn≡sm+n m (succ n) = begin
        m + succ (succ n)
    ≡⟨ +-right m (succ n) ⟩
        succ (m + succ n)
    ≡⟨ cong succ (m+sn≡sm+n m n) ⟩
        succ (succ m + n)
    ≡⟨ sym (+-right (succ m) n) ⟩
        succ m + succ n
    ∎

sn≤m : (n m : ℕ) → n ≤ m → ¬ (n ≡ m) → succ n ≤ m
sn≤m n m (c , n+c≡m) q = lem (ℕ-ω c)
    where
        n+c≡n : c ≡ zero → n + c ≡ n
        n+c≡n p = begin
                n + c
            ≡⟨ cong (λ x → n + x) p ⟩
                n + zero
            ≡⟨ +-rUnit n ⟩
                n
            ∎
        lem : c ≡ zero ⊎ Σ ℕ (λ d → c ≡ succ d) → succ n ≤ m
        lem (inj₁ x) = ⊥-elim (q (trans (sym (n+c≡n x)) n+c≡m))
        lem (inj₂ (d , c≡sd)) = d , (begin
                succ n + d
            ≡⟨ sym (m+sn≡sm+n n d) ⟩
                n + succ d
            ≡⟨ sym (cong (λ x → n + x) c≡sd) ⟩
                n + c
            ≡⟨ n+c≡m ⟩
                m
            ∎)

≤-all : (m n : ℕ) → m ≤ n ⊎ n ≤ m
≤-all m zero = inj₂ (m , refl)
≤-all m (succ n) = lem (≤-all m n)
    where
        lem : m ≤ n ⊎ n ≤ m → m ≤ succ n ⊎ succ n ≤ m
        lem (inj₁ x) = inj₁ (≤-trans m n (succ n) x (n≤sn n))
        lem (inj₂ (zero , n+zero≡m)) = inj₁ (succ zero , (begin
                m + succ zero
            ≡⟨ +-right m zero ⟩
                succ (m + zero)
            ≡⟨ cong succ (+-rUnit m) ⟩
                succ m
            ≡⟨ cong succ (sym n+zero≡m) ⟩
                succ (n + zero)
            ≡⟨ cong succ (+-rUnit n) ⟩
                succ n
            ∎))
        lem (inj₂ (succ c , n+sc≡m)) = inj₂ (c , (begin
                succ n + c
            ≡⟨ refl ⟩
                succ (n + c)
            ≡⟨ sym (+-right n c) ⟩
                n + succ c
            ≡⟨ n+sc≡m ⟩
                m
            ∎))

+-mono : (m n l : ℕ) → m ≤ n → (m + l) ≤ (n + l)
+-mono m n zero (c , m+c≡n) = c , (begin
        (m + zero) + c
    ≡⟨ cong (λ x → x + c) (+-rUnit m) ⟩
        m + c
    ≡⟨ m+c≡n ⟩
        n
    ≡⟨ sym (+-rUnit n) ⟩
        n + zero
    ∎)
+-mono m n (succ l) (c , m+c≡n) = lem (+-mono m n l (c , m+c≡n))
    where
        lem : (m + l) ≤ (n + l) → (m + succ l) ≤ (n + succ l)
        lem (d , m+l+d≡n+l) = d , (begin
                (m + succ l) + d
            ≡⟨ cong (λ x → x + d) (+-right m l) ⟩
                succ (m + l) + d
            ≡⟨ refl ⟩
                succ ((m + l) + d)
            ≡⟨ cong succ m+l+d≡n+l ⟩
                succ (n + l)
            ≡⟨ sym (+-right n l) ⟩
                n + succ l
            ∎)

*-mono : (m n l : ℕ) → m ≤ n → (m * l) ≤ (n * l)
*-mono m n zero (c , m+c≡n) = zero , (begin
        (m * zero) + zero
    ≡⟨ +-rUnit (m * zero) ⟩
        m * zero
    ≡⟨ trans (*-rAbsorp m) (sym (*-rAbsorp n)) ⟩
        n * zero
    ∎)
*-mono m n (succ l) (c , m+c≡n) = lem (*-mono m n l (c , m+c≡n))
    where
        lem : (m * l) ≤ (n * l) → (m * succ l) ≤ (n * succ l)
        lem (d , m*l+d≡n*l) = (c * succ l) , sym (begin
                n * succ l
            ≡⟨ cong (λ x → x * succ l) (sym m+c≡n) ⟩
                (m + c) * succ l
            ≡⟨ +*-rDist m c (succ l) ⟩
                (m * succ l) + (c * succ l)
            ∎)

s≤s : (m n : ℕ) → m ≤ n → succ m ≤ succ n
s≤s zero n (c , c≡n) = n , refl
s≤s (succ m) n (c , sm+c≡n) = c , cong succ sm+c≡n

data _≲_ : ℕ → ℕ → Set where
    0≲n : {n : ℕ} → zero ≲ n
    s≲s : {n m : ℕ} → n ≲ m → succ n ≲ succ m

≤-≲ : (m n : ℕ) → m ≤ n → m ≲ n
≤-≲ zero _ _ = 0≲n
≤-≲ (succ m) zero (c , ())
≤-≲ (succ m) (succ n) (c , m+c≡n) = s≲s (≤-≲ m n (c , ≡-succ (m + c) n m+c≡n))

≲-≤ : (m n : ℕ) → m ≲ n → m ≤ n
≲-≤ .zero n 0≲n = n , refl
≲-≤ (succ m) (succ n) (s≲s p) = s≤s m n (≲-≤ m n p)


module Type.Properties.Inhabited{ℓ} where

import      Lvl
open import Type

-- An inhabited type, which essentially means non-empty (there exists objects with this type), and this object is pointed out/specified/chosen.
-- This means that there exists objects with such an type, and such an object is extractable constructively (like a witness).
-- Also called: Pointed type.
record ◊ (T : Type{ℓ}) : Type{ℓ} where
  constructor intro
  field
    ⦃ existence ⦄ : T
open ◊ ⦃ ... ⦄ renaming (existence to [◊]-existence) public


module IsLiteralFormula where

open import OscarPrelude
open import PredicateName
open import Term
open import Formula
open import HasNegation

data IsLiteralFormula : Formula → Set
 where
  atomic : (𝑃 : PredicateName) → (τs : Terms) → IsLiteralFormula $ 𝑃[ 𝑃 ♭ τs ]
  logical : (𝑃 : PredicateName) → (τs : Terms) → IsLiteralFormula ∘ ~ $ 𝑃[ 𝑃 ♭ τs ]

eqIsLiteralFormula : ∀ {φ} → (lf₁ lf₂ : IsLiteralFormula φ) → lf₁ ≡ lf₂
eqIsLiteralFormula (atomic _ _) (atomic _ _) = refl
eqIsLiteralFormula (logical _ _) (logical _ _) = refl

instance EqIsLiteralFormula : ∀ {φ} → Eq (IsLiteralFormula φ)
Eq._==_ EqIsLiteralFormula lf₁ lf₂ = yes $ eqIsLiteralFormula lf₁ lf₂