{-# OPTIONS --safe --experimental-lossy-unification #-}
module Cubical.Algebra.CommRing.Instances.MultivariatePoly where

open import Cubical.Foundations.Prelude

open import Cubical.Data.Nat renaming(_+_ to _+n_; _·_ to _·n_)
open import Cubical.Data.Vec

open import Cubical.Algebra.Ring
open import Cubical.Algebra.CommRing

open import Cubical.Algebra.Polynomials.Multivariate.Base
open import Cubical.Algebra.Polynomials.Multivariate.Properties

private variable
  ℓ ℓ' : Level

module _ (A' : CommRing ℓ) (n : ℕ) where

  private
    A = fst A'
    Ar = CommRing→Ring A'

  open CommRingStr
  open RingTheory Ar
  open Nth-Poly-structure A' n

  PolyCommRing : CommRing ℓ
  fst PolyCommRing = Poly A' n
  0r (snd PolyCommRing) = 0P
  1r (snd PolyCommRing) = 1P
  _+_ (snd PolyCommRing) = _Poly+_
  _·_ (snd PolyCommRing) = _Poly*_
  - snd PolyCommRing = Poly-inv
  isCommRing (snd PolyCommRing) = makeIsCommRing
                                  trunc
                                  Poly+-assoc
                                  Poly+-Rid
                                  Poly+-rinv
                                  Poly+-comm
                                  Poly*-assoc
                                  Poly*-Rid
                                  Poly*-Rdist
                                  Poly*-comm


{-# OPTIONS --without-K #-}
open import Data.Nat
open import Data.Two
open import Data.Zero
open import Data.Fin.NP
open import Type
open import Function
open import Relation.Binary.PropositionalEquality.NP

import Explore.Universe.Base
open import Explore.Core
open import Explore.Zero
open import Explore.One
open import Explore.Two
open import Explore.Universe.Type

-- Exploring Fin comes in two flavors Regular & Custom
-- We recommend Regular if you want to work for arbitrary values of n.
-- We recommend Custom if you want to work for particular values of n (2, 6...).
module Explore.Fin where

module Regular n = Explore.Universe.Base (≃ᵁ (Finᵁ n) (Fin n) (Finᵁ≃Fin n))

module Custom where
  module _ n where
    open Explore.Universe.Base (≃ᵁ (Finᵁ' n) (Fin n) (Finᵁ'≃Fin n))
      public

  Finᵉ0-𝟘ᵉ : (λ {M : ★₀} (ε : M) op f → explore 0 ε op (f ∘ Fin▹𝟘)) ≡ 𝟘ᵉ
  Finᵉ0-𝟘ᵉ = refl

  Finᵉ1-𝟙ᵉ : (λ {M : ★₀} (ε : M) op f → explore 1 ε op (f ∘ Fin▹𝟙)) ≡ 𝟙ᵉ
  Finᵉ1-𝟙ᵉ = refl

  Finᵉ2-𝟚ᵉ : (λ {M : ★₀} (ε : M) op f → explore 2 ε op (f ∘ Fin▹𝟚)) ≡ 𝟚ᵉ
  Finᵉ2-𝟚ᵉ = refl

module ByHand {ℓ} where
  Finᵉ' : ∀ n → Explore ℓ (Fin n)
  Finᵉ' zero    z _⊕_ f = z
  Finᵉ' (suc n) z _⊕_ f = f zero ⊕ Finᵉ' n z _⊕_ (f ∘ suc)

  -- Finᵉ and Finᵉ' are extensionally equal.
  -- Moreover the simplicity of the proof shows that the two functions are computing
  -- in the same way.
  Finᵉ-Finᵉ' : ∀ n {M} (ε : M) (_⊕_ : M → M → M) (f : Fin n → M) → Regular.explore n ε _⊕_ f ≡ Finᵉ' n ε _⊕_ f
  Finᵉ-Finᵉ' zero    ε _⊕_ f = idp
  Finᵉ-Finᵉ' (suc n) ε _⊕_ f = ap (_⊕_ (f zero))
                                  (Finᵉ-Finᵉ' n ε _⊕_ (f ∘ suc))


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

open import Cubical.Core.Primitives
open import Cubical.Data.Nat
open import Cubical.Data.Empty

record ℕ₋₁ : Type₀ where
  constructor -1+_
  field
    n : ℕ

pattern neg1 = -1+ zero
pattern ℕ→ℕ₋₁ n = -1+ (suc n)

1+_ : ℕ₋₁ → ℕ
1+_ (-1+ n) = n

suc₋₁ : ℕ₋₁ → ℕ₋₁
suc₋₁ (-1+ n) = -1+ (suc n)

-- Natural number and negative integer literals for ℕ₋₁

open import Cubical.Data.Nat.Literals public

instance
  fromNatℕ₋₁ : HasFromNat ℕ₋₁
  fromNatℕ₋₁ = record { Constraint = λ _ → Unit ; fromNat = ℕ→ℕ₋₁ }

instance
  fromNegℕ₋₁ : HasFromNeg ℕ₋₁
  fromNegℕ₋₁ = record { Constraint = λ { (suc (suc _)) → ⊥ ; _ → Unit }
                       ; fromNeg = λ { zero → 0 ; (suc zero) → neg1 } }


module Data.Tuple.Function where

open import Data
open import Data.Tuple as Tuple using (_⨯_ ; _,_)
open import Functional
open import Type

module _ {ℓ₁ ℓ₂ ℓ₃} {T₁ : Type{ℓ₁}} {T₂ : Type{ℓ₂}} {T₃ : Type{ℓ₃}} where
  _,⃝_ : (T₁ → T₂) → (T₁ → T₃) → (T₁ → (T₂ ⨯ T₃))
  _,⃝_ f g x = (f(x) , g(x))

  left : (T₁ → (T₂ ⨯ T₃)) → (T₁ → T₂)
  left =  Tuple.left ∘_

  right : (T₁ → (T₂ ⨯ T₃)) → (T₁ → T₃)
  right =  Tuple.right ∘_


module Oscar.Property.Extensionality where

open import Oscar.Level

record Extensionality
  {a} {A : Set a} {b} {B : A → Set b} {ℓ₁}
    (_≤₁_ : (x : A) → B x → Set ℓ₁)
  {c} {C : A → Set c} {d} {D : ∀ {x} → B x → Set d} {ℓ₂}
    (_≤₂_ : ∀ {x} → C x → ∀ {y : B x} → D y → Set ℓ₂)
    (μ₁ : (x : A) → C x)
    (μ₂ : ∀ {x} → (y : B x) → D y)
  : Set (a ⊔ ℓ₁ ⊔ b ⊔ ℓ₂) where
  field
    extensionality : ∀ {x} {y : B x} → x ≤₁ y → μ₁ x ≤₂ μ₂ y

open Extensionality ⦃ … ⦄ public

extension : ∀
    {a} {A : Set a}
    {b} {B : A → Set b}
    {ℓ₁} {_≤₁_ : (x : A) → B x → Set ℓ₁}
    {c} {C : A → Set c} {d} {D : ∀ {x} → B x → Set d} {ℓ₂}
  (_≤₂_ : ∀ {x} → C x → ∀ {y : B x} → D y → Set ℓ₂)
    {μ₁ : (x : A) → C x}
    {μ₂ : ∀ {x} → (y : B x) → D y}
  ⦃ _ : Extensionality _≤₁_ _≤₂_ μ₁ μ₂ ⦄
    {x} {y : B x}
  → x ≤₁ y → μ₁ x ≤₂ μ₂ y
extension _≤₂_ = extensionality {_≤₂_ = _≤₂_}


-- Andreas, 2011-10-03
-- allow matching on irrelevant data as long as there is at most one
-- matching constructor
{-# OPTIONS --experimental-irrelevance #-}
module MatchIrrelevant where

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

data NAT : Nat -> Set where
  Zero : NAT zero
  Suc  : (n : Nat) -> NAT n -> NAT (suc n)

-- should succeed:
f : (n : Nat).(N : NAT n) -> Nat
f zero Zero = zero
f (suc n) (Suc .n N) = f n N

-- prove the equations to test reduction

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

fzero : f zero Zero ≡ zero
fzero = refl

fsuc : (n : Nat)(N : NAT n) -> f (suc n) (Suc n N) ≡ f n N
fsuc n N = refl

{- DOES NOT YET WORK and probably should never work
fzero' : (N : NAT zero) → f zero N ≡ zero
fzero' N = refl
-}

{-
-- should fail:
f' : (n : Nat).(N : NAT n) -> Nat
f' zero Zero = zero
f' (suc _) (Suc n N) = n
-}

{-
-- should fail:
g : {n : Nat}.(N : NAT n) -> Nat
g Zero = zero
g (Suc _ N) = g N
-}

{-
data Fin : Nat -> Set where
  zero : (n : Nat) -> Fin (suc n)
  suc  : (n : Nat) -> Fin n -> Fin (suc n)

-- should fail:
toNat : {n : Nat} → .(Fin n) -> Nat
toNat (zero n) = zero
toNat (suc n i) = suc (toNat i)
-}

{-
-- fails for other reasons
weak : {n : Nat} → .(Fin n) -> Fin (suc n)
weak (zero n) = zero (suc n)
weak (suc n i) = suc (suc n) (weak i)
-}


module list-thms where

-- see list-thms2 for more

open import bool
open import bool-thms
open import functions
open import list
open import nat
open import nat-thms
open import product-thms
open import logic

++[] : ∀{ℓ}{A : Set ℓ} → (l : 𝕃 A) → l ++ [] ≡ l
++[] [] = refl
++[] (x :: xs) rewrite ++[] xs = refl

++-assoc : ∀ {ℓ}{A : Set ℓ} (l1 l2 l3 : 𝕃 A) →
           (l1 ++ l2) ++ l3 ≡ l1 ++ (l2 ++ l3)
++-assoc [] l2 l3 = refl
++-assoc (x :: xs) l2 l3 rewrite ++-assoc xs l2 l3 = refl

length-++ : ∀{ℓ}{A : Set ℓ}(l1 l2 : 𝕃 A) →
            length (l1 ++ l2) ≡ (length l1) + (length l2)
length-++ [] l2 = refl
length-++ (h :: t) l2 rewrite length-++ t l2 = refl

map-append : ∀ {ℓ ℓ'} {A : Set ℓ} {B : Set ℓ'} →
             (f : A → B) (l1 l2 : 𝕃 A) →
             map f (l1 ++ l2) ≡ (map f l1) ++ (map f l2)
map-append f [] l2 = refl
map-append f (x :: xs) l2 rewrite map-append f xs l2 = refl

map-compose : ∀ {ℓ ℓ' ℓ''} {A : Set ℓ} {B : Set ℓ'}{C : Set ℓ''} →
             (f : B → C) (g : A → B) (l : 𝕃 A) →
             map f (map g l) ≡ map (f ∘ g) l
map-compose f g [] = refl
map-compose f g (x :: xs) rewrite map-compose f g xs = refl

foldr-monoid : ∀{ℓ}{A B : Set ℓ}{l₁ l₂ : 𝕃 A}{_⊗_ : B → B → B}{f : A → B}{b : B}
  {p-sym : ∀{a} → b ⊗ a ≡ a}
  {p-assoc : ∀{a b c} → a ⊗ (b ⊗ c) ≡ (a ⊗ b) ⊗ c}
  → (foldr (λ x r → (f x) ⊗ r) b l₁) ⊗ (foldr (λ x r → (f x) ⊗ r) b l₂) ≡ foldr (λ x r → (f x) ⊗ r) b (l₁ ++ l₂)
foldr-monoid {ℓ}{A}{B}{[]}{l₂}{_⊗_}{f}{b}{p-sym} rewrite p-sym {foldr (λ x → _⊗_ (f x)) b l₂} = refl
foldr-monoid {ℓ}{A}{B}{y :: ys}{l₂}{_⊗_}{f}{b}{p-sym}{p-assoc}
 rewrite
   sym (p-assoc {f y}{foldr (λ x → _⊗_ (f x)) b ys}{foldr (λ x → _⊗_ (f x)) b l₂})
 | foldr-monoid {l₁ = ys}{l₂}{_⊗_}{f}{b}{p-sym}{p-assoc}
 = refl

foldr-append : ∀{ℓ₂}{B : Set ℓ₂}{l₁ l₂ : 𝕃 (𝕃 B)} → (foldr _++_ [] l₁) ++ (foldr _++_ [] l₂) ≡ foldr _++_ [] (l₁ ++ l₂)
foldr-append {l₁ = []}{l₂} = refl
foldr-append {_}{B}{l₁ = x :: xs}{l₂} rewrite sym (foldr-append {l₁ = xs}{l₂}) = ++-assoc x (foldr _++_ [] xs) (foldr _++_ [] l₂)

foldr-append-fun : ∀{ℓ₁ ℓ₂}{A : Set ℓ₁}{B : Set ℓ₂}{l₁ l₂ : 𝕃 (A → 𝕃 B)}{a : A}
  → (foldr (λ f → _++_ (f a)) [] l₁) ++ (foldr (λ f → _++_ (f a)) [] l₂) ≡ foldr (λ f → _++_ (f a)) [] (l₁ ++ l₂)
foldr-append-fun {l₁ = []}{_}{a} = refl
foldr-append-fun {l₁ = x :: l₁}{l₂}{a}
 rewrite
    ++-assoc (x a) (foldr (λ f → _++_ (f a)) [] l₁) (foldr (λ f → _++_ (f a)) [] l₂)
  | foldr-append-fun {l₁ = l₁}{l₂}{a}
 = refl

foldr-map : ∀{ℓ}{A : Set ℓ}{l : 𝕃 A} → l ≡ foldr _++_ [] (map (λ x₁ → x₁ :: []) l)
foldr-map {_}{_}{[]} = refl
foldr-map {ℓ}{A}{x :: xs} rewrite sym (foldr-map {ℓ}{A}{xs}) = refl

invert𝕃 : ∀{ℓ}{A : Set ℓ}{t : A}{ts : 𝕃 A} → t :: ts ≢ []
invert𝕃 ()

length-repeat : ∀{ℓ}{A : Set ℓ} (n : ℕ) (a : A) → length (repeat n a) ≡ n
length-repeat 0 a = refl
length-repeat (suc n) a rewrite length-repeat n a = refl

map-repeat : ∀ {ℓ ℓ'}{A : Set ℓ}{B : Set ℓ'}(n : ℕ)(a : A)(f : A → B) → map f (repeat n a) ≡ repeat n (f a)
map-repeat 0 a f = refl
map-repeat (suc x) a f rewrite map-repeat x a f = refl

length-map : ∀{ℓ ℓ'} {A : Set ℓ} {B : Set ℓ'} (f : A → B)(l : 𝕃 A) → length (map f l) ≡ length l
length-map f [] = refl
length-map f (head :: tail) rewrite length-map f tail = refl

length-reverse-helper : ∀{ℓ}{A : Set ℓ}(h l : 𝕃 A) →
                      length (reverse-helper h l) ≡ length h + length l
length-reverse-helper h [] rewrite +0 (length h) = refl
length-reverse-helper h (x :: xs) rewrite length-reverse-helper (x :: h) xs = sym (+suc (length h) (length xs))

length-reverse : ∀{ℓ}{A : Set ℓ}(l : 𝕃 A) → length (reverse l) ≡ length l
length-reverse l = length-reverse-helper [] l

reverse-++h : ∀{ℓ}{A : Set ℓ}(l1 l2 : 𝕃 A) → reverse-helper l1 l2 ≡ reverse-helper [] l2 ++ l1
reverse-++h l1 [] = refl
reverse-++h l1 (x :: xs) rewrite reverse-++h (x :: l1) xs | reverse-++h (x :: []) xs | ++-assoc (reverse xs) (x :: []) l1 = refl

reverse-++ : ∀{ℓ}{A : Set ℓ}(l1 l2 : 𝕃 A) → reverse(l1 ++ l2) ≡ reverse(l2) ++ reverse(l1)
reverse-++ [] l2 rewrite ++[] (reverse l2) = refl
reverse-++ (x :: xs) l2 rewrite reverse-++h (x :: []) (xs ++ l2) | reverse-++ xs l2 | ++-assoc (reverse l2) (reverse xs) (x :: []) | sym (reverse-++h (x :: []) xs) = refl

reverse-involution-aux : ∀{ℓ}{A : Set ℓ}(h h' l : 𝕃 A) → reverse-helper h (reverse-helper h' l) ≡ (reverse-helper [] h') ++ l ++ h
reverse-involution-aux h h' [] = reverse-++h h h'
reverse-involution-aux h h' (x₁ :: l) rewrite reverse-involution-aux h (x₁ :: h') l | reverse-++h (x₁ :: []) h' | ++-assoc (reverse-helper [] h') (x₁ :: []) (l ++ h) = refl

reverse-involution : ∀{ℓ}{A : Set ℓ}(l : 𝕃 A) → reverse (reverse l) ≡ l
reverse-involution l rewrite reverse-involution-aux [] [] l = ++[] l

reverse-++-bad : ∀{ℓ}{A : Set ℓ}(l1 l2 : 𝕃 A) → reverse-bad (l1 ++ l2) ≡ reverse-bad l2 ++ reverse-bad l1
reverse-++-bad [] l2 = sym (++[] (reverse-bad l2))
reverse-++-bad (x :: l1) l2 rewrite reverse-++-bad l1 l2 = ++-assoc (reverse-bad l2) (reverse-bad l1) (x :: [])

reverse-involution-bad : ∀{ℓ}{A : Set ℓ}(l : 𝕃 A) → reverse-bad (reverse-bad l) ≡ l
reverse-involution-bad [] = refl
reverse-involution-bad (x :: xs) rewrite reverse-++-bad (reverse-bad xs) (x :: []) | reverse-involution-bad xs = refl

=𝕃-refl : ∀{ℓ}{A : Set ℓ}{l1 : 𝕃 A} → (eq : A → A → 𝔹) → ((x y : A) → x ≡ y → eq x y ≡ tt) → =𝕃 eq l1 l1 ≡ tt
=𝕃-refl{l1 = []} eq rise = refl
=𝕃-refl{l1 = x :: xs} eq rise = &&-combo (rise x x refl) (=𝕃-refl{l1 = xs} eq rise)

≡𝕃-from-= : ∀{ℓ}{A : Set ℓ}{l1 l2 : 𝕃 A} → (eq : A → A → 𝔹) → ((x y : A) → eq x y ≡ tt → x ≡ y) → =𝕃 eq l1 l2 ≡ tt → l1 ≡ l2
≡𝕃-from-={l1 = []}{[]} eq drop p = refl
≡𝕃-from-={l1 = x :: xs}{[]} eq drop ()
≡𝕃-from-={l1 = []}{y :: ys} eq drop ()
≡𝕃-from-={l1 = x :: xs}{y :: ys} eq drop p rewrite ≡𝕃-from-={l1 = xs} eq drop (&&-snd{eq x y}{=𝕃 eq xs ys} p) |  drop x y (&&-fst p) = refl

=𝕃-from-≡ : ∀{ℓ}{A : Set ℓ}{l1 l2 : 𝕃 A} → (eq : A → A → 𝔹) → ((x y : A) → x ≡ y → eq x y ≡ tt) → l1 ≡ l2  → =𝕃 eq l1 l2 ≡ tt
=𝕃-from-≡{l2 = l2} eq rise p rewrite p  = =𝕃-refl{l1 = l2} eq rise

multi++-assoc : ∀{ℓ}{A : Set ℓ} → (Ls : 𝕃 (𝕃 A)) → (l0 : 𝕃 A) → (foldr _++_ [] Ls) ++ l0 ≡ (foldr _++_ [] (Ls ++ [ l0 ]))
multi++-assoc [] l' rewrite ++[] l' = refl
multi++-assoc (l :: ls) l' rewrite ++-assoc l (foldr _++_ [] ls) l' | multi++-assoc ls l' = refl

concat-foldr : ∀{ℓ}{A : Set ℓ} → (ls : 𝕃 (𝕃 A)) → (l : 𝕃 A) → concat ls ++ l ≡ foldr _++_ l ls
concat-foldr [] l = refl
concat-foldr (l' :: ls) l rewrite ++-assoc l' (concat ls) l | concat-foldr ls l = refl

--concat-foldr (l' :: (l'' :: ls)) l rewrite ++-assoc l' (concat (l'' :: ls)) l | concat-foldr (l'' :: ls) l = refl

longer-trans : ∀{ℓ}{A : Set ℓ}(l1 l2 l3 : 𝕃 A) →
                l1 longer l2 ≡ tt →
                l2 longer l3 ≡ tt →
                l1 longer l3 ≡ tt
longer-trans [] l2 l3 () q
longer-trans (x :: l1) [] l3 p ()
longer-trans (x :: l1) (x₁ :: l2) [] p q = refl
longer-trans (x :: l1) (x₁ :: l2) (x₂ :: l3) p q = longer-trans l1 l2 l3 p q

filter-idem : ∀{ℓ}{A : Set ℓ}(p : A → 𝔹)(l : 𝕃 A) →
              (filter p (filter p l)) ≡ (filter p l)
filter-idem p [] = refl
filter-idem p (x :: l) with keep (p x)
filter-idem p (x :: l) | tt , p' rewrite p' | p' | filter-idem p l = refl
filter-idem p (x :: l) | ff , p' rewrite p' = filter-idem p l

length-filter : ∀{ℓ}{A : Set ℓ}(p : A → 𝔹)(l : 𝕃 A) →
                length (filter p l) ≤ length l ≡ tt
length-filter p [] = refl
length-filter p (x :: l) with p x
length-filter p (x :: l) | tt = length-filter p l
length-filter p (x :: l) | ff =
  ≤-trans{length (filter p l)} (length-filter p l) (≤-suc (length l))

filter-++ : ∀{ℓ}{A : Set ℓ}(p : A → 𝔹)(l1 l2 : 𝕃 A) → filter p (l1 ++ l2) ≡ filter p l1 ++ filter p l2
filter-++ p [] l2 = refl
filter-++ p (x :: l1) l2 with p x
filter-++ p (x :: l1) l2 | tt rewrite (filter-++ p l1 l2) = refl
filter-++ p (x :: l1) l2 | ff rewrite (filter-++ p l1 l2) = refl

remove-++ : ∀{ℓ}{A : Set ℓ}(eq : A → A → 𝔹)(a : A)(l1 l2 : 𝕃 A) →
            remove eq a (l1 ++ l2) ≡ remove eq a l1 ++ remove eq a l2
remove-++ eq a l1 l2 = filter-++ (λ x → ~ (eq a x)) l1 l2

::-injective : ∀{ℓ}{A : Set ℓ}{x y : A}{xs ys : 𝕃 A} →
               x :: xs ≡ y :: ys → x ≡ y ∧ xs ≡ ys
::-injective refl = refl , refl

concat-++ : ∀{ℓ}{A : Set ℓ}(ls1 ls2 : 𝕃 (𝕃 A)) → concat (ls1 ++ ls2) ≡ (concat ls1) ++ (concat ls2)
concat-++ [] ls2 = refl
concat-++ (l :: ls) ls2 rewrite concat-++ ls ls2 = sym (++-assoc l (concat ls) (concat ls2))

-- This holds as long as we have the equations p₁ and p₂.  We know
-- that these equations are consistant to adopt, because they are
-- equivalent up and an isomorphism, and hence, by univalence they are
-- consistent as equations.  The respective isomorphisms can be found
-- in products-thms.agda.
all-pred-append : ∀{X : Set}{f : X → Set}{l₁ l₂}
  → (p₁ : ∀{ℓ}{A : Set ℓ} → A ≡ ((⊤ {ℓ}) ∧ A))
  → (p₂ : ∀{ℓ}{A B C : Set ℓ} →  (A ∧ (B ∧ C)) ≡ ((A ∧ B) ∧ C))
  → all-pred f (l₁ ++ l₂) ≡ ((all-pred f l₁) ∧ (all-pred f l₂))
all-pred-append {l₁ = []} {l₂} p₁ p₂ = p₁
all-pred-append {X}{f}{x :: l₁} {l₂} p₁ p₂ rewrite all-pred-append {X}{f}{l₁ = l₁} {l₂} p₁ p₂ = p₂

all-pred-triv : {ℓ : Level}{l : 𝕃 (⊤ {ℓ})}(γ : ⊤ {ℓ} → Set ℓ)(p : γ triv) → all-pred γ l
all-pred-triv {_}{[]} γ p = triv
all-pred-triv {_}{triv :: l} γ p = p , all-pred-triv γ p

map-proj-⊎₁ : ∀{ℓ ℓ'}{A : Set ℓ}{B : Set ℓ'} → (l : 𝕃 A) →
                proj-⊎₁ {A = A}{B} (map inj₁ l) ≡ l
map-proj-⊎₁ [] = refl
map-proj-⊎₁ {A = A}{B} (x :: l) rewrite map-proj-⊎₁ {A = A}{B} l = refl

map-proj-⊎₂ : ∀{ℓ ℓ'}{A : Set ℓ}{B : Set ℓ'} → (l : 𝕃 B) →
                proj-⊎₂ {A = A}{B} (map inj₂ l) ≡ l
map-proj-⊎₂ [] = refl
map-proj-⊎₂ {A = A}{B} (x :: l) rewrite map-proj-⊎₂ {A = A}{B} l = refl

map-proj-⊎₂-[] : ∀{ℓ ℓ'}{A : Set ℓ}{B : Set ℓ'} → (l : 𝕃 A) →
                  proj-⊎₂ {A = A}{B} (map inj₁ l) ≡ []
map-proj-⊎₂-[] [] = refl
map-proj-⊎₂-[] {A = A}{B} (x :: l) rewrite map-proj-⊎₂-[] {A = A}{B} l = refl

map-proj-⊎₁-[] : ∀{ℓ ℓ'}{A : Set ℓ}{B : Set ℓ'} → (l : 𝕃 B) →
                  proj-⊎₁ {A = A}{B} (map inj₂ l) ≡ []
map-proj-⊎₁-[] [] = refl
map-proj-⊎₁-[] {A = A}{B} (x :: l) rewrite map-proj-⊎₁-[] {A = A}{B} l = refl

is-empty-++ : ∀{ℓ}{A : Set ℓ}(l1 l2 : 𝕃 A) → is-empty (l1 ++ l2) ≡ is-empty l1 && is-empty l2
is-empty-++ [] l2 = refl
is-empty-++ (x :: l1) l2 = refl

is-empty-ff-length : ∀{ℓ}{A : Set ℓ}(l : 𝕃 A) → is-empty l ≡ ff → length l =ℕ 0 ≡ ff
is-empty-ff-length [] ()
is-empty-ff-length (x :: l) p = refl


module chap0 where

open import Data.List
open import Data.Nat hiding (_⊔_)
-- open import Data.Integer hiding (_⊔_ ;  _≟_ ; _+_ )
open import Data.Product

A : List ℕ
A = 1 ∷ 2 ∷ []

data Literal : Set where
    x : Literal
    y : Literal
    z : Literal

B : List Literal
B = x ∷ y ∷ z ∷ []

ListProduct : {A B : Set } → List A → List B → List ( A × B )
ListProduct  = {!!}

ex05 : List ( ℕ × Literal )
ex05 = ListProduct A B   -- (1 , x) ∷ (1 , y) ∷ (1 , z) ∷ (2 , x) ∷ (2 , y) ∷ (2 , z) ∷ []

ex06 : List ( ℕ × Literal × ℕ )
ex06 = ListProduct A (ListProduct B A)

ex07 : Set
ex07 =  ℕ × ℕ

data ex08-f : ℕ → ℕ → Set where
    ex08f0 : ex08-f 0 1
    ex08f1 : ex08-f 1 2
    ex08f2 : ex08-f 2 3
    ex08f3 : ex08-f 3 4
    ex08f4 : ex08-f 4 0

data ex09-g : ℕ → ℕ → ℕ → ℕ → Set where
    ex09g0 : ex09-g 0 1 2 3
    ex09g1 : ex09-g 1 2 3 0
    ex09g2 : ex09-g 2 3 0 1
    ex09g3 : ex09-g 3 0 1 2

open import Data.Nat.DivMod
open import Relation.Binary.PropositionalEquality
open import Relation.Binary.Core
open import Data.Nat.Properties

-- _%_ : ℕ → ℕ → ℕ
-- _%_ a b with <-cmp a b
-- _%_ a b | tri< a₁ ¬b ¬c = a
-- _%_ a b | tri≈ ¬a b₁ ¬c = 0
-- _%_ a b | tri> ¬a ¬b c = _%_ (a - b) b

_≡7_ : ℕ → ℕ → Set
n ≡7 m = (n % 7) ≡ (m % 7 )

refl7 :  { n : ℕ} → n ≡7 n
refl7 = {!!}

sym7  : { n m : ℕ} → n ≡7 m → m ≡7 n
sym7  = {!!}

trans7 : { n m o : ℕ} → n ≡7 m → m ≡7 o → n ≡7 o
trans7 = {!!}

open import Level renaming ( zero to Zero ; suc to Suc )

record Graph  { v v' : Level } : Set (Suc v ⊔ Suc v' ) where
  field
    vertex : Set v
    edge : vertex  → vertex → Set v'

open Graph

-- open import Data.Fin hiding ( _≟_ )
open import Data.Empty
open import Relation.Nullary
open import Data.Unit  hiding ( _≟_ )

-- data Dec (P : Set) : Set where
--    yes :   P → Dec P
--    no  : ¬ P → Dec P
--
--  _≟_ :  (s t : ℕ ) → Dec ( s ≡ t )

-- ¬ A = A → ⊥

_n≟_ :  (s t : ℕ ) → Dec ( s ≡ t )
zero n≟ zero = yes refl
zero n≟ suc t = no (λ ())
suc s n≟ zero = no (λ ())
suc s n≟ suc t with s n≟ t
... | yes refl = yes refl
... | no n = no (λ k → n (tt1 k) )  where
   tt1 : suc s ≡ suc t → s ≡ t
   tt1 refl = refl

open import Data.Bool  hiding ( _≟_ )

conn : List ( ℕ × ℕ ) → ℕ → ℕ → Bool
conn [] _ _ = false
conn ((n1 , m1 ) ∷ t ) n m  with n ≟ n1 | m ≟ m1
conn ((n1 , m1) ∷ t) n m | yes refl | yes refl  = true
conn ((n1 , m1) ∷ t) n m | _ | _ = conn t n m

list012a : List ( ℕ × ℕ )
list012a = (1 , 2) ∷ (2 , 3) ∷ (3 , 4) ∷ (4 , 5) ∷ (5 , 1) ∷ []

graph012a : Graph {Zero} {Zero}
graph012a = record { vertex = ℕ ; edge = λ s t → (conn list012a s t) ≡ true }

data edge012b :  ℕ → ℕ →  Set where
    e012b-1 : edge012b 1 2
    e012b-2 : edge012b 1 3
    e012b-3 : edge012b 1 4
    e012b-4 : edge012b 2 3
    e012b-5 : edge012b 2 4
    e012b-6 : edge012b 3 4

edge? : (E : ℕ → ℕ →  Set) → ( a b : ℕ ) → Set
edge? E a b = Dec ( E a b )

lemma3 : ( a b : ℕ ) → edge? edge012b a b
lemma3 1 2  = yes e012b-1
lemma3 1 3  = yes e012b-2
lemma3 1 4  = yes e012b-3
lemma3 2 3  = yes e012b-4
lemma3 2 4  = yes e012b-5
lemma3 3 4  = yes e012b-6
lemma3 1 1  = no ( λ () )
lemma3 2 1  = no ( λ () )
lemma3 2 2  = no ( λ () )
lemma3 3 1  = no ( λ () )
lemma3 3 2  = no ( λ () )
lemma3 3 3  = no ( λ () )
lemma3 0 _  = no ( λ () )
lemma3 _ 0  = no ( λ () )
lemma3 _ (suc (suc (suc (suc (suc _)))))  = no ( λ () )
lemma3 (suc (suc (suc (suc _)))) _  = no ( λ () )

graph012b : Graph {Zero} {Zero}
graph012b = record { vertex = ℕ  ; edge = edge012b }

data connected { V : Set } ( E : V -> V -> Set ) ( x y : V ) : Set  where
    direct :   E x y → connected E x y
    indirect :  ( z : V  ) -> E x z  →  connected {V} E z y → connected E x y

lemma1 : connected ( edge graph012a ) 1 2
lemma1 = direct refl  where

lemma1-2 : connected ( edge graph012a ) 1 3
lemma1-2 = indirect 2 refl (direct refl )

lemma2 : connected ( edge graph012b ) 1 2
lemma2 = direct e012b-1

reachable :  { V : Set } ( E : V -> V -> Set ) ( x y : V ) -> Set
reachable {V} E X Y = Dec ( connected {V} E X Y )

dag :  { V : Set } ( E : V -> V -> Set ) ->  Set
dag {V} E =  ∀ (n : V)  →  ¬ ( connected E n n )

open import Function

lemma4 : ¬ ( dag ( edge graph012a)  )
lemma4 neg = neg 1 $ indirect 2 refl $ indirect 3 refl $ indirect 4 refl $ indirect 5 refl $ direct refl

dgree : List ( ℕ × ℕ ) → ℕ → ℕ
dgree [] _ = 0
dgree ((e , e1) ∷ t) e0 with e0 ≟ e | e0 ≟ e1
dgree ((e , e1) ∷ t) e0 | yes _ | _ = 1 + (dgree t e0)
dgree ((e , e1) ∷ t) e0 | _ | yes p = 1 + (dgree t e0)
dgree ((e , e1) ∷ t) e0 | no _ | no _ = dgree t e0

dgree-c : {t : Set} → List ( ℕ × ℕ ) → ℕ → (ℕ → t)  → t
dgree-c {t} [] e0 next = next 0
dgree-c {t} ((e , e1) ∷ tail ) e0 next with e0 ≟ e | e0 ≟ e1
... | yes _ | _ = dgree-c tail e0 ( λ n → next (n + 1 ))
... | _ | yes _ = dgree-c tail e0 ( λ n → next (n + 1 ))
... | no _ | no _ = dgree-c tail e0 next

lemma6 = dgree list012a 2
lemma7 = dgree-c list012a 2 ( λ n → n )

even2 : (n : ℕ ) → n % 2 ≡ 0 → (n + 2) % 2 ≡ 0
even2 0 refl = refl
even2 1 ()
even2 (suc (suc n)) eq = trans ([a+n]%n≡a%n n _) eq -- [a+n]%n≡a%n : ∀ a n → (a + suc n) % suc n ≡ a % suc n

sum-of-dgree : ( g : List ( ℕ × ℕ )) → ℕ
sum-of-dgree [] = 0
sum-of-dgree ((e , e1) ∷ t) = 2 + sum-of-dgree t

dgree-even : ( g : List ( ℕ × ℕ )) → sum-of-dgree g % 2 ≡ 0
dgree-even [] = refl
dgree-even ((e , e1) ∷ t) = begin
       sum-of-dgree ((e , e1) ∷ t) % 2
    ≡⟨⟩
       (2 + sum-of-dgree t ) % 2
    ≡⟨ cong ( λ k → k % 2 ) ( +-comm 2 (sum-of-dgree t) )  ⟩
       (sum-of-dgree t + 2) % 2
    ≡⟨ [a+n]%n≡a%n (sum-of-dgree t) _ ⟩
       sum-of-dgree t % 2
    ≡⟨ dgree-even t ⟩
       0
    ∎ where open ≡-Reasoning


module Structure.Operator.Monoid.Monoids.Function where

open import Functional
open import Function.Equals
open import Function.Equals.Proofs
import      Lvl
open import Logic
open import Logic.Predicate
open import Structure.Function
open import Structure.Operator.Monoid
open import Structure.Operator.Properties
open import Structure.Operator
open import Structure.Setoid
open import Type

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

function-monoid : ⦃ equiv : Equiv{ℓₑ}(T)⦄ ⦃ function : ∀{f : T → T} → Function(f) ⦄ → Monoid(_∘_ {X = T}{Y = T}{Z = T})
Monoid.binary-operator    function-monoid = [⊜][∘]-binaryOperator
Monoid.associativity      function-monoid = intro(\{f g h} → [⊜]-associativity {x = f}{y = g}{z = h})
Monoid.identity-existence function-monoid = [∃]-intro id ⦃ [⊜]-identity ⦄


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

module TypeTheory.Nat.Instance where

-- agda-stdlib
open import Level renaming (zero to lzero; suc to lsuc)
open import Data.Nat using (ℕ; zero; suc)
open import Relation.Binary.PropositionalEquality using (refl)

-- agda-misc
import TypeTheory.Nat.Operations as NatOperations

ℕ-ind : ∀ {l} (P : ℕ → Set l) → P zero → (∀ k → P k → P (suc k)) → ∀ n → P n
ℕ-ind P P-base P-step zero    = P-base
ℕ-ind P P-base P-step (suc n) = P-step n (ℕ-ind P P-base P-step n)

open NatOperations ℕ zero suc ℕ-ind
                   (λ _ _ _ → refl) (λ _ _ _ _ → refl) public


------------------------------------------------------------------------
-- The Agda standard library
--
-- All predicate transformer for fresh lists
------------------------------------------------------------------------

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

module Data.List.Fresh.Relation.Unary.All where

open import Level using (Level; _⊔_; Lift)
open import Data.Product using (_×_; _,_; proj₁; uncurry)
open import Relation.Nullary
import Relation.Nullary.Decidable as Dec
open import Relation.Nullary.Product using (_×-dec_)
open import Relation.Unary  as U
open import Relation.Binary as B using (Rel)

open import Data.List.Fresh using (List#; []; cons; _∷#_; _#_)
open import Data.List.Fresh.Relation.Unary.Any as Any using (Any; here; there)

private
  variable
    a p q r : Level
    A : Set a

module _ {A : Set a} {R : Rel A r} (P : Pred A p) where

  data All : List# A R → Set (p ⊔ a ⊔ r) where
    []  : All []
    _∷_ : ∀ {x xs pr} → P x → All xs → All (cons x xs pr)

module _ {R : Rel A r} {P : Pred A p} where

  uncons : ∀ {x} {xs : List# A R} {pr} →
           All P (cons x xs pr) → P x × All P xs
  uncons (p ∷ ps) = p , ps

module _ {R : Rel A r} where

  append   : (xs ys : List# A R) → All (_# ys) xs → List# A R
  append-# : ∀ {x} xs ys {ps} → x # xs → x # ys → x # append xs ys ps

  append []             ys _  = ys
  append (cons x xs pr) ys ps =
    let (p , ps) = uncons ps in
    cons x (append xs ys ps) (append-# xs ys pr p)

  append-# []             ys x#xs       x#ys = x#ys
  append-# (cons x xs pr) ys (r , x#xs) x#ys = r , append-# xs ys x#xs x#ys

module _ {R : Rel A r} {P : Pred A p} {Q : Pred A q} where

  map : ∀ {xs : List# A R} → ∀[ P ⇒ Q ] → All P xs → All Q xs
  map p⇒q []       = []
  map p⇒q (p ∷ ps) = p⇒q p ∷ map p⇒q ps

  lookup : ∀ {xs : List# A R} → All Q xs → (ps : Any P xs) →
           Q (proj₁ (Any.witness ps))
  lookup (q ∷ _)  (here _)  = q
  lookup (_ ∷ qs) (there k) = lookup qs k

module _ {R : Rel A r} {P : Pred A p} (P? : Decidable P) where

  all? : (xs : List# A R) → Dec (All P xs)
  all? []        = yes []
  all? (x ∷# xs) = Dec.map′ (uncurry _∷_) uncons (P? x ×-dec all? xs)


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

module HoTT.Identity where

open variables
private variable x y z w : A

-- Lemma 2.1.4
--  (i)
unitᵣ : {p : x == y} → p == p ∙ refl
unitᵣ {p = refl} = refl

unitₗ : {p : x == y} → p == refl ∙ p
unitₗ {p = refl} = refl

--  (ii)
invₗ : {p : x == y} → p ⁻¹ ∙ p == refl
invₗ {p = refl} = refl

invᵣ : {p : x == y} → p ∙ p ⁻¹ == refl
invᵣ {p = refl} = refl

--  (iv)
assoc : {p : x == y} {q : y == z} {r : z == w} →
        p ∙ (q ∙ r) == (p ∙ q) ∙ r
assoc {p = refl} {refl} {refl} = refl

invinv : {p : x == y} → p ⁻¹ ⁻¹ == p
invinv {p = refl} = refl

-- Whiskering
_∙ᵣ_ : {p q : x == y} (α : p == q) (r : y == z) → p ∙ r == q ∙ r
refl ∙ᵣ refl = refl
infixl 25 _∙ᵣ_

_∙ₗ_ : {r s : y == z} (q : x == y) (β : r == s) → q ∙ r == q ∙ s
refl ∙ₗ refl = refl
infixl 25 _∙ₗ_

-- Horizontal composition
_⋆_ : {p q : x == y} {r s : y == z} → (p == q) → (r == s) → p ∙ r == q ∙ s
refl ⋆ refl = refl

cancelᵣ : {p q : x == y} {r : y == z} (α : p ∙ r == q ∙ r) → p == q
cancelᵣ {r = refl} α = unitᵣ ∙ α ∙ unitᵣ ⁻¹

cancelₗ : {r s : y == z} {q : x == y} (β : q ∙ r == q ∙ s) → r == s
cancelₗ {q = refl} β = unitₗ ∙ β ∙ unitₗ ⁻¹

pivotᵣ : {p : x == y} {q : y == z} {r : x == z} → p ∙ q == r → p == r ∙ q ⁻¹
pivotᵣ {p = refl} {q = refl} α = α ∙ unitᵣ

pivotₗ : {p : x == y} {q : y == z} {r : x == z} → p ∙ q == r → q == p ⁻¹ ∙ r
pivotₗ {p = refl} {q = refl} α = α ∙ unitₗ

-- Lemma 2.2.2
--  (i)
ap-∙ : (f : A → B) (p : x == y) (q : y == z) → ap f (p ∙ q) == ap f p ∙ ap f q
ap-∙ _ refl refl = refl

--  (ii)
ap-inv : (f : A → B) (p : x == y) → ap f (p ⁻¹) == ap f p ⁻¹
ap-inv _ refl = refl

--  (iii)
ap-∘ : {C : 𝒰 i} (f : B → C) (g : A → B) (p : x == y) → ap (f ∘ g) p == ap f (ap g p)
ap-∘ _ _ refl = refl

--  (iv)
ap-id : (p : x == y) → ap id p == p
ap-id refl = refl

ap-const : (p : x == y) → ap (const B) p == refl
ap-const refl = refl

-- Lemma 2.3.5
transportconst : (p : x == y) → transport (const B) p ~ id
transportconst refl _ = refl

-- Lemma 2.3.9
transport-∙ : (P : A → 𝒰 i) (p : x == y) (q : y == z) →
              transport P (p ∙ q) ~ transport P q ∘ transport P p
transport-∙ P refl refl _ = refl

-- Lemma 2.3.10
transport-ap : (P : B → 𝒰 i) (f : A → B) {x y : A} (p : x == y) →
               transport P (ap f p) ~ transport (P ∘ f) p
transport-ap _ _ refl _ = refl

-- Lemma 2.3.11
transport-∘ : (f : {x : A} → P x → Q x) (p : x == y) →
              transport Q p ∘ f ~ f ∘ transport P p
transport-∘ _ refl _ = refl

module =-Reasoning {i} {A : 𝒰 i}
  where
  _=⟨_⟩_ : (x : A) {y z : A} → x == y → y == z → x == z
  x =⟨ p ⟩ q = p ∙ q
  infixr 2 _=⟨_⟩_

  _=⟨⟩_ : (x : A) {y : A} → x == y → x == y
  _ =⟨⟩ p = p
  infixr 2 _=⟨⟩_

  _∎ : (x : A) → x == x
  _ ∎ = refl
  infix 3 _∎


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

open import Categories.Category

module Categories.Diagram.Pushout {o ℓ e} (C : Category o ℓ e) where

open Category C
open HomReasoning

open import Level

private
  variable
    A B X Y Z : Obj
    h h₁ h₂ j : A ⇒ B

record Pushout (f : X ⇒ Y) (g : X ⇒ Z) : Set (o ⊔ ℓ ⊔ e) where
  field
    {Q} : Obj
    i₁  : Y ⇒ Q
    i₂  : Z ⇒ Q

  field
    commute   : i₁ ∘ f ≈ i₂ ∘ g
    universal : h₁ ∘ f ≈ h₂ ∘ g → Q ⇒ cod h₁
    unique    : ∀ {eq : h₁ ∘ f ≈ h₂ ∘ g} →
                  j ∘ i₁ ≈ h₁ → j ∘ i₂ ≈ h₂ →
                  j ≈ universal eq

    universal∘i₁≈h₁  : ∀ {eq : h₁ ∘ f ≈ h₂ ∘ g} →
                         universal eq ∘ i₁ ≈ h₁
    universal∘i₂≈h₂  : ∀ {eq : h₁ ∘ f ≈ h₂ ∘ g} →
                         universal eq ∘ i₂ ≈ h₂


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

open import Numbers.Naturals.Definition
open import LogicalFormulae
open import Groups.Definition
open import Groups.Orders.Partial.Definition
open import Setoids.Orders.Partial.Definition
open import Setoids.Setoids

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

module Groups.Orders.Archimedean {a b : _} {A : Set a} {S : Setoid {a} {b} A} {_+_ : A → A → A} {G : Group S _+_} {c : _} {_<_ : A → A → Set c} {pOrder : SetoidPartialOrder S _<_} (p : PartiallyOrderedGroup G pOrder) where

open Setoid S
open import Groups.Cyclic.Definition G
open Group G

Archimedean : Set (a ⊔ c)
Archimedean = (x y : A) → (0G < x) → (0G < y) → Sg ℕ (λ n → y < (positiveEltPower x n))


module _ where

data N : Set where
  zero : N
  suc  : N → N

record P : Set where
  constructor p
  field fst : N
        snd : N

open P

-- f = λ z → z   internally
f : P → P
f z = p (fst z) (snd z)

-- This should also be λ z → z, but was not due to #2157.
g : P → P
g (p x y) = p x y


module DeBruijn where

open import Prelude -- using (_∘_)       -- composition, identity
open import Data.Maybe
open import Logic.Identity renaming (subst to subst≡)
import Logic.ChainReasoning
module Chain = Logic.ChainReasoning.Poly.Homogenous _≡_ (\x -> refl) (\x y z -> trans)
open Chain

-- untyped de Bruijn terms
data Lam (A : Set) : Set where
    var : A -> Lam A
    app : Lam A -> Lam A -> Lam A
    abs : Lam (Maybe A) -> Lam A

-- functoriality of Lam
lam : {A B : Set} -> (A -> B) -> Lam A -> Lam B
lam f (var a)     = var (f a)
lam f (app t1 t2) = app (lam f t1) (lam f t2)
lam f (abs r)     = abs (lam (fmap f) r)

-- lifting a substitution A -> Lam B under a binder
lift : {A B : Set} -> (A -> Lam B) -> Maybe A -> Lam (Maybe B)
lift f nothing  = var nothing
lift f (just a) = lam just (f a)

-- extensionality of lifting
liftExt : {A B : Set}(f g : A -> Lam B) ->
   ((a : A) -> f a ≡ g a) -> (t : Maybe A) -> lift f t ≡ lift g t
liftExt f g H nothing  = refl
liftExt f g H (just a) = cong (lam just) $ H a

-- simultaneous substitution
subst : {A B : Set} -> (A -> Lam B) -> Lam A -> Lam B
subst f (var a)     = f a
subst f (app t1 t2) = app (subst f t1) (subst f t2)
subst f (abs r)     = abs (subst (lift f) r)

-- extensionality of subst
substExt : {A B : Set}(f g : A -> Lam B) ->
   ((a : A) -> f a ≡ g a) -> (t : Lam A) -> subst f t ≡ subst g t
substExt f g H (var a)     = H a
substExt f g H (app t1 t2) =
  chain> subst f (app t1 t2)
     === app (subst f t1) (subst f t2)
       by refl
     === app (subst g t1) (subst f t2)
       by cong (\ x -> app x (subst f t2)) (substExt f g H t1)
     === app (subst g t1) (subst g t2)
       by cong (\ x -> app (subst g t1) x) (substExt f g H t2)
substExt f g H (abs r) =
  chain> subst f (abs r)
     === abs (subst (lift f) r)
       by refl
     === abs (subst (lift g) r)
       by cong abs (substExt (lift f) (lift g) (liftExt f g H) r)
     === subst g (abs r)
       by refl

-- Lemma: lift g ∘ fmap f = lift (g ∘ f)
liftLaw1 : {A B C : Set}(f : A -> B)(g : B -> Lam C)(t : Maybe A) ->
  lift g (fmap f t) ≡ lift (g ∘ f) t
liftLaw1 f g nothing =
  chain> lift g (fmap f nothing)
     === lift g nothing          by refl
     === var nothing             by refl
     === lift (g ∘ f) nothing    by refl
liftLaw1 f g (just a) =
  chain> lift g (fmap f (just a))
     === lift g (just (f a))     by refl
     === lam just (g (f a))      by refl
     === lift (g ∘ f) (just a)   by refl

-- Lemma: subst g (lam f t) = subst (g ∘ f) t
substLaw1 : {A B C : Set}(f : A -> B)(g : B -> Lam C)(t : Lam A) ->
  subst g (lam f t) ≡ subst (g ∘ f) t

substLaw1 f g (var a) = refl

substLaw1 f g (app t1 t2) =
  chain> subst g (lam f (app t1 t2))
     === subst g (app (lam f t1) (lam f t2))
       by refl
     === app (subst g (lam f t1)) (subst g (lam f t2))
       by refl
     === app (subst (g ∘ f) t1) (subst g (lam f t2))
       by cong (\ x -> app x (subst g (lam f t2))) (substLaw1 f g t1)
     === app (subst (g ∘ f) t1) (subst (g ∘ f) t2)
       by cong (\ x -> app (subst (g ∘ f) t1) x) (substLaw1 f g t2)

substLaw1 f g (abs r) =
  chain> subst g (lam f (abs r))
     === subst g (abs (lam (fmap f) r))
       by refl
     === abs (subst (lift g) (lam (fmap f) r))
       by refl
     === abs (subst (lift g ∘ fmap f) r)
       by cong abs (substLaw1 (fmap f) (lift g) r)
     === abs (subst (lift (g ∘ f)) r)
       by cong abs (substExt (lift g ∘ fmap f) (lift (g ∘ f)) (liftLaw1 f g) r)

-- Lemma: subst (lam f ∘ g) = lam f ∘ subst g
substLaw2 : {A B C : Set}(f : B -> C)(g : A -> Lam B)(t : Lam A) ->
  subst (lam f ∘ g) t ≡ lam f (subst g t)
substLaw2 f g (var a) = refl


module tests.Forcing where

open import Prelude.IO
open import Prelude.Unit
open import Prelude.Vec
open import Prelude.Nat

len : {A : Set}{n : Nat} -> Vec A n -> Nat
len {A} .{Z}   []              = Z
len {A} .{S n} (_::_ {n} x xs) = S n

len2 : {A : Set}{n : Nat} -> Vec A n -> Nat
len2 [] = 0
len2 (_::_ {n} x xs) = S (len2 {n = n} xs)

len3 : {A : Set}{n : Nat} -> Vec A n -> Nat
len3 {n = Z}   []               = Z
len3 {n = S n} (_::_ .{n} x xs) = S n

len4 : {A : Set}{n : Nat} -> Vec A n -> Nat
len4 []               = Z
len4 (_::_ {Z} x xs) = S Z
len4 (_::_ {S n} x xs) = S (S n)

main : IO Unit
main =
    printNat (len  l1) ,,
    printNat (len  l2) ,,
    printNat (len  l3) ,,

    printNat (len2 l1) ,,
    printNat (len2 l2) ,,
    printNat (len2 l3) ,,

    printNat (len3 l1) ,,
    printNat (len3 l2) ,,
    printNat (len3 l3) ,,

    printNat (len4 l1) ,,
    printNat (len4 l2) ,,
    printNat (len4 l3) ,,

    return unit
  where l1 = "a" :: "b" :: "c" :: []
        l2 = 1   :: 2   :: 3   :: 4 :: 5 :: []
        l3 : Vec Nat Z
        l3 = []


------------------------------------------------------------------------------
-- Testing the conjectures inside a @where@ clause
------------------------------------------------------------------------------

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

module Where2 where

infixl 6 _+_
infix  4 _≡_

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

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

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

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

+-assoc : ∀ {m n o} → N m → N n → N o → m + n + o ≡ m + (n + o)
+-assoc {n = n} {o} Nm Nn No = N-ind A A0 is Nm
  where
  A : D → Set
  A i = i + n + o ≡ i + (n + o)

  postulate A0 : zero + n + o ≡ zero + (n + o)
  {-# ATP prove A0 #-}

  postulate is : ∀ {i} → i + n + o ≡ i + (n + o) →
                 succ i + n + o ≡ succ i + (n + o)
  {-# ATP prove is #-}


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

open import Groups.Definition
open import Setoids.Setoids
open import Setoids.Subset
open import LogicalFormulae
open import Sets.EquivalenceRelations
open import Groups.Homomorphisms.Definition
open import Groups.Homomorphisms.Lemmas
open import Groups.Subgroups.Definition
open import Groups.Lemmas

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

module Groups.Homomorphisms.Image {a b c d : _} {A : Set a} {B : Set b} {S : Setoid {a} {c} A} {T : Setoid {b} {d} B} {_+A_ : A → A → A} {_+B_ : B → B → B} {G : Group S _+A_} {H : Group T _+B_} {f : A → B} (fHom : GroupHom G H f) where

imageGroupPred : B → Set (a ⊔ d)
imageGroupPred b = Sg A (λ a → Setoid._∼_ T (f a) b)

imageGroupSubset : subset T imageGroupPred
imageGroupSubset {x} {y} x=y (a , fa=x) = a , transitive fa=x x=y
  where
    open Setoid T
    open Equivalence eq

imageGroupSubgroup : Subgroup H imageGroupPred
Subgroup.isSubset imageGroupSubgroup = imageGroupSubset
Subgroup.closedUnderPlus imageGroupSubgroup {x} {y} (a , fa=x) (b , fb=y) = (a +A b) , transitive (GroupHom.groupHom fHom) (Group.+WellDefined H fa=x fb=y)
  where
    open Setoid T
    open Equivalence eq
Subgroup.containsIdentity imageGroupSubgroup = Group.0G G , imageOfIdentityIsIdentity fHom
Subgroup.closedUnderInverse imageGroupSubgroup {x} (a , fa=x) = Group.inverse G a , transitive (homRespectsInverse fHom) (inverseWellDefined H fa=x)
  where
    open Setoid T
    open Equivalence eq


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

open import Relation.Binary

module Algorithms.List.Sort.Common
  {c l₁ l₂} (DTO : DecTotalOrder c l₁ l₂)
  where

-- agda-stdlib
open import Data.List
import Data.List.Relation.Binary.Equality.Setoid as ListSetoidEquality
open import Data.List.Relation.Unary.AllPairs
open import Data.List.Relation.Unary.Linked
import Data.List.Relation.Unary.Linked.Properties as Linkedₚ

-- agda-misc
open import Experiment.ListRelationProperties using (Linked-resp-≋)

open DecTotalOrder DTO
open ListSetoidEquality Eq.setoid

Sorted : List Carrier → Set _
Sorted = Linked _≤_

toAllPairs : ∀ {xs} → Sorted xs → AllPairs _≤_ xs
toAllPairs = Linkedₚ.Linked⇒AllPairs trans

Sorted-resp-≋ : ∀ {xs ys} → xs ≋ ys → Sorted xs → Sorted ys
Sorted-resp-≋ = Linked-resp-≋ Eq.setoid ≤-resp-≈


import Relation.Binary.PropositionalEquality as Eq
open Eq using (_≡_; refl)
open import Data.Nat using (ℕ; zero; suc)
open import Relation.Nullary using (¬_; Dec; yes; no)

data _≤_ : ℕ → ℕ → Set where
  z≤n : ∀ {n : ℕ} → zero ≤ n
  s≤s : ∀ {m n : ℕ} → m ≤ n → suc m ≤ suc n

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

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

_≤?_ : ∀ (m n : ℕ) → Dec (m ≤ n)
zero ≤? n = yes z≤n
suc m ≤? zero = no ¬s≤z
suc m ≤? suc n with m ≤? n
... | yes m≤n = yes (s≤s m≤n)
... | no ¬m≤n = no (¬s≤s ¬m≤n)

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

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


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

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

  infixr 30 _::_

  [1,0,2] = one :: zero :: succ one :: []
    where one = succ zero


{-# OPTIONS --without-K --safe #-}
module Categories.Functor.Algebra where

-- Algebra for a Functor

open import Level
open import Function using (_$_)

open import Categories.Category using (Category)
open import Categories.Functor using (Functor; Endofunctor)

private
  variable
    o ℓ e : Level

module _ {C : Category o ℓ e} where

  record F-Algebra (F : Endofunctor C) : Set (o ⊔ ℓ) where
    open Category C
    field
      A : Obj
      α : Functor.F₀ F A ⇒ A

  open F-Algebra

  -- Given an F-Algebra F, one can apply F to it to obtain an new 'iterated' F-Algebra
  iterate : {F : Endofunctor C} → F-Algebra F → F-Algebra F
  iterate {F} c = record { A = Functor.F₀ F $ A c ; α = Functor.F₁ F $ α c }

  record F-Algebra-Morphism {F : Endofunctor C} (X Y : F-Algebra F) : Set (ℓ ⊔ e) where
    open Category C
    module X = F-Algebra X
    module Y = F-Algebra Y
    open Functor F
    field
      f : X.A ⇒ Y.A
      commutes : f ∘ X.α ≈ Y.α ∘ F₁ f


import      Lvl
open import Structure.Setoid
open import Type

module Automaton.Deterministic.Accessible where

open import Automaton.Deterministic
open import Data.List renaming (∅ to ε ; _⊰_ to _·_)
open import Data.List.Functions using (postpend ; _++_)
open import Logic.Predicate
open import Logic.Predicate.Equiv
open import Sets.ExtensionalPredicateSet using (PredSet ; intro ; _∈_ ; _∋_ ; ⊶ ; [∋]-binaryRelator)
open import Structure.Operator
open import Structure.Relator
open import Structure.Relator.Properties
open import Syntax.Transitivity

private variable ℓₚ ℓₛ ℓₑ₁ ℓₐ ℓₑ₂ : Lvl.Level

module _
  {State : Type{ℓₛ}} ⦃ equiv-state : Equiv{ℓₑ₁}(State) ⦄
  {Alphabet : Type{ℓₐ}} ⦃ equiv-alphabet : Equiv{ℓₑ₂}(Alphabet) ⦄
  where

  module _ (d : Deterministic{ℓₚ = ℓₚ}(State)(Alphabet)) where
    open Deterministic(d)

    -- The subset of State which are the accessible states from the start state by chained transitions.
    Accessible : PredSet(State)
    Accessible = ⊶(wordTransition start)

    instance
      accessible-start : (start ∈ Accessible)
      accessible-start = [∃]-intro ε ⦃ reflexivity(_≡_) {x = start} ⦄

    instance
      accessible-transition : ∀{s}{a} → ⦃ _ : (s ∈ Accessible) ⦄ → (transition s a ∈ Accessible)
      accessible-transition {s} {a = a} ⦃ [∃]-intro w ⦃ p ⦄ ⦄ = [∃]-intro (postpend a w)
        ⦃
          wordTransition start (postpend a w)   🝖-[ wordTransition-postpend {d = d} {start}{w}{a} ]
          transition (wordTransition start w) a 🝖-[ congruence₂ₗ(transition) a p ]
          transition s a                        🝖-end
        ⦄

  module _ where
    open Deterministic

    accessibleAutomaton : (d : Deterministic{ℓₚ = ℓₚ}(State)(Alphabet)) → Deterministic(∃(_∈ Accessible d)) (Alphabet)
    transition (accessibleAutomaton d) ([∃]-intro s) a = [∃]-intro (transition d s a) ⦃ accessible-transition d ⦄
    BinaryOperator.congruence (transition-binaryOperator (accessibleAutomaton d)) = congruence₂(transition d)
    start (accessibleAutomaton d) = [∃]-intro (start d) ⦃ accessible-start d ⦄
    Final (accessibleAutomaton d) PredSet.∋ [∃]-intro s = s ∈ Final d
    UnaryRelator.substitution (PredSet.preserve-equiv (Final (accessibleAutomaton d))) {[∃]-intro x} {[∃]-intro y} = substitute₂ᵣ(_∋_) {intro (_∈ Final d)}


open import Type
open import Structure.Setoid renaming (_≡_ to _≡ₑ_)

-- Finite sets represented by lists
module Data.List.Relation.Membership {ℓ ℓₑ} {T : Type{ℓ}} ⦃ equiv : Equiv{ℓₑ}(T)⦄ where

open import Data.List
open import Data.List.Relation.Quantification using (ExistsElement ; ExistsUniqueElement)
open import Functional
open import Logic

_∈_ : T → List(T) → Stmt
_∈_ = ExistsElement ∘ (_≡ₑ_)
module _∈_ where
  pattern use  {x}{l} px = ExistsElement.•_ {x = x}{l = l} px
  pattern skip {x}{l} el = ExistsElement.⊰_ {l = l}{x = x} el

open _∈_ public
open import Relator.Sets(_∈_) public

_∈!_ : T → List(T) → Stmt
_∈!_ = ExistsUniqueElement ∘ (_≡ₑ_)


open import Agda.Builtin.Nat
open import Agda.Builtin.Sigma

interleaved mutual

  data Rec : Set
  ⟦_⟧ : Rec → Set

  constructor `Nat : Rec
  ⟦ `Nat   ⟧ = Nat

  _ : Rec
  _ = `Σ `Nat (λ _ → `Nat)

  _ : Rec → Rec
  _ = λ r → `Σ r (λ _ → `Nat)

  constructor `Σ : (r : Rec) → (⟦ r ⟧ → Rec) → Rec
  ⟦ `Σ A B ⟧ = Σ ⟦ A ⟧ λ a → ⟦ B a ⟧

_+1-Nats : Nat → Rec
zero  +1-Nats = `Nat
suc n +1-Nats = `Σ `Nat λ _ → n +1-Nats

Nats : Rec
Nats = `Σ `Nat _+1-Nats

[1] : ⟦ Nats ⟧
[1] = 0 , 1

[1⋯3] : ⟦ Nats ⟧
[1⋯3] = 2 , 1 , 2 , 3


{-# OPTIONS --safe #-}
module Cubical.Data.Vec.DepVec where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Equiv
open import Cubical.Foundations.Isomorphism

import Cubical.Data.Empty as ⊥
open import Cubical.Data.Unit
open import Cubical.Data.Nat
open import Cubical.Data.Sigma
open import Cubical.Data.Vec

open import Cubical.Relation.Nullary

open Iso

private
  variable
    ℓ : Level

data depVec (G : (n : ℕ) → Type ℓ) : ℕ → Type ℓ where
  ⋆   : depVec G 0
  _□_ : {n : ℕ} → (a : G n) → (v : depVec G n) → depVec G (suc n)

module depVecPath (G : (n : ℕ) → Type ℓ)
  where

  code : {n : ℕ} → (v v' : depVec G n) → Type ℓ
  code ⋆ ⋆ = Unit*
  code (a □ v) (a' □ v') = (a ≡ a') × (v ≡ v')

  -- encode
  reflEncode : {n : ℕ} → (v : depVec G n) → code v v
  reflEncode ⋆ = tt*
  reflEncode (a □ v) = refl , refl

  encode : {n : ℕ} → (v v' : depVec G n) → (v ≡ v') → code v v'
  encode v v' p = J (λ v' _ → code v v') (reflEncode v) p

  encodeRefl : {n : ℕ} → (v : depVec G n) → encode v v refl ≡ reflEncode v
  encodeRefl v = JRefl (λ v' _ → code v v') (reflEncode v)

  -- decode
  decode : {n : ℕ} → (v v' : depVec G n) → (r : code v v') → (v ≡ v')
  decode ⋆ ⋆ _ = refl
  decode (a □ v) (a' □ v') (p , q) = cong₂ _□_ p q

  decodeRefl : {n : ℕ} → (v : depVec G n) → decode v v (reflEncode v) ≡ refl
  decodeRefl ⋆ = refl
  decodeRefl (a □ v) = refl

  -- equiv
  ≡Vec≃codeVec : {n : ℕ} → (v v' : depVec G n) → (v ≡ v') ≃ (code v v')
  ≡Vec≃codeVec v v' = isoToEquiv is
    where
    is : Iso (v ≡ v') (code v v')
    fun is = encode v v'
    inv is = decode v v'
    rightInv is = sect v v'
      where
      sect : {n : ℕ} → (v v' : depVec G n) → (r : code v v')
             → encode v v' (decode v v' r) ≡ r
      sect ⋆ ⋆ tt* = encodeRefl ⋆
      sect (a □ v) (a' □ v') (p , q) = J (λ a' p → encode (a □ v) (a' □ v') (decode (a □ v) (a' □ v') (p , q)) ≡ (p , q))
                                       (J (λ v' q → encode (a □ v) (a □ v') (decode (a □ v) (a □ v') (refl , q)) ≡ (refl , q))
                                       (encodeRefl (a □ v)) q) p
    leftInv is = retr v v'
      where
      retr : {n : ℕ} → (v v' : depVec G n) → (p : v ≡ v')
             → decode v v' (encode v v' p) ≡ p
      retr v v' p = J (λ v' p → decode v v' (encode v v' p) ≡ p)
                    (cong (decode v v) (encodeRefl v) ∙ decodeRefl v) p


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

module Cubical.Categories.Functor where

open import Cubical.Foundations.Prelude
open import Cubical.Data.Sigma
open import Cubical.Categories.Category

private
  variable
    ℓC ℓC' ℓD ℓD' : Level

record Functor (C : Precategory ℓC ℓC') (D : Precategory ℓD ℓD') : Type (ℓ-max (ℓ-max ℓC ℓC') (ℓ-max ℓD ℓD')) where
  no-eta-equality
  open Precategory

  field
    F-ob : C .ob → D .ob
    F-hom : {x y : C .ob} → C [ x , y ] → D [(F-ob x) , (F-ob y)]
    F-id : {x : C .ob} → F-hom (C .id x) ≡ D .id (F-ob x)
    F-seq : {x y z : C .ob} (f : C [ x , y ]) (g : C [ y , z ]) → F-hom (f ⋆⟨ C ⟩ g) ≡ (F-hom f) ⋆⟨ D ⟩ (F-hom g)

  isFull = (x y : _) (F[f] : D [(F-ob x) , (F-ob y)]) → ∃ (C [ x , y ]) (λ f → F-hom f ≡ F[f])
  isFaithful = (x y : _) (f g : C [ x , y ]) → F-hom f ≡ F-hom g → f ≡ g

-- Functor results

module _ (C : Precategory ℓC ℓC') (D : Precategory ℓC ℓC') (F : Functor C D ) where
  open Precategory
  open Functor F

  open CatIso

  -- functors preserve isomorphisms
  preserveIsosF : ∀ {x y : C .ob} → CatIso {C = C} x y → CatIso {C = D} (F-ob x) (F-ob y)
  preserveIsosF {x} {y} (catiso f f⁻¹ sec' ret') =
    catiso
      g g⁻¹
      -- sec
      ( (g⁻¹ ⋆⟨ D ⟩ g)
      ≡⟨ sym (F-seq f⁻¹ f) ⟩
        F-hom (f⁻¹ ⋆⟨ C ⟩ f)
      ≡⟨ cong F-hom sec' ⟩
        F-hom (C .id y)
      ≡⟨ F-id ⟩
        D .id y'
      ∎ )
      -- ret
      ( (g ⋆⟨ D ⟩ g⁻¹)
        ≡⟨ sym (F-seq f f⁻¹) ⟩
      F-hom (f ⋆⟨ C ⟩ f⁻¹)
        ≡⟨ cong F-hom ret' ⟩
      F-hom (C .id x)
      ≡⟨ F-id ⟩
        D .id x'
      ∎ )

      where
        x' : D .ob
        x' = F-ob x
        y' : D .ob
        y' = F-ob y

        g : D [ x' , y' ]
        g = F-hom f
        g⁻¹ : D [ y' , x' ]
        g⁻¹ = F-hom f⁻¹


------------------------------------------------------------------------
-- The Agda standard library
--
-- Some properties about signs
------------------------------------------------------------------------

module Data.Sign.Properties where

open import Data.Empty
open import Function
open import Data.Sign
open import Relation.Binary.PropositionalEquality

-- The opposite of a sign is not equal to the sign.

opposite-not-equal : ∀ s → s ≢ opposite s
opposite-not-equal - ()
opposite-not-equal + ()

-- Sign multiplication is right cancellative.

cancel-*-right : ∀ s₁ s₂ {s} → s₁ * s ≡ s₂ * s → s₁ ≡ s₂
cancel-*-right - - _  = refl
cancel-*-right - + eq = ⊥-elim (opposite-not-equal _ $ sym eq)
cancel-*-right + - eq = ⊥-elim (opposite-not-equal _ eq)
cancel-*-right + + _  = refl


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

open import Categories.Category

module Categories.Monad.Duality {o ℓ e} (C : Category o ℓ e) where

open import Categories.Functor
open import Categories.NaturalTransformation
open import Categories.Monad
open import Categories.Comonad

private
  module C = Category C
  open C
  open HomReasoning

coMonad⇒Comonad : Monad C.op → Comonad C
coMonad⇒Comonad M = record
    { F         = Functor.op F
    ; ε         = NaturalTransformation.op η
    ; δ         = NaturalTransformation.op μ
    ; assoc     = M.sym-assoc
    ; sym-assoc = M.assoc
    ; identityˡ = M.identityˡ
    ; identityʳ = M.identityʳ
    }
  where module M = Monad M
        open M using (F; η; μ)

Comonad⇒coMonad : Comonad C → Monad C.op
Comonad⇒coMonad M = record
    { F         = Functor.op F
    ; η         = NaturalTransformation.op ε
    ; μ         = NaturalTransformation.op δ
    ; assoc     = M.sym-assoc
    ; sym-assoc = M.assoc
    ; identityˡ = M.identityˡ
    ; identityʳ = M.identityʳ
    }
  where module M = Comonad M
        open M using (F; ε; δ)


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

open import Agda.Primitive using (Level; lzero; lsuc; _⊔_)
open import LogicalFormulae
open import Functions.Definition
open import Numbers.Naturals.Definition
open import Sets.FinSet.Definition
open import Setoids.Setoids

module Setoids.Cardinality.Infinite.Definition where

InfiniteSetoid : {a b : _} {A : Set a} (S : Setoid {a} {b} A) → Set (a ⊔ b)
InfiniteSetoid {A = A} S = (n : ℕ) → (f : FinSet n → A) → (SetoidBijection (reflSetoid (FinSet n)) S f) → False

record DedekindInfiniteSetoid {a b : _} {A : Set a} (S : Setoid {a} {b} A) : Set (a ⊔ b) where
  field
    inj : ℕ → A
    isInjection : SetoidInjection (reflSetoid ℕ) S inj


{-# OPTIONS --without-K --safe #-}
module Mult3 where

open import Data.Nat
open import Data.Nat.Properties
open import Relation.Binary.PropositionalEquality

data Mult3 : ℕ → Set where
  0-mult : Mult3 0
  SSS-mult : ∀ n → Mult3 n → Mult3 (suc (suc (suc n)))

data Mult3' : ℕ → Set where
  30-mult : Mult3' 30
  21-mult : Mult3' 21
  sum-mult : ∀ n m → Mult3' n → Mult3' m → Mult3' (n + m)
  diff-mult : ∀ l n m → Mult3' n → Mult3' m → l + n ≡ m → Mult3' l

silly3 : Mult3' 3
silly3 = diff-mult 3 9 12 (diff-mult 9 21 30 21-mult 30-mult refl) (diff-mult 12 9 21 (diff-mult 9 21 30 21-mult 30-mult refl) 21-mult refl) refl

lemma-plus : ∀ {n m : ℕ} → Mult3 n → Mult3 m → Mult3 (n + m)
lemma-plus 0-mult m = m
lemma-plus {m = m₁} (SSS-mult n n₁) m = SSS-mult (n + m₁) (lemma-plus n₁ m)

lemma-minus : ∀ {l n : ℕ} → Mult3 n → Mult3 (n + l) → Mult3 l
lemma-minus {l} {.0} 0-mult m₁ = m₁
lemma-minus {l} {.(suc (suc (suc n)))} (SSS-mult n n₁) (SSS-mult .(n + l) m₁) = lemma-minus n₁ m₁

lemma-silly : ∀ {m n : ℕ} → Mult3 m → m ≡ n → Mult3 n
lemma-silly m eq rewrite eq = m

mult-imp-mult' : ∀ {n : ℕ} → Mult3 n → Mult3' n
mult-imp-mult' 0-mult = diff-mult zero 30 30 30-mult 30-mult refl
mult-imp-mult' (SSS-mult n M) = sum-mult 3 n silly3 (mult-imp-mult' M)

mult'-imp-mult : ∀ {n : ℕ} → Mult3' n → Mult3 n
mult'-imp-mult 30-mult = SSS-mult 27
                           (SSS-mult 24
                            (SSS-mult 21
                             (SSS-mult 18
                              (SSS-mult 15
                               (SSS-mult 12
                                (SSS-mult 9 (SSS-mult 6 (SSS-mult 3 (SSS-mult zero 0-mult)))))))))
mult'-imp-mult 21-mult = SSS-mult 18
                           (SSS-mult 15
                            (SSS-mult 12
                             (SSS-mult 9 (SSS-mult 6 (SSS-mult 3 (SSS-mult zero 0-mult))))))
mult'-imp-mult (sum-mult n m M M₁) = lemma-plus (mult'-imp-mult M) (mult'-imp-mult M₁)
mult'-imp-mult (diff-mult l n m M M₁ x) rewrite +-comm l n = lemma-minus {l} {n} (mult'-imp-mult M) (lemma-silly {m} {n + l} (mult'-imp-mult M₁) (sym x))


module Logic.Congruence where

import Prelude
import Logic.Relations
import Logic.Equivalence

open Prelude
open Logic.Relations
open Logic.Equivalence using    (Equivalence)
                       renaming (module Equivalence to Proj)

data Congruence (A : Set) : Set1 where
  congruence :
    (Eq : Equivalence A) ->
    Congruent (Proj._==_ Eq) ->
    Congruence A

module Projections where

  eq : {A : Set} -> Congruence A -> Rel A
  eq (congruence Eq _) = Proj._==_ Eq

  refl : {A : Set}(Cong : Congruence A) -> Reflexive (eq Cong)
  refl (congruence Eq _) = Proj.refl Eq

  sym : {A : Set}(Cong : Congruence A) -> Symmetric (eq Cong)
  sym (congruence Eq _) = Proj.sym Eq

  trans : {A : Set}(Cong : Congruence A) -> Transitive (eq Cong)
  trans (congruence Eq _) = Proj.trans Eq

  cong : {A : Set}(Cong : Congruence A) -> Congruent (eq Cong)
  cong (congruence _ c) = c

module Congruence {A : Set}(Cong : Congruence A) where

  _==_  = Projections.eq    Cong
  refl  = Projections.refl  Cong
  sym   = Projections.sym   Cong
  trans = Projections.trans Cong
  cong  = Projections.cong  Cong

  cong2 : (f : A -> A -> A)(a b c d : A) -> a == c -> b == d -> f a b == f c d
  cong2 f a b c d ac bd = trans _ _ _ rem1 rem2
    where
      rem1 : f a b == f a d
      rem1 = cong (f a) _ _ bd

      rem2 : f a d == f c d
      rem2 = cong (flip f d) _ _ ac


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

open import Categories.Category

-- a zero object is both terminal and initial.
module Categories.Object.Zero {o ℓ e} (C : Category o ℓ e) where

open import Level

open import Categories.Object.Terminal C
open import Categories.Object.Initial C

open import Categories.Morphism C
open import Categories.Morphism.Reasoning C

open Category C
open HomReasoning

record IsZero (Z : Obj) : Set (o ⊔ ℓ ⊔ e) where
  field
    isInitial : IsInitial Z
    isTerminal : IsTerminal Z

  open IsInitial isInitial public
    renaming
    ( ! to ¡
    ; !-unique to ¡-unique
    ; !-unique₂ to ¡-unique₂
    )
  open IsTerminal isTerminal public

  zero⇒ : ∀ {A B : Obj} → A ⇒ B
  zero⇒ = ¡ ∘ !

  zero-∘ˡ : ∀ {X Y Z} → (f : Y ⇒ Z) → f ∘ zero⇒ {X} ≈ zero⇒
  zero-∘ˡ f = pullˡ (⟺ (¡-unique (f ∘ ¡)))

  zero-∘ʳ : ∀ {X Y Z} → (f : X ⇒ Y) → zero⇒ {Y} {Z} ∘ f ≈ zero⇒
  zero-∘ʳ f = pullʳ (⟺ (!-unique (! ∘ f)))

record Zero : Set (o ⊔ ℓ ⊔ e) where
  field
    𝟘 : Obj
    isZero : IsZero 𝟘

  open IsZero isZero public

  terminal : Terminal
  terminal = record { ⊤-is-terminal = isTerminal }

  initial : Initial
  initial = record { ⊥-is-initial = isInitial }

open Zero

¡-Mono : ∀ {A} {z : Zero} → Mono (¡ z {A})
¡-Mono {z = z} = from-⊤-is-Mono {t = terminal z} (¡ z)

!-Epi : ∀ {A} {z : Zero} → Epi (! z {A})
!-Epi {z = z} = to-⊥-is-Epi {i = initial z} (! z)


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

module SDG.Extra.OrderedAlgebra where

open import Relation.Binary
open import Algebra.FunctionProperties
open import Level

open import SDG.Extra.OrderedAlgebra.Structures

record OrderedCommutativeRing c ℓ : Set (suc (c ⊔ ℓ)) where
  infix 8 -_
  infixl 7 _*_
  infixl 6 _+_
  infix 4 _≈_
  field
    Carrier : Set c
    _≈_ : Rel Carrier ℓ
    _<_ : Rel Carrier ℓ
    _+_ : Op₂ Carrier
    _*_ : Op₂ Carrier
    -_ : Op₁ Carrier
    0# : Carrier
    1# : Carrier
    isOrderedCommutativeRing : IsOrderedCommutativeRing _≈_ _<_ _+_ _*_ -_ 0# 1#

  open IsOrderedCommutativeRing isOrderedCommutativeRing public


-- exercises-04-thursday.agda

open import mylib

-- 1. Coinduction

{-
  Now your task is to define multiplication _*∞_ for conatural numbers.

  This is harder then it sounds. Why? Because to check termination of
  corecursive programs agda needs to make sure that if you want to find out a
  finite amout of information about the result of the function it only needs a
  finite amount of information about its inputs. Such a function is called
  productive. And agda isn't very clever in figuring this out, it has to be
  obvious from the program (similar as structural recursion has to be
  obviously structural).
  You should *not* use the TERMINATING pragma in your solution.
  But it may be useful for experiments.

  _*_ : ℕ → ℕ → ℕ
  zero * n = zero
  suc m * n = n + m * n
-}

{-
_*∞_ :  ℕ∞ → ℕ∞ → ℕ∞
m *∞ n = {!!}
-}

aux : ℕ∞ → ℕ∞ → ℕ∞ → ℕ∞  -- aux l m n = l +∞ (m *∞ n)
pred∞ (aux l m n) with pred∞ l
pred∞ (aux l m n) | nothing with  pred∞ m
pred∞ (aux l m n) | nothing | nothing = nothing
pred∞ (aux l m n) | nothing | just m' with pred∞ n
pred∞ (aux l m n) | nothing | just m' | nothing = nothing
pred∞ (aux l m n) | nothing | just m' | just n' = just (aux n' m' n)
pred∞ (aux l m n) | just l' = just (aux l' m n)

{-# TERMINATING #-}
_*∞_ :  ℕ∞ → ℕ∞ → ℕ∞
m *∞ n = aux zero∞ m n
{-
pred∞ (m *∞ n) with pred∞ m
... | nothing = nothing
... | just m' with pred∞ n
...           | nothing = nothing
...           | just n' = just (n' +∞ (m' *∞ n))
-}

{-
with pred∞ m
...| nothing = zero∞
...| just m' with pred∞ n
...|              nothing = zero∞
...|              just n' = n' +∞ (m' *∞ n)
-}

-- pred∞ (∞ *∞ zero∞) = nothing
-- here are some testing tools
ℕ→ℕ∞ : ℕ → ℕ∞
ℕ→ℕ∞ zero = zero∞
ℕ→ℕ∞ (suc n) = suc∞ (ℕ→ℕ∞ n)

{-# TERMINATING #-} -- a lie
-- this function is a cheat - it doesn't terminate for ∞
ℕ∞→ℕ : ℕ∞ → ℕ
ℕ∞→ℕ n with pred∞ n
ℕ∞→ℕ n | nothing = 0
ℕ∞→ℕ n | just n' = suc (ℕ∞→ℕ n')

-- My unit-test
x3*5 = ℕ∞→ℕ (ℕ→ℕ∞ 3 *∞ ℕ→ℕ∞ 5)

-- 2. Dependent types  Fin

{-
  Define the following operations on Fin
  - max returns the largest element in Fin (suc n)
  - emb embeds Fin n into Fin (suc n) without changing its values
  - inv inverts the order of elements in Fin n
-}

max : (n : ℕ) → Fin (suc n)
max zero = zero
max (suc n) = suc (max n)

emb : {n : ℕ} → Fin n → Fin (suc n)
emb zero = zero
emb (suc m) = suc (emb m)

inv : {n : ℕ} → Fin n → Fin n
inv zero = max _
inv (suc i) = emb (inv i)

-- 2. Dependent types : Vec

Vector : ℕ → Set {- Vec n is an n-dimensional vector -}
Vector m = Vec ℕ m

Matrix : ℕ → ℕ → Set {- Matrix m n is an m x n Matrix -}
Matrix m n = Vec (Vector n) m

m3 : Matrix 3 3
m3 = (1 ∷ 2 ∷ 3 ∷ [])
    ∷ (4 ∷ 5 ∷ 6 ∷ [])
    ∷ (7 ∷ 8 ∷ 9 ∷ [])
    ∷ []

m4 : Matrix 3 2
m4 = (1 ∷ 2 ∷ [])
    ∷ (4 ∷ 5 ∷ [])
    ∷ (7 ∷ 8 ∷ [])
    ∷ []

-- Define the operation transpose which switches columns and rows.
-- Applicative functor, Vec _ n is an applicative functor
-- mapVec : (A → B) → Vec A n → Vec B n
-- return : A → Vec A n
-- app : Vec (A → B) n → Vec A n → Vec B n
-- mapVec f as = app (return f) as

return : {A : Set}{n : ℕ} → A → Vec A n
return {n = zero} a = []
return {n = suc m} a = a ∷ return {n = m} a

app : {A B : Set}{n : ℕ} → Vec (A → B) n → Vec A n → Vec B n
app [] [] = []
app (a2b ∷ a2bs) (a ∷ as) = a2b a ∷ app a2bs as

transpose : {m n : ℕ} → Matrix m n → Matrix n m
transpose [] = return []
transpose (ns ∷ mns) = app (app (return _∷_) ns) (transpose mns)

{-
transpose : {m n : ℕ} → Matrix m n → Matrix n m
transpose [] = {!!} -- [ [] , [] , [] ] m empty rows
transpose (ns ∷ mns) = {!transpose mns!}
-}
-- if ns = [1 , 2 , 3]
-- transpose mns = [ns1 , ns2 , ns3] => [1 ∷ ns1 , 2 ∷ ns2 , 3 ∷ ns3]

test8 : Matrix 2 3
test8 = transpose m4

test9 : Matrix 3 3
test9 = transpose m3


module Issue408 where

open import Common.Prelude
open import Common.Equality

-- 1. Agda should prefer to split on an argument that covers

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

wk : {n : Nat} → Fin n → Fin (suc n)
wk zero = zero
wk (suc n) = suc (wk n)

predFin : (n : Nat) → Fin n → Fin n
predFin (suc n) zero    = zero
predFin (suc n) (suc i) = wk i
-- predFin should be covering

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

_!!_ : {A : Set}{n : Nat} → Vec A n → Fin n → A
(x ∷ xs) !! zero    = x
(x ∷ xs) !! (suc i) = xs !! i
-- should be covering, no need for absurd clause

test!!1 : ∀ {A}{n} (x : A) (xs : Vec A n) →   (x ∷ xs) !! zero    ≡ x
test!!1 x xs = refl

test!!2 : ∀ {A}{n} (x : A) (xs : Vec A n) i → (x ∷ xs) !! (suc i) ≡ xs !! i
test!!2 x xs i = refl

-- 2. Agda should prefer  to split on an argument that has only
-- constructor patterns.  For max below, split on 2nd, then on 1st.

max : Nat → Nat → Nat
max (suc n) (suc m) = suc (max n m)
max 0       (suc m) = suc m
max n        0      = n

testmax1 : {n m : Nat} → max (suc n) (suc m) ≡ suc (max n m)
testmax1 = refl

testmax2 : {m : Nat} → max 0 (suc m) ≡ suc m
testmax2 = refl

{- DOES NOT WORK YET
testmax3 : {n : Nat} → max n 0 ≡ n
testmax3 = refl
-- equation should hold definitionally
-}


module ASN1.Util where

open import Data.Word8 using (Word8) renaming (primWord8fromNat to to𝕎; primWord8toNat to from𝕎)
open import Data.Nat using (ℕ; _+_; _*_; _≤?_)
open import Data.Nat.DivMod using (_divMod_; result)
open import Data.Fin using (toℕ)
open import Data.List using (List; []; _∷_)
open import Relation.Nullary using (Dec; yes; no)

-- TODO: use WF induction
{-# TERMINATING #-}
base256 : ℕ → List Word8
base256 n with n ≤? 255
... | yes _ = to𝕎 n ∷ []
... | no _ with n divMod 256
... | result quotient remainder _ = to𝕎 (toℕ remainder) ∷ base256 quotient

fromBase256 : List Word8 → ℕ
fromBase256 [] = 0 -- this should not be the case, as 0 is encoded as (0 ∷ [])
fromBase256 (x ∷ ns) = from𝕎 x + 256 * fromBase256 ns

{-
base256-prop : ∀ n → n ≡ fromBase256 (base256 n)
base256-prop n with n ≤? 255
base256-prop n | yes p = {!!}
base256-prop n | no ¬p = {!!}
-}

{-# TERMINATING #-}
base128 : ℕ → List Word8
base128 n with n ≤? 127
... | yes _ = to𝕎 n ∷ []
... | no _ with n divMod 128
... | result quotient remainder _ = to𝕎 (128 + toℕ remainder) ∷ base128 quotient


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

open import LogicalFormulae
open import Setoids.Setoids
open import Rings.Definition
open import Rings.IntegralDomains.Definition

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

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

open Setoid S
open Ring R
open import Rings.Units.Definition R

record Irreducible (r : A) : Set (a ⊔ b) where
  field
    nonzero : (r ∼ 0R) → False
    nonunit : (Unit r) → False
    irreducible : (x y : A) → (x * y) ∼ r → (Unit x → False) → Unit y


------------------------------------------------------------------------
-- Definitions of combinatorial functions
------------------------------------------------------------------------

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

module Math.Combinatorics.Function where

-- agda-stdlib
import Algebra.Operations.CommutativeMonoid as CommutativeMonoidOperations
open import Data.Fin using (toℕ)
open import Data.Nat
open import Data.Nat.DivMod
open import Data.Nat.Properties using (+-0-commutativeMonoid)
open import Data.List
open import Data.Sum using (_⊎_; inj₁; inj₂)
open import Data.Unit using (tt)
open import Relation.Binary.PropositionalEquality
open import Relation.Nullary using (yes; no; ¬_)
open import Relation.Nullary.Decidable using (False; fromWitnessFalse)

-- agda-misc
open import Math.NumberTheory.Summation.Nat

open CommutativeMonoidOperations +-0-commutativeMonoid

infix 10 _! _!!

------------------------------------------------------------------------
-- Factorial
-- n ! = n * (n - 1) * ... * 2 * 1
-- A000142

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

------------------------------------------------------------------------
-- Permutation, Falling factorial
-- P n k = (n)ₖ = n * (n - 1) * ... * (n - k + 1)  (k terms)

P : ℕ → ℕ → ℕ
P n       0       = 1
P 0       (suc k) = 0
P (suc n) (suc k) = suc n * P n k

------------------------------------------------------------------------
-- Combination, Binomial coefficient
-- C n k = P n k / k !

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

-- recursive definition
CRec : ℕ → ℕ → ℕ
CRec n       0       = 1
CRec 0       (suc k) = 0
CRec (suc n) (suc k) = CRec n k + CRec n (suc k)

------------------------------------------------------------------------
-- Double factorial
-- A006882

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

------------------------------------------------------------------------
-- unsigned Stirling numbers of the first kind

S1 : ℕ → ℕ → ℕ
S1 0       0       = 1
S1 0       (suc k) = 0
S1 (suc n) 0       = 0
S1 (suc n) (suc k) = n * S1 n (suc k) + S1 n k

------------------------------------------------------------------------
-- Stirling numbers of the second kind

S2 : ℕ → ℕ → ℕ
S2 0       0       = 1
S2 0       (suc k) = 0
S2 (suc n) 0       = 0
S2 (suc n) (suc k) = suc k * S2 n (suc k) + S2 n k

------------------------------------------------------------------------
-- Lah number

L : ℕ → ℕ → ℕ
L n               0             = 0
L 0               (suc k)       = 0
L 1               1             = 1
L 1               (suc (suc k)) = 0
L (suc n@(suc _)) (suc k)       = (n + suc k) * L n (suc k) + L n k

------------------------------------------------------------------------
-- Bell number
-- A000110

B : ℕ → ℕ
B n = Σ[ i ≤ n ] S2 n i

------------------------------------------------------------------------
-- Pochhammer symbol, Rising factorial
-- Poch n k = x^(n) = n * (n + 1) * ... * (n + k - 1) (k terms)

Poch : ℕ → ℕ → ℕ
Poch n 0       = 1
Poch n (suc k) = n * Poch (suc n) k

------------------------------------------------------------------------
-- Central binomial coefficient
-- A000984

CB : ℕ → ℕ
CB n = C (2 * n) n

------------------------------------------------------------------------
-- Catalan number
-- A000108

Catalan : ℕ → ℕ
Catalan n = CB n / suc n

------------------------------------------------------------------------
-- Eulerian number

A : ℕ → ℕ → ℕ
A 0       0       = 1
A 0       (suc m) = 0
A (suc n) 0       = 1
A (suc n) (suc m) = (n ∸ m) * A n m + suc (suc m) * A n (suc m)

------------------------------------------------------------------------
-- Eulerian numbers of the second kind

E2 : ℕ → ℕ → ℕ
E2 0       0       = 1
E2 0       (suc m) = 0
E2 (suc n) 0       = 1
E2 (suc n) (suc m) =
  (2 * suc n ∸ suc m ∸ 1) * E2 n m + suc (suc m) * E2 n (suc m)

------------------------------------------------------------------------
-- Multinomial coefficient
-- Multinomial xs = (sum xs) ! / product (map _! xs)

Multinomial : List ℕ → ℕ
Multinomial []           = 1
Multinomial xxs@(x ∷ xs) = C (sum xxs) x * Multinomial xs

------------------------------------------------------------------------
-- Pascal's triangle

gpascal : ∀ {a} {A : Set a} → (A → A → A) → A → A → ℕ → List A
gpascal f v0 v1 0       = v1 ∷ []
gpascal f v0 v1 (suc n) =
  let ps = gpascal f v0 v1 n in zipWith f (v0 ∷ ps) (ps ∷ʳ v0)

pascal : ℕ → List ℕ
pascal = gpascal _+_ 0 1


------------------------------------------------------------------------
-- The Agda standard library
--
-- Integer division
------------------------------------------------------------------------

module Issue846.OldDivMod where

open import Data.Nat as Nat
open import Data.Nat.Properties
open SemiringSolver
open import Data.Fin as Fin using (Fin; zero; suc; toℕ; fromℕ)
import Data.Fin.Properties as Fin
open import Induction.Nat
open import Relation.Nullary.Decidable
open import Relation.Binary.PropositionalEquality
open ≡-Reasoning
open import Function

------------------------------------------------------------------------
-- Some boring lemmas

private

  lem₁ : (m k : ℕ) →
         Nat.suc m ≡ suc (toℕ (Fin.inject+ k (fromℕ m)) + 0)
  lem₁ m k = cong suc $ begin
    m
      ≡⟨ sym $ Fin.to-from m ⟩
    toℕ (fromℕ m)
      ≡⟨ Fin.inject+-lemma k (fromℕ m) ⟩
    toℕ (Fin.inject+ k (fromℕ m))
      ≡⟨ solve 1 (λ x → x := x :+ con 0) refl _ ⟩
    toℕ (Fin.inject+ k (fromℕ m)) + 0
      ∎

  lem₂ : ∀ n → _
  lem₂ = solve 1 (λ n → con 1 :+ n  :=  con 1 :+ (n :+ con 0)) refl

  lem₃ : ∀ n k q (r : Fin n) eq → suc n + k ≡ toℕ r + suc q * n
  lem₃ n k q r eq = begin
      suc n + k
        ≡⟨ solve 2 (λ n k → con 1 :+ n :+ k  :=  n :+ (con 1 :+ k))
                   refl n k ⟩
      n + suc k
        ≡⟨ cong (_+_ n) eq ⟩
      n + (toℕ r + q * n)
        ≡⟨ solve 3 (λ n r q → n :+ (r :+ q :* n)  :=
                              r :+ (con 1 :+ q) :* n)
                   refl n (toℕ r) q ⟩
      toℕ r + suc q * n
        ∎

------------------------------------------------------------------------
-- Division

infixl 7 _divMod_ _div_ _mod_

-- A specification of integer division.

record DivMod (dividend divisor : ℕ) : Set where
  constructor result
  field
    quotient  : ℕ
    remainder : Fin divisor
    property  : dividend ≡ toℕ remainder + quotient * divisor

-- Integer division with remainder.

-- Note that Induction.Nat.<-rec is used to establish termination of
-- division. The run-time complexity of this implementation of integer
-- division should be linear in the size of the dividend, assuming
-- that well-founded recursion and the equality type are optimised
-- properly (see "Inductive Families Need Not Store Their Indices"
-- (Brady, McBride, McKinna, TYPES 2003)).

_divMod_ : (dividend divisor : ℕ) {≢0 : False (divisor ≟ 0)} →
           DivMod dividend divisor
_divMod_ m n {≢0} = <-rec Pred dm m n {≢0}
  where
  Pred : ℕ → Set
  Pred dividend = (divisor : ℕ) {≢0 : False (divisor ≟ 0)} →
                  DivMod dividend divisor

  1+_ : ∀ {k n} → DivMod (suc k) n → DivMod (suc n + k) n
  1+_ {k} {n} (result q r eq) = result (1 + q) r (lem₃ n k q r eq)

  dm : (dividend : ℕ) → <-Rec Pred dividend → Pred dividend
  dm m       rec zero    {≢0 = ()}
  dm zero    rec (suc n)            = result 0 zero refl
  dm (suc m) rec (suc n)            with compare m n
  dm (suc m) rec (suc .(suc m + k)) | less .m k    = result 0 r (lem₁ m k)
                                        where r = suc (Fin.inject+ k (fromℕ m))
  dm (suc m) rec (suc .m)           | equal .m     = result 1 zero (lem₂ m)
  dm (suc .(suc n + k)) rec (suc n) | greater .n k =
    1+ rec (suc k) le (suc n)
    where le = s≤′s (s≤′s (n≤′m+n n k))

-- Integer division.

_div_ : (dividend divisor : ℕ) {≢0 : False (divisor ≟ 0)} → ℕ
_div_ m n {≢0} = DivMod.quotient $ _divMod_ m n {≢0}

-- The remainder after integer division.

_mod_ : (dividend divisor : ℕ) {≢0 : False (divisor ≟ 0)} → Fin divisor
_mod_ m n {≢0} = DivMod.remainder $ _divMod_ m n {≢0}


data ⊥ : Set where

data Bool : Set where
  false true : Bool

data _≡_ (x : Bool) : Bool → Set where
  refl : x ≡ x

true≠false : false ≡ true → ⊥
true≠false ()

data Maybe (A : Set) : Set where
  nothing : Maybe A
  just : A → Maybe A

data Eq {A : Set} (_≈_ : A → A → Set) : Maybe A → Maybe A → Set where
  just    : ∀ {x y} (x≈y : x ≈ y) → Eq _≈_ (just x) (just y)
  nothing : Eq _≈_ nothing nothing

drop-just : ∀ {A : Set} {_≈_ : A → A → Set} {x y : A} →
            Eq _≈_ (just x) (just y) → x ≈ y
drop-just (just x≈y) = x≈y


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

open import Groups.Definition
open import Setoids.Setoids
open import Sets.EquivalenceRelations
open import Groups.Homomorphisms.Definition
open import Groups.Homomorphisms.Lemmas
open import Groups.Subgroups.Definition
open import Groups.Subgroups.Normal.Definition
open import Groups.Lemmas

module Groups.Homomorphisms.Kernel {a b c d : _} {A : Set a} {B : Set b} {S : Setoid {a} {c} A} {T : Setoid {b} {d} B} {_+G_ : A → A → A} {_+H_ : B → B → B} {G : Group S _+G_} {H : Group T _+H_} {f : A → B} (fHom : GroupHom G H f) where

open Setoid T
open Equivalence eq

groupKernelPred : A → Set d
groupKernelPred a = Setoid._∼_ T (f a) (Group.0G H)

groupKernelPredWd : {x y : A} → (Setoid._∼_ S x y) → groupKernelPred x → groupKernelPred y
groupKernelPredWd x=y fx=0 = transitive (GroupHom.wellDefined fHom (Equivalence.symmetric (Setoid.eq S) x=y)) fx=0

groupKernelIsSubgroup : Subgroup G groupKernelPred
Subgroup.closedUnderPlus groupKernelIsSubgroup fg=0 fh=0 = transitive (transitive (GroupHom.groupHom fHom) (Group.+WellDefined H fg=0 fh=0)) (Group.identLeft H)
Subgroup.containsIdentity groupKernelIsSubgroup = imageOfIdentityIsIdentity fHom
Subgroup.closedUnderInverse groupKernelIsSubgroup fg=0 = transitive (homRespectsInverse fHom) (transitive (inverseWellDefined H fg=0) (invIdent H))
Subgroup.isSubset groupKernelIsSubgroup = groupKernelPredWd

groupKernelIsNormalSubgroup : normalSubgroup G groupKernelIsSubgroup
groupKernelIsNormalSubgroup {g} fk=0 = transitive (transitive (transitive (GroupHom.groupHom fHom) (transitive (Group.+WellDefined H reflexive (transitive (GroupHom.groupHom fHom) (transitive (Group.+WellDefined H fk=0 reflexive) (Group.identLeft H)))) (symmetric (GroupHom.groupHom fHom)))) (GroupHom.wellDefined fHom (Group.invRight G {g}))) (imageOfIdentityIsIdentity fHom)


module Test.Factorial where

open import Data.Nat

factorial : ℕ -> ℕ
factorial zero = 1
factorial n@(suc n') = n * factorial n'


{-# OPTIONS --without-K #-}
module hott.level.sets where

open import level
open import decidable
open import sum
open import equality.core
open import equality.calculus
open import equality.reasoning
open import function.core
open import function.extensionality.proof
open import sets.empty
open import sets.unit
open import hott.level.core

-- ⊤ is contractible
⊤-contr : contr ⊤
⊤-contr = tt , λ { tt → refl }

-- ⊥ is propositional
⊥-prop : h 1 ⊥
⊥-prop x _ = ⊥-elim x

⊥-initial : ∀ {i} {A : Set i} → contr (⊥ → A)
⊥-initial = (λ ()) , (λ f → funext λ ())

-- Hedberg's theorem
hedberg : ∀ {i} {A : Set i}
        → ((x y : A) → Dec (x ≡ y))
        → h 2 A
hedberg {A = A} dec x y = prop⇒h1 ≡-prop
  where
    open ≡-Reasoning

    canonical : {x y : A} → x ≡ y → x ≡ y
    canonical {x} {y} p with dec x y
    ... | yes q = q
    ... | no _ = p

    canonical-const : {x y : A}
                    → (p q : x ≡ y)
                    → canonical p ≡ canonical q
    canonical-const {x} {y} p q with dec x y
    ... | yes _ = refl
    ... | no f = ⊥-elim (f p)

    canonical-inv : {x y : A}(p : x ≡ y)
                  → canonical p · sym (canonical refl) ≡ p
    canonical-inv refl = left-inverse (canonical refl)

    ≡-prop : {x y : A}(p q : x ≡ y) → p ≡ q
    ≡-prop p q = begin
        p
      ≡⟨ sym (canonical-inv p) ⟩
        canonical p · sym (canonical refl)
      ≡⟨ ap (λ z → z · sym (canonical refl))
              (canonical-const p q) ⟩
        canonical q · sym (canonical refl)
      ≡⟨ canonical-inv q ⟩
        q
      ∎

-- Bool is a set
private
  module BoolSet where
    open import sets.bool
    bool-set : h 2 Bool
    bool-set = hedberg _≟_
open BoolSet public

-- Nat is a set
private
  module NatSet where
    open import sets.nat.core
    nat-set : h 2 ℕ
    nat-set = hedberg _≟_
open NatSet public

-- Fin is a set
private
  module FinSet where
    open import sets.fin.core
    fin-set : ∀ n → h 2 (Fin n)
    fin-set n = hedberg _≟_
open FinSet public


------------------------------------------------------------------------
-- Propositional equality
------------------------------------------------------------------------

module Relation.Binary.PropositionalEquality1 where

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

------------------------------------------------------------------------
-- Propositional equality

infix 4 _≡₁_ _≢₁_

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

-- Nonequality.

_≢₁_ : {a : Set₁} → a → a → Set
x ≢₁ y = ¬ x ≡₁ y

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

reflexive : ∀ {a} (x : a) → x ≡₁ x
reflexive _ = refl

sym : ∀ {a} {x y : a} → x ≡₁ y → y ≡₁ x
sym refl = refl

trans : ∀ {a} {x y z : a} → x ≡₁ y → y ≡₁ z → x ≡₁ z
trans refl refl = refl

subst : {a b : Set} → a ≡₁ b → a → b
subst refl x = x

cong : ∀ {a b} (f : a → b) → ∀ {x y} → x ≡₁ y → f x ≡₁ f y
cong _ refl = refl

cong₂ : ∀ {a b c} (f : a → b → c) →
        ∀ {x₁ x₂ y₁ y₂} → x₁ ≡₁ x₂ → y₁ ≡₁ y₂ → f x₁ y₁ ≡₁ f x₂ y₂
cong₂ _ refl refl = refl

cong₀₁ : ∀ {a b} (f : a → b) → ∀ {x y} → x ≡ y → f x ≡₁ f y
cong₀₁ _ refl = refl

cong₁₀ : ∀ {a b} (f : a → b) → ∀ {x y} → x ≡₁ y → f x ≡ f y
cong₁₀ _ refl = refl


open import Data.Nat using (ℕ)

module Data.BitVector.Properties.LatticeProperties (n : ℕ) where

open import Data.BitVector
open import Algebra.Structures
open import Relation.Binary.PropositionalEquality
open import Data.Vec
open import Data.Product hiding (map)
import Data.Bool.Properties as Bool

private
  module BitProperties = IsBooleanAlgebra Bool.isBooleanAlgebra
  -- All these properties follow trivially from the bit properties. TODO: generalize the pattern to just reuse the bitproperties
  ∨-comm : ∀ {n} (x y : BitVector n) → bitwise-or x y ≡ bitwise-or y x
  ∨-comm [] [] = refl
  ∨-comm (x ∷ xs) (y ∷ ys) rewrite BitProperties.∨-comm x y | ∨-comm xs ys = refl

  ∧-comm : ∀ {n} (x y : BitVector n) → bitwise-and x y ≡ bitwise-and y x
  ∧-comm [] [] = refl
  ∧-comm (x ∷ xs) (y ∷ ys) rewrite BitProperties.∧-comm x y | ∧-comm xs ys = refl

  ∨-assoc : ∀ {n} (x y z : BitVector n) → bitwise-or (bitwise-or x y) z ≡ bitwise-or x (bitwise-or y z)
  ∨-assoc [] [] [] = refl
  ∨-assoc (x ∷ xs) (y ∷ ys) (z ∷ zs) rewrite BitProperties.∨-assoc x y z | ∨-assoc xs ys zs = refl

  ∧-assoc : ∀ {n} (x y z : BitVector n) → bitwise-and (bitwise-and x y) z ≡ bitwise-and x (bitwise-and y z)
  ∧-assoc [] [] [] = refl
  ∧-assoc (x ∷ xs) (y ∷ ys) (z ∷ zs) rewrite BitProperties.∧-assoc x y z | ∧-assoc xs ys zs = refl

  ∨∧-absorb : ∀ {n} (x y : BitVector n) → bitwise-or x (bitwise-and x y) ≡ x
  ∨∧-absorb [] [] = refl
  ∨∧-absorb (x ∷ xs) (y ∷ ys) rewrite proj₁ BitProperties.absorptive x y | ∨∧-absorb xs ys = refl

  ∧∨-absorb : ∀ {n} (x y : BitVector n) → bitwise-and x (bitwise-or x y) ≡ x
  ∧∨-absorb [] [] = refl
  ∧∨-absorb (x ∷ xs) (y ∷ ys) rewrite proj₂ BitProperties.absorptive x y | ∧∨-absorb xs ys = refl

  ∨-cong : ∀ {n} {x y u v : BitVector n} → x ≡ y → u ≡ v → bitwise-or x u ≡ bitwise-or y v
  ∨-cong refl refl = refl

  ∧-cong : ∀ {n} {x y u v : BitVector n} → x ≡ y → u ≡ v → bitwise-and x u ≡ bitwise-and y v
  ∧-cong refl refl = refl

  isLattice : ∀ {n} → IsLattice _≡_ (bitwise-or {n}) bitwise-and
  isLattice = record
    { isEquivalence = isEquivalence
    ; ∨-comm = ∨-comm
    ; ∨-assoc = ∨-assoc
    ; ∨-cong = ∨-cong
    ; ∧-comm = ∧-comm
    ; ∧-assoc = ∧-assoc
    ; ∧-cong = ∧-cong
    ; absorptive = ∨∧-absorb , ∧∨-absorb
    }

  ∨∧-distribʳ : ∀ {n} (x y z : BitVector n) → bitwise-or (bitwise-and y z) x ≡ bitwise-and (bitwise-or y x) (bitwise-or z x)
  ∨∧-distribʳ [] [] [] = refl
  ∨∧-distribʳ (x ∷ xs) (y ∷ ys) (z ∷ zs) rewrite BitProperties.∨-∧-distribʳ x y z | ∨∧-distribʳ xs ys zs = refl

  isDistributiveLattice : ∀ {n} → IsDistributiveLattice _≡_ (bitwise-or {n}) bitwise-and
  isDistributiveLattice = record
    { isLattice = isLattice
    ; ∨-∧-distribʳ = ∨∧-distribʳ
    }

  ∨-complementʳ : ∀ {n} (x : BitVector n) → bitwise-or x (bitwise-negation x) ≡ ones n
  ∨-complementʳ [] = refl
  ∨-complementʳ (x ∷ xs) rewrite BitProperties.∨-complementʳ x | ∨-complementʳ xs = refl

  ∧-complementʳ : ∀ {n} (x : BitVector n) → bitwise-and x (bitwise-negation x) ≡ zero n
  ∧-complementʳ [] = refl
  ∧-complementʳ (x ∷ xs) rewrite BitProperties.∧-complementʳ x | ∧-complementʳ xs = refl

  ¬-cong : ∀ {n} {i j : BitVector n} → i ≡ j → bitwise-negation i ≡ bitwise-negation j
  ¬-cong refl = refl

isBooleanAlgebra : ∀ {n} → IsBooleanAlgebra _≡_ bitwise-or bitwise-and bitwise-negation (ones n) (zero n)
isBooleanAlgebra = record
  { isDistributiveLattice = isDistributiveLattice
  ; ∨-complementʳ = ∨-complementʳ
  ; ∧-complementʳ = ∧-complementʳ
  ; ¬-cong = ¬-cong
  }


{-# OPTIONS --universe-polymorphism #-}
-- {-# OPTIONS --verbose tc.records.ifs:15 #-}
-- {-# OPTIONS --verbose tc.constr.findInScope:15 #-}
-- {-# OPTIONS --verbose tc.term.args.ifs:15 #-}
-- {-# OPTIONS --verbose cta.record.ifs:15 #-}
-- {-# OPTIONS --verbose tc.section.apply:25 #-}
-- {-# OPTIONS --verbose tc.mod.apply:100 #-}
-- {-# OPTIONS --verbose scope.rec:15 #-}
-- {-# OPTIONS --verbose tc.rec.def:15 #-}

module 04-equality where

record ⊤ : Set where
  constructor tt

data Bool : Set where
  true : Bool
  false : Bool

or : Bool → Bool → Bool
or true _ = true
or _ true = true
or false false = false

and : Bool → Bool → Bool
and false _ = false
and _ false = false
and true true = false

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

id : {A : Set} → A → A
id v = v

primEqBool : Bool → Bool → Bool
primEqBool true = id
primEqBool false = not

record Eq (A : Set) : Set where
  field eq : A → A → Bool

eqBool : Eq Bool
eqBool = record { eq = primEqBool }

open Eq {{...}}

neq : {t : Set} → {{eqT : Eq t}} → t → t → Bool
neq a b = not (eq a b)

test = eq false false

-- Instance arguments will also resolve to candidate instances which
-- still require hidden arguments. This allows us to define a
-- reasonable instance for Fin types
data ℕ : Set where
  zero : ℕ
  suc : ℕ → ℕ

{-# BUILTIN NATURAL ℕ    #-}

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

primEqFin : {n : ℕ} → Fin n → Fin n → Bool
primEqFin zero zero = true
primEqFin zero (suc y) = false
primEqFin (suc y) zero = false
primEqFin (suc x) (suc y) = primEqFin x y

eqFin : {n : ℕ} → Eq (Fin n)
eqFin = record { eq = primEqFin }

-- eqFin′ : Eq (Fin 3)
-- eqFin′ = record { eq = primEqFin }

-- eqFinSpecial : {n : ℕ} → Prime n → Eq (Fin n)
-- eqFinSpecial

fin1 : Fin 3
fin1 = zero

fin2 : Fin 3
fin2 = suc (suc zero)

testFin : Bool
testFin = eq fin1 fin2


module Definitions where

data ℕ : Set where
  zero : ℕ
  suc  : (n : ℕ) → ℕ

data _≡_ (x : ℕ) : ℕ → Set where
  refl : x ≡ x

data _≢_ : ℕ → ℕ → Set where
  z≢s : ∀ {n} → zero ≢ suc n
  s≢z : ∀ {n} → suc n ≢ zero
  s≢s : ∀ {m n} → m ≢ n → suc m ≢ suc n

data Equal? (m n : ℕ) : Set where
  yes : m ≡ n → Equal? m n
  no  : m ≢ n → Equal? m n

data ⊥ : Set where


module ICFPPrelude where

record ⊤ : Set where
  constructor ⟨⟩

data ⊥ : Set where

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

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

{-# BUILTIN NATURAL Nat #-}

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

infixr 2 _∪_
data _∪_ A B : Set where
  inl : A → A ∪ B
  inr : B → A ∪ B

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

{-# BUILTIN EQUALITY _≡_ #-}
{-# BUILTIN REFL refl #-}


{-# OPTIONS -v treeless:20 #-}
module _ where

data N : Set where
  zero : N
  suc : N → N

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

record P A B : Set where
  constructor _,_
  field fst : A
        snd : B

open P

{-# INLINE fst #-}
{-# INLINE snd #-}

-- Without handling repeated cases:
-- g = λ a → case a of b , c → b (case a of d , e → e)
-- Should be
-- g = λ a → case a of b , c → b c
g : P (N → N) N → N
g z = fst z (snd z)


module Logic.DiagonalMethod where

open import Functional
open import Logic.Predicate
open import Logic.Propositional
import      Lvl
open import Relator.Equals
open import Relator.Equals.Proofs
open import Structure.Function.Domain
open import Structure.Operator
open import Structure.Relator.Properties
open import Syntax.Function
open import Type.Size
open import Type

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

-- Also called: Diagonal method, Cantor's diagonal argument.
function-type-surjectivity-fixpoint : (A ≽ (A → B)) → ∀{f : B → B} → ∃(Fixpoint f)
function-type-surjectivity-fixpoint ([∃]-intro s) {f}
  with [∃]-intro i ⦃ p ⦄ ← surjective(s) {f ∘ (s $₂_)}
  = [∃]-intro(s i i) ⦃ intro(symmetry(_≡_) (congruence₂ₗ(_$_)(i) p)) ⦄

module _ where
  open import Data.Boolean
  open import Data.Boolean.Proofs

  decidable-power-set-no-surjection : ¬(T ≽ (T → Bool))
  decidable-power-set-no-surjection = (p ↦ [!]-no-fixpoints(Fixpoint.proof([∃]-proof(p{not})))) ∘ function-type-surjectivity-fixpoint

module _ where
  open import Data.Boolean
  open import Data.Boolean.Proofs
  open import Function.Inverseᵣ
  open import Structure.Function.Domain.Proofs
  open import Structure.Function
  open import Syntax.Transitivity

  function-type-no-surjection : (B ≽ Bool) → ¬(A ≽ (A → B))
  function-type-no-surjection ([∃]-intro r-bool) surj
    with [∃]-intro i ⦃ fix ⦄ ← function-type-surjectivity-fixpoint surj {invᵣ r-bool ⦃ surjective-to-invertibleᵣ ⦄ ∘ not ∘ r-bool}
    = [!]-no-fixpoints(symmetry(_≡_) (Inverseᵣ.proof surjective-to-inverseᵣ) 🝖 congruence₁(r-bool) (Fixpoint.proof fix))

module _ where
  open import Numeral.Natural
  open import Numeral.Natural.Oper.Proofs

  ℕ-function-non-surjectivity : ¬(ℕ ≽ (ℕ → ℕ))
  ℕ-function-non-surjectivity = (p ↦ 𝐒-not-self(Fixpoint.proof([∃]-proof(p{𝐒})))) ∘ function-type-surjectivity-fixpoint


----------------------------------------------------------------------
-- Copyright: 2013, Jan Stolarek, Lodz University of Technology     --
--                                                                  --
-- License: See LICENSE file in root of the repo                    --
-- Repo address: https://github.com/jstolarek/dep-typed-wbl-heaps   --
--                                                                  --
-- Refl datatype and functions required for equational reasoning.   --
----------------------------------------------------------------------

module Basics.Reasoning where

open import Basics.Nat hiding (_≥_)
open import Basics.Ordering

-- Basic definition we will need in our proofs is propositional
-- equality (known as refl). Unlike refl definition provided by Agda's
-- standard library the definition below is not universe
-- polymorphic. It works only on Set, but not on Set1 and higher Sets
-- - this will be perfectly sufficient for our purposes. This datatype
-- allows to express equality between types belonging to Set.
data _≡_ {S : Set} (s : S) : S → Set where
  refl : s ≡ s

infixl 1 _≡_

-- Below we prove basic properties of relations: symmetry,
-- transitivity, congruence and substitution. If these proofs are not
-- familiar I encourage to take a look at tutorials on Agda Wiki. The
-- most useful source in my opinion are the online lecture notes for
-- the Computer Aided Formal Reasoning course by Thorsten Altenkirch:
--
-- http://www.cs.nott.ac.uk/~txa/g53cfr/
sym : {A : Set} → {a b : A} → a ≡ b → b ≡ a
sym refl = refl

trans : {A : Set}{a b c : A} → a ≡ b → b ≡ c → a ≡ c
trans refl refl = refl

cong : {A B : Set} (f : A → B) → ∀ {a b} → a ≡ b → f a ≡ f b
cong f refl = refl

subst : {A : Set}(P : A → Set) → {a b : A} → a ≡ b → P a → P b
subst prp refl p = p

-- We prove some basic properties of addition that we will need later
-- in more complex proofs. I assume that you had previous exposure to
-- these basic proofs, but nevertheless I provide extensive
-- explanations. Make sure you understand how these proofs work before
-- proceeding with rest of the paper.

-- Note [0 is right identity of addition]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
--
-- The fact that 0 is left identity of addition (ie. 0 + a ≡ a)
-- follows directly from our definition of _+_:
--
--   _+_ : Nat → Nat → Nat
--   zero  + m = m
--   suc n + m = suc (n + m)
--
-- But we need a separate proof that 0 is also right identity of
-- addition, ie. a + 0 ≡ a. Proof proceeds by induction on a. If a is
-- zero then we have:
--
--   0 + 0 = 0
--
-- And the proof follows from the definition of addition - hence we
-- use refl. In a recursive case we have:
--
--   (suc a) + zero ≡ (suc a)
--
-- Applying definition of addition to LHS we have:
--
--   suc (a + zero) ≡ suc a
--
-- Since we have suc on both sides of the equality, we use
-- congruence. This leaves us with a proof that equality holds for the
-- parameters of suc:
--
--   a + zero ≡ a
--
-- But that happens to be the equality we are proving at the
-- moment. We therefore make a recursive call to (+0 a), which is
-- equivalent of applying inductive hypothesis in an inductive proof.
--
-- ∎

+0 : (a : Nat) → a + zero ≡ a -- See Note [0 is right identity of addition]
+0 zero    = refl
+0 (suc a) = cong suc (+0 a)

-- Note [1 + (a + b) equals a + (1 + b)]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
--
-- We will need this property surprisingly often. We proceed by
-- inductive proof on a. In the base case, when a = 0, we have:
--
--   suc (0 + b) ≡ 0 + (suc b)
--
-- Applying definition of + to both sides of equality we get:
--
--   suc b ≡ suc b
--
-- Which is true by definition, hence we use refl. In the recursive
-- case we have:
--
--   suc ((suc a) + b) ≡ (suc a) + (suc b)
--
-- We apply definition of + to both sides and get:
--
--   suc (suc (a + b)) ≡ suc (a + (suc b))
--
-- Again, since we have suc on both sides we use congruence and are
-- left with a proof:
--
--   suc (a + b) ≡ a + (suc b)
--
-- Which again is the equality we are proving. We appeal to inductive
-- hypothesis by making a recursive call.
--
-- ∎

+suc : (a b : Nat) → suc (a + b) ≡ a + (suc b)
+suc zero b    = refl
+suc (suc a) b = cong suc (+suc a b)

-- Note [Commutativity of addition]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
--
-- Everyone knows that a + b ≡ b + a. But Agda won't take our word and
-- requires a formal proof. Let's proceed by induction on second
-- argument. In the base case we have:
--
--   a + 0 ≡ 0 + a
--
-- Right side reduces by the definition of + which leaves us with
--
--   a + 0 ≡ a
--
-- We proved that earlier so we appeal to already existing proof. In
-- the inductive case we have:
--
--   a + suc b ≡ (suc b) + a      [1]
--
-- Right hand side reduces by definition of + giving us:
--
--   a + suc b ≡ suc (b + a)      [2]
--
-- [2] is therefore the equality we have to prove. From +suc we know
-- that
--
--   suc (a + b) ≡ a + (suc b)    [3]
--
-- And we can use that to transform left hand side of [1]. Note
-- however that in order to apply [3] to left hand side of [1] we need
-- to reverse sides of the equality [3]:
--
--   a + (suc b) ≡ suc (a + b)    [4]
--
-- We achieve this by using symmetry.
--
-- Looking at right hand sides of [2] and [4] we see they differ by
-- the order of arguments to +. We can prove them equal by using
-- congruence on suc and appealing to our inductive hypothesis of
-- commutativity of addition. This means we have proven two things:
--
--   a + (suc b) ≡ suc (a + b)   [4, repeated], from symmetry of +suc
--   suc (a + b) ≡ suc (b + a)   [5], from congruence on suc and
--                               inductive hypothesis
--
-- Combining [4] and [5] using transitivity yields the proof of [2].
--
-- ∎
--
-- Here is a diagram, showing how code relates to the proof:
--
--                                 a + b ≡ b + a
--                                   ____|____
--                                  /         \
-- trans (sym (+suc a b)) (cong suc (+comm a b))
--       ̲\_____________/   \__________________/
--              |                    |
--  a + (suc b) ≡ suc (a + b)        |
--                       suc (a + b) ≡ suc (b + a)

+comm : (a b : Nat) → a + b ≡ b + a
+comm a zero    = +0 a
+comm a (suc b) = trans (sym (+suc a b)) (cong suc (+comm a b))

-- Note [Associativity of addition]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
--
-- We proceed by induction on the first parameter. In the base case we
-- have a = 0:
--
--   0 + (b + c) ≡ (0 + b) + c
--
-- Both sides can be normalized using the definition of + giving us
--
--   b + c ≡ b + c
--
-- Since this is true by definition we use refl. In the inductive case
-- we have to prove:
--
--   suc a + (b + c) ≡ (suc a + b) + c
--
-- Again, Agda normalizes each side using definition of + :
--
--   LHS: suc a + (b + c) ≡ suc (a + (b + c))
--   RHS: (suc a + b) + c ≡ suc (a + b) + c ≡ suc ((a + b) + c)
--
-- This means we have to prove:
--
--   suc (a + (b + c)) ≡ suc ((a + b) + c)
--
-- We can use congruence to remove the outer suc on both sides which
-- leaves us with a proof of:
--
--   a + (b + c) ̄≡ (a + b) + c
--
-- Which happens to be our inductive hypothesis - hence a recursive
-- call to +assoc.
--
-- ∎

+assoc : (a b c : Nat) → a + (b + c) ≡ (a + b) + c
+assoc zero b c    = refl
+assoc (suc a) b c = cong suc (+assoc a b c)

-- Note [If numbers are equal they are in the greater-equal relation]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
--
-- Finally, we need a proof that if a = b then a ≥ b. This property is
-- specific to our task, so you most likely haven't seen it other
-- tutorials. There are three interesting things in this proof:
--
--  1) a value of type m ≥ n proves that m is greater-equal than n. We
--     therefore need to construct the value of this type.
--
--  2) since refl is the only constructor of type ≡ we always use refl
--     when pattern matching on a value of ≡. We also always pass refl
--     as a value of ≡ in calls.
--
--  3) we need to match on implicit parameters to construct a
--     proof. Note that although type signature specifies Nats m and
--     n, in the proof we require that these are always equal.  This
--     requirement comes from the fact that m ≡ n, i.e. that m and n
--     are equal.
--
-- In the base case we need to construct a proof that 0 ≥ 0, which we
-- do by using ge0. Inductive case simply applies geS to result of
-- recursive call to ≥sym.

≥sym : {m n : Nat} → m ≡ n → m ≥ n
≥sym {zero}     {zero}    refl = ge0
≥sym {.(suc n)} {(suc n)} refl = geS (≥sym {n} {n} refl)


------------------------------------------------------------------------------
-- First-order Peano arithmetic
------------------------------------------------------------------------------

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

module PA.Inductive.README where

-- Formalization of first-order Peano arithmetic using Agda data types
-- and primitive recursive functions for addition and multiplication.

------------------------------------------------------------------------------
-- Inductive definitions
open import PA.Inductive.Base

-- Some properties
open import PA.Inductive.PropertiesATP
open import PA.Inductive.PropertiesI

open import PA.Inductive.PropertiesByInduction
open import PA.Inductive.PropertiesByInductionATP
open import PA.Inductive.PropertiesByInductionI


-- Generalized variables in datatype (and record) parameters

module _ where

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

module NotParameterised where

  variable
    ℓ : Level
    A : Set ℓ
    x y : A
    m n : Nat

  data Vec (A : Set ℓ) : Nat → Set ℓ where
    []  : Vec A zero
    _∷_ : A → Vec A n → Vec A (suc n)

  variable
    xs : Vec A n

  -- n should be generalized as an index here
  data All (P : A → Set ℓ) : Vec A n → Set ℓ where
    []  : All P []
    _∷_ : P x → All P xs → All P (x ∷ xs)

  infix 2 _∈_
  -- need an occurrence of ℓ in the params to not generalize it as an index,
  -- so we bind A explicitly
  data _∈_ {A : Set ℓ} (x : A) : Vec A n → Set ℓ where
    zero : x ∈ x ∷ xs
    suc  : x ∈ xs → x ∈ y ∷ xs

  lookup : {P : A → Set ℓ} → All P xs → x ∈ xs → P x
  lookup (x ∷  _)  zero   = x
  lookup (_ ∷ xs) (suc i) = lookup xs i

-- Check that we can do the same in a parameterised module
module Parameterised (Dummy : Set) where

  variable
    ℓ : Level
    A : Set ℓ
    x y : A
    m n : Nat

  data Vec (A : Set ℓ) : Nat → Set ℓ where
    []  : Vec A zero
    _∷_ : A → Vec A n → Vec A (suc n)

  variable
    xs : Vec A n

  -- n should be generalized as an index here
  data All (P : A → Set ℓ) : Vec A n → Set ℓ where
    []  : All P []
    _∷_ : P x → All P xs → All P (x ∷ xs)

  infix 2 _∈_
  -- need an occurrence of ℓ in the params to not generalize it as an index,
  -- so we bind A explicitly
  data _∈_ {A : Set ℓ} (x : A) : Vec A n → Set ℓ where
    zero : x ∈ x ∷ xs
    suc  : x ∈ xs → x ∈ y ∷ xs

  lookup : {P : A → Set ℓ} → All P xs → x ∈ xs → P x
  lookup (x ∷  _)  zero   = x
  lookup (_ ∷ xs) (suc i) = lookup xs i


{-# OPTIONS --without-K --safe #-}
module Categories.NaturalTransformation.NaturalIsomorphism.Equivalence where

-- a certain notion of equivalence between Natural Isomorphisms.

open import Level
open import Data.Product using (_×_; _,_; map; zip)
open import Relation.Binary using (IsEquivalence)

open import Categories.Category
open import Categories.Functor using (Functor)
open import Categories.NaturalTransformation.NaturalIsomorphism hiding (_≃_)
open import Categories.NaturalTransformation.Equivalence
open NaturalIsomorphism

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

infix 4 _≅_
_≅_ : ∀ {F G : Functor C D} → (α β : NaturalIsomorphism F G) → Set _
α ≅ β = F⇒G α ≃ F⇒G β × F⇐G α ≃ F⇐G β

≅-isEquivalence : ∀ {F G : Functor C D} → IsEquivalence (_≅_ {F = F} {G = G})
≅-isEquivalence {D = D} {F = F} {G = G} = record
  { refl  = H.refl , H.refl
  ; sym   =  map (λ z → H.sym z) (λ z → H.sym z) -- eta expansion needed
  ; trans = zip (λ a b → H.trans a b) λ a b → H.trans a b -- ditto
  }
  where module H = Category.HomReasoning D


{-# OPTIONS --safe #-}
module Cubical.Algebra.NatSolver.NatExpression where

open import Cubical.Foundations.Prelude

open import Cubical.Data.FinData
open import Cubical.Data.Nat
open import Cubical.Data.Nat.Order using (zero-≤)
open import Cubical.Data.Vec.Base

infixl 6 _+'_
infixl 7 _·'_

-- Expression in a ring on A with n variables
data Expr (n : ℕ) : Type ℓ-zero where
  K : ℕ → Expr n
  ∣ : Fin n → Expr n
  _+'_ : Expr n → Expr n → Expr n
  _·'_ : Expr n → Expr n → Expr n

module Eval where
  open import Cubical.Data.Vec

  ⟦_⟧ : ∀ {n} → Expr n → Vec ℕ n → ℕ
  ⟦ K r ⟧ v = r
  ⟦ ∣ k ⟧ v = lookup k v
  ⟦ x +' y ⟧ v =  ⟦ x ⟧ v + ⟦ y ⟧ v
  ⟦ x ·' y ⟧ v = ⟦ x ⟧ v · ⟦ y ⟧ v


module Data.List.Relation where

import      Lvl
import      Data
open import Data.List
open import Logic
open import Logic.Propositional
open import Structure.Setoid
open import Type

private variable ℓ ℓₑ ℓₑ₁ ℓₑ₂ : Lvl.Level
private variable T : Type{ℓ}

data Empty {ℓ}{T : Type{ℓ}} : List(T) → Stmt{Lvl.𝐒(ℓ)} where
  intro : Empty(∅)

-- Statement of whether a list is contained in the beginning of another list
_isPrefixOf_ : ⦃ equiv : Equiv{ℓₑ}(T) ⦄ → List(T) → List(T) → Stmt{Lvl.of(T) Lvl.⊔ ℓₑ}
∅            isPrefixOf _       = Data.Unit
(p ⊰ prefix) isPrefixOf ∅       = Data.Empty
(p ⊰ prefix) isPrefixOf (x ⊰ l) = (p ≡ x) ∧ (prefix isPrefixOf l)
-- _isPrefixOf_ prefix l = (∃ \rest → l ≡ (prefix ++ rest))

-- Statement of whether a list is contained in the end of another list
_isSuffixOf_ : ⦃ equiv : Equiv{ℓₑ₁}(T) ⦄ → ⦃ equiv-list : Equiv{ℓₑ₂}(List(T)) ⦄ → List(T) → List(T) → Stmt{Lvl.of(T) Lvl.⊔ ℓₑ₁ Lvl.⊔ ℓₑ₂}
∅            isSuffixOf _       = Data.Unit
(p ⊰ prefix) isSuffixOf ∅       = Data.Empty
(p ⊰ prefix) isSuffixOf (x ⊰ l) = ((p ⊰ prefix) isSuffixOf l) ∨ ((p ⊰ prefix) ≡ (x ⊰ l))
-- _isSuffixOf_ suffix l = (∃ \rest → l ≡ (rest ++ suffix))