module Prelude where

  id : {a : Set} -> a -> a
  id x = x

  infixr 0 _$_

  _$_ : {a b : Set} -> (a -> b) -> a -> b
  f $ x = f x

  data Bool : Set where
    True  : Bool
    False : Bool

  _&&_ : Bool -> Bool -> Bool
  True  && b = b
  False && _ = False

  data Pair (a b : Set) : Set where
    pair : a -> b -> Pair a b

  fst : {a b : Set} -> Pair a b -> a
  fst (pair x y) = x

  snd : {a b : Set} -> Pair a b -> b
  snd (pair x y) = y

  data Either (a b : Set) : Set where
    left  : a -> Either a b
    right : b -> Either a b

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

  data Unit : Set where
    unit : Unit

  data Absurd : Set where

  absurdElim : {whatever : Set} -> Absurd -> whatever
  absurdElim ()

--   data Pi {a : Set} (f : a -> Set) : Set where
--     pi : ((x : a) -> f x) -> Pi f
--
--   apply : {a : Set} -> {f : a -> Set} -> Pi f -> (x : a) -> f x
--   apply (pi f) x = f x

  T : Bool -> Set
  T True  = Unit
  T False = Absurd

  andT : {x y : Bool} -> T x -> T y -> T (x && y)
  andT {True}  {True}  _  _ = unit
  andT {True}  {False} _  ()
  andT {False} {_}     () _

  T' : {a : Set} -> (a -> a -> Bool) -> (a -> a -> Set)
  T' f x y = T (f x y)

  data Not (a : Set) : Set where
    not : (a -> Absurd) -> Not a

  -- Not : Set -> Set
  -- Not a = a -> Absurd

  contrapositive : {a b : Set} -> (a -> b) -> Not b -> Not a
  contrapositive p (not nb) = not (\a -> nb (p a))

  private
    notDistribOut' : {a b : Set} -> Not a -> Not b -> Either a b -> Absurd
    notDistribOut' (not na) _        (left a)  = na a
    notDistribOut' _        (not nb) (right b) = nb b

  notDistribOut : {a b : Set} -> Not a -> Not b -> Not (Either a b)
  notDistribOut na nb = not (notDistribOut' na nb)

  notDistribIn : {a b : Set} -> Not (Either a b) -> Pair (Not a) (Not b)
  notDistribIn (not nab) = pair (not (\a -> nab (left a)))
                                (not (\b -> nab (right b)))

  data _<->_ (a b : Set) : Set where
    iff : (a -> b) -> (b -> a) -> a <-> b

  iffLeft : {a b : Set} -> (a <-> b) -> (a -> b)
  iffLeft (iff l _) = l

  iffRight : {a b : Set} -> (a <-> b) -> (b -> a)
  iffRight (iff _ r) = r

  Dec : (A : Set) -> Set
  Dec A = Either A (Not A)


module Utilities.VecSplit where

-- Standard libraries imports ----------------------------------------
open import Data.Nat using (ℕ ; _+_)
open import Data.Vec using (Vec ; _++_)

open import Relation.Binary.PropositionalEquality
  using (_≡_)
open import Relation.Binary.HeterogeneousEquality
  using (_≅_)
----------------------------------------------------------------------

record Split {A : Set} {n : ℕ} (xs : Vec A n) : Set where
  field
    {m₁} {m₂} : ℕ
    n≡m₁+m₂ : n ≡ m₁ + m₂
    ys : Vec A m₁
    zs : Vec A m₂
    xs≅ys++zs : xs ≅ ys ++ zs


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

module Cubical.HITs.InfNat.Properties where

open import Cubical.Core.Everything
open import Cubical.Data.Maybe
open import Cubical.Data.Nat

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

open import Cubical.HITs.InfNat.Base
import Cubical.Data.InfNat as Coprod

ℕ+∞→Cℕ+∞ : ℕ+∞ → Coprod.ℕ+∞
ℕ+∞→Cℕ+∞ zero = Coprod.zero
ℕ+∞→Cℕ+∞ (suc n) = Coprod.suc (ℕ+∞→Cℕ+∞ n)
ℕ+∞→Cℕ+∞ ∞ = Coprod.∞
ℕ+∞→Cℕ+∞ (suc-inf i) = Coprod.∞

ℕ→ℕ+∞ : ℕ → ℕ+∞
ℕ→ℕ+∞ zero = zero
ℕ→ℕ+∞ (suc n) = suc (ℕ→ℕ+∞ n)

Cℕ+∞→ℕ+∞ : Coprod.ℕ+∞ → ℕ+∞
Cℕ+∞→ℕ+∞ Coprod.∞ = ∞
Cℕ+∞→ℕ+∞ (Coprod.fin n) = ℕ→ℕ+∞ n

ℕ→ℕ+∞→Cℕ+∞ : ∀ n → ℕ+∞→Cℕ+∞ (ℕ→ℕ+∞ n) ≡ Coprod.fin n
ℕ→ℕ+∞→Cℕ+∞ zero = refl
ℕ→ℕ+∞→Cℕ+∞ (suc n) = cong Coprod.suc (ℕ→ℕ+∞→Cℕ+∞ n)

Cℕ+∞→ℕ+∞→Cℕ+∞ : ∀ n → ℕ+∞→Cℕ+∞ (Cℕ+∞→ℕ+∞ n) ≡ n
Cℕ+∞→ℕ+∞→Cℕ+∞ Coprod.∞ = refl
Cℕ+∞→ℕ+∞→Cℕ+∞ (Coprod.fin n) = ℕ→ℕ+∞→Cℕ+∞ n

suc-hom : ∀ n → Cℕ+∞→ℕ+∞ (Coprod.suc n) ≡ suc (Cℕ+∞→ℕ+∞ n)
suc-hom Coprod.∞ = suc-inf
suc-hom (Coprod.fin x) = refl

ℕ+∞→Cℕ+∞→ℕ+∞ : ∀ n → Cℕ+∞→ℕ+∞ (ℕ+∞→Cℕ+∞ n) ≡ n
ℕ+∞→Cℕ+∞→ℕ+∞ zero = refl
ℕ+∞→Cℕ+∞→ℕ+∞ ∞ = refl
ℕ+∞→Cℕ+∞→ℕ+∞ (suc n) = suc-hom (ℕ+∞→Cℕ+∞ n) ∙ cong suc (ℕ+∞→Cℕ+∞→ℕ+∞ n)
ℕ+∞→Cℕ+∞→ℕ+∞ (suc-inf i) = lemma i
  where
  lemma : (λ i → ∞ ≡ suc-inf i) [ refl ≡ suc-inf ∙ refl ]
  lemma i j = hcomp (λ k → λ
    { (i = i0) → ∞
    ; (i = i1) → compPath-filler suc-inf refl k j
    ; (j = i0) → ∞
    ; (j = i1) → suc-inf i
    }) (suc-inf (i ∧ j))

open Iso

ℕ+∞⇔Cℕ+∞ : Iso ℕ+∞ Coprod.ℕ+∞
ℕ+∞⇔Cℕ+∞ .fun = ℕ+∞→Cℕ+∞
ℕ+∞⇔Cℕ+∞ .inv = Cℕ+∞→ℕ+∞
ℕ+∞⇔Cℕ+∞ .leftInv = ℕ+∞→Cℕ+∞→ℕ+∞
ℕ+∞⇔Cℕ+∞ .rightInv = Cℕ+∞→ℕ+∞→Cℕ+∞


------------------------------------------------------------------------
-- Types with decidable equality have unique identity proofs, and
-- related results
------------------------------------------------------------------------

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

-- The part up to "decidable⇒set" follows a proof by Michael Hedberg
-- ("A coherence theorem for Martin-Löf's type theory", JFP 1998).

open import Equality

module Equality.Decidable-UIP
  {reflexive} (eq : ∀ {a p} → Equality-with-J a p reflexive) where

open Derived-definitions-and-properties eq
open import Logical-equivalence using (module _⇔_)
open import H-level eq
open import Prelude

-- Weakly constant functions.

Constant : ∀ {a b} {A : Type a} {B : Type b} → (A → B) → Type (a ⊔ b)
Constant f = ∀ x y → f x ≡ f y

-- Left inverses.

_Left-inverse-of_ : ∀ {a b} {A : Type a} {B : Type b} →
                    (B → A) → (A → B) → Type a
g Left-inverse-of f = ∀ x → g (f x) ≡ x

abstract

  -- A set with a constant endofunction with a left inverse is a
  -- proposition.

  proposition : ∀ {a} {A : Type a} →
                (f : ∃ λ (f : A → A) → Constant f) →
                (∃ λ g → g Left-inverse-of (proj₁ f)) →
                Is-proposition A
  proposition (f , constant) (g , left-inverse) x y =
    x        ≡⟨ sym (left-inverse x) ⟩
    g (f x)  ≡⟨ cong g (constant x y) ⟩
    g (f y)  ≡⟨ left-inverse y ⟩∎
    y        ∎

  -- Endofunction families on _≡_ always have left inverses.

  left-inverse :
    ∀ {a} {A : Type a} (f : (x y : A) → x ≡ y → x ≡ y) →
    ∀ {x y} → ∃ λ g → g Left-inverse-of f x y
  left-inverse {A = A} f {x} {y} =
    (λ x≡y →
       x  ≡⟨ x≡y ⟩
       y  ≡⟨ sym (f y y (refl y)) ⟩∎
       y  ∎) ,
    elim (λ {x y} x≡y → trans (f x y x≡y) (sym (f y y (refl y))) ≡ x≡y)
         (λ _ → trans-symʳ _)

  -- A type A is a set if there is a family of constant endofunctions
  -- on _≡_ {A = A}.

  constant⇒set :
    ∀ {a} {A : Type a} →
    ((x y : A) → ∃ λ (f : x ≡ y → x ≡ y) → Constant f) →
    Is-set A
  constant⇒set constant {x} {y} =
    proposition (constant x y)
                (left-inverse (λ x y → proj₁ $ constant x y))

  -- If it is known whether or not a type is inhabited, then one can
  -- define a constant endofunction for that type.

  decidable⇒constant : ∀ {a} {A : Type a} → Dec A →
                       ∃ λ (f : A → A) → Constant f
  decidable⇒constant (yes x) = (const x , λ _ _ → refl x)
  decidable⇒constant (no ¬x) = (id      , λ _ → ⊥-elim ∘ ¬x)

  -- Types with decidable equality are sets.

  decidable⇒set : ∀ {a} {A : Type a} → Decidable-equality A → Is-set A
  decidable⇒set dec =
    constant⇒set (λ x y → decidable⇒constant (dec x y))

  -- Non-dependent functions with propositional domains are constant.

  propositional-domain⇒constant :
    ∀ {a b} {A : Type a} {B : Type b} →
    Is-proposition A → (f : A → B) → Constant f
  propositional-domain⇒constant A-prop f = λ x y →
    cong f (A-prop x y)

  -- If there is a propositional, reflexive relation on A, and related
  -- elements are equal, then A is a set.
  --
  -- (The statement of this lemma is one part of the statement of
  -- Theorem 7.2.2 in "Homotopy Type Theory: Univalent Foundations of
  -- Mathematics" (first edition).)

  propositional-identity⇒set :
    ∀ {a b} {A : Type a}
    (B : A → A → Type b) →
    (∀ x y → Is-proposition (B x y)) →
    (∀ x → B x x) →
    (∀ x y → B x y → x ≡ y) →
    Is-set A
  propositional-identity⇒set B B-prop B-refl f =
    constant⇒set λ x y →
      (λ eq → f x y (subst (B x) eq (B-refl x))) ,
      (λ _ _ → propositional-domain⇒constant (B-prop x y) (f x y) _ _)

  -- The function cong {x = x} {y = y} takes (weakly) constant
  -- functions to constant functions.
  --
  -- This is Lemma 3.1 from van Doorn's "Constructing the
  -- Propositional Truncation using Non-recursive HITs".

  cong-preserves-Constant :
    ∀ {a b} {A : Type a} {B : Type b} {f : A → B} {x y : A} →
    Constant f → Constant (cong {x = x} {y = y} f)
  cong-preserves-Constant {f = f} {x = x} {y = y} c p q =
    cong f p                     ≡⟨ lemma p ⟩
    trans (sym (c x x)) (c x y)  ≡⟨ sym (lemma q) ⟩∎
    cong f q                     ∎
    where
    lemma : ∀ p → cong {x = x} {y = y} f p ≡ trans (sym (c x x)) (c x y)
    lemma = elim
      (λ {x y} p → cong {x = x} {y = y} f p ≡ trans (sym (c x x)) (c x y))
      (λ x →
         cong f (refl x)              ≡⟨ cong-refl _ ⟩
         refl (f x)                   ≡⟨ sym $ trans-symˡ _ ⟩∎
         trans (sym (c x x)) (c x x)  ∎)

  -- The following two results come from "Generalizations of Hedberg's
  -- Theorem" by Kraus, Escardó, Coquand and Altenkirch.

  -- Proposition 3.
  --
  -- (I proved this result using cong-preserves-Constant.)

  cong-constant :
    ∀ {a b} {A : Type a} {B : Type b} {f : A → B} {x} {x≡x : x ≡ x} →
    Constant f →
    cong f x≡x ≡ refl (f x)
  cong-constant {f = f} {x} {x≡x} c =
    cong f x≡x       ≡⟨ cong-preserves-Constant c _ _ ⟩
    cong f (refl x)  ≡⟨ cong-refl _ ⟩∎
    refl (f x)       ∎

  -- The "Fixed Point Lemma".

  fixpoint-lemma :
    ∀ {a} {A : Type a} →
    (f : A → A) →
    Constant f →
    Is-proposition (∃ λ x → f x ≡ x)
  fixpoint-lemma f constant (x , fx≡x) (y , fy≡y) =
      let x≡y = x    ≡⟨ sym fx≡x ⟩
                f x  ≡⟨ constant x y ⟩
                f y  ≡⟨ fy≡y ⟩∎
                y    ∎

          x≡x = x    ≡⟨ sym fx≡x ⟩
                f x  ≡⟨ subst (λ z → f z ≡ z) (sym x≡y) fy≡y ⟩∎
                x    ∎

          lemma =
            subst (λ z → f z ≡ z) x≡x fx≡x                       ≡⟨ subst-in-terms-of-trans-and-cong ⟩

            trans (sym (cong f x≡x)) (trans fx≡x (cong id x≡x))  ≡⟨ cong₂ (λ p q → trans (sym p) (trans _ q))
                                                                          (cong-constant constant) (sym $ cong-id _) ⟩
            trans (sym (refl (f x))) (trans fx≡x x≡x)            ≡⟨ cong (λ p → trans p (trans fx≡x x≡x)) sym-refl ⟩

            trans (refl (f x)) (trans fx≡x x≡x)                  ≡⟨ trans-reflˡ _ ⟩

            trans fx≡x x≡x                                       ≡⟨ sym $ trans-assoc _ _ _ ⟩

            trans (trans fx≡x (sym fx≡x))
                  (subst (λ z → f z ≡ z) (sym x≡y) fy≡y)         ≡⟨ cong (λ p → trans p (subst (λ z → f z ≡ z) (sym x≡y) fy≡y)) $
                                                                      trans-symʳ _ ⟩
            trans (refl (f x))
                  (subst (λ z → f z ≡ z) (sym x≡y) fy≡y)         ≡⟨ trans-reflˡ _ ⟩∎

            subst (λ z → f z ≡ z) (sym x≡y) fy≡y                 ∎
      in
      x , fx≡x                                  ≡⟨ Σ-≡,≡→≡ x≡x lemma ⟩
      x , subst (λ z → f z ≡ z) (sym x≡y) fy≡y  ≡⟨ sym $ Σ-≡,≡→≡ (sym x≡y) (refl _) ⟩∎
      y , fy≡y                                  ∎


module PatternSynonyms where

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

{-# BUILTIN NATURAL ℕ #-}
{-# BUILTIN ZERO zero #-}
{-# BUILTIN SUC suc #-}

pattern z    = zero
pattern sz   = suc z
pattern ss x = suc (suc x)

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

test : z ≡ zero
test = refl

test′ : sz ≡ suc zero
test′ = refl

test″ : ss z ≡ suc (suc zero)
test″ = refl

test‴ : ss ≡ λ x → suc (suc x)
test‴ = refl

f : ℕ → ℕ
f z            = zero
f sz           = suc z
f (ss 0)       = 2
f (ss (suc n)) = n

test-f : f zero ≡ zero
test-f = refl

test-f′ : f (suc zero) ≡ suc zero
test-f′ = refl

test-f″ : f (suc (suc 0)) ≡ 2
test-f″ = refl

test-f‴ : ∀ {n} → f (suc (suc (suc n))) ≡ n
test-f‴ = refl

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

data L (A : Set) : Set where
  nil  : L A
  cons : A → L A → L A

pattern cc x y xs = cons x (cons y xs)

test-cc : ∀ {A} → cc ≡ λ (x : A) y xs → cons x (cons y xs)
test-cc = refl

crazyLength : ∀ {A} → L A → ℕ
crazyLength nil          = 0
crazyLength (cons x nil) = 1
crazyLength (cc x y xs)  = 9000

swap : ∀ {A} → L A → L A
swap nil          = nil
swap (cons x nil) = cons x nil
swap (cc x y xs)  = cc y x xs

test-swap : ∀ {xs} → swap (cons 1 (cons 2 xs)) ≡ cons 2 (cons 1 xs)
test-swap = refl

------------------------------------------------------------------------
-- refl and _

record ⊤ : Set where
  constructor tt

data _⊎_ (A B : Set) : Set where
  inj₁ : (x : A) → A ⊎ B
  inj₂ : (y : B) → A ⊎ B

infixr 4 _,_
record Σ (A : Set)(B : A → Set) : Set where
  constructor _,_
  field
    proj₁ : A
    proj₂ : B proj₁

open Σ

_×_ : (A B : Set) → Set
A × B = Σ A λ _ → B

infixr 5 _+_
infixr 6 _*_

data Sig (O : Set) : Set₁ where
  ε ψ     : Sig O
  ρ       : (o : O) → Sig O
  ι       : (o : O) → Sig O
  _+_ _*_ : (Σ Σ′ : Sig O) → Sig O
  σ π     : (A : Set)(φ : A → Sig O) → Sig O

⟦_⟧ : ∀ {O} → Sig O → (Set → (O → Set) → (O → Set))
⟦ ε      ⟧ P R o = ⊤
⟦ ψ      ⟧ P R o = P
⟦ ρ o′   ⟧ P R o = R o′
⟦ ι o′   ⟧ P R o = o ≡ o′
⟦ Σ + Σ′ ⟧ P R o = ⟦ Σ ⟧ P R o ⊎ ⟦ Σ′ ⟧ P R o
⟦ Σ * Σ′ ⟧ P R o = ⟦ Σ ⟧ P R o × ⟦ Σ′ ⟧ P R o
⟦ σ A φ  ⟧ P R o = Σ A λ x → ⟦ φ x ⟧ P R o
⟦ π A φ  ⟧ P R o = (x : A) → ⟦ φ x ⟧ P R o

′List : Sig ⊤
′List = ε + ψ * ρ _

data μ {O}(Σ : Sig O)(P : Set)(o : O) : Set where
  ⟨_⟩ : ⟦ Σ ⟧ P (μ Σ P) o → μ Σ P o

List : Set → Set
List A = μ ′List A _

infixr 5 _∷_
pattern []       = ⟨ inj₁ _ ⟩
pattern _∷_ x xs = ⟨ inj₂ (x , xs) ⟩

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

test-list : List ℕ
test-list = 1 ∷ 2 ∷ []

test-length : length test-list ≡ 2
test-length = refl

′Vec : Sig ℕ
′Vec = ι 0
     + σ ℕ λ m → ψ * ρ m * ι (suc m)

Vec : Set → ℕ → Set
Vec A n = μ ′Vec A n

pattern []V     = ⟨ inj₁ refl ⟩
pattern _∷V_ x xs = ⟨ inj₂ (_ , x , xs , refl) ⟩

nilV : ∀ {A} → Vec A zero
nilV = []V

consV : ∀ {A n} → A → Vec A n → Vec A (suc n)
consV x xs = x ∷V xs

lengthV : ∀ {A n} → Vec A n → ℕ
lengthV []V       = 0
lengthV (x ∷V xs) = suc (lengthV xs)

test-lengthV : lengthV (consV 1 (consV 2 (consV 3 nilV))) ≡ 3
test-lengthV = refl

------------------------------------------------------------------------
-- .-patterns

pattern zr          = (.zero , refl)
pattern underscore² = _ , _

dot : (p : Σ ℕ λ n → n ≡ zero) → ⊤ × ⊤
dot zr = underscore²

------------------------------------------------------------------------
-- Implicit arguments

{-
pattern hiddenUnit = {_} -- XXX: We get lhs error msgs, can we refine
                         -- that?

imp : {p : ⊤} → ⊤
imp hiddenUnit = _
-}

data Box (A : Set) : Set where
  box : {x : A} → Box A

pattern [_] y = box {x = y}

b : Box ℕ
b = [ 1 ]

test-box : b ≡ box {x = 1}
test-box = refl

------------------------------------------------------------------------
-- Anonymous λs

g : ℕ → ℕ
g = λ { z → z
      ; sz → sz
      ; (ss n) → n
      }

test-g : g zero ≡ zero
test-g = refl

test-g′ : g sz ≡ suc zero
test-g′ = refl

test-g″ : ∀ {n} → g (suc (suc n)) ≡ n
test-g″ = refl

------------------------------------------------------------------------
-- λs

postulate
  X Y : Set
  h   : X → Y

p : (x : X)(y : Y) → h x ≡ y → ⊤
p x .((λ x → x) (h x)) refl = _

pattern app x = x , .((λ x → x) (h x))

p′ : (p : X × Y) → h (proj₁ p) ≡ proj₂ p → ⊤
p′ (app x) refl = _

------------------------------------------------------------------------
-- records

record Rec : Set where
  constructor rr
  field
    r : ℕ

rrr : (x : Rec) → x ≡ record { r = 0 } → ⊤
rrr .(record { r = 0}) refl = _

rrr′ : (x : Rec) → x ≡ record { r = 0 } → ⊤
rrr′ .(rr 0) refl = _

rrrr : (a : Rec × ℕ) → proj₁ a ≡ record { r = proj₂ a } → ⊤
rrrr (.(rr 0)       , 0)     refl = _
rrrr (.(rr (suc n)) , suc n) refl = _

pattern pair x = (.(record { r = x }) , x)

rrrr′ : (a : Rec × ℕ) → proj₁ a ≡ record { r = proj₂ a } → ⊤
rrrr′ (pair 0)       refl = _
rrrr′ (pair (suc n)) refl = _

------------------------------------------------------------------------
-- lets

pp : (x : X)(y : Y) → h x ≡ y → ⊤
pp x .(let i = (λ x → x) in i (h x)) refl = _

pattern llet x = x , .(let i = (λ x → x) in i (h x))

pp′ : (p : X × Y) → h (proj₁ p) ≡ proj₂ p → ⊤
pp′ (llet x) refl = _

------------------------------------------------------------------------
-- absurd patterns

pattern absurd = ()

data ⊥ : Set where

⊥-elim : ∀ {A : Set} → ⊥ → A
⊥-elim absurd

------------------------------------------------------------------------
-- ambiguous constructors

data ℕ2 : Set where
  zero : ℕ2
  suc  : ℕ2 -> ℕ2

-- This needs a type signature, because it is ambiguous:
amb : ℕ2
amb = suc (suc zero)

-- This isn't ambiguous, because the overloading is resolved when the
-- pattern synonym is scope-checked:
unamb = ss z

------------------------------------------------------------------------
-- underscore

pattern trivial = ._

trivf : (a : ⊤) -> a ≡ tt -> ⊤
trivf trivial refl = trivial

------------------------------------------------------------------------
-- let open

pattern nuts = .(let open Σ in z)

foo : (n : ℕ) -> n ≡ z -> ℕ
foo nuts refl = nuts

------------------------------------------------------------------------
-- pattern synonym inside unparamterised module

module M where
  pattern sss x = suc (suc (suc x))

  a : ℕ
  a = sss 2

mb : ℕ
mb = M.sss 0

mf : ℕ -> ℕ -> ℕ
mf (M.sss _) = M.sss
mf _         = \ _ -> 0

{-
module M (A : Set)(a : A) where
  pattern peep x = x , .a

  pop : (z : A × A) -> proj₂ z ≡ a -> ⊤
  pop (peep x) refl = _

  peep' = peep

pop' : (z : ⊤ × ⊤) -> proj₂ z ≡ tt -> ⊤
pop' (M.peep tt) refl = _

peep' = M.peep
-}


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

module Bundles where

open import Algebra.Core
open import Quasigroup.Structures
open import Relation.Binary
open import Level
open import Algebra.Bundles
open import Algebra.Structures
open import Structures

record InverseSemigroup c ℓ : Set (suc (c ⊔ ℓ)) where
  infixl 7 _∙_
  infix  4 _≈_
  field
    Carrier            : Set c
    _≈_                : Rel Carrier ℓ
    _∙_                : Op₂ Carrier
    isInverseSemigroup : IsInverseSemigroup _≈_ _∙_

  open IsInverseSemigroup isInverseSemigroup public

  magma : Magma c ℓ
  magma = record { isMagma = isMagma }

  open Magma magma public
    using (_≉_; rawMagma)

record Rng c ℓ : Set (suc (c ⊔ ℓ)) where
  infix  8 -_
  infixl 7 _*_
  infixl 6 _+_
  infix  4 _≈_
  field
    Carrier : Set c
    _≈_     : Rel Carrier ℓ
    _+_     : Op₂ Carrier
    _*_     : Op₂ Carrier
    -_      : Op₁ Carrier
    0#      : Carrier
    isRng  : IsRng _≈_ _+_ _*_ -_ 0#

  open IsRng isRng public

  +-abelianGroup : AbelianGroup _ _
  +-abelianGroup = record { isAbelianGroup = +-isAbelianGroup }

  *-semigroup : Semigroup _ _
  *-semigroup = record { isSemigroup = *-isSemigroup }

  open AbelianGroup +-abelianGroup public
    using () renaming (group to +-group; invertibleMagma to +-invertibleMagma; invertibleUnitalMagma to +-invertibleUnitalMagma)

  open Semigroup *-semigroup public
    using () renaming
    ( rawMagma to *-rawMagma
    ; magma    to *-magma
    )

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

  open IsNonAssociativeRing isNonAssociativeRing public

  +-abelianGroup : AbelianGroup _ _
  +-abelianGroup = record { isAbelianGroup = +-isAbelianGroup }

  *-unitalmagma : UnitalMagma _ _
  *-unitalmagma = record { isUnitalMagma = *-isUnitalMagma }

  open AbelianGroup +-abelianGroup public
    using () renaming (group to +-group; invertibleMagma to +-invertibleMagma; invertibleUnitalMagma to +-invertibleUnitalMagma)

  open UnitalMagma *-unitalmagma public
    using () renaming
    ( rawMagma to *-rawMagma
    ; magma    to *-magma
    )


module Rationals.Add.Comm where

open import Equality
open import Function

open import Nats using (zero; ℕ)
                 renaming (suc to s; _+_ to _:+:_; _*_ to _:*:_)
open import Rationals
open import Rationals.Properties
open import Nats.Add.Comm
open import Nats.Multiply.Distrib
open import Nats.Multiply.Comm

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

private

  a/c+b/c=a*b/c : ∀ a b c → a ÷ c + b ÷ c ≡ (a :+: b) ÷ c
  a/c+b/c=a*b/c a b c
    rewrite (a :+: b) ÷ c ↑ c
          | sym $ nat-multiply-distrib a b c
            = refl

  a+b=b+a : ∀ x y → x + y ≡ y + x
  a+b=b+a (a ÷ c) (b ÷ d)
    rewrite a ÷ c ↑ d
          | b ÷ d ↑ c
          | a/c+b/c=a*b/c (a :*: d) (b :*: c) $ d :*: c
          | nat-add-comm (a :*: d) $ b :*: c
          | nat-multiply-comm c d
            = refl

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

rational-add-comm : ∀ x y → x + y ≡ y + x
rational-add-comm = a+b=b+a


------------------------------------------------------------------------
-- The Agda standard library
--
-- Bisimilarity for Colists
------------------------------------------------------------------------

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

module Codata.Colist.Bisimilarity where

open import Level using (_⊔_)
open import Size
open import Codata.Thunk
open import Codata.Colist
open import Relation.Binary
open import Relation.Binary.PropositionalEquality as Eq using (_≡_)

data Bisim {a b r} {A : Set a} {B : Set b} (R : A → B → Set r) (i : Size) :
           (xs : Colist A ∞) (ys : Colist B ∞) → Set (r ⊔ a ⊔ b) where
  []  : Bisim R i [] []
  _∷_ : ∀ {x y xs ys} → R x y → Thunk^R (Bisim R) i xs ys → Bisim R i (x ∷ xs) (y ∷ ys)

module _ {a r} {A : Set a} {R : A → A → Set r} where

 reflexive : Reflexive R → ∀ {i} → Reflexive (Bisim R i)
 reflexive refl^R {i} {[]}     = []
 reflexive refl^R {i} {r ∷ rs} = refl^R ∷ λ where .force → reflexive refl^R

module _ {a b} {A : Set a} {B : Set b}
         {r} {P : A → B → Set r} {Q : B → A → Set r} where

 symmetric : Sym P Q → ∀ {i} → Sym (Bisim P i) (Bisim Q i)
 symmetric sym^PQ []       = []
 symmetric sym^PQ (p ∷ ps) = sym^PQ p ∷ λ where .force → symmetric sym^PQ (ps .force)

module _ {a b c} {A : Set a} {B : Set b} {C : Set c}
         {r} {P : A → B → Set r} {Q : B → C → Set r} {R : A → C → Set r} where

 transitive : Trans P Q R → ∀ {i} → Trans (Bisim P i) (Bisim Q i) (Bisim R i)
 transitive trans^PQR []       []       = []
 transitive trans^PQR (p ∷ ps) (q ∷ qs) =
   trans^PQR p q ∷ λ where .force → transitive trans^PQR (ps .force) (qs .force)

-- Pointwise Equality as a Bisimilarity
------------------------------------------------------------------------

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

 infix 1 _⊢_≈_
 _⊢_≈_ : ∀ i → Colist A ∞ → Colist A ∞ → Set ℓ
 _⊢_≈_ = Bisim _≡_

 refl : ∀ {i} → Reflexive (i ⊢_≈_)
 refl = reflexive Eq.refl

 sym : ∀ {i} → Symmetric (i ⊢_≈_)
 sym = symmetric Eq.sym

 trans : ∀ {i} → Transitive (i ⊢_≈_)
 trans = transitive Eq.trans


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

-- A variety of Diagonal functors

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

open import Categories.Category
open import Categories.Functor
open import Categories.Category.Product
open import Categories.Category.Construction.Functors
open import Categories.Functor.Construction.Constant
open import Categories.NaturalTransformation using (ntHelper)

import Categories.Functor.Power as Power

private
  variable
    o ℓ e o′ ℓ′ e′ : Level

Δ : (C : Category o ℓ e) → Functor C (Product C C)
Δ C = record
  { F₀           = λ x → x , x
  ; F₁           = λ f → f , f
  ; identity     = refl , refl
  ; homomorphism = refl , refl
  ; F-resp-≈     = λ x → x , x
  }
  where
    open Category C
    open Equiv

Δ′ : (I : Set) → (C : Category o ℓ e) → Functor C (Power.Exp C I)
Δ′ I C = record
  { F₀           = λ x _ → x
  ; F₁           = λ f _ → f
  ; identity     = λ _ → refl
  ; homomorphism = λ _ → refl
  ; F-resp-≈     = λ x _ → x
  }
  where open Category.Equiv C

ΔF : {C : Category o ℓ e} (I : Category o′ ℓ′ e′) → Functor C (Functors I C)
ΔF {C = C} I = record
  { F₀           = const
  ; F₁           = λ f → ntHelper record { η = λ _ → f; commute = λ _ → C.identityʳ ○ ⟺ C.identityˡ }
  ; identity     = refl
  ; homomorphism = refl
  ; F-resp-≈     = λ x → x
  }
 where
   module C = Category C
   open C.Equiv
   open C.HomReasoning using (_○_; ⟺)


module Test2 where
   open import MiniHoTT

   A : Set
   A = ℕ

--  a, b : A

  {-
   [ a, b ] : List A
   [ a, b ] := inr ( a , ?)
    -- inr ((a, inr ( b, inl(unit))
    -}

   T : {A : Set} → (X : Set) → Set
   T {A} X = 𝟙 lzero + A × X -- This is an example of a polynomial functor.

   data
     List (A : Set)
      : Set
     where
     [] : List A
     cons : A → List A → List A

   data Vec (A : Set) : ℕ → Set
    where
    nil : ∀ n → Vec A n
    cons : ∀ n → A → Vec A n → Vec A (succ n)

   data Fin : ℕ →  Set
    where
    cero : ∀ {n} → Fin n
    succ : ∀ {n} → Fin n → Fin (succ n)

   at : ∀ {n : ℕ} {A : Set}
    → Vec A (succ n)
    → Fin (succ n)
    → A
   at v n = {!   !}

   go' : ∀ {n} {A : Set}
    → (Fin 0n → A) → Fin n → Vec A n
   go' pick cero     = nil _
   go' pick (succ n) = cons {!   !} (pick {! n  !})
    (go' {! pick    !} {!   !})

   record
     Algebra
      (A : Set)
      (T : Set → Set)
      : Set (lsuc lzero)
     where
     constructor algebra
     field
      X : Set
      μ : T X → X

   -- Objects: (X, μ)
   -- morphisms f : (X, μ) --> (Y, ν)
   --   this is given by α : X → Y, that makes the diagram commutes.
   -- Initial object: Object  (X, μ) + initiallity condition:
   --   Any other (Y, ν), there exists unique α : X → Y such that...

   list-is-an-algebra : (A : Set) → Algebra A (λ X → 𝟙 lzero + A × X)
   list-is-an-algebra A =
    algebra (List A) λ { (inl x) → []
                       ; (inr (a , xs)) → cons a xs
                       }

   -- where (T X -> X) is the type of list with elements of type A.
   -- elements? is TA a set?
   -- Yes, assuming A is a set. Let's find that.

   list-of-nats-is-set
     : A is-set
     → isSet (T A)
   list-of-nats-is-set A-is-set
    = +-set
        (prop-is-set 𝟙-is-prop)
        (∑-set
          A-is-set
          λ _ → A-is-set)

  -- T(X) = 1+X + (X ×X) a


------------------------------------------------------------------------
-- The Agda standard library
--
-- Basic definitions for morphisms between algebraic structures
------------------------------------------------------------------------

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

open import Relation.Binary.Core

module Algebra.Morphism.Definitions
  {a} (A : Set a)     -- The domain of the morphism
  {b} (B : Set b)     -- The codomain of the morphism
  {ℓ} (_≈_ : Rel B ℓ)  -- The equality relation over the codomain
  where

open import Algebra.Core
open import Function.Core

------------------------------------------------------------------------
-- Basic definitions

Homomorphic₀ : (A → B) → A → B → Set _
Homomorphic₀ ⟦_⟧ ∙ ∘ = ⟦ ∙ ⟧ ≈ ∘

Homomorphic₁ : (A → B) → Op₁ A → Op₁ B → Set _
Homomorphic₁ ⟦_⟧ ∙_ ∘_ = ∀ x → ⟦ ∙ x ⟧ ≈ (∘ ⟦ x ⟧)

Homomorphic₂ : (A → B) → Op₂ A → Op₂ B → Set _
Homomorphic₂ ⟦_⟧ _∙_ _∘_ = ∀ x y → ⟦ x ∙ y ⟧ ≈ (⟦ x ⟧ ∘ ⟦ y ⟧)

------------------------------------------------------------------------
-- DEPRECATED NAMES
------------------------------------------------------------------------
-- Please use the new names as continuing support for the old names is
-- not guaranteed.

-- Version 1.3

Morphism : Set _
Morphism = A → B

{-# WARNING_ON_USAGE Morphism
"Warning: Morphism was deprecated in v1.3.
Please use the standard function notation (e.g. A → B) instead."
#-}


-- Classical propositional logic, de Bruijn approach, initial encoding

module Bi.Cp where

open import Lib using (List; _,_; LMem; lzero; lsuc)

-- Types

infixl 2 _&&_
infixl 1 _||_
infixr 0 _=>_
data Ty : Set where
  UNIT  :             Ty
  _=>_  : Ty -> Ty -> Ty
  _&&_  : Ty -> Ty -> Ty
  _||_  : Ty -> Ty -> Ty
  FALSE :             Ty

infixr 0 _<=>_
_<=>_ : Ty -> Ty -> Ty
a <=> b = (a => b) && (b => a)

NOT : Ty -> Ty
NOT a = a => FALSE

TRUE : Ty
TRUE = FALSE => FALSE

-- Context and truth judgement

Cx : Set
Cx = List Ty

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

-- Terms

module Cp where
  infixl 1 _$_
  infixr 0 lam=>_
  infixr 0 abort=>_
  data Tm (tc : Cx) : Ty -> Set where
    var      : forall {a}     -> isTrue a tc               -> Tm tc a
    lam=>_   : forall {a b}   -> Tm (tc , a) b             -> Tm tc (a => b)
    _$_      : forall {a b}   -> Tm tc (a => b) -> Tm tc a -> Tm tc b
    pair'    : forall {a b}   -> Tm tc a        -> Tm tc b -> Tm tc (a && b)
    fst      : forall {a b}   -> Tm tc (a && b)            -> Tm tc a
    snd      : forall {a b}   -> Tm tc (a && b)            -> Tm tc b
    left     : forall {a b}   -> Tm tc a                   -> Tm tc (a || b)
    right    : forall {a b}   -> Tm tc b                   -> Tm tc (a || b)
    case'    : forall {a b c} -> Tm tc (a || b) -> Tm (tc , a) c -> Tm (tc , b) c -> Tm tc c
    abort=>_ : forall {a}     -> Tm (tc , NOT a) FALSE     -> Tm tc a

  syntax pair' x y    = [ x , y ]
  syntax case' xy x y = case xy => x => y

  v0 : forall {tc a} -> Tm (tc , a) a
  v0 = var lzero

  v1 : forall {tc a b} -> Tm (tc , a , b) a
  v1 = var (lsuc lzero)

  v2 : forall {tc a b c} -> Tm (tc , a , b , c) a
  v2 = var (lsuc (lsuc lzero))

  Thm : Ty -> Set
  Thm a = forall {tc} -> Tm tc a
open Cp public


module Type.Identity.Proofs where

import      Lvl
open import Structure.Function
open import Structure.Relator.Properties
open import Structure.Relator
open import Structure.Type.Identity
open import Type.Identity
open import Type

private variable ℓ ℓ₁ ℓ₂ ℓₑ ℓₑ₁ ℓₑ₂ ℓₚ : Lvl.Level
private variable T A B : Type{ℓ}
private variable P : T → Type{ℓ}
private variable _▫_ : A → B → Type{ℓ}

instance
  Id-reflexivity : Reflexivity(Id{T = T})
  Reflexivity.proof Id-reflexivity = intro

instance
  Id-identityEliminator : IdentityEliminator{ℓₚ = ℓₚ}(Id{T = T})
  IdentityEliminator.elim Id-identityEliminator = elim

instance
  Id-identityEliminationOfIntro : IdentityEliminationOfIntro{ℓₘ = ℓ}(Id{T = T})(Id)
  IdentityEliminationOfIntro.proof Id-identityEliminationOfIntro P p = intro

instance
  Id-identityType : IdentityType(Id)
  Id-identityType = intro

{-
open import Logic.Propositional
open import Logic.Propositional.Equiv
open import Relator.Equals.Proofs
open import Structure.Setoid

te : ⦃ equiv-A : Equiv{ℓₑ}(A)⦄ → ∀{f : A → Type{ℓ}} → Function ⦃ equiv-A ⦄ ⦃ [↔]-equiv ⦄ (f)

test : ⦃ equiv-A : Equiv{ℓₑ}(A)⦄ → ∀{P : A → Type{ℓ}} → UnaryRelator ⦃ equiv-A ⦄ (P)
UnaryRelator.substitution test eq p = [↔]-to-[→] (Function.congruence te eq) p
-}


module Oscar.Class.TermSubstitution.Internal {𝔣} (FunctionName : Set 𝔣) where

open import Oscar.Data.Term.Core FunctionName
open import Oscar.Data.Nat.Core
open import Oscar.Data.Fin.Core
open import Oscar.Data.Vec.Core
open import Oscar.Data.Equality.Core
open import Oscar.Data.Product.Core
open import Oscar.Function
open import Oscar.Level

_⊸_ : (m n : ℕ) → Set 𝔣
m ⊸ n = Fin m → Term n

⊸-Property : {ℓ : Level} → ℕ → Set (lsuc ℓ ⊔ 𝔣)
⊸-Property {ℓ} m = ∀ {n} → m ⊸ n → Set ℓ

_≐_ : {m n : ℕ} → m ⊸ n → m ⊸ n → Set 𝔣
f ≐ g = ∀ x → f x ≡ g x

⊸-Extensional : {ℓ : Level} {m : ℕ} → ⊸-Property {ℓ} m → Set (ℓ ⊔ 𝔣)
⊸-Extensional P = ∀ {m f g} → f ≐ g → P {m} f → P g

⊸-ExtentionalProperty : {ℓ : Level} → ℕ → Set (lsuc ℓ ⊔ 𝔣)
⊸-ExtentionalProperty {ℓ} m = Σ (⊸-Property {ℓ} m) ⊸-Extensional

mutual

  _◃Term_ : ∀ {m n} → (f : m ⊸ n) → Term m → Term n
  f ◃Term i x = f x
  f ◃Term leaf = leaf
  f ◃Term (s fork t) = (f ◃Term s) fork (f ◃Term t)
  f ◃Term (function fn ts) = function fn (f ◃VecTerm ts) where

  _◃VecTerm_ : ∀ {N m n} → m ⊸ n → Vec (Term m) N → Vec (Term n) N
  f ◃VecTerm [] = []
  f ◃VecTerm (t ∷ ts) = f ◃Term t ∷ f ◃VecTerm ts

_◇_ : ∀ {l m n} → m ⊸ n → l ⊸ m → l ⊸ n
_◇_ f g = (f ◃Term_) ∘ g

record Substitution {a} (A : ℕ → Set a) : Set (a ⊔ 𝔣) where
  field
    _◃_ : ∀ {m n} → m ⊸ n → A m → A n
    ◃-extentionality : ∀ {m n} {f g : m ⊸ n} → f ≐ g → (t : A m) → f ◃ t ≡ g ◃ t
    ◃-identity : ∀ {n} → (t : A n) → i ◃ t ≡ t

  field
    ◃-associativity : ∀ {l m n} → {f : m ⊸ n} {g : _} (t : A l) → (f ◇ g) ◃ t ≡ f ◃ (g ◃ t)

  ⊸-Unifies : ∀ {m} (s t : A m) → ⊸-Property m
  ⊸-Unifies s t f = f ◃ s ≡ f ◃ t

open Substitution ⦃ … ⦄ public

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


module Data.Rational where

import Data.Bool as Bool
import Data.Nat as Nat
import Data.Integer as Int

open Int renaming
            ( _*_  to _*'_
            ; _+_  to _+'_
            ; -_   to -'_
            ; _-_  to _-'_
            ; !_!  to !_!'
            ; _==_ to _=='_
            ; _≤_  to _≤'_
            ; _≥_  to _≥'_
            ; _>_  to _>'_
            ; _<_  to _<'_
            )
open Nat using (Nat; zero; suc)
open Bool

infix  40 _==_ _<_ _>_ _≤_ _≥_
infixl 60 _+_ _-_
infixl 70 _%'_ _%_ _/_ _*_
infixr 80 _^_
infix  90 -_

data Rational : Set where
  _%'_  : Int -> Int -> Rational

numerator : Rational -> Int
numerator (n %' d) = n

denominator : Rational -> Int
denominator (n %' d) = d

_%_ : Int -> Int -> Rational
neg n       % neg m = pos (suc n) % pos (suc m)
pos 0       % neg m = pos 0 %' pos 1
pos (suc n) % neg m = neg n % pos (suc m)
x           % y     = div x z %' div y z
  where
    z = gcd x y

fromInt : Int -> Rational
fromInt x = x %' pos 1

fromNat : Nat -> Rational
fromNat x = fromInt (pos x)

_+_ : Rational -> Rational -> Rational
(a %' b) + (c %' d) = (a *' d +' c *' b) % (b *' d)

-_ : Rational -> Rational
- (a %' b) = -' a %' b

_-_ : Rational -> Rational -> Rational
a - b = a + (- b)

_/_ : Rational -> Rational -> Rational
(a %' b) / (c %' d) = (a *' d) % (b *' c)

_*_ : Rational -> Rational -> Rational
(a %' b) * (c %' d) = (a *' c) % (b *' d)

recip : Rational -> Rational
recip (a %' b) = b %' a

_^_ : Rational -> Int -> Rational
q ^ neg n       = recip q ^ pos (suc n)
q ^ pos zero    = fromNat 1
q ^ pos (suc n) = q * q ^ pos n

!_! : Rational -> Rational
! a %' b ! = pos ! a !' %' pos ! b !'

round : Rational -> Int
round (a %' b) = div (a +' div b (pos 2)) b

_==_ : Rational -> Rational -> Bool
(a %' b) == (c %' d) = a *' d ==' b *' c

_<_ : Rational -> Rational -> Bool
(a %' b) < (c %' d) = a *' d <' b *' c

_>_ : Rational -> Rational -> Bool
(a %' b) > (c %' d) = a *' d >' b *' c

_≤_ : Rational -> Rational -> Bool
(a %' b) ≤ (c %' d) = a *' d ≤' b *' c

_≥_ : Rational -> Rational -> Bool
(a %' b) ≥ (c %' d) = a *' d ≥' b *' c

max : Rational -> Rational -> Rational
max a b = if a < b then b else a

min : Rational -> Rational -> Rational
min a b = if a < b then a else b


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

module Data.Fin.Indexed.Base where

open import Data.Nat using (ℕ; suc; zero)
open import Agda.Builtin.Nat using (_<_)
open import Level
open import Data.Bool.Truth

private variable n m : ℕ

-- This is the more traditional definition of Fin,
-- that you would usually find in Agda code.
-- I tend to use the other one because cubical
-- Agda doesn't yet support transport along
-- equalities of indexed types.
data Fin : ℕ → Type where
  f0 : Fin (suc n)
  fs : Fin n → Fin (suc n)

FinToℕ : Fin n → ℕ
FinToℕ f0 = zero
FinToℕ (fs i) = suc (FinToℕ i)

{-# DISPLAY f0 = zero #-}
{-# DISPLAY fs n = suc n #-}

FinFromℕ : ∀ {m} → (n : ℕ) → T (n < m) → Fin m
FinFromℕ {m = suc m} zero    p = f0
FinFromℕ {m = suc m} (suc n) p = fs (FinFromℕ n p)


------------------------------------------------------------------------
-- The Agda standard library
--
-- Core definition of divisibility
------------------------------------------------------------------------

-- The definition of divisibility is split out from
-- `Data.Nat.Divisibility` to avoid a dependency cycle with
-- `Data.Nat.DivMod`.

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

module Data.Nat.Divisibility.Core where

open import Data.Nat.Base using (ℕ; _*_)
open import Data.Nat.Properties
open import Level using (0ℓ)
open import Relation.Nullary using (¬_)
open import Relation.Binary using (Rel)
open import Relation.Binary.PropositionalEquality
  using (_≡_; refl; sym)

------------------------------------------------------------------------
-- Definition
--
-- m ∣ n is inhabited iff m divides n. Some sources, like Hardy and
-- Wright's "An Introduction to the Theory of Numbers", require m to
-- be non-zero. However, some things become a bit nicer if m is
-- allowed to be zero. For instance, _∣_ becomes a partial order, and
-- the gcd of 0 and 0 becomes defined.

infix 4 _∣_ _∤_

record _∣_ (m n : ℕ) : Set where
  constructor divides
  field quotient : ℕ
        equality : n ≡ quotient * m
open _∣_ using (quotient) public

_∤_ : Rel ℕ 0ℓ
m ∤ n = ¬ (m ∣ n)


{-# OPTIONS --no-termination-check #-}

module Data.Bits where

import Prelude
import Logic.Base
import Data.List as List
import Data.Nat  as Nat
import Data.Bool as Bool

open Prelude
open Nat
open Bool
open List

Bit = Bool

shiftL : Nat -> Nat -> Nat
shiftL n i = n * 2 ^ i

sucBits : List Bit -> List Bit
sucBits []            = true :: []
sucBits (false :: xs) = true :: xs
sucBits (true  :: xs) = false :: sucBits xs

-- Least significant bit first. Last bit (when present) is always one.
toBits : Nat -> List Bit
toBits zero    = []
toBits (suc n) = sucBits (odd n :: toBits (div n 2))

fromBits : List Bit -> Nat
fromBits xs = foldr (\b n -> bitValue b + 2 * n) 0 xs
  where
    bitValue : Bit -> Nat
    bitValue b = if b then 1 else 0

nofBits : Nat -> Nat
nofBits = length ∘ toBits

module Proofs where

  open Logic.Base

--   fromBits∘toBits=id : (n : Nat) -> fromBits (toBits n) ≡ n
--   fromBits∘toBits=id  zero   = tt
--   fromBits∘toBits=id (suc n) = ?


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

module Categories.Category.Monoidal.Instance.Setoids where

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

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

module _ {o ℓ} where

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

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


------------------------------------------------------------------------
-- Groups
------------------------------------------------------------------------

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

open import Equality

module Group
  {e⁺} (eq : ∀ {a p} → Equality-with-J a p e⁺) where

open Derived-definitions-and-properties eq

open import Logical-equivalence using (_⇔_)
open import Prelude as P hiding (id; _∘_) renaming (_×_ to _⊗_)

import Bijection eq as B
open import Equivalence eq as Eq using (_≃_)
open import Function-universe eq as F hiding (id; _∘_)
open import Groupoid eq using (Groupoid)
open import H-level eq
open import H-level.Closure eq
open import Integer.Basics eq using (+_; -[1+_])
open import Univalence-axiom eq

private
  variable
    a g₁ g₂ : Level
    A       : Type a
    g x y   : A
    k       : Kind

------------------------------------------------------------------------
-- Groups

-- Groups.
--
-- Note that the carrier type is required to be a set (following the
-- HoTT book).

record Group g : Type (lsuc g) where
  infix  8 _⁻¹
  infixr 7 _∘_

  field
    Carrier        : Type g
    Carrier-is-set : Is-set Carrier
    _∘_            : Carrier → Carrier → Carrier
    id             : Carrier
    _⁻¹            : Carrier → Carrier
    left-identity  : ∀ x → (id ∘ x) ≡ x
    right-identity : ∀ x → (x ∘ id) ≡ x
    assoc          : ∀ x y z → (x ∘ (y ∘ z)) ≡ ((x ∘ y) ∘ z)
    left-inverse   : ∀ x → ((x ⁻¹) ∘ x) ≡ id
    right-inverse  : ∀ x → (x ∘ (x ⁻¹)) ≡ id

  -- Groups are groupoids.

  groupoid : Groupoid lzero g
  groupoid = record
    { Object         = ⊤
    ; _∼_            = λ _ _ → Carrier
    ; id             = id
    ; _∘_            = _∘_
    ; _⁻¹            = _⁻¹
    ; left-identity  = left-identity
    ; right-identity = right-identity
    ; assoc          = assoc
    ; left-inverse   = left-inverse
    ; right-inverse  = right-inverse
    }

  open Groupoid groupoid public
    hiding (Object; _∼_; id; _∘_; _⁻¹; left-identity; right-identity;
            assoc; left-inverse; right-inverse)

private
  variable
    G G₁ G₁′ G₂ G₂′ G₃ : Group g

-- The type of groups can be expressed using a nested Σ-type.

Group-as-Σ :
  Group g ≃
  ∃ λ (A : Set g) →
  let A = ⌞ A ⌟ in
  ∃ λ (_∘_ : A → A → A) →
  ∃ λ (id : A) →
  ∃ λ (_⁻¹ : A → A) →
    (∀ x → (id ∘ x) ≡ x) ⊗
    (∀ x → (x ∘ id) ≡ x) ⊗
    (∀ x y z → (x ∘ (y ∘ z)) ≡ ((x ∘ y) ∘ z)) ⊗
    (∀ x → ((x ⁻¹) ∘ x) ≡ id) ⊗
    (∀ x → (x ∘ (x ⁻¹)) ≡ id)
Group-as-Σ =
  Eq.↔→≃
    (λ G → let open Group G in
         (Carrier , Carrier-is-set)
       , _∘_
       , id
       , _⁻¹
       , left-identity
       , right-identity
       , assoc
       , left-inverse
       , right-inverse)
    _
    refl
    refl

------------------------------------------------------------------------
-- Group homomorphisms and isomorphisms

-- Group homomorphisms (generalised to several kinds of underlying
-- "functions").

record Homomorphic (k : Kind) (G₁ : Group g₁) (G₂ : Group g₂) :
                   Type (g₁ ⊔ g₂) where
  private
    module G₁ = Group G₁
    module G₂ = Group G₂

  field
    related : G₁.Carrier ↝[ k ] G₂.Carrier

  to : G₁.Carrier → G₂.Carrier
  to = to-implication related

  field
    homomorphic :
      ∀ x y → to (x G₁.∘ y) ≡ to x G₂.∘ to y

open Homomorphic public using (related; homomorphic)
open Homomorphic using (to)

-- The type of (generalised) group homomorphisms can be expressed
-- using a nested Σ-type.

Homomorphic-as-Σ :
  {G₁ : Group g₁} {G₂ : Group g₂} →
  Homomorphic k G₁ G₂ ≃
  let module G₁ = Group G₁
      module G₂ = Group G₂
  in
  ∃ λ (f : G₁.Carrier ↝[ k ] G₂.Carrier) →
    ∀ x y →
    to-implication f (x G₁.∘ y) ≡
    to-implication f x G₂.∘ to-implication f y
Homomorphic-as-Σ =
  Eq.↔→≃
    (λ G₁↝G₂ → G₁↝G₂ .related , G₁↝G₂ .homomorphic)
    _
    refl
    refl

-- A variant of Homomorphic.

infix 4 _↝[_]ᴳ_ _→ᴳ_ _≃ᴳ_

_↝[_]ᴳ_ : Group g₁ → Kind → Group g₂ → Type (g₁ ⊔ g₂)
_↝[_]ᴳ_ = flip Homomorphic

-- Group homomorphisms.

_→ᴳ_ : Group g₁ → Group g₂ → Type (g₁ ⊔ g₂)
_→ᴳ_ = _↝[ implication ]ᴳ_

-- Group isomorphisms.

_≃ᴳ_ : Group g₁ → Group g₂ → Type (g₁ ⊔ g₂)
_≃ᴳ_ = _↝[ equivalence ]ᴳ_

-- "Functions" of type G₁ ↝[ k ]ᴳ G₂ can be converted to group
-- homomorphisms.

↝ᴳ→→ᴳ : G₁ ↝[ k ]ᴳ G₂ → G₁ →ᴳ G₂
↝ᴳ→→ᴳ f .related     = to f
↝ᴳ→→ᴳ f .homomorphic = f .homomorphic

-- _↝[ k ]ᴳ_ is reflexive.

↝ᴳ-refl : G ↝[ k ]ᴳ G
↝ᴳ-refl                 .related         = F.id
↝ᴳ-refl {G = G} {k = k} .homomorphic x y =
  to-implication {k = k} F.id (x ∘ y)  ≡⟨ cong (_$ _) $ to-implication-id k ⟩

  x ∘ y                                ≡⟨ sym $ cong₂ (λ f g → f _ ∘ g _)
                                            (to-implication-id k)
                                            (to-implication-id k) ⟩∎
  to-implication {k = k} F.id x ∘
  to-implication {k = k} F.id y        ∎
  where
  open Group G

-- _↝[ k ]ᴳ_ is transitive.

↝ᴳ-trans : G₁ ↝[ k ]ᴳ G₂ → G₂ ↝[ k ]ᴳ G₃ → G₁ ↝[ k ]ᴳ G₃
↝ᴳ-trans {G₁ = G₁} {k = k} {G₂ = G₂} {G₃ = G₃}
  G₁↝G₂ G₂↝G₃ = λ where
    .related         → G₂↝G₃ .related F.∘ G₁↝G₂ .related
    .homomorphic x y →
      to-implication (G₂↝G₃ .related F.∘ G₁↝G₂ .related) (x G₁.∘ y)  ≡⟨ cong (_$ _) $ to-implication-∘ k ⟩

      to G₂↝G₃ (to G₁↝G₂ (x G₁.∘ y))                                 ≡⟨ cong (to G₂↝G₃) $ homomorphic G₁↝G₂ _ _ ⟩

      to G₂↝G₃ (to G₁↝G₂ x G₂.∘ to G₁↝G₂ y)                          ≡⟨ homomorphic G₂↝G₃ _ _ ⟩

      to G₂↝G₃ (to G₁↝G₂ x) G₃.∘ to G₂↝G₃ (to G₁↝G₂ y)               ≡⟨ sym $ cong₂ (λ f g → f _ G₃.∘ g _)
                                                                          (to-implication-∘ k)
                                                                          (to-implication-∘ k) ⟩∎
      to-implication (G₂↝G₃ .related F.∘ G₁↝G₂ .related) x G₃.∘
      to-implication (G₂↝G₃ .related F.∘ G₁↝G₂ .related) y           ∎
  where
  module G₁ = Group G₁
  module G₂ = Group G₂
  module G₃ = Group G₃

-- _≃ᴳ_ is symmetric.

≃ᴳ-sym : G₁ ≃ᴳ G₂ → G₂ ≃ᴳ G₁
≃ᴳ-sym {G₁ = G₁} {G₂ = G₂} G₁≃G₂ = λ where
    .related         → inverse (G₁≃G₂ .related)
    .homomorphic x y → _≃_.injective (G₁≃G₂ .related)
      (to G₁≃G₂ (_≃_.from (G₁≃G₂ .related) (x G₂.∘ y))                   ≡⟨ _≃_.right-inverse-of (G₁≃G₂ .related) _ ⟩

       x G₂.∘ y                                                          ≡⟨ sym $ cong₂ G₂._∘_
                                                                              (_≃_.right-inverse-of (G₁≃G₂ .related) _)
                                                                              (_≃_.right-inverse-of (G₁≃G₂ .related) _) ⟩
       to G₁≃G₂ (_≃_.from (G₁≃G₂ .related) x) G₂.∘
       to G₁≃G₂ (_≃_.from (G₁≃G₂ .related) y)                            ≡⟨ sym $ G₁≃G₂ .homomorphic _ _ ⟩∎

       to G₁≃G₂
         (_≃_.from (G₁≃G₂ .related) x G₁.∘ _≃_.from (G₁≃G₂ .related) y)  ∎)
  where
  module G₁ = Group G₁
  module G₂ = Group G₂

-- Group homomorphisms preserve identity elements.

→ᴳ-id :
  (G₁↝G₂ : G₁ ↝[ k ]ᴳ G₂) →
  to G₁↝G₂ (Group.id G₁) ≡ Group.id G₂
→ᴳ-id {G₁ = G₁} {G₂ = G₂} G₁↝G₂ =
  G₂.idempotent⇒≡id
    (to G₁↝G₂ G₁.id G₂.∘ to G₁↝G₂ G₁.id  ≡⟨ sym $ G₁↝G₂ .homomorphic _ _ ⟩
     to G₁↝G₂ (G₁.id G₁.∘ G₁.id)         ≡⟨ cong (to G₁↝G₂) $ G₁.left-identity _ ⟩∎
     to G₁↝G₂ G₁.id                      ∎)
  where
  module G₁ = Group G₁
  module G₂ = Group G₂

-- Group homomorphisms are homomorphic with respect to the inverse
-- operators.

→ᴳ-⁻¹ :
  ∀ (G₁↝G₂ : G₁ ↝[ k ]ᴳ G₂) x →
  to G₁↝G₂ (Group._⁻¹ G₁ x) ≡ Group._⁻¹ G₂ (to G₁↝G₂ x)
→ᴳ-⁻¹ {G₁ = G₁} {G₂ = G₂} G₁↝G₂ x = G₂.⁻¹∘≡id→≡
  (to G₁↝G₂ x G₂.⁻¹ G₂.⁻¹ G₂.∘ to G₁↝G₂ (x G₁.⁻¹)  ≡⟨ cong (G₂._∘ to G₁↝G₂ (x G₁.⁻¹)) $ G₂.involutive _ ⟩
   to G₁↝G₂ x G₂.∘ to G₁↝G₂ (x G₁.⁻¹)              ≡⟨ sym $ G₁↝G₂ .homomorphic _ _ ⟩
   to G₁↝G₂ (x G₁.∘ x G₁.⁻¹)                       ≡⟨ cong (to G₁↝G₂) (G₁.right-inverse _) ⟩
   to G₁↝G₂ G₁.id                                  ≡⟨ →ᴳ-id G₁↝G₂ ⟩∎
   G₂.id                                           ∎)
  where
  module G₁ = Group G₁
  module G₂ = Group G₂

-- Group homomorphisms are homomorphic with respect to exponentiation.

→ᴳ-^ :
  ∀ (G₁↝G₂ : G₁ ↝[ k ]ᴳ G₂) x i →
  to G₁↝G₂ (Group._^_ G₁ x i) ≡
  Group._^_ G₂ (to G₁↝G₂ x) i
→ᴳ-^ {G₁ = G₁} {G₂ = G₂} G₁↝G₂ x = lemma₂
  where
  module G₁ = Group G₁
  module G₂ = Group G₂

  lemma₁ : ∀ n → to G₁↝G₂ (y G₁.^+ n) ≡ to G₁↝G₂ y G₂.^+ n
  lemma₁ zero =
    to G₁↝G₂ G₁.id  ≡⟨ →ᴳ-id G₁↝G₂ ⟩∎
    G₂.id    ∎
  lemma₁ {y = y} (suc n) =
    to G₁↝G₂ (y G₁.∘ y G₁.^+ n)           ≡⟨ G₁↝G₂ .homomorphic _ _ ⟩
    to G₁↝G₂ y G₂.∘ to G₁↝G₂ (y G₁.^+ n)  ≡⟨ cong (_ G₂.∘_) $ lemma₁ n ⟩∎
    to G₁↝G₂ y G₂.∘ to G₁↝G₂ y G₂.^+ n    ∎

  lemma₂ : ∀ i → to G₁↝G₂ (x G₁.^ i) ≡ to G₁↝G₂ x G₂.^ i
  lemma₂ (+ n)    = lemma₁ n
  lemma₂ -[1+ n ] =
    to G₁↝G₂ ((x G₁.⁻¹) G₁.^+ suc n)  ≡⟨ lemma₁ (suc n) ⟩
    to G₁↝G₂ (x G₁.⁻¹) G₂.^+ suc n    ≡⟨ cong (G₂._^+ suc n) $ →ᴳ-⁻¹ G₁↝G₂ _ ⟩∎
    (to G₁↝G₂ x G₂.⁻¹) G₂.^+ suc n    ∎

-- Group equality can be expressed in terms of equality of pairs of
-- carrier types and binary operators (assuming extensionality).

≡≃,∘≡,∘ :
  {G₁ G₂ : Group g} →
  Extensionality g g →
  let module G₁ = Group G₁
      module G₂ = Group G₂
  in
  (G₁ ≡ G₂) ≃ ((G₁.Carrier , G₁._∘_) ≡ (G₂.Carrier , G₂._∘_))
≡≃,∘≡,∘ {g = g} {G₁ = G₁} {G₂ = G₂} ext =
  G₁ ≡ G₂                                                    ↝⟨ inverse $ Eq.≃-≡ Group≃ ⟩

  ((G₁.Carrier , G₁._∘_) , _) ≡ ((G₂.Carrier , G₂._∘_) , _)  ↔⟨ (inverse $
                                                                 ignore-propositional-component $
                                                                 The-rest-propositional _) ⟩□
  (G₁.Carrier , G₁._∘_) ≡ (G₂.Carrier , G₂._∘_)              □
  where
  module G₁ = Group G₁
  module G₂ = Group G₂

  Carrier-∘ = ∃ λ (C : Type g) → (C → C → C)

  The-rest : Carrier-∘ → Type g
  The-rest (C , _∘_) =
    ∃ λ ((id , _⁻¹) : C ⊗ (C → C)) →
      Is-set C ⊗
      (∀ x → (id ∘ x) ≡ x) ⊗
      (∀ x → (x ∘ id) ≡ x) ⊗
      (∀ x y z → (x ∘ (y ∘ z)) ≡ ((x ∘ y) ∘ z)) ⊗
      (∀ x → ((x ⁻¹) ∘ x) ≡ id) ⊗
      (∀ x → (x ∘ (x ⁻¹)) ≡ id)

  Group≃ : Group g ≃ Σ Carrier-∘ The-rest
  Group≃ = Eq.↔→≃
    (λ G → let open Group G in
         (Carrier , _∘_)
       , (id , _⁻¹)
       , Carrier-is-set , left-identity , right-identity , assoc
       , left-inverse , right-inverse)
    _
    refl
    refl

  The-rest-propositional : ∀ C → Is-proposition (The-rest C)
  The-rest-propositional C R₁ R₂ =
    Σ-≡,≡→≡
      (cong₂ _,_ id-unique inverse-unique)
      ((×-closure 1 (H-level-propositional ext 2) $
        ×-closure 1 (Π-closure ext 1 λ _ →
                     G₂′.Carrier-is-set) $
        ×-closure 1 (Π-closure ext 1 λ _ →
                     G₂′.Carrier-is-set) $
        ×-closure 1 (Π-closure ext 1 λ _ →
                     Π-closure ext 1 λ _ →
                     Π-closure ext 1 λ _ →
                     G₂′.Carrier-is-set) $
        ×-closure 1 (Π-closure ext 1 λ _ →
                     G₂′.Carrier-is-set) $
                    (Π-closure ext 1 λ _ →
                     G₂′.Carrier-is-set))
         _ _)
    where
    module G₁′ = Group (_≃_.from Group≃ (C , R₁))
    module G₂′ = Group (_≃_.from Group≃ (C , R₂))

    id-unique : G₁′.id ≡ G₂′.id
    id-unique = G₂′.idempotent⇒≡id (G₁′.left-identity G₁′.id)

    inverse-unique : G₁′._⁻¹ ≡ G₂′._⁻¹
    inverse-unique = apply-ext ext λ x → G₂′.⁻¹-unique-right
      (x G₁′.∘ x G₁′.⁻¹  ≡⟨ G₁′.right-inverse _ ⟩
       G₁′.id            ≡⟨ id-unique ⟩∎
       G₂′.id            ∎)

-- Group isomorphisms are equivalent to equalities (assuming
-- extensionality and univalence).

≃ᴳ≃≡ :
  {G₁ G₂ : Group g} →
  Extensionality g g →
  Univalence g →
  (G₁ ≃ᴳ G₂) ≃ (G₁ ≡ G₂)
≃ᴳ≃≡ {G₁ = G₁} {G₂ = G₂} ext univ =
  G₁ ≃ᴳ G₂                                                              ↝⟨ Homomorphic-as-Σ ⟩

  (∃ λ (eq : G₁.Carrier ≃ G₂.Carrier) →
     ∀ x y →
     _≃_.to eq (x G₁.∘ y) ≡ _≃_.to eq x G₂.∘ _≃_.to eq y)               ↝⟨ (∃-cong λ eq → Π-cong ext eq λ _ → Π-cong ext eq λ _ →
                                                                            ≡⇒≃ $ sym $ cong (_≡ _≃_.to eq _ G₂.∘ _≃_.to eq _) $ cong (_≃_.to eq) $
                                                                            cong₂ G₁._∘_
                                                                              (_≃_.left-inverse-of eq _)
                                                                              (_≃_.left-inverse-of eq _)) ⟩
  (∃ λ (eq : G₁.Carrier ≃ G₂.Carrier) →
     ∀ x y → _≃_.to eq (_≃_.from eq x G₁.∘ _≃_.from eq y) ≡ x G₂.∘ y)   ↝⟨ (∃-cong λ _ → ∀-cong ext λ _ →
                                                                            Eq.extensionality-isomorphism ext) ⟩
  (∃ λ (eq : G₁.Carrier ≃ G₂.Carrier) →
     ∀ x →
     (λ y → _≃_.to eq (_≃_.from eq x G₁.∘ _≃_.from eq y)) ≡ (x G₂.∘_))  ↝⟨ (∃-cong λ _ →
                                                                            Eq.extensionality-isomorphism ext) ⟩
  (∃ λ (eq : G₁.Carrier ≃ G₂.Carrier) →
     (λ x y → _≃_.to eq (_≃_.from eq x G₁.∘ _≃_.from eq y)) ≡ G₂._∘_)   ↝⟨ (∃-cong λ eq → ≡⇒≃ $ cong (_≡ _) $ sym $ lemma eq) ⟩

  (∃ λ (eq : G₁.Carrier ≃ G₂.Carrier) →
     subst (λ A → A → A → A) (≃⇒≡ univ eq) G₁._∘_ ≡ G₂._∘_)             ↝⟨ (Σ-cong (inverse $ ≡≃≃ univ) λ _ → Eq.id) ⟩

  (∃ λ (eq : G₁.Carrier ≡ G₂.Carrier) →
     subst (λ A → A → A → A) eq G₁._∘_ ≡ G₂._∘_)                        ↔⟨ B.Σ-≡,≡↔≡ ⟩

  ((G₁.Carrier , G₁._∘_) ≡ (G₂.Carrier , G₂._∘_))                       ↝⟨ inverse $ ≡≃,∘≡,∘ ext ⟩□

  G₁ ≡ G₂                                                               □
  where
  module G₁ = Group G₁
  module G₂ = Group G₂

  lemma : ∀ _ → _
  lemma = λ eq → apply-ext ext λ x → apply-ext ext λ y →
    subst (λ A → A → A → A) (≃⇒≡ univ eq) G₁._∘_ x y      ≡⟨ cong (_$ y) subst-→ ⟩

    subst (λ A → A → A) (≃⇒≡ univ eq)
      (subst P.id (sym (≃⇒≡ univ eq)) x G₁.∘_) y          ≡⟨ subst-→ ⟩

    subst P.id (≃⇒≡ univ eq)
      (subst P.id (sym (≃⇒≡ univ eq)) x G₁.∘
       subst P.id (sym (≃⇒≡ univ eq)) y)                  ≡⟨ cong₂ (λ f g → f (g x G₁.∘ g y))
                                                               (trans (apply-ext ext λ _ → subst-id-in-terms-of-≡⇒↝ equivalence) $
                                                                cong _≃_.to $ _≃_.right-inverse-of (≡≃≃ univ) _)
                                                               (trans (apply-ext ext λ _ → subst-id-in-terms-of-inverse∘≡⇒↝ equivalence) $
                                                                cong _≃_.from $ _≃_.right-inverse-of (≡≃≃ univ) _) ⟩∎
    _≃_.to eq (_≃_.from eq x G₁.∘ _≃_.from eq y)          ∎

------------------------------------------------------------------------
-- Abelian groups

-- The property of being abelian.

Abelian : Group g → Type g
Abelian G =
  ∀ x y → x ∘ y ≡ y ∘ x
  where
  open Group G

-- If two groups are isomorphic, and one is abelian, then the other
-- one is abelian.

≃ᴳ→Abelian→Abelian : G₁ ≃ᴳ G₂ → Abelian G₁ → Abelian G₂
≃ᴳ→Abelian→Abelian {G₁ = G₁} {G₂ = G₂} G₁≃G₂ ∘-comm x y =
  _≃_.injective (G₂≃G₁ .related)
    (to G₂≃G₁ (x G₂.∘ y)         ≡⟨ G₂≃G₁ .homomorphic _ _ ⟩
     to G₂≃G₁ x G₁.∘ to G₂≃G₁ y  ≡⟨ ∘-comm _ _ ⟩
     to G₂≃G₁ y G₁.∘ to G₂≃G₁ x  ≡⟨ sym $ G₂≃G₁ .homomorphic _ _ ⟩∎
     to G₂≃G₁ (y G₂.∘ x)         ∎)
  where
  module G₁ = Group G₁
  module G₂ = Group G₂

  G₂≃G₁ = ≃ᴳ-sym G₁≃G₂

------------------------------------------------------------------------
-- A group construction

-- The direct product of two groups.

infixr 2 _×_

_×_ : Group g₁ → Group g₂ → Group (g₁ ⊔ g₂)
G₁ × G₂ = λ where
    .Carrier          → G₁.Carrier ⊗ G₂.Carrier
    .Carrier-is-set   → ×-closure 2 G₁.Carrier-is-set G₂.Carrier-is-set
    ._∘_              → Σ-zip G₁._∘_ G₂._∘_
    .id               → G₁.id , G₂.id
    ._⁻¹              → Σ-map G₁._⁻¹ G₂._⁻¹
    .left-identity _  → cong₂ _,_
                          (G₁.left-identity _) (G₂.left-identity _)
    .right-identity _ → cong₂ _,_
                          (G₁.right-identity _) (G₂.right-identity _)
    .assoc _ _ _      → cong₂ _,_ (G₁.assoc _ _ _) (G₂.assoc _ _ _)
    .left-inverse _   → cong₂ _,_
                          (G₁.left-inverse _) (G₂.left-inverse _)
    .right-inverse _  → cong₂ _,_
                          (G₁.right-inverse _) (G₂.right-inverse _)
  where
  open Group

  module G₁ = Group G₁
  module G₂ = Group G₂

-- The direct product operator preserves group homomorphisms.

↝-× :
  G₁ ↝[ k ]ᴳ G₂ → G₁′ ↝[ k ]ᴳ G₂′ →
  (G₁ × G₁′) ↝[ k ]ᴳ (G₂ × G₂′)
↝-× {G₁ = G₁} {k = k} {G₂ = G₂} {G₁′ = G₁′} {G₂′ = G₂′}
  G₁↝G₂ G₁′↝G₂′ = λ where
  .related →
    G₁↝G₂ .related ×-cong G₁′↝G₂′ .related
  .homomorphic x@(x₁ , x₂) y@(y₁ , y₂) →
    to-implication (G₁↝G₂ .related ×-cong G₁′↝G₂′ .related)
      (Σ-zip (Group._∘_ G₁) (Group._∘_ G₁′) x y)                   ≡⟨ cong (_$ _) $ to-implication-×-cong k ⟩

    Σ-map (to G₁↝G₂) (to G₁′↝G₂′)
      (Σ-zip (Group._∘_ G₁) (Group._∘_ G₁′) x y)                   ≡⟨⟩

    to G₁↝G₂   (Group._∘_ G₁  x₁ y₁) ,
    to G₁′↝G₂′ (Group._∘_ G₁′ x₂ y₂)                               ≡⟨ cong₂ _,_
                                                                        (G₁↝G₂   .homomorphic _ _)
                                                                        (G₁′↝G₂′ .homomorphic _ _) ⟩
    Group._∘_ G₂  (to G₁↝G₂   x₁) (to G₁↝G₂   y₁) ,
    Group._∘_ G₂′ (to G₁′↝G₂′ x₂) (to G₁′↝G₂′ y₂)                  ≡⟨⟩

    Group._∘_ (G₂ × G₂′)
      (to G₁↝G₂ x₁ , to G₁′↝G₂′ x₂)
      (to G₁↝G₂ y₁ , to G₁′↝G₂′ y₂)                                ≡⟨ sym $ cong₂ (λ f g → Group._∘_ (G₂ × G₂′) (f _) (g _))
                                                                        (to-implication-×-cong k)
                                                                        (to-implication-×-cong k) ⟩∎
    Group._∘_ (G₂ × G₂′)
      (to-implication (G₁↝G₂ .related ×-cong G₁′↝G₂′ .related) x)
      (to-implication (G₁↝G₂ .related ×-cong G₁′↝G₂′ .related) y)  ∎

-- Exponentiation for the direct product of G₁ and G₂ can be expressed
-- in terms of exponentiation for G₁ and exponentiation for G₂.

^-× :
  ∀ (G₁ : Group g₁) (G₂ : Group g₂) {x y} i →
  Group._^_ (G₁ × G₂) (x , y) i ≡
  (Group._^_ G₁ x i , Group._^_ G₂ y i)
^-× G₁ G₂ = helper
  where
  module G₁  = Group G₁
  module G₂  = Group G₂
  module G₁₂ = Group (G₁ × G₂)

  +-helper : ∀ n → (x , y) G₁₂.^+ n ≡ (x G₁.^+ n , y G₂.^+ n)
  +-helper                 zero    = refl _
  +-helper {x = x} {y = y} (suc n) =
    (x , y) G₁₂.∘ (x , y) G₁₂.^+ n         ≡⟨ cong (_ G₁₂.∘_) $ +-helper n ⟩
    (x , y) G₁₂.∘ (x G₁.^+ n , y G₂.^+ n)  ≡⟨⟩
    (x G₁.∘ x G₁.^+ n , y G₂.∘ y G₂.^+ n)  ∎

  helper : ∀ i → (x , y) G₁₂.^ i ≡ (x G₁.^ i , y G₂.^ i)
  helper (+ n)    = +-helper n
  helper -[1+ n ] = +-helper (suc n)

------------------------------------------------------------------------
-- The centre of a group

-- Centre ext G is the centre of the group G, sometimes denoted Z(G).

Centre :
  Extensionality g g →
  Group g → Group g
Centre ext G = λ where
    .Carrier        → ∃ λ (x : Carrier) → ∀ y → x ∘ y ≡ y ∘ x
    .Carrier-is-set → Σ-closure 2 Carrier-is-set λ _ →
                      Π-closure ext 2 λ _ →
                      mono₁ 2 Carrier-is-set
    ._∘_            → Σ-zip _∘_ λ {x y} hyp₁ hyp₂ z →
                        (x ∘ y) ∘ z  ≡⟨ sym $ assoc _ _ _ ⟩
                        x ∘ (y ∘ z)  ≡⟨ cong (x ∘_) $ hyp₂ z ⟩
                        x ∘ (z ∘ y)  ≡⟨ assoc _ _ _ ⟩
                        (x ∘ z) ∘ y  ≡⟨ cong (_∘ y) $ hyp₁ z ⟩
                        (z ∘ x) ∘ y  ≡⟨ sym $ assoc _ _ _ ⟩∎
                        z ∘ (x ∘ y)  ∎
    .id             → id
                    , λ x →
                        id ∘ x  ≡⟨ left-identity _ ⟩
                        x       ≡⟨ sym $ right-identity _ ⟩∎
                        x ∘ id  ∎
    ._⁻¹            → Σ-map _⁻¹ λ {x} hyp y →
                        x ⁻¹ ∘ y        ≡⟨ cong (x ⁻¹ ∘_) $ sym $ involutive _ ⟩
                        x ⁻¹ ∘ y ⁻¹ ⁻¹  ≡⟨ sym ∘⁻¹ ⟩
                        (y ⁻¹ ∘ x) ⁻¹   ≡⟨ cong _⁻¹ $ sym $ hyp (y ⁻¹) ⟩
                        (x ∘ y ⁻¹) ⁻¹   ≡⟨ ∘⁻¹ ⟩
                        y ⁻¹ ⁻¹ ∘ x ⁻¹  ≡⟨ cong (_∘ x ⁻¹) $ involutive _ ⟩∎
                        y ∘ x ⁻¹        ∎
    .left-identity  → λ _ →
                      Σ-≡,≡→≡ (left-identity _)
                        ((Π-closure ext 1 λ _ → Carrier-is-set) _ _)
    .right-identity → λ _ →
                      Σ-≡,≡→≡ (right-identity _)
                        ((Π-closure ext 1 λ _ → Carrier-is-set) _ _)
    .assoc          → λ _ _ _ →
                      Σ-≡,≡→≡ (assoc _ _ _)
                        ((Π-closure ext 1 λ _ → Carrier-is-set) _ _)
    .left-inverse   → λ _ →
                      Σ-≡,≡→≡ (left-inverse _)
                        ((Π-closure ext 1 λ _ → Carrier-is-set) _ _)
    .right-inverse  → λ _ →
                      Σ-≡,≡→≡ (right-inverse _)
                        ((Π-closure ext 1 λ _ → Carrier-is-set) _ _)
  where
  open Group G

-- The centre of an abelian group is isomorphic to the group.

Abelian→Centre≃ :
  (ext : Extensionality g g) (G : Group g) →
  Abelian G → Centre ext G ≃ᴳ G
Abelian→Centre≃ ext G abelian = ≃ᴳ-sym λ where
    .Homomorphic.related         → inverse equiv
    .Homomorphic.homomorphic _ _ →
      cong (_ ,_) ((Π-closure ext 1 λ _ → Carrier-is-set) _ _)
  where
  open Group G

  equiv =
    (∃ λ (x : Carrier) → ∀ y → x ∘ y ≡ y ∘ x)  ↔⟨ (drop-⊤-right λ _ →
                                                   _⇔_.to contractible⇔↔⊤ $
                                                   Π-closure ext 0 λ _ →
                                                   propositional⇒inhabited⇒contractible
                                                     Carrier-is-set
                                                     (abelian _ _)) ⟩□
    Carrier                                    □


{-# OPTIONS --without-K  #-}
module algebra.monoid.core where

open import level
open import algebra.semigroup
open import equality.core
open import sum

record IsMonoid {i} (M : Set i) : Set i where
  field
    instance sgrp : IsSemigroup M

  open IsSemigroup sgrp public
  field
    e : M
    lunit : (x : M) → e * x ≡ x
    runit : (x : M) → x * e ≡ x

Monoid : ∀ i → Set (lsuc i)
Monoid i = Σ (Set i) IsMonoid


module Tactic.Nat.Coprime.Problem where

open import Prelude
open import Prelude.List.Relations.All
open import Numeric.Nat.GCD

Atom = Nat

infixl 7 _⊗_
infix  3 _⋈_
infix  2 _⊨_

data Exp : Set where
  atom : (x : Atom) → Exp
  _⊗_ : (a b : Exp) → Exp

data Formula : Set where
  _⋈_ : (a b : Exp) → Formula

data Problem : Set where
  _⊨_ : (Γ : List Formula) (φ : Formula) → Problem

Env = Atom → Nat

⟦_⟧e_ : Exp → Env → Nat
⟦ atom x ⟧e ρ = ρ x
⟦ e ⊗ e₁ ⟧e ρ = ⟦ e ⟧e ρ * ⟦ e₁ ⟧e ρ

⟦_⟧f_ : Formula → Env → Set
⟦ a ⋈ b ⟧f ρ = Coprime (⟦ a ⟧e ρ) (⟦ b ⟧e ρ)

⟦_⟧p'_ : Problem → Env → Set
⟦ Γ ⊨ φ ⟧p' ρ = All (⟦_⟧f ρ) Γ → ⟦ φ ⟧f ρ

⟦_⟧p_ : Problem → Env → Set
⟦ Γ ⊨ φ ⟧p ρ = foldr (λ ψ A → ⟦ ψ ⟧f ρ → A) (⟦ φ ⟧f ρ) Γ

curryProblem : ∀ Q ρ → ⟦ Q ⟧p' ρ → ⟦ Q ⟧p ρ
curryProblem ([]    ⊨ φ) ρ H = H []
curryProblem (x ∷ Γ ⊨ φ) ρ H = λ x → curryProblem (Γ ⊨ φ) ρ (H ∘ (x ∷_))


module InductiveAndCoinductiveConstructors where

open import Common.Coinduction

record ⊤ : Set where

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

data Stream (A : Set) : Set where
  _≺_ : (x : A) (xs : ∞ (Stream A)) → Stream A

data U : Set where
  stream : (a : U) → U
  _⊗_    : (a b : U) → U
  unit   : U

El : U → Set
El (stream a) = Stream (El a)
El (a ⊗ b)    = El a × El b
El unit       = ⊤

mutual

  data WHNF : U → Set where
    _≺_  : ∀ {a} → El a → Prog (stream a) → WHNF (stream a)
    _,_  : ∀ {a b} → WHNF a → WHNF b → WHNF (a ⊗ b)

  data Prog : U → Set where
    ↓_  : ∀ {a} → ∞ (WHNF a) → Prog a
    fst : ∀ {a b} → Prog (a ⊗ b) → Prog a
    snd : ∀ {a b} → Prog (a ⊗ b) → Prog b
    lab : Prog (stream unit) → Prog (stream (stream unit)) →
          Prog (stream unit ⊗ stream (stream unit))

whnf : ∀ {a} → Prog a → WHNF a
whnf (↓ w) = ♭ w
whnf (fst p) with whnf p
... | (x , y) = x
whnf (snd p) with whnf p
... | (x , y) = y
whnf (lab xs lss) with whnf xs | whnf lss
... | _ ≺ xs′ | (x ≺ ls) ≺ lss′ =
  ((_ ≺ fst (lab xs′ lss′)) , (♭ ls ≺ snd (lab xs′ lss′)))

⟦_⟧ : Prog (stream unit) → Stream ⊤
⟦ p ⟧ with whnf p
... | x ≺ xs = x ≺ ♯ ⟦ xs ⟧

data _≈_ : Stream ⊤ → Stream ⊤ → Set where
  cons : ∀ {xs xs′} → ∞ ((♭ xs) ≈ (♭ xs′)) → (_ ≺ xs) ≈ (_ ≺ xs′)

lemma : ∀ xs lss → ⟦ fst (lab xs lss) ⟧ ≈ ⟦ xs ⟧
lemma xs lss with whnf xs | whnf lss
... | _ ≺ xs′ | (x ≺ ls) ≺ lss′ = cons (♯ lemma xs′ lss′)

label : Prog (stream unit) → Stream ⊤ →
        Prog (stream unit ⊗ stream (stream unit))
label xs ls = lab xs (↓ (♯ (ls ≺ snd (label xs ls))))

shape-preserved : ∀ xs ls → ⟦ fst (label xs ls) ⟧ ≈ ⟦ xs ⟧
shape-preserved xs ls = lemma xs _


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

module Algebra.Group.Group where

open import Algebra.Category
open import Algebra.Group.Monoid
open import Algebra.Group.Semigroup
open import Core

-- A group is a monoid where every element has an inverse.

record IsGroup {a r} (S : Semigroup {a} {r}) : Set (a ⊔ r) where
  open Semigroup S

  field isMonoid : IsMonoid S
  open IsMonoid isMonoid

  field iso : ∀ x → Iso x

  inv : A → A
  inv x = Iso.inv (iso x)

  field inv-cong : ∀ {x y} → x ≈ y → inv x ≈ inv y

  groupoid : Groupoid
  groupoid =
    record {
      category = category;
      iso = iso;
      inv-cong = inv-cong
    }

  open Groupoid groupoid public
    using (inv-invol)

record Group {a r} : Set (lsuc (a ⊔ r)) where
  field semigroup : Semigroup {a} {r}
  open Semigroup semigroup public

  field isGroup : IsGroup semigroup
  open IsGroup isGroup public

  monoid : Monoid
  monoid =
    record {
      semigroup = semigroup;
      isMonoid = isMonoid
    }

-- A group morphism is a function that maps the elements of one group to
-- another while preserving the compositional structure, the identity
-- and all inverses.

record GroupMorphism
           {ga gr ha hr}
           (G : Group {ga} {gr})
           (H : Group {ha} {hr})
           : Set (ga ⊔ gr ⊔ ha ⊔ hr)
       where

  private
    module G = Group G
    module H = Group H

  field monoidMorphism : MonoidMorphism G.monoid H.monoid
  open MonoidMorphism monoidMorphism public

  field inv-preserving : ∀ x → map (G.inv x) H.≈ H.inv (map x)


{-# OPTIONS --type-in-type #-}

module z where

{-
Generic Programming with Dependent Types
Stephanie Weirich and Chris Casinghino, University of Pennsylvania, {sweirich,ccasin}@cis.upenn.edu

ccasin@cis.upenn.edu

2010 : https://www.seas.upenn.edu/~sweirich/papers/aritygen.pdf
2012 : https://www.cis.upenn.edu/~sweirich/papers/ssgip-journal.pdf

------------------------------------------------------------------------------
-- Abstract and Intro

2 types of genericity
- datatype
  - operate on type structure of data
  - so no need to define for each new type
- arity
  - enables functions to be applied to a variable number of args.

e.g., generalize arity of map
repeat   :: a               → [a]
map      :: (a → b)         → [a] → [b]
zipWith  :: (a → b → c)     → [a] → [b] → [c]
zipWith3 :: (a → b → c → d) → [a] → [b] → [c] → [d]

code        : http://www.seas.upenn.edu/~sweirich/papers/aritygen-lncs.tar.gz
tested with : Agda version 2.2.10

------------------------------------------------------------------------------
2 SIMPLE TYPE-GENERIC PROGRAMMING IN AGDA

using Agda with flags (which implies cannot do proofs)
{-# OPTIONS --type-in-type #-}
–no-termination-check
{-# OPTIONS --no-positivity-check #-}
-}

data Bool : Set where
  true  : Bool
  false : Bool

¬ : Bool → Bool
¬ true = false
¬ false = true

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

if_then_else : ∀ {A : Set} → Bool → A → A → A
if true  then a1 else a2 = a1
if false then a1 else a2 = a2

data ℕ : Set where
  zero :     ℕ
  suc  : ℕ → ℕ
{-# BUILTIN NATURAL ℕ #-}

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

data List (A : Set) : Set where
  []   :              List A
  _::_ : A → List A → List A
infixr 5 _::_ -- https://agda.github.io/agda-stdlib/Data.Vec.Functional.html

replicate : ∀ {A} → ℕ → A → List A
replicate  zero   _ = []
replicate (suc n) x = x :: replicate n x

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

repeat : ∀ {n} {A} → A → Vec A n
repeat {zero}  x = []
repeat {suc n} x = x :: repeat x

------------------------------------------------------------------------------
-- 2.1 BASIC TYPE-GENERIC PROGRAMMING

eq-bool : Bool → Bool → Bool
eq-bool true  true  = true
eq-bool false false = true
eq-bool _     _     = false

eq-nat : ℕ → ℕ → Bool
eq-nat  zero    zero   = true
eq-nat (suc n) (suc m) = eq-nat n m
eq-nat      _       _  = false

{-
Structural equality functions, like above, motivate type-generic programming:
- enables defining functions that observe and use structure of types

In a dependently typed language, type-generic is accomplished using universes [17, 21].

E.G., universe of natural number, boolean and product types
-}

-- datatype 'Type', called a "universe"
data Type : Set where
  TNat  :               Type
  TBool :               Type
  TProd : Type → Type → Type

open import Data.Product

-- define an interpretation function '⟨_⟩'
-- maps elements of this universe to Agda types
⟨_⟩ : Type → Set
⟨ TNat ⟩        = ℕ
⟨ TBool ⟩       = Bool
⟨ TProd t1 t2 ⟩ = ⟨ t1 ⟩ × ⟨ t2 ⟩

geq : (t : Type) → ⟨ t ⟩ → ⟨ t ⟩ → Bool
geq TNat  n1 n2 = eq-nat  n1 n2
geq TBool b1 b2 = eq-bool b1 b2
geq (TProd a b) (a1 , b1) (a2 , b2) = geq a a1 a2 ∧ geq b b1 b2

geqEx : Bool
geqEx = geq (TProd TNat TBool) (1 , false) (1 , false)

{-
------------------------------------------------------------------------------
-- 3 ARITY-GENERIC PROGRAMMING : generalize over number of arguments

e.g., map-like (above), +, foldl, foldr

e.g., generalize following functions into one definition : maps for vectors
-}

-- infix zipping application, pronounced “zap” for “zip with apply”
_⊗_ : {A B : Set} {n : ℕ} → Vec (A → B) n → Vec A n → Vec B n
[] ⊗ [] = []
(a :: As) ⊗ (b :: Bs) = a b :: As ⊗ Bs
infixl 40 _⊗_

map0 : {m : ℕ} {A     : Set} →  A          →                     Vec A m
map0         = repeat

map1 : {m : ℕ} {A B   : Set} → (A → B)     → Vec A m →           Vec B m
map1 f x     = repeat f ⊗ x

map2 : {m : ℕ} {A B C : Set} → (A → B → C) → Vec A m → Vec B m → Vec C m
map2 f x1 x2 = repeat f ⊗ x1 ⊗ x2

{-
Intuitively, each map defined by a application of repeat and n copies of _⊗_.
nvec-map f n v1 v2 ... vn = repeat f ⊗ v1 ⊗ v2 ⊗ ... ⊗ vn

-- recursion on n in accumulator style
-- after repeating f :  have a vector of functions
-- then zap this vector across n argument vectors
-- NEEDS type declaration - given below (in Arity section)
nvec-map n f = g n (repeat f)
 where
  g0 a = a
  g (suc n) f = (λ a → g n (f ⊗ a))

--------------------------------------------------
3.1 Typing Arity-Generic Vector Map

arity-generic map : instances have different types

Given arity n, generate corresponding type in the sequence

Part of the difficulty is that generic function is curried in both its type and term args.

This subsection starts with an initial def that takes
- all of the type args in a vector,
- curries term arguments

next subsection, shows how to uncurry type args

ℕ for arity

store types in vector of Agda types, Bool :: N :: [].

vector has type Vec Set 2, so can use standard vector operations (such as _⊗_)

(given in OPTIONS at top of file)
--type-in-type : gives Set the type Set
- simplifies presentation by hiding Agda’s infinite hierarchy of Set levels
- at cost of making Agda’s logic inconsistent
-}

-- folds arrow type constructor (→) over vector of types
-- used to construct the type of 1sr arg to nvec-map
arrTy : {n : ℕ} → Vec Set (suc n) → Set
arrTy {0} (A :: []) = A
arrTy {suc n} (A :: As) = A → arrTy As

arrTyTest : Set
arrTyTest = arrTy (ℕ :: ℕ :: Bool :: [])
-- C-c C-n arrTyTest
-- ℕ → ℕ → Bool

-- Constructs result type of arity-generic map for vectors.
-- Map Vec constructor onto the vector of types, then placing arrows between them.
-- There are two indices:
-- - n : number of types (the arity)
-- - m : length of vectors to be mapped over
arrTyVec : {n : ℕ} → ℕ → Vec Set (suc n) → Set
arrTyVec m As = arrTy (repeat (λ A → Vec A m) ⊗ As)

{- alternate type sigs of previous mapN examples:
map0' : {m : ℕ} {A     : Set} → arrTy (A :: [])           → arrTyVec m (A :: [])
map1' : {m : ℕ} {A B   : Set} → arrTy (A :: B :: [])      → arrTyVec m (A :: B :: [])
map2' : {m : ℕ} {A B C : Set} → arrTy (A :: B :: C :: []) → arrTyVec m (A :: B :: C :: [])
-}

nvec-map : {m : ℕ}
         → (n : ℕ) → {As : Vec Set (suc n)}
         → arrTy As → arrTyVec m As
nvec-map n f = g n (repeat f)
 where
  g : {m : ℕ}
    → (n : ℕ) → {As : Vec Set (suc n)}
    → Vec (arrTy As) m → arrTyVec m As
  g      0  {A :: []} a = a
  g (suc n) {A :: As} f = (λ a → g n (f ⊗ a))

nvec-map-Test : Vec ℕ 2 -- 11 :: 15 :: []
nvec-map-Test = nvec-map 1 { ℕ :: ℕ :: [] } (λ x → 10 + x) (1 :: 5 :: [])

{-
annoying : must explicitly supply types
next section : enable inference

--------------------------------------------------
3.2 A Curried Vector Map

Curry type args so they are supplied individually (rather than a ector).
Enables inference (usually).
-}

-- quantify : creates curried version of a type which depends on a vector
∀⇒ : {n : ℕ} {A : Set} → (Vec A n → Set)
   → Set
∀⇒ {zero}       B = B []
∀⇒ {suc n} {A}  B = (a : A) → ∀⇒ {n} (λ as → B (a :: as))

-- curry : creates curried version of a corresponding function term
λ⇒ : {n : ℕ} {A : Set} {B : Vec A n → Set}
   → ((X : Vec A n) → B X)
   → (∀⇒ B)
λ⇒ {zero}       f = f []
λ⇒ {suc n} {A}  f = (λ a → λ⇒ {n} (λ as → f (a :: as))) -- **** HERE
-- 'a' is implicit in paper
-- Victor says 'hidden' lambdas are magic.
-- see: Eliminating the problems of hidden-lambda insertion
--      https://www.cse.chalmers.se/~abela/MScThesisJohanssonLloyd.pdf

-- uncurry (from 2010 paper)
/⇒ : (n : ℕ) → {K : Set} {B : Vec K n → Set}
   → (∀⇒ B)
   → (A : Vec K n)
   → B A
/⇒ (zero)  f       []  = f
/⇒ (suc n) f (a :: as) = /⇒ n (f a) as

-- arity-generic map
nmap : {m : ℕ}
     → (n : ℕ) -- specifies arity
     → ∀⇒ (λ (As : Vec Set (suc n)) → arrTy As → arrTyVec m As)
nmap {m} n = λ⇒ (λ As → nvec-map {m} n {As})

{-
nmap 1
has type
{m : N} → {A B : Set} → (A → B) → (Vec A m) → (Vec B m)
C-c C-d
(a a₁ : Set) → (a → a₁) → arrTyVec _m_193 (a :: a₁ :: [])

nmap 1 (λ x → 10 + x) (10 :: 5 :: [])
evaluates to
11 :: 15 :: []
C-c C-d
(x : ℕ) → ℕ !=< Set
when checking that the expression λ x → 10 + x has type Set

nmap 2
has type
{m : N} → {ABC : Set} → (A → B → C) → Vec A m → Vec B m → Vec C m
C-c C-d
(a a₁ a₂ : Set) → (a → a₁ → a₂) → arrTyVec _m_193 (a :: a₁ :: a₂ :: [])

nmap 2 ( , ) (1 :: 2 :: 3 :: []) (4 :: 5 :: 6 :: [])
evaluates to
(1 , 4) :: (2 , 5) :: (3 , 6) :: []

now : do not need to explicitly specify type of data in vectors
-}


open import FRP.LTL.Time using ( Time ; _,_ )
open import FRP.LTL.Time.Bound using
  ( Time∞ ; _≼_ ; _≺_ ; fin ; +∞ ; +∞-top ; t≺+∞ ; ≼-refl ; _≼-trans_
  ; ≡-impl-≼ ; ≺-impl-≼ ; _≺-trans_ ; _≺-transʳ_ ; ≺-impl-⋡ ; t≺t+1 )
open import FRP.LTL.Util using ( irrelevant ; ⊥-elim )
open import Relation.Unary using ( _∈_ )
open import Relation.Binary.PropositionalEquality using ( _≡_ ; refl ; sym )

module FRP.LTL.Time.Interval where

infixr 2 _⊑_ _~_
infixr 4 _,_ _⌢_∵_

-- Semi-open intervals, with possibly infinite bounds

-- Previous versions of Interval used ≼ rather than ≺
-- (that is, empty intervals were supported) but
-- MSet has been written to avoid requiring empty intervals.

data Interval : Set where
  [_⟩ : ∀ {s t} → .(s ≺ t) → Interval

lb : Interval → Time∞
lb ([_⟩ {s} {t} s≺t) = s

ub : Interval → Time∞
ub ([_⟩ {s} {t} s≺t) = t

.lb≺ub : ∀ i → (lb i ≺ ub i)
lb≺ub [ s≺t ⟩ = irrelevant s≺t

-- Semantics of intervals

data Int∞ (i : Interval) (t : Time∞) : Set where
  _,_ : .(lb i ≼ t) → .(t ≺ ub i) → (t ∈ Int∞ i)

Int : Interval → Time → Set
Int i t = fin t ∈ Int∞ i

.lb≼ : ∀ {t i} → (t ∈ Int i) → (lb i ≼ fin t)
lb≼ (s≼t , t≺u) = irrelevant s≼t

.≺ub : ∀ {t i} → (t ∈ Int i) → (fin t ≺ ub i)
≺ub (s≼t , t≺u) = irrelevant t≺u

-- Ordering on intervals

data _⊑_ (i j : Interval) : Set where
  _,_ : .(lb j ≼ lb i) → .(ub i ≼ ub j) → (i ⊑ j)

⊑-refl : ∀ {i} → (i ⊑ i)
⊑-refl = (≼-refl , ≼-refl)

_⊑-trans_ : ∀ {i j k} → (i ⊑ j) → (j ⊑ k) → (i ⊑ k)
(sj≼si , ui≼uj) ⊑-trans (sk≼sj , uj≼uk) =
  (sk≼sj ≼-trans sj≼si , ui≼uj ≼-trans uj≼uk)

.⊑-impl-≼ : ∀ {i j} → (i ⊑ j) → (ub i ≼ ub j)
⊑-impl-≼ (lj≼li , ui≼uj) = irrelevant ui≼uj

.⊑-impl-≽ : ∀ {i j} → (i ⊑ j) → (lb j ≼ lb i)
⊑-impl-≽ (lj≼li , ui≼uj) = irrelevant lj≼li

-- When do two intervals abut?

_~_ : Interval → Interval → Set
i ~ j = ub i ≡ lb j

-- Concatenation of intervals

_⌢_∵_ : ∀ i j → (i ~ j) → Interval
i ⌢ j ∵ i~j = [ lb≺ub i ≺-trans ≡-impl-≼ i~j ≺-transʳ lb≺ub j ⟩

⌢-inj₁ : ∀ i j i~j → (i ⊑ (i ⌢ j ∵ i~j))
⌢-inj₁ [ s≺t ⟩ [ t≺u ⟩ refl = (≼-refl , ≺-impl-≼ t≺u)

⌢-inj₂ : ∀ i j i~j → (j ⊑ (i ⌢ j ∵ i~j))
⌢-inj₂ [ s≺t ⟩ [ t≺u ⟩ refl = (≺-impl-≼ s≺t , ≼-refl)

-- Up-closure of a time

↑ : Time → Interval
↑ t = [ t≺+∞ {t} ⟩

-- Singleton interval

sing : Time → Interval
sing t = [ t≺t+1 {t} ⟩


open import Data.Product renaming (_,_ to _,,_) -- just to avoid clash with other commas
open import Algebra.Structures           using (IsSemigroup)
open import Algebra.FunctionProperties   using (LeftIdentity; Commutative)

module Preliminaries where

Rel : Set -> Set₁
Rel A  =  A -> A -> Set

Entire : {A B : Set} -> (_R_ : A -> B -> Set) -> Set
Entire _R_ = ∀ a -> ∃ \ b -> a R b

fun : {A B : Set} -> {_R_ : A -> B -> Set} -> Entire _R_ -> A -> B
fun ent a = proj₁ (ent a)

correct :  {A B : Set} -> {_R_ : A -> B -> Set} -> (ent : Entire _R_) ->
           let f = fun ent in  ∀ {a : A} -> a R (f a)
correct ent {a} = proj₂ (ent a)

Entire3 : {A B C D : Set} -> (R : A -> B -> C -> D -> Set) -> Set
Entire3 R = ∀ x y z -> ∃ (R x y z)

fun3 : {A B C D : Set} -> {R : A -> B -> C -> D -> Set} -> Entire3 R -> A -> B -> C -> D
fun3 ent a b c = proj₁ (ent a b c)

correct3 :  {A B C D : Set} -> {R : A -> B -> C -> D -> Set} -> (e : Entire3 R) ->
           ∀ {a : A} {b : B} {c : C} -> R a b c (fun3 e a b c)
correct3 ent {a} {b} {c} = proj₂ (ent a b c)

UniqueSolution : {A : Set} -> Rel A -> (A -> Set) -> Set
UniqueSolution _≃_ P = ∀ {x y} -> P x -> P y  ->  x ≃ y

LowerBound : {A : Set} -> Rel A -> (A -> Set) -> (A -> Set)
LowerBound _≤_ P  a = ∀ z -> (P z -> a ≤ z)

Least   : {A : Set} -> Rel A -> (A -> Set) -> (A -> Set)
Least   _≤_ P  a =  P a  ×  LowerBound _≤_ P a


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

module AKS.Nat.Combinatorial where

open import AKS.Nat.Base using (ℕ; _+_; _∸_; _*_; _≤_)
open ℕ
open import AKS.Nat.Properties using (*-identityʳ)
open import AKS.Nat.Properties using (0≤n; ≤-refl; m≤m+n; *-mono-≤; module ≤-Reasoning)
open import AKS.Nat.Properties using (<-irrefl; *-mono-<)
open import AKS.Nat.Divisibility using (_/_)
open ≤-Reasoning

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

_! : ℕ → ℕ
zero ! = 1
suc n ! = suc n * n !

1≤n! : ∀ n → 1 ≤ n !
1≤n! zero = ≤-refl
1≤n! (suc n) = begin
  1 ≤⟨ 1≤n! n ⟩
  n ! ≤⟨ m≤m+n ⟩
  n ! + n * n ! ≡⟨ refl ⟩
  (1 + n) ! ∎

n≤n! : ∀ n → n ≤ n !
n≤n! zero = 0≤n
n≤n! (suc n) = begin
  suc n ≡⟨ sym (*-identityʳ (suc n)) ⟩
  suc n * 1 ≤⟨ *-mono-≤ (≤-refl {suc n}) (1≤n! n) ⟩
  (1 + n) ! ∎

_C′_ : ℕ → ℕ → ℕ
n C′ k = (n ! / (k ! * (n ∸ k) !)) {≢⇒¬≟ den≢0}
  where
  den≢0 : k ! * (n ∸ k) ! ≢ 0
  den≢0 den≡0 = <-irrefl (sym den≡0) (*-mono-< (1≤n! k) (1≤n! (n ∸ k)))

nC′0≡1 : ∀ {n} → n C′ 0 ≡ 1
nC′0≡1 {n} = lemma num≡dem
  where
  num≡dem : n ! ≡ (0 ! * (n ∸ 0) !)
  num≡dem = sym (+-identityʳ (n !))
  lemma : ∀ {num dem} .{dem≢0} → num ≡ dem → (num / dem) {dem≢0} ≡ 1
  lemma {num} {_} {dem≢0} refl = n/n≡1 num {dem≢0}

-- 0C′n≡0 : ∀ {k} → 0 C′ k ≡ 0
-- 0C′n≡0 {k} = {!0/n≡0 (k ! * (0 ∸ k) !) {?}!}

-- lem : ∀ {n k} → n C k ≡ n C′ k
-- lem {n} {zero} = sym (nC′0≡1 {n})
-- lem {zero} {suc k} = {!refl!}
-- lem {suc n} {suc k} with lem {n} {k} | lem {n} {suc k}
-- ... | p₁ | p₂ = {!!}