module Numeral.Natural.Function.GreatestCommonDivisor.Proofs where

open import Data
open import Functional
open import Logic.Propositional
open import Numeral.Finite
open import Numeral.Natural
open import Numeral.Natural.Function.GreatestCommonDivisor
open import Numeral.Natural.Oper
open import Numeral.Natural.Oper.FlooredDivision
open import Numeral.Natural.Oper.FlooredDivision.Proofs.Inverse
open import Numeral.Natural.Oper.Modulo
open import Numeral.Natural.Relation.Divisibility
open import Numeral.Natural.Relation.Divisibility.Proofs
open import Numeral.Natural.Relation.Divisibility.Proofs.Modulo
open import Numeral.Natural.Relation.Order
open import Relator.Equals
open import Relator.Equals.Proofs.Equiv
open import Structure.Relator
open import Structure.Relator.Properties
open import Structure.Operator
open import Structure.Operator.Properties
open import Syntax.Number
open import Syntax.Transitivity

private variable a b c d d₁ d₂ : ℕ

gcd-same : (gcd(a)(a) ≡ a)
gcd-same = [↔]-to-[→] Gcd-gcd-value (Gcd.intro₂ (reflexivity(_∣_)) (reflexivity(_∣_)) (const id))

instance
  gcd-identityₗ : Identityₗ(gcd)(𝟎)
  Identityₗ.proof gcd-identityₗ = [↔]-to-[→] Gcd-gcd-value (Gcd.intro₂ Div𝟎 (reflexivity(_∣_)) (const id))

instance
  gcd-identityᵣ : Identityᵣ(gcd)(𝟎)
  Identityᵣ.proof gcd-identityᵣ = [≡]-intro

instance
  gcd-absorberₗ : Absorberₗ(gcd)(1)
  Absorberₗ.proof gcd-absorberₗ{b} = [↔]-to-[→] (Gcd-gcd-value{_}{b}) (Gcd.intro₂ [1]-divides [1]-divides const)

instance
  gcd-absorberᵣ : Absorberᵣ(gcd)(1)
  Absorberᵣ.proof gcd-absorberᵣ{a} = [↔]-to-[→] (Gcd-gcd-value{a}{_}) (Gcd.intro₂ [1]-divides [1]-divides (const id))

instance
  gcd-commutativity : Commutativity(gcd)
  Commutativity.proof gcd-commutativity {x}{y} = [↔]-to-[→] (Gcd-gcd-value {x}{y}) (Gcd-swap Gcd-gcd)

instance
  gcd-associativity : Associativity(gcd)
  Associativity.proof gcd-associativity {x}{y}{z} = [↔]-to-[→] (Gcd-gcd-value) (assoc Gcd-gcd Gcd-gcd Gcd-gcd) where
    assoc : Gcd x y d₁ → Gcd y z d₂ → Gcd x d₂ d → Gcd d₁ z d
    assoc xyd₁ yzd₂ xd₂d =
      let d₁x   = Gcd.divisorₗ xyd₁
          d₁y   = Gcd.divisorᵣ xyd₁
          xyd₁m = Gcd.maximum₂ xyd₁
          d₂y   = Gcd.divisorₗ yzd₂
          d₂z   = Gcd.divisorᵣ yzd₂
          yzd₂m = Gcd.maximum₂ yzd₂
          dx    = Gcd.divisorₗ xd₂d
          dd₂   = Gcd.divisorᵣ xd₂d
          xd₂dm = Gcd.maximum₂ xd₂d
      in Gcd.intro₂
        (xyd₁m dx (dd₂ 🝖 d₂y))
        (dd₂ 🝖 d₂z)
        (\dd₁ dz → xd₂dm (dd₁ 🝖 d₁x) (xd₂dm (dd₁ 🝖 d₁x) (yzd₂m (dd₁ 🝖 d₁y) dz) 🝖 dd₂))

gcd-dividesₗ : (gcd(a)(b) ∣ a)
gcd-dividesₗ {a}{b} = Gcd.divisorₗ{a}{b} Gcd-gcd

gcd-dividesᵣ : (gcd(a)(b) ∣ b)
gcd-dividesᵣ {a}{b} = Gcd.divisorᵣ{a}{b} Gcd-gcd

gcd-divisors : (d ∣ a) → (d ∣ b) → (d ∣ gcd(a)(b))
gcd-divisors da db = Gcd.maximum₂ Gcd-gcd da db

gcd-of-mod : (gcd(a mod 𝐒(b))(𝐒(b)) ≡ gcd(a)(𝐒(b)))
gcd-of-mod{a}{b} = [↔]-to-[→] (Gcd-gcd-value{a mod 𝐒(b)}{𝐒(b)}) (p Gcd-gcd) where
  p : Gcd(a)(𝐒(b)) d → Gcd(a mod 𝐒(b))(𝐒(b)) d
  p abd =
    let da = Gcd.divisorₗ abd
        db = Gcd.divisorᵣ abd
        m  = Gcd.maximum₂ abd
    in Gcd.intro₂ ([↔]-to-[→] (divides-mod db) da) db (Dab ↦ Db ↦ m ([↔]-to-[←] (divides-mod Db) Dab) Db)

-- TODO: Is it neccessary to prove this? By gcd-dividesₗ and gcd-dividesᵣ, one get (gcd(a)(b) ∣ min(a)(b)) and the divisor is always smaller
-- gcd-min-order : (gcd(a)(b) ≤ min(a)(b))

gcd-with-[+] : (gcd(a + b)(b) ≡ gcd(a)(b))
gcd-with-[+] {a}{b} = [↔]-to-[→] Gcd-gcd-value (p Gcd-gcd) where
  p : Gcd(a)(b) d → Gcd(a + b)(b) d
  p abd =
    let da = Gcd.divisorₗ abd
        db = Gcd.divisorᵣ abd
        m  = Gcd.maximum₂ abd
    in Gcd.intro₂ (divides-with-[+] da db) db (Dab ↦ Db ↦ m ([↔]-to-[←] (divides-without-[+] Dab) Db) Db)

gcd-with₁-[⋅] : (gcd(a ⋅ b)(b) ≡ b)
gcd-with₁-[⋅] {a}{b} = [↔]-to-[→] (Gcd-gcd-value {a ⋅ b}{b}) (Gcd.intro₂ (divides-with-[⋅] {b}{a} ([∨]-introᵣ (reflexivity(_∣_)))) (reflexivity(_∣_)) (const id))

gcd-with-[⋅] : (gcd(a ⋅ c)(b ⋅ c) ≡ gcd(a)(b) ⋅ c)
gcd-with-[⋅] {a}{𝟎}   {b} = [≡]-intro
gcd-with-[⋅] {a}{𝐒(c)}{b} =
  gcd(a ⋅ 𝐒(c)) (b ⋅ 𝐒(c))                 🝖[ _≡_ ]-[ q ]-sym
  gcd(a ⋅ 𝐒(c)) (b ⋅ 𝐒(c)) ⌊/⌋ 𝐒(c) ⋅ 𝐒(c) 🝖[ _≡_ ]-[ congruence₂ₗ(_⋅_)(𝐒(c)) ([↔]-to-[→] Gcd-gcd-value (p{gcd(a ⋅ 𝐒(c))(b ⋅ 𝐒(c)) ⌊/⌋ 𝐒(c)} ([↔]-to-[←] Gcd-gcd-value (symmetry(_≡_) q)))) ]-sym
  gcd(a)(b) ⋅ 𝐒(c)                         🝖-end
  where
    p : Gcd a b d ← Gcd(a ⋅ 𝐒(c))(b ⋅ 𝐒(c))(d ⋅ 𝐒(c))
    p acbcdc =
      let dcac = Gcd.divisorₗ acbcdc
          dcbc = Gcd.divisorᵣ acbcdc
          m    = Gcd.maximum₂ acbcdc
      in Gcd.intro₂ (divides-without-[⋅]ᵣ-both {z = c} dcac) (divides-without-[⋅]ᵣ-both {z = c} dcbc) (\{D} → Da ↦ Db ↦ divides-without-[⋅]ᵣ-both {z = c} (m{D ⋅ 𝐒(c)} (divides-with-[⋅]ᵣ-both {z = 𝐒(c)} Da) (divides-with-[⋅]ᵣ-both {z = 𝐒(c)} Db)))

    q = [⋅][⌊/⌋]-inverseOperatorᵣ (gcd-divisors{𝐒(c)}{a ⋅ 𝐒(c)}{b ⋅ 𝐒(c)} (divides-with-[⋅] {𝐒(c)}{a} ([∨]-introᵣ (reflexivity(_∣_)))) (divides-with-[⋅]  {𝐒(c)}{b} ([∨]-introᵣ (reflexivity(_∣_)))))

gcd-0 : ((a ≡ 𝟎) ∧ (b ≡ 𝟎)) ↔ (gcd a b ≡ 𝟎)
gcd-0 = [↔]-intro l r where
  l : ((a ≡ 𝟎) ∧ (b ≡ 𝟎)) ← (gcd a b ≡ 𝟎)
  l {𝟎}   {𝟎}   p = [∧]-intro [≡]-intro [≡]-intro
  l {𝐒 a} {𝐒 b} p
    with intro zv _ ← [↔]-to-[←] (Gcd-gcd-value{𝐒(a)}{𝐒(b)}) p
    with () ← [0]-divides-not (zv 𝟎)

  r : ((a ≡ 𝟎) ∧ (b ≡ 𝟎)) → (gcd a b ≡ 𝟎)
  r {𝟎} {𝟎} _ = [≡]-intro

open import Logic.Classical
open import Logic.Propositional.Theorems
open import Numeral.Natural.Decidable
open import Numeral.Natural.Relation
open import Numeral.Natural.Relation.Proofs
open import Type.Properties.Decidable.Proofs

gcd-positive : (Positive(a) ∨ Positive(b)) ↔ Positive(gcd a b)
gcd-positive{a}{b} = [↔]-transitivity ([∨]-map-[↔] Positive-non-zero Positive-non-zero) ([↔]-transitivity ([↔]-symmetry ([¬]-preserves-[∧][∨] ⦃ decider-classical(a ≡ 𝟎) ⦄ ⦃ decider-classical(b ≡ 𝟎) ⦄)) ([↔]-transitivity ([¬]-unaryOperator (gcd-0 {a}{b})) ([↔]-symmetry Positive-non-zero)))

gcd-of-successor : ∀{n} → Gcd(n)(𝐒(n))(1)
gcd-of-successor = Gcd.intro₂ [1]-divides [1]-divides p where
  p : ∀{d n} → (d ∣ n) → (d ∣ 𝐒(n)) → (d ∣ 1)
  p Div𝟎 dsn = dsn
  p (Div𝐒 dn) dsn = p dn ([↔]-to-[→] (divides-without-[+] dsn) (reflexivity(_∣_)))

open import Logic.Propositional.Theorems
open import Numeral.Natural.Coprime
open import Numeral.Natural.Coprime.Proofs
open import Numeral.Natural.Oper.FlooredDivision.Proofs
open import Numeral.Natural.Oper.FlooredDivision.Proofs.Inverse
open import Numeral.Natural.Oper.Proofs
open import Numeral.Natural.Relation.Order.Proofs
open import Syntax.Implication

[⌊/⌋₀]-gcd-coprime : (Positive(a) ∨ Positive(b)) → Coprime(a ⌊/⌋₀ gcd(a)(b)) (b ⌊/⌋₀ gcd(a)(b))
[⌊/⌋₀]-gcd-coprime {a}{b} nz =
  let d = gcd(a)(b)
      D = gcd(a ⌊/⌋₀ d) (b ⌊/⌋₀ d)
      gcd-D = Gcd-gcd {a ⌊/⌋₀ d} {b ⌊/⌋₀ d}
      d-pos = [↔]-to-[→] Positive-greater-than-zero ([↔]-to-[→] gcd-positive nz)
  in
    • (
      Gcd.divisorₗ gcd-D ⇒
      (D ∣ (a ⌊/⌋₀ d))         ⇒-[ divides-with-[⋅]ᵣ-both {z = d} ]
      (D ⋅ d ∣ (a ⌊/⌋₀ d) ⋅ d) ⇒-[ substitute₂ᵣ(_∣_) ([⋅][⌊/⌋₀]-inverseOperatorᵣ d-pos (gcd-dividesₗ {b = b})) ]
      (D ⋅ d ∣ a)              ⇒-[ substitute₂ₗ(_∣_) (commutativity(_⋅_) {D}{d}) ]
      (d ⋅ D ∣ a)              ⇒-end
    )
    • (
      Gcd.divisorᵣ gcd-D ⇒
      (D ∣ (b ⌊/⌋₀ d))         ⇒-[ divides-with-[⋅]ᵣ-both {z = d} ]
      (D ⋅ d ∣ (b ⌊/⌋₀ d) ⋅ d) ⇒-[ substitute₂ᵣ(_∣_) ([⋅][⌊/⌋₀]-inverseOperatorᵣ d-pos gcd-dividesᵣ) ]
      (D ⋅ d ∣ b)              ⇒-[ substitute₂ₗ(_∣_) (commutativity(_⋅_) {D}{d}) ]
      (d ⋅ D ∣ b)              ⇒-end
    )
    ⇒₂-[ Gcd.maximum₂ Gcd-gcd ]
    ((d ⋅ D) ∣ d)                ⇒-[]
    ((d ⋅ D) ∣ (d ⋅ 1))          ⇒-[ divides-without-[⋅]ₗ-both' d-pos ]
    (D ∣ 1)                      ⇒-[ [1]-only-divides-[1] ]
    (D ≡ 1)                      ⇒-[ [↔]-to-[←] Coprime-gcd ]
    Coprime(a ⌊/⌋₀ d) (b ⌊/⌋₀ d) ⇒-end

[⌊/⌋]-gcd-coprime : (nz : Positive(a) ∨ Positive(b)) → Coprime((a ⌊/⌋ gcd(a)(b)) ⦃ [↔]-to-[→] gcd-positive nz ⦄) ((b ⌊/⌋ gcd(a)(b)) ⦃ [↔]-to-[→] gcd-positive nz ⦄)
[⌊/⌋]-gcd-coprime {a}{b} nz = substitute₂(Coprime)
  ([⌊/⌋][⌊/⌋₀]-equality ⦃ [↔]-to-[→] gcd-positive nz ⦄)
  ([⌊/⌋][⌊/⌋₀]-equality ⦃ [↔]-to-[→] gcd-positive nz ⦄)
  ([⌊/⌋₀]-gcd-coprime nz)


------------------------------------------------------------------------
-- The Agda standard library
--
-- Some theory for Semigroup
------------------------------------------------------------------------

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

open import Algebra using (Semigroup)

module Algebra.Properties.Semigroup {a ℓ} (S : Semigroup a ℓ) where

open Semigroup S

x∙yz≈xy∙z : ∀ x y z → x ∙ (y ∙ z) ≈ (x ∙ y) ∙ z
x∙yz≈xy∙z x y z =  sym (assoc x y z)


{- Category of sets -}
module CategoryTheory.Instances.Sets where

open import CategoryTheory.Categories
open import CategoryTheory.BCCCs

import Function as F using (_∘_)
open import Data.Unit using () renaming (⊤ to top) public
open import Data.Product public
open import Data.Empty using (⊥-elim) renaming (⊥ to bot) public
open import Data.Sum

-- Category of sets.
𝕊et : Category lzero
𝕊et = record
    { obj      = Set
    ; _~>_     = λ a b   -> (a -> b)
    ; id       = λ a     -> a
    ; _∘_      = λ g f a -> g (f a)
    ; _≈_      = λ f g   -> ∀ {a} -> f a ≡ g a
    ; id-left  = refl
    ; id-right = refl
    ; ∘-assoc  = refl
    ; ≈-equiv  = record { refl = refl
                        ; sym = λ p → sym p
                        ; trans = λ p q → trans p q }
    ; ≈-cong   = ≈-cong-𝕊
    }
    where
    ≈-cong-𝕊 : ∀{A B C : Set} {f f′ : A -> B} {g g′ : B -> C}
            -> (∀ {a} -> f a ≡ f′ a)
            -> (∀ {b} -> g b ≡ g′ b)
            -> (∀ {a} -> g (f a) ≡ g′ (f′ a))
    ≈-cong-𝕊 {f′ = f′} fe ge {a′} rewrite fe {a′} | ge {f′ a′} = refl

-- Bicartesian closed structure
𝕊et-BCCC : BicartesianClosed 𝕊et
𝕊et-BCCC = record
    { cart = record
        { term = record
            { ⊤ = top
            ; ! = λ {A} _ → top.tt
            ; !-unique = λ m → refl
            }
        ; prod = λ A B → record
            { A⊗B = A × B
            ; π₁ = proj₁
            ; π₂ = proj₂
            ; ⟨_,_⟩ = <_,_>
            ; π₁-comm = refl
            ; π₂-comm = refl
            ; ⊗-unique = λ pr1 pr2 → unique-cart (ext λ x → pr1 {x}) (ext λ x → pr2 {x})
            }
        }
    ; cocart = record
        { init = record
            { ⊥ = bot
            ; ¡ = ⊥-elim
            ; ¡-unique = λ {A} m → λ {}
            }
        ; sum = λ A B → record
            { A⊕B = A ⊎ B
            ; ι₁ = inj₁
            ; ι₂ = inj₂
            ; [_⁏_] = [_,_]
            ; ι₁-comm = λ {S} {i₁} {i₂} {a} → refl
            ; ι₂-comm = λ {S} {i₁} {i₂} {a} → refl
            ; ⊕-unique = λ {S} {i₁} {i₂} {m} pr1 pr2
                      -> unique-cocart {m = m} (ext λ x → pr1 {x}) (ext λ x → pr2 {x})
            }
        }
    ; closed = record
        { exp = λ A B → record
            { A⇒B = A -> B
            ; eval = λ fa → proj₁ fa (proj₂ fa)
            ; Λ = λ f a b → f (a , b)
            ; Λ-comm = refl
            ; Λ-unique = λ pr → λ {a} ->  unique-closed (ext λ x → pr {x})
            ; Λ-cong = λ pr → ext (λ _ → pr)
            }
        }
    }
    where
    unique-cart : ∀{A B P : Set}{a}
              -> {p₁ : P -> A} {p₂ : P -> B} {m : P -> A × B}
              -> proj₁ F.∘ m ≡ p₁ -> proj₂ F.∘ m ≡ p₂
              -> < p₁ , p₂ > a ≡ m a
    unique-cart refl refl = refl
    unique-cocart : ∀{A B S : Set}{a}
              -> {i₁ : A -> S} {i₂ : B -> S} {m : A ⊎ B -> S}
              -> m F.∘ inj₁ ≡ i₁ -> m F.∘ inj₂ ≡ i₂
              -> [ i₁ , i₂ ] a ≡ m a
    unique-cocart {a = inj₁ x} refl refl = refl
    unique-cocart {a = inj₂ y} refl refl = refl
    open Category 𝕊et
    unique-closed : ∀{A B E : Set}{a}
              -> {e : E × A -> B} {m : E -> (A -> B)}
              -> (λ fa → proj₁ fa (proj₂ fa)) ∘ < m ∘ proj₁ , proj₂ > ≡ e
              -> (λ b → e (a , b)) ≡ m a
    unique-closed refl = refl


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

open import HoTT

module homotopy.ConstantToSetFactorization
  {i j} {A : Type i} {B : Type j} (B-is-set : is-set B)
  (f : A → B) (f-is-const : ∀ a₁ a₂ → f a₁ == f a₂) where

  private
    Skel = SetQuotient {A = A} (λ _ _ → Unit)

    abstract
      Skel-has-all-paths : has-all-paths Skel
      Skel-has-all-paths =
        SetQuot-elim (λ _ → Π-is-set λ _ → =-preserves-set SetQuotient-is-set)
          (λ a₁ →
            SetQuot-elim {P = λ s₂ → q[ a₁ ] == s₂}
              (λ _ → =-preserves-set SetQuotient-is-set)
              (λ _ → quot-rel _)
              (λ _ → prop-has-all-paths-↓ (SetQuotient-is-set _ _)))
          (λ {a₁ a₂} _ → ↓-cst→app-in λ s₂ →
              prop-has-all-paths-↓ (SetQuotient-is-set _ _))

    Skel-is-prop : is-prop Skel
    Skel-is-prop = all-paths-is-prop Skel-has-all-paths

    Skel-lift : Skel → B
    Skel-lift = SetQuot-rec B-is-set f (λ {a₁ a₂} _ → f-is-const a₁ a₂)

  cst-extend : Trunc -1 A → B
  cst-extend = Skel-lift ∘ Trunc-rec Skel-is-prop q[_]

  -- The beta rule.
  -- This is definitionally true, so you don't need it.
  cst-extend-β : cst-extend ∘ [_] == f
  cst-extend-β = idp


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

module Tools.Fin where

open import Tools.Nat
open import Tools.Nullary
open import Tools.PropositionalEquality

open import Data.Fin.Properties using (suc-injective)

open import Data.Fin public using (Fin) renaming (zero to x0 ; suc to _+1)

-- Decidability of equality

_≟ⱽ_ : {n : Nat} → (x y : Fin n) → Dec (x ≡ y)
x0 ≟ⱽ x0 = yes refl
x0 ≟ⱽ (y +1) = no (λ ())
(x +1) ≟ⱽ x0 = no (λ ())
(x +1) ≟ⱽ (y +1) = map (cong _+1) suc-injective (x ≟ⱽ y)


module _ where

open import Common.Prelude

data Vec (A : Set) : Nat → Set where
  [] : Vec A 0
  _∷_ : ∀ {@0 n} → A → Vec A n → Vec A (suc n)

sum : ∀ {@0 n} → Vec Nat n → Nat
sum (x ∷ xs) = x + sum xs
sum [] = 0

foldl : ∀ {A} {B : Nat → Set} → (∀ {@0 n} → B n → A → B (suc n)) → B 0 → ∀ {@0 n} → Vec A n → B n
foldl {B = B} f z (x ∷ xs) = foldl {B = λ n → B (suc n)} f (f z x) xs
foldl f z [] = z

reverse : ∀ {A} {@0 n} → Vec A n → Vec A n
reverse = foldl {B = Vec _} (λ xs x → x ∷ xs) []

downFrom : ∀ n → Vec Nat n
downFrom zero = []
downFrom (suc n) = n ∷ downFrom n

main : IO Unit
main = printNat (sum (reverse (downFrom 100000)))


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

module fin where

open import Data.Fin hiding (_<_ ; _≤_ )
open import Data.Fin.Properties hiding ( <-trans )
open import Data.Nat
open import logic
open import nat
open import Relation.Binary.PropositionalEquality

-- toℕ<n
fin<n : {n : ℕ} {f : Fin n} → toℕ f < n
fin<n {_} {zero} = s≤s z≤n
fin<n {suc n} {suc f} = s≤s (fin<n {n} {f})

-- toℕ≤n
fin≤n : {n : ℕ} (f : Fin (suc n)) → toℕ f ≤ n
fin≤n {_} zero = z≤n
fin≤n {suc n} (suc f) = s≤s (fin≤n {n} f)

pred<n : {n : ℕ} {f : Fin (suc n)} → n > 0  → Data.Nat.pred (toℕ f) < n
pred<n {suc n} {zero} (s≤s z≤n) = s≤s z≤n
pred<n {suc n} {suc f} (s≤s z≤n) = fin<n

fin<asa : {n : ℕ} → toℕ (fromℕ< {n} a<sa) ≡ n
fin<asa = toℕ-fromℕ< nat.a<sa

-- fromℕ<-toℕ
toℕ→from : {n : ℕ} {x : Fin (suc n)} → toℕ x ≡ n → fromℕ n ≡ x
toℕ→from {0} {zero} refl = refl
toℕ→from {suc n} {suc x} eq = cong (λ k → suc k ) ( toℕ→from {n} {x} (cong (λ k → Data.Nat.pred k ) eq ))

0≤fmax : {n : ℕ } → (# 0) Data.Fin.≤ fromℕ< {n} a<sa
0≤fmax  = subst (λ k → 0 ≤ k ) (sym (toℕ-fromℕ< a<sa)) z≤n

0<fmax : {n : ℕ } → (# 0) Data.Fin.< fromℕ< {suc n} a<sa
0<fmax = subst (λ k → 0 < k ) (sym (toℕ-fromℕ< a<sa)) (s≤s z≤n)

-- toℕ-injective
i=j : {n : ℕ} (i j : Fin n) → toℕ i ≡ toℕ j → i ≡ j
i=j {suc n} zero zero refl = refl
i=j {suc n} (suc i) (suc j) eq = cong ( λ k → suc k ) ( i=j i j (cong ( λ k → Data.Nat.pred k ) eq) )

-- raise 1
fin+1 :  { n : ℕ } → Fin n → Fin (suc n)
fin+1  zero = zero
fin+1  (suc x) = suc (fin+1 x)

open import Data.Nat.Properties as NatP  hiding ( _≟_ )

fin+1≤ : { i n : ℕ } → (a : i < n)  → fin+1 (fromℕ< a) ≡ fromℕ< (<-trans a a<sa)
fin+1≤ {0} {suc i} (s≤s z≤n) = refl
fin+1≤ {suc n} {suc (suc i)} (s≤s (s≤s a)) = cong (λ k → suc k ) ( fin+1≤ {n} {suc i} (s≤s a) )

fin+1-toℕ : { n : ℕ } → { x : Fin n} → toℕ (fin+1 x) ≡ toℕ x
fin+1-toℕ {suc n} {zero} = refl
fin+1-toℕ {suc n} {suc x} = cong (λ k → suc k ) (fin+1-toℕ {n} {x})

open import Relation.Nullary
open import Data.Empty

fin-1 :  { n : ℕ } → (x : Fin (suc n)) → ¬ (x ≡ zero )  → Fin n
fin-1 zero ne = ⊥-elim (ne refl )
fin-1 {n} (suc x) ne = x

fin-1-sx : { n : ℕ } → (x : Fin n) →  fin-1 (suc x) (λ ()) ≡ x
fin-1-sx zero = refl
fin-1-sx (suc x) = refl

fin-1-xs : { n : ℕ } → (x : Fin (suc n)) → (ne : ¬ (x ≡ zero ))  → suc (fin-1 x ne ) ≡ x
fin-1-xs zero ne = ⊥-elim ( ne refl )
fin-1-xs (suc x) ne = refl

-- suc-injective
-- suc-eq : {n : ℕ } {x y : Fin n} → Fin.suc x ≡ Fin.suc y  → x ≡ y
-- suc-eq {n} {x} {y} eq = subst₂ (λ j k → j ≡ k ) {!!} {!!} (cong (λ k → Data.Fin.pred k ) eq )

-- this is refl
lemma3 : {a b : ℕ } → (lt : a < b ) → fromℕ< (s≤s lt) ≡ suc (fromℕ< lt)
lemma3 (s≤s lt) = refl

-- fromℕ<-toℕ
lemma12 : {n m : ℕ } → (n<m : n < m ) → (f : Fin m )  → toℕ f ≡ n → f ≡ fromℕ< n<m
lemma12 {zero} {suc m} (s≤s z≤n) zero refl = refl
lemma12 {suc n} {suc m} (s≤s n<m) (suc f) refl =  cong suc ( lemma12 {n} {m} n<m f refl  )

open import Relation.Binary.HeterogeneousEquality as HE using (_≅_ )
open import Data.Fin.Properties

-- <-irrelevant
<-nat=irr : {i j n : ℕ } → ( i ≡ j ) → {i<n : i < n } → {j<n : j < n } → i<n ≅ j<n
<-nat=irr {zero} {zero} {suc n} refl {s≤s z≤n} {s≤s z≤n} = HE.refl
<-nat=irr {suc i} {suc i} {suc n} refl {s≤s i<n} {s≤s j<n} = HE.cong (λ k → s≤s k ) ( <-nat=irr {i} {i} {n} refl  )

lemma8 : {i j n : ℕ } → ( i ≡ j ) → {i<n : i < n } → {j<n : j < n } → i<n ≅ j<n
lemma8 {zero} {zero} {suc n} refl {s≤s z≤n} {s≤s z≤n} = HE.refl
lemma8 {suc i} {suc i} {suc n} refl {s≤s i<n} {s≤s j<n} = HE.cong (λ k → s≤s k ) ( lemma8 {i} {i} {n} refl  )

-- fromℕ<-irrelevant
lemma10 : {n i j  : ℕ } → ( i ≡ j ) → {i<n : i < n } → {j<n : j < n }  → fromℕ< i<n ≡ fromℕ< j<n
lemma10 {n} refl  = HE.≅-to-≡ (HE.cong (λ k → fromℕ< k ) (lemma8 refl  ))

lemma31 : {a b c : ℕ } → { a<b : a < b } { b<c : b < c } { a<c : a < c } → NatP.<-trans a<b b<c ≡ a<c
lemma31 {a} {b} {c} {a<b} {b<c} {a<c} = HE.≅-to-≡ (lemma8 refl)

-- toℕ-fromℕ<
lemma11 : {n m : ℕ } {x : Fin n } → (n<m : n < m ) → toℕ (fromℕ< (NatP.<-trans (toℕ<n x) n<m)) ≡ toℕ x
lemma11 {n} {m} {x} n<m  = begin
              toℕ (fromℕ< (NatP.<-trans (toℕ<n x) n<m))
           ≡⟨ toℕ-fromℕ< _ ⟩
              toℕ x
           ∎  where
               open ≡-Reasoning


-----------------------------------
-- First order logic
-----------------------------------

module sv20.assign2.SetTheory.Logic where

infix 4 _,_
infix 3 ¬_
infix 1 _∧_
infix 1 _∨_
infix 0 _⇔_

-- Some First order logic I need.

-- ∧ data type (conjunction).

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

∧-proj₁ : ∀ {A B} → A ∧ B → A
∧-proj₁ (a , _) = a

∧-proj₂ : ∀ {A B} → A ∧ B → B
∧-proj₂ (_ , b) = b

-- ∨ data type (disjunction), with many useful properties.

data _∨_ (A B : Set) : Set where
  inj₁ : A → A ∨ B
  inj₂ : B → A ∨ B

∨-e : (A B C : Set) → A ∨ B → (A → C) → (B → C) → C
∨-e A B C (inj₁ a) i₁ i₂ = i₁ a
∨-e A B C (inj₂ b) i₁ i₂ = i₂ b

∨-sym : (A B : Set) → A ∨ B → B ∨ A
∨-sym A B (inj₁ a) = inj₂ a
∨-sym A B (inj₂ b) = inj₁ b

trivial : (A : Set) → A → A
trivial _ A = A

∨-idem : (A : Set) → A ∨ A → A
∨-idem A (inj₁ a) = a
∨-idem A (inj₂ a) = a

∨-prop₁ : {A B C : Set} → (A ∨ B → C) → A → C
∨-prop₁ i a = i (inj₁ a)

∨-prop₂ : {A B C : Set} → (A ∨ B → C) → B → C
∨-prop₂ i b = i (inj₂ b)

∨-prop₃ : {A B C : Set} → A ∨ B → (A → C) → C ∨ B
∨-prop₃ (inj₁ x) i = inj₁ (i x)
∨-prop₃ (inj₂ x) i = inj₂ x

∨-prop₄ : {A B C : Set} → A ∨ B → (B → C) → A ∨ C
∨-prop₄ (inj₁ x) x₁ = inj₁ x
∨-prop₄ (inj₂ x) x₁ = inj₂ (x₁ x)

∨-prop₅ : {A B C D : Set} → A ∨ B → (A → C) → (B → D) → C ∨ D
∨-prop₅ (inj₁ a) a→c b→d = inj₁ (a→c a)
∨-prop₅ (inj₂ b) a→c b→d = inj₂ (b→d b)

∨-∧ : {A B : Set} → (A ∧ B) ∨ (B ∧ A) → A ∧ B
∨-∧ (inj₁ (a , b)) = a , b
∨-∧ (inj₂ (b , a)) = a , b

-- Bi-implication.

_⇔_ : Set → Set → Set
A ⇔ B = (A → B) ∧ (B → A)

⇔-p : (A B C : Set) →  A ⇔ (B ∧ C) → (C → B) → A ⇔ C
⇔-p A B C (h₁ , h₂) h₃ = prf₁ , prf₂
  where
  prf₁ : A → C
  prf₁ A = ∧-proj₂ (h₁ A)

  prf₂ : C → A
  prf₂ C = h₂ ((h₃ C) , C)

-- Empty data type.

data ⊥ : Set where

⊥-elim : {A : Set} → ⊥ → A
⊥-elim ()

data ⊤ : Set where
  tt : ⊤

-- Negation

¬_ : Set → Set
¬ A = A → ⊥

cont : (A : Set) → A ∧ ¬ A → ⊥
cont _ (x , ¬x) = ¬x x


-- Andreas, Ulf, 2015-06-03
-- Issue 473 was not fixed for records without constructor
record _×_ A B : Set where
  constructor _,_
  field
    fst : A
    snd : B

open _×_

data Nat : Set where
  zero : Nat
  suc  : Nat → Nat

data Zero : Nat → Set where
  zero : Zero zero

data Zero₂ : Nat → Nat → Set where
  zero : Zero₂ zero zero

f₁ : (p : Nat × Nat) → Zero₂ (fst p) (snd p) → Set
f₁ (.zero , .zero) zero = Nat    -- works
-- f₁ .(zero , zero) zero = Nat  -- fails

f₂ : (p : Nat × Nat) → Zero (fst p) → Set
f₂ (.zero , y) zero = Nat  -- works
-- foo .?? zero             -- fails (nothing to write in place of ??)

f₃ : {p : Nat × Nat} → Zero (fst p) → Set
f₃ zero = Nat

f₄ : {p : Nat × (Nat × Nat)} → Zero (fst (snd p)) → Set
f₄ zero = Nat

f₅ : {p : Nat × Nat} → Zero₂ (fst p) (snd p) → Set
f₅ zero = Nat

data I : Set where
  i : I

record Box (A B : Set) : Set where
  -- no constructor [_]
  field contents : A

[_] : ∀{A B} → A → Box A B
[ a ] = record { contents = a }

data D : Set → Set₁ where
  d₁ : (R : Set) → D R
  d₂ : (i : I) (R : I → Set) → D (R i) → D (Box I (R i))

data S : (R : Set) → R → D R → Set₁ where
  s : (j : I) (R : I → Set) (p : D (R j)) →
      S (Box I (R j)) [ j ] (d₂ j R p)

postulate
  P : I → Set

Fails : {e : Box I (P i)} → S (Box I (P i)) e (d₂ i P (d₁ (P i))) → Set₁
Fails (s .i .P .(d₁ (P i))) = Set

-- Refuse to solve heterogeneous constraint p : D (P (Box.contents e))
-- =?= d₁ (P i) : D (P i)
-- when checking that the pattern s .i .P .(d₁ (P i)) has type
-- S (Box I (P i)) e (d₂ i P (d₁ (P i)))


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

open import Categories.Category
open import Categories.Category.Monoidal

module Categories.Category.Monoidal.Traced {o ℓ e} {C : Category o ℓ e} (M : Monoidal C) where

open Category C

open import Level

open import Data.Product using (_,_)

open import Categories.Category.Monoidal.Symmetric M

private
  variable
    A B X Y : Obj
    f g : A ⇒ B

------------------------------------------------------------------------------
-- Def from http://ncatlab.org/nlab/show/traced+monoidal+category
--
-- A symmetric monoidal category (C,⊗,1,b) (where b is the symmetry) is
-- said to be traced if it is equipped with a natural family of functions
--
-- TrXA,B:C(A⊗X,B⊗X)→C(A,B)
-- satisfying three axioms:
--
-- Vanishing: Tr1A,B(f)=f (for all f:A→B) and
-- TrX⊗YA,B=TrXA,B(TrYA⊗X,B⊗X(f)) (for all f:A⊗X⊗Y→B⊗X⊗Y)
--
-- Superposing: TrXC⊗A,C⊗B(idC⊗f)=idC⊗TrXA,B(f) (for all f:A⊗X→B⊗X)
--
-- Yanking: TrXX,X(bX,X)=idX

-- Traced monoidal category
--  is a symmetric monoidal category with a trace operation
--
-- note that the definition in this library is significantly easier than the previous one because
-- we adopt a simpler definition of monoidal category to begin with.
record Traced : Set (levelOfTerm M) where
  field
    symmetric : Symmetric

  open Symmetric symmetric public

  field
    trace : ∀ {X A B} → A ⊗₀ X ⇒ B ⊗₀ X → A ⇒ B

    vanishing₁  : trace {X = unit} (f ⊗₁ id) ≈ f
    vanishing₂  : trace {X = X} (trace {X = Y} (associator.to ∘ f ∘ associator.from))
                ≈ trace {X = X ⊗₀ Y} f
    superposing : trace {X = X} (associator.to ∘ id {Y} ⊗₁ f ∘ associator.from) ≈ id {Y} ⊗₁ trace {X = X} f
    yanking     : trace (braiding.⇒.η (X , X)) ≈ id


{-

        Agda Implementors' Meeting VI

                  Göteborg
             May 24 - 30, 2007

                Hello Agda!

                Ulf Norell

-}

-- Let's have a closer look at the module system

module Modules where

{-

  Importing and opening modules

-}

-- You can import a module defined in a different file.
import Naturals

-- This will bring the module into scope and allows you to
-- access its contents using qualified names.
plusTwo : Naturals.Nat -> Naturals.Nat
plusTwo n = Naturals._+_ n 2

-- To bring everything from a module into scope you can open
-- the module.
open Naturals

z : Nat
z = zero

-- There's also a short-hand to import and open at the same time
open import Bool

_&&_ : Bool -> Bool -> Bool
x && y = if x then y else false

-- Sometimes it's nice to be able to control what is brought
-- into scope when you open a module. There are three modifiers
-- that affect this: using, hiding and renaming.

module DifferentWaysOfOpeningNat where

  -- nothing but Nat
  open Naturals using (Nat)

  -- everything but zero
  open Naturals hiding (zero)

  -- everything, but zero and suc under different names
  open Naturals renaming (zero to ZZ; suc to S_S)

  two : Nat
  two = S S ZZ S S

  -- you can combine using or hiding with renaming, but not using
  -- with hiding (for obvious reasons).

-- To re-export something opened use the public modifier.
module A where
  open Naturals public using (Nat)

N = A.Nat -- now Nat is a visible name in module A

{-

  Parameterised modules

-}

-- A very useful feature is parameterised modules.

data Vec (A : Set) : Nat -> Set where
  []   : Vec A 0
  _::_ : {n : Nat} -> A -> Vec A n -> Vec A (suc n)

infixr 40 _::_

module Sort {A : Set}(_≤_ : A -> A -> Bool) where

  insert : {n : Nat} -> A -> Vec A n -> Vec A (suc n)
  insert x [] = x :: []
  insert x (y :: ys) = if x ≤ y
                       then x :: y :: ys
                       else y :: insert x ys

  sort : {n : Nat} -> Vec A n -> Vec A n
  sort []        = []
  sort (x :: xs) = insert x (sort xs)

_≤_ : Nat -> Nat -> Bool
zero  ≤ m     = true
suc n ≤ zero  = false
suc n ≤ suc m = n ≤ m

-- When used directly, functions from parameterised modules
-- take the parameters as extra arguments.
test = Sort.sort _≤_ (6 :: 2 :: 0 :: 4 :: [])

-- But, you can also apply the entire module to its arguments.
-- Let's open the new module while we're at it.
open module SortNat = Sort _≤_

test' = sort (3 :: 2 :: 4 :: 0 :: [])

{-

  Local definitions

-}

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

subst : {A : Set}(C : A -> Set){x y : A} -> x == y -> C x -> C y
subst C refl cx = cx

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

lem₁ : (n : Nat) -> n + 0 == n
lem₁ zero    = refl
lem₁ (suc n) = cong suc (lem₁ n)

lem₂ : (n m : Nat) -> n + suc m == suc n + m
lem₂  zero   m = refl
lem₂ (suc n) m = cong suc (lem₂ n m)

-- You can define things locally to a function clause
reverse : {A : Set}{n : Nat} -> Vec A n -> Vec A n
reverse {A} = \xs -> subst (Vec A) (lem₁ _) (rev xs [])
  where
    rev : {n m : Nat} -> Vec A n -> Vec A m -> Vec A (n + m)
    rev []              ys = ys
    rev (_::_ {n} x xs) ys = subst (Vec A) (lem₂ n _)
                                   (rev xs (x :: ys))

-- More precisely, each clause can have one local module. In the
-- example above we didn't bother naming the module. We could've
-- said
reverse' : {A : Set}{n : Nat} -> Vec A n -> Vec A n
reverse' {A}{n} = \xs -> subst (Vec A) (lem₁ n) (rev xs [])
  module Rev where
    rev : {m p : Nat} -> Vec A m -> Vec A p -> Vec A (m + p)
    rev []              ys = ys
    rev (_::_ {n} x xs) ys = subst (Vec A) (lem₂ n _)
                                   (rev xs (x :: ys))

-- Now we can access the local function from inside the module Rev.
-- Variables bound in the left hand side of the clause become
-- parameters to the module, so since the implicit n argument to
-- reverse' is bound implicitly there's an extra argument of type
-- Nat which isn't used.

test'' = Rev.rev {_}{0} (4 :: 3 :: 2 :: []) (5 :: 6 :: [])

{-

  What's next?

-}

-- The final thing on the agenda is records.

-- Move on to: Records.agda


------------------------------------------------------------------------
-- The Agda standard library
--
-- Rational numbers in non-reduced form.
------------------------------------------------------------------------

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

module Data.Rational.Unnormalised where

open import Data.Integer.Base as ℤ using (ℤ; ∣_∣; +_; +0; +[1+_]; -[1+_])
open import Data.Nat as ℕ using (ℕ; zero; suc)
open import Level using (0ℓ)
open import Relation.Nullary using (¬_)
open import Relation.Nullary.Decidable using (False)
open import Relation.Binary using (Rel)
open import Relation.Binary.PropositionalEquality using (_≡_)

------------------------------------------------------------------------
-- Definition

-- Here we define rationals that are not necessarily in reduced form.
-- Consequently there are multiple ways of representing a given rational
-- number, and the performance of the arithmetic operations may suffer
-- due to blowup of the numerator and denominator.

-- Nonetheless they are much easier to reason about. In general proofs
-- are first proved for these unnormalised rationals and then translated
-- into the normalised rationals.

record ℚᵘ : Set where
  constructor mkℚᵘ
  field
    numerator     : ℤ
    denominator-1 : ℕ

  denominatorℕ : ℕ
  denominatorℕ = suc denominator-1

  denominator : ℤ
  denominator = + denominatorℕ

open ℚᵘ public using ()
  renaming
  ( numerator    to ↥_
  ; denominator  to ↧_
  ; denominatorℕ to ↧ₙ_
  )

------------------------------------------------------------------------
-- Equality of rational numbers (does not coincide with _≡_)

infix 4 _≃_
data _≃_ : Rel ℚᵘ 0ℓ where
  *≡* : ∀ {p q} → (↥ p ℤ.* ↧ q) ≡ (↥ q ℤ.* ↧ p) → p ≃ q

------------------------------------------------------------------------
-- Ordering of rationals

infix 4 _≤_ _<_ _≥_ _>_ _≰_ _≱_ _≮_ _≯_

data _≤_ : Rel ℚᵘ 0ℓ where
  *≤* : ∀ {p q} → (↥ p ℤ.* ↧ q) ℤ.≤ (↥ q ℤ.* ↧ p) → p ≤ q

data _<_ : Rel ℚᵘ 0ℓ where
  *<* : ∀ {p q} → (↥ p ℤ.* ↧ q) ℤ.< (↥ q ℤ.* ↧ p) → p < q

_≥_ : Rel ℚᵘ 0ℓ
x ≥ y = y ≤ x

_>_ : Rel ℚᵘ 0ℓ
x > y = y < x

_≰_ : Rel ℚᵘ 0ℓ
x ≰ y = ¬ (x ≤ y)

_≱_ : Rel ℚᵘ 0ℓ
x ≱ y = ¬ (x ≥ y)

_≮_ : Rel ℚᵘ 0ℓ
x ≮ y = ¬ (x < y)

_≯_ : Rel ℚᵘ 0ℓ
x ≯ y = ¬ (x > y)

------------------------------------------------------------------------
-- Constructing rationals

infix 4 _≢0
_≢0 : ℕ → Set
n ≢0 = False (n ℕ.≟ 0)

-- An alternative constructor for ℚᵘ. See the constants section below
-- for examples of how to use this operator.

infixl 7 _/_

_/_ : (n : ℤ) (d : ℕ) .{d≢0 : d ≢0} → ℚᵘ
n / suc d = mkℚᵘ n d

------------------------------------------------------------------------------
-- Operations on rationals

infix  8 -_ 1/_
infixl 7 _*_ _÷_
infixl 6 _-_ _+_

-- negation

-_ : ℚᵘ → ℚᵘ
- mkℚᵘ n d = mkℚᵘ (ℤ.- n) d

-- addition

_+_ : ℚᵘ → ℚᵘ → ℚᵘ
p + q = (↥ p ℤ.* ↧ q ℤ.+ ↥ q ℤ.* ↧ p) / (↧ₙ p ℕ.* ↧ₙ q)

-- multiplication

_*_ : ℚᵘ → ℚᵘ → ℚᵘ
p * q = (↥ p ℤ.* ↥ q) / (↧ₙ p ℕ.* ↧ₙ q)

-- subtraction

_-_ : ℚᵘ → ℚᵘ → ℚᵘ
p - q = p + (- q)

-- reciprocal: requires a proof that the numerator is not zero

1/_ : (p : ℚᵘ) → .{n≢0 : ∣ ↥ p ∣ ≢0} → ℚᵘ
1/ mkℚᵘ +[1+ n ] d = mkℚᵘ +[1+ d ] n
1/ mkℚᵘ -[1+ n ] d = mkℚᵘ -[1+ d ] n

-- division: requires a proof that the denominator is not zero

_÷_ : (p q : ℚᵘ) → .{n≢0 : ∣ ↥ q ∣ ≢0} → ℚᵘ
(p ÷ q) {n≢0} = p * (1/_ q {n≢0})

------------------------------------------------------------------------------
-- Some constants

0ℚᵘ : ℚᵘ
0ℚᵘ = + 0 / 1

1ℚᵘ : ℚᵘ
1ℚᵘ = + 1 / 1

½ : ℚᵘ
½ = + 1 / 2

-½ : ℚᵘ
-½ = - ½


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

open import Cubical.Foundations.Prelude
open import Cubical.Data.Int renaming (ℤ to ℤType ; _+_ to _+ℤ_ ; _-_ to _-ℤ_; -_ to -ℤ_ ; _·_ to _·ℤ_)
open import Cubical.Algebra.Group.Base

open GroupStr

ℤ : Group₀
fst ℤ = ℤType
1g (snd ℤ) = 0
_·_ (snd ℤ) = _+ℤ_
inv (snd ℤ) = _-ℤ_ 0
isGroup (snd ℤ) = isGroupℤ
  where
  abstract
    isGroupℤ : IsGroup (pos 0) _+ℤ_ (_-ℤ_ (pos 0))
    isGroupℤ = makeIsGroup isSetℤ +Assoc (λ _ → refl) (+Comm 0)
                           (λ x → +Comm x (pos 0 -ℤ x) ∙ minusPlus x 0)
                           (λ x → minusPlus x 0)


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

open import Agda.Primitive using (Level; lzero; lsuc; _⊔_)
open import LogicalFormulae
open import Sets.EquivalenceRelations
open import Setoids.Setoids
open import Setoids.Subset

module Setoids.Intersection.Lemmas {a b : _} {A : Set a} (S : Setoid {a} {b} A) {c d : _} {pred1 : A → Set c} {pred2 : A → Set d} (s1 : subset S pred1) (s2 : subset S pred2) where

open import Setoids.Intersection.Definition S
open import Setoids.Equality S

intersectionCommutative : intersection s1 s2 =S intersection s2 s1
intersectionCommutative i = (λ t → _&&_.snd t ,, _&&_.fst t) ,, λ t → _&&_.snd t ,, _&&_.fst t

intersectionAssociative : {e : _} {pred3 : A → Set e} (s3 : subset S pred3) → intersection (intersection s1 s2) s3 =S intersection s1 (intersection s2 s3)
intersectionAssociative s3 x = (λ pr → _&&_.fst (_&&_.fst pr) ,, (_&&_.snd (_&&_.fst pr) ,, _&&_.snd pr)) ,, λ z → (_&&_.fst z ,, _&&_.fst (_&&_.snd z)) ,, _&&_.snd (_&&_.snd z)


-- Andreas, 2011-04-14
-- {-# OPTIONS -v tc.cover:20 -v tc.lhs.unify:20 #-}

-- Jesper, 2016-06-23: should also work --cubical-compatible
{-# OPTIONS --cubical-compatible #-}

module Issue291-1775 where

-- Example by Ulf

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

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

-- since 'n' occurs stronly rigid in 'suc n', the type 'n ≡ suc n' is empty
h : (n : Nat) -> n ≡ suc n -> Nat
h n ()

-- Example by jdanbr...@gmail.com

data Type : Set where
  ₁   : Type
  _×_ : Type → Type → Type
  _+_ : Type → Type → Type

data Fun : Type → Type → Set where
  _∙_ : ∀ {s t u} → Fun t u → Fun s t → Fun s u
  π₁  : ∀ {s t} →   Fun (s × t) s
  π₂  : ∀ {s t} →   Fun (s × t) t
  ι₁  : ∀ {s t} →   Fun s (s + t)
  ι₂  : ∀ {s t} →   Fun t (s + t)

data Val : (t : Type) → Fun ₁ t → Set where
  Valι₁ : ∀ {s t V} → Val s V → Val (s + t) (ι₁ ∙ V)
  Valι₂ : ∀ {s t V} → Val t V → Val (s + t) (ι₂ ∙ V)

data ⊥ : Set where

-- should succeed:
¬Valπ₁ : ∀ {s t : Type} {M : Fun ₁ (s × t)} → Val s (π₁ ∙ M) → ⊥
¬Valπ₁ ()
{- OLD ERROR:
Val .s (π₁ ∙ .M) should be empty, but it isn't obvious that it is.
when checking that the clause ¬Valπ₁ () has type
{s t : Type} {M : Fun ₁ (s × t)} → Val s (π₁ ∙ M) → ⊥
-}


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

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

open import Setoids.Setoids
open import Rings.Definition
open import Rings.Orders.Partial.Definition
open import Rings.Orders.Total.Definition
open import Sets.EquivalenceRelations
open import Sequences
open import Setoids.Orders.Partial.Definition
open import Setoids.Orders.Total.Definition
open import Functions.Definition
open import LogicalFormulae
open import Numbers.Naturals.Semiring
open import Groups.Definition

module Rings.Orders.Total.Bounded {m n o : _} {A : Set m} {S : Setoid {m} {n} A} {_+_ : A → A → A} {_*_ : A → A → A} {_<_ : Rel {m} {o} A} {pOrder : SetoidPartialOrder S _<_} {R : Ring S _+_ _*_} {pRing : PartiallyOrderedRing R pOrder} (tRing : TotallyOrderedRing pRing) where

open import Rings.Orders.Partial.Bounded pRing
open Ring R
open Group additiveGroup
open import Groups.Lemmas (Ring.additiveGroup R)
open Setoid S
open Equivalence eq
open SetoidPartialOrder pOrder
open import Rings.Orders.Total.Lemmas tRing
open PartiallyOrderedRing pRing

boundGreaterThanZero : {s : Sequence A} → (b : Bounded s) → 0G < underlying b
boundGreaterThanZero {s} (a , b) with b 0
... | (l ,, r) = halvePositive a (<WellDefined invLeft reflexive (orderRespectsAddition (<Transitive l r) a))


module Numeral.Integer.Oper where

open import Numeral.Natural      as ℕ using (ℕ)
import      Numeral.Natural.Oper as ℕ
open import Numeral.Integer
open import Numeral.Integer.Sign
import      Numeral.Sign       as Sign
import      Numeral.Sign.Oper0 as Sign

-- Unclosed total subtraction from natural numbers to integers
_−ₙ_ : ℕ → ℕ → ℤ
x      −ₙ ℕ.𝟎    = ℤ.+ₙ x
ℕ.𝟎    −ₙ ℕ.𝐒(x) = ℤ.−𝐒ₙ(x)
ℕ.𝐒(x) −ₙ ℕ.𝐒(y) = x −ₙ y

-- Construction of an integer with the sign and numeral components
signed : (Sign.+|−) → ℕ → ℤ
signed (Sign.➕) (n) = +ₙ n
signed (Sign.➖) (n) = −ₙ n

signed0 : (Sign.+|0|−) → ℕ → ℤ
signed0(Sign.➕) (ℕ.𝐒(n)) = +𝐒ₙ(n)
signed0(Sign.➖) (ℕ.𝐒(n)) = −𝐒ₙ(n)
{-# CATCHALL #-}
signed0(_)      (_)      = 𝟎

------------------------------------------
-- Unary operations

-- Predecessor
𝐏 : ℤ → ℤ
𝐏(+𝐒ₙ(n)) = +ₙ n
𝐏(𝟎)      = −𝐒ₙ(ℕ.𝟎)
𝐏(−𝐒ₙ(n)) = −𝐒ₙ(ℕ.𝐒(n))

-- Successor
𝐒 : ℤ → ℤ
𝐒(+ₙ n)        = +ₙ ℕ.𝐒(n)
𝐒(−𝐒ₙ(ℕ.𝟎))    = +ₙ ℕ.𝟎
𝐒(−𝐒ₙ(ℕ.𝐒(n))) = −𝐒ₙ(n)

-- Identity
+_ : ℤ → ℤ
+ n = n

-- Negation
−_ : ℤ → ℤ
− 𝟎 = 𝟎
− (+𝐒ₙ(n)) = −𝐒ₙ(n)
− (−𝐒ₙ(n)) = +𝐒ₙ(n)

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

------------------------------------------
-- Binary operations

infixl 10010 _+_
infixl 10020 _⋅_

-- Addition
_+_ : ℤ → ℤ → ℤ
(+ₙ  x) + (+ₙ  y) = +ₙ (x ℕ.+ y)
(−𝐒ₙ x) + (−𝐒ₙ y) = −𝐒ₙ(ℕ.𝐒(x ℕ.+ y))
(+ₙ  x) + (−𝐒ₙ y) = x −ₙ ℕ.𝐒(y)
(−𝐒ₙ x) + (+ₙ  y) = (+ₙ y) + (−𝐒ₙ x)

-- Subtraction
_−_ : ℤ → ℤ → ℤ
x − y = x + (− y)

-- Multiplication
_⋅_ : ℤ → ℤ → ℤ
x ⋅ y = signed0 ((sign0 x) Sign.⨯ (sign0 y)) ((absₙ x) ℕ.⋅ (absₙ y))

-- Distance
_𝄩_ : ℤ → ℤ → ℕ
(+ₙ  x)     𝄩 (+ₙ  y)     = x ℕ.𝄩 y
(−𝐒ₙ x)     𝄩 (−𝐒ₙ y)     = x ℕ.𝄩 y
(+ₙ(ℕ.𝟎))   𝄩 (−𝐒ₙ y)     = ℕ.𝐒(y)
(+ₙ(ℕ.𝐒 x)) 𝄩 (−𝐒ₙ y)     = ℕ.𝐒((+ₙ x) 𝄩 (−𝐒ₙ y))
(−𝐒ₙ x)     𝄩 (+ₙ(ℕ.𝟎))   = ℕ.𝐒(x)
(−𝐒ₙ x)     𝄩 (+ₙ(ℕ.𝐒 y)) = ℕ.𝐒((−𝐒ₙ x) 𝄩 (+ₙ y))


{-# OPTIONS --without-K --no-pattern-matching #-}

module Ch2-9 where

open import Level hiding (lift)

open import Ch2-1
open import Ch2-2
open import Ch2-3
open import Ch2-4
open import Ch2-5
open import Ch2-6
open import Ch2-7
open import Ch2-8

open import Data.Product
open import Function using (id; _∘_)

-- happly (Definition 2.9.2)
happly : ∀ {a} {b} {A : Set a} {B : A → Set b}
  → {f g : (x : A) → B x}
  → (f ≡ g) → (f ~ g)
happly {_} {_} {A} {B} {f} {g} p = J ((x : A) → B x) D d f g p
  where
    D : (f g : (x : A) → B x) (p : f ≡ g) → Set _
    D f g p = f ~ g

    d : (x : (x : A) → B x) → D x x refl
    d f x = refl

postulate
  funext : ∀ {a} {b} {A : Set a} {B : A → Set b}
    → {f g : (x : A) → B x}
    → (f ~ g) → (f ≡ g)

Theorem-2-9-1 : ∀ {a} {b} {A : Set a} {B : A → Set b}
  → (f g : (x : A) → B x)
  → (f ≡ g) ≅ (f ~ g)
Theorem-2-9-1 {_} {_} {A} {B} f g = happly , (funext , α) , (funext , {!   !})

  where
    α : happly ∘ funext ~ id
    α p = J {!   !} D {!   !} f g (funext p)
      -- J ((x : A) → B x) D d f g (funext p)
      --
      where
        D : (f g : (x : A) → B x) (p : {!   !}) → Set _
        D f g p = {!   !}
          -- ((λ {x} → happly) ∘ funext) p ≡ id p
          -- ((λ {x} → happly) ∘ funext) p ≡ id p
          -- happly ∘ funext ~ id

        -- d : (x : (x : A) → B x) → D x x refl
        -- d x = refl

    -- happly-isequiv : isequiv (happly f g)
    -- happly-isequiv =

  -- where
  --   f : x ≡ y → ⊤
  --   f p = tt
  --
  --   f' : ⊤ → x ≡ y
  --   f' x = refl
  --
  --   α : (λ _ → f refl) ~ id
  --   α w = refl
  --
  --   β : (λ _ → refl) ~ id
  --   β w = J ⊤ D d x y w
  --     where
  --       D : (x y : ⊤) (p : x ≡ y) → Set _
  --       D x y p = refl ≡ id p
  --
  --       d : (x : ⊤) → D x x refl
  --       d x = refl
  --
  --   f-isequiv : isequiv f
  --   f-isequiv = (f' , α) , f' , β


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

-- Discrete Category.
-- https://ncatlab.org/nlab/show/discrete+category
-- says:
-- A category is discrete if it is both a groupoid and a preorder. That is,
-- every morphism should be invertible, any two parallel morphisms should be equal.
-- The idea is that in a discrete category, no two distinct (nonisomorphic) objects
-- are connectable by any path (morphism), and an object connects to itself only through
-- its identity morphism.

open import Level using (Level; suc; _⊔_)

open import Categories.Category using (Category)
open import Categories.Category.Groupoid using (IsGroupoid)

record IsDiscrete {o ℓ e} (C : Category o ℓ e) : Set (o ⊔ ℓ ⊔ e) where
  open Category C using (Obj; _⇒_; _≈_)
  field
     isGroupoid : IsGroupoid C
     preorder : {A B : Obj} → (f g : A ⇒ B) → f ≈ g

record DiscreteCategory (o ℓ e : Level) : Set (suc (o ⊔ ℓ ⊔ e)) where
  field
    category   : Category o ℓ e
    isDiscrete : IsDiscrete category

  open IsDiscrete isDiscrete public


{-# OPTIONS --safe #-}
module Cubical.Categories.Instances.Poset where

open import Cubical.Foundations.Prelude

open import Cubical.Relation.Binary.Poset

open import Cubical.Categories.Category

open Category

private
  variable
    ℓ ℓ' : Level

module _ (P : Poset ℓ ℓ') where

  open PosetStr (snd P)

  PosetCategory : Category ℓ ℓ'
  ob PosetCategory           = fst P
  Hom[_,_] PosetCategory     = _≤_
  id PosetCategory           = is-refl _
  _⋆_ PosetCategory          = is-trans _ _ _
  ⋆IdL PosetCategory _       = is-prop-valued _ _ _ _
  ⋆IdR PosetCategory _       = is-prop-valued _ _ _ _
  ⋆Assoc PosetCategory _ _ _ = is-prop-valued _ _ _ _
  isSetHom PosetCategory     = isProp→isSet (is-prop-valued _ _)


-- Syntax: Types, terms and contexts.
module Syntax where

open import Library

infixr 6 _⇒_
infixr 4 _,_

-- Types and contexts.

data Ty : Set where
  ★   : Ty
  _⇒_ : (a b : Ty) → Ty

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

-- Variables and terms.

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

data Tm (Γ : Cxt) : (a : Ty) → Set where
  var : ∀ {a}   (x : Var Γ a)                   → Tm Γ a
  abs : ∀ {a b} (t : Tm (Γ , a) b)              → Tm Γ (a ⇒ b)
  app : ∀ {a b} (t : Tm Γ (a ⇒ b)) (u : Tm Γ a) → Tm Γ b

-- Generalized neutral terms.

data GNe (Arg : Cxt → Ty → Set) (Γ : Cxt) : Ty → Set where
  var : ∀{a}    (x : Var Γ a)                         → GNe Arg Γ a
  app : ∀{a b}  (n : GNe Arg Γ (a ⇒ b)) (o : Arg Γ a) → GNe Arg Γ b

-- βη-normal forms.

mutual

  Ne = GNe Nf

  data Nf (Γ : Cxt) : Ty → Set where
    abs : ∀{a b}  (o : Nf (Γ , a) b)  → Nf Γ (a ⇒ b)
    ne  :         (n : Ne Γ ★)        → Nf Γ ★

mutual

  embNe : ∀{Γ a} → Ne Γ a → Tm Γ a
  embNe (var x) = var x
  embNe (app t u) = app (embNe t) (embNf u)

  embNf : ∀{Γ a} → Nf Γ a → Tm Γ a
  embNf (ne t) = embNe t
  embNf (abs t) = abs (embNf t)


import      Lvl

module Structure.Semicategory {ℓₒ ℓₘ ℓₑ : Lvl.Level} where

open import Functional using (swap)
open import Logic
import      Structure.Categorical.Names as Names
open import Structure.Categorical.Properties
open import Structure.Operator
import      Structure.Relator.Names as Names
open import Structure.Relator.Properties
open import Structure.Setoid
open import Type

-- Obj is the collection of objects.
-- _⟶_ is the collection of morphisms.
module _
  {Obj : Type{ℓₒ}}
  (_⟶_ : Obj → Obj → Type{ℓₘ})
  ⦃ morphism-equiv : ∀{x y} → Equiv{ℓₑ}(x ⟶ y) ⦄
  where

  -- A semicategory is a structure on a relation called a morphism.
  --
  -- It is similar to a category (a generalisation of it), but without the identity morphism/reflexivity.
  -- See `Structure.Category`.
  --
  -- It can also be seen as a generalized algebraic structure, or more specifically a generalization of semigroups (structure with an associative binary operator).
  -- The similarity between a semicategory and a category is like the similarity between a semigroup and a monoid.
  --
  -- An alternative interpretation of the definition:
  -- A type (Obj) and a binary relation (Morphism) on this type is a semicategory when:
  -- • The relator is transitive.
  -- • Chains of the transitivity proofs can be applied in any order and the resulting proof will be the same.
  record Semicategory : Stmt{ℓₒ Lvl.⊔ ℓₘ Lvl.⊔ ℓₑ} where
    field
      _∘_ : Names.SwappedTransitivity(_⟶_)

    field
      ⦃ binaryOperator ⦄ : ∀{x y z} → BinaryOperator(_∘_ {x}{y}{z})
      ⦃ associativity ⦄ : Morphism.Associativity(\{x} → _∘_ {x})

    -- This can be interpreted as proof of transitivity when `Morphism` is interpreted as a binary relation.
    morphism-transitivity : Transitivity(_⟶_)
    morphism-transitivity = intro(swap(_∘_))

    module ArrowNotation = Names.ArrowNotation(_⟶_)

record SemicategoryObject : Stmt{Lvl.𝐒(ℓₒ Lvl.⊔ ℓₘ Lvl.⊔ ℓₑ)} where
  constructor intro
  field
    {Object}           : Type{ℓₒ}
    {Morphism}         : Object → Object → Type{ℓₘ}
    ⦃ morphism-equiv ⦄ : ∀{x y} → Equiv{ℓₑ}(Morphism x y)
    semicategory       : Semicategory(Morphism)

  open Semicategory(semicategory) public
  instance
    semicategory-instance = semicategory


------------------------------------------------------------------------------
-- Generic well-founded induction on trees
------------------------------------------------------------------------------

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

-- Adapted from FOTC.Data.Nat.Induction.Acc.WellFounded.

module FOT.FOTC.Program.Mirror.Induction.Acc.WellFounded where

open import FOTC.Base

open import FOTC.Program.Mirror.Type

------------------------------------------------------------------------------
-- The accessibility predicate: x is accessible if everything which is
-- smaller than x is also accessible (inductively).
data Acc (_<_ : D → D → Set)(t : D) : Set where
 acc : (∀ {t'} → Tree t' → t' < t → Acc _<_ t') → Acc _<_ t

accFold : {P : D → Set}(_<_ : D → D → Set) →
          (∀ {t} → Tree t → (∀ {t'} → Tree t' → t' < t → P t') → P t) →
          ∀ {t} → Tree t → Acc _<_ t → P t
accFold _<_ f Tt (acc h) = f Tt (λ Tt' t'<t → accFold _<_ f Tt' (h Tt' t'<t))

-- The accessibility predicate encodes what it means to be
-- well-founded; if all elements are accessible, then _<_ is
-- well-founded.
WellFounded : (D → D → Set) → Set
WellFounded _<_ = ∀ {t} → Tree t → Acc _<_ t

WellFoundedInduction :
  {P : D → Set}{_<_ : D → D → Set} →
  WellFounded _<_ →
  (∀ {t} → Tree t → (∀ {t'} → Tree t' → t' < t → P t') → P t) →
  ∀ {t} → Tree t → P t
WellFoundedInduction {_<_ = _<_} wf f Tt = accFold _<_ f Tt (wf Tt)


module Issue3879.Fin where

open import Agda.Builtin.Nat

data Fin : Nat → Set where
  zero : ∀ {n} → Fin (suc n)
  suc  : ∀ {n} → Fin n → Fin (suc n)

pattern 0F = zero


{-# OPTIONS --without-K --exact-split --allow-unsolved-metas #-}

module 06-universes where

import 05-identity-types
open 05-identity-types public

-- Section 6.3 Pointed types

-- Definition 6.3.1

UU-pt : (i : Level) → UU (lsuc i)
UU-pt i = Σ (UU i) (λ X → X)

type-UU-pt : {i : Level} → UU-pt i → UU i
type-UU-pt = pr1

pt-UU-pt : {i : Level} (A : UU-pt i) → type-UU-pt A
pt-UU-pt = pr2

-- Definition 6.3.2

_→*_ : {i j : Level} → UU-pt i → UU-pt j → UU-pt (i ⊔ j)
A →* B =
  pair
    ( Σ (type-UU-pt A → type-UU-pt B) (λ f → Id (f (pt-UU-pt A)) (pt-UU-pt B)))
    ( pair
      ( const (type-UU-pt A) (type-UU-pt B) (pt-UU-pt B))
      ( refl))

-- Definition 6.3.3

Ω : {i : Level} → UU-pt i → UU-pt i
Ω A = pair (Id (pt-UU-pt A) (pt-UU-pt A)) refl

-- Definition 6.3.4

iterated-loop-space : {i : Level} → ℕ → UU-pt i → UU-pt i
iterated-loop-space zero-ℕ A = A
iterated-loop-space (succ-ℕ n) A = Ω (iterated-loop-space n A)

-- Section 6.4 Families and relations on the natural numbers

-- Definition 6.4.1

Fin : ℕ → UU lzero
Fin zero-ℕ = empty
Fin (succ-ℕ n) = coprod (Fin n) unit

-- Definition 6.4.2

-- Observational equality on the natural numbers

Eq-ℕ : ℕ → (ℕ → UU lzero)
Eq-ℕ zero-ℕ zero-ℕ = 𝟙
Eq-ℕ zero-ℕ (succ-ℕ n) = 𝟘
Eq-ℕ (succ-ℕ m) zero-ℕ = 𝟘
Eq-ℕ (succ-ℕ m) (succ-ℕ n) = Eq-ℕ m n

-- Lemma 6.4.3

refl-Eq-ℕ : (n : ℕ) → Eq-ℕ n n
refl-Eq-ℕ zero-ℕ = star
refl-Eq-ℕ (succ-ℕ n) = refl-Eq-ℕ n

succ-relation-ℕ :
  {i : Level} (R : ℕ → ℕ → UU i) → ℕ → ℕ → UU i
succ-relation-ℕ R m n = R (succ-ℕ m) (succ-ℕ n)

succ-reflexivity-ℕ :
  {i : Level} (R : ℕ → ℕ → UU i) (ρ : (n : ℕ) → R n n) →
  (n : ℕ) → succ-relation-ℕ R n n
succ-reflexivity-ℕ R ρ n = ρ (succ-ℕ n)

{- In the book we suggest that first the order of the variables should be
   swapped, in order to make the inductive hypothesis stronger. Agda's pattern
   matching mechanism allows us to bypass this step and give a more direct
   construction. -}

least-reflexive-Eq-ℕ :
  {i : Level} (R : ℕ → ℕ → UU i) (ρ : (n : ℕ) → R n n) →
  (m n : ℕ) → Eq-ℕ m n → R m n
least-reflexive-Eq-ℕ R ρ zero-ℕ zero-ℕ star = ρ zero-ℕ
least-reflexive-Eq-ℕ R ρ zero-ℕ (succ-ℕ n) ()
least-reflexive-Eq-ℕ R ρ (succ-ℕ m) zero-ℕ ()
least-reflexive-Eq-ℕ R ρ (succ-ℕ m) (succ-ℕ n) e =
  least-reflexive-Eq-ℕ (succ-relation-ℕ R) (succ-reflexivity-ℕ R ρ) m n e

-- Exercises

-- Exercise 6.1

{- In this exercise we were asked to show that the observational equality on ℕ
   is an equivalence relation. -}

symmetric-Eq-ℕ : (m n : ℕ) → Eq-ℕ m n → Eq-ℕ n m
symmetric-Eq-ℕ zero-ℕ zero-ℕ star = star
symmetric-Eq-ℕ (succ-ℕ m) (succ-ℕ n) t = symmetric-Eq-ℕ m n t

transitive-Eq-ℕ : (l m n : ℕ) → Eq-ℕ l m → Eq-ℕ m n → Eq-ℕ l n
transitive-Eq-ℕ zero-ℕ zero-ℕ zero-ℕ p q = star
transitive-Eq-ℕ (succ-ℕ l) (succ-ℕ m) (succ-ℕ n) p q =
  transitive-Eq-ℕ l m n p q

-- Exercise 6.2

{- In this exercise we were asked to show that any function on the natural
   numbers preserves observational equality. The quick solution uses the fact
   that observational equality is the least reflexive relation. -}

preserve_Eq-ℕ : (f : ℕ → ℕ) (n m : ℕ) → (Eq-ℕ n m) → (Eq-ℕ (f n) (f m))
preserve_Eq-ℕ f =
  least-reflexive-Eq-ℕ
    ( λ x y → Eq-ℕ (f x) (f y))
    ( λ x → refl-Eq-ℕ (f x))

-- Exercise 6.3

{- In this exercise we were asked to construct the relations ≤ and < on the
   natural numbers, and show basic properties about them. -}

-- Exercise 6.3(a)

-- The definition of ≤

leq-ℕ : ℕ → ℕ → UU lzero
leq-ℕ zero-ℕ m = unit
leq-ℕ (succ-ℕ n) zero-ℕ = empty
leq-ℕ (succ-ℕ n) (succ-ℕ m) = leq-ℕ n m

_≤_ = leq-ℕ

leq-zero-ℕ :
  (n : ℕ) → leq-ℕ zero-ℕ n
leq-zero-ℕ n = star

-- The definition of <

le-ℕ : ℕ → ℕ → UU lzero
le-ℕ m zero-ℕ = empty
le-ℕ zero-ℕ (succ-ℕ m) = unit
le-ℕ (succ-ℕ n) (succ-ℕ m) = le-ℕ n m

_<_ = le-ℕ

reflexive-leq-ℕ : (n : ℕ) → n ≤ n
reflexive-leq-ℕ zero-ℕ = star
reflexive-leq-ℕ (succ-ℕ n) = reflexive-leq-ℕ n

anti-reflexive-le-ℕ : (n : ℕ) → ¬ (n < n)
anti-reflexive-le-ℕ zero-ℕ = ind-empty
anti-reflexive-le-ℕ (succ-ℕ n) = anti-reflexive-le-ℕ n

transitive-leq-ℕ :
  (n m l : ℕ) → (n ≤ m) → (m ≤ l) → (n ≤ l)
transitive-leq-ℕ zero-ℕ m l p q = star
transitive-leq-ℕ (succ-ℕ n) (succ-ℕ m) (succ-ℕ l) p q =
  transitive-leq-ℕ n m l p q

transitive-le-ℕ : (n m l : ℕ) → (le-ℕ n m) → (le-ℕ m l) → (le-ℕ n l)
transitive-le-ℕ zero-ℕ (succ-ℕ m) (succ-ℕ l) p q = star
transitive-le-ℕ (succ-ℕ n) (succ-ℕ m) (succ-ℕ l) p q =
  transitive-le-ℕ n m l p q

succ-leq-ℕ : (n : ℕ) → leq-ℕ n (succ-ℕ n)
succ-leq-ℕ zero-ℕ = star
succ-leq-ℕ (succ-ℕ n) = succ-leq-ℕ n

succ-le-ℕ : (n : ℕ) → le-ℕ n (succ-ℕ n)
succ-le-ℕ zero-ℕ = star
succ-le-ℕ (succ-ℕ n) = succ-le-ℕ n

anti-symmetric-leq-ℕ : (m n : ℕ) → leq-ℕ m n → leq-ℕ n m → Id m n
anti-symmetric-leq-ℕ zero-ℕ zero-ℕ p q = refl
anti-symmetric-leq-ℕ (succ-ℕ m) (succ-ℕ n) p q =
  ap succ-ℕ (anti-symmetric-leq-ℕ m n p q)

anti-symmetric-le-ℕ : (m n : ℕ) → le-ℕ m n → le-ℕ n m → Id m n
anti-symmetric-le-ℕ (succ-ℕ m) (succ-ℕ n) p q =
  ap succ-ℕ (anti-symmetric-le-ℕ m n p q)

-- Exercise 6.5

{- In this exercise we were asked to construct observational equality on the
   booleans. This construction is analogous to, but simpler than, the
   construction of observational equality on the natural numbers. -}

Eq-𝟚 : bool → bool → UU lzero
Eq-𝟚 true true = unit
Eq-𝟚 true false = empty
Eq-𝟚 false true = empty
Eq-𝟚 false false = unit

reflexive-Eq-𝟚 : (x : bool) → Eq-𝟚 x x
reflexive-Eq-𝟚 true = star
reflexive-Eq-𝟚 false = star

least-reflexive-Eq-𝟚 : {i : Level}
  (R : bool → bool → UU i) (ρ : (x : bool) → R x x)
  (x y : bool) → Eq-𝟚 x y → R x y
least-reflexive-Eq-𝟚 R ρ true true p = ρ true
least-reflexive-Eq-𝟚 R ρ true false p = ind-empty p
least-reflexive-Eq-𝟚 R ρ false true p = ind-empty p
least-reflexive-Eq-𝟚 R ρ false false p = ρ false

-- Exercise 6.6

{- In this exercise we were asked to define the relations ≤ and < on the
   integers. As a criterion of correctness, we were then also asked to show
   that the type of all integers l satisfying k ≤ l satisfy the induction
   principle of the natural numbers. -}

diff-ℤ : ℤ → ℤ → ℤ
diff-ℤ k l = add-ℤ (neg-ℤ k) l

is-non-negative-ℤ : ℤ → UU lzero
is-non-negative-ℤ (inl x) = empty
is-non-negative-ℤ (inr k) = unit

leq-ℤ : ℤ → ℤ → UU lzero
leq-ℤ k l = is-non-negative-ℤ (diff-ℤ k l)

reflexive-leq-ℤ : (k : ℤ) → leq-ℤ k k
reflexive-leq-ℤ k =
  tr is-non-negative-ℤ (inv (left-inverse-law-add-ℤ k)) star

is-non-negative-succ-ℤ :
  (k : ℤ) → is-non-negative-ℤ k → is-non-negative-ℤ (succ-ℤ k)
is-non-negative-succ-ℤ (inr (inl star)) p = star
is-non-negative-succ-ℤ (inr (inr x)) p = star

is-non-negative-add-ℤ :
  (k l : ℤ) →
  is-non-negative-ℤ k → is-non-negative-ℤ l → is-non-negative-ℤ (add-ℤ k l)
is-non-negative-add-ℤ (inr (inl star)) (inr (inl star)) p q = star
is-non-negative-add-ℤ (inr (inl star)) (inr (inr n)) p q = star
is-non-negative-add-ℤ (inr (inr zero-ℕ)) (inr (inl star)) p q = star
is-non-negative-add-ℤ (inr (inr (succ-ℕ n))) (inr (inl star)) star star =
  is-non-negative-succ-ℤ
    ( add-ℤ (inr (inr n)) (inr (inl star)))
    ( is-non-negative-add-ℤ (inr (inr n)) (inr (inl star)) star star)
is-non-negative-add-ℤ (inr (inr zero-ℕ)) (inr (inr m)) star star = star
is-non-negative-add-ℤ (inr (inr (succ-ℕ n))) (inr (inr m)) star star =
  is-non-negative-succ-ℤ
    ( add-ℤ (inr (inr n)) (inr (inr m)))
    ( is-non-negative-add-ℤ (inr (inr n)) (inr (inr m)) star star)

triangle-diff-ℤ :
  (k l m : ℤ) → Id (add-ℤ (diff-ℤ k l) (diff-ℤ l m)) (diff-ℤ k m)
triangle-diff-ℤ k l m =
  ( associative-add-ℤ (neg-ℤ k) l (diff-ℤ l m)) ∙
  ( ap
    ( add-ℤ (neg-ℤ k))
    ( ( inv (associative-add-ℤ l (neg-ℤ l) m)) ∙
      ( ( ap (λ x → add-ℤ x m) (right-inverse-law-add-ℤ l)) ∙
        ( left-unit-law-add-ℤ m))))

transitive-leq-ℤ : (k l m : ℤ) → leq-ℤ k l → leq-ℤ l m → leq-ℤ k m
transitive-leq-ℤ k l m p q =
  tr is-non-negative-ℤ
    ( triangle-diff-ℤ k l m)
    ( is-non-negative-add-ℤ
      ( add-ℤ (neg-ℤ k) l)
      ( add-ℤ (neg-ℤ l) m)
      ( p)
      ( q))

succ-leq-ℤ : (k : ℤ) → leq-ℤ k (succ-ℤ k)
succ-leq-ℤ k =
  tr is-non-negative-ℤ
    ( inv
      ( ( right-successor-law-add-ℤ (neg-ℤ k) k) ∙
        ( ap succ-ℤ (left-inverse-law-add-ℤ k))))
    ( star)

leq-ℤ-succ-leq-ℤ : (k l : ℤ) → leq-ℤ k l → leq-ℤ k (succ-ℤ l)
leq-ℤ-succ-leq-ℤ k l p = transitive-leq-ℤ k l (succ-ℤ l) p (succ-leq-ℤ l)

is-positive-ℤ : ℤ → UU lzero
is-positive-ℤ k = is-non-negative-ℤ (pred-ℤ k)

le-ℤ : ℤ → ℤ → UU lzero
le-ℤ (inl zero-ℕ) (inl x) = empty
le-ℤ (inl zero-ℕ) (inr y) = unit
le-ℤ (inl (succ-ℕ x)) (inl zero-ℕ) = unit
le-ℤ (inl (succ-ℕ x)) (inl (succ-ℕ y)) = le-ℤ (inl x) (inl y)
le-ℤ (inl (succ-ℕ x)) (inr y) = unit
le-ℤ (inr x) (inl y) = empty
le-ℤ (inr (inl star)) (inr (inl star)) = empty
le-ℤ (inr (inl star)) (inr (inr x)) = unit
le-ℤ (inr (inr x)) (inr (inl star)) = empty
le-ℤ (inr (inr zero-ℕ)) (inr (inr zero-ℕ)) = empty
le-ℤ (inr (inr zero-ℕ)) (inr (inr (succ-ℕ y))) = unit
le-ℤ (inr (inr (succ-ℕ x))) (inr (inr zero-ℕ)) = empty
le-ℤ (inr (inr (succ-ℕ x))) (inr (inr (succ-ℕ y))) =
  le-ℤ (inr (inr x)) (inr (inr y))

-- Extra material

-- We show that ℕ is an ordered semi-ring

leq-eq-ℕ : {m m' n n' : ℕ} → Id m m' → Id n n' → leq-ℕ m n → leq-ℕ m' n'
leq-eq-ℕ refl refl = id

left-law-leq-add-ℕ : (k m n : ℕ) → leq-ℕ m n → leq-ℕ (add-ℕ m k) (add-ℕ n k)
left-law-leq-add-ℕ zero-ℕ m n = id
left-law-leq-add-ℕ (succ-ℕ k) m n H = left-law-leq-add-ℕ k m n H

right-law-leq-add-ℕ : (k m n : ℕ) → leq-ℕ m n → leq-ℕ (add-ℕ k m) (add-ℕ k n)
right-law-leq-add-ℕ k m n H =
  leq-eq-ℕ
    ( commutative-add-ℕ m k)
    ( commutative-add-ℕ n k)
    ( left-law-leq-add-ℕ k m n H)

preserves-leq-add-ℕ :
  {m m' n n' : ℕ} → leq-ℕ m m' → leq-ℕ n n' → leq-ℕ (add-ℕ m n) (add-ℕ m' n')
preserves-leq-add-ℕ {m} {m'} {n} {n'} H K =
  transitive-leq-ℕ
    ( add-ℕ m n)
    ( add-ℕ m' n)
    ( add-ℕ m' n')
    ( left-law-leq-add-ℕ n m m' H)
    ( right-law-leq-add-ℕ m' n n' K)

right-law-leq-mul-ℕ : (k m n : ℕ) → leq-ℕ m n → leq-ℕ (mul-ℕ k m) (mul-ℕ k n)
right-law-leq-mul-ℕ zero-ℕ m n H = star
right-law-leq-mul-ℕ (succ-ℕ k) m n H = {!!}

{-
  preserves-leq-add-ℕ
    { m = mul-ℕ k m}
    { m' = mul-ℕ k n}
    ( right-law-leq-mul-ℕ k m n H) H

left-law-leq-mul-ℕ : (k m n : ℕ) → leq-ℕ m n → leq-ℕ (mul-ℕ m k) (mul-ℕ n k)
left-law-leq-mul-ℕ k m n H =
  leq-eq-ℕ
    ( commutative-mul-ℕ k m)
    ( commutative-mul-ℕ k n)
    ( right-law-leq-mul-ℕ k m n H)

-- We show that ℤ is an ordered ring

{-
leq-add-ℤ : (m k l : ℤ) → leq-ℤ k l → leq-ℤ (add-ℤ m k) (add-ℤ m l)
leq-add-ℤ (inl zero-ℕ) k l H = {!!}
leq-add-ℤ (inl (succ-ℕ x)) k l H = {!!}
leq-add-ℤ (inr m) k l H = {!!}
-}

-- Section 5.5 Identity systems

succ-fam-Eq-ℕ :
  {i : Level} (R : (m n : ℕ) → Eq-ℕ m n → UU i) →
  (m n : ℕ) → Eq-ℕ m n → UU i
succ-fam-Eq-ℕ R m n e = R (succ-ℕ m) (succ-ℕ n) e

succ-refl-fam-Eq-ℕ :
  {i : Level} (R : (m n : ℕ) → Eq-ℕ m n → UU i)
  (ρ : (n : ℕ) → R n n (refl-Eq-ℕ n)) →
  (n : ℕ) → (succ-fam-Eq-ℕ R n n (refl-Eq-ℕ n))
succ-refl-fam-Eq-ℕ R ρ n = ρ (succ-ℕ n)

path-ind-Eq-ℕ :
  {i : Level} (R : (m n : ℕ) → Eq-ℕ m n → UU i)
  ( ρ : (n : ℕ) → R n n (refl-Eq-ℕ n)) →
  ( m n : ℕ) (e : Eq-ℕ m n) → R m n e
path-ind-Eq-ℕ R ρ zero-ℕ zero-ℕ star = ρ zero-ℕ
path-ind-Eq-ℕ R ρ zero-ℕ (succ-ℕ n) ()
path-ind-Eq-ℕ R ρ (succ-ℕ m) zero-ℕ ()
path-ind-Eq-ℕ R ρ (succ-ℕ m) (succ-ℕ n) e =
  path-ind-Eq-ℕ (succ-fam-Eq-ℕ R) (succ-refl-fam-Eq-ℕ R ρ) m n e

comp-path-ind-Eq-ℕ :
  {i : Level} (R : (m n : ℕ) → Eq-ℕ m n → UU i)
  ( ρ : (n : ℕ) → R n n (refl-Eq-ℕ n)) →
  ( n : ℕ) → Id (path-ind-Eq-ℕ R ρ n n (refl-Eq-ℕ n)) (ρ n)
comp-path-ind-Eq-ℕ R ρ zero-ℕ = refl
comp-path-ind-Eq-ℕ R ρ (succ-ℕ n) =
  comp-path-ind-Eq-ℕ (succ-fam-Eq-ℕ R) (succ-refl-fam-Eq-ℕ R ρ) n
-}

{-
-- Graphs
Gph : (i : Level) → UU (lsuc i)
Gph i = Σ (UU i) (λ X → (X → X → (UU i)))

-- Reflexive graphs
rGph : (i : Level) →  UU (lsuc i)
rGph i = Σ (UU i) (λ X → Σ (X → X → (UU i)) (λ R → (x : X) → R x x))
-}

-- Exercise 3.7

{- With the construction of the divisibility relation we open the door to basic
   number theory. -}

divides : (d n : ℕ) → UU lzero
divides d n = Σ ℕ (λ m → Eq-ℕ (mul-ℕ d m) n)


open import Oscar.Prelude

module Oscar.Class.Fmap where

module _ where
  open import Oscar.Data.Proposequality
  open import Oscar.Class.IsFunctor
  open import Oscar.Class.Reflexivity
  import Oscar.Class.Reflexivity.Function
  open import Oscar.Class.Surjidentity

  record Fmap {𝔬₁ 𝔬₂} (𝓕 : Ø 𝔬₁ → Ø 𝔬₂) : Ø (↑̂ (↑̂ 𝔬₁ ∙̂ 𝔬₂)) where
    constructor ∁
    field
      fmap : ∀ {𝔄 𝔅} → (𝔄 → 𝔅) → 𝓕 𝔄 → 𝓕 𝔅 -- level-polymorphic functors cannot be represented by `Functor` or any other type in universe < ω.
      ⦃ isFunctor ⦄ : IsFunctor
                         Function⟦ 𝔬₁ ⟧
                           Proposextensequality ε (flip _∘′_)
                         (MFunction 𝓕)
                           Proposextensequality ε (flip _∘′_)
                         fmap
    fmap-id-law : ∀ {𝔄} → fmap ¡[ 𝔄 ] ≡̇ ¡
    fmap-id-law = surjidentity

  open Fmap ⦃ … ⦄ public using (fmap)

-- level-polymorphic functor
module _
  (𝔉 : ∀ {𝔣} → Ø 𝔣 → Ø 𝔣)
  𝔬₁ 𝔬₂
  where
  𝓯map = ∀ {𝔒₁ : Ø 𝔬₁} {𝔒₂ : Ø 𝔬₂} (f : 𝔒₁ → 𝔒₂) → 𝔉 𝔒₁ → 𝔉 𝔒₂
  record 𝓕map : Ø ↑̂ (𝔬₁ ∙̂ 𝔬₂) where field fmap′ : 𝓯map
open 𝓕map ⦃ … ⦄ public


------------------------------------------------------------------------
-- The Agda standard library
--
-- Some simple binary relations
------------------------------------------------------------------------

module Relation.Binary.Simple where

open import Relation.Binary
open import Data.Unit
open import Data.Empty
open import Level

-- Constant relations.

Const : ∀ {a b c} {A : Set a} {B : Set b} → Set c → REL A B c
Const I = λ _ _ → I

-- The universally true relation.

Always : ∀ {a ℓ} {A : Set a} → Rel A ℓ
Always = Const (Lift ⊤)

Always-setoid : ∀ {a ℓ} (A : Set a) → Setoid a ℓ
Always-setoid A = record
  { Carrier       = A
  ; _≈_           = Always
  ; isEquivalence = record {}
  }

-- The universally false relation.

Never : ∀ {a ℓ} {A : Set a} → Rel A ℓ
Never = Const (Lift ⊥)


module Div where

data True : Set where
  trivial : True

data False : Set where

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

NonZero : Nat -> Set
NonZero  zero   = False
NonZero (suc _) = True

divHelp : Nat -> Nat -> Nat -> Nat
divHelp  zero    zero   c = suc zero
divHelp  zero   (suc y) c = zero
divHelp (suc x)  zero   c = suc (divHelp x c c)
divHelp (suc x) (suc y) c = divHelp x y c

div : (x y : Nat) -> NonZero y -> Nat
div  x       zero  ()
div  zero   (suc y) _ = zero
div (suc x) (suc y) _ = divHelp (suc x) (suc y) y

n1 = suc zero
n2 = suc n1
n3 = suc n2
n4 = suc n3
n5 = suc n4
n6 = suc n5
n7 = suc n6
n8 = suc n7
n9 = suc n8
n10 = suc n9
n11 = suc n10
n12 = suc n11


module AnonymousDecl where

_ : Set₁
_ = Set

_ : Set → Set
_ = λ x → x

_∋_ : ∀ {ℓ} (A : Set ℓ) → A → A
A ∋ a = a

_ = Set₁
_ = (Set → Set) ∋ λ x → x

data Bool : Set where t f : Bool

not : Bool → Bool
not t = f
not f = t

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

_ : ∀ x → not (not x) ≡ x
_ = λ { t → refl; f → refl }


module _ where

open import Agda.Primitive.Cubical
open import Agda.Builtin.Nat

postulate
  PathP : ∀ {ℓ} (A : I → Set ℓ) → A i0 → A i1 → Set ℓ

{-# BUILTIN PATHP        PathP     #-}

postulate
  A : Set
  a : A
  b : A
  p : PathP (\ _ → A) a b

test1 : ∀ {p : PathP (\ _ → A) a a} {P : A → Set} → P (p i0) → P a
test1 x = x

test2 : ∀ {P : A → Set} → P (p i0) → P a
test2 x = x

q : (x : Nat) → PathP (\ _ → Nat) x x
q zero i = zero
q (suc n) i = suc (q n i)

test3 : ∀ {P : Nat → Set}{n : Nat} → P (q n i0) → P n
test3 x = x


module Oscar.Category.CategoryAction where

open import Oscar.Category.Action
open import Oscar.Category.Category
open import Oscar.Category.SemigroupoidAction
open import Oscar.Category.Setoid
open import Oscar.Level

module _ {𝔊𝔬 𝔊𝔪 𝔊𝔮} (category : Category 𝔊𝔬 𝔊𝔪 𝔊𝔮) where
  open Category category

  module _ {𝔄𝔬 𝔄𝔮} (action : Action ⋆ 𝔄𝔬 𝔄𝔮) where
    open Action action

    record IsCategoryAction
      (_◂_ : ∀ {x y} → x ↦ y → ↥ x → ↥ y)
      : Set (𝔊𝔬 ⊔ 𝔊𝔪 ⊔ 𝔊𝔮 ⊔ 𝔄𝔬 ⊔ 𝔄𝔮) where
      field ⦃ isSemigroupoidAction ⦄ : IsSemigroupoidAction semigroupoid action _◂_
      field identity : ∀ {x} → (s : ↥ x) → ε ◂ s ≋ s

open IsCategoryAction ⦃ … ⦄ public

record CategoryAction 𝔊𝔬 𝔊𝔪 𝔊𝔮 𝔄𝔬 𝔄𝔮 : Set (lsuc (𝔊𝔬 ⊔ 𝔊𝔪 ⊔ 𝔊𝔮 ⊔ 𝔄𝔬 ⊔ 𝔄𝔮)) where
  constructor [_/_]
  field category : Category 𝔊𝔬 𝔊𝔪 𝔊𝔮
  open Category category public

  field action : Action ⋆ 𝔄𝔬 𝔄𝔮
  open Action action public

  field _◂_ : ∀ {x y} → x ↦ y → ↥ x → ↥ y
  field ⦃ isCategoryAction ⦄ : IsCategoryAction category action _◂_

  semgroupoidAction : SemigroupoidAction _ _ _ _ _
  SemigroupoidAction.semigroupoid semgroupoidAction = semigroupoid
  SemigroupoidAction.action semgroupoidAction = action
  SemigroupoidAction._◂_ semgroupoidAction = _◂_


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

module Avionics.Probability where

open import Data.Nat using (ℕ; zero; suc)
open import Relation.Unary using (_∈_)

open import Avionics.Real using (
    ℝ; _+_; _-_; _*_; _÷_; _^_; √_; 1/_; _^2;
    -1/2; π; e; 2ℝ;
    ⟨0,∞⟩; [0,∞⟩; [0,1])

--postulate
--  Vec : Set → ℕ → Set
--  Mat : Set → ℕ → ℕ → Set

record Dist (Input : Set) : Set where
  field
    pdf : Input → ℝ
    cdf : Input → ℝ
    pdf→[0,∞⟩ : ∀ x → pdf x ∈ [0,∞⟩
    cdf→[0,1] : ∀ x → cdf x ∈ [0,1]
    --∫pdf≡cdf : ∫ pdf ≡ cdf
    --∫pdf[-∞,∞]≡1ℝ : ∫ pdf [ -∞ , ∞ ] ≡ 1ℝ

record NormalDist : Set where
  constructor ND
  field
    μ : ℝ
    σ : ℝ

  dist : Dist ℝ
  dist = record
    {
      pdf = pdf
    ; cdf = ?
    ; pdf→[0,∞⟩ = ?
    ; cdf→[0,1] = ?
    }
    where
      √2π = (√ (2ℝ * π))
      1/⟨σ√2π⟩ = (1/ (σ * √2π))

      pdf : ℝ → ℝ
      pdf x = 1/⟨σ√2π⟩ * e ^ (-1/2 * (⟨x-μ⟩÷σ ^2))
        where
          ⟨x-μ⟩÷σ = ((x - μ) ÷ σ)

--MultiNormal : ∀ {n : ℕ} → Vec ℝ n → Mat ℝ n n → Dist (Vec ℝ n)
--MultiNormal {n} means cov = record
--  {
--    pdf = ?
--  ; cdf = ?
--  }

--Things to prove using this approach
--_ : ∀ (mean1 std1 mean2 std2 x)
--  → Dist.pdf (Normal mean1 std1) x + Dist.pdf (Normal mean2 std2) x ≡ Dist.pdf (Normal (mean1 + mean2) (...))


------------------------------------------------------------------------
-- The Agda standard library
--
-- Primality
------------------------------------------------------------------------

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

module Data.Nat.Primality where

open import Data.Empty using (⊥)
open import Data.Fin using (Fin; toℕ)
open import Data.Fin.Properties using (all?)
open import Data.Nat using (ℕ; suc; _+_)
open import Data.Nat.Divisibility using (_∤_; _∣?_)
open import Relation.Nullary using (yes; no)
open import Relation.Nullary.Decidable using (from-yes)
open import Relation.Nullary.Negation using (¬?)
open import Relation.Unary using (Decidable)

-- Definition of primality.

Prime : ℕ → Set
Prime 0             = ⊥
Prime 1             = ⊥
Prime (suc (suc n)) = (i : Fin n) → 2 + toℕ i ∤ 2 + n

-- Decision procedure for primality.

prime? : Decidable Prime
prime? 0             = no λ()
prime? 1             = no λ()
prime? (suc (suc n)) = all? (λ _ → ¬? (_ ∣? _))

private

  -- Example: 2 is prime.

  2-is-prime : Prime 2
  2-is-prime = from-yes (prime? 2)


module Cats.Category.Op where

open import Relation.Binary using (Rel ; _Preserves₂_⟶_⟶_)
open import Relation.Binary.PropositionalEquality as ≡
open import Level

open import Cats.Category
open import Cats.Category.Cat using (Cat)

module _  {lo la l≈} (C : Category lo la l≈) where

  infixr 9 _∘_
  infixr 4 _≈_

  private
    module C = Category C
    module ≈ = C.≈

  Obj : Set lo
  Obj = C.Obj

  _⇒_ : Obj → Obj → Set la
  A ⇒ B = B C.⇒ A

  id : ∀ {A} → A ⇒ A
  id = C.id

  _∘_ : ∀ {A B C : Obj} → (B ⇒ C) → (A ⇒ B) → A ⇒ C
  f ∘ g = g C.∘ f

  _≈_ : ∀ {A B} → Rel (A ⇒ B) l≈
  _≈_ = C._≈_

  ∘-resp : ∀ {A B C} → _∘_ {A} {B} {C} Preserves₂ _≈_ ⟶ _≈_ ⟶ _≈_
  ∘-resp {x = f} {g} {h} {i} f≈g h≈i = C.∘-resp h≈i f≈g

  assoc : ∀ {A B C D} {f : C ⇒ D} {g : B ⇒ C} {h : A ⇒ B}
    → (f ∘ g) ∘ h ≈ f ∘ (g ∘ h)
  assoc = C.unassoc

  _ᵒᵖ : Category lo la l≈
  _ᵒᵖ = record
      { Obj = Obj
      ; _⇒_ = _⇒_
      ; _≈_ = _≈_
      ; id = id
      ; _∘_ = λ f g → g C.∘ f
      ; equiv = C.equiv
      ; ∘-resp = ∘-resp
      ; id-r = C.id-l
      ; id-l = C.id-r
      ; assoc = assoc
      }

module _ {lo la l≈ : Level} where

  private module Cat = Category (Cat lo la l≈)

  op-involution : {C : Category lo la l≈} → ((C ᵒᵖ) ᵒᵖ) Cat.≅ C
  op-involution {C} = record
      { forth = record
          { fobj = λ x → x
          ; fmap = λ f → f
          ; fmap-resp = λ eq → eq
          ; fmap-id = C.≈.reflexive ≡.refl
          ; fmap-∘ = C.≈.reflexive ≡.refl
          }
      ; back = record
          { fobj = λ x → x
          ; fmap = λ f → f
          ; fmap-resp = λ eq → eq
          ; fmap-id = C.≈.reflexive ≡.refl
          ; fmap-∘ = C.≈.reflexive ≡.refl
          }
      -- TODO This sort of natural iso comes up all the time. Can we abstract it
      -- out?
      ; back-forth = record
          { iso = Coo.≅.refl
          ; forth-natural = C.≈.trans C.id-l (C.≈.sym C.id-r)
          }
      ; forth-back = record
          { iso = C.≅.refl
          ; forth-natural = C.≈.trans C.id-l (C.≈.sym C.id-r)
          }
      }
    where
      module C = Category C
      module Coo = Category ((C ᵒᵖ)ᵒᵖ)
      module ≈ = C.≈


open import Data.Product using ( ∃ ; _×_ )
open import FRP.LTL.RSet.Core using ( RSet ; _[_,_⟩ )
open import FRP.LTL.Time using ( _≤_ )

module FRP.LTL.RSet.Until where

infixr 2 _U_

_U_ : RSet → RSet → RSet
(A U B) t = ∃ λ u → (t ≤ u) × (A [ t , u ⟩) × B u


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

open import Base
open import HLevel

module Homotopy.Extensions.ToPropToConstSet {i}
  {A B : Set i} ⦃ B-is-set : is-set B ⦄
  (f : A → B) (f-is-const : ∀ a₁ a₂ → f a₁ ≡ f a₂) where

  open import Homotopy.Truncation
  open import Homotopy.Skeleton

  private
    skel : Set i
    skel = π₀ (skeleton₁ f)

    abstract
      skel-has-all-paths : has-all-paths skel
      skel-has-all-paths =
        π₀-extend ⦃ λ _ → Π-is-set λ _ → ≡-is-set $ π₀-is-set _ ⦄
          (skeleton₁-rec (λ s₁ → ∀ s₂ → proj s₁ ≡ s₂)
            (λ a₁ → π₀-extend ⦃ λ _ → ≡-is-set $ π₀-is-set _ ⦄
              (skeleton₁-rec (λ s₂ → proj (point a₁) ≡ proj s₂)
                (λ a₂ → ap proj $ link a₁ a₂ $ f-is-const a₁ a₂)
                (λ _ _ _ → prop-has-all-paths (π₀-is-set _ _ _) _ _)))
            (λ _ _ _ → funext λ _ → prop-has-all-paths (π₀-is-set _ _ _) _ _))

    skel-is-prop : is-prop skel
    skel-is-prop = all-paths-is-prop skel-has-all-paths

  cst-extend : [ A ] → B
  cst-extend = π₀-extend-nondep ⦃ B-is-set ⦄ skeleton₁-lifted
            ◯ []-extend-nondep ⦃ skel-is-prop ⦄ (proj ◯ point)


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

open import Level
open import Function using (flip)

open import Relation.Binary hiding (_⇒_)
import Relation.Binary.PropositionalEquality as ≡
import Relation.Binary.Reasoning.Setoid as SetoidR

-- Basic definition of a |Category| with a Hom setoid.
-- Also comes with some reasoning combinators (see HomReasoning)
record Category (o ℓ e : Level) : Set (suc (o ⊔ ℓ ⊔ e)) where
  eta-equality
  infix  4 _≈_ _⇒_
  infixr 9 _∘_

  field
    Obj : Set o
    _⇒_ : Rel Obj ℓ
    _≈_ : ∀ {A B} → Rel (A ⇒ B) e

    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)
    -- We add a symmetric proof of associativity so that the opposite category of the
    -- opposite category is definitionally equal to the original category. See how
    -- `op` is implemented.
    sym-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
    -- We add a proof of "neutral" identity proof, in order to ensure the opposite of
    -- constant functor is definitionally equal to itself.
    identity² : ∀ {A} → id ∘ id {A} ≈ id {A}
    equiv     : ∀ {A B} → IsEquivalence (_≈_ {A} {B})
    ∘-resp-≈  : ∀ {A B C} {f h : B ⇒ C} {g i : A ⇒ B} → f ≈ h → g ≈ i → f ∘ g ≈ h ∘ i

  module Equiv {A B : Obj} = IsEquivalence (equiv {A} {B})

  open Equiv

  dom : ∀ {A B} → (A ⇒ B) → Obj
  dom {A} _ = A

  cod : ∀ {A B} → (A ⇒ B) → Obj
  cod {B = B} _ = B

  ∘-resp-≈ˡ : ∀ {A B C} {f h : B ⇒ C} {g : A ⇒ B} → f ≈ h → f ∘ g ≈ h ∘ g
  ∘-resp-≈ˡ pf = ∘-resp-≈ pf refl

  ∘-resp-≈ʳ : ∀ {A B C} {f h : A ⇒ B} {g : B ⇒ C} → f ≈ h → g ∘ f ≈ g ∘ h
  ∘-resp-≈ʳ pf = ∘-resp-≈ refl pf

  hom-setoid : ∀ {A B} → Setoid _ _
  hom-setoid {A} {B} = record
    { Carrier       = A ⇒ B
    ; _≈_           = _≈_
    ; isEquivalence = equiv
    }

  -- Reasoning combinators.  _≈⟨_⟩_ and _≈˘⟨_⟩_ from SetoidR.
  -- Also some useful combinators for doing reasoning on _∘_ chains
  module HomReasoning {A B : Obj} where
    open SetoidR (hom-setoid {A} {B}) public
    open Equiv {A = A} {B = B} public

    infixr 4 _⟩∘⟨_ refl⟩∘⟨_
    infixl 5 _⟩∘⟨refl
    _⟩∘⟨_ : ∀ {M} {f h : M ⇒ B} {g i : A ⇒ M} → f ≈ h → g ≈ i → f ∘ g ≈ h ∘ i
    _⟩∘⟨_ = ∘-resp-≈

    refl⟩∘⟨_ : ∀ {M} {f : M ⇒ B} {g i : A ⇒ M} → g ≈ i → f ∘ g ≈ f ∘ i
    refl⟩∘⟨_ = Equiv.refl ⟩∘⟨_

    _⟩∘⟨refl : ∀ {M} {f h : M ⇒ B} {g : A ⇒ M} → f ≈ h → f ∘ g ≈ h ∘ g
    _⟩∘⟨refl = _⟩∘⟨ Equiv.refl

    -- convenient inline versions
    infix 2 ⟺
    infixr 3 _○_
    ⟺ : {f g : A ⇒ B} → f ≈ g → g ≈ f
    ⟺ = Equiv.sym
    _○_ : {f g h : A ⇒ B} → f ≈ g → g ≈ h → f ≈ h
    _○_ = Equiv.trans

    -- for reasoning in the Strict cases
    ≡⇒≈ : {f g : A ⇒ B} → f ≡.≡ g → f ≈ g
    ≡⇒≈ ≡.refl = Equiv.refl

    subst₂≈ : {C D : Obj} {f g : A ⇒ B} → f ≈ g → (eq₁ : A ≡.≡ C) (eq₂ : B ≡.≡ D) →
      ≡.subst₂ (_⇒_) eq₁ eq₂ f ≈ ≡.subst₂ (_⇒_) eq₁ eq₂ g
    subst₂≈ f≈g ≡.refl ≡.refl = f≈g

  -- Combinators for commutative diagram
  -- The idea is to use the combinators to write commutations in a more readable way.
  -- It starts with [_⇒_]⟨_≈_⟩, and within the third and fourth places, use _⇒⟨_⟩_ to
  -- connect morphisms with the intermediate object specified.
  module Commutation where
    infix 1 [_⇒_]⟨_≈_⟩
    [_⇒_]⟨_≈_⟩ : ∀ (A B : Obj) → A ⇒ B → A ⇒ B → Set _
    [ A ⇒ B ]⟨ f ≈ g ⟩ = f ≈ g

    infixl 2 connect
    connect : ∀ {A C : Obj} (B : Obj) → A ⇒ B → B ⇒ C → A ⇒ C
    connect B f g = g ∘ f

    syntax connect B f g = f ⇒⟨ B ⟩ g

  op : Category o ℓ e
  op = record
    { Obj       = Obj
    ; _⇒_       = flip _⇒_
    ; _≈_       = _≈_
    ; _∘_       = flip _∘_
    ; id        = id
    ; assoc     = sym-assoc
    ; sym-assoc = assoc
    ; identityˡ = identityʳ
    ; identityʳ = identityˡ
    ; identity² = identity²
    ; equiv     = equiv
    ; ∘-resp-≈  = flip ∘-resp-≈
    }

  -- Q: Should this really be defined here?
  CommutativeSquare : ∀ {A B C D} → (f : A ⇒ B) (g : A ⇒ C) (h : B ⇒ D) (i : C ⇒ D) → Set _
  CommutativeSquare f g h i = h ∘ f ≈ i ∘ g

-- Since we add extra proofs in the definition of `Category` (i.e. `sym-assoc` and
-- `identity²`), we might still want to construct a `Category` in its originally
-- easier manner. Thus, this redundant definition is here to ease the construction.
record CategoryHelper (o ℓ e : Level) : Set (suc (o ⊔ ℓ ⊔ e)) where
  infix  4 _≈_ _⇒_
  infixr 9 _∘_

  field
    Obj : Set o
    _⇒_ : Rel Obj ℓ
    _≈_ : ∀ {A B} → Rel (A ⇒ B) e

    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
    equiv     : ∀ {A B} → IsEquivalence (_≈_ {A} {B})
    ∘-resp-≈  : ∀ {A B C} {f h : B ⇒ C} {g i : A ⇒ B} → f ≈ h → g ≈ i → f ∘ g ≈ h ∘ i

categoryHelper : ∀ {o ℓ e} → CategoryHelper o ℓ e → Category o ℓ e
categoryHelper C = record
  { Obj       = Obj
  ; _⇒_       = _⇒_
  ; _≈_       = _≈_
  ; id        = id
  ; _∘_       = _∘_
  ; assoc     = assoc
  ; sym-assoc = sym assoc
  ; identityˡ = identityˡ
  ; identityʳ = identityʳ
  ; identity² = identityˡ
  ; equiv     = equiv
  ; ∘-resp-≈  = ∘-resp-≈
  }
  where open CategoryHelper C
        module _ {A B} where
          open IsEquivalence (equiv {A} {B}) public


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

module Data.Fin.Indexed.Properties where

open import Agda.Builtin.Nat using (_<_)
open import Data.Nat.Base
open import Data.Fin.Indexed.Base
open import Data.Bool
open import Data.Maybe.Base

private variable n m k : ℕ

weaken : ∀ {n} → Fin n → Fin (suc n)
weaken {suc n} f0 = f0
weaken {suc n} (fs x) = fs (weaken x)

-- x \\ y | x < y = just x
--        | x ≡ y = nothing
--        | x > y = just (x - 1)
_\\_ : Fin (suc n) → Fin (suc n) → Maybe (Fin n)
f0   \\ f0   = nothing
fs i \\ f0   = just i
_\\_ {suc n} (fs i) (fs j) = mapMaybe fs (i \\ j)
_\\_ {suc n} (f0  ) (fs j) = just f0

insert : Fin (suc n) → Fin n → Fin (suc n)
insert f0     j      = fs j
insert (fs i) f0     = f0
insert (fs i) (fs j) = fs (insert i j)

weakens : ∀ n → Fin m → Fin (n + m)
weakens zero    x = x
weakens (suc n) x = weaken (weakens n x)

_∔_ : Fin n → Fin m → Fin (n + m)
f0   ∔ m = weakens _ m
fs n ∔ m = fs (n ∔ m)

under : (Fin m → Fin k) → Fin (n + m) → Fin (n + k)
under {n = zero } f x      = f x
under {n = suc n} f (fs x) = fs (under f x)
under {n = suc n} f f0     = f0


open import Relation.Binary.Indexed

module Relation.Binary.Indexed.EqReasoning {𝒾} {I : Set 𝒾} {𝒸 ℓ} (S : Setoid I 𝒸 ℓ) where

open Setoid S
import Relation.Binary.Indexed.PreorderReasoning as PreR
open import Relation.Binary.Indexed.Extra using (Setoid⇒Preorder)
open PreR (Setoid⇒Preorder S) public
       renaming ( _∼⟨_⟩_  to _≈⟨_⟩_
                ; _≈⟨_⟩_  to _≡⟨_⟩_
                ; _≈⟨⟩_  to _≡⟨⟩_
                )


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

open import Categories.Category

module Categories.Functor.Hom.Properties.Covariant {o ℓ e} (C : Category o ℓ e) where

open import Level
open import Function.Equality using (Π)
open import Relation.Binary using (Setoid)

open import Categories.Category.Construction.Cones
open import Categories.Category.Instance.Setoids
open import Categories.Diagram.Cone.Properties
open import Categories.Diagram.Limit
open import Categories.Functor
open import Categories.Functor.Limits
open import Categories.Functor.Hom

import Categories.Morphism.Reasoning as MR

private
  variable
    o′ ℓ′ e′ : Level
    J : Category o′ ℓ′ e′
  module C = Category C

open Category C
open Hom C
open Π

-- Hom functor preserves limits in C
module _ (W : Obj) {F : Functor J C} (lim : Limit F) where
  private
    module F   = Functor F
    module lim = Limit lim
    open lim
    HomF : Functor J (Setoids ℓ e)
    HomF = Hom[ W ,-] ∘F F
    open HomReasoning
    open MR C

    ⊤ : Cone HomF
    ⊤ = F-map-Coneˡ Hom[ W ,-] limit

    module _ (K : Cone HomF) where
      private
        module K = Cone _ K

      KW : Setoid.Carrier (Cone.N K) → Cone F
      KW x = record
        { N    = W
        ; apex = record
          { ψ       = λ X → K.ψ X ⟨$⟩ x
          ; commute = λ f → ⟺ (∘-resp-≈ʳ identityʳ) ○ K.commute f (Setoid.refl K.N)
          }
        }

      ! : Cones HomF [ K , ⊤ ]
      ! = record
        { arr     = record
          { _⟨$⟩_ = λ x → rep (KW x)
          ; cong  = λ {x y} eq → ψ-≈⇒rep-≈ F W (Cone.apex (KW x)) (Cone.apex (KW y)) lim
                                              (λ A → cong (K.ψ A) eq)
          }
        ; commute = λ {X} {x y} eq → begin
          proj X ∘ rep (KW x) ∘ C.id ≈⟨ refl⟩∘⟨ C.identityʳ ⟩
          proj X ∘ rep (KW x)        ≈⟨ lim.commute ⟩
          K.ψ X ⟨$⟩ x                ≈⟨ cong (K.ψ X) eq ⟩
          K.ψ X ⟨$⟩ y                ∎
        }

    !-unique : ∀ {K : Cone HomF} (f : Cones HomF [ K , ⊤ ]) → Cones HomF [ ! K ≈ f ]
    !-unique {K} f {x} {y} x≈y = begin
      rep (KW K x) ≈⟨ terminal.!-unique f′ ⟩
      f.arr ⟨$⟩ x  ≈⟨ cong f.arr x≈y ⟩
      f.arr ⟨$⟩ y  ∎
      where module K = Cone _ K
            module f = Cone⇒ _ f

            f′ : Cones F [ KW K x , limit ]
            f′ = record
              { arr     = f.arr ⟨$⟩ x
              ; commute = ⟺ (∘-resp-≈ʳ C.identityʳ) ○ f.commute (Setoid.refl K.N)
              }

  hom-resp-limit : Limit HomF
  hom-resp-limit = record
    { terminal = record
      { ⊤             = ⊤
      ; ⊤-is-terminal = record
        { !        = ! _
        ; !-unique = !-unique
        }
      }
    }

Hom-Continuous : ∀ X o′ ℓ′ e′ → Continuous o′ ℓ′ e′ Hom[ X ,-]
Hom-Continuous X _ _ _ L = terminal.⊤-is-terminal
  where open Limit (hom-resp-limit X L)


-- Andreas, 2012-09-24 Ensure that size successor is monotone
{-# OPTIONS --sized-types #-}
module SizeSucMonotone where

open import Common.Size

data Bool : Set where
  true false : Bool

-- T should be monotone in its second arg
T : Bool → Size → Set
T true  i = Size< i
T false i = Size< (↑ i)

test : {x : Bool}{i : Size}{j : Size< i} → T x j → T x i
test h = h


-- {-# OPTIONS -v tc.pos:100 #-}
-- Records are allowed in mutual blocks.
module RecordInMutual where

import Common.Level
open import Common.Equality

mutual
  record A : Set where
    field p : D
  record B : Set where
    field q : A
  data D : Set where
    c : B -> D

open A
open B

-- A and B are guarded via D, so we have eta for A and for B:

etaA : {a : A} → a ≡ record { p = p a }
etaA = refl

etaB : {b : B} → b ≡ record { q = q b }
etaB = refl


module Haskell.Prim.Maybe where

--------------------------------------------------
-- Maybe

data Maybe {ℓ} (a : Set ℓ) : Set ℓ where
  Nothing : Maybe a
  Just    : a -> Maybe a

maybe : ∀ {ℓ₁ ℓ₂} {a : Set ℓ₁} {b : Set ℓ₂} → b → (a → b) → Maybe a → b
maybe n j Nothing  = n
maybe n j (Just x) = j x


module Formalization.PredicateLogic.Signature where

import      Lvl
open import Numeral.Natural
open import Type

-- A signature consists of a countable family of constant/function and relation symbols.
-- `Prop(n)` should be interpreted as the indices for relations of arity `n`.
-- `Obj(n)` should be interpreted as the indices for functions of arity `n` (constants if `n = 0`).
record Signature : Typeω where
  constructor intro
  field
    {ℓₚ} : Lvl.Level
    Prop : ℕ → Type{ℓₚ}
    {ℓₒ} : Lvl.Level
    Obj : ℕ → Type{ℓₒ}


------------------------------------------------------------------------------
-- Testing the translation of definitions
------------------------------------------------------------------------------

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

module Definition07d where

infixl 6 _+_
infix  4 _≡_

postulate
  D    : Set
  zero : D
  succ : D → D
  _≡_  : D → D → Set

data N : D → Set where
  nzero : N zero
  nsucc : ∀ {n} → N n → N (succ n)

N-ind : (A : D → Set) →
        A zero →
        (∀ {n} → A n → A (succ n)) →
        ∀ {n} → N n → A n
N-ind A A0 h nzero      = A0
N-ind A A0 h (nsucc Nn) = h (N-ind A A0 h Nn)

postulate
  _+_  : D → D → D
  +-0x : ∀ n → zero + n     ≡ n
  +-Sx : ∀ m n → succ m + n ≡ succ (m + n)
{-# ATP axioms +-0x +-Sx #-}

-- We test the translation of a definition where we need to erase
-- proof terms.
+-rightIdentity : ∀ {n} → N n → n + zero ≡ n
+-rightIdentity Nn = N-ind A A0 is Nn
  where
  A : D → Set
  A i = i + zero ≡ i
  {-# ATP definition A #-}

  postulate A0 : A zero
  {-# ATP prove A0 #-}

  postulate is : ∀ {i} → A i → A (succ i)
  {-# ATP prove is #-}


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

module Bool where
  open import Basics
  open import lib.Basics
  open import lib.types.Bool public

  _≤b_ : Bool → Bool → PropT₀
  true ≤b true = True
  true ≤b false  = False
  false ≤b true = True
  false ≤b false = True

  ≤b-refl : (b : Bool) → (b ≤b b) holds
  ≤b-refl true = unit
  ≤b-refl false = unit

  ≤b-trans : {a b c : Bool} → (a ≤b b) holds → (b ≤b c) holds → (a ≤b c) holds
  ≤b-trans {a} {b} {c} = ≤b-trans' a b c
    where
      ≤b-trans' : (a b c : Bool) → (a ≤b b) holds → (b ≤b c) holds → (a ≤b c) holds
      ≤b-trans' true true true = λ _ _ → unit
      ≤b-trans' true true false = λ _ z → z
      ≤b-trans' true false true = λ _ _ → unit
      ≤b-trans' true false false = λ z _ → z
      ≤b-trans' false true true = λ _ _ → unit
      ≤b-trans' false true false = λ _ _ → unit
      ≤b-trans' false false true = λ _ _ → unit
      ≤b-trans' false false false = λ _ _ → unit

  Bool-to-PropT₀ : Bool → PropT₀
  Bool-to-PropT₀ true = True
  Bool-to-PropT₀ false = False

  Dec-Prop-to-Bool : {i : ULevel} (P : PropT i) → Dec (P holds) → Bool
  Dec-Prop-to-Bool _ (inl _) = true
  Dec-Prop-to-Bool _ (inr _) = false

  Dec-Prop-to-Bool-true-id : {i : ULevel} (P : PropT i) (d : Dec (P holds))
                             → P holds → (Dec-Prop-to-Bool P d) == true
  Dec-Prop-to-Bool-true-id P (inl _) p  = refl
  Dec-Prop-to-Bool-true-id P (inr d) p = quodlibet (d p)

  Dec-Prop-to-Bool-false-id : {i : ULevel} (P : PropT i) (d : Dec (P holds))
                              → ¬ (P holds) → (Dec-Prop-to-Bool P d) == false
  Dec-Prop-to-Bool-false-id P (inl x) np = quodlibet (np x)
  Dec-Prop-to-Bool-false-id P (inr _) np = refl

  _holds-b : Bool → Type₀
  b holds-b = (Bool-to-PropT₀ b) holds


module Data.Tuple where

import      Lvl
open import Type
open import Syntax.Function

infixr 200 _⨯_ _,_

private variable ℓ ℓ₁ ℓ₂ ℓ₃ ℓ₄ : Lvl.Level
private variable A B C A₁ A₂ B₁ B₂ : Type{ℓ}

-- Definition of a 2-tuple
record _⨯_ (A : Type{ℓ₁}) (B : Type{ℓ₂}) : Type{ℓ₁ Lvl.⊔ ℓ₂} where
  constructor _,_
  field
    left  : A
    right : B
open _⨯_ public

elim : ∀{P : (A ⨯ B) → Type{ℓ}} → ((a : A) → (b : B) → P(a , b)) → ((p : (A ⨯ B)) → P(p))
elim f(a , b) = f a b

map : (A₁ → A₂) → (B₁ → B₂) → (A₁ ⨯ B₁) → (A₂ ⨯ B₂)
map f g (x , y) = (f(x) , g(y))

-- Curries a function taking a 2-tuple, transforming it to a function returning a function instead
curry : ((A ⨯ B) → C) → (A → B → C)
curry f x y = f(x , y)

-- Uncurries a function taking a function, transforming it to a function taking a 2-tuple instead
uncurry : (A → B → C) → ((A ⨯ B) → C)
uncurry = elim

mapLeft : (A₁ → A₂) → (A₁ ⨯ B) → (A₂ ⨯ B)
mapLeft f = map f (x ↦ x)

mapRight : let _ = A in (B₁ → B₂) → (A ⨯ B₁) → (A ⨯ B₂)
mapRight f = map (x ↦ x) f

associateLeft : (A ⨯ (B ⨯ C)) → ((A ⨯ B) ⨯ C)
associateLeft (x , (y , z)) = ((x , y) , z)

associateRight : ((A ⨯ B) ⨯ C) → (A ⨯ (B ⨯ C))
associateRight ((x , y) , z) = (x , (y , z))

-- Swaps the left and right elements of a 2-tuple
swap : (A ⨯ B) → (B ⨯ A)
swap(x , y) = (y , x)

repeat : A → (A ⨯ A)
repeat x = (x , x)


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

-- Andreas, 2014-05-17 reported by Fabien Renaud

open import Common.Equality

data Nat : Set where
  zero : Nat
  suc  : Nat → Nat

{-# BUILTIN NATURAL Nat #-}

data List {a} (A : Set a) : Set a where
  [] : List A
  _∷_ : A → List A → List A

length : ∀{a}{A : Set a} → List A → Nat
length [] = zero
length (x ∷ xs) = suc (length xs)

foldr : ∀{a b}{A : Set a}{B : Set b} → (A → B → B) → B → List A → B
foldr c n [] = n
foldr c n (x ∷ xs) = c x (foldr c n xs)

length-cons : ∀{b} {B : Set b} (L : List B) x → length (x ∷ L) ≡ suc (length L)
length-cons []      _ = refl
length-cons (x ∷ L) _ = refl

suc-foldr-eq : ∀{b} {c} {B : Set b} {C : Set c} (LL : List B) (LA : List C)

  → suc (foldr (λ _ → suc) 0 LL) ≡
    suc (foldr (λ _ → suc) 0 LA)

  → length LL ≡
    length LA

suc-foldr-eq [] [] Eq = refl
suc-foldr-eq [] (x ∷ LA) ()
suc-foldr-eq (x ∷ LL) [] ()
suc-foldr-eq (x ∷ LL) (y ∷ LA) Eq rewrite length-cons LL x = {!!}

-- WAS:
-- Failed to infer the value of dotted pattern
-- when checking that the pattern ._ has type Nat

-- NOW: unsolved meta


------------------------------------------------------------------------
-- Some defined operations (multiplication by natural number and
-- exponentiation)
------------------------------------------------------------------------

open import Algebra

module Algebra.Operations (s : Semiring) where

open Semiring s hiding (zero)
open import Data.Nat using (zero; suc; ℕ)
open import Data.Function
open import Relation.Binary
open import Relation.Binary.PropositionalEquality as PropEq using (_≡_)
import Relation.Binary.EqReasoning as EqR
open EqR setoid

------------------------------------------------------------------------
-- Operations

-- Multiplication by natural number.

infixr 7 _×_

_×_ : ℕ → carrier → carrier
zero  × x = 0#
suc n × x = x + n × x

-- Exponentiation.

infixr 8 _^_

_^_ : carrier → ℕ → carrier
x ^ zero  = 1#
x ^ suc n = x * x ^ n

------------------------------------------------------------------------
-- Some properties

×-pres-≈ : _×_ Preserves₂ _≡_ ⟶ _≈_ ⟶ _≈_
×-pres-≈ {n} {n'} {x} {x'} n≡n' x≈x' = begin
  n  × x   ≈⟨ reflexive $ PropEq.cong (λ n → n × x) n≡n' ⟩
  n' × x   ≈⟨ ×-pres-≈ʳ n' x≈x' ⟩
  n' × x'  ∎
  where
  ×-pres-≈ʳ : ∀ n → (_×_ n) Preserves _≈_ ⟶ _≈_
  ×-pres-≈ʳ zero    x≈x' = refl
  ×-pres-≈ʳ (suc n) x≈x' = x≈x' ⟨ +-pres-≈ ⟩ ×-pres-≈ʳ n x≈x'

^-pres-≈ : _^_ Preserves₂ _≈_ ⟶ _≡_ ⟶ _≈_
^-pres-≈ {x} {x'} {n} {n'} x≈x' n≡n' = begin
  x  ^ n   ≈⟨ reflexive $ PropEq.cong (_^_ x) n≡n' ⟩
  x  ^ n'  ≈⟨ ^-pres-≈ˡ n' x≈x' ⟩
  x' ^ n'  ∎
  where
  ^-pres-≈ˡ : ∀ n → (λ x → x ^ n) Preserves _≈_ ⟶ _≈_
  ^-pres-≈ˡ zero    x≈x' = refl
  ^-pres-≈ˡ (suc n) x≈x' = x≈x' ⟨ *-pres-≈ ⟩ ^-pres-≈ˡ n x≈x'


module my-vector where

open import nat
open import bool
open import eq

data 𝕍 {ℓ}(A : Set ℓ) : ℕ → Set ℓ where
  [] : 𝕍 A 0
  _::_ : {n : ℕ} (x : A) (xs : 𝕍 A n) → 𝕍 A (suc n)

infixr 6 _::_ _++𝕍_

_++𝕍_ : ∀ {ℓ} {A : Set ℓ}{n m : ℕ} →
        𝕍 A n → 𝕍 A m → 𝕍 A (n + m)
[] ++𝕍 ys = ys
(x :: xs) ++𝕍 ys = x :: (xs ++𝕍 ys)

test-vector : 𝕍 𝔹 4
test-vector = ff :: tt :: ff :: ff :: []

test-vector-append : 𝕍 𝔹 8
test-vector-append = test-vector ++𝕍 test-vector

head𝕍 : ∀{ℓ}{A : Set ℓ}{n : ℕ} → 𝕍 A (suc n) → A
head𝕍 (x :: _) = x

tail𝕍 : ∀{ℓ}{A : Set ℓ}{n : ℕ} → 𝕍 A n → 𝕍 A (pred n)
tail𝕍 [] = []
tail𝕍 (_ :: xs) = xs

map𝕍 : ∀{ℓ ℓ'}{A : Set ℓ}{B : Set ℓ'}{n : ℕ} →
       (A → B) → 𝕍 A n → 𝕍 B n
map𝕍 f [] = []
map𝕍 f (x :: xs) = f x :: map𝕍 f xs

concat𝕍 : ∀{ℓ}{A : Set ℓ}{n m : ℕ} →
          𝕍 (𝕍 A n) m → 𝕍 A (m * n)
concat𝕍 [] = []
concat𝕍 (xs :: xs₁) = xs ++𝕍 (concat𝕍 xs₁)

nth𝕍 : ∀{ℓ}{A : Set ℓ}{m : ℕ} →
       (n : ℕ) → n < m ≡ tt → 𝕍 A m → A
nth𝕍 zero () []
nth𝕍 zero _ (x :: _) = x
nth𝕍 (suc _) () []
nth𝕍 (suc n₁) p (_ :: xs) = nth𝕍 n₁ p xs

repeat𝕍 : ∀{ℓ}{A : Set ℓ} → (a : A)(n : ℕ) → 𝕍 A n
repeat𝕍 a zero = []
repeat𝕍 a (suc n) = a :: (repeat𝕍 a n)


{-# OPTIONS --universe-polymorphism #-}

module PatternMatchingOnCodata where

data Level : Set where
  zero : Level
  suc  : (i : Level) → Level

_⊔_ : Level → Level → Level
zero  ⊔ j     = j
suc i ⊔ zero  = suc i
suc i ⊔ suc j = suc (i ⊔ j)

{-# BUILTIN LEVEL     Level #-}
{-# BUILTIN LEVELZERO zero  #-}
{-# BUILTIN LEVELSUC  suc   #-}
{-# BUILTIN LEVELMAX  _⊔_   #-}

infix 1000 ♯_

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

my-♭ : ∀ {a} {A : Set a} → ∞ A → A
my-♭ (♯ x) = x


------------------------------------------------------------------------
-- The Agda standard library
--
-- Natural numbers defined in terms of Data.Star
------------------------------------------------------------------------

module Data.Star.Nat where

open import Data.Star
open import Data.Unit
open import Function
open import Relation.Binary
open import Relation.Binary.Simple

-- Natural numbers.

ℕ : Set
ℕ = Star Always tt tt

-- Zero and successor.

zero : ℕ
zero = ε

suc : ℕ → ℕ
suc = _◅_ _

-- The length of a star-list.

length : ∀ {i t} {I : Set i} {T : Rel I t} {i j} → Star T i j → ℕ
length = gmap (const _) (const _)

-- Arithmetic.

infixl 7 _*_
infixl 6 _+_ _∸_

_+_ : ℕ → ℕ → ℕ
_+_ = _◅◅_

_*_ : ℕ → ℕ → ℕ
_*_ m = const m ⋆

_∸_ : ℕ → ℕ → ℕ
m       ∸ ε       = m
ε       ∸ (_ ◅ n) = zero
(_ ◅ m) ∸ (_ ◅ n) = m ∸ n

-- Some constants.

0# = zero
1# = suc 0#
2# = suc 1#
3# = suc 2#
4# = suc 3#
5# = suc 4#


module LearnYouAgda where
  data ℕ : Set where
    zero : ℕ
--    one  : ℕ
    suc  : ℕ -> ℕ

-- define arithmetic operations
  _+_ : ℕ → ℕ → ℕ
  zero + zero = zero
  zero + n    = n
  (suc n) + n′ = suc (n + n′)


module Numeral.Rational where

open import Data.Tuple
open import Logic
import      Lvl
open import Numeral.Natural
open import Numeral.Natural.Oper
open import Numeral.Integer
open import Numeral.Integer.Oper
open import Relator.Equals
open import Type
open import Type.Quotient

-- Equivalence relation of quotient equality.
-- Essentially (if one would already work in the rationals):
--   (a₁ , a₂) quot-≡_ (b₁ , b₂)
--   ⇔ a₁ ⋅ b₂ ≡ a₂ ⋅ b₁
--   ⇔ a₁ / a₂ ≡ b₁ / b₂
_quot-≡_ : (ℤ ⨯ ℕ₊) → (ℤ ⨯ ℕ₊) → Stmt{Lvl.𝟎}
(a₁ , a₂) quot-≡ (b₁ , b₂) = (a₁ ⋅ b₂ ≡ a₂ ⋅ b₁)

ℤ : Type{Lvl.𝟎}
ℤ = (ℤ ⨯ ℕ₊) / (_quot-≡_)


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

syntax Lens | L

type
  S : 0-ary
  A : 0-ary

term
  get : S  ->  A
  put : S  A  ->  S

theory
  (PG) s : S  a : A   |> get (put (s, a))   = a
  (GP) s : S          |> put (s, get(s))    = s
  (PP) s : S  a b : A |> put (put(s, a), b) = put (s, a)
-}

module Lens.Signature where

open import SOAS.Context

-- Type declaration
data LT : Set where
  S : LT
  A : LT

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

-- Operator symbols
data Lₒ : Set where
  getₒ putₒ : Lₒ

-- Term signature
L:Sig : Signature Lₒ
L:Sig = sig λ
  {  getₒ  → (⊢₀ S) ⟼₁ A
  ;  putₒ  → (⊢₀ S) , (⊢₀ A) ⟼₂ S
  }

open Signature L:Sig public


module Logics.Not where

open import Function
open import Relation.Nullary

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

private

  a=¬∘¬a : ∀ {a} {A : Set a} → A → ¬ (¬ A)
  a=¬∘¬a a z = z a

  /p→q/→¬/p→¬q/ : ∀ {p q} {P : Set p} {Q : Set q} → (P → Q) → (¬ Q → ¬ P)
  /p→q/→¬/p→¬q/ p→q ¬q p = ¬q $ p→q p

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

not-not : ∀ {ℓ} {A : Set ℓ} → A → ¬ (¬ A)
not-not = a=¬∘¬a

contrapositive : ∀ {p q} {P : Set p} {Q : Set q} → (P → Q) → (¬ Q → ¬ P)
contrapositive = /p→q/→¬/p→¬q/


module LC.Example where

open import LC.Base
open import LC.Subst
open import LC.Reduction
open import LC.Reasoning

test-1 : ((ƛ var 0) ∙ var 0) β→* ((var 0) [ var 0 ])
test-1 =
  begin
    (ƛ var 0) ∙ var 0
  →⟨ β-ƛ-∙ ⟩
    (var 0) [ var 0 ]
  ∎

test-0 : ƛ (ƛ var 0 ∙ var 1) ∙ (ƛ var 0 ∙ var 1) β→* ƛ var 0 ∙ var 0
test-0 =
    begin
        ƛ (ƛ var 0 ∙ var 1) ∙ (ƛ var 0 ∙ var 1)
    →⟨ β-ƛ β-ƛ-∙ ⟩
        ƛ (var 0 ∙ var 1) [ ƛ var 0 ∙ var 1 ]
    →⟨⟩
        ƛ (var 0 ∙ var 1) [ ƛ var 0 ∙ var 1 / 0 ]
    →⟨⟩
        ƛ (var 0) [ ƛ var 0 ∙ var 1 / 0 ] ∙ (var 1) [ ƛ var 0 ∙ var 1 / 0 ]
    →⟨⟩
        ƛ lift 0 0 (ƛ var 0 ∙ var 1) ∙ var 0
    →⟨⟩
        ƛ (ƛ lift 0 0 (var 0 ∙ var 1)) ∙ var 0
    →⟨⟩
        ƛ (ƛ lift 0 0 (var 0) ∙ lift 0 0 (var 1)) ∙ var 0
    →⟨⟩
        ƛ ((ƛ var 0 ∙ var 1) ∙ var 0)
    →⟨ β-ƛ β-ƛ-∙ ⟩
        ƛ (var 0 ∙ var 1) [ var 0 / 0 ]
    →⟨⟩
        ƛ var 0 ∙ var 0
    ∎

Z : Term
Z = ƛ ƛ var 0

SZ : Term
SZ = ƛ ƛ var 1 ∙ var 0

PLUS : Term
PLUS = ƛ ƛ ƛ ƛ var 3 ∙ var 1 ∙ (var 2 ∙ var 1 ∙ var 0)

test-2 : PLUS ∙ Z ∙ SZ β→* SZ
test-2 =
  begin
    PLUS ∙ Z ∙ SZ
  →⟨ β-∙-l β-ƛ-∙ ⟩
    (ƛ ƛ ƛ var 3 ∙ var 1 ∙ (var 2 ∙ var 1 ∙ var 0)) [ ƛ ƛ var 0 / 0 ] ∙ SZ
  →⟨⟩
    (ƛ ((ƛ ƛ var 3 ∙ var 1 ∙ (var 2 ∙ var 1 ∙ var 0)) [ ƛ ƛ var 0 / 1 ])) ∙ SZ
  →⟨⟩
    (ƛ (ƛ (ƛ var 3 ∙ var 1 ∙ (var 2 ∙ var 1 ∙ var 0)) [ ƛ ƛ var 0 / 2 ])) ∙ SZ
  →⟨⟩
    (ƛ (ƛ (ƛ ((var 3 ∙ var 1 ∙ (var 2 ∙ var 1 ∙ var 0)) [ ƛ ƛ var 0 / 3 ])))) ∙ SZ
  →⟨⟩
    (ƛ (ƛ (ƛ (var 3) [ ƛ ƛ var 0 / 3 ] ∙ (var 1) [ ƛ ƛ var 0 / 3 ] ∙ (var 2 ∙ var 1 ∙ var 0) [ ƛ ƛ var 0 / 3 ]))) ∙ SZ
  →⟨⟩
    (ƛ (ƛ (ƛ (lift 0 3 (ƛ (ƛ var 0))) ∙ var 1 ∙ (var 2 ∙ var 1 ∙ var 0)))) ∙ SZ
  →⟨⟩
    (ƛ (ƛ (ƛ (ƛ (ƛ (var 0))) ∙ var 1 ∙ (var 2 ∙ var 1 ∙ var 0)))) ∙ SZ
  →⟨ β-∙-l (β-ƛ (β-ƛ (β-ƛ (β-∙-l β-ƛ-∙)))) ⟩
    (ƛ (ƛ (ƛ (ƛ var 0) [ var 1 / 0 ] ∙ (var 2 ∙ var 1 ∙ var 0)))) ∙ SZ
  →⟨⟩
    (ƛ (ƛ (ƛ (ƛ (var 0) [ var 1 / 1 ]) ∙ (var 2 ∙ var 1 ∙ var 0)))) ∙ SZ
  →⟨⟩
    (ƛ (ƛ (ƛ (ƛ var 0) ∙ (var 2 ∙ var 1 ∙ var 0)))) ∙ SZ
  →⟨ β-∙-l (β-ƛ (β-ƛ (β-ƛ β-ƛ-∙))) ⟩
    (ƛ (ƛ (ƛ (var 0) [ var 2 ∙ var 1 ∙ var 0 / 0 ]))) ∙ SZ
  →⟨⟩
    (ƛ (ƛ (ƛ (var 2 ∙ var 1 ∙ var 0)))) ∙ SZ
  →⟨ β-ƛ-∙ ⟩
    (ƛ (ƛ (var 2 ∙ var 1 ∙ var 0))) [ SZ / 0 ]
  →⟨⟩
    ƛ (ƛ (var 2 ∙ var 1 ∙ var 0) [ SZ / 2 ])
  →⟨⟩
    ƛ (ƛ lift 0 2 SZ ∙ var 1 ∙ var 0)
  →⟨⟩
    ƛ (ƛ (ƛ ƛ var 1 ∙ var 0) ∙ var 1 ∙ var 0)
  →⟨ β-ƛ (β-ƛ (β-∙-l β-ƛ-∙)) ⟩
    ƛ (ƛ (ƛ var 1 ∙ var 0) [ var 1 / 0 ] ∙ var 0)
  →⟨⟩
    ƛ (ƛ (ƛ ((var 1 ∙ var 0) [ var 1 / 1 ])) ∙ var 0)
  →⟨⟩
    ƛ (ƛ (ƛ ((var 1) [ var 1 / 1 ] ∙ (var 0) [ var 1 / 1 ])) ∙ var 0)
  →⟨⟩
    ƛ (ƛ (ƛ (lift 0 1 (var 1) ∙ var 0)) ∙ var 0)
  →⟨⟩
    ƛ (ƛ (ƛ (var 2 ∙ var 0)) ∙ var 0)
  →⟨ β-ƛ (β-ƛ β-ƛ-∙) ⟩
    ƛ (ƛ (var 2 ∙ var 0) [ var 0 / 0 ])
  →⟨⟩
    ƛ (ƛ (var 2) [ var 0 / 0 ] ∙ var 0)
  →⟨⟩
    ƛ (ƛ var 1 ∙ var 0)
  ∎


open import Type

module Relator.Congruence {ℓ₁}{ℓ₂} {X : Type{ℓ₁}}{Y : Type{ℓ₂}} where

import      Lvl
open import Functional
open import Logic
open import Logic.Propositional
open import Relator.Equals

-- The congruence relation with respect to a relation
infixl 15 _≅_of_
data _≅_of_ (x₁ : X) (x₂ : X) (f : X → Y) : Stmt{ℓ₂} where
  [≅]-intro : (f(x₁) ≡ f(x₂)) → (x₁ ≅ x₂ of f)

[≅]-elim : ∀{x₁ x₂ : X}{f : X → Y} → (x₁ ≅ x₂ of f) → (f(x₁) ≡ f(x₂))
[≅]-elim ([≅]-intro eq) = eq


------------------------------------------------------------------------
-- The Agda standard library
--
-- Instantiates the ring solver, using the natural numbers as the
-- coefficient "ring"
------------------------------------------------------------------------

open import Algebra
import Algebra.Operations
open import Relation.Nullary

module Algebra.RingSolver.Natural-coefficients
         {r₁ r₂}
         (R : CommutativeSemiring r₁ r₂)
         (dec : let open CommutativeSemiring R
                    open Algebra.Operations semiring in
                ∀ m n → Dec (m × 1# ≈ n × 1#)) where

import Algebra.RingSolver
open import Algebra.RingSolver.AlmostCommutativeRing
open import Data.Nat as ℕ
open import Data.Product using (module Σ)
open import Function
import Relation.Binary.EqReasoning
import Relation.Nullary.Decidable as Dec

open CommutativeSemiring R
open Algebra.Operations semiring
open Relation.Binary.EqReasoning setoid

private

  -- The coefficient "ring".

  ℕ-ring : RawRing _
  ℕ-ring = record
    { Carrier = ℕ
    ; _+_     = ℕ._+_
    ; _*_     = ℕ._*_
    ; -_      = id
    ; 0#      = 0
    ; 1#      = 1
    }

  -- There is a homomorphism from ℕ to R.
  --
  -- Note that _×′_ is used rather than _×_. If _×_ were used, then
  -- Function.Related.TypeIsomorphisms.test would fail to type-check.

  homomorphism :
    ℕ-ring -Raw-AlmostCommutative⟶ fromCommutativeSemiring R
  homomorphism = record
    { ⟦_⟧    = λ n → n ×′ 1#
    ; +-homo = ×′-homo-+ 1#
    ; *-homo = ×′1-homo-*
    ; -‿homo = λ _ → refl
    ; 0-homo = refl
    ; 1-homo = refl
    }

  -- Equality of certain expressions can be decided.

  dec′ : ∀ m n → Dec (m ×′ 1# ≈ n ×′ 1#)
  dec′ m n = Dec.map′ to from (dec m n)
    where
    to : m × 1# ≈ n × 1# → m ×′ 1# ≈ n ×′ 1#
    to m≈n = begin
      m ×′ 1#  ≈⟨ sym $ ×≈×′ m 1# ⟩
      m ×  1#  ≈⟨ m≈n ⟩
      n ×  1#  ≈⟨ ×≈×′ n 1# ⟩
      n ×′ 1#  ∎

    from : m ×′ 1# ≈ n ×′ 1# → m × 1# ≈ n × 1#
    from m≈n = begin
      m ×  1#  ≈⟨ ×≈×′ m 1# ⟩
      m ×′ 1#  ≈⟨ m≈n ⟩
      n ×′ 1#  ≈⟨ sym $ ×≈×′ n 1# ⟩
      n ×  1#  ∎

-- The instantiation.

open Algebra.RingSolver _ _ homomorphism dec′ public