module Array.Repr where

open import Array.Base

open import Data.Nat
open import Data.Vec as V
open import Data.Fin using (Fin; zero; suc; raise)
open import Relation.Binary.PropositionalEquality
open import Function

-- This is a function that inductively generates a Vec-based type
-- for the given arguments of Ar.
repr-t : ∀ {a} → (X : Set a) → (n : ℕ) → (s : Vec ℕ n) → Set a
repr-t X zero s = X
repr-t X (suc n) (x ∷ s) = Vec (repr-t X n s) x

a→rt : ∀ {a}{X : Set a}{n s} → Ar X n s → repr-t X n s
a→rt {n = zero}  {s = []} (imap f) = f []
a→rt {n = suc n} {x ∷ s} (imap f) = tabulate λ i → a→rt (imap (λ iv → f (i ∷ iv)))

rt→a : ∀ {a}{X : Set a}{n s} → repr-t X n s → Ar X n s
rt→a {n = zero} {s} x = imap (λ _ → x)
rt→a {n = suc n} {s ∷ _} x = imap λ where
                                (i ∷ iv) → case rt→a (lookup x i) of λ where
                                              (imap f) → f iv

-- This is an inductive type for tensors
data Tensor {a} (X : Set a) : (n : ℕ) → (s : Vec ℕ n) → Set a where
  zz : (x : X) → Tensor X 0 []
  ss : ∀ {n m}{s : Vec ℕ n} → (v : Vec (Tensor X n s) m) → Tensor X (1 + n) (m ∷ s)

-- Ugh, well...  This is big because we have to formulate point-wise equality.
data EqTen {a} (X : Set a) : (n : ℕ) → ∀ {s s₁} → Tensor X n s → Tensor X n s₁ → Set a where
  zeq : ∀ {x} → EqTen X 0 (zz x) (zz x)
  s[] : ∀ {n}{s s₁ : Vec ℕ n}
        → (∀ i → lookup s i ≡ lookup s₁ i)
        → EqTen X (1 + n) (ss {s = s} []) (ss {s = s₁} [])
  s∷ : ∀ {n}{s s₁ : Vec ℕ n}{m}
        → (∀ i → lookup s i ≡ lookup s₁ i)
        → ∀ {x y xs ys}
        → EqTen X n {s = s} {s₁ = s₁} x y
        → EqTen X (1 + n) (ss {m = m} xs) (ss {m = m} ys)
        → EqTen X (1 + n) (ss (x ∷ xs)) (ss (y ∷ ys))

a→tensor : ∀ {a}{X : Set a}{n s} → Ar X n s → Tensor X n s
a→tensor {n = zero} {s = []} (imap f) = zz (f [])
a→tensor {n = suc n}{s = s ∷ _} (imap f) = ss $ tabulate λ i → a→tensor (imap (λ iv → f (i ∷ iv)))

tensor→a : ∀ {a}{X : Set a}{n s} → Tensor X n s → Ar X n s --(lookup s)
tensor→a {s = []} (zz x) = imap (λ _ → x)
tensor→a {s = a ∷ s} (ss v) = imap λ where
                                 (i ∷ iv) → case tensor→a (lookup v i) of λ where
                                               (imap f) → f iv

t→rt : ∀ {a}{X : Set a}{n s} → Tensor X n s → repr-t X n s
t→rt {s = []} (zz x) = x
t→rt {s = x₁ ∷ s} (ss v) = V.map t→rt v

rt→t : ∀ {a}{X : Set a}{n s} → repr-t X n s → Tensor X n s
rt→t {s = []}     x = zz x
rt→t {s = _ ∷ _} x = ss (V.map rt→t x)

module test-repr where
    a : Ar ℕ 2 (3 ∷ 3 ∷ [])
    a = cst 42

    at = (a→tensor a)
    aₜ = tensor→a at

    rt = a→rt a
    a₁ = rt→a {n = 2} {s = 3 ∷ 3 ∷ []} rt

    test₁ : t→rt at ≡ rt
    test₁ = refl

    -- This one is quite tricky to show
    --test₂ : ∀ iv → sel a₁ iv ≡ sel aₜ iv
    --test₂ iv = {!!}


------------------------------------------------------------------------
-- The Agda standard library
--
-- Properties of the extensional sublist relation over setoid equality.
------------------------------------------------------------------------

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

open import Relation.Binary hiding (Decidable)

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

open import Data.Bool.Base using (Bool; true; false)
open import Data.List.Base
open import Data.List.Relation.Unary.Any using (here; there)
import Data.List.Membership.Setoid as Membership
open import Data.List.Membership.Setoid.Properties
import Data.List.Relation.Binary.Subset.Setoid as Sublist
import Data.List.Relation.Binary.Equality.Setoid as Equality
open import Relation.Nullary using (¬_; does)
open import Relation.Unary using (Pred; Decidable)
import Relation.Binary.Reasoning.Preorder as PreorderReasoning

open Setoid using (Carrier)

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

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

  open Equality S
  open Sublist S
  open Membership S

  ⊆-reflexive : _≋_ ⇒ _⊆_
  ⊆-reflexive xs≋ys = ∈-resp-≋ S xs≋ys

  ⊆-refl : Reflexive _⊆_
  ⊆-refl x∈xs = x∈xs

  ⊆-trans : Transitive _⊆_
  ⊆-trans xs⊆ys ys⊆zs x∈xs = ys⊆zs (xs⊆ys x∈xs)

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

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

  -- Reasoning over subsets
  module ⊆-Reasoning where
    private
      module Base = PreorderReasoning ⊆-preorder

    open Base public
      hiding (step-∼; step-≈; step-≈˘)
      renaming (_≈⟨⟩_ to _≋⟨⟩_)

    infix 2 step-⊆ step-≋ step-≋˘
    infix 1 step-∈

    step-∈ : ∀ x {xs ys} → xs IsRelatedTo ys → x ∈ xs → x ∈ ys
    step-∈ x xs⊆ys x∈xs = (begin xs⊆ys) x∈xs

    step-⊆  = Base.step-∼
    step-≋  = Base.step-≈
    step-≋˘ = Base.step-≈˘

    syntax step-∈  x  xs⊆ys x∈xs  = x  ∈⟨  x∈xs  ⟩ xs⊆ys
    syntax step-⊆  xs ys⊆zs xs⊆ys = xs ⊆⟨  xs⊆ys ⟩ ys⊆zs
    syntax step-≋  xs ys⊆zs xs≋ys = xs ≋⟨  xs≋ys ⟩ ys⊆zs
    syntax step-≋˘ xs ys⊆zs xs≋ys = xs ≋˘⟨ xs≋ys ⟩ ys⊆zs

------------------------------------------------------------------------
-- filter

module _ {a p ℓ} (S : Setoid a ℓ)
         {P : Pred (Carrier S) p} (P? : Decidable P) where

  open Setoid S renaming (Carrier to A)
  open Sublist S

  filter⁺ : ∀ xs → filter P? xs ⊆ xs
  filter⁺ (x ∷ xs) y∈f[x∷xs] with does (P? x)
  ... | false = there (filter⁺ xs y∈f[x∷xs])
  ... | true  with y∈f[x∷xs]
  ...   | here  y≈x     = here y≈x
  ...   | there y∈f[xs] = there (filter⁺ xs y∈f[xs])


module Cats.Category.Wedges where

open import Level using (_⊔_ ; suc)
open import Relation.Binary using (Rel ; IsEquivalence)

open import Cats.Category
open import Cats.Category.Setoids using (Setoids)
open import Cats.Profunctor
open import Cats.Util.Function using (_on_ ; on-isEquivalence)

module _ {lo la l≈ lo′ la′ l≈′}
  {C : Category lo la l≈} {D : Category lo′ la′ l≈′}
  (F : Profunctor C C D)
  where

  private
    module C = Category C
    module D = Category D
    module F = Profunctor F

  record Wedge : Set (lo ⊔ la ⊔ lo′ ⊔ la′ ⊔ l≈′) where
    open D

    field
      Apex : Obj
      arr : ∀ x → Apex ⇒ pobj F x x
      commute : ∀ {a b} (f : a C.⇒ b)
        → pmap₂ F f ∘ arr a ≈ pmap₁ F f ∘ arr b

  Obj = Wedge

  record _⇒_ (A B : Obj) : Set (lo ⊔ la′ ⊔ l≈′) where
    open Wedge
    open D

    field
      θ : Apex A D.⇒ Apex B
      commute : ∀ x → arr B x ∘ θ ≈ arr A x

  _≈_ : ∀ {A B} → Rel (A ⇒ B) l≈′
  _≈_ = D._≈_ on _⇒_.θ

  equiv : ∀ {A B} → IsEquivalence (_≈_ {A} {B})
  equiv = on-isEquivalence _⇒_.θ D.equiv

  id : ∀ {A} → A ⇒ A
  id = record
    { θ = D.id
    ; commute = λ x → D.id-r
    }

  _∘_ : ∀ {A B C} → B ⇒ C → A ⇒ B → A ⇒ C
  _∘_ {A} {B} {C} f g = record
    { θ = θ f ∘S θ g
    ; commute = λ j →
        begin
          arr C j ∘S θ f ∘S θ g
        ≈⟨ D.unassoc ⟩
          (arr C j ∘S θ f) ∘S θ g
        ≈⟨ D.∘-resp-l (commute f j) ⟩
          arr B j ∘S θ g
        ≈⟨ commute g j ⟩
          arr A j
        ∎
    }
    where
      open Wedge using (arr)
      open _⇒_
      open D using () renaming (_∘_ to _∘S_)
      open D.≈-Reasoning

  Wedges : Category (lo ⊔ la ⊔ lo′ ⊔ la′ ⊔ l≈′) (lo ⊔ la′ ⊔ l≈′) l≈′
  Wedges = record
    { Obj = Obj
    ; _⇒_ = _⇒_
    ; _≈_ = _≈_
    ; id = id
    ; _∘_ = _∘_
    ; equiv = equiv
    ; ∘-resp = D.∘-resp
    ; id-r = D.id-r
    ; id-l = D.id-l
    ; assoc = D.assoc
    }


module Pi-.Dir where
open import Relation.Binary.PropositionalEquality

data Dir : Set where
  ◁ : Dir
  ▷ : Dir

-ᵈⁱʳ_ : Dir → Dir
-ᵈⁱʳ ▷ = ◁
-ᵈⁱʳ ◁ = ▷

_×ᵈⁱʳ_ : Dir → Dir → Dir
◁ ×ᵈⁱʳ ◁ = ▷
◁ ×ᵈⁱʳ ▷ = ◁
▷ ×ᵈⁱʳ ◁ = ◁
▷ ×ᵈⁱʳ ▷ = ▷

identˡᵈⁱʳ : ∀ d → ▷ ×ᵈⁱʳ d ≡ d
identˡᵈⁱʳ ◁ = refl
identˡᵈⁱʳ ▷ = refl

assoclᵈⁱʳ : ∀ d₁ d₂ d₃ → d₁ ×ᵈⁱʳ (d₂ ×ᵈⁱʳ d₃) ≡ (d₁ ×ᵈⁱʳ d₂) ×ᵈⁱʳ d₃
assoclᵈⁱʳ ◁ ◁ ◁ = refl
assoclᵈⁱʳ ◁ ◁ ▷ = refl
assoclᵈⁱʳ ◁ ▷ ◁ = refl
assoclᵈⁱʳ ◁ ▷ ▷ = refl
assoclᵈⁱʳ ▷ ◁ ◁ = refl
assoclᵈⁱʳ ▷ ◁ ▷ = refl
assoclᵈⁱʳ ▷ ▷ ◁ = refl
assoclᵈⁱʳ ▷ ▷ ▷ = refl

commᵈⁱʳ : ∀ d₁ d₂ → d₁ ×ᵈⁱʳ d₂ ≡ d₂ ×ᵈⁱʳ d₁
commᵈⁱʳ ◁ ◁ = refl
commᵈⁱʳ ◁ ▷ = refl
commᵈⁱʳ ▷ ◁ = refl
commᵈⁱʳ ▷ ▷ = refl

assocl-commᵈⁱʳ : ∀ d₁ d₂ d₃ → d₁ ×ᵈⁱʳ (d₂ ×ᵈⁱʳ d₃) ≡ (d₂ ×ᵈⁱʳ d₁) ×ᵈⁱʳ d₃
assocl-commᵈⁱʳ ◁ ◁ ◁ = refl
assocl-commᵈⁱʳ ◁ ◁ ▷ = refl
assocl-commᵈⁱʳ ◁ ▷ ◁ = refl
assocl-commᵈⁱʳ ◁ ▷ ▷ = refl
assocl-commᵈⁱʳ ▷ ◁ ◁ = refl
assocl-commᵈⁱʳ ▷ ◁ ▷ = refl
assocl-commᵈⁱʳ ▷ ▷ ◁ = refl
assocl-commᵈⁱʳ ▷ ▷ ▷ = refl

assoc-commᵈⁱʳ : ∀ d₁ d₂ d₃ → d₁ ×ᵈⁱʳ (d₂ ×ᵈⁱʳ d₃) ≡ d₂ ×ᵈⁱʳ (d₁ ×ᵈⁱʳ d₃)
assoc-commᵈⁱʳ ◁ ◁ ◁ = refl
assoc-commᵈⁱʳ ◁ ◁ ▷ = refl
assoc-commᵈⁱʳ ◁ ▷ ◁ = refl
assoc-commᵈⁱʳ ◁ ▷ ▷ = refl
assoc-commᵈⁱʳ ▷ ◁ ◁ = refl
assoc-commᵈⁱʳ ▷ ◁ ▷ = refl
assoc-commᵈⁱʳ ▷ ▷ ◁ = refl
assoc-commᵈⁱʳ ▷ ▷ ▷ = refl


-- Paths in a graph
{-# OPTIONS --safe #-}

module Cubical.Data.Graph.Path where

open import Cubical.Data.Graph.Base
open import Cubical.Data.List.Base hiding (_++_)
open import Cubical.Data.Nat.Base
open import Cubical.Data.Nat.Properties
open import Cubical.Data.Sigma.Base hiding (Path)
open import Cubical.Foundations.HLevels
open import Cubical.Foundations.Prelude hiding (Path)

module _ {ℓv ℓe : Level} where

  module _ (G : Graph ℓv ℓe) where
    data Path : (v w : Node G) → Type (ℓ-max ℓv ℓe) where
      pnil : ∀ {v} → Path v v
      pcons : ∀ {v w x} → Path v w → Edge G w x → Path v x

    -- Path concatenation
    ccat : ∀ {v w x} → Path v w → Path w x → Path v x
    ccat P pnil = P
    ccat P (pcons Q e) = pcons (ccat P Q) e

    private
      _++_ = ccat
      infixr 20 _++_

    -- Some properties
    pnil++ : ∀ {v w} (P : Path v w) → pnil ++ P ≡ P
    pnil++ pnil = refl
    pnil++ (pcons P e) = cong (λ P → pcons P e) (pnil++ _)

    ++assoc : ∀ {v w x y}
        (P : Path v w) (Q : Path w x) (R : Path x y)
      → (P ++ Q) ++ R ≡ P ++ (Q ++ R)
    ++assoc P Q pnil = refl
    ++assoc P Q (pcons R e) = cong (λ P → pcons P e) (++assoc P Q R)

    -- Paths as lists
    pathToList : ∀ {v w} → Path v w
        → List (Σ[ x ∈ Node G ] Σ[ y ∈ Node G ] Edge G x y)
    pathToList pnil = []
    pathToList (pcons P e) = (_ , _ , e) ∷ (pathToList P)

    -- Path v w is a set
    -- Lemma 4.2 of https://arxiv.org/abs/2112.06609
    module _ (isSetNode : isSet (Node G))
             (isSetEdge : ∀ v w → isSet (Edge G v w)) where

      -- This is called ̂W (W-hat) in the paper
      PathWithLen : ℕ → Node G → Node G → Type (ℓ-max ℓv ℓe)
      PathWithLen 0 v w = Lift {j = ℓe} (v ≡ w)
      PathWithLen (suc n) v w = Σ[ k ∈ Node G ] (PathWithLen n v k × Edge G k w)

      isSetPathWithLen : ∀ n v w → isSet (PathWithLen n v w)
      isSetPathWithLen 0 _ _ = isOfHLevelLift 2 (isProp→isSet (isSetNode _ _))
      isSetPathWithLen (suc n) _ _ = isSetΣ isSetNode λ _ →
          isSet× (isSetPathWithLen _ _ _) (isSetEdge _ _)

      isSet-ΣnPathWithLen : ∀ {v w} → isSet (Σ[ n ∈ ℕ ] PathWithLen n v w)
      isSet-ΣnPathWithLen = isSetΣ isSetℕ (λ _ → isSetPathWithLen _ _ _)

      Path→PathWithLen : ∀ {v w} → Path v w → Σ[ n ∈ ℕ ] PathWithLen n v w
      Path→PathWithLen pnil = 0 , lift refl
      Path→PathWithLen (pcons P e) = suc (Path→PathWithLen P .fst) ,
                                          _ , Path→PathWithLen P .snd , e

      PathWithLen→Path : ∀ {v w} → Σ[ n ∈ ℕ ] PathWithLen n v w → Path v w
      PathWithLen→Path (0 , q) = subst (Path _) (q .lower) pnil
      PathWithLen→Path (suc n , _ , pwl , e) = pcons (PathWithLen→Path (n , pwl)) e

      Path→PWL→Path : ∀ {v w} P → PathWithLen→Path {v} {w} (Path→PathWithLen P) ≡ P
      Path→PWL→Path {v} pnil = substRefl {B = Path v} pnil
      Path→PWL→Path (pcons P x) = cong₂ pcons (Path→PWL→Path _) refl

      isSetPath : ∀ v w → isSet (Path v w)
      isSetPath v w = isSetRetract Path→PathWithLen PathWithLen→Path
                                   Path→PWL→Path isSet-ΣnPathWithLen


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

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

open import Numbers.ClassicalReals.RealField
open import LogicalFormulae
open import Setoids.Subset
open import Setoids.Setoids
open import Setoids.Orders
open import Sets.EquivalenceRelations
open import Rings.Orders.Total.Definition
open import Rings.Orders.Partial.Definition
open import Rings.Definition
open import Fields.Fields
open import Groups.Definition
open import Numbers.Naturals.Semiring
open import Numbers.Naturals.Order
open import Numbers.Naturals.Order.Lemmas
open import Sequences

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

open RealField ℝ
open Setoid S
open Equivalence eq
open Ring R
open Field F
open SetoidPartialOrder pOrder
open import Fields.Orders.LeastUpperBounds.Definition pOrder
open import Rings.Orders.Total.Lemmas orderedRing
open import Rings.Orders.Partial.Lemmas pOrderedRing
open Group additiveGroup
open PartiallyOrderedRing pOrderedRing
open SetoidTotalOrder (TotallyOrderedRing.total orderedRing)
open import Rings.InitialRing R
open import Fields.Orders.Lemmas oField
open import Rings.Lemmas R
open import Groups.Lemmas additiveGroup
open import Numbers.Intervals.Definition pOrderedRing
open import Numbers.Intervals.Arithmetic pOrderedRing
open import Fields.Lemmas F
open import Fields.Orders.Total.Definition F

orderedField : TotallyOrderedField pOrderedRing
orderedField = record { oRing = orderedRing }

open import Fields.Orders.Limits.Definition orderedField

StrictlyIncreasing : Sequence A → Set c
StrictlyIncreasing x = (n : ℕ) → (index x n) < (index x (succ n))

Increasing : Sequence A → Set (b ⊔ c)
Increasing x = (n : ℕ) → ((index x n) < (index x (succ n))) || ((index x n) ∼ (index x (succ n)))

sequencePredicate : (x : Sequence A) → A → Set b
sequencePredicate x a = Sg ℕ (λ n → index x n ∼ a)

sequenceSubset : (x : Sequence A) → subset S (sequencePredicate x)
sequenceSubset sequence {x} {y} x=y (n , sn=x) = n , transitive sn=x x=y

boundedSequenceBounds : (K : A) (x : Sequence A) → ((n : ℕ) → index x n < K) → UpperBound (sequenceSubset x) K
boundedSequenceBounds K x pr y (n , y=xn) = inl (<WellDefined y=xn reflexive (pr n))

increasingBoundedLimit : (x : Sequence A) → Increasing x → Bounded x → A
increasingBoundedLimit x increasing (K , kIsBound) with lub (sequenceSubset x) ((index x 0) , (0 , reflexive)) (K , boundedSequenceBounds K x kIsBound)
... | a , _ = a

increasingBoundedConverges : (x : Sequence A) → (increasing : Increasing x) → (bounded : Bounded x) → x ~> (increasingBoundedLimit x increasing bounded)
increasingBoundedConverges x increasing (K , prBound) with lub (sequenceSubset x) (Sequence.head x , (0 , reflexive)) (K , boundedSequenceBounds K x prBound)
... | lub , isLub = {!!}


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

module Categories.Category.Monoidal.Instance.Setoids where

open import Level
open import Data.Product
open import Data.Product.Relation.Binary.Pointwise.NonDependent
open import Data.Sum
open import Data.Sum.Relation.Binary.Pointwise
open import Function.Equality
open import Relation.Binary using (Setoid)

open import Categories.Category
open import Categories.Category.Instance.Setoids
open import Categories.Category.Cartesian
open import Categories.Category.Cocartesian
open import Categories.Category.Instance.SingletonSet
open import Categories.Category.Instance.EmptySet

module _ {o ℓ} where

  Setoids-Cartesian : Cartesian (Setoids o ℓ)
  Setoids-Cartesian = record
    { terminal = SingletonSetoid-⊤
    ; products = record
      { product = λ {A B} →
        let module A = Setoid A
            module B = Setoid B
         in record
          { A×B      = ×-setoid A B -- the stdlib doesn't provide projections!
          ; π₁       = record
            { _⟨$⟩_ = proj₁
            ; cong  = proj₁
            }
          ; π₂       = record
            { _⟨$⟩_ = proj₂
            ; cong  = proj₂
            }
          ; ⟨_,_⟩    = λ f g → record
            { _⟨$⟩_ = λ x → f ⟨$⟩ x , g ⟨$⟩ x
            ; cong  = λ eq → cong f eq , cong g eq
            }
          ; project₁ = λ {_ h i} eq → cong h eq
          ; project₂ = λ {_ h i} eq → cong i eq
          ; unique   = λ {W h i j} eq₁ eq₂ eq → A.sym (eq₁ (Setoid.sym W eq)) , B.sym (eq₂ (Setoid.sym W eq))
          }
      }
    }

  module Setoids-Cartesian = Cartesian Setoids-Cartesian
  open Setoids-Cartesian renaming (monoidal to Setoids-Monoidal) public

  Setoids-Cocartesian : Cocartesian (Setoids o (o ⊔ ℓ))
  Setoids-Cocartesian = record
    { initial = EmptySetoid-⊥
    ; coproducts = record
      { coproduct = λ {A} {B} → record
        { A+B = ⊎-setoid A B
        ; i₁ = record { _⟨$⟩_ = inj₁ ; cong = inj₁ }
        ; i₂ = record { _⟨$⟩_ = inj₂ ; cong = inj₂ }
        ; [_,_] = λ f g → record
          { _⟨$⟩_ = [ f ⟨$⟩_ , g ⟨$⟩_ ]
          ; cong = λ { (inj₁ x) → Π.cong f x ; (inj₂ x) → Π.cong g x }
          }
        ; inject₁ = λ {_} {f} → Π.cong f
        ; inject₂ = λ {_} {_} {g} → Π.cong g
        ; unique = λ { {C} h≈f h≈g (inj₁ x) → Setoid.sym C (h≈f (Setoid.sym A x))
                     ; {C} h≈f h≈g (inj₂ x) → Setoid.sym C (h≈g (Setoid.sym B x)) }
        }
      }
    }


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

module Cubical.Homotopy.Loopspace where

open import Cubical.Core.Everything

open import Cubical.Data.Nat

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Pointed
open import Cubical.Foundations.GroupoidLaws

{- loop space of a pointed type -}
Ω : {ℓ : Level} → Pointed ℓ → Pointed ℓ
Ω (_ , a) = ((a ≡ a) , refl)

{- n-fold loop space of a pointed type -}
Ω^_ : ∀ {ℓ} → ℕ → Pointed ℓ → Pointed ℓ
(Ω^ 0) p = p
(Ω^ (suc n)) p = Ω ((Ω^ n) p)

{- loop space map -}
Ω→ : ∀ {ℓA ℓB} {A : Pointed ℓA} {B : Pointed ℓB} (f : A →∙ B) → (Ω A →∙ Ω B)
Ω→ (f , f∙) = (λ p → (sym f∙ ∙ cong f p) ∙ f∙) , cong (λ q → q ∙ f∙) (sym (rUnit (sym f∙))) ∙ lCancel f∙


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

-- The Category of Presheaves over a Category C, i.e.
-- the Functor Category [ C.op , Setoids ]
-- Again, the levels are made explicit to show the generality and constraints.
open import Level

open import Categories.Category
open import Categories.Category.Construction.Functors
open import Categories.Category.Instance.Setoids using (Setoids)

Presheaves : ∀ {o ℓ e o′ ℓ′ : Level} → Category o ℓ e →
  Category (o ⊔ ℓ ⊔ e ⊔ suc (o′ ⊔ ℓ′)) (o ⊔ ℓ ⊔ o′ ⊔ ℓ′) (o ⊔ o′ ⊔ ℓ′)
Presheaves {o} {ℓ} {e} {o′} {ℓ′} C = Functors (Category.op C) (Setoids o′ ℓ′)


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

open import LogicalFormulae
open import Groups.Homomorphisms.Definition
open import Groups.Definition
open import Setoids.Setoids
open import Sets.EquivalenceRelations
open import Rings.Definition
open import Lists.Lists
open import Rings.Homomorphisms.Definition

module Rings.Polynomial.Evaluation {a b : _} {A : Set a} {S : Setoid {a} {b} A} {_+_ _*_ : A → A → A} (R : Ring S _+_ _*_) where

open Ring R
open Setoid S
open Equivalence eq
open Group additiveGroup
open import Groups.Polynomials.Definition additiveGroup
open import Groups.Polynomials.Addition additiveGroup
open import Rings.Polynomial.Ring R
open import Rings.Polynomial.Multiplication R

inducedFunction : NaivePoly → A → A
inducedFunction [] a = 0R
inducedFunction (x :: p) a = x + (a * inducedFunction p a)

inducedFunctionMult : (as : NaivePoly) (b c : A) → inducedFunction (map (_*_ b) as) c ∼ (inducedFunction as c) * b
inducedFunctionMult [] b c = symmetric (transitive *Commutative timesZero)
inducedFunctionMult (x :: as) b c = transitive (transitive (+WellDefined reflexive (transitive (transitive (*WellDefined reflexive (inducedFunctionMult as b c)) *Associative) *Commutative)) (symmetric *DistributesOver+)) *Commutative

inducedFunctionWellDefined : {a b : NaivePoly} → polysEqual a b → (c : A) → inducedFunction a c ∼ inducedFunction b c
inducedFunctionWellDefined {[]} {[]} a=b c = reflexive
inducedFunctionWellDefined {[]} {x :: b} (fst ,, snd) c = symmetric (transitive (+WellDefined fst (transitive (*WellDefined reflexive (symmetric (inducedFunctionWellDefined {[]} {b} snd c))) (timesZero {c}))) identRight)
inducedFunctionWellDefined {a :: as} {[]} (fst ,, snd) c = transitive (+WellDefined fst reflexive) (transitive identLeft (transitive (*WellDefined reflexive (inducedFunctionWellDefined {as} {[]} snd c)) (timesZero {c})))
inducedFunctionWellDefined {a :: as} {b :: bs} (fst ,, snd) c = +WellDefined fst (*WellDefined reflexive (inducedFunctionWellDefined {as} {bs} snd c))

inducedFunctionGroupHom : {x y : NaivePoly} → (a : A) → inducedFunction (x +P y) a ∼ (inducedFunction x a + inducedFunction y a)
inducedFunctionGroupHom {[]} {[]} a = symmetric identLeft
inducedFunctionGroupHom {[]} {x :: y} a rewrite mapId y = symmetric identLeft
inducedFunctionGroupHom {x :: xs} {[]} a rewrite mapId xs = symmetric identRight
inducedFunctionGroupHom {x :: xs} {y :: ys} a = transitive (symmetric +Associative) (transitive (+WellDefined reflexive (transitive (transitive (+WellDefined reflexive (transitive (*WellDefined reflexive (transitive (inducedFunctionGroupHom {xs} {ys} a) groupIsAbelian)) *DistributesOver+)) +Associative) groupIsAbelian)) +Associative)

inducedFunctionRingHom : (r s : NaivePoly) (a : A) → inducedFunction (r *P s) a ∼ (inducedFunction r a * inducedFunction s a)
inducedFunctionRingHom [] s a = symmetric (transitive *Commutative timesZero)
inducedFunctionRingHom (x :: xs) [] a = symmetric timesZero
inducedFunctionRingHom (b :: bs) (c :: cs) a = transitive (+WellDefined reflexive (*WellDefined reflexive (inducedFunctionGroupHom {map (_*_ b) cs +P map (_*_ c) bs} {0G :: (bs *P cs)} a))) (transitive (+WellDefined reflexive (*WellDefined reflexive (+WellDefined (inducedFunctionGroupHom {map (_*_ b) cs} {map (_*_ c) bs} a) identLeft))) (transitive (transitive (transitive (+WellDefined reflexive (transitive (transitive (transitive (*WellDefined reflexive (transitive (+WellDefined (transitive groupIsAbelian (+WellDefined (inducedFunctionMult bs c a) (inducedFunctionMult cs b a))) (transitive (transitive (*WellDefined reflexive (transitive (inducedFunctionRingHom bs cs a) *Commutative)) *Associative) *Commutative)) (symmetric +Associative))) *DistributesOver+) (+WellDefined reflexive *DistributesOver+)) (+WellDefined *Associative (+WellDefined (transitive *Associative *Commutative) *Associative)))) +Associative) (+WellDefined (symmetric *DistributesOver+') (symmetric *DistributesOver+'))) (symmetric *DistributesOver+)))

inducedFunctionIsHom : (a : A) → RingHom polyRing R (λ p → inducedFunction p a)
RingHom.preserves1 (inducedFunctionIsHom a) = transitive (+WellDefined reflexive (timesZero {a})) identRight
RingHom.ringHom (inducedFunctionIsHom a) {r} {s} = inducedFunctionRingHom r s a
GroupHom.groupHom (RingHom.groupHom (inducedFunctionIsHom a)) {x} {y} = inducedFunctionGroupHom {x} {y} a
GroupHom.wellDefined (RingHom.groupHom (inducedFunctionIsHom a)) x=y = inducedFunctionWellDefined x=y a


------------------------------------------------------------------------------
-- The map-iterate property: A property using co-induction
------------------------------------------------------------------------------

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

-- The map-iterate property (Gibbons and Hutton, 2005):
-- map f (iterate f x) = iterate f (f · x)

module FOTC.Program.MapIterate.MapIterateATP where

open import FOTC.Base
open import FOTC.Base.List
open import FOTC.Data.List
open import FOTC.Relation.Binary.Bisimilarity.Type

------------------------------------------------------------------------------
-- The map-iterate property.
≈-map-iterate : ∀ f x → map f (iterate f x) ≈ iterate f (f · x)
≈-map-iterate f x = ≈-coind B h₁ h₂
  where
  -- Based on the relation used by (Giménez and Castéran, 2007).
  B : D → D → Set
  B xs ys = ∃[ y ] xs ≡ map f (iterate f y) ∧ ys ≡ iterate f (f · y)
  {-# ATP definition B #-}

  postulate
    h₁ : ∀ {xs} {ys} → B xs ys →
         ∃[ x' ] ∃[ xs' ] ∃[ ys' ] xs ≡ x' ∷ xs' ∧ ys ≡ x' ∷ ys' ∧ B xs' ys'
  {-# ATP prove h₁ #-}

  postulate h₂ : B (map f (iterate f x)) (iterate f (f · x))
  {-# ATP prove h₂ #-}

------------------------------------------------------------------------------
-- References
--
-- Giménez, Eduardo and Casterán, Pierre (2007). A Tutorial on
-- [Co-]Inductive Types in Coq.
--
-- Gibbons, Jeremy and Hutton, Graham (2005). Proof Methods for
-- Corecursive Programs. Fundamenta Informaticae XX, pp. 1–14.


------------------------------------------------------------------------
-- Function setoids and related constructions
------------------------------------------------------------------------

module Relation.Binary.FunctionSetoid where

open import Data.Function
open import Relation.Binary

infixr 0 _↝_ _⟶_ _⇨_ _≡⇨_

-- A logical relation (i.e. a relation which relates functions which
-- map related things to related things).

_↝_ : ∀ {A B} → (∼₁ : Rel A) (∼₂ : Rel B) → Rel (A → B)
_∼₁_ ↝ _∼₂_ = λ f g → ∀ {x y} → x ∼₁ y → f x ∼₂ g y

-- Functions which preserve equality.

record _⟶_ (From To : Setoid) : Set where
  open Setoid
  infixl 5 _⟨$⟩_
  field
    _⟨$⟩_ : carrier From → carrier To
    pres  : _⟨$⟩_ Preserves _≈_ From ⟶ _≈_ To

open _⟶_ public

↝-isEquivalence : ∀ {A B C} {∼₁ : Rel A} {∼₂ : Rel B}
                  (fun : C → (A → B)) →
                  (∀ f → fun f Preserves ∼₁ ⟶ ∼₂) →
                  IsEquivalence ∼₁ → IsEquivalence ∼₂ →
                  IsEquivalence ((∼₁ ↝ ∼₂) on₁ fun)
↝-isEquivalence _ pres eq₁ eq₂ = record
  { refl  = λ {f} x∼₁y → pres f x∼₁y
  ; sym   = λ f∼g x∼y → sym eq₂ (f∼g (sym eq₁ x∼y))
  ; trans = λ f∼g g∼h x∼y → trans eq₂ (f∼g (refl eq₁)) (g∼h x∼y)
  } where open IsEquivalence

-- Function setoids.

_⇨_ : Setoid → Setoid → Setoid
S₁ ⇨ S₂ = record
  { carrier       = S₁ ⟶ S₂
  ; _≈_           = (_≈_ S₁ ↝ _≈_ S₂) on₁ _⟨$⟩_
  ; isEquivalence =
      ↝-isEquivalence _⟨$⟩_ pres (isEquivalence S₁) (isEquivalence S₂)
  } where open Setoid; open _⟶_

-- A generalised variant of (_↝_ _≡_).

≡↝ : ∀ {A} {B : A → Set} → (∀ x → Rel (B x)) → Rel ((x : A) → B x)
≡↝ R = λ f g → ∀ x → R x (f x) (g x)

≡↝-isEquivalence : {A : Set} {B : A → Set} {R : ∀ x → Rel (B x)} →
                   (∀ x → IsEquivalence (R x)) → IsEquivalence (≡↝ R)
≡↝-isEquivalence eq = record
  { refl  = λ _ → refl
  ; sym   = λ f∼g x → sym (f∼g x)
  ; trans = λ f∼g g∼h x → trans (f∼g x) (g∼h x)
  } where open module Eq {x} = IsEquivalence (eq x)

_≡⇨_ : (A : Set) → (A → Setoid) → Setoid
A ≡⇨ S = record
  { carrier       = (x : A) → carrier (S x)
  ; _≈_           = ≡↝ (λ x → _≈_ (S x))
  ; isEquivalence = ≡↝-isEquivalence (λ x → isEquivalence (S x))
  } where open Setoid


module Metalogic.Classical.Propositional.TruthSemanticsModel {ℓ} (Proposition : Set(ℓ)) where

import      Lvl
open import Data.Boolean
open import Data
open import Data.Tuple as Tuple using (_⨯_ ; _,_)
open import Functional
open import Metalogic.Classical.Propositional.Syntax{ℓ} (Proposition)
  renaming (
    ⊤   to ⊤ₗ ;
    ⊥   to ⊥ₗ ;
    ¬_  to ¬ₗ_ ;
    _∧_ to _∧ₗ_ ;
    _∨_ to _∨ₗ_ ;
    _⇒_ to _⇒ₗ_ )
open import Relator.Equals
open import Relator.Equals.Proofs
open import Sets.BoolSet

-- A model decides whether a proposition is true or false
-- Also known as Interpretation, Structure, Model
record Model : Set(ℓ) where
  field
    interpretProp : Proposition → Bool

-- TODO: Can this be called a "theory" of propositional logic? So that instances of the type Semantics is the "models" of logic?
-- TODO: Now, all the metalogic depends on booleans, which may not be satisfactory
module _ where
  import      Data.Boolean.Operators
  open        Data.Boolean.Operators.Logic

  satisfaction : Model → Formula → Bool
  satisfaction(𝔐)(• prop) = Model.interpretProp(𝔐) (prop)
  satisfaction(𝔐)(⊤ₗ) = 𝑇
  satisfaction(𝔐)(⊥ₗ) = 𝐹
  satisfaction(𝔐)(¬ₗ φ) = ¬(satisfaction(𝔐)(φ))
  satisfaction(𝔐)(φ₁ ∧ₗ φ₂) = (satisfaction(𝔐)(φ₁)) ∧ (satisfaction(𝔐)(φ₂))
  satisfaction(𝔐)(φ₁ ∨ₗ φ₂) = (satisfaction(𝔐)(φ₁)) ∨ (satisfaction(𝔐)(φ₂))
  satisfaction(𝔐)(φ₁ ⇒ₗ φ₂) = ¬(satisfaction(𝔐)(φ₁)) ∨ (satisfaction(𝔐)(φ₂))

  -- Syntactic details with the relation symbol
  record SatisfactionRelation {ℓ₁}{ℓ₂} (Obj : Set(ℓ) → Set(ℓ₁)) : Set(Lvl.𝐒(ℓ Lvl.⊔ ℓ₁ Lvl.⊔ ℓ₂)) where
    field
      _⊧_ : Model → Obj(Formula) → Set(ℓ₂)
  open SatisfactionRelation ⦃ ... ⦄ public

  instance
    -- Satisfaction for a single formula
    formula-satisfaction-relation : SatisfactionRelation(id)
    formula-satisfaction-relation = record{_⊧_ = \𝔐 φ → satisfaction(𝔐)(φ) ≡ 𝑇}

  instance
    -- Satisfaction for a list of formulas
    list-satisfaction-relation : SatisfactionRelation(BoolSet{ℓ})
    list-satisfaction-relation = record{_⊧_ = \𝔐 Γ → (∀{γ} → (γ ∈ Γ) → satisfaction(𝔐)(γ) ≡ 𝑇)}

  -- Entailment
  data _⊨_ (Γ : BoolSet{ℓ}(Formula)) (φ : Formula) : Set(ℓ) where
    [⊨]-intro : (∀{𝔐} → (𝔐 ⊧ Γ) → (𝔐 ⊧ φ)) → (Γ ⊨ φ)

  _⊭_ : BoolSet{ℓ}(Formula) → Formula → Set(ℓ)
  _⊭_ Γ φ = (_⊨_ Γ φ) → Empty{ℓ}

  -- Validity
  valid : Formula → Set(ℓ)
  valid = (∅ ⊨_)

  module Theorems where
    [⊤]-entailment : (∅ ⊨ ⊤ₗ)
    [⊤]-entailment = [⊨]-intro(const [≡]-intro)
    -- ∅ ⊨ ⊤ₗ
    -- ∀{𝔐} → (𝔐 ⊧ ∅) → (𝔐 ⊧ ⊤ₗ)
    -- ∀{𝔐} → (𝔐 ⊧ ∅) → (satisfaction(𝔐)(⊤ₗ) ≡ 𝑇)
    -- ∀{𝔐} → (∀{γ} → (γ ∈ ∅) → satisfaction(𝔐)(γ) ≡ 𝑇) → (satisfaction(𝔐)(⊤ₗ) ≡ 𝑇)

    -- [∧]-entailment : ∀{φ₁ φ₂} → ([ φ₁ ⊰ φ₂ ] ⊨ (φ₁ ∧ₗ φ₂))
    -- [∧]-entailment{φ₁}{φ₂} = [⊨]-intro ([∈]-proof ↦ congruence₁-op(_∧_) ([∈]-proof (use)) ([∈]-proof (skip use)))
    -- [ φ₁ ⊰ φ₂ ] ⊨ (φ₁ ∧ φ₂)
    -- ∀{𝔐} → (𝔐 ⊧ [ φ₁ ⊰ φ₂ ]) → (𝔐 ⊧ (φ₁ ∧ φ₂))
    -- ∀{𝔐} → (𝔐 ⊧ [ φ₁ ⊰ φ₂ ]) → (satisfaction(𝔐)(φ₁ ∧ₗ φ₂) ≡ 𝑇)
    -- ∀{𝔐} → (𝔐 ⊧ [ φ₁ ⊰ φ₂ ]) → (satisfaction(𝔐)(φ₁) ∧ satisfaction(𝔐)(φ₂) ≡ 𝑇)
    -- ∀{𝔐} → (∀{γ} → (γ ∈ [ φ₁ ⊰ φ₂ ]) → satisfaction(𝔐)(γ) ≡ 𝑇) → (satisfaction(𝔐)(φ₁) ∧ satisfaction(𝔐)(φ₂) ≡ 𝑇)


open import Relation.Binary.PropositionalEquality using (_≡_; _≢_; refl)
open import Data.Fin using (Fin)
open import Data.Nat using (ℕ)
open import Data.Product using (_×_; _,_)
open import Data.Vec using (Vec; lookup; _[_]≔_)

open import Common

data Local (n : ℕ) : Set where
  endL : Local n
  sendSingle recvSingle : Fin n -> Label -> Local n -> Local n

private
  variable
    n : ℕ
    p p′ q : Fin n
    l l′ : Label
    lSub lSub′ : Local n

endL≢sendSingle : ∀ { lSub } -> endL {n} ≢ sendSingle q l lSub
endL≢sendSingle ()

endL≢recvSingle : ∀ { lSub } -> endL {n} ≢ recvSingle q l lSub
endL≢recvSingle ()

sendSingle-injective :
  sendSingle {n} p l lSub ≡ sendSingle p′ l′ lSub′
  -> p ≡ p′ × l ≡ l′ × lSub ≡ lSub′
sendSingle-injective refl = refl , refl , refl

recvSingle-injective :
  recvSingle {n} p l lSub ≡ recvSingle p′ l′ lSub′
  -> p ≡ p′ × l ≡ l′ × lSub ≡ lSub′
recvSingle-injective refl = refl , refl , refl

Configuration : ℕ -> Set
Configuration n = Vec (Local n) n

data _-_→l_ {n : ℕ} : (Fin n × Local n) -> Action n -> (Fin n × Local n) -> Set where
  →l-send :
    ∀ { lp lpSub }
    -> (p : Fin n)
    -> lp ≡ sendSingle q l lpSub
    -> (p≢q : p ≢ q)
    -> (p , lp) - (action p q p≢q l) →l (p , lpSub)
  →l-recv :
    ∀ { lp lpSub }
    -> (p : Fin n)
    -> lp ≡ recvSingle q l lpSub
    -> (q≢p : q ≢ p)
    -> (p , lp) - (action q p q≢p l) →l (p , lpSub)

data _-_→c_ {n : ℕ} : Configuration n -> Action n -> Configuration n -> Set where
  →c-comm :
    ∀ { lp lp′ lq lq′ c′ p≢q-p p≢q-q }
    -> (c : Configuration n)
    -> (p≢q : p ≢ q)
    -> lp ≡ lookup c p
    -> lq ≡ lookup c q
    -> c′ ≡ c [ p ]≔ lp′ [ q ]≔ lq′
    -> (p , lp) - (action p q p≢q-p l) →l (p , lp′)
    -> (q , lq) - (action p q p≢q-q l) →l (q , lq′)
    -> c - (action p q p≢q l) →c  c′


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

open import Prelude
open import Relation.Binary

module Relation.Binary.Construct.Decision
  {a ℓ₁ ℓ₂} {A : Type a}
  (ord : TotalOrder A ℓ₁ ℓ₂)
  where

open TotalOrder ord renaming (refl to ≤-refl)

_<′_ : A → A → Type
x <′ y = T (does (x <? y))

_≤′_ : A → A → Type
x ≤′ y = T (not (does (y <? x)))

witness-< : ∀ {x y} → x <′ y → x < y
witness-< {x} {y} p with x <? y
witness-< {x} {y} p | yes q = q

witness-≤ : ∀ {x y} → x ≤′ y → x ≤ y
witness-≤ {x} {y} p with y <? x
witness-≤ {x} {y} p | no q = ≮⇒≥ q

compute-< : ∀ {x y} → x < y → x <′ y
compute-< {x} {y} p with x <? y
compute-< {x} {y} p | yes q = tt
compute-< {x} {y} p | no ¬p = ⊥-elim (¬p p)

compute-≤ : ∀ {x y} → x ≤ y → x ≤′ y
compute-≤ {x} {y} ¬p with y <? x
compute-≤ {x} {y} ¬p | yes p = ⊥-elim (<⇒≱ p ¬p)
compute-≤ {x} {y} ¬p | no  _ = tt

≰⇒>′ : ∀ {x y} → ¬ (x ≤′ y) → y <′ x
≰⇒>′ {x} {y} p with y <? x
≰⇒>′ {x} {y} p | no  _ = p tt
≰⇒>′ {x} {y} p | yes _ = tt

≮⇒≥′ : ∀ {x y} → ¬ (x <′ y) → y ≤′ x
≮⇒≥′ {x} {y} p with x <? y
≮⇒≥′ {x} {y} p | no  _ = tt
≮⇒≥′ {x} {y} p | yes _ = p tt

dec-ord : TotalOrder A ℓzero ℓzero
StrictPreorder._<_    (StrictPartialOrder.strictPreorder (TotalOrder.strictPartialOrder dec-ord)) = _<′_
StrictPreorder.trans  (StrictPartialOrder.strictPreorder (TotalOrder.strictPartialOrder dec-ord)) p q = compute-< (<-trans (witness-< p) (witness-< q))
StrictPreorder.irrefl (StrictPartialOrder.strictPreorder (TotalOrder.strictPartialOrder dec-ord)) p = irrefl (witness-< p)
StrictPartialOrder.conn (TotalOrder.strictPartialOrder dec-ord) p q = conn (p ∘ compute-<) (q ∘ compute-<)
Preorder._≤_  (PartialOrder.preorder (TotalOrder.partialOrder dec-ord)) = _≤′_
Preorder.refl (PartialOrder.preorder (TotalOrder.partialOrder dec-ord)) = compute-≤ ≤-refl
PartialOrder.antisym (TotalOrder.partialOrder dec-ord) p q = antisym (witness-≤ p) (witness-≤ q)
Preorder.trans (PartialOrder.preorder (TotalOrder.partialOrder dec-ord)) p q = compute-≤ (≤-trans (witness-≤ p) (witness-≤ q))
TotalOrder._<?_ dec-ord x y = iff-dec (compute-< iff witness-<) (x <? y)
TotalOrder.≰⇒> dec-ord = ≰⇒>′
TotalOrder.≮⇒≥ dec-ord = ≮⇒≥′


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

-- The category of Cats is Monoidal

module Categories.Category.Monoidal.Instance.Cats where

open import Level

open import Categories.Category.BinaryProducts using (BinaryProducts)
open import Categories.Category.Cartesian using (Cartesian)
open import Categories.Category.Cartesian.Monoidal using (module CartesianMonoidal)
open import Categories.Category.Instance.Cats using (Cats)
open import Categories.Category.Instance.One using (One-⊤)
open import Categories.Category.Monoidal using (Monoidal)
open import Categories.Category.Product using (Product; πˡ; πʳ; _※_)
open import Categories.Category.Product.Properties using (project₁; project₂; unique)

-- Cats is a Monoidal Category with Product as Bifunctor
module Product {o ℓ e : Level} where
  private
    C = Cats o ℓ e

  Cats-has-all : BinaryProducts C
  Cats-has-all = record { product = λ {A} {B} → record
    { A×B = Product A B
    ; π₁ = πˡ
    ; π₂ = πʳ
    ; ⟨_,_⟩ = _※_
    ; project₁ = λ {_} {h} {i} → project₁ {i = h} {j = i}
    ; project₂ = λ {_} {h} {i} → project₂ {i = h} {j = i}
    ; unique = unique
    } }

  Cats-is : Cartesian C
  Cats-is = record { terminal = One-⊤ ; products = Cats-has-all }

  Cats-Monoidal : Monoidal C
  Cats-Monoidal = CartesianMonoidal.monoidal Cats-is


module List.Permutation.Base (A : Set) where

open import Data.List

data _/_⟶_ : List A → A → List A → Set where
  /head : {x : A}{xs : List A}
                   →  (x ∷ xs) / x ⟶ xs
  /tail : {x y : A}{xs ys : List A}
                   → xs / y ⟶ ys
                   → (x ∷ xs) / y ⟶ (x ∷ ys)

data _∼_ : List A → List A → Set where
  ∼[] : [] ∼ []
  ∼x : {x : A}{xs ys xs' ys' : List A}
                   → xs / x ⟶ xs'
                   → ys / x ⟶ ys'
                   → xs' ∼ ys'
                   → xs ∼ ys


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

open import LogicalFormulae
open import Numbers.Naturals.Semiring
open import Numbers.Integers.Definition

module Numbers.Integers.Multiplication where

infix 25 _*Z_
_*Z_ : ℤ → ℤ → ℤ
nonneg x *Z nonneg y = nonneg (x *N y)
nonneg zero *Z negSucc y = nonneg zero
nonneg (succ x) *Z negSucc y = negSucc ((succ x) *N y +N x)
negSucc x *Z nonneg zero = nonneg zero
negSucc x *Z nonneg (succ y) = negSucc ((succ y) *N x +N y)
negSucc x *Z negSucc y = nonneg ((succ x) *N (succ y))

*ZInherits : (a b : ℕ) → nonneg (a *N b) ≡ (nonneg a) *Z (nonneg b)
*ZInherits a b = refl


------------------------------------------------------------------------
-- The Agda standard library
--
-- Semi-heterogeneous vector equality over setoids
------------------------------------------------------------------------

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

open import Relation.Binary

module Data.Vec.Relation.Binary.Equality.Setoid
  {a ℓ} (S : Setoid a ℓ) where

open import Data.Nat.Base using (ℕ; zero; suc; _+_)
open import Data.Vec
open import Data.Vec.Relation.Binary.Pointwise.Inductive as PW
  using (Pointwise)
open import Function
open import Level using (_⊔_)
open import Relation.Binary
open import Relation.Binary.PropositionalEquality as P using (_≡_)

open Setoid S renaming (Carrier to A)

------------------------------------------------------------------------
-- Definition of equality

infix 4 _≋_

_≋_ : ∀ {m n} → REL (Vec A m) (Vec A n) (a ⊔ ℓ)
_≋_ = Pointwise _≈_

open Pointwise public using ([]; _∷_)
open PW public using (length-equal)

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

≋-refl : ∀ {n} → Reflexive (_≋_ {n})
≋-refl = PW.refl refl

≋-sym : ∀ {n m} → Sym _≋_ (_≋_ {m} {n})
≋-sym = PW.sym sym

≋-trans : ∀ {n m o} → Trans (_≋_ {m}) (_≋_ {n} {o}) (_≋_)
≋-trans = PW.trans trans

≋-isEquivalence : ∀ n → IsEquivalence (_≋_ {n})
≋-isEquivalence = PW.isEquivalence isEquivalence

≋-setoid : ℕ → Setoid a (a ⊔ ℓ)
≋-setoid = PW.setoid S

------------------------------------------------------------------------
-- map

open PW public using ( map⁺)

------------------------------------------------------------------------
-- ++

open PW public using (++⁺ ; ++⁻ ; ++ˡ⁻; ++ʳ⁻)

++-identityˡ : ∀ {n} (xs : Vec A n) → [] ++ xs ≋ xs
++-identityˡ _ = ≋-refl

++-identityʳ : ∀ {n} (xs : Vec A n) → xs ++ [] ≋ xs
++-identityʳ []       = []
++-identityʳ (x ∷ xs) = refl ∷ ++-identityʳ xs

map-++-commute : ∀ {b m n} {B : Set b}
                   (f : B → A) (xs : Vec B m) {ys : Vec B n} →
                   map f (xs ++ ys) ≋ map f xs ++ map f ys
map-++-commute f []       = ≋-refl
map-++-commute f (x ∷ xs) = refl ∷ map-++-commute f xs

------------------------------------------------------------------------
-- concat

open PW public using (concat⁺; concat⁻)

------------------------------------------------------------------------
-- replicate

replicate-shiftʳ : ∀ {m} n x (xs : Vec A m) →
                  replicate {n = n}     x ++ (x ∷ xs) ≋
                  replicate {n = 1 + n} x ++      xs
replicate-shiftʳ zero    x xs = ≋-refl
replicate-shiftʳ (suc n) x xs = refl ∷ (replicate-shiftʳ n x xs)


{- Voevodsky's proof that univalence implies funext -}

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

module Cubical.Experiments.FunExtFromUA where

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

variable
 ℓ ℓ' : Level
_∼_ : {X : Type ℓ} {A : X → Type ℓ'} → (f g : (x : X) → A x) → Type (ℓ-max ℓ ℓ')
f ∼ g = ∀ x → f x ≡ g x

funext : ∀ ℓ ℓ' → Type (ℓ-suc(ℓ-max ℓ ℓ'))
funext ℓ ℓ' = {X : Type ℓ} {Y : Type ℓ'} {f g : X → Y} → f ∼ g → f ≡ g

elimEquivFun' : ∀ {ℓ} (P : (A B : Type ℓ) → (A → B) → Type ℓ)
              → (r : (B : Type ℓ) → P B B (λ x → x))
              → (A B : Type ℓ) → (e : A ≃ B) → P A B (e .fst)
elimEquivFun' P r A B = elimEquivFun B (λ A → P A B) (r B) A

pre-comp-is-equiv : (X Y : Type ℓ) (f : X → Y) (Z : Type ℓ)
                  → isEquiv f
                  → isEquiv (λ (g : Y → Z) → g ∘ f)
pre-comp-is-equiv {ℓ} X Y f Z e = elimEquivFun' P r X Y (f , e)
 where
  P : (X Y : Type ℓ) → (X → Y) → Type ℓ
  P X Y f = isEquiv (λ (g : Y → Z) → g ∘ f)
  r : (B : Type ℓ) → P B B (λ x → x)
  r B = idIsEquiv (B → Z)

leftCancellable : {X : Type ℓ} {Y : Type ℓ'} → (X → Y) → Type (ℓ-max ℓ ℓ')
leftCancellable f = ∀ {x x'} → f x ≡ f x' → x ≡ x'

equivLC : {X : Type ℓ} {Y : Type ℓ'} (f : X → Y) → isEquiv f → leftCancellable f
equivLC f e {x} {x'} p i = hcomp (λ j → \ {(i = i0) → secEq (f , e) x j ;
                                           (i = i1) → secEq (f , e) x' j})
                                 (invEq (f , e) (p i))

univalence-gives-funext : funext ℓ' ℓ
univalence-gives-funext {ℓ'} {ℓ} {X} {Y} {f₀} {f₁} = γ
 where
  Δ = Σ[ y₀ ∈ Y ] Σ[ y₁ ∈ Y ] y₀ ≡ y₁

  δ : Y → Δ
  δ y = (y , y , refl)

  π₀ π₁ : Δ → Y
  π₀ (y₀ , y₁ , p) = y₀
  π₁ (y₀ , y₁ , p) = y₁

  δ-is-equiv : isEquiv δ
  δ-is-equiv = isoToIsEquiv (iso δ π₀ ε η)
   where
    η : (y : Y) → π₀ (δ y) ≡ y
    η y = refl
    ε : (d : Δ) → δ (π₀ d) ≡ d
    ε (y₀ , y₁ , p) i = y₀ , p i , λ j → p (i ∧ j)

  φ : (Δ → Y) → (Y → Y)
  φ π = π ∘ δ

  e : isEquiv φ
  e = pre-comp-is-equiv Y Δ δ Y δ-is-equiv

  p : φ π₀ ≡ φ π₁
  p = refl

  q : π₀ ≡ π₁
  q = equivLC φ e p

  g : (h : f₀ ∼ f₁) (π : Δ → Y) (x : X) → Y
  g = λ h π x → π (f₀ x , f₁ x , h x)

  γ : f₀ ∼ f₁ → f₀ ≡ f₁
  γ h = cong (g h) q

  γ' : f₀ ∼ f₁ → f₀ ≡ f₁
  γ' h = f₀                              ≡⟨ refl ⟩
         (λ x → f₀ x)                    ≡⟨ refl ⟩
         (λ x → π₀ (f₀ x , f₁ x , h x))  ≡⟨ cong (g h) q ⟩
         (λ x → π₁ (f₀ x , f₁ x , h x))  ≡⟨ refl ⟩
         (λ x → f₁ x)                    ≡⟨ refl ⟩
         f₁                              ∎

{- Experiment testing univalence via funext -}

private

  data ℕ : Type₀ where
   zero : ℕ
   succ : ℕ → ℕ

  f g : ℕ → ℕ

  f n = n

  g zero = zero
  g (succ n) = succ (g n)

  h : (n : ℕ) → f n ≡ g n
  h zero = refl
  h (succ n) = cong succ (h n)

  p : f ≡ g
  p = univalence-gives-funext h

  five : ℕ
  five = succ (succ (succ (succ (succ zero))))

  a : Σ ℕ (λ n → f n ≡ five)
  a = five , refl

  b : Σ ℕ (λ n → g n ≡ five)
  b = subst (λ - → Σ ℕ (λ n → - n ≡ five)) p a

  c : fst b ≡ five
  c = refl

{- It works, fast. -}


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

module Data.Binary.Operations.Semantics where

open import Data.Nat as ℕ using (ℕ; suc; zero)
open import Data.Binary.Definitions
open import Data.Binary.Operations.Unary
import Data.List as List

2* : ℕ → ℕ
2* x = x ℕ.+ x
{-# INLINE 2* #-}

_∷⇓_ : Bit → ℕ → ℕ
O ∷⇓ xs = 2* xs
I ∷⇓ xs = suc (2* xs)
{-# INLINE _∷⇓_ #-}

⟦_⇓⟧⁺ : 𝔹⁺ → ℕ
⟦_⇓⟧⁺ = List.foldr _∷⇓_ 1
{-# INLINE ⟦_⇓⟧⁺ #-}

⟦_⇓⟧ : 𝔹 → ℕ
⟦ 0ᵇ ⇓⟧ = 0
⟦ 0< xs ⇓⟧ = ⟦ xs ⇓⟧⁺

⟦_⇑⟧ : ℕ → 𝔹
⟦ zero ⇑⟧ = 0ᵇ
⟦ suc n ⇑⟧ = inc ⟦ n ⇑⟧


{-# OPTIONS --cubical --no-import-sorts --safe #-}
module Cubical.Algebra.CommRing.Integers where

open import Cubical.Foundations.Prelude

open import Cubical.Algebra.CommRing
open import Cubical.HITs.Ints.BiInvInt
  renaming (
    _+_ to _+ℤ_;
    -_ to _-ℤ_;
    +-assoc to +ℤ-assoc;
    +-comm to +ℤ-comm
  )

BiInvIntAsCommRing : CommRing {ℓ-zero}
BiInvIntAsCommRing =
  makeCommRing
    zero (suc zero) _+ℤ_ _·_ _-ℤ_
    isSetBiInvInt
    +ℤ-assoc +-zero +-invʳ +ℤ-comm
    ·-assoc ·-identityʳ
    (λ x y z → sym (·-distribˡ x y z))
    ·-comm


-- In Agda 2.5.3 the error was:

-- μ₂ is not strictly positive, because it occurs
-- in the third argument to ⟦_⟧
-- in the type of the constructor fix
-- in the definition of μ₂.

open import Data.Nat using (ℕ;zero;suc)
open import Data.Fin using (Fin;zero;suc)
open import Data.Vec
open import Data.Empty
open import Data.Product
open import Data.Sum
open import Data.Unit

Σ# : {n : ℕ} -> (Fin n -> Set) -> Set
Σ# {zero} f = ⊥
Σ# {suc zero} f = f zero
Σ# {suc n} f = f zero ⊎ Σ# {n} λ i -> f (suc i)

module Matrices {Ix : Set} {Σ : (Ix -> Set) -> Set} where

  Matrix : Set1
  Matrix = (i j : Ix) -> Set

  _<+>_ : Matrix -> Matrix -> Matrix
  m <+> n = λ i j -> m i j ⊎ n i j
  {-# INLINE _<+>_ #-}

  _<*>_ : Matrix -> Matrix -> Matrix
  m <*> n = λ i j -> Σ λ k -> m i k × n k j
  {-# INLINE _<*>_ #-}

data Poly {Coeffs : Set1} : Set1 where
  0p 1p : Poly
  X : Poly
  _+_ _*_ : (D1 D2 : Poly {Coeffs}) -> Poly {Coeffs}
  K : Coeffs -> Poly

module Dim {n : ℕ} where
  open Matrices {Fin n} {Σ#}

  ⟦_⟧ : Poly {Vec (Vec Set n) n} -> Matrix -> Matrix
  ⟦ 0p ⟧ x i j = ⊥
  ⟦ 1p ⟧ x i j = ⊤
  ⟦ X ⟧ x i j = x i j
  ⟦ D1 + D2 ⟧ x i j = (⟦ D1 ⟧ x <+> ⟦ D2 ⟧ x) i j
  ⟦ D1 * D2 ⟧ x i j = (⟦ D1 ⟧ x <*> ⟦ D2 ⟧ x) i j
  ⟦ K S ⟧ x i j = lookup (lookup S i) j

  ⟪_⟫ : Poly {Set} -> Set → Set
  ⟪ 0p ⟫ x = ⊥
  ⟪ 1p ⟫ x = ⊤
  ⟪ X ⟫ x = x
  ⟪ D1 + D2 ⟫ x = (⟪ D1 ⟫ x ⊎ ⟪ D2 ⟫ x)
  ⟪ D1 * D2 ⟫ x = (⟪ D1 ⟫ x × ⟪ D2 ⟫ x)
  ⟪ K S ⟫ x = S

  data μ₁ (p : Poly) : Set where
    fix : ⟪ p ⟫ (μ₁ p) -> μ₁ p

  data μ₂ (p : Poly) (i j : Fin n) : Set where
    fix : ⟦ p ⟧ (μ₂ p) i j -> μ₂ p i j


------------------------------------------------------------------------------
-- Equality reasoning on inductive PA
------------------------------------------------------------------------------

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

-- This module only re-export the preorder reasoning instanced on
-- the inductive PA propositional equality.

module PA.Inductive.Relation.Binary.EqReasoning where

open import PA.Inductive.Base

import Common.Relation.Binary.PreorderReasoning
open module ≡-Reasoning =
  Common.Relation.Binary.PreorderReasoning _≡_ refl trans public
    renaming ( _∼⟨_⟩_ to _≡⟨_⟩_ )


module Prelude.List.Relations.All where

open import Prelude.Equality
open import Prelude.Nat
open import Prelude.Empty
open import Prelude.Unit
open import Prelude.Product
open import Prelude.Number
open import Prelude.List.Base

open import Prelude.Applicative

open import Agda.Primitive

infixr 5 _∷_
data All {a b} {A : Set a} (P : A → Set b) : List A → Set (a ⊔ b) where
  []  : All P []
  _∷_ : ∀ {x xs} (p : P x) (ps : All P xs) → All P (x ∷ xs)


------------------------------------------------------------------------------
-- The gcd program is correct
------------------------------------------------------------------------------

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

-- This module proves the correctness of the gcd program using
-- the Euclid's algorithm.

module LTC-PCF.Program.GCD.Total.CorrectnessProof where

open import LTC-PCF.Base
open import LTC-PCF.Data.Nat.Type
open import LTC-PCF.Program.GCD.Total.CommonDivisor using ( gcdCD )
open import LTC-PCF.Program.GCD.Total.Definitions using ( gcdSpec )
open import LTC-PCF.Program.GCD.Total.Divisible using ( gcdDivisible )
open import LTC-PCF.Program.GCD.Total.GCD using ( gcd )

------------------------------------------------------------------------------
-- The gcd is correct.
gcdCorrect : ∀ {m n} → N m → N n → gcdSpec m n (gcd m n)
gcdCorrect Nm Nn = gcdCD Nm Nn , gcdDivisible Nm Nn


module map-compose where

import Relation.Binary.PropositionalEquality as Eq
open Eq using (_≡_; refl; cong)
open Eq.≡-Reasoning
open import Function using (_∘_)
open import lists using (List; []; _∷_; map)

postulate
  -- 外延性の公理
  extensionality : ∀ {A B : Set} {f g : A → B}
    → (∀ (x : A) → f x ≡ g x)
      -----------------------
    → f ≡ g

-- 外延性の公理を用いた証明のための補助定理
lemma : ∀ {A B C : Set} → (f : A → B) → (g : B → C) → (x : List A)
  → map (g ∘ f) x ≡ (map g ∘ map f) x
lemma f g []       = refl
lemma f g (x ∷ xs) =
  begin
    map (g ∘ f) (x ∷ xs)
  ≡⟨⟩
    (g ∘ f) x ∷ map (g ∘ f) xs
  ≡⟨ cong ((g ∘ f) x ∷_) (lemma f g xs) ⟩
    (g ∘ f) x ∷ (map g ∘ map f) xs
  ≡⟨⟩
    (map g ∘ map f) (x ∷ xs)
  ∎

-- mapの分配法則の証明
map-compose : ∀ {A B C : Set} → (f : A → B) → (g : B → C)
  → map (g ∘ f) ≡ map g ∘ map f
map-compose f g = extensionality (lemma f g)


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

open import HoTT

module cohomology.Choice where

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

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

{- Binary Choice -}
module _ {k} where

  pick-Bool : ∀ {j} {C : Lift {j = k} Bool → Type j}
    → (C (lift true)) → (C (lift false)) → Π (Lift Bool) C
  pick-Bool x y (lift true) = x
  pick-Bool x y (lift false) = y

  pick-Bool-η : ∀ {j} {C : Lift Bool → Type j} (f : Π (Lift Bool) C)
    → pick-Bool (f (lift true)) (f (lift false)) == f
  pick-Bool-η {C = C} f = λ= lemma
    where
    lemma : (b : Lift Bool) →
      pick-Bool {C = C} (f (lift true)) (f (lift false)) b == f b
    lemma (lift true) = idp
    lemma (lift false) = idp

  module _ {i} {n : ℕ₋₂} {A : Lift {j = k} Bool → Type i} where
    choose-Bool : Π (Lift Bool) (Trunc n ∘ A) → Trunc n (Π (Lift Bool) A)
    choose-Bool f = Trunc-rec Trunc-level
      (λ ft → Trunc-rec Trunc-level
        (λ ff → [ pick-Bool ft ff ] )
        (f (lift false)))
      (f (lift true))

    choose-Bool-squash : (f : Π (Lift Bool) A)
      → choose-Bool (λ b → [ f b ]) == [ f ]
    choose-Bool-squash f = ap [_] (pick-Bool-η f)

    private
      unc-c : ∀ f → unchoose (choose-Bool f) == f
      unc-c f = transport
        (λ h → unchoose (choose-Bool h) == h)
        (pick-Bool-η f)
        (Trunc-elim
           {P = λ tft →
             unchoose (choose-Bool (pick-Bool tft (f (lift false))))
             == pick-Bool tft (f (lift false))}
           (λ _ → =-preserves-level _ (Π-level (λ _ → Trunc-level)))
           (λ ft → Trunc-elim
             {P = λ tff →
               unchoose (choose-Bool (pick-Bool [ ft ] tff ))
               == pick-Bool [ ft ] tff}
             (λ _ → =-preserves-level _ (Π-level (λ _ → Trunc-level)))
             (λ ff → ! (pick-Bool-η _))
             (f (lift false)))
           (f (lift true)))

      c-unc : ∀ tg → choose-Bool (unchoose tg) == tg
      c-unc = Trunc-elim
        {P = λ tg → choose-Bool (unchoose tg) == tg}
        (λ _ → =-preserves-level _ Trunc-level)
        (λ g → ap [_] (pick-Bool-η g))

    Bool-has-choice : has-choice n (Lift Bool) A
    Bool-has-choice = is-eq unchoose choose-Bool unc-c c-unc


------------------------------------------------------------------------------
-- FOTC version of a nested recursive function
------------------------------------------------------------------------------

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

-- From: Ana Bove and Venanzio Capretta. Nested general recursion and
-- partiality in type theory. Vol. 2152 of LNCS. 2001.

module FOT.FOTC.Program.Nest.PropertiesI where

open import Common.FOL.Relation.Binary.EqReasoning

open import FOTC.Base
open import FOTC.Data.Nat.Type
open import FOTC.Program.Nest.Nest

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

nestCong : ∀ {m n} → m ≡ n → nest m ≡ nest n
nestCong refl = refl

nest-x≡0 : ∀ {n} → N n → nest n ≡ zero
nest-x≡0 nzero = nest-0
nest-x≡0 (nsucc {n} Nn) =
  nest (succ₁ n) ≡⟨ nest-S n ⟩
  nest (nest n)  ≡⟨ nestCong (nest-x≡0 Nn) ⟩
  nest zero      ≡⟨ nest-0 ⟩
  zero           ∎

nest-N : ∀ {n} → N n → N (nest n)
nest-N Nn = subst N (sym (nest-x≡0 Nn)) nzero


test.id : (A:Set) -> (x:A) -> A
test.id A x = x

nat.plus : (x:Nat) -> (y:Nat) -> Nat
nat.plus (nat.suc x) y = nat.suc (nat.plus x y)
nat.plus nat.zero y = y


import Either
open import Boolean

module Logic where

  id : ∀ { A : Set } → A → A
  id x = x

  Rel : Set → Set₁
  Rel X = X → X → Set

  Decidable : ∀ { X } → Rel X → Set
  Decidable R = ∀ x y → Either (R x y) (¬ (R x y))
    where open Either

  modusPonens : { P Q : Set } → ( P → Q ) → P → Q
  modusPonens = id


module 747Decidable where

-- Library

import Relation.Binary.PropositionalEquality as Eq
open Eq using (_≡_; refl; sym) -- added sym
open Eq.≡-Reasoning
open import Data.Nat using (ℕ; zero; suc; _≤_; z≤n; s≤s)
open import Data.Product using (_×_) renaming (_,_ to ⟨_,_⟩)
open import Data.Sum using (_⊎_; inj₁; inj₂)
open import Relation.Nullary using (¬_)
open import Relation.Nullary.Negation using ()
  renaming (contradiction to ¬¬-intro)
open import Data.Unit using (⊤; tt)
open import Data.Empty using (⊥; ⊥-elim)

-- Copied from 747Isomorphism.

record _⇔_ (A B : Set) : Set where
  field
    to   : A → B
    from : B → A
open _⇔_

-- Copied from 747Relations.

infix 4 _<_

data _<_ : ℕ → ℕ → Set where

  z<s : ∀ {n : ℕ}
      ------------
    → zero < suc n

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

-- Recall that the constructors for _≤_ are z≤n and s≤s.

-- Here are a couple of examples to show how to prove inequalities
-- (or their negations).

2≤4 : 2 ≤ 4
2≤4 = {!!}

¬4≤2 : ¬ (4 ≤ 2)
¬4≤2 = {!!}

-- This should be familiar.

data Bool : Set where
  true  : Bool
  false : Bool

-- We can define a Boolean comparison function.

infix 4 _≤ᵇ_

_≤ᵇ_ : ℕ → ℕ → Bool
m ≤ᵇ n = {!!}

-- PLFA steps through these computations using equational reasoning.

_ : (2 ≤ᵇ 4) ≡ true
_ =  refl

_ : (4 ≤ᵇ 2) ≡ false
_ = refl

-- Relating evidence and computation.

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

T→≡ : ∀ (b : Bool) → T b → b ≡ true
T→≡ b t = {!!}

≡→T : ∀ {b : Bool} → b ≡ true → T b
≡→T e = {!!}

≤ᵇ→≤ : ∀ (m n : ℕ) → T (m ≤ᵇ n) → m ≤ n
≤ᵇ→≤ m n t = {!!}

≤→≤ᵇ : ∀ {m n : ℕ} → m ≤ n → T (m ≤ᵇ n)
≤→≤ᵇ m≤n = {!!}

-- Getting the best of both worlds!

data Dec (A : Set) : Set where
  yes :   A → Dec A
  no  : ¬ A → Dec A

-- Helpers for defining _≤?_
-- If you don't use these, the examples below won't normalize.

¬s≤z : ∀ {m : ℕ} → ¬ (suc m ≤ zero)
¬s≤z = {!!}

¬s≤s : ∀ {m n : ℕ} → ¬ (m ≤ n) → ¬ (suc m ≤ suc n)
¬s≤s = {!!}

-- Decidable ≤.

_≤?_ : ∀ (m n : ℕ) → Dec (m ≤ n)
m ≤? n = {!!}

_ : 2 ≤? 4 ≡ yes (s≤s (s≤s z≤n))
_ = refl

_ : 4 ≤? 2 ≡ no (¬s≤s (¬s≤s ¬s≤z))
_ = refl

-- We can also evaluate the LHS of these using C-c C-n.

-- 747/PLFA exercise: DecLT (3 point)
-- Decidable strict equality.
-- You will need these helper functions as we did above.

¬z<z : ¬ (zero < zero)
¬z<z = {!!}

¬s<s : ∀ {m n : ℕ} → ¬ (m < n) → ¬ (suc m < suc n)
¬s<s = {!!}

¬s<z : ∀ {n : ℕ} → ¬ (suc n < zero)
¬s<z = {!!}

_<?_ : ∀ (m n : ℕ) → Dec (m < n)
m <? n = {!!}

-- Some tests.

_ : 2 <? 4 ≡ yes (s<s (s<s (z<s)))
_ = refl

_ : 4 <? 2 ≡ no (¬s<s (¬s<s ¬s<z))
_ = refl

_ : 3 <? 3 ≡ no (¬s<s (¬s<s (¬s<s ¬z<z)))
_ = refl

-- 747/PLFA exercise: DecNatEq (3 points)
-- Decidable equality for natural numbers.

_≡ℕ?_ : ∀ (m n : ℕ) → Dec (m ≡ n) -- split m,n
m ≡ℕ? n = {!!}

-- Reusing ≤ᵇ and proofs of equivalence with ≤ to decide ≤.

_≤?′_ : ∀ (m n : ℕ) → Dec (m ≤ n)
m ≤?′ n = {!!}

-- Erasing Dec down to Bool (or "isYes").

⌊_⌋ : ∀ {A : Set} → Dec A → Bool
⌊ yes x ⌋ = true
⌊ no x ⌋ = false

_≤ᵇ′_ : ℕ → ℕ → Bool
m ≤ᵇ′ n  =  ⌊ m ≤? n ⌋

-- If D is Dec A, then T ⌊ D ⌋ is inhabited exactly when A is inhabited.

toWitness : ∀ {A : Set} {D : Dec A} → T ⌊ D ⌋ → A
toWitness t = {!!}

fromWitness : ∀ {A : Set} {D : Dec A} → A → T ⌊ D ⌋
fromWitness a = {!!}

-- Similar ideas when it is the "no" witnesses we want to handle.

isNo : ∀ {A : Set} → Dec A → Bool
isNo (yes _) = false
isNo (no _)  = true

toWitnessFalse : ∀ {A : Set} {D : Dec A} → T (isNo D) → ¬ A
toWitnessFalse = {!!}

fromWitnessFalse : ∀ {A : Set} {D : Dec A} → ¬ A → T (isNo D)
fromWitnessFalse = {!!}

-- Agda standard library definitions for use of these.

True : ∀ {A : Set} → (D : Dec A) → Set
True Q = T ⌊ Q ⌋

False : ∀ {A : Set} → (D : Dec A) → Set
False Q = T (isNo Q)

-- A concrete example.

≤ᵇ′→≤ : ∀ {m n : ℕ} → T (m ≤ᵇ′ n) → m ≤ n
≤ᵇ′→≤  =  toWitness

≤→≤ᵇ′ : ∀ {m n : ℕ} → m ≤ n → T (m ≤ᵇ′ n)
≤→≤ᵇ′  =  fromWitness

-- Conclusion: use Decidables instead of Booleans!

-- Logical connectives for Decidables.

infixr 6 _∧_

_∧_ : Bool → Bool → Bool
true ∧ true = true
true ∧ false = false
false ∧ y = false

infixr 6 _×-dec_

_×-dec_ : ∀ {A B : Set} → Dec A → Dec B → Dec (A × B)
da ×-dec db = {!!}

infixr 5 _∨_

_∨_ : Bool → Bool → Bool
true ∨ y = true
false ∨ y = y

infixr 5 _⊎-dec_

_⊎-dec_ : ∀ {A B : Set} → Dec A → Dec B → Dec (A ⊎ B)
da ⊎-dec db = {!!}

not : Bool → Bool
not true  = false
not false = true

¬? : ∀ {A : Set} → Dec A → Dec (¬ A)
¬? da = {!!}

-- A Boolean version of implication.

_⊃_ : Bool → Bool → Bool
true ⊃ true = true
true ⊃ false = false
false ⊃ y = true

_→-dec_ : ∀ {A B : Set} → Dec A → Dec B → Dec (A → B)
da →-dec db = {!!}

-- 747/PLFA exercise: ErasBoolDec (3 points)
-- Erasure relates boolean and decidable operations.

∧-× : ∀ {A B : Set} (x : Dec A) (y : Dec B) → ⌊ x ⌋ ∧ ⌊ y ⌋ ≡ ⌊ x ×-dec y ⌋
∧-× da db = {!!}

∨-× : ∀ {A B : Set} (x : Dec A) (y : Dec B) → ⌊ x ⌋ ∨ ⌊ y ⌋ ≡ ⌊ x ⊎-dec y ⌋
∨-× da db = {!!}

not-¬ : ∀ {A : Set} (x : Dec A) → not ⌊ x ⌋ ≡ ⌊ ¬? x ⌋
not-¬ da = {!!}

-- 747/PLFA exercise: iff-erasure.

_iff_ : Bool → Bool → Bool
true iff true = true
true iff false = false
false iff true = false
false iff false = true

_⇔-dec_ : ∀ {A B : Set} → Dec A → Dec B → Dec (A ⇔ B)
da ⇔-dec db = {!!}

iff-⇔ : ∀ {A B : Set} (x : Dec A) (y : Dec B) → ⌊ x ⌋ iff ⌊ y ⌋ ≡ ⌊ x ⇔-dec y ⌋
iff-⇔ da db = {!!}

-- Proof by reflection.
-- Or, getting Agda to construct proofs at compile time.

-- A guarded version of monus.

minus : (m n : ℕ) (n≤m : n ≤ m) → ℕ
minus m zero _ = m
minus (suc m) (suc n) (s≤s m≤n) = minus m n m≤n

-- But we have to provide proofs.

_ : minus 5 3 (s≤s (s≤s (s≤s z≤n))) ≡ 2
_ = refl

-- Agda will fill in an implicit record type if it can fill in all fields.
-- Since ⊤ is defined as a record type with no fields...
-- We can get Agda to compute a value of type True (n ≤? m).

_-_ : (m n : ℕ) {n≤m : True (n ≤? m)} → ℕ
_-_ m n {n≤m} = minus m n (toWitness n≤m)

_ : 5 - 3 ≡ 2
_ = refl

-- We will later use this to get Agda to compute parts of proofs
-- that would be annoying for us to provide.


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

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

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

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

  open IsLoop isLoop public

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

  open IsLoop isLoop public

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

  open IsLoop isLoop public


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

open import LogicalFormulae
open import Setoids.Setoids
open import Sets.EquivalenceRelations
open import Rings.Definition
open import Rings.Homomorphisms.Definition

module Rings.Homomorphisms.Image {a b c d : _} {A : Set a} {B : Set c} {S : Setoid {a} {b} A} {T : Setoid {c} {d} B} {_+A_ _*A_ : A → A → A} {_+B_ _*B_ : B → B → B} {R1 : Ring S _+A_ _*A_} {R2 : Ring T _+B_ _*B_} {f : A → B} (hom : RingHom R1 R2 f) where

open import Groups.Homomorphisms.Image (RingHom.groupHom hom)
open import Rings.Subrings.Definition

imageGroupSubring : Subring R2 imageGroupPred
Subring.isSubgroup imageGroupSubring = imageGroupSubgroup
Subring.containsOne imageGroupSubring = Ring.1R R1 , RingHom.preserves1 hom
Subring.closedUnderProduct imageGroupSubring {x} {y} (a , fa=x) (b , fb=y) = (a *A b) , transitive ringHom (Ring.*WellDefined R2 fa=x fb=y)
  where
    open Setoid T
    open Equivalence eq
    open RingHom hom


------------------------------------------------------------------------------
-- Proving properties without using pattern matching on refl
------------------------------------------------------------------------------

{-# OPTIONS --no-pattern-matching      #-}
{-# OPTIONS --exact-split              #-}
{-# OPTIONS --no-sized-types           #-}
{-# OPTIONS --no-universe-polymorphism #-}

module FOT.PA.Axiomatic.Standard.NoPatternMatchingOnRefl where

open import PA.Axiomatic.Standard.Base

------------------------------------------------------------------------------
-- From PA.Axiomatic.Standard.PropertiesI

-- Congruence properties

succCong : ∀ {m n} → m ≡ n → succ m ≡ succ n
succCong {m} h = subst (λ t → succ m ≡ succ t) h refl

+-leftCong : ∀ {m n o} → m ≡ n → m + o ≡ n + o
+-leftCong {m} {o = o} h = subst (λ t → m + o ≡ t + o) h refl

+-rightCong : ∀ {m n o} → n ≡ o → m + n ≡ m + o
+-rightCong {m} {n} h = subst (λ t → m + n ≡ m + t) h refl


{-# OPTIONS --show-implicit #-}
-- {-# OPTIONS --sized-types #-}         -- no longer necessary
-- {-# OPTIONS --termination-depth=2 #-} -- no longer necessary
-- {-# OPTIONS -v term:10 #-}

module SizedBTree where

open import Common.Size

module Old where

  data BTree (A : Set) : {size : Size} → Set where
    leaf : {i : Size} → A → BTree A {↑ i}
    node : {i : Size} → BTree A {i} → BTree A {i} → BTree A {↑ i}

  map : ∀ {A B i} → (A → B) → BTree A {i} → BTree B {i}
  map f (leaf a) = leaf (f a)
  map f (node l r) = node (map f l) (map f r)

  -- deep matching

  deep : ∀ {i A} → BTree A {i} → A
  deep (leaf a) = a
  deep (node (leaf _) r) = deep r
  deep (node (node l r) _) = deep (node l r)

  -- nesting

  -- Jesper 2015-12-18: The new unifier requires the size argument of the first
  -- deep2 to be given explicitly. This is because otherwise the unifier gets
  -- stuck on an equation [↑ i₁ =?= _i_46 {i} {A} l r t]. It's not clear whether
  -- it is safe to instantiate the meta to [↑ _] here.
  deep2 : ∀ {i A} → BTree A {i} → BTree A {i}
  deep2 (leaf a) = leaf a
  deep2 (node (leaf _) r) = r
  deep2 (node (node {i} l r) t) with deep2 {↑ i} (deep2 (node l r))
  ... | leaf a = leaf a
  ... | node l2 r2 = deep2 (node l2 r2)

  -- OUTDATED: -- increasing the termination count does the job!

module New where

  data BTree (A : Set) {i : Size} :  Set where
    leaf : A → BTree A
    node : {i' : Size< i} → BTree A {i'} → BTree A {i'} → BTree A

  map : ∀ {A B i} → (A → B) → BTree A {i} → BTree B {i}
  map f (leaf a)   = leaf (f a)
  map f (node l r) = node (map f l) (map f r)

  -- deep matching

  deep : ∀ {i A} → BTree A {i} → A
  deep (leaf a)            = a
  deep (node (leaf _)   r) = deep r
  deep (node (node l r) _) = deep (node l r)

  -- nesting

  deep2 : ∀ {i A} → BTree A {i} → BTree A {i}
  deep2 (leaf a)            = leaf a
  deep2 (node (leaf _)   r) = r
  deep2 (node (node l r) _) with deep2 (deep2 (node l r))
  ... | leaf a     = leaf a
  ... | node l2 r2 = deep2 (node l2 r2)


{- Diamond operator. -}
module TemporalOps.Diamond.Functor where

open import CategoryTheory.Categories
open import CategoryTheory.Instances.Reactive
open import CategoryTheory.Functor
open import TemporalOps.Common
open import TemporalOps.Next
open import TemporalOps.Delay
open import Data.Product

-- Arbitrary delay
◇_ : τ -> τ
(◇ A) n = Σ[ k ∈ ℕ ] (delay A by k at n)
infixr 65 ◇_

-- ◇ instances
F-◇ : Endofunctor ℝeactive
F-◇ = record
    { omap      = ◇_
    ; fmap      = fmap-◇
    ; fmap-id   = fmap-◇-id
    ; fmap-∘    = fmap-◇-∘
    ; fmap-cong = fmap-◇-cong
    }
    where
    -- Lifting of ◇
    fmap-◇ : {A B : τ} -> A ⇴ B -> ◇ A ⇴ ◇ B
    fmap-◇ f n (k , v) = k , (Functor.fmap (F-delay k) f at n) v
    -- ◇ preserves identities
    fmap-◇-id : ∀ {A : τ} {n : ℕ} {a : (◇ A) n}
             -> (fmap-◇ (id {A}) at n) a ≡ a
    fmap-◇-id {A} {n} {zero , v} = refl
    fmap-◇-id {A} {zero} {suc k , v} = refl
    fmap-◇-id {A} {suc n} {suc k , v}
        rewrite delay-+ {A} 1 k n
              | Functor.fmap-id (F-delay (suc k)) {A} {suc n} {v}
        = refl
    -- ◇ preserves composition
    fmap-◇-∘ : ∀ {A B C : τ} {g : B ⇴ C} {f : A ⇴ B} {n : ℕ} {a : (◇ A) n}
            -> (fmap-◇ (g ∘ f) at n) a ≡ (fmap-◇ g ∘ fmap-◇ f at n) a
    fmap-◇-∘ {n = n} {zero , v} = refl
    fmap-◇-∘ {n = zero} {suc k , v} = refl
    fmap-◇-∘ {A} {B} {C} {g} {f} {suc n} {suc k , v}
        rewrite delay-+ {A} 1 k n
              | Functor.fmap-∘ (F-delay (suc k)) {A} {B} {C} {g} {f} {suc n} {v}
        = refl
    -- ▹ is congruent
    fmap-◇-cong : ∀{A B : τ} {f f′ : A ⇴ B}
            -> ({n : ℕ} {a : A at n}   -> f n a ≡ f′ n a)
            -> ({n : ℕ} {a : ◇ A at n} -> (fmap-◇ f at n) a
                                        ≡ (fmap-◇ f′ at n) a)
    fmap-◇-cong {A} e {n} {zero , a}
        rewrite delay-+-left0 {A} 0 n
              | e {n} {a} = refl
    fmap-◇-cong e {zero} {suc k , a} = refl
    fmap-◇-cong {A} {B} {f} {f′} e {suc n} {suc k , a}
        rewrite delay-+ {A} 1 k n
              | Functor.fmap-cong (F-delay (suc k)) {A} {B} {f} {f′} e {suc n} {a}
              = refl


-- Minimal implicational logic, PHOAS approach, initial encoding

module Pi.ArrMp where

-- Types

infixr 0 _=>_
data Ty : Set where
  UNIT :             Ty
  _=>_ : Ty -> Ty -> Ty

-- Context and truth judgement

Cx : Set1
Cx = Ty -> Set

isTrue : Ty -> Cx -> Set
isTrue a tc = tc a

-- Terms

module ArrMp where
  infixl 1 _$_
  data Tm (tc : Cx) : Ty -> Set where
    var  : forall {a}   -> isTrue a tc               -> Tm tc a
    lam' : forall {a b} -> (isTrue a tc -> Tm tc b)  -> Tm tc (a => b)
    _$_  : forall {a b} -> Tm tc (a => b) -> Tm tc a -> Tm tc b

  lam'' : forall {tc a b} -> (Tm tc a -> Tm tc b) -> Tm tc (a => b)
  lam'' f = lam' \x -> f (var x)

  syntax lam'' (\a -> b) = lam a => b

  Thm : Ty -> Set1
  Thm a = forall {tc} -> Tm tc a
open ArrMp public

-- Example theorems

aI : forall {a} -> Thm (a => a)
aI =
  lam x => x

aK : forall {a b} -> Thm (a => b => a)
aK =
  lam x =>
    lam _ => x

aS : forall {a b c} -> Thm ((a => b => c) => (a => b) => a => c)
aS =
  lam f =>
    lam g =>
      lam x => f $ x $ (g $ x)

tSKK : forall {a} -> Thm (a => a)
tSKK {a = a} =
  aS {b = a => a} $ aK $ aK


------------------------------------------------------------------------
-- The Agda standard library
--
-- Digits and digit expansions
------------------------------------------------------------------------

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

module Data.Digit where

open import Data.Nat using (ℕ; zero; suc; pred; _+_; _*_; _≤?_; _≤′_)
open import Data.Nat.Properties
open import Data.Nat.Solver
open import Data.Fin as Fin using (Fin; zero; suc; toℕ)
open import Data.Char using (Char)
open import Data.List.Base
open import Data.Product
open import Data.Vec as Vec using (Vec; _∷_; [])
open import Data.Nat.DivMod
open import Induction.Nat using (<′-rec; <′-Rec)
open import Relation.Nullary using (yes; no)
open import Relation.Nullary.Decidable
open import Relation.Binary using (Decidable)
open import Relation.Binary.PropositionalEquality as P using (_≡_; refl)
open import Function

open +-*-Solver

------------------------------------------------------------------------
-- Digits

-- Digit b is the type of digits in base b.

Digit : ℕ → Set
Digit b = Fin b

-- Some specific digit kinds.

Decimal = Digit 10
Bit     = Digit 2

-- Some named digits.

0b : Bit
0b = zero

1b : Bit
1b = suc zero

------------------------------------------------------------------------
-- Showing digits

-- The characters used to show the first 16 digits.

digitChars : Vec Char 16
digitChars =
  '0' ∷ '1' ∷ '2' ∷ '3' ∷ '4' ∷ '5' ∷ '6' ∷ '7' ∷ '8' ∷ '9' ∷
  'a' ∷ 'b' ∷ 'c' ∷ 'd' ∷ 'e' ∷ 'f' ∷ []

-- showDigit shows digits in base ≤ 16.

showDigit : ∀ {base} {base≤16 : True (base ≤? 16)} →
            Digit base → Char
showDigit {base≤16 = base≤16} d =
  Vec.lookup digitChars (Fin.inject≤ d (toWitness base≤16))

------------------------------------------------------------------------
-- Digit expansions

Expansion : ℕ → Set
Expansion base = List (Fin base)

-- fromDigits takes a digit expansion of a natural number, starting
-- with the _least_ significant digit, and returns the corresponding
-- natural number.

fromDigits : ∀ {base} → Expansion base → ℕ
fromDigits        []       = 0
fromDigits {base} (d ∷ ds) = toℕ d + fromDigits ds * base

-- toDigits b n yields the digits of n, in base b, starting with the
-- _least_ significant digit.
--
-- Note that the list of digits is always non-empty.

toDigits : (base : ℕ) {base≥2 : True (2 ≤? base)} (n : ℕ) →
           ∃ λ (ds : Expansion base) → fromDigits ds ≡ n
toDigits zero       {base≥2 = ()} _
toDigits (suc zero) {base≥2 = ()} _
toDigits (suc (suc k)) n = <′-rec Pred helper n
  where
  base = suc (suc k)
  Pred = λ n → ∃ λ ds → fromDigits ds ≡ n

  cons : ∀ {m} (r : Fin base) → Pred m → Pred (toℕ r + m * base)
  cons r (ds , eq) = (r ∷ ds , P.cong (λ i → toℕ r + i * base) eq)

  open ≤-Reasoning

  lem : ∀ x k r → 2 + x ≤′ r + (1 + x) * (2 + k)
  lem x k r = ≤⇒≤′ $ begin
    2 + x
      ≤⟨ m≤m+n _ _ ⟩
    2 + x + (x + (1 + x) * k + r)
      ≡⟨ solve 3 (λ x r k → con 2 :+ x :+ (x :+ (con 1 :+ x) :* k :+ r)
                              :=
                            r :+ (con 1 :+ x) :* (con 2 :+ k))
                 refl x r k ⟩
    r + (1 + x) * (2 + k)
      ∎

  helper : ∀ n → <′-Rec Pred n → Pred n
  helper n                       rec with n divMod base
  helper .(toℕ r + 0     * base) rec | result zero    r refl = ([ r ] , refl)
  helper .(toℕ r + suc x * base) rec | result (suc x) r refl =
    cons r (rec (suc x) (lem (pred (suc x)) k (toℕ r)))


------------------------------------------------------------------------
-- Spheres
------------------------------------------------------------------------

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

-- This module follows the HoTT book rather closely.

import Equality.Path as P

module Sphere
  {e⁺} (eq : ∀ {a p} → P.Equality-with-paths a p e⁺) where

open P.Derived-definitions-and-properties eq hiding (elim)

open import Logical-equivalence using (_⇔_)
open import Prelude

open import Bijection equality-with-J using (_↔_)
open import Equality.Path.Isomorphisms eq
open import Equality.Tactic equality-with-J
import Equivalence equality-with-J as Equiv
open import Function-universe equality-with-J as F hiding (_∘_)
open import H-level equality-with-J
open import H-level.Closure equality-with-J
open import Nat equality-with-J as Nat
open import Pointed-type equality-with-J
open import Suspension eq as Suspension

private
  variable
    a b : Level
    A B : Type a
    C   : Pointed-type a
    x   : A
    n   : ℕ

-- Spheres.

𝕊[_-1] : ℕ → Type
𝕊[ zero  -1] = ⊥
𝕊[ suc n -1] = Susp 𝕊[ n -1]

-- Spheres with non-negative dimensions.

𝕊 : ℕ → Type
𝕊 n = 𝕊[ 1 + n -1]

-- The booleans are isomorphic to the 0-dimensional sphere.

Bool↔𝕊⁰ : Bool ↔ 𝕊 0
Bool↔𝕊⁰ = Bool↔Susp-⊥

-- Based maps from spheres with non-negative dimensions (using north
-- as the point) are isomorphic to iterated loop spaces.

𝕊→ᴮ↔ : ∀ n → (𝕊 n , north) →ᴮ C ↔ proj₁ (Ω[ n ] C)
𝕊→ᴮ↔ {C = C} = lemma zero
  where
  lemma : ∀ m n → (𝕊 n , north) →ᴮ Ω[ m ] C ↔ proj₁ (Ω[ m + n ] C)
  lemma m zero =
    (𝕊 0 , north) →ᴮ Ω[ m ] C  ↝⟨ Σ-cong (→-cong ext (inverse Bool↔𝕊⁰) F.id) (λ _ → F.id) ⟩
    (Bool , true) →ᴮ Ω[ m ] C  ↝⟨ Bool→ᴮ↔ ext ⟩
    proj₁ (Ω[ m ] C)           ↝⟨ ≡⇒↝ _ $ cong (λ n → proj₁ (Ω[ n ] C)) $ sym $ Nat.+-right-identity {n = m} ⟩□
    proj₁ (Ω[ m + 0 ] C)       □

  lemma m (suc n) =
    (𝕊 (suc n) , north) →ᴮ Ω[ m ] C  ↝⟨ Susp→ᴮ↔ ⟩
    (𝕊 n , north) →ᴮ Ω[ suc m ] C    ↝⟨ lemma (suc m) n ⟩
    proj₁ (Ω[ suc m + n ] C)         ↝⟨ ≡⇒↝ _ $ cong (λ n → proj₁ (Ω[ n ] C)) $ Nat.suc+≡+suc m ⟩□
    proj₁ (Ω[ m + suc n ] C)         □

-- A corollary.

+↔∀contractible𝕊→ᴮ :
  H-level (1 + n) A ↔
  (∀ x → Contractible ((𝕊 n , north) →ᴮ (A , x)))
+↔∀contractible𝕊→ᴮ {n = n} {A = A} =
  H-level (1 + n) A                                ↔⟨ _↔_.to (Equiv.⇔↔≃ ext (H-level-propositional ext _)
                                                                            (Π-closure ext 1 λ _ →
                                                                             H-level-propositional ext _))
                                                             (+⇔∀contractible-Ω[] _) ⟩
  (∀ x → Contractible (proj₁ $ Ω[ n ] (A , x)))    ↝⟨ (∀-cong ext λ _ → H-level-cong ext 0 (inverse $ 𝕊→ᴮ↔ _)) ⟩□
  (∀ x → Contractible ((𝕊 n , north) →ᴮ (A , x)))  □


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

module Container.List.Isomorphism where

open import Prelude
open import Container
open import Container.List
open import Data.Fin
open import Data.List using (tabulate; length ; _!_) renaming (_∷_ to _L∷_; [] to L[]; List to 𝕃)
open import Data.List.Properties

ℒ→𝕃 : List A → 𝕃 A
ℒ→𝕃 = uncurry tabulate

𝕃→ℒ : 𝕃 A → List A
𝕃→ℒ xs .fst = length xs
𝕃→ℒ xs .snd i = xs ! i

ℒ→𝕃→ℒ : ∀ n (xs : Fin n → A) → 𝕃→ℒ (ℒ→𝕃 (n , xs)) ≡ (n , xs)
ℒ→𝕃→ℒ n xs i .fst = tab-length n xs i
ℒ→𝕃→ℒ n xs i .snd = tab-id n xs i

𝕃→ℒ→𝕃 : ∀ (xs : 𝕃 A) → ℒ→𝕃 (𝕃→ℒ xs) ≡ xs
𝕃→ℒ→𝕃 L[] _ = L[]
𝕃→ℒ→𝕃 (x L∷ xs) i = x L∷ 𝕃→ℒ→𝕃 xs i

𝕃⇔ℒ : 𝕃 A ⇔ List A
𝕃⇔ℒ .fun = 𝕃→ℒ
𝕃⇔ℒ .inv = ℒ→𝕃
𝕃⇔ℒ .rightInv  = uncurry ℒ→𝕃→ℒ
𝕃⇔ℒ .leftInv = 𝕃→ℒ→𝕃


------------------------------------------------------------------------
-- Reasoning about _⇔_
--
-- NOTE: we don’t use Relation.Binary.IsEquivalence here, since we’re reasoning
-- about a heterogeneous equivalence relation (i.e., the types of the operands
-- of _⇔_, which are themselves types, can be of different levels). In the proof
-- of Chapter₁₅.problem₁, the fact that _⇔_ is heterogeneous is actually used,
-- so we cannot use a homogeneous version of _⇔_.
------------------------------------------------------------------------

module Function.Equivalence.Reasoning where

open import Function using (_⇔_)
open import Function.Construct.Composition using (_∘-⇔_) public
open import Function.Construct.Identity using (id-⇔) public
open import Function.Construct.Symmetry using (sym-⇔) public
open import Level using (Level)

private
  variable
    a b c : Level

infix  1 begin_
infixr 2 _⇔⟨⟩_ step-⇔ step-⇔˘
infix  3 _∎

begin_ : {A : Set a} {B : Set b} → A ⇔ B → A ⇔ B
begin A⇔B = A⇔B

_∎ : (A : Set a) → A ⇔ A
_∎ = id-⇔

_⇔⟨⟩_ : (A : Set a) {B : Set b} → A ⇔ B → A ⇔ B
A ⇔⟨⟩ A⇔B = A⇔B

step-⇔ : (A : Set a) {B : Set b} {C : Set c} → A ⇔ B → B ⇔ C → A ⇔ C
step-⇔ A = _∘-⇔_

syntax step-⇔ A A⇔B B⇔C = A ⇔⟨ A⇔B ⟩ B⇔C

step-⇔˘ : (A : Set a) {B : Set b} {C : Set c} → B ⇔ A → B ⇔ C → A ⇔ C
step-⇔˘ A B⇔A B⇔C = A ⇔⟨ sym-⇔ B⇔A ⟩ B⇔C

syntax step-⇔˘ A B⇔A B⇔C = A ⇔˘⟨ B⇔A ⟩ B⇔C


module Formalization.ClassicalPropositionalLogic.Syntax where

import      Lvl
open import Functional
open import Sets.PredicateSet using (PredSet)
open import Type

private variable ℓₚ ℓ : Lvl.Level

module _ (P : Type{ℓₚ}) where
  -- Formulas.
  -- Inductive definition of the grammatical elements of the language of propositional logic.
  -- Note: It is possible to reduce the number of formula variants to for example {•,¬,∨} or {•,¬,∧} (This is called propositional adequacy/functional completeness).
  data Formula : Type{ℓₚ} where
    •_ : P → Formula -- Propositional constants

    ⊤ : Formula -- Tautology (Top / True)
    ⊥ : Formula -- Contradiction (Bottom / False)

    ¬_ : Formula → Formula -- Negation (Not)

    _∧_ : Formula → Formula → Formula -- Conjunction (And)
    _∨_ : Formula → Formula → Formula -- Disjunction (Or)
    _⟶_ : Formula → Formula → Formula -- Implication
    _⟷_ : Formula → Formula → Formula -- Equivalence

  Formulas : Type{ℓₚ Lvl.⊔ Lvl.𝐒(ℓ)}
  Formulas{ℓ} = PredSet{ℓ}(Formula)

  infix 1011 •_
  infix 1010 ¬_ ¬¬_
  infixr 1005 _∧_
  infixr 1004 _∨_
  infixr 1000 _⟷_ _⟶_

module _ {P : Type{ℓₚ}} where
  -- Double negation
  -- ¬¬_ : Formula(P) → Formula(P)
  -- ¬¬_ : (¬_) ∘ (¬_)

  -- Reverse implication
  _⟵_ : Formula(P) → Formula(P) → Formula(P)
  _⟵_ = swap(_⟶_)

  -- (Nor)
  _⊽_ : Formula(P) → Formula(P) → Formula(P)
  _⊽_ = (¬_) ∘₂ (_∨_)

  -- (Nand)
  _⊼_ : Formula(P) → Formula(P) → Formula(P)
  _⊼_ = (¬_) ∘₂ (_∧_)

  -- (Exclusive or / Xor)
  _⊻_ : Formula(P) → Formula(P) → Formula(P)
  _⊻_ = (¬_) ∘₂ (_⟷_)

  infixl 1000 _⟵_


{-# OPTIONS --safe #-}
module Cubical.Algebra.CommAlgebra.FGIdeal where
open import Cubical.Foundations.Prelude

open import Cubical.Data.FinData
open import Cubical.Data.Nat
open import Cubical.Data.Vec

open import Cubical.Algebra.CommRing
open import Cubical.Algebra.CommRing.FGIdeal renaming (generatedIdeal to generatedIdealCommRing)
open import Cubical.Algebra.CommAlgebra
open import Cubical.Algebra.CommAlgebra.Ideal

private
  variable
    ℓ : Level

module _ {R : CommRing ℓ} (A : CommAlgebra R ℓ) where
  open CommAlgebraStr (snd A)

  generatedIdeal : {n : ℕ} → FinVec (fst A) n → IdealsIn A
  generatedIdeal = generatedIdealCommRing (CommAlgebra→CommRing A)


-- The simpler case of index inductive definitions. (no induction-recursion)
module IID where

open import LF

-- A code for an IID
-- I - index set
-- E = I for general IIDs
-- E = One for restricted IIDs
data OP (I : Set)(E : Set) : Set1 where
  ι : E -> OP I E
  σ : (A : Set)(γ : A -> OP I E) -> OP I E
  δ : (A : Set)(i : A -> I)(γ : OP I E) -> OP I E

-- The type of constructor arguments. Parameterised over
--  U - the inductive type
-- This is the F of the simple polynomial type μF
Args : {I : Set}{E : Set} -> OP I E ->
     (U : I -> Set) -> Set
Args (ι e)     U = One
Args (σ A γ)   U = A × \a -> Args (γ a) U
Args (δ A i γ) U = ((a : A) -> U (i a)) × \_ -> Args γ U

-- Computing the index
index : {I : Set}{E : Set}(γ : OP I E)(U : I -> Set) -> Args γ U -> E
index (ι e)     U _ = e
index (σ A γ)   U a = index (γ (π₀ a)) U (π₁ a)
index (δ A i γ) U a = index γ U (π₁ a)

-- The assumptions of a particular inductive occurrence in a value.
IndArg : {I : Set}{E : Set}
       (γ : OP I E)(U : I -> Set) ->
       Args γ U -> Set
IndArg (ι e)     U _ = Zero
IndArg (σ A γ)   U a = IndArg (γ (π₀ a)) U (π₁ a)
IndArg (δ A i γ) U a = A + IndArg γ U (π₁ a)

-- Given the assumptions of an inductive occurence in a value we can compute
-- its index.
IndIndex : {I : Set}{E : Set}
          (γ : OP I E)(U : I -> Set) ->
          (a : Args γ U) -> IndArg γ U a -> I
IndIndex (ι e)     U _	      ()
IndIndex (σ A γ)   U arg c       = IndIndex (γ (π₀ arg)) U (π₁ arg) c
IndIndex (δ A i γ) U arg (inl a) = i a
IndIndex (δ A i γ) U arg (inr a) = IndIndex γ U (π₁ arg) a

-- Given the assumptions of an inductive occurrence in a value we can compute
-- its value.
Ind : {I : Set}{E : Set}
      (γ : OP I E)(U : I -> Set) ->
      (a : Args γ U)(v : IndArg γ U a) -> U (IndIndex γ U a v)
Ind (ι e)     U _	      ()
Ind (σ A γ)   U arg c       = Ind (γ (π₀ arg)) U (π₁ arg) c
Ind (δ A i γ) U arg (inl a) = (π₀ arg) a
Ind (δ A i γ) U arg (inr a) = Ind γ U (π₁ arg) a

-- The type of induction hypotheses. Basically
--  forall assumptions, the predicate holds for an inductive occurrence with
--  those assumptions
IndHyp : {I : Set}{E : Set}
      (γ : OP I E)(U : I -> Set) ->
      (F : (i : I) -> U i -> Set)(a : Args γ U) -> Set
IndHyp γ U F a = (v : IndArg γ U a) -> F (IndIndex γ U a v) (Ind γ U a v)

IndHyp₁ : {I : Set}{E : Set}
      (γ : OP I E)(U : I -> Set) ->
      (F : (i : I) -> U i -> Set1)(a : Args γ U) -> Set1
IndHyp₁ γ U F a = (v : IndArg γ U a) -> F (IndIndex γ U a v) (Ind γ U a v)

-- If we can prove a predicate F for any values, we can construct the inductive
-- hypotheses for a given value.
-- Termination note: g will only be applied to values smaller than a
induction :
  {I : Set}{E : Set}
  (γ : OP I E)(U : I -> Set)
  (F : (i : I) -> U i -> Set)
  (g : (i : I)(u : U i) -> F i u)
  (a : Args γ U) -> IndHyp γ U F a
induction γ U F g a = \hyp -> g (IndIndex γ U a hyp) (Ind γ U a hyp)

induction₁ :
  {I : Set}{E : Set}
  (γ : OP I E)(U : I -> Set)
  (F : (i : I) -> U i -> Set1)
  (g : (i : I)(u : U i) -> F i u)
  (a : Args γ U) -> IndHyp₁ γ U F a
induction₁ γ U F g a = \hyp -> g (IndIndex γ U a hyp) (Ind γ U a hyp)


module Oscar.Class.Symmetry where

open import Oscar.Class.Extensionality
open import Oscar.Function
open import Oscar.Level

record Symmetry {a} {A : Set a} {ℓ} (_≤_ : A → A → Set ℓ) : Set (a ⊔ ℓ) where
  field
    ⦃ ′extensionality ⦄ : Extensionality _≤_ (λ ⋆ → flip _≤_ ⋆) id id

  symmetry : ∀ {x y} → x ≤ y → y ≤ x
  symmetry = extension (λ ⋆ → flip _≤_ ⋆)

open Symmetry ⦃ … ⦄ public hiding (′extensionality)

instance

  Symmetry⋆ : ∀
    {a} {A : Set a} {ℓ} {_≤_ : A → A → Set ℓ}
    ⦃ _ : Extensionality _≤_ (λ ⋆ → flip _≤_ ⋆) id id ⦄
    → Symmetry _≤_
  Symmetry.′extensionality Symmetry⋆ = it


module DivMod where

open import IO
open import Data.Nat
open import Data.Nat.DivMod
open import Codata.Musical.Notation
open import Data.String.Base
open import Data.Fin.Base using (toℕ)
open import Level using (0ℓ)

g : ℕ
g = 7 div 5

k : ℕ
k = toℕ (7 mod 5)

showNat : ℕ → String
showNat zero = "Z"
showNat (suc x) = "S (" ++ showNat x ++ ")"

main = run {0ℓ} (putStrLn (showNat g) >> putStrLn (showNat k))


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

open import Categories.Category

module Categories.Object.Initial {o ℓ e} (C : Category o ℓ e) where

open Category C

open import Level

record Initial : Set (o ⊔ ℓ ⊔ e) where
  field
    ⊥ : Obj
    ! : ∀ {A} → (⊥ ⇒ A)
    .!-unique : ∀ {A} → (f : ⊥ ⇒ A) → ! ≡ f

  .!-unique₂ : ∀ {A} → (f g : ⊥ ⇒ A) → f ≡ g
  !-unique₂ f g =
      begin
        f
      ↑⟨ !-unique f ⟩
        !
      ↓⟨ !-unique g ⟩
        g
      ∎
    where
    open HomReasoning

  .⊥-id : (f : ⊥ ⇒ ⊥) → f ≡ id
  ⊥-id f = !-unique₂ f id


{-

The naive, but incorrect, way to define the integers as a HIT.

This file mainly contains a proof that IsoInt ≢ Int, and ends with a
 demonstration of how the same proof strategy fails for BiInvInt.

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

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Function
open import Cubical.Foundations.Isomorphism

open import Cubical.Data.Int
open import Cubical.Data.Nat
open import Cubical.Data.Empty

open import Cubical.Relation.Nullary

data IsoInt : Type₀ where
  zero : IsoInt
  suc : IsoInt -> IsoInt

  -- suc is an isomorphism:
  pred : IsoInt -> IsoInt
  suc-pred : ∀ z -> suc (pred z) ≡ z
  pred-suc : ∀ z -> pred (suc z) ≡ z

suc-iso : Iso IsoInt IsoInt
suc-iso = record { fun = suc ; inv = pred ; rightInv = suc-pred ; leftInv = pred-suc }

-- this submodule is adapted from Section 5 of
--  http://www.cs.ru.nl/~herman/PUBS/HIT-programming.pdf

module NonTrivial where

  -- these two paths are distinct!
  p₁ p₂ : Path IsoInt (suc (pred (suc zero))) (suc zero)
  p₁ i = suc-pred (suc zero) i
  p₂ i = suc (pred-suc zero i)

  -- to prove this we map into S¹, sending p₁ to refl and p₂ to loop

  open import Cubical.HITs.S1

  toS¹ : IsoInt → S¹
  toS¹ zero           = base
  toS¹ (suc x)        = toS¹ x
  toS¹ (pred x)       = toS¹ x
  toS¹ (suc-pred x i) = refl {x = toS¹ x} i
  toS¹ (pred-suc x i) = rotLoop (toS¹ x) i

  p₁≡refl : cong toS¹ p₁ ≡ refl
  p₁≡refl = refl

  p₂≡loop : cong toS¹ p₂ ≡ loop
  p₂≡loop = refl

  -- this is enough to show that p₁ and p₂ cannot be equal
  p₁≢p₂ : ¬ (p₁ ≡ p₂)
  p₁≢p₂ eq = znots 0≡1
    where -- using winding numbers, p₁ ≡ p₂ implies 0 ≡ 1
          0≡1 : 0 ≡ 1
          0≡1 = injPos (cong (winding ∘ cong toS¹) eq)

¬isSet-IsoInt : ¬ (isSet IsoInt)
¬isSet-IsoInt pf = NonTrivial.p₁≢p₂ (pf _ _ NonTrivial.p₁ NonTrivial.p₂)

¬Int≡IsoInt : ¬ (Int ≡ IsoInt)
¬Int≡IsoInt p = ¬isSet-IsoInt (subst isSet p isSetInt)

private

  -- Note: this same proof strategy fails for BiInvInt!

  open import Cubical.HITs.Ints.BiInvInt hiding (zero; suc; pred; suc-pred; pred-suc)
  import Cubical.HITs.Ints.BiInvInt as BiI

  p₁ p₂ : Path BiInvInt (BiI.suc (BiI.pred (BiI.suc BiI.zero))) (BiI.suc BiI.zero)
  p₁ i = BiI.suc-pred (BiI.suc BiI.zero) i
  p₂ i = BiI.suc (BiI.pred-suc BiI.zero i)

  open import Cubical.HITs.S1

  toS¹ : BiInvInt → S¹
  toS¹ BiI.zero            = base
  toS¹ (BiI.suc x)         = toS¹ x
  toS¹ (BiI.predr x)       = toS¹ x
  toS¹ (BiI.predl x)       = toS¹ x
  toS¹ (BiI.suc-predr x i) = refl {x = toS¹ x} i
  toS¹ (BiI.predl-suc x i) = rotLoop (toS¹ x) i

  -- still p₂ maps to loop...
  p₂≡loop : cong toS¹ p₂ ≡ loop
  p₂≡loop = refl

  open import Cubical.Foundations.GroupoidLaws

  -- ...but now so does p₁!
  p₁≡loop : cong toS¹ p₁ ≡ loop
  p₁≡loop = sym (decodeEncode base (cong toS¹ p₁)) ∙ sym (lUnit loop)

  -- if we use BiI.predr instead of BiI.pred (≡ BiI.predl) in p₁ and p₂,
  --  both paths in S¹ are refl


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

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

private
  variable
    ℓ ℓ₁ ℓ₂ ℓ₃ : Level

-- Function extensionality is an equivalence
module _ {A : Type ℓ} {B : A → Type ℓ₁} {f g : (x : A) → B x} where
  private
    fib : (p : f ≡ g) → fiber funExt p
    fib p = (funExt⁻ p , refl)

    funExt-fiber-isContr : (p : f ≡ g) → (fi : fiber funExt p) → fib p ≡ fi
    funExt-fiber-isContr p (h , eq) i = (funExt⁻ (eq (~ i)) , λ j → eq (~ i ∨ j))

  funExt-isEquiv : isEquiv funExt
  equiv-proof funExt-isEquiv p = (fib p , funExt-fiber-isContr p)

  funExtEquiv : (∀ x → f x ≡ g x) ≃ (f ≡ g)
  funExtEquiv = (funExt {B = B} , funExt-isEquiv)

  funExtPath : (∀ x → f x ≡ g x) ≡ (f ≡ g)
  funExtPath = ua funExtEquiv

-- Function extensionality for binary functions
funExt₂ : {A : Type ℓ} {B : A → Type ℓ₁} {C : (x : A) → B x → Type ℓ₂}
            {f g : (x : A) → (y : B x) → C x y}
          → ((x : A) (y : B x) → f x y ≡ g x y) → f ≡ g
funExt₂ p i x y = p x y i

-- Function extensionality for binary functions is an equivalence
module _ {A : Type ℓ} {B : A → Type ℓ₁} {C : (x : A) → B x → Type ℓ₂}
         {f g : (x : A) → (y : B x) → C x y} where
  private
    appl₂ : f ≡ g → ∀ x y → f x y ≡ g x y
    appl₂ eq x y i = eq i x y

    fib : (p : f ≡ g) → fiber funExt₂ p
    fib p = (appl₂ p , refl)

    funExt₂-fiber-isContr : (p : f ≡ g) → (fi : fiber funExt₂ p) → fib p ≡ fi
    funExt₂-fiber-isContr p (h , eq) i = (appl₂ (eq (~ i)) , λ j → eq (~ i ∨ j))

  funExt₂-isEquiv : isEquiv funExt₂
  equiv-proof funExt₂-isEquiv p = (fib p , funExt₂-fiber-isContr p)

  funExt₂Equiv : (∀ x y → f x y ≡ g x y) ≃ (f ≡ g)
  funExt₂Equiv = (funExt₂ , funExt₂-isEquiv)

  funExt₂Path : (∀ x y → f x y ≡ g x y) ≡ (f ≡ g)
  funExt₂Path = ua funExt₂Equiv

-- Function extensionality for ternary functions
funExt₃ : {A : Type ℓ} {B : A → Type ℓ₁} {C : (x : A) → B x → Type ℓ₂}
          {D : (x : A) → (y : B x) → C x y → Type ℓ₃}
          {f g : (x : A) → (y : B x) → (z : C x y) → D x y z}
        → ((x : A) (y : B x) (z : C x y) → f x y z ≡ g x y z) → f ≡ g
funExt₃ p i x y z = p x y z i

-- Function extensionality for ternary functions is an equivalence
module _ {A : Type ℓ} {B : A → Type ℓ₁} {C : (x : A) → B x → Type ℓ₂}
         {D : (x : A) → (y : B x) → C x y → Type ℓ₃}
         {f g : (x : A) → (y : B x) → (z : C x y) → D x y z} where
  private
    appl₃ : f ≡ g → ∀ x y z → f x y z ≡ g x y z
    appl₃ eq x y z i = eq i x y z

    fib : (p : f ≡ g) → fiber funExt₃ p
    fib p = (appl₃ p , refl)

    funExt₃-fiber-isContr : (p : f ≡ g) → (fi : fiber funExt₃ p) → fib p ≡ fi
    funExt₃-fiber-isContr p (h , eq) i = (appl₃ (eq (~ i)) , λ j → eq (~ i ∨ j))

  funExt₃-isEquiv : isEquiv funExt₃
  equiv-proof funExt₃-isEquiv p = (fib p , funExt₃-fiber-isContr p)

  funExt₃Equiv : (∀ x y z → f x y z ≡ g x y z) ≃ (f ≡ g)
  funExt₃Equiv = (funExt₃ , funExt₃-isEquiv)

  funExt₃Path : (∀ x y z → f x y z ≡ g x y z) ≡ (f ≡ g)
  funExt₃Path = ua funExt₃Equiv

-- Puzzle: Can one generalize this to n-ary functions?


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

open import LogicalFormulae
open import Groups.Abelian.Definition
open import Groups.Homomorphisms.Definition
open import Setoids.Setoids
open import Sets.EquivalenceRelations
open import Rings.Definition
open import Lists.Lists
open import Rings.Homomorphisms.Definition

module Rings.Polynomial.Ring {a b : _} {A : Set a} {S : Setoid {a} {b} A} {_+_ _*_ : A → A → A} (R : Ring S _+_ _*_) where

open Ring R
open Setoid S
open Equivalence eq
open import Groups.Polynomials.Group additiveGroup
open import Groups.Polynomials.Definition additiveGroup
open import Rings.Polynomial.Multiplication R

polyRing : Ring naivePolySetoid _+P_ _*P_
Ring.additiveGroup polyRing = polyGroup
Ring.*WellDefined polyRing {a} {b} {c} {d} = *PwellDefined {a} {b} {c} {d}
Ring.1R polyRing = 1R :: []
Ring.groupIsAbelian polyRing {x} {y} = AbelianGroup.commutative (abelian (record { commutative = Ring.groupIsAbelian R })) {x} {y}
Ring.*Associative polyRing {a} {b} {c} = *Passoc {a} {b} {c}
Ring.*Commutative polyRing {a} {b} = p*Commutative {a} {b}
Ring.*DistributesOver+ polyRing {a} {b} {c} = *Pdistrib {a} {b} {c}
Ring.identIsIdent polyRing {a} = *Pident {a}

polyInjectionIsHom : RingHom R polyRing polyInjection
RingHom.preserves1 polyInjectionIsHom = reflexive ,, record {}
RingHom.ringHom polyInjectionIsHom = reflexive ,, (reflexive ,, record {})
GroupHom.groupHom (RingHom.groupHom polyInjectionIsHom) = reflexive ,, record {}
GroupHom.wellDefined (RingHom.groupHom polyInjectionIsHom) = SetoidInjection.wellDefined polyInjectionIsInj


------------------------------------------------------------------------------
-- Group theory base
------------------------------------------------------------------------------

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

module GroupTheory.Base where

infix  8 _⁻¹
infixl 7 _·_

------------------------------------------------------------------------------
-- First-order logic with equality.
open import Common.FOL.FOL-Eq public renaming ( D to G )

-- Group theory axioms
postulate
  ε   : G          -- The identity element.
  _·_ : G → G → G  -- The binary operation.
  _⁻¹ : G → G      -- The inverse function.

  -- We choose a non-redundant set of axioms. See for example (Mac
  -- Lane and Garret 1999, exercises 5-7, p. 50-51, or Hodges 1993,
  -- p. 37).
  assoc         : ∀ a b c → a · b · c ≡ a · (b · c)
  leftIdentity  : ∀ a → ε · a         ≡ a
  leftInverse   : ∀ a → a ⁻¹ · a      ≡ ε
{-# ATP axioms assoc leftIdentity leftInverse #-}

------------------------------------------------------------------------------
-- References
--
-- Hodges, W. (1993). Model Theory. Vol. 42. Encyclopedia of
-- Mathematics and its Applications. Cambridge University Press.
--
-- Mac Lane, S. and Birkhof, G. (1999). Algebra. 3rd ed. AMS Chelsea
-- Publishing.


module regular-star where

open import Level renaming ( suc to Suc ; zero to Zero )
open import Data.List
open import Data.Nat hiding ( _≟_ )
open import Data.Fin hiding ( _+_ )
open import Data.Empty
open import Data.Unit
open import Data.Product
-- open import Data.Maybe
open import  Relation.Nullary
open import  Relation.Binary.PropositionalEquality hiding ( [_] )
open import logic
open import nat
open import automaton
open import regular-language

open import nfa
open import sbconst2
open import finiteSet
open import finiteSetUtil
open import Relation.Binary.PropositionalEquality hiding ( [_] )
open import regular-concat

open Automaton
open FiniteSet

open RegularLanguage

Star-NFA :  {Σ : Set} → (A : RegularLanguage Σ ) → NAutomaton (states A ) Σ
Star-NFA {Σ} A  = record { Nδ = δnfa ; Nend = nend }
   module Star-NFA where
       δnfa : states A → Σ → states A → Bool
       δnfa q i q₁ with aend (automaton A) q
       ... | true = equal? (afin A) ( astart A) q₁
       ... | false = equal? (afin A) (δ (automaton A) q i) q₁
       nend : states A → Bool
       nend q = aend (automaton A) q

Star-NFA-start :  {Σ : Set} → (A : RegularLanguage Σ ) → states A  → Bool
Star-NFA-start A q = equal? (afin A) (astart A) q \/  aend (automaton A) q

SNFA-exist : {Σ : Set} → (A : RegularLanguage Σ ) → (states A → Bool) → Bool
SNFA-exist A qs = exists (afin A) qs

M-Star : {Σ : Set} → (A : RegularLanguage Σ ) → RegularLanguage Σ
M-Star {Σ} A  = record {
       states = states A  → Bool
     ; astart = Star-NFA-start A
     ; afin = fin→  (afin A)
     ; automaton = subset-construction (SNFA-exist A ) (Star-NFA A )
   }

open Split

open _∧_

open NAutomaton
open import Data.List.Properties

closed-in-star :  {Σ : Set} → (A B : RegularLanguage Σ ) → ( x : List Σ ) → isRegular (Star (contain A) ) x ( M-Star A  )
closed-in-star {Σ} A B x = ≡-Bool-func closed-in-star→ closed-in-star← where
    NFA = (Star-NFA A )

    closed-in-star→ : Star (contain A)  x ≡ true → contain (M-Star A ) x ≡ true
    closed-in-star→ star = {!!}

    open Found

    closed-in-star← : contain (M-Star A ) x ≡ true → Star (contain A)  x ≡ true
    closed-in-star← C with subset-construction-lemma← (SNFA-exist A ) NFA {!!} x C
    ... | CC = {!!}


-- Copyright:  (c) 2016 Ertugrul Söylemez
-- License:    BSD3
-- Maintainer: Ertugrul Söylemez <esz@posteo.de>

module Data.Int where

open import Algebra.Group
open import Classes
open import Core
open import Data.Int.Core
open import Data.Int.Core public
  using (ℤ; ℤ-Negative; ℤ-Number; negsuc; pos)

ℤ,+ : Group
ℤ,+ =
  record {
    semigroup = record {
      A = ℤ;
      Eq = PropEq ℤ;
      semigroupOver = record {
        _⋄_ = _+_;
        ⋄-cong = cong2 _+_;
        assoc = Props.+-assoc
      }
    };
    isGroup = record {
      isMonoid = record {
        id = 0;
        left-id = Props.+-left-id;
        right-id = Props.+-right-id
      };
      iso = λ x → record {
        inv = neg x;
        left-inv = Props.+-left-inv x;
        right-inv = Props.+-right-inv x
      };
      inv-cong = cong neg
    }
  }

ℤ,* : Monoid
ℤ,* =
  record {
    semigroup = record {
      A = ℤ;
      Eq = PropEq ℤ;
      semigroupOver = record {
        _⋄_ = _*_;
        ⋄-cong = cong2 _*_;
        assoc = Props.*-assoc
      }
    };
    isMonoid = record {
      id = 1;
      left-id = Props.*-left-id;
      right-id = Props.*-right-id
    }
  }


------------------------------------------------------------------------
-- The Agda standard library
--
-- Coprimality
------------------------------------------------------------------------

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

module Data.Integer.Coprimality where

open import Data.Integer
open import Data.Integer.Divisibility
open import Data.Integer.Properties
import Data.Nat.Coprimality as ℕ
import Data.Nat.Divisibility as ℕ
open import Function using (_on_)
open import Level using (0ℓ)
open import Relation.Binary using (Rel; Decidable; Symmetric)
open import Relation.Binary.PropositionalEquality using (subst)

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

Coprime : Rel ℤ 0ℓ
Coprime = ℕ.Coprime on ∣_∣

------------------------------------------------------------------------
-- Properties of coprimality

sym : Symmetric Coprime
sym = ℕ.sym

coprime? : Decidable Coprime
coprime? x y = ℕ.coprime? ∣ x ∣ ∣ y ∣

coprime-divisor : ∀ i j k → Coprime i j → i ∣ j * k → i ∣ k
coprime-divisor i j k c eq =
  ℕ.coprime-divisor c (subst (∣ i ∣ ℕ.∣_ ) (abs-*-commute j k) eq)


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

open import Equivalence
open import NTypes.Contractible
open import PathOperations
open import Types

fib : ∀ {a b} {A : Set a} {B : Set b}
  (f : A → B) (y : B) →
  Set _
fib {A = A} f y = Σ A λ x → f x ≡ y

fib→dom : ∀ {a b} {A : Set a} {B : Set b} (f : A → B) →
  Σ B (fib f) → A
fib→dom f (b , a , p) = a

dom→fib : ∀ {a b} {A : Set a} {B : Set b} (f : A → B) →
  A → Σ B (fib f)
dom→fib f a = f a , a , refl

fib-dom-eq :  ∀ {a b} {A : Set a} {B : Set b} (f : A → B) →
  Σ B (fib f) ≃ A
fib-dom-eq {A = A} {B = B} f
  = fib→dom f
  , (dom→fib f , λ _ → refl)
  , (dom→fib f , λ {(b , a , p) →
      ap (swap ∘ _,_ a) (π₂ (pp-space-contr (f a)) (b , p))})
  where
  swap : (Σ A λ x → Σ B λ y → f x ≡ y) → Σ B (fib f)
  swap (b , a , p) = a , b , p


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

open import LogicalFormulae
open import Lists.Definition
open import Lists.Fold.Fold
open import Lists.Concat
open import Lists.Length
open import Numbers.Naturals.Semiring

module Lists.Monad where

open import Lists.Map.Map public

flatten : {a : _} {A : Set a} → (l : List (List A)) → List A
flatten [] = []
flatten (l :: ls) = l ++ flatten ls

flatten' : {a : _} {A : Set a} → (l : List (List A)) → List A
flatten' = fold _++_ []

flatten=flatten' : {a : _} {A : Set a} (l : List (List A)) → flatten l ≡ flatten' l
flatten=flatten' [] = refl
flatten=flatten' (l :: ls) = applyEquality (l ++_) (flatten=flatten' ls)

lengthFlatten : {a : _} {A : Set a} (l : List (List A)) → length (flatten l) ≡ (fold _+N_ zero (map length l))
lengthFlatten [] = refl
lengthFlatten (l :: ls) rewrite lengthConcat l (flatten ls) | lengthFlatten ls = refl

flattenConcat : {a : _} {A : Set a} (l1 l2 : List (List A)) → flatten (l1 ++ l2) ≡ (flatten l1) ++ (flatten l2)
flattenConcat [] l2 = refl
flattenConcat (l1 :: ls) l2 rewrite flattenConcat ls l2 | concatAssoc l1 (flatten ls) (flatten l2) = refl

pure : {a : _} {A : Set a} → A → List A
pure a = [ a ]

bind : {a b : _} {A : Set a} {B : Set b} → (f : A → List B) → List A → List B
bind f l = flatten (map f l)

private
  leftIdentLemma : {a : _} {A : Set a} (xs : List A) → flatten (map pure xs) ≡ xs
  leftIdentLemma [] = refl
  leftIdentLemma (x :: xs) rewrite leftIdentLemma xs = refl

leftIdent : {a b : _} {A : Set a} {B : Set b} → (f : A → List B) → {x : A} → bind pure (f x) ≡ f x
leftIdent f {x} with f x
leftIdent f {x} | [] = refl
leftIdent f {x} | y :: ys rewrite leftIdentLemma ys = refl

rightIdent : {a b : _} {A : Set a} {B : Set b} → (f : A → List B) → {x : A} → bind f (pure x) ≡ f x
rightIdent f {x} with f x
rightIdent f {x} | [] = refl
rightIdent f {x} | y :: ys rewrite appendEmptyList ys = refl

associative : {a b c : _} {A : Set a} {B : Set b} {C : Set c} → (f : A → List B) (g : B → List C) → {x : List A} → bind g (bind f x) ≡ bind (λ a → bind g (f a)) x
associative f g {[]} = refl
associative f g {x :: xs} rewrite mapConcat (f x) (flatten (map f xs)) g | flattenConcat (map g (f x)) (map g (flatten (map f xs))) = applyEquality (flatten (map g (f x)) ++_) (associative f g {xs})


-- Minimal implicational logic, vector-based de Bruijn approach, initial encoding

module Vi.ArrMp where

open import Lib using (Nat; suc; _+_; Fin; fin; Vec; _,_; proj; VMem; mem)

-- Types

infixr 0 _=>_
data Ty : Set where
  UNIT :             Ty
  _=>_ : Ty -> Ty -> Ty

-- Context and truth judgement

Cx : Nat -> Set
Cx n = Vec Ty n

isTrue : forall {tn} -> Ty -> Fin tn -> Cx tn -> Set
isTrue a i tc = VMem a i tc

-- Terms

module ArrMp where
  infixr 0 lam=>_
  infixl 1 _$_
  data Tm {tn} (tc : Cx tn) : Ty -> Set where
    var    : forall {a i} -> isTrue a i tc             -> Tm tc a
    lam=>_ : forall {a b} -> Tm (tc , a) b             -> Tm tc (a => b)
    _$_    : forall {a b} -> Tm tc (a => b) -> Tm tc a -> Tm tc b

  v : forall {tn} (k : Nat) {tc : Cx (suc (k + tn))} -> Tm tc (proj tc (fin k))
  v i = var (mem i)

  Thm : Ty -> Set
  Thm a = forall {tn} {tc : Cx tn} -> Tm tc a
open ArrMp public

-- Example theorems

aI : forall {a} -> Thm (a => a)
aI =
  lam=> v 0

aK : forall {a b} -> Thm (a => b => a)
aK =
  lam=>
    lam=> v 1

aS : forall {a b c} -> Thm ((a => b => c) => (a => b) => a => c)
aS =
  lam=>
    lam=>
      lam=> v 2 $ v 0 $ (v 1 $ v 0)

tSKK : forall {a} -> Thm (a => a)
tSKK {a = a} =
  aS {b = a => a} $ aK $ aK