{-

    Practical Relational Algebra
            Toon Nolten
              based on
          The Power Of Pi

-}
module relational-algebra where

open import Data.Empty
open import Data.Unit hiding (_≤_)
open import Data.Bool
open import Data.Nat
open import Data.Integer hiding (show)
open import Data.List
open import Data.Char hiding (_==_) renaming (show to charToString)
open import Data.Vec hiding (_++_; lookup; map; foldr; _>>=_)
open import Data.String using (String; toVec; _==_; strictTotalOrder)
                        renaming (_++_ to _∥_)
open import Data.Product using (_×_; _,_; proj₁)
open import Coinduction
open import IO

open import Relation.Binary
open StrictTotalOrder Data.String.strictTotalOrder renaming (compare to str_cmp)

data Order : Set where
  LT EQ GT : Order

module InsertionSort where
  insert : {A : Set} → (A → A → Order) → A → List A → List A
  insert _   e []       = e ∷ []
  insert cmp e (l ∷ ls) with cmp e l
  ... | GT = l ∷ insert cmp e ls
  ... | _  = e ∷ l ∷ ls

  sort : {A : Set} → (A → A → Order) → List A → List A
  sort cmp = foldr (insert cmp) []
open InsertionSort using (insert; sort)

-- Universe U exists of type U and el : U → Set
data U : Set where
  CHAR NAT BOOL : U
  VEC  : U → ℕ → U

el : U → Set
el CHAR      = Char
el NAT       = ℕ
el (VEC u n) = Vec (el u) n
el BOOL      = Bool

parens : String → String
parens str = "(" ∥ str ∥ ")"

show : {u : U} → el u → String
show {CHAR         } c        = charToString c
show {NAT          } zero     = "Zero"
show {NAT          } (suc k)  = "Succ " ∥ parens (show k)
show {VEC u zero   } Nil      = "Nil"
show {VEC u (suc k)} (x ∷ xs) = parens (show x) ∥ " ∷ " ∥ parens (show xs)
show {BOOL         } true     = "True"
show {BOOL         } false    = "False"

_=ᴺ_ : ℕ → ℕ → Bool
zero  =ᴺ zero  = true
suc m =ᴺ suc n = (m =ᴺ n)
_     =ᴺ _     = false

_≤ᴺ_ : ℕ → ℕ → Order
zero  ≤ᴺ zero  = EQ
zero  ≤ᴺ _     = LT
_     ≤ᴺ zero  = GT
suc a ≤ᴺ suc b = a ≤ᴺ b

_=ᵁ_ : U → U → Bool
CHAR    =ᵁ CHAR      = true
NAT     =ᵁ NAT       = true
BOOL    =ᵁ BOOL      = true
VEC u x =ᵁ VEC u' x' = (u =ᵁ u') ∧ (x =ᴺ x')
_       =ᵁ _         = false

_≤ᵁ_ : U → U → Order
CHAR ≤ᵁ CHAR = EQ
CHAR ≤ᵁ _ = LT
_ ≤ᵁ CHAR = GT
NAT ≤ᵁ NAT = EQ
NAT ≤ᵁ _ = LT
_ ≤ᵁ NAT = GT
BOOL ≤ᵁ BOOL = EQ
BOOL ≤ᵁ _ = LT
_ ≤ᵁ BOOL = GT
VEC a x ≤ᵁ VEC b y with a ≤ᵁ b
... | LT = LT
... | EQ = x ≤ᴺ y
... | GT = GT

So : Bool → Set
So true  = ⊤
So false = ⊥

data SqlValue : Set where
  SqlString  : String → SqlValue
  SqlChar    : Char   → SqlValue
  SqlBool    : Bool   → SqlValue
  SqlInteger : ℤ      → SqlValue
--{-# COMPILED_DATA SqlValue SqlValue SqlString SqlChar SqlBool SqlInteger #-}

module OrderedSchema where
  SchemaDescription = List (List SqlValue)

  Attribute : Set
  Attribute = String × U

  -- Compare on type if names are equal.
  -- SQL DB's probably don't allow columns with the same name
  -- but nothing prevents us from writing a Schema that does,
  -- this is necessary to make our sort return a unique answer.
  attr_cmp : Attribute → Attribute → Order
  attr_cmp (nm₁ , U₁) (nm₂ , U₂) with str_cmp nm₁ nm₂ | U₁ ≤ᵁ U₂
  ... | tri< _ _ _ | _     = LT
  ... | tri≈ _ _ _ | U₁≤U₂ = U₁≤U₂
  ... | tri> _ _ _ | _     = GT

  data Schema : Set where
    sorted : List Attribute → Schema

  mkSchema : List Attribute → Schema
  mkSchema xs = sorted (sort attr_cmp xs)

  expandSchema : Attribute → Schema → Schema
  expandSchema x (sorted xs) = sorted (insert attr_cmp x xs)

  schemify : SchemaDescription → Schema
  schemify sdesc = {!!}

  disjoint : Schema → Schema → Bool
  disjoint (sorted []      ) (_              ) = true
  disjoint (_              ) (sorted []      ) = true
  disjoint (sorted (x ∷ xs)) (sorted (y ∷ ys)) with attr_cmp x y
  ... | LT = disjoint (sorted xs      ) (sorted (y ∷ ys))
  ... | EQ = false
  ... | GT = disjoint (sorted (x ∷ xs)) (sorted ys      )

  sub : Schema → Schema → Bool
  sub (sorted []      ) (_              ) = true
  sub (sorted (x ∷ _) ) (sorted []      ) = false
  sub (sorted (x ∷ xs)) (sorted (X ∷ Xs)) with attr_cmp x X
  ... | LT = false
  ... | EQ = sub (sorted xs      ) (sorted Xs)
  ... | GT = sub (sorted (x ∷ xs)) (sorted Xs)

  same' : List Attribute → List Attribute → Bool
  same' ([]              ) ([]              ) = true
  same' ((nm₁ , ty₁) ∷ xs) ((nm₂ , ty₂) ∷ ys) =
    (nm₁ == nm₂) ∧ (ty₁ =ᵁ ty₂) ∧ same' xs ys
  same' (_               ) (_               ) = false

  same : Schema → Schema → Bool
  same (sorted xs) (sorted ys) = same' xs ys

  occurs : String → Schema → Bool
  occurs nm (sorted s) = any (_==_ nm) (map (proj₁) s)

  lookup' : (nm : String) → (s : List Attribute)
              → So (occurs nm (sorted s)) → U
  lookup' _  []                   ()
  lookup' nm ((name , type) ∷ s') p with nm == name
  ... | true  = type
  ... | false = lookup' nm s' p

  lookup : (nm : String) → (s : Schema) → So (occurs nm s) → U
  lookup nm (sorted s) = lookup' nm s

  append : (s s' : Schema) → Schema
  append (sorted s) (sorted s') = mkSchema (s ++ s')
open OrderedSchema using (Schema; mkSchema; expandSchema; schemify;
                          disjoint; sub; same; occurs; lookup;
                          append)

data Row : Schema → Set where
  EmptyRow : Row (mkSchema [])
  ConsRow  : ∀ {name u s} → el u → Row s → Row (expandSchema (name , u) s)

Table : Schema → Set
Table s = List (Row s)

DatabasePath = String
TableName    = String

postulate
  Connection : Set
  connectSqlite3 : DatabasePath → IO Connection
  describe_table : TableName → Connection → IO (List (List SqlValue))
-- {-# COMPILED_TYPE Connection Connection #-}
-- {-# COMPILED connectSqlite3 connectSqlite3 #-}
-- {-# COMPILED describe_table describe_table #-}

data Handle : Schema → Set where
  conn : Connection → (s : Schema) → Handle s

-- Connect currently ignores differences between
-- the expected schema and the actual schema.
-- According to tpop this should result in
-- "a *runtime exception* in the *IO* monad."
-- Agda does not have exceptions(?)
--  -> postulate error with a compiled pragma?
connect : DatabasePath → TableName → (s : Schema) → IO (Handle s)
connect DB table schema_expect =
  ♯ (connectSqlite3 DB) >>=
    (λ sqlite_conn →
      ♯ (♯ (describe_table table sqlite_conn) >>=
      (λ description →
        ♯ (♯ (return (schemify description)) >>=
        (λ schema_actual →
          ♯ (♯ (return (same schema_expect schema_actual)) >>=
          (λ { true  → ♯ (return (conn sqlite_conn schema_expect));
               false → ♯ (return (conn sqlite_conn schema_expect)) })))))))

data Expr : Schema → U → Set where
  equal    : ∀ {u s} → Expr s u → Expr s u → Expr s BOOL
  lessThan : ∀ {u s} → Expr s u → Expr s u → Expr s BOOL
  _!_      : (s : Schema) → (nm : String) → {p : So (occurs nm s)}
               → Expr s (lookup nm s p)

data RA : Schema → Set where
  Read    : ∀ {s} → Handle s → RA s
  Union   : ∀ {s} → RA s → RA s → RA s
  Diff    : ∀ {s} → RA s → RA s → RA s
  Product : ∀ {s s'} → {_ : So (disjoint s s')} → RA s → RA s'
              → RA (append s s')
  Project : ∀ {s} → (s' : Schema) → {_ : So (sub s' s)} → RA s → RA s'
  Select  : ∀ {s} → Expr s BOOL → RA s → RA s
  -- ...
{-
  As we mentioned previously, we have taken a very minimal set of relational
  algebra operators. It should be fairly straightforward to add operators
  for the many other operators in relational algebra, such as the

  natural join, θ-join, equijoin, renaming, or division,

  using the same techniques. Alternatively, you can define many of these
  operations in terms of the operations we have implemented in the RA data type.
-}

-- We could:
postulate
  toSQL : ∀ {s} → RA s → String

-- We can do much better:
postulate
  query : {s : Schema} → RA s → IO (List (Row s))
{-
  The *query* function uses *toSQL* to produce a query, and passes this to the
  database server. When the server replies, however, we know exactly how to
  parse the response: we know the schema of the table resulting from our query,
  and can use this to parse the database server's response in a type-safe
  manner. The type checker can then statically check that the program uses the
  returned list in a way consistent with its type.
-}

Cars : Schema
Cars = mkSchema (("Model" , VEC CHAR 20) ∷ ("Time" , VEC CHAR 6)
                 ∷ ("Wet" , BOOL) ∷ [])

zonda : Row Cars
zonda = ConsRow (toVec "Pagani Zonda C12 F  ")
        (ConsRow (toVec "1:18.4")
        (ConsRow false EmptyRow))

Models : Schema
Models = mkSchema (("Model" , VEC CHAR 20) ∷ [])

models : Handle Cars → RA Models
models h = Project Models (Read h)

wet : Handle Cars → RA Models
wet h = Project Models (Select (Cars ! "Wet") (Read h))

{- Discussion
   ==========

   There are many, many aspects of this proposal that can be improved. Some
   attributes of a schema contain *NULL*-values; we should close our universe
   under *Maybe* accordingly. Some database servers silently truncate strings
   longer than 255 characters. We would do well to ensure statically that this
   never happens. Our goal, however, was not to provide a complete model of all
   of SQL's quirks and idiosyncrasies: we want to show how a language with
   dependent types can schine where Haskell struggles.
     Our choice of *Schema* data type suffers from the usual disadvantages of
   using a list to represent a set: our *Schema* data type may contain
   duplicates and the order of the elements matters. The first problem is easy
   to solve. Using an implicit proof argument in the *Cons* case, we can define
   a data type for lists that do not contain duplicates. The type of *Cons* then
   becomes:
     Cons : (nm : String) → (u : U) → (s : Schema) → {_ : So (not (elem nm s))}
                → Schema
   The second point is a bit trickier. The real solution would involve quotient
   types to make the order of the elements unobservable. As Agda does not
   support quotient types, however, the best we can do is parameterise our
   constructors by an additional proof argument, when necessary. For example,
   the *Union* constructor could be defined as follows:
     Union : ∀ {s s'} → {_ : So (permute s s')} → RA s → RA s' → RA s
   Instead of requiring that both arguments of *Union* are indexed by the same
   schema, we should only require that the two schemas are equal up to a
   permutation of the elements. Alternatively, we could represent the *Schema*
   using a data structure that fixes the order in which its constituent
   elements occur, such as a trie or sorted list.
     Finally, we would like to return to our example table. We chose to model
   the lap time as a fixed-length string ─ clearly, a triple of integers would
   be a better representation. Unfortunately, most database servers only
   support a handful of built-in types, such as strings, numbers, bits. There
   is no way to extend these primitive types. This problem is sometimes
   referred to as the *object-relational impedance mismatch*. We believe the
   generic programming techniques and views from the previous sections can be
   used to marshall data between a low-level representation in the database
   and the high-level representation in our programming language.
-}


module Data.Fin.Sigma where

open import Prelude
open import Data.Nat
open import Data.Nat.Properties

Fin : ℕ → Type
Fin n = ∃ m × (m < n)

open import Data.List

_!!_ : (xs : List A) → Fin (length xs) → A
(x ∷ xs) !! (zero  , p) = x
(x ∷ xs) !! (suc n , p) = xs !! (n , p)


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

open import Categories.Category
open import Categories.Functor.Bifunctor

module Categories.Diagram.Coend {o ℓ e o′ ℓ′ e′} {C : Category o ℓ e} {D : Category o′ ℓ′ e′}
  (F : Bifunctor (Category.op C) C D) where

private
  module C = Category C
  module D = Category D
  open D
  open HomReasoning
  variable
    A B : Obj
    f g : A ⇒ B

open import Level
open import Data.Product using (Σ; _,_)

open import Categories.Functor
open import Categories.Functor.Construction.Constant
open import Categories.NaturalTransformation.Dinatural
open import Categories.Morphism.Reasoning D

open Functor F

record Cowedge : Set (levelOfTerm F) where
  field
    E         : Obj
    dinatural : DinaturalTransformation F (const E)

  module dinatural = DinaturalTransformation dinatural

Cowedge-∘ : (W : Cowedge) → Cowedge.E W ⇒ A → Cowedge
Cowedge-∘ {A = A} W f = record
  { E         = A
  ; dinatural = extranaturalˡ (λ X → f ∘ dinatural.α X)
                              (assoc ○ ∘-resp-≈ʳ (extranatural-commˡ dinatural) ○ ⟺ assoc)
  }
  where open Cowedge W

record Coend : Set (levelOfTerm F) where
  field
    cowedge : Cowedge

  module cowedge = Cowedge cowedge
  open cowedge public
  open Cowedge

  field
    factor    : (W : Cowedge) → cowedge.E ⇒ E W
    universal : ∀ {W : Cowedge} {A} → factor W ∘ cowedge.dinatural.α A ≈ dinatural.α W A
    unique    : ∀ {W : Cowedge} {g : cowedge.E ⇒ E W} → (∀ {A} → g ∘ cowedge.dinatural.α A ≈ dinatural.α W A) → factor W ≈ g

  η-id : factor cowedge ≈ D.id
  η-id = unique identityˡ

  unique′ :(∀ {A} → f ∘ cowedge.dinatural.α A ≈ g ∘ cowedge.dinatural.α A) → f ≈ g
  unique′ {f = f} {g = g} eq = ⟺ (unique {W = Cowedge-∘ cowedge f} refl) ○ unique (⟺ eq)


------------------------------------------------------------------------------
-- The paradoxical combinator
------------------------------------------------------------------------------

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

-- See (Barendregt 2004, corollary 6.1.3).

module FOT.LTC-PCF.Y where

open import LTC-PCF.Base hiding ( fix ; fix-eq )

------------------------------------------------------------------------------
-- This is the fixed-point combinator used by (Dybjer 1985).
Y : D
Y = lam (λ f → lam (λ x → f · (x · x)) · lam (λ x → f · (x · x)))

-- We define a higher-order Y.
Y₁ : (D → D) → D
Y₁ f = Y · lam f

------------------------------------------------------------------------------
-- References
--
-- Barendregt, Henk (2004). The Lambda Calculus. Its Syntax and
-- Semantics. 2nd ed. Vol. 103. Studies in Logic and the Foundations
-- of Mathematics. 6th impression. Elsevier.
--
-- Dybjer, Peter (1985). Program Verification in a Logical Theory of
-- Constructions. In: Functional Programming Languages and Computer
-- Architecture. Ed. by Jouannaud,
-- Jean-Pierre. Vol. 201. LNCS. Appears in revised form as Programming
-- Methodology Group Report 26, University of Gothenburg and Chalmers
-- University of Technology, June 1986. Springer, pp. 334–349 (cit. on
-- p. 26).


open import Agda.Primitive
open import Agda.Builtin.Equality

variable
  ℓ : Level
  A : Set ℓ
  P : A → Set ℓ
  x y : A
  f : (x : A) → P x

cong : x ≡ y → f x ≡ f y
cong refl = refl


open import Prelude
open import dynamics-core

open import progress-checks

module finality where
  finality : Σ[ d ∈ ihexp ] (d final × (Σ[ d' ∈ ihexp ] (d ↦ d'))) → ⊥
  finality (π1 , π2 , π3 , π4) = final-not-step π2 (π3 , π4)

  -- a slight restatement of the above, generalizing it to the
  -- multistep judgement
  finality* : ∀{d d'} → d final → d ↦* d' → d == d'
  finality* fin MSRefl = refl
  finality* fin (MSStep x ms) = abort (final-not-step fin (_ , x))


{-# OPTIONS --without-K #-}
module Explore.README where

-- The core types behind exploration functions
open import Explore.Core

-- The core properties behind exploration functions
open import Explore.Properties

-- Lifting the dependent axiom of choice to sums and products
open import Explore.BigDistr

-- Constructions on top of exploration functions
open import Explore.Explorable

-- Specific constructions on top of summation functions
open import Explore.Summable

-- Exploration of Cartesian products (and Σ-types)
open import Explore.Product

-- Exploration of disjoint sums
open import Explore.Sum

-- Exploration of base types 𝟘, 𝟙, 𝟚, Fin n
open import Explore.Zero
open import Explore.One
open import Explore.Two
open import Explore.Fin

-- A type universe of explorable types
open import Explore.Universe.Type
open import Explore.Universe.Base
open import Explore.Universe

-- Transporting explorations across isomorphisms
open import Explore.Isomorphism

-- From binary trees to explorations and back
open import Explore.BinTree

-- Exploration functions form a monad
open import Explore.Monad

-- Some high-level properties about group homomorphisms and
-- group isomorphisms.
-- For instance the indistinguisability (One-time-pad like) for groups
open import Explore.Group

-- In a (bit) guessing game,
open import Explore.GuessingGameFlipping

-- An example with a specific type: 6 sided dice
open import Explore.Dice

-- TODO unfinished
-- BROKEN open import Explore.Function.Fin
open import Explore.Subset


module sum where

open import level
open import bool
open import eq
open import maybe
open import product

----------------------------------------------------------------------
-- datatypes
----------------------------------------------------------------------

data _⊎_ {ℓ ℓ'} (A : Set ℓ) (B : Set ℓ') : Set (ℓ ⊔ ℓ') where
  inj₁ : (x : A) → A ⊎ B
  inj₂ : (y : B) → A ⊎ B

_∨_ : ∀ {ℓ ℓ'} (A : Set ℓ) (B : Set ℓ') → Set (ℓ ⊔ ℓ')
_∨_ = _⊎_

----------------------------------------------------------------------
-- syntax
----------------------------------------------------------------------

infixr 0 _⊎_ _∨_

----------------------------------------------------------------------
-- operations
----------------------------------------------------------------------

_≫=⊎_ : ∀ {ℓ ℓ'}{A : Set ℓ}{B : Set ℓ'}{C : Set (ℓ ⊔ ℓ')}  → A ⊎ B → (B → A ⊎ C) → A ⊎ C
inj₁ x ≫=⊎ f = inj₁ x
inj₂ x ≫=⊎ f = f x

return⊎ : ∀ {ℓ ℓ'}{A : Set ℓ}{B : Set ℓ'} → B → A ⊎ B
return⊎ b = inj₂ b

infix 5 error⊎_

error⊎_ : ∀ {ℓ ℓ'}{A : Set ℓ}{B : Set ℓ'} → A → A ⊎ B
error⊎_ a = inj₁ a

extract-inj₁≡ : ∀{ℓ}{ℓ'}{A : Set ℓ}{B : Set ℓ'}{a a' : A} → inj₁{B = B} a ≡ inj₁ a' → a ≡ a'
extract-inj₁≡ refl = refl

extract-inj₂≡ : ∀{ℓ}{ℓ'}{A : Set ℓ}{B : Set ℓ'}{b b' : B} → inj₂{A = A} b ≡ inj₂ b' → b ≡ b'
extract-inj₂≡ refl = refl

=⊎ : ∀{ℓ}{ℓ'}{A : Set ℓ}{B : Set ℓ'} → (A → A → 𝔹) → (B → B → 𝔹) → A ⊎ B → A ⊎ B → 𝔹
=⊎ eqa eqb (inj₁ a) (inj₁ a') = eqa a a'
=⊎ eqa eqb (inj₂ b) (inj₂ b') = eqb b b'
=⊎ _ _ _ _ = ff

=⊎-to-≡ : ∀{ℓ}{ℓ'}{A : Set ℓ}{B : Set ℓ'} → (_eqa_ : A → A → 𝔹) → (_eqb_ : B → B → 𝔹) → ((a a' : A) → (a eqa a' ≡ tt) → a ≡ a') → ((b b' : B) → (b eqb b' ≡ tt) → b ≡ b') →  (x y : A ⊎ B) → =⊎ _eqa_ _eqb_ x y  ≡ tt → x ≡ y
=⊎-to-≡ eqa eqb risea riseb (inj₁ a) (inj₁ a') p rewrite risea a a' p = refl
=⊎-to-≡ eqa eqb risea riseb (inj₂ b) (inj₂ b') p rewrite riseb b b' p = refl
=⊎-to-≡ eqa eqb risea riseb (inj₁ a) (inj₂ b) ()
=⊎-to-≡ eqa eqb risea riseb (inj₂ b) (inj₁ a) ()

≡⊎-to-= : ∀{ℓ}{ℓ'}{A : Set ℓ}{B : Set ℓ'} → (_eqa_ : A → A → 𝔹) → (_eqb_ : B → B → 𝔹) → ((a a' : A) → a ≡ a' → a eqa a' ≡ tt) → ((b b' : B) → b ≡ b' → b eqb b' ≡ tt) →  (x y : A ⊎ B) → x ≡ y → =⊎ _eqa_ _eqb_ x y  ≡ tt
≡⊎-to-= eqa eqb dropa dropb (inj₁ a) (inj₁ a') p = dropa a a' (extract-inj₁≡ p)
≡⊎-to-= eqa eqb dropa dropb (inj₂ b) (inj₂ b') p = dropb b b' (extract-inj₂≡ p)
≡⊎-to-= eqa eqb dropa dropb (inj₁ a) (inj₂ b) ()
≡⊎-to-= eqa eqb dropa dropb (inj₂ b) (inj₁ a) ()


-- Andreas, 2011-04-05
module EtaContractToMillerPattern where

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

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

postulate A B C : Set

test : let X : (Prod A B -> C) -> (Prod A B -> C)
           X = _
       in (x : Prod A B -> C) ->
            X (\ z -> x (fst z , snd z)) == x
test x = refl
-- eta contracts unification problem to  X x = x


module Structure.Relator.Function where

import      Lvl
open import Lang.Instance
open import Logic
open import Logic.Propositional
open import Logic.Predicate
open import Functional
open import Structure.Setoid
open import Structure.Setoid.Uniqueness
open import Structure.Relator
open import Type

private variable ℓₒ₁ ℓₒ₂ ℓₒ₃ ℓₑ₂ : Lvl.Level

module _ {A : Type{ℓₒ₁}}{B : Type{ℓₒ₂}} ⦃ equiv-B : Equiv{ℓₑ₂}(B) ⦄ (φ : A → B → Stmt{ℓₒ₃}) where
  module _ (f : A → B) where
    record Computable : Stmt{ℓₒ₁ Lvl.⊔ ℓₒ₂ Lvl.⊔ ℓₒ₃ Lvl.⊔ ℓₑ₂} where
      constructor intro
      field proof : ∀{x}{y} → (f(x) ≡ y) → φ(x)(y)
    computable = inst-fn Computable.proof

  -- A binary operation is total when every LHS have at least one RHS in which the relation holds.
  record Total : Stmt{ℓₒ₁ Lvl.⊔ ℓₒ₂ Lvl.⊔ ℓₒ₃} where
    constructor intro
    field proof : ∀{x} → ∃(y ↦ φ(x)(y))

    compute : A → B
    compute(x) = [∃]-witness(proof{x})

    computableFunction : ⦃ _ : ∀{x} → UnaryRelator(φ(x)) ⦄ → ∃(Computable)
    ∃.witness computableFunction = compute
    Computable.proof (∃.proof computableFunction) {x} eq = substitute₁(φ(x)) eq ([∃]-proof(proof{x}))
  total = inst-fn Total.proof

  -- A binary operation is a function when every LHS have at least one RHS in which the relation holds.
  record Function : Stmt{ℓₒ₁ Lvl.⊔ ℓₒ₂ Lvl.⊔ ℓₒ₃ Lvl.⊔ ℓₑ₂} where
    constructor intro
    field proof : ∀{x} → Unique(φ(x))
  function = inst-fn Function.proof
  -- (∀{x}{y₁ y₂} → φ(x)(y₁) → φ(x)(y₂) → (y₁ ≡ y₂))

  totalFunction : ⦃ _ : Total ⦄ → ⦃ _ : Function ⦄ → (∀{x} → ∃!(φ(x)))
  totalFunction = [∧]-intro total function


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

module Algebra.Construct.Free.Semilattice.Definition where

open import Prelude

infixr 5 _∷_
data 𝒦 (A : Type a) : Type a where
  []   : 𝒦 A
  _∷_  : A → 𝒦 A → 𝒦 A
  com   : ∀ x y xs → x ∷ y ∷ xs ≡ y ∷ x ∷ xs
  dup   : ∀ x xs → x ∷ x ∷ xs ≡ x ∷ xs
  trunc : isSet (𝒦 A)


--- Sample Sit file

{-# OPTIONS --experimental-irrelevance #-}
{-# OPTIONS --sized-types #-}

open import Base

--; --- Leibniz-equality

Eq : forall (A : Set) (a b : A) -> Set1 --;
Eq = \ A a b -> (P : A -> Set) -> (P a) -> P b

--; --- Reflexivity

refl : forall (A : Set) (a : A) -> Eq A a a --;
refl = \ A a P pa -> pa

--; --- Symmetry

sym : forall (A : Set) (a b : A) -> Eq A a b -> Eq A b a --;
sym = \ A a b eq P pb ->  eq (\ x -> P x -> P a) (\ pa -> pa) pb

--; --- Transitivity

trans : forall (A : Set) (a b c : A) -> Eq A a b -> Eq A b c -> Eq A a c --;
trans = \ A a b c p q P pa -> q P (p P pa)

--; --- Congruence

cong : forall (A B : Set) (f : A -> B) (a a' : A) -> Eq A a a' -> Eq B (f a) (f a') --;
cong = \ A B f a a' eq P pfa -> eq (\ x -> P (f x)) pfa

--; --- Addition

plus : forall .i -> Nat i -> Nat oo -> Nat oo --;
plus = \ i x y ->
  fix (\ i x -> Nat oo)
      (\ _ f -> \
              { (zero _)   -> y
              ; (suc _ x) -> suc oo (f x)
              })
      x

--; --- Unit tests for plus

inc : Nat oo -> Nat oo --;
inc = \ x -> suc oo x  --;

one : Nat oo        --;
one = inc (zero oo) --;

two : Nat oo  --;
two = inc one --;

three : Nat oo  --;
three = inc two --;

four : Nat oo  --;
four = inc three --;

five : Nat oo  --;
five = inc four --;

six : Nat oo  --;
six = inc five --;

plus_one_zero : Eq (Nat oo) (plus oo one (zero oo)) one --;
plus_one_zero = refl (Nat oo) one  --;

plus_one_one : Eq (Nat oo) (plus oo one one) two --;
plus_one_one = refl (Nat oo) two  --;

--; --- Reduction rules for plus

plus_red_zero : forall .i (y : Nat oo) -> Eq (Nat oo) (plus (i + 1) (zero i) y) y  --;
plus_red_zero = \ i y -> refl (Nat oo) y  --;

plus_red_suc : forall .i (x : Nat i) (y : Nat oo) -> Eq (Nat oo) (plus (i + 1) (suc i x) y) (suc oo (plus i x y))  --;
plus_red_suc = \ i x y -> refl (Nat oo) (suc oo (plus i x y))  --;

--; --- Law: x + 0 = x

plus_zero : forall .i (x : Nat i) -> Eq (Nat oo) (plus i x (zero oo)) x  --;
plus_zero = \ i x ->
  fix (\ i x -> Eq (Nat oo) (plus i x (zero oo)) x)
      (\ j f -> \
         { (zero _)  -> refl (Nat oo) (zero oo)
         ; (suc _ y) -> cong (Nat oo) (Nat oo) inc (plus j y (zero oo)) y (f y)
         })
      x

--; --- Law: x + suc y = suc x + y

plus_suc : forall .i (x : Nat i) (y : Nat oo) -> Eq (Nat oo) (plus i x (inc y)) (inc (plus i x y))  --;
plus_suc = \ i x y ->
  fix (\ i x -> Eq (Nat oo) (plus i x (inc y)) (inc (plus i x y)))
      (\ j f -> \
         { (zero _)  -> refl (Nat oo) (inc y)
         ; (suc _ x') -> cong (Nat oo) (Nat oo) inc (plus j x' (inc y)) (inc (plus j x' y)) (f x')
         })
      x

--; --- Another definition of addition

plus' : forall .i -> Nat i -> Nat oo -> Nat oo  --;
plus' = \ i x ->
  fix (\ i x -> Nat oo -> Nat oo)
      (\ _ f -> \
         { (zero _)  -> \ y -> y
         ; (suc _ x) -> \ y -> suc oo (f x y)
         })
      x

--; --- Predecessor

pred  : forall .i -> Nat i -> Nat i  --;
pred = \ i n ->
  fix (\ i _ -> Nat i)
      (\ i _ -> \{ (zero _) -> zero i ; (suc _ y) -> y })
      n

--; --- Subtraction

sub : forall .j -> Nat j -> forall .i -> Nat i -> Nat i  --;
sub = \ j y ->
  fix (\ _ _ -> forall .i -> Nat i -> Nat i)
      (\ _ f -> \
        { (zero _) -> \ i x -> x
        ; (suc _ y) -> \ i x -> f y i (pred i x)
        }) --- pred i (f y i x) })
      y

--; --- Lemma: x - x == 0

sub_diag : forall .i (x : Nat i) -> Eq (Nat oo) (sub i x i x) (zero oo)  --;
sub_diag = \ i x ->
  fix (\ i x -> Eq (Nat oo) (sub i x i x) (zero oo))
      (\ _ f -> \
        { (zero _) -> refl (Nat oo) (zero oo)
        ; (suc _ y) -> f y
        })
      x

--- Large eliminations

--; --- Varying arity

Fun : forall .i (n : Nat i) (A : Set) (B : Set) -> Set --;
Fun = \ i n A B ->
  fix (\ _ _ -> Set)
      (\ _ f -> \
         { (zero _) -> B
         ; (suc _ x) -> A -> f x
         })
      n

--; --- Type of n-ary Sum function

Sum : forall .i (n : Nat i) -> Set  --;
Sum = \ i n -> Nat oo -> Fun i n (Nat oo) (Nat oo)

--; --- n-ary summation function

sum : forall .i (n : Nat i) -> Sum i n --;
sum = \ _ n ->
  fix (\ i n -> Sum i n)
      (\ _ f -> \
        { (zero _) -> \ acc -> acc
        ; (suc _ x) -> \ acc -> \ k -> f x (plus oo k acc)
        })
      n

--; --- Testing sum

sum123 : Eq (Nat oo) (sum oo three (zero oo) one two three) six --;
sum123 = refl (Nat oo) six


module Formalization.LambdaCalculus.Semantics where

open import Data
open import Formalization.LambdaCalculus
open import Syntax.Number
open import Type

-- A value in the language of lambda calculus is a irreducible term by a standard reduction definition.
-- It can also be defined as terms that are lambda abstractions because an application of a lambda is supposed to be β-reducible.
data Value : Expression → Type{0} where
  instance abs : ∀{body : Term(1)} → Value(Abstract body)


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

open import lib.Basics
open import lib.types.Group
open import lib.types.CommutingSquare
open import lib.groups.Homomorphism
open import lib.groups.Isomorphism

module lib.groups.CommutingSquare where

-- A new type to keep the parameters.
record CommSquareᴳ {i₀ i₁ j₀ j₁}
  {G₀ : Group i₀} {G₁ : Group i₁} {H₀ : Group j₀} {H₁ : Group j₁}
  (φ₀ : G₀ →ᴳ H₀) (φ₁ : G₁ →ᴳ H₁) (ξG : G₀ →ᴳ G₁) (ξH : H₀ →ᴳ H₁)
  : Type (lmax (lmax i₀ i₁) (lmax j₀ j₁)) where
  constructor comm-sqrᴳ
  field
    commutesᴳ : ∀ g₀ → GroupHom.f (ξH ∘ᴳ φ₀) g₀ == GroupHom.f (φ₁ ∘ᴳ ξG) g₀

infix 0 _□$ᴳ_
_□$ᴳ_ = CommSquareᴳ.commutesᴳ

CommSquareᴳ-∘v : ∀ {i₀ i₁ i₂ j₀ j₁ j₂}
  {G₀ : Group i₀} {G₁ : Group i₁} {G₂ : Group i₂}
  {H₀ : Group j₀} {H₁ : Group j₁} {H₂ : Group j₂}
  {φ : G₀ →ᴳ H₀} {ψ : G₁ →ᴳ H₁} {χ : G₂ →ᴳ H₂}
  {ξG : G₀ →ᴳ G₁} {ξH : H₀ →ᴳ H₁}
  {μA : G₁ →ᴳ G₂} {μB : H₁ →ᴳ H₂}
  → CommSquareᴳ ψ χ μA μB
  → CommSquareᴳ φ ψ ξG ξH
  → CommSquareᴳ φ χ (μA ∘ᴳ ξG) (μB ∘ᴳ ξH)
CommSquareᴳ-∘v {ξG = ξG} {μB = μB} (comm-sqrᴳ □₁₂) (comm-sqrᴳ □₀₁) =
  comm-sqrᴳ λ g₀ → ap (GroupHom.f μB) (□₀₁ g₀) ∙ □₁₂ (GroupHom.f ξG g₀)

CommSquareᴳ-inverse-v : ∀ {i₀ i₁ j₀ j₁}
  {G₀ : Group i₀} {G₁ : Group i₁} {H₀ : Group j₀} {H₁ : Group j₁}
  {φ₀ : G₀ →ᴳ H₀} {φ₁ : G₁ →ᴳ H₁} {ξG : G₀ →ᴳ G₁} {ξH : H₀ →ᴳ H₁}
  → CommSquareᴳ φ₀ φ₁ ξG ξH
  → (ξG-ise : is-equiv (GroupHom.f ξG)) (ξH-ise : is-equiv (GroupHom.f ξH))
  → CommSquareᴳ φ₁ φ₀ (GroupIso.g-hom (ξG , ξG-ise)) (GroupIso.g-hom (ξH , ξH-ise))
CommSquareᴳ-inverse-v (comm-sqrᴳ □) ξG-ise ξH-ise =
  comm-sqrᴳ (commutes (CommSquare-inverse-v (comm-sqr □) ξG-ise ξH-ise))


------------------------------------------------------------------------
-- The Agda standard library
--
-- An inductive definition of the sublist relation with respect to a
-- setoid which is decidable. This is a generalisation of what is
-- commonly known as Order Preserving Embeddings (OPE).
------------------------------------------------------------------------

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

open import Relation.Binary

module Data.List.Relation.Binary.Sublist.DecSetoid
  {c ℓ} (S : DecSetoid c ℓ) where

import Data.List.Relation.Binary.Equality.DecSetoid as DecSetoidEquality
import Data.List.Relation.Binary.Sublist.Setoid as SetoidSublist
import Data.List.Relation.Binary.Sublist.Heterogeneous.Properties
  as HeterogeneousProperties
open import Level using (_⊔_)

open DecSetoid S
open DecSetoidEquality S

------------------------------------------------------------------------
-- Re-export core definitions

open SetoidSublist setoid public

------------------------------------------------------------------------
-- Additional relational properties

_⊆?_ : Decidable _⊆_
_⊆?_ = HeterogeneousProperties.sublist? _≟_

⊆-isDecPartialOrder : IsDecPartialOrder _≋_ _⊆_
⊆-isDecPartialOrder = record
  { isPartialOrder = ⊆-isPartialOrder
  ; _≟_            = _≋?_
  ; _≤?_           = _⊆?_
  }

⊆-decPoset : DecPoset c (c ⊔ ℓ) (c ⊔ ℓ)
⊆-decPoset = record
  { isDecPartialOrder = ⊆-isDecPartialOrder
  }


open import Logic
open import Structure.Setoid
open import Structure.Operator.Ring
open import Structure.OrderedField
open import Type

module Structure.OrderedField.AbsoluteValue
  {ℓ ℓₗ ℓₑ}
  {F : Type{ℓ}}
  ⦃ equiv : Equiv{ℓₑ}(F) ⦄
  (_+_ _⋅_ : F → F → F)
  (_≤_ : F → F → Stmt{ℓₗ})
  ⦃ ring : Ring(_+_)(_⋅_) ⦄ -- TODO: The definition does not require a ring, only some kind of total order compatible with an operation with an identity and an inverse
  -- ⦃ identity : Identity(_+_) ⦄
  -- ⦃ inverseFunction : InverseFunction(_+_)(−_) ⦄
  ⦃ ordered : Ordered(_+_)(_⋅_)(_≤_) ⦄
  where

open Ring(ring)
open Ordered(ordered)

import      Lvl
open import Data.Boolean
open import Data.Boolean.Proofs
import      Data.Either as Either
open import Functional
open import Logic.IntroInstances
open import Logic.Propositional
open import Structure.Function.Domain
open import Structure.Function.Ordering
open import Structure.Function
open import Structure.Operator
open import Structure.Operator.Proofs
open import Structure.Operator.Properties
open import Structure.Operator.Ring.Proofs
open import Structure.Relator.Properties
open import Syntax.Implication
open import Syntax.Transitivity

‖_‖ : F → F
‖ x ‖ = if Either.isRight(converseTotal(_≤_){𝟎}{x}) then (− x) else x

instance
  abs-function : Function(‖_‖)
  Function.congruence abs-function {x}{y} xy with converseTotal(_≤_){𝟎}{x} | converseTotal(_≤_){𝟎}{y}
  ... | Either.Left  p | Either.Left  q = xy
  ... | Either.Left  p | Either.Right q = antisymmetry(_≤_)(_≡_) (sub₂(_≡_)(_≤_) xy 🝖 q) p 🝖 antisymmetry(_≤_)(_≡_) ([↔]-to-[→] [≤]-flip-negative q) ([↔]-to-[→] [≤]-flip-positive(p 🝖 sub₂(_≡_)(_≤_) xy))
  ... | Either.Right p | Either.Left  q = antisymmetry(_≤_)(_≡_) ([↔]-to-[→] [≤]-flip-positive(q 🝖 sub₂(_≡_)(_≤_) (symmetry(_≡_) xy))) ([↔]-to-[→] [≤]-flip-negative p) 🝖 antisymmetry(_≤_)(_≡_) q (sub₂(_≡_)(_≤_) (symmetry(_≡_) xy) 🝖 p)
  ... | Either.Right p | Either.Right q = congruence₁(−_) xy

abs-positive : ∀{x} → (‖ x ‖ ≥ 𝟎)
abs-positive{x} = if-either-bool-intro {P = _≥ 𝟎} {x = x} {y = − x} id ([↔]-to-[→] [≤]-flip-negative) (converseTotal(_≤_){𝟎}{x})

abs-values : ∀{x} → (‖ x ‖ ≡ x) ∨ (‖ x ‖ ≡ − x)
abs-values{x} with converseTotal(_≤_){𝟎}{x}
... | [∨]-introₗ _ = [∨]-introₗ (reflexivity(_≡_))
... | [∨]-introᵣ _ = [∨]-introᵣ (reflexivity(_≡_))

abs-of-zero : (‖ 𝟎 ‖ ≡ 𝟎)
abs-of-zero with abs-values{𝟎}
... | Either.Left  p = p
... | Either.Right p = p 🝖 [−]-of-𝟎

abs-when-zero : ∀{x} → (‖ x ‖ ≡ 𝟎) ↔ (x ≡ 𝟎)
abs-when-zero{x} = [↔]-intro (p ↦ congruence₁(‖_‖) p 🝖 abs-of-zero) (p ↦ symmetry(_≡_) ([∨]-elim id (q ↦ p 🝖 symmetry(_≡_) ([↔]-to-[→] [−]-is-𝟎 (symmetry(_≡_) q 🝖 p))) abs-values) 🝖 p)

abs-of-negation : ∀{x} → (‖ − x ‖ ≡ ‖ x ‖)
abs-of-negation{x} with converseTotal(_≤_){𝟎}{x} | converseTotal(_≤_){𝟎}{− x}
... | [∨]-introₗ _   | [∨]-introᵣ _   = involution(−_)
... | [∨]-introᵣ _   | [∨]-introₗ _   = reflexivity(_≡_)
... | [∨]-introₗ zx  | [∨]-introₗ znx = antisymmetry(_≤_)(_≡_) (nxz 🝖 zx) (xz 🝖 znx) where
  nxz : (− x) ≤ 𝟎
  nxz = [↔]-to-[←] [≤]-flip-negative (zx 🝖 (sub₂(_≡_)(_≤_) $ symmetry(_≡_) $ involution(−_)))

  xz : x ≤ 𝟎
  xz = [↔]-to-[←] [≤]-flip-negative znx
... | [∨]-introᵣ xz | [∨]-introᵣ nxz  = antisymmetry(_≤_)(_≡_) (involution(−_) 🝖-subₗ (xz 🝖 znx)) (nxz 🝖 zx 🝖-subᵣ symmetry(_≡_) (involution(−_))) where
  znx : 𝟎 ≤ (− x)
  znx = [↔]-to-[→] [≤]-flip-negative xz

  zx : 𝟎 ≤ x
  zx = [↔]-to-[→] [≤]-flip-negative nxz 🝖 (sub₂(_≡_)(_≤_) $ involution(−_))

instance
  abs-idempotent : Idempotent(‖_‖)
  Idempotent.proof abs-idempotent {x} with abs-values{x}
  ... | Either.Left  p = congruence₁(‖_‖) p
  ... | Either.Right p = congruence₁(‖_‖) p 🝖 abs-of-negation

abs-order : ∀{x} → ((− ‖ x ‖) ≤ ‖ x ‖)
abs-order{x} = [↔]-to-[→] [≤]-flip-positive(abs-positive{x}) 🝖 abs-positive{x}

abs-order-pos : ∀{x} → (x ≤ ‖ x ‖)
abs-order-pos {x} with converseTotal(_≤_){𝟎}{x}
... | Either.Left  p = reflexivity(_≤_)
... | Either.Right p = p 🝖 [↔]-to-[→] [≤]-flip-negative p

abs-order-neg : ∀{x} → ((− x) ≤ ‖ x ‖)
abs-order-neg {x} with converseTotal(_≤_){𝟎}{x}
... | Either.Left  p = [↔]-to-[→] [≤]-flip-positive p 🝖 p
... | Either.Right p = reflexivity(_≤_)

abs-of-positive : ∀{x} → (𝟎 ≤ x) → (‖ x ‖ ≡ x)
abs-of-positive {x} ox = antisymmetry(_≤_)(_≡_) p abs-order-pos where
  p : ‖ x ‖ ≤ x
  p with converseTotal(_≤_){𝟎}{x}
  ... | Either.Left  _ = reflexivity(_≤_)
  ... | Either.Right _ = [↔]-to-[→] [≤]-flip-positive ox 🝖 ox
  -- Alternative 1:
  -- with abs-values{x}
  -- ... | Either.Left  p = p
  -- ... | Either.Right p = [↔]-to-[←] abs-when-zero xzero 🝖 symmetry(_≡_) xzero where
  --   xzero : (x ≡ 𝟎)
  --   xzero = antisymmetry(_≤_)(_≡_) ([↔]-to-[←] [≤]-flip-negative (abs-positive{x} 🝖 sub₂(_≡_)(_≤_) p)) ox
  -- Alternative 2: antisymmetry(_≤_)(_≡_) (sub₂(_≡_)(_≤_) p 🝖 [≤]-flip-positive ox 🝖 ox) (sub₂(_≡_)(_≤_) (symmetry(_≡_) (congruence₁(−_) p 🝖 [−−]-elim)) 🝖 abs-order{x})

abs-of-negative : ∀{x} → (x ≤ 𝟎) → (‖ x ‖ ≡ − x)
abs-of-negative {x} xo = antisymmetry(_≤_)(_≡_) p abs-order-neg where
  p : ‖ x ‖ ≤ (− x)
  p with converseTotal(_≤_){𝟎}{x}
  ... | Either.Left  _ = xo 🝖 [↔]-to-[→] [≤]-flip-negative xo
  ... | Either.Right _ = reflexivity(_≤_)
  -- Alternative 1:
  -- with abs-values{x}
  -- ... | Either.Right p = p
  -- ... | Either.Left  p = symmetry(_≡_) abs-of-negation 🝖 [↔]-to-[←] abs-when-zero xzero 🝖 symmetry(_≡_) xzero where
  --   xzero : (− x ≡ 𝟎)
  --   xzero = antisymmetry(_≤_)(_≡_) ([↔]-to-[←] [≤]-flip-negative (abs-positive{x} 🝖 sub₂(_≡_)(_≤_) p 🝖 sub₂(_≡_)(_≤_) (symmetry(_≡_) [−−]-elim))) ([↔]-to-[→] [≤]-flip-negative xo)

abs-triangle-inequality : ∀{x y} → (‖ x + y ‖ ≤ (‖ x ‖ + ‖ y ‖))
abs-triangle-inequality {x}{y} with converseTotal(_≤_){𝟎}{x + y}
... | Either.Left  p =
  (x + y)         🝖[ _≤_ ]-[ [≤][+]-preserve abs-order-pos abs-order-pos ]
  (‖ x ‖ + ‖ y ‖) 🝖-end
... | Either.Right p =
  −(x + y)        🝖[ _≡_ ]-[ [+]-negation-distribution ]-sub
  (− x) + (− y)   🝖[ _≤_ ]-[ [≤][+]-preserve abs-order-neg abs-order-neg ]
  (‖ x ‖ + ‖ y ‖) 🝖-end

-- TODO: True in rings? Only division rings? Maybe ≤ instead of ≡ is better because of zero divisors
-- abs-scaling : ∀{a x} → (‖ a ⋅ x ‖ ≡ (‖ a ‖ ⋅ ‖ x ‖))
-- abs-scaling{a}{x} with converseTotal(_≤_){𝟎}{a ⋅ x} | converseTotal(_≤_){𝟎}{a} | converseTotal(_≤_){𝟎}{x}
{-... | Either.Left  p =
  (a ⋅ x)         🝖[ _≡_ ]-[ {!!} ]
  (‖ a ‖ ⋅ ‖ x ‖) 🝖-end
... | Either.Right p = {!!}
-}

-- Distance
_𝄩_ : F → F → F
x 𝄩 y = ‖ x − y ‖

open import Structure.Function.Proofs
open import Structure.Operator.Proofs.Util

instance
  [𝄩]-binaryOperator : BinaryOperator(_𝄩_)
  [𝄩]-binaryOperator = [∘₂]-function {f = ‖_‖} ⦃ oper = [−]-binaryOperator ⦄

instance
  [𝄩]-commutativity : Commutativity(_𝄩_)
  Commutativity.proof [𝄩]-commutativity {x}{y} =
    ‖ x − y ‖    🝖-[ abs-of-negation ]-sym
    ‖ −(x − y) ‖ 🝖-[ congruence₁(‖_‖) [−]-negation-distribution ]
    ‖ y − x ‖    🝖-end

[𝄩]-triangle-inequality : ∀{x y z} → ((x 𝄩 z) ≤ ((x 𝄩 y) + (y 𝄩 z)))
[𝄩]-triangle-inequality {x}{y}{z} =
  x 𝄩 z                     🝖[ _≤_ ]-[]
  ‖ x − z ‖                 🝖[ _≡_ ]-[ congruence₁(‖_‖) (congruence₂ₗ(_−_) ⦃ [−]-binaryOperator ⦄ (z) (symmetry(_≡_) (identityᵣ(_+_)(𝟎)))) ]-sub
  ‖ (x + 𝟎) − z ‖           🝖[ _≡_ ]-[ congruence₁(‖_‖) (congruence₂ₗ(_−_) ⦃ [−]-binaryOperator ⦄ (z) (congruence₂ᵣ(_+_)(x) (symmetry(_≡_) (inverseFunctionₗ(_+_)(−_))))) ]-sub
  ‖ (x + ((− y) + y)) − z ‖ 🝖[ _≡_ ]-[ congruence₁(‖_‖) ((One.associate4-213-222 {_▫_ = _+_} {a = x}{− y}{y}{− z})) ]-sub
  ‖ (x + (− y)) + (y − z) ‖ 🝖[ _≤_ ]-[]
  ‖ (x − y) + (y − z) ‖     🝖[ _≤_ ]-[ abs-triangle-inequality ]
  (‖ x − y ‖) + (‖ y − z ‖) 🝖[ _≤_ ]-[]
  (x 𝄩 y) + (y 𝄩 z)          🝖-end

[𝄩]-self : ∀{x y} → (x 𝄩 y ≡ 𝟎) ↔ (x ≡ y)
[𝄩]-self {x}{y} = [↔]-intro l r where
  l =
    (x ≡ y)            ⇒-[ symmetry(_≡_) ∘ congruence₂ᵣ(_𝄩_)(x) ]
    (x 𝄩 y ≡ x 𝄩 x)     ⇒-[]
    (_     ≡ ‖ x − x ‖) ⇒-[ _🝖 congruence₁(‖_‖) (inverseFunctionᵣ(_+_)(−_)) ]
    (_     ≡ ‖ 𝟎 ‖)     ⇒-[ _🝖 abs-of-zero ]
    (_     ≡ 𝟎)         ⇒-end
  r =
    (x 𝄩 y ≡ 𝟎) ⇒-[ [↔]-to-[→] (abs-when-zero{x − y}) ]
    (x − y ≡ 𝟎) ⇒-[ [↔]-to-[→] [−]-difference-is-𝟎 ]
    (x ≡ y)     ⇒-end


------------------------------------------------------------------------
-- The Agda standard library
--
-- This module constructs the zero R-module, and similar for weaker
-- module-like structures.
-- The intended universal property is that, given any R-module M, there
-- is a unique map into and a unique map out of the zero R-module
-- from/to M.
------------------------------------------------------------------------

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

module Algebra.Module.Construct.Zero where

open import Algebra.Bundles
open import Algebra.Module.Bundles
open import Data.Unit
open import Level

private
  variable
    r s ℓr ℓs : Level

leftSemimodule : {R : Semiring r ℓr} → LeftSemimodule R 0ℓ 0ℓ
leftSemimodule = record
  { Carrierᴹ = ⊤
  ; _≈ᴹ_ = λ _ _ → ⊤
  }

rightSemimodule : {S : Semiring s ℓs} → RightSemimodule S 0ℓ 0ℓ
rightSemimodule = record
  { Carrierᴹ = ⊤
  ; _≈ᴹ_ = λ _ _ → ⊤
  }

bisemimodule :
  {R : Semiring r ℓr} {S : Semiring s ℓs} → Bisemimodule R S 0ℓ 0ℓ
bisemimodule = record
  { Carrierᴹ = ⊤
  ; _≈ᴹ_ = λ _ _ → ⊤
  }

semimodule : {R : CommutativeSemiring r ℓr} → Semimodule R 0ℓ 0ℓ
semimodule = record
  { Carrierᴹ = ⊤
  ; _≈ᴹ_ = λ _ _ → ⊤
  }

leftModule : {R : Ring r ℓr} → LeftModule R 0ℓ 0ℓ
leftModule = record
  { Carrierᴹ = ⊤
  ; _≈ᴹ_ = λ _ _ → ⊤
  }

rightModule : {S : Ring s ℓs} → RightModule S 0ℓ 0ℓ
rightModule = record
  { Carrierᴹ = ⊤
  ; _≈ᴹ_ = λ _ _ → ⊤
  }

bimodule : {R : Ring r ℓr} {S : Ring s ℓs} → Bimodule R S 0ℓ 0ℓ
bimodule = record
  { Carrierᴹ = ⊤
  ; _≈ᴹ_ = λ _ _ → ⊤
  }

⟨module⟩ : {R : CommutativeRing r ℓr} → Module R 0ℓ 0ℓ
⟨module⟩ = record
  { Carrierᴹ = ⊤
  ; _≈ᴹ_ = λ _ _ → ⊤
  }


------------------------------------------------------------------------------
-- Mendelson's substitution
------------------------------------------------------------------------------

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

module FOT.FOL.MendelsonSubstATP where

-- First-order logic with equality.
open import Common.FOL.FOL-Eq public

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

-- Mendelson's [2015] substitution (p. 93).

--   (A7) x = y ⇒ (A(x,x) ⇒ B(x,y)) (substitutivity of equality)

postulate mendelsonSubst : (A : D → D → Set) → ∀ {x y} → x ≡ y → A x x → A x y

{-# ATP prove mendelsonSubst #-}

------------------------------------------------------------------------------
-- References

-- Mendelson, Elliott (2015). Introduction to Mathematical Logic. CRC
-- Press, 6th edition.


------------------------------------------------------------------------
-- The partiality monad
------------------------------------------------------------------------

module Category.Monad.Partiality where

open import Coinduction
open import Category.Monad
open import Data.Nat
open import Data.Bool

-- The partiality monad.

data _⊥ (A : Set) : Set where
  now   : (x : A) → A ⊥
  later : (x : ∞ (A ⊥)) → A ⊥

monad : RawMonad _⊥
monad = record
  { return = now
  ; _>>=_  = _>>=_
  }
  where
  _>>=_ : ∀ {A B} → A ⊥ → (A → B ⊥) → B ⊥
  now x   >>= f = f x
  later x >>= f = later (♯ ♭ x >>= f)

-- run x for n steps peels off at most n "later" constructors from x.

run_for_steps : ∀ {A} → A ⊥ → ℕ → A ⊥
run now   x for n     steps = now x
run later x for zero  steps = later x
run later x for suc n steps = run ♭ x for n steps

-- Is the computation done?

isNow : ∀ {A} → A ⊥ → Bool
isNow (now x)   = true
isNow (later x) = false

------------------------------------------------------------------------
-- Productivity checker workaround

-- The monad can be awkward to use, due to the limitations of guarded
-- coinduction. The following code provides a (limited) workaround.

infixl 1 _>>=_

data _⊥-prog : Set → Set₁ where
  now   : ∀ {A} (x : A) → A ⊥-prog
  later : ∀ {A} (x : ∞₁ (A ⊥-prog)) → A ⊥-prog
  _>>=_ : ∀ {A B} (x : A ⊥-prog) (f : A → B ⊥-prog) → B ⊥-prog

data _⊥-whnf : Set → Set₁ where
  now   : ∀ {A} (x : A) → A ⊥-whnf
  later : ∀ {A} (x : A ⊥-prog) → A ⊥-whnf

whnf : ∀ {A} → A ⊥-prog → A ⊥-whnf
whnf (now   x) = now x
whnf (later x) = later (♭₁ x)
whnf (x >>= f) with whnf x
whnf (x >>= f) | now   x′ = whnf (f x′)
whnf (x >>= f) | later x′ = later (x′ >>= f)

mutual

  value : ∀ {A} → A ⊥-whnf → A ⊥
  value (now   x) = now x
  value (later x) = later (♯ run x)

  run : ∀ {A} → A ⊥-prog → A ⊥
  run x = value (whnf x)

------------------------------------------------------------------------
-- Examples

module Examples where

  open import Relation.Nullary

  -- McCarthy's f91:

  f91′ : ℕ → ℕ ⊥-prog
  f91′ n with n ≤? 100
  ... | yes _ = later (♯₁ (f91′ (11 + n) >>= f91′))
  ... | no  _ = now (n ∸ 10)

  f91 : ℕ → ℕ ⊥
  f91 n = run (f91′ n)


{-# OPTIONS --cubical-compatible #-}
module Common.Nat where

open import Agda.Builtin.Nat public
  using    ( Nat; zero; suc; _+_; _*_ )
  renaming ( _-_ to _∸_ )

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


------------------------------------------------------------------------------
-- Agda-Prop Library.
-- Theorems of ¬ connective.
------------------------------------------------------------------------------

open import Data.Nat using ( ℕ )

module Data.PropFormula.Theorems.Negation ( n : ℕ ) where

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

open import Data.PropFormula.Properties n using ( ¬-injective ; subst )
open import Data.PropFormula.Syntax n
open import Data.PropFormula.Theorems.Classical n
open import Data.PropFormula.Theorems.Implication n using ( subst⊢⊃₁ )

open import Function using ( _$_ ; _∘_ )
open import Relation.Binary.PropositionalEquality using ( _≡_ ; refl ; sym )

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

-- Theorem.
¬-equiv₁
  : ∀ {Γ} {φ}
  → Γ ⊢ ¬ φ
  → Γ ⊢ φ ⊃ ⊥
¬-to-⊃⊥ = ¬-equiv₁

-- Proof.
¬-equiv₁ {φ = φ} Γ⊢¬φ =
  ⊃-intro
    (¬-elim
      (weaken φ Γ⊢¬φ)
      (assume φ))
-------------------------------------------------------------------------- ∎

-- Theorem.
¬-equiv₂
  : ∀ {Γ} {φ}
  → Γ ⊢ φ ⊃ ⊥
  → Γ ⊢ ¬ φ
⊃⊥-to-¬ = ¬-equiv₂

-- Proof.
¬-equiv₂ {φ = φ} Γ⊢φ⊃⊥ =
  ¬-intro
    (⊃-elim
      (weaken φ Γ⊢φ⊃⊥)
      (assume φ))
-------------------------------------------------------------------------- ∎

-- Theorem.
¬¬-equiv₁
  : ∀ {Γ} {φ}
  → Γ ⊢ ¬ (¬ φ)
  → Γ ⊢ φ

-- Proof.
¬¬-equiv₁ {Γ}{φ} Γ⊢¬¬φ =
  (⊃-elim
    (⊃-intro $ RAA
      (¬-elim
        (weaken (¬ φ) $
          assume $ ¬ (¬ φ))
        (assume {Γ = Γ , ¬ (¬ φ)} $ ¬ φ)))
    Γ⊢¬¬φ)
-------------------------------------------------------------------------- ∎

-- Theorem.
¬¬-equiv₂
  : ∀ {Γ} {φ}
  → Γ ⊢ φ
  → Γ ⊢ ¬ (¬ φ)

-- Proof.
¬¬-equiv₂ {Γ}{φ} Γ⊢φ =
  ⊃⊥-to-¬
    (⊃-intro
      (¬-elim
        (assume (¬ φ))
        (weaken (¬ φ) Γ⊢φ)))
-------------------------------------------------------------------------- ∎

-- Theorem.
¬∨-to-⊃
  : ∀ {Γ} {φ ψ}
  → Γ ⊢ ¬ φ ∨ ψ
  → Γ ⊢ φ ⊃ ψ

-- Proof.
¬∨-to-⊃ {Γ}{φ}{ψ} =
  ⊃-elim $
    ⊃-intro $
      ∨-elim
        (⊃-intro $
          ⊥-elim {Γ = Γ , ¬ φ , φ} ψ
          (¬-elim
            (weaken φ $
              assume (¬ φ))
            (assume {Γ = Γ , ¬ φ} φ)))
        (⊃-intro $
          weaken φ $
            assume ψ)
-------------------------------------------------------------------------- ∎

-- Theorem.
¬⊤-to-⊥
  : ∀ {Γ}
  → Γ ⊢ ¬ ⊤
  → Γ ⊢ ⊥

-- Proof.
¬⊤-to-⊥ Γ⊢¬⊤ = ¬-elim Γ⊢¬⊤ ⊤-intro
-------------------------------------------------------------------------- ∎

-- Theorem.
⊤-to-¬⊥
  : ∀ {Γ}
  → Γ ⊢ ⊤
  → Γ ⊢ ¬ ⊥

-- Proof.
⊤-to-¬⊥ = λ _ → ¬-intro (assume ⊥)
-------------------------------------------------------------------------- ∎

-- Theorem.
¬⊥-to-⊤
  : ∀ {Γ}
  → Γ ⊢ ¬ ⊥
  → Γ ⊢ ⊤

-- Proof.
¬⊥-to-⊤ Γ⊢¬⊥ = ⊤-intro
-------------------------------------------------------------------------- ∎

-- Theorem.
⊥-to-¬⊤
  : ∀ {Γ}
  → Γ ⊢ ⊥
  → Γ ⊢ ¬ ⊤

-- Proof.
⊥-to-¬⊤ = ¬-intro ∘ weaken ⊤
-------------------------------------------------------------------------- ∎

-- Theorem.
¬-inside
  : ∀ {Γ} {φ ψ}
  → φ ≡ ψ
  → Γ ⊢ ¬ φ
  → Γ ⊢ ¬ ψ
≡-¬-to-¬ = ¬-inside

-- Proof.
¬-inside {φ = φ}{ψ} φ≡ψ Γ⊢¬φ =
  ¬-equiv₂
    (⊃-intro
      (⊃-elim
        (¬-equiv₁
          (weaken ψ Γ⊢¬φ))
        (subst
          (sym φ≡ψ)
          (assume ψ))))
-------------------------------------------------------------------------- ∎

-- Theorem.
subst⊢¬
  : ∀ {Γ} {φ γ}
  → Γ ⊢ γ ⊃ φ
  → Γ ⊢ ¬ φ
  → Γ ⊢ ¬ γ

-- Proof.
subst⊢¬ Γ⊢γ⊃φ Γ⊢¬φ = ⊃⊥-to-¬ (subst⊢⊃₁ Γ⊢γ⊃φ (¬-to-⊃⊥ Γ⊢¬φ))
-------------------------------------------------------------------------- ∎

-- Theorem.
¬⇔-to-⊃¬∧⊃¬
  : ∀ {Γ} {φ₁ φ₂}
  → Γ ⊢ ¬ (φ₁ ⇔ φ₂)
  → Γ ⊢ (φ₁ ⊃ ¬ φ₂) ∧ (φ₂ ⊃ ¬ φ₁)

-- Proof.
¬⇔-to-⊃¬∧⊃¬ {Γ}{φ₁}{φ₂} thm =
  ∧-intro
    (⊃-intro
      (¬-intro
        (¬-elim
          (weaken φ₂ $ weaken φ₁ thm)
          (⇔-intro
            (weaken φ₁ $ assume {Γ = Γ , φ₁} φ₂)
            (weaken φ₂ $ weaken φ₂ $ assume φ₁)))))
    (⊃-intro
      (¬-intro
        (¬-elim (weaken φ₁ $ weaken φ₂ thm)
          (⇔-intro
            (weaken φ₁ $ weaken φ₁ $ assume φ₂)
            (weaken φ₂ $ assume {Γ = Γ , φ₂} φ₁)))))
-------------------------------------------------------------------------- ∎


{-# OPTIONS --without-K #-}
open import HoTT.Base

module HoTT.Transport.Coproduct where

private
  variable
    i : Level
    X : 𝒰 i
    A B : X → 𝒰 i
    x₁ x₂ : X

transport-+ : (p : x₁ == x₂) →
              transport (λ x → A x + B x) p ~
              +-rec (inl ∘ transport A p) (inr ∘ transport B p)
transport-+ refl (inl a) = refl
transport-+ refl (inr b) = refl


module Logic.DiagonalProof {ℓ₁} {ℓ₂} where

import      Lvl
open import Logic.Propositional{ℓ₁ Lvl.⊔ ℓ₂}
open import Logic.Predicate{ℓ₁}{ℓ₂}
open import Functional
open import Relator.Equals{ℓ₁}{ℓ₂}
open import Relator.Equals.Proofs{ℓ₁}{ℓ₂}
open import Type{ℓ₂}

diagonal-proof : ∀{T₁ T₂ : Type}(diff-oper : T₂ → T₂) → (∀{x} → (x ≢ diff-oper(x))) → (ff : T₁ → T₁ → T₂) → ∃{T₁ → T₂}(f ↦ (∀{a : T₁} → ¬(ff(a)(a) ≡ f(a))))
diagonal-proof(diff-oper)(diff-proof)(ff) = [∃]-intro (a ↦ diff-oper(ff(a)(a))) ⦃ \{a} → diff-proof{ff(a)(a)} ⦄


module Type.Dependent.Functions where

import      Lvl
open import Functional.Dependent
open import Type
open import Type.Dependent
open import Syntax.Function

module _ {ℓ₁ ℓ₂ ℓ₃}
         {A : Type{ℓ₁}}
         {B : A → Type{ℓ₂}}
         {C : ∀{x} → B(x) → Type{ℓ₃}}
         where
  _[Π]-∘_ : (∀{x} → Π(B(x))(C)) → (g : Π(A)(B)) → Π(A)(\x → C(Π.apply g x))
  Π.apply (f [Π]-∘ g) x = Π.apply f (Π.apply g x)

  depCurry : (Π(Σ A B) (C ∘ Σ.right)) → (Π A (a ↦ (Π(B(a)) C)))
  Π.apply (Π.apply (depCurry f) a) b = Π.apply f (intro a b)

  depUncurry : (Π A (a ↦ Π(B(a)) C)) → (Π(Σ A B) (C ∘ Σ.right))
  Π.apply (depUncurry f) (intro a b) = Π.apply(Π.apply f a) b

module _ {ℓ₁ ℓ₂ ℓ₃ ℓ₄}
         {A₁ : Type{ℓ₁}}
         {B₁ : A₁ → Type{ℓ₂}}
         {A₂ : Type{ℓ₃}}
         {B₂ : A₂ → Type{ℓ₄}}
         where
  [Σ]-apply : (x : Σ(A₁)(B₁)) → (l : A₁ → A₂) → (r : B₁(Σ.left x) → B₂(l(Σ.left x))) → Σ(A₂)(B₂)
  [Σ]-apply x l r = intro(l(Σ.left x))(r(Σ.right x))

  [ℰ]-apply : (x : Σ(A₁)(B₁)) → {l : A₁ → A₂} → (r : B₁(Σ.left x) → B₂(l(Σ.left x))) → Σ(A₂)(B₂)
  [ℰ]-apply x {l} r = [Σ]-apply x l r

  [Σ]-map : (l : A₁ → A₂) → (∀{a} → B₁(a) → B₂(l(a))) → (Σ(A₁)(B₁) → Σ(A₂)(B₂))
  [Σ]-map l r (intro left right) = intro (l left) (r right)

  [ℰ]-map : ∀{l : A₁ → A₂} → (∀{a} → B₁(a) → B₂(l(a))) → (Σ(A₁)(B₁) → Σ(A₂)(B₂))
  [ℰ]-map {l} = [Σ]-map l

module _ {ℓ₁ ℓ₂ ℓ₃}
         {A : Type{ℓ₁}}
         {B₁ : A → Type{ℓ₂}}
         {B₂ : A → Type{ℓ₃}}
         where
  [Σ]-applyᵣ : (x : Σ(A)(B₁)) → (r : B₁(Σ.left x) → B₂(Σ.left x)) → Σ(A)(B₂)
  [Σ]-applyᵣ x r = intro(Σ.left x)(r(Σ.right x))

module _ {ℓ₁ ℓ₂ ℓ₃ ℓ₄ ℓ₅ ℓ₆}
         {A₁ : Type{ℓ₁}}
         {B₁ : A₁ → Type{ℓ₂}}
         {A₂ : Type{ℓ₃}}
         {B₂ : A₂ → Type{ℓ₄}}
         {A₃ : Type{ℓ₅}}
         {B₃ : A₃ → Type{ℓ₆}}
         where
  [Σ]-apply₂ : (x : Σ(A₁)(B₁)) → (y : Σ(A₂)(B₂)) → (l : A₁ → A₂ → A₃) → (r : B₁(Σ.left x) → B₂(Σ.left y) → B₃(l(Σ.left x)(Σ.left y))) → Σ(A₃)(B₃)
  [Σ]-apply₂ x y l r = intro(l(Σ.left x)(Σ.left y))(r(Σ.right x)(Σ.right y))

  [ℰ]-apply₂ : (x : Σ(A₁)(B₁)) → (y : Σ(A₂)(B₂)) → {l : A₁ → A₂ → A₃} → (r : B₁(Σ.left x) → B₂(Σ.left y) → B₃(l(Σ.left x)(Σ.left y))) → Σ(A₃)(B₃)
  [ℰ]-apply₂ x y {l} r = [Σ]-apply₂ x y l r

  [Σ]-map₂ : (l : A₁ → A₂ → A₃) → (∀{a₁}{a₂} → B₁(a₁) → B₂(a₂) → B₃(l a₁ a₂)) → (Σ(A₁)(B₁) → Σ(A₂)(B₂) → Σ(A₃)(B₃))
  [Σ]-map₂ l r (intro left₁ right₁) (intro left₂ right₂) = intro (l left₁ left₂) (r right₁ right₂)

  [ℰ]-map₂ : ∀{l : A₁ → A₂ → A₃} → (∀{a₁}{a₂} → B₁(a₁) → B₂(a₂) → B₃(l a₁ a₂)) → (Σ(A₁)(B₁) → Σ(A₂)(B₂) → Σ(A₃)(B₃))
  [ℰ]-map₂ {l} = [Σ]-map₂ l


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

module Data.Binary.Increment.Strict where

open import Prelude
open import Strict
open import Data.Binary.Definition
open import Data.Bits.Strict
open import Data.Binary.Increment

inc′ : 𝔹 → 𝔹
inc′ 0ᵇ      = 1ᵇ 0ᵇ
inc′ (1ᵇ xs) = 2ᵇ xs
inc′ (2ᵇ xs) = 0∷! inc′ xs

inc′≡inc : ∀ xs → inc′ xs ≡ inc xs
inc′≡inc 0ᵇ = refl
inc′≡inc (1ᵇ xs) = refl
inc′≡inc (2ᵇ xs) = 0∷!≡0∷ (inc′ xs) ; cong 1ᵇ_ (inc′≡inc xs)


import Relation.Binary.PropositionalEquality as PEq

module Relation.Binary.PropositionalEquality.Extensionality
  (funext : ∀ {ℓ₁ ℓ₂} → PEq.Extensionality ℓ₁ ℓ₂) where

funext² : ∀ {p q r}{P : Set p}{Q : P → Set q}
          {R : (p : P) → Q p → Set r} →
          {f g : ∀ (p : P)(q : Q p) → R p q} → (∀ p q → f p q PEq.≡ g p q) →
          f PEq.≡ g
funext² f = funext λ p → funext λ q → f p q

funext³ : ∀ {p q r s}{P : Set p}{Q : P → Set q}
          {R : (p : P) → Q p → Set r}{S : (p : P)(q : Q p) → R p q → Set s} →
          {f g : ∀ (p : P)(q : Q p)(r : R p q) → S p q r} → (∀ p q r → f p q r PEq.≡ g p q r) →
          f PEq.≡ g
funext³ f = funext λ p → funext λ q → funext λ r → f p q r


------------------------------------------------------------------------------
-- FOCT terms properties
------------------------------------------------------------------------------

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

module FOTC.Base.PropertiesATP where

open import FOTC.Base

------------------------------------------------------------------------------
-- Injective properties

postulate succInjective : ∀ {m n} → succ₁ m ≡ succ₁ n → m ≡ n
{-# ATP prove succInjective #-}

------------------------------------------------------------------------------
-- Discrimination rules

postulate S≢0 : ∀ {n} → succ₁ n ≢ zero
{-# ATP prove S≢0 #-}


------------------------------------------------------------------------
-- The Agda standard library
--
-- An inductive definition of the sublist relation. This is commonly
-- known as Order Preserving Embeddings (OPE).
------------------------------------------------------------------------

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

module Data.List.Relation.Binary.Sublist.Propositional
  {a} {A : Set a} where

open import Data.List.Relation.Binary.Equality.Propositional using (≋⇒≡)
import Data.List.Relation.Binary.Sublist.Setoid as SetoidSublist
open import Data.List.Relation.Unary.Any using (Any)
open import Relation.Binary
open import Relation.Binary.PropositionalEquality
open import Relation.Unary using (Pred)

------------------------------------------------------------------------
-- Re-export definition and operations from setoid sublists

open SetoidSublist (setoid A) public
  hiding
  (lookup; ⊆-reflexive; ⊆-antisym
  ; ⊆-isPreorder; ⊆-isPartialOrder
  ; ⊆-preorder; ⊆-poset
  )

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

module _ {p} {P : Pred A p} where

  lookup : ∀ {xs ys} → xs ⊆ ys → Any P xs → Any P ys
  lookup = SetoidSublist.lookup (setoid A) (subst _)

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

⊆-reflexive : _≡_ ⇒ _⊆_
⊆-reflexive refl = ⊆-refl

⊆-antisym : Antisymmetric _≡_ _⊆_
⊆-antisym xs⊆ys ys⊆xs = ≋⇒≡ (SetoidSublist.⊆-antisym (setoid A) xs⊆ys ys⊆xs)

⊆-isPreorder : IsPreorder _≡_ _⊆_
⊆-isPreorder = record
  { isEquivalence = isEquivalence
  ; reflexive     = ⊆-reflexive
  ; trans         = ⊆-trans
  }

⊆-isPartialOrder : IsPartialOrder _≡_ _⊆_
⊆-isPartialOrder = record
  { isPreorder = ⊆-isPreorder
  ; antisym    = ⊆-antisym
  }

⊆-preorder : Preorder a a a
⊆-preorder = record
  { isPreorder = ⊆-isPreorder
  }

⊆-poset : Poset a a a
⊆-poset = record
  { isPartialOrder = ⊆-isPartialOrder
  }


------------------------------------------------------------------------
-- The Agda standard library
--
-- Implications of nullary relations
------------------------------------------------------------------------

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

module Relation.Nullary.Implication where

open import Data.Bool.Base
open import Data.Empty
open import Function.Base
open import Relation.Nullary
open import Level

private
  variable
    p q : Level
    P : Set p
    Q : Set q

------------------------------------------------------------------------
-- Some properties which are preserved by _→_.

infixr 2 _→-reflects_ _→-dec_

_→-reflects_ : ∀ {bp bq} → Reflects P bp → Reflects Q bq →
                           Reflects (P → Q) (not bp ∨ bq)
ofʸ  p →-reflects ofʸ  q = ofʸ (const q)
ofʸ  p →-reflects ofⁿ ¬q = ofⁿ (¬q ∘ (_$ p))
ofⁿ ¬p →-reflects _      = ofʸ (⊥-elim ∘ ¬p)

_→-dec_ : Dec P → Dec Q → Dec (P → Q)
does  (p? →-dec q?) = not (does p?) ∨ does q?
proof (p? →-dec q?) = proof p? →-reflects proof q?


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

module Categories.Adjoint.Instance.PosetCore where

-- The adjunction between the "forgetful" functor from Posets to
-- Setoids and the core functor for posets.

open import Level using (_⊔_)
import Function
open import Function.Equality using (Π; _⟶_)
open import Relation.Binary using (Setoid; Poset)
open import Relation.Binary.OrderMorphism using (_⇒-Poset_) renaming (_∘_ to _∙_)

open import Categories.Adjoint using (_⊣_)
import Categories.Adjoint.Instance.0-Truncation as Setd
import Categories.Adjoint.Instance.01-Truncation as Pos
open import Categories.Category using (Category)
open import Categories.Category.Construction.Thin
open import Categories.Category.Instance.Posets using (fun-resp-≈; Posets)
open import Categories.Category.Instance.Setoids using (Setoids)
open import Categories.Functor.Instance.Core using () renaming (Core to CatCore)
import Categories.Functor.Instance.Core as Cat
open import Categories.Functor using (Functor; _∘F_; id)
import Categories.Morphism as Morphism
open import Categories.Morphism.IsoEquiv using (⌞_⌟)
open import Categories.NaturalTransformation using (ntHelper)
open import Categories.NaturalTransformation.NaturalIsomorphism
  using (_≃_; niHelper)

open Π
open _⇒-Poset_

-- The "forgetful" functor from Setoids to Posets (forgetting symmetry).

Forgetful : ∀ {c ℓ} → Functor (Setoids c ℓ) (Posets c ℓ ℓ)
Forgetful = record
  { F₀           = Forgetful₀
  ; F₁           = λ f → record { fun = _⟨$⟩_ f ; monotone = cong f }
  ; identity     = λ {S}       → refl S
  ; homomorphism = λ {_ _ S}   → refl S
  ; F-resp-≈     = λ {S _} f≗g → f≗g (refl S)
  }
  where
    Forgetful₀ : ∀ {c ℓ} → Setoid c ℓ → Poset c ℓ ℓ
    Forgetful₀ S = record
      { _≈_               = _≈_
      ; _≤_               = _≈_
      ; isPartialOrder    = record
        { isPreorder      = record
          { isEquivalence = isEquivalence
          ; reflexive     = Function.id
          ; trans         = trans
          }
        ; antisym         = Function.const
        }
      }
      where open Setoid S

    open Setoid

-- The "core" functor from Posets to Setoids.
--
-- This functor simply forgets the _≤_ relation, mapping a Poset to
-- the Setoid over which it is defined.  This Setoid is the "core" of
-- the Poset in the sense that the "equality" _≈_ associated with the
-- Poset is really an equivalence, and antisymmetry ensures that this
-- equivalence is equivalent to the symmetric core of _≤_.

Core : ∀ {c ℓ₁ ℓ₂} → Functor (Posets c ℓ₁ ℓ₂) (Setoids c ℓ₁)
Core = record
  { F₀           = λ A → record { isEquivalence = isEquivalence A }
  ; F₁           = λ f → record { _⟨$⟩_ = fun f ; cong = fun-resp-≈ f }
  ; identity     = Function.id
  ; homomorphism = λ {_ _ _ f g} → fun-resp-≈ (g ∙ f)
  ; F-resp-≈     = λ {_ B} {f _} f≗g x≈y → Eq.trans B (fun-resp-≈ f x≈y) f≗g
  }
  where open Poset

-- Core is right-adjoint to the forgetful functor

CoreAdj : ∀ {o ℓ} → Forgetful ⊣ Core {o} {ℓ} {ℓ}
CoreAdj = record
  { unit   = ntHelper record { η = unit   ; commute = cong                  }
  ; counit = ntHelper record { η = counit ; commute = λ {_ B} _ → Eq.refl B }
  ; zig    = λ {S} → Setoid.refl S
  ; zag    = Function.id
  }
  where
    open Poset
    open Functor Core      using () renaming (F₀ to Core₀; F₁ to Core₁)
    open Functor Forgetful using () renaming (F₀ to U₀   ; F₁ to U₁)

    unit : ∀ S → S ⟶ Core₀ (U₀ S)
    unit S = record { _⟨$⟩_ = Function.id ; cong = Function.id }

    counit : ∀ A → U₀ (Core₀ A) ⇒-Poset A
    counit C = record { fun = Function.id ; monotone = reflexive C }

-- The core functor commutes with inclusion, i.e. the core of a thin
-- category is the 0-Groupoid generated by the associated equivalence.
--
-- Note that the core functor does not commute with truncation,
-- because the latter forgets too much (there are many more isos in
-- the (0,1)-truncated category).

Core-commutes : ∀ {c ℓ} e → Setd.Inclusion e ∘F Core ≃
                Cat.Core ∘F Pos.Inclusion {c} {ℓ ⊔ e} {ℓ} e
Core-commutes e = niHelper record
  { η   = λ A → record { F₀ = Function.id ; F₁ = EqIsIso.≈⇒≅ e A }
  ; η⁻¹ = λ A → record { F₀ = Function.id ; F₁ = EqIsIso.≅⇒≈ e A }
  ; commute = λ {A B} f →
    let open Morphism (Thin e B)
    in niHelper record { η   = λ _ → ≅.refl ; η⁻¹ = λ _ → ≅.refl }
  ; iso = λ A →
    let open Poset A
        open Morphism (Thin e A)
    in record
    { isoˡ = niHelper record { η = λ _ → Eq.refl ; η⁻¹ = λ _ → Eq.refl }
    ; isoʳ = niHelper record { η = λ _ → ≅.refl  ; η⁻¹ = λ _ → ≅.refl  }
    }
  }


------------------------------------------------------------------------
-- All library modules, along with short descriptions
------------------------------------------------------------------------

-- Note that core modules are not included.

module Everything where

-- Definitions of algebraic structures like monoids and rings
-- (packed in records together with sets, operations, etc.)
import Algebra

-- Properties of functions, such as associativity and commutativity
import Algebra.FunctionProperties

-- Morphisms between algebraic structures
import Algebra.Morphism

-- Some defined operations (multiplication by natural number and
-- exponentiation)
import Algebra.Operations

-- Some derivable properties
import Algebra.Props.AbelianGroup

-- Some derivable properties
import Algebra.Props.BooleanAlgebra

-- Some derivable properties
import Algebra.Props.DistributiveLattice

-- Some derivable properties
import Algebra.Props.Group

-- Some derivable properties
import Algebra.Props.Lattice

-- Some derivable properties
import Algebra.Props.Ring

-- Solver for commutative ring or semiring equalities
import Algebra.RingSolver

-- Commutative semirings with some additional structure ("almost"
-- commutative rings), used by the ring solver
import Algebra.RingSolver.AlmostCommutativeRing

-- Some boring lemmas used by the ring solver
import Algebra.RingSolver.Lemmas

-- Instantiates the ring solver with two copies of the same ring
import Algebra.RingSolver.Simple

-- Some algebraic structures (not packed up with sets, operations,
-- etc.)
import Algebra.Structures

-- Applicative functors
import Category.Applicative

-- Indexed applicative functors
import Category.Applicative.Indexed

-- Functors
import Category.Functor

-- Monads
import Category.Monad

-- A delimited continuation monad
import Category.Monad.Continuation

-- The identity monad
import Category.Monad.Identity

-- Indexed monads
import Category.Monad.Indexed

-- The partiality monad
import Category.Monad.Partiality

-- The state monad
import Category.Monad.State

-- Types used to make recursive arguments coinductive
import Coinduction

-- AVL trees
import Data.AVL

-- Finite maps with indexed keys and values, based on AVL trees
import Data.AVL.IndexedMap

-- Finite sets, based on AVL trees
import Data.AVL.Sets

-- A binary representation of natural numbers
import Data.Bin

-- Booleans
import Data.Bool

-- A bunch of properties
import Data.Bool.Properties

-- Showing booleans
import Data.Bool.Show

-- Bounded vectors
import Data.BoundedVec

-- Bounded vectors (inefficient, concrete implementation)
import Data.BoundedVec.Inefficient

-- Characters
import Data.Char

-- "Finite" sets indexed on coinductive "natural" numbers
import Data.Cofin

-- Coinductive lists
import Data.Colist

-- Coinductive "natural" numbers
import Data.Conat

-- Coinductive vectors
import Data.Covec

-- Lists with fast append
import Data.DifferenceList

-- Natural numbers with fast addition (for use together with
-- DifferenceVec)
import Data.DifferenceNat

-- Vectors with fast append
import Data.DifferenceVec

-- Digits and digit expansions
import Data.Digit

-- Empty type
import Data.Empty

-- Empty type (in Set₁)
import Data.Empty1

-- Finite sets
import Data.Fin

-- Decision procedures for finite sets and subsets of finite sets
import Data.Fin.Dec

-- Properties related to Fin, and operations making use of these
-- properties (or other properties not available in Data.Fin)
import Data.Fin.Props

-- Subsets of finite sets
import Data.Fin.Subset

-- Some properties about subsets
import Data.Fin.Subset.Props

-- Substitutions
import Data.Fin.Substitution

-- An example of how Data.Fin.Substitution can be used: a definition
-- of substitution for the untyped λ-calculus, along with some lemmas
import Data.Fin.Substitution.Example

-- Substitution lemmas
import Data.Fin.Substitution.Lemmas

-- Application of substitutions to lists, along with various lemmas
import Data.Fin.Substitution.List

-- Simple combinators working solely on and with functions
import Data.Function

-- Directed acyclic multigraphs
import Data.Graph.Acyclic

-- Integers
import Data.Integer

-- Divisibility and coprimality
import Data.Integer.Divisibility

-- Some properties about integers
import Data.Integer.Properties

-- Lists
import Data.List

-- Lists where all elements satisfy a given property
import Data.List.All

-- Properties relating All to various list functions
import Data.List.All.Properties

-- Lists where at least one element satisfies a given property
import Data.List.Any

-- Properties relating Any to various list functions
import Data.List.Any.Properties

-- A data structure which keeps track of an upper bound on the number
-- of elements /not/ in a given list
import Data.List.Countdown

-- List equality
import Data.List.Equality

-- Non-empty lists
import Data.List.NonEmpty

-- Properties of non-empty lists
import Data.List.NonEmpty.Properties

-- List-related properties
import Data.List.Properties

-- Lists parameterised on things in Set₁
import Data.List1

-- Finite maps, i.e. lookup tables (currently only some type
-- signatures)
import Data.Map

-- The Maybe type
import Data.Maybe

-- Natural numbers
import Data.Nat

-- Coprimality
import Data.Nat.Coprimality

-- Integer division
import Data.Nat.DivMod

-- Divisibility
import Data.Nat.Divisibility

-- Greatest common divisor
import Data.Nat.GCD

-- Boring lemmas used in Data.Nat.GCD and Data.Nat.Coprimality
import Data.Nat.GCD.Lemmas

-- Least common multiple
import Data.Nat.LCM

-- A bunch of properties about natural number operations
import Data.Nat.Properties

-- Showing natural numbers
import Data.Nat.Show

-- Products
import Data.Product

-- Products implemented using records
import Data.Product.Record

-- Products (variants for Set₁)
import Data.Product1

-- Rational numbers
import Data.Rational

-- Finite sets (currently only some type signatures)
import Data.Sets

-- Signs
import Data.Sign

-- Some properties about signs
import Data.Sign.Properties

-- The reflexive transitive closures of McBride, Norell and Jansson
import Data.Star

-- Bounded vectors (inefficient implementation)
import Data.Star.BoundedVec

-- Decorated star-lists
import Data.Star.Decoration

-- Environments (heterogeneous collections)
import Data.Star.Environment

-- Finite sets defined in terms of Data.Star
import Data.Star.Fin

-- Lists defined in terms of Data.Star
import Data.Star.List

-- Natural numbers defined in terms of Data.Star
import Data.Star.Nat

-- Pointers into star-lists
import Data.Star.Pointer

-- Some properties related to Data.Star
import Data.Star.Properties

-- Vectors defined in terms of Data.Star
import Data.Star.Vec

-- Streams
import Data.Stream

-- Strings
import Data.String

-- Sums (disjoint unions)
import Data.Sum

-- The unit type
import Data.Unit

-- The unit type (in Set₁)
import Data.Unit1

-- Vectors
import Data.Vec

-- Semi-heterogeneous vector equality
import Data.Vec.Equality

-- Code for converting Vec n A → B to and from n-ary functions
import Data.Vec.N-ary

-- Code for converting Vec₁ n A → B to and from n-ary functions
import Data.Vec.N-ary1

-- Some Vec-related properties
import Data.Vec.Properties

-- Vectors parameterised on types in Set₁
import Data.Vec1

-- Types used (only) when calling out to Haskell via the FFI
import Foreign.Haskell

-- IO
import IO

-- Primitive IO: simple bindings to Haskell types and functions
import IO.Primitive

-- An abstraction of various forms of recursion/induction
import Induction

-- Lexicographic induction
import Induction.Lexicographic

-- Various forms of induction for natural numbers
import Induction.Nat

-- Well-founded induction
import Induction.WellFounded

-- A variant of Induction for Set₁
import Induction1

-- One form of induction for natural numbers
import Induction1.Nat

-- Well-founded induction
import Induction1.WellFounded

-- Properties of homogeneous binary relations
import Relation.Binary

-- Some properties imply others
import Relation.Binary.Consequences

-- Convenient syntax for equational reasoning
import Relation.Binary.EqReasoning

-- Many properties which hold for _∼_ also hold for flip₁ _∼_
import Relation.Binary.Flip

-- Function setoids and related constructions
import Relation.Binary.FunctionSetoid

-- Heterogeneous equality
import Relation.Binary.HeterogeneousEquality

-- Conversion of ≤ to <, along with a number of properties
import Relation.Binary.NonStrictToStrict

-- Many properties which hold for _∼_ also hold for _∼_ on₁ f
import Relation.Binary.On

-- Order morphisms
import Relation.Binary.OrderMorphism

-- Convenient syntax for "equational reasoning" using a partial order
import Relation.Binary.PartialOrderReasoning

-- Convenient syntax for "equational reasoning" using a preorder
import Relation.Binary.PreorderReasoning

-- Lexicographic products of binary relations
import Relation.Binary.Product.NonStrictLex

-- Pointwise products of binary relations
import Relation.Binary.Product.Pointwise

-- Lexicographic products of binary relations
import Relation.Binary.Product.StrictLex

-- Propositional (intensional) equality
import Relation.Binary.PropositionalEquality

-- Propositional equality
import Relation.Binary.PropositionalEquality1

-- Properties satisfied by decidable total orders
import Relation.Binary.Props.DecTotalOrder

-- Properties satisfied by posets
import Relation.Binary.Props.Poset

-- Properties satisfied by strict partial orders
import Relation.Binary.Props.StrictPartialOrder

-- Properties satisfied by strict partial orders
import Relation.Binary.Props.StrictTotalOrder

-- Properties satisfied by total orders
import Relation.Binary.Props.TotalOrder

-- Helpers intended to ease the development of "tactics" which use
-- proof by reflection
import Relation.Binary.Reflection

-- Some simple binary relations
import Relation.Binary.Simple

-- Convenient syntax for "equational reasoning" using a strict partial
-- order
import Relation.Binary.StrictPartialOrderReasoning

-- Conversion of < to ≤, along with a number of properties
import Relation.Binary.StrictToNonStrict

-- Sums of binary relations
import Relation.Binary.Sum

-- Operations on nullary relations (like negation and decidability)
import Relation.Nullary

-- Operations on and properties of decidable relations
import Relation.Nullary.Decidable

-- Properties related to negation
import Relation.Nullary.Negation

-- Products of nullary relations
import Relation.Nullary.Product

-- Sums of nullary relations
import Relation.Nullary.Sum

-- A universe of proposition functors, along with some properties
import Relation.Nullary.Universe

-- Unary relations
import Relation.Unary

-- Unary relations (variant for Set₁)
import Relation.Unary1

-- Sizes for Agda's sized types
import Size


------------------------------------------------------------------------
-- The Agda standard library
--
-- Symmetric closures of binary relations
------------------------------------------------------------------------

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

module Relation.Binary.Construct.Closure.Symmetric where

open import Data.Sum as Sum using (_⊎_)
open import Function using (id)
open import Relation.Binary

open Sum public using () renaming (inj₁ to fwd; inj₂ to bwd)

-- The symmetric closure of a relation.

SymClosure : ∀ {a ℓ} {A : Set a} → Rel A ℓ → Rel A ℓ
SymClosure _∼_ a b = a ∼ b ⊎ b ∼ a

module _ {a ℓ} {A : Set a} where

  -- Symmetric closures are symmetric.

  symmetric : (_∼_ : Rel A ℓ) → Symmetric (SymClosure _∼_)
  symmetric _ (fwd a∼b) = bwd a∼b
  symmetric _ (bwd b∼a) = fwd b∼a

  -- A generalised variant of map which allows the index type to change.

  gmap : ∀ {b ℓ₂} {B : Set b} {P : Rel A ℓ} {Q : Rel B ℓ₂} →
         (f : A → B) → P =[ f ]⇒ Q → SymClosure P =[ f ]⇒ SymClosure Q
  gmap _ g = Sum.map g g

  map : ∀ {ℓ₂} {P : Rel A ℓ} {Q : Rel A ℓ₂} →
        P ⇒ Q → SymClosure P ⇒ SymClosure Q
  map = gmap id


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

open import Cubical.Data.Int.Base public

open import Cubical.Data.Int.Properties public


-- Andreas, 2017-01-18, issue #2408

-- DLubs were not serialized, thus, there was a problem with
-- level dependent on irrelevant values.

{-# OPTIONS --show-irrelevant #-}

-- {-# OPTIONS -v tc:70 #-}

open import Agda.Primitive

postulate
  A : Set
  l : .(a : A) → Level
  F : .(a : A) → Set (l a)

-- checked type signature
--   F : .(a : A) → Set (l a)
--   of sort  dLub Set (λ a → Set (lsuc (l a)))


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

open import LogicalFormulae
open import Sets.EquivalenceRelations
open import Setoids.Setoids
open import Rings.Definition
open import Rings.PrincipalIdealDomains.Definition
open import Rings.IntegralDomains.Definition
open import Rings.Ideals.Maximal.Definition

module Rings.PrincipalIdealDomains.Lemmas {a b : _} {A : Set a} {S : Setoid {a} {b} A} {_+_ _*_ : A → A → A} {R : Ring S _+_ _*_} (intDom : IntegralDomain R) (pid : {c : _} → PrincipalIdealDomain intDom {c}) where

open import Rings.Ideals.Definition R
open import Rings.Irreducibles.Definition intDom
open import Rings.Ideals.Principal.Definition R
open import Rings.Divisible.Definition R
open import Rings.Associates.Lemmas intDom
open import Rings.Ideals.Lemmas R
open import Rings.Units.Definition R
open import Rings.Irreducibles.Lemmas intDom
open import Rings.Units.Lemmas R
open import Rings.Ideals.Prime.Definition {R = R}
open import Rings.Ideals.Prime.Lemmas {R = R}
open import Rings.Primes.Definition intDom
open import Rings.Primes.Lemmas intDom
open import Rings.Ideals.Principal.Lemmas R
open import Rings.Ideals.Maximal.Lemmas {R = R}

open Ring R
open Setoid S
open Equivalence eq

irreducibleImpliesMaximalIdeal : {r : A} → Irreducible r → {d : _} → MaximalIdeal (generatedIdeal r) {d}
MaximalIdeal.notContained (irreducibleImpliesMaximalIdeal {r} irred {d}) = 1R
MaximalIdeal.notContainedIsNotContained (irreducibleImpliesMaximalIdeal {r} irred {d}) = Irreducible.nonunit irred
MaximalIdeal.isMaximal (irreducibleImpliesMaximalIdeal {r} irred {d}) {biggerPred} bigger biggerContains (outsideR , (biggerContainsOutside ,, notInR)) {x} = biggerPrincipal' (unitImpliesGeneratedIdealEverything w {x})
  where
    biggerGen : A
    biggerGen = PrincipalIdeal.generator (pid bigger)
    biggerPrincipal : {x : A} → biggerPred x → biggerGen ∣ x
    biggerPrincipal = PrincipalIdeal.genGenerates (pid bigger)
    bp : biggerPred biggerGen
    bp = PrincipalIdeal.genIsInIdeal (pid bigger)
    biggerPrincipal' : {x : A} → biggerGen ∣ x → biggerPred x
    biggerPrincipal' {y} bg|y = memberDividesImpliesMember bigger bp bg|y
    u : biggerGen ∣ r
    u = biggerPrincipal (biggerContains (1R , transitive *Commutative identIsIdent))
    biggerGenNonzero : biggerGen ∼ 0R → False
    biggerGenNonzero bg=0 = notInR (Ideal.isSubset (generatedIdeal r) (symmetric t) (Ideal.containsIdentity (generatedIdeal r)))
      where
        t : outsideR ∼ 0R
        t with biggerPrincipal {outsideR} biggerContainsOutside
        ... | mult , pr = transitive (symmetric pr) (transitive (*WellDefined bg=0 reflexive) (transitive *Commutative timesZero))
    v : (r ∣ biggerGen) → False
    v r|bg with mutualDivisionImpliesAssociate r|bg u (Irreducible.nonzero irred)
    v r|bg | assoc = notInR (associateImpliesGeneratedIdealsEqual' assoc (PrincipalIdeal.genGenerates (pid bigger) biggerContainsOutside))
    w : Unit biggerGen
    w = dividesIrreducibleImpliesUnit irred u v

primeIdealIsMaximal : {c : _} {pred : A → Set c} → {i : Ideal pred} → (nonzero : Sg A (λ a → ((a ∼ 0R) → False) && pred a)) → PrimeIdeal i → {d : _} → MaximalIdeal i {d}
primeIdealIsMaximal {pred = pred} {i} (m , (m!=0 ,, predM)) prime {d = d} = maximalIdealWellDefined (generatedIdeal (PrincipalIdeal.generator princ)) i (memberDividesImpliesMember i (PrincipalIdeal.genIsInIdeal princ)) (PrincipalIdeal.genGenerates princ) isMaximal
  where
    princ : PrincipalIdeal i
    princ = pid i
    isPrime : Prime (PrincipalIdeal.generator princ)
    isPrime = primeIdealImpliesPrime (λ gen=0 → PrimeIdeal.notContainedIsNotContained prime (exFalso (m!=0 (generatorZeroImpliesAllZero princ gen=0 predM)))) (primeIdealWellDefined i (generatedIdeal (PrincipalIdeal.generator princ)) (PrincipalIdeal.genGenerates princ) (memberDividesImpliesMember i (PrincipalIdeal.genIsInIdeal princ)) prime)
    isIrreducible : Irreducible (PrincipalIdeal.generator princ)
    isIrreducible = primeIsIrreducible isPrime
    isMaximal : MaximalIdeal (generatedIdeal (PrincipalIdeal.generator princ)) {d}
    isMaximal = irreducibleImpliesMaximalIdeal isIrreducible {d}

irreducibleImpliesPrime : {x : A} → Irreducible x → Prime x
irreducibleImpliesPrime {x} irred = primeIdealImpliesPrime (Irreducible.nonzero irred) (idealMaximalImpliesIdealPrime (generatedIdeal x) (irreducibleImpliesMaximalIdeal irred))


------------------------------------------------------------------------
-- The Agda standard library
--
-- Heterogeneous equality
------------------------------------------------------------------------

-- This file contains some core definitions which are reexported by
-- Relation.Binary.HeterogeneousEquality.

{-# OPTIONS --with-K --safe #-}

module Relation.Binary.HeterogeneousEquality.Core where

open import Relation.Binary.PropositionalEquality.Core using (_≡_; refl)

------------------------------------------------------------------------
-- Heterogeneous equality

infix 4 _≅_

data _≅_ {ℓ} {A : Set ℓ} (x : A) : {B : Set ℓ} → B → Set ℓ where
   refl : x ≅ x

------------------------------------------------------------------------
-- Conversion

≅-to-≡ : ∀ {a} {A : Set a} {x y : A} → x ≅ y → x ≡ y
≅-to-≡ refl = refl

≡-to-≅ : ∀ {a} {A : Set a} {x y : A} → x ≡ y → x ≅ y
≡-to-≅ refl = refl


open import FRP.JS.Bool using ( Bool ; true ; false )

module FRP.JS.Maybe where

-- Data.Maybe doesn't have bindings for JavaScript, so we define Maybe here.

-- We'd like to use JavaScript's built-in null as the
-- representation of nothing, and use x as the representation of just
-- x.  Unfortunately this doens't work for nested Maybes, as it
-- identifies nothing and just nothing at type Maybe Maybe A, which in
-- turn breaks parametericity. Instead, we link to a JS library which
-- provides functions box and unbox such that box(x) !== null,
-- unbox(box(x)) === x, and if x !== box^n (null) then x ==
-- box(x). Note that for never-null types (e.g. String), values
-- of type Maybe T are either null or values of type T, which
-- corresponds to the JavaScript idiom (for example, a lookup in an
-- array of strings can be translated to native array lookup).

data Maybe {α} (A : Set α) : Set α where
  just : (a : A) → Maybe A
  nothing : Maybe A

{-# COMPILED_JS Maybe function(x,v) {
  if (x === null) { return v.nothing(); }
  else { return v.just(require("agda.box").unbox(x)); }
} #-}
{-# COMPILED_JS just require("agda.box").box #-}
{-# COMPILED_JS nothing null #-}

_≟[_]_ : ∀ {α β A B} → Maybe {α} A → (A → B → Bool) → Maybe {β} B → Bool
just a  ≟[ p ] just b  = p a b
just a  ≟[ p ] nothing = false
nothing ≟[ p ] just b  = false
nothing ≟[ p ] nothing = true


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

module Cubical.Data.FinSet.Binary.Small.Base where

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

open import Cubical.Data.Bool hiding (isSetBool)

data Binary : Type₀
El : Binary → Type₀

data Binary where
  ℕ₂ : Binary
  un : ∀ x y → El x ≃ El y → x ≡ y

El ℕ₂ = Bool
El (un _ _ e i) = ua e i


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

open import Cubical.ZCohomology.Base
open import Cubical.ZCohomology.Properties
open import Cubical.ZCohomology.Groups.Unit

open import Cubical.Foundations.HLevels
open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Isomorphism
open import Cubical.Foundations.GroupoidLaws

open import Cubical.HITs.SetTruncation renaming (rec to sRec ; elim to sElim ; elim2 to sElim2)
open import Cubical.HITs.PropositionalTruncation renaming (rec to pRec ; ∥_∥ to ∥_∥₁ ; ∣_∣ to ∣_∣₁)
open import Cubical.HITs.Nullification

open import Cubical.Data.Sigma hiding (_×_)
open import Cubical.Data.Int renaming (_+_ to _+ℤ_; +-comm to +ℤ-comm ; +-assoc to +ℤ-assoc)
open import Cubical.Data.Nat
open import Cubical.HITs.Truncation renaming (rec to trRec)
open import Cubical.Algebra.Group

open import Cubical.Homotopy.Connected
open import Cubical.Foundations.Equiv

private
  H⁰-connected-type : ∀ {ℓ} {A : Type ℓ} (a : A) → isConnected 2 A → Iso (coHom 0 A) Int
  Iso.fun (H⁰-connected-type a con) = sRec isSetInt λ f → f a
  Iso.inv (H⁰-connected-type a con) b = ∣ (λ x → b) ∣₂
  Iso.rightInv (H⁰-connected-type a con) b = refl
  Iso.leftInv (H⁰-connected-type a con) =
    sElim (λ _ → isOfHLevelPath 2 setTruncIsSet _ _)
           λ f → cong ∣_∣₂ (funExt λ x → trRec (isSetInt _ _) (cong f) (isConnectedPath 1 con a x .fst))

H⁰-connected : ∀ {ℓ} {A : Type ℓ} (a : A) → ((x : A) → ∥ a ≡ x ∥₁) → GroupIso (coHomGr 0 A) intGroup
GroupHom.fun (GroupIso.map (H⁰-connected a con)) = sRec isSetInt (λ f → f a)
GroupHom.isHom (GroupIso.map (H⁰-connected a con)) =
  sElim2 (λ _ _ → isProp→isSet (isSetInt _ _)) λ x y → addLemma (x a) (y a)
GroupIso.inv (H⁰-connected a con) b = ∣ (λ _ → b) ∣₂
GroupIso.rightInv (H⁰-connected a con) _ = refl
GroupIso.leftInv (H⁰-connected a con) =
  sElim (λ _ → isProp→isSet (setTruncIsSet _ _))
        (λ f → cong ∣_∣₂ (funExt λ x → pRec (isSetInt _ _) (cong f) (con x)))


-- Andreas, issue reported by Matteo Acerbi, 2014-09-04.
-- Short summary: x = c x is not impossible for coinductive constructors c,
-- so x should not be considered a strictly rigid occurrence in (c x).

-- Matteo:

-- In the following I cannot understand what justifies the absurd pattern
-- in the definition of ¬id≡In: as νId is coinductive, elaboration of the
-- no-cycles check to eliminators should not be possible (as far as I know).

-- Any two inhabitants of νId are bisimilar, but it seems that current
-- pattern matching makes it inconsistent to assume that bisimilarity
-- implies equality for νId, which *might* upset some. :-)

{-# OPTIONS --copatterns #-}

-- False and equality.

⊥ = (X : Set) → X

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

-- The cofixpoint of the identity functor.

record νId : Set where
  coinductive
  constructor In
  field       Out : νId
open νId

-- The "only" inhabitant of νId.

tt : νId
Out tt = tt

-- x ≡ In x is considered absurd.

¬id≡In : {x : νId} → x ≡ In x → ⊥
¬id≡In ()

-- _≈_ is bisimilarity for elements of νId.

record _≈νId_ (x y : νId) : Set where
  coinductive
  field step : Out x ≈νId Out y
open _≈νId_

-- Any two elements are bisimilar.

trivial-≈νId : ∀ {x y} → x ≈νId y
step trivial-≈νId = trivial-≈νId

-- For νId it is not consistent to assume that bisimilarity implies
-- equality.

problem? : (ext : ∀ {x y} → x ≈νId y → x ≡ y) → ⊥
problem? ext = ¬id≡In {tt} (ext trivial-≈νId)


module Numeral.Real where

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

-- TODO: This will not work, but it is the standard concept at least. Maybe there is a better way

record CauchySequence (a : ℕ → ℚ) : Stmt where
  field
    N : ℚ₊ → ℕ
    ∀{ε : ℚ₊}{m n : ℕ} → (m > N(ε)) → (n > N(ε)) → (‖ a(m) − a(n) ‖ < ε)

_converges-to-same_ : Σ(CauchySequence) → Σ(CauchySequence) → Stmt{Lvl.𝟎}
a converges-to-same b = lim(n ↦ Σ.left(a) − Σ.left(b)) ≡ 𝟎

ℝ : Type{Lvl.𝟎}
ℝ = Σ(CauchySequence) / (_converges-to-same_)

-- TODO: Here is another idea: https://github.com/dylanede/cubical-experiments/blob/master/scratch.agda
-- TODO: Also these: https://en.wikipedia.org/wiki/Construction_of_the_real_numbers#Construction_from_Cauchy_sequences


open import Agda.Primitive

postulate
  ℓ : Level
  F : Level → Set

module Two where

  mutual

    α : Level
    α = _

    G : F (α ⊔ ℓ) → F ℓ
    G A = A

    H : F (α ⊔ ℓ) → F α
    H A = A

module Three where

  mutual

    α : Level
    α = _

    β : Level
    β = _

    G : F (α ⊔ β ⊔ ℓ) → F ℓ
    G A = A

    H : F (α ⊔ β ⊔ ℓ) → F α
    H A = A

    I : F (α ⊔ β ⊔ ℓ) → F β
    I A = A


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

open import HoTT

{- Proof that if [A] and [B] are two propositions, then so is [A * B]. -}

module homotopy.PropJoinProp
  {i} {A : Type i} (pA : is-prop A)
  {j} {B : Type j} (pB : is-prop B) where

contr-left : (a : A) → is-contr (A * B)
contr-left a = left a , Pushout-elim
  (λ a' → ap left (prop-has-all-paths pA a a'))
  (λ b' → glue (a , b'))
  (λ {(a' , b') → ↓-cst=idf-in' $ ! $
    ↓-app=cst-out (apd (λ a → glue (a , b')) (prop-has-all-paths pA a a'))})

contr-right : (b : B) → is-contr (A * B)
contr-right b = right b , Pushout-elim
  (λ a' → ! (glue (a' , b)))
  (λ b' → ap right (prop-has-all-paths pB b b'))
  (λ {(a' , b') → ↓-cst=idf-in' $
    ! (glue (a' , b)) ∙ glue (a' , b')
      =⟨ ! (↓-cst=app-out' $ apd (λ b → glue (a' , b)) (prop-has-all-paths pB b b'))
        |in-ctx ! (glue (a' , b)) ∙_ ⟩
    ! (glue (a' , b)) ∙ glue (a' , b) ∙ ap right (prop-has-all-paths pB b b')
      =⟨ ! $ ∙-assoc (! (glue (a' , b))) (glue (a' , b)) (ap right (prop-has-all-paths pB b b')) ⟩
    (! (glue (a' , b)) ∙ glue (a' , b)) ∙ ap right (prop-has-all-paths pB b b')
      =⟨ !-inv-l (glue (a' , b)) |in-ctx _∙ ap right (prop-has-all-paths pB b b') ⟩
    ap right (prop-has-all-paths pB b b')
      =∎})

prop*prop-is-prop : is-prop (A * B)
prop*prop-is-prop = inhab-to-contr-is-prop $
  Pushout-rec contr-left contr-right (λ _ → prop-has-all-paths is-contr-is-prop _ _)