module plfa.working.Naturals where

    data ℕ : Set where
      zero : ℕ
      suc : ℕ → ℕ

    seven : ℕ
    seven = suc(suc(suc(suc(suc(suc(suc(zero)))))))

    {-# BUILTIN NATURAL ℕ #-}

    import Relation.Binary.PropositionalEquality as Eq
    open Eq using (_≡_; refl)
    open Eq.≡-Reasoning using (begin_; _≡⟨⟩_; _∎)

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

    _ : 2 + 3 ≡ 5
    _ =
      begin
        2 + 3
      ≡⟨⟩
        (suc (suc zero)) + (suc (suc (suc zero)))
      ≡⟨⟩
        suc( (suc zero) + (suc (suc (suc zero))))
      ≡⟨⟩
        (suc(suc (zero + (suc (suc (suc zero))))))
      ≡⟨⟩
        (suc (suc (suc (suc (suc zero)))))
      ≡⟨⟩
        5
      ∎

    _ : 2 + 3 ≡ 5
    _ =
      begin
        2 + 3
      ≡⟨⟩
        suc (1 + 3)
      ≡⟨⟩
        suc (suc (0 + 3))
      ≡⟨⟩
        suc (suc 3)
      ≡⟨⟩
        5
      ∎

    _ : 3 + 4 ≡ 7
    _ =
      begin
        3 + 4
      ≡⟨⟩
        suc (2 + 4)
      ≡⟨⟩
        suc (2 + (suc 3))
      ≡⟨⟩
        suc (suc (2 + 3))
      ≡⟨⟩
        suc (suc  5)
      ≡⟨⟩
        7
      ∎

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

    _ : 3 * 4 ≡ 12
    _ =
      begin
        3 * 4
      ≡⟨⟩
        (suc 2) * 4
      ≡⟨⟩
        4 + (4 * 2)
      ≡⟨⟩
        4 + ((suc 3) * 2)
      ≡⟨⟩
        4 + (2 + (2 * 3))
      ≡⟨⟩
        4 + (2 + (suc 1 * 3))
      ≡⟨⟩
        4 + (2 + (3 + (3 * 1)))
      ≡⟨⟩
        4 + (2 + (3 + (suc 2 * 1)))
      ≡⟨⟩
        4 + (2 + (3 + (1 + (1 * 2))))
      ≡⟨⟩
        12
      ∎

    _^_ : ℕ → ℕ → ℕ
    n ^ zero = suc zero
    n ^ (suc m) = n * (n ^ m)

    _ : 3 ^ 4 ≡ 81
    _ =
      begin
        3 ^ 4
      ≡⟨⟩
        3 ^ (1 + 3)
      ≡⟨⟩
        3 * (3 ^ 3)
      ≡⟨⟩
        3 * (3 * (3 ^ 2))
      ≡⟨⟩
        3 * (3 * (3 * (3 ^ 1)))
      ≡⟨⟩
        3 * (3 * (3 * 3))
      ≡⟨⟩
        81
      ∎

    _∸_ : ℕ → ℕ → ℕ
    m ∸ zero = m
    zero ∸ suc n = zero
    suc m ∸ suc n = m ∸ n

    _ : 5 ∸ 3 ≡ 2
    _ =
      begin
        5 ∸ 3
      ≡⟨⟩
        (1 + 4) ∸ (1 + 2)
      ≡⟨⟩
        4 ∸ 2
      ≡⟨⟩
        3 ∸ 1
      ≡⟨⟩
        2 ∸ 0
      ≡⟨⟩
        2
      ∎

    _ : 2 ∸ 5 ≡ 0
    _ =
      begin
        2 ∸ 5
      ≡⟨⟩
        1 ∸ 4
      ≡⟨⟩
        0 ∸ 3
      ≡⟨⟩
        0
      ∎

    data Bin : Set where
      ⟨⟩ : Bin
      _O : Bin → Bin
      _I : Bin → Bin

    inc : Bin → Bin
    inc ⟨⟩ = ⟨⟩ I
    inc (p O) = p I
    inc (p I) = (inc p) O

    _ : inc (⟨⟩ O O O O) ≡ ⟨⟩ O O O I
    _ = refl

    _ : inc (⟨⟩ O O O I) ≡ ⟨⟩ O O I O
    _ = refl

    _ : inc (⟨⟩ O O I O) ≡ ⟨⟩ O O I I
    _ = refl

    _ : inc (⟨⟩ O O I I) ≡ ⟨⟩ O I O O
    _ = refl

    _ : inc (⟨⟩ I O I I) ≡ ⟨⟩ I I O O
    _ = refl

    to : ℕ → Bin
    to zero = ⟨⟩ O
    to (suc n) = inc (to n)

    from : Bin → ℕ
    from ⟨⟩ = zero
    from (p O) = from p * 2
    from (p I) = suc ((from p) * 2)

    _ : to 3 ≡ ⟨⟩ I I
    _ = refl

    _ : from (⟨⟩ I I) ≡ 3
    _ = refl


module Nat where

data ℕ : Set where
  zero : ℕ
  suc : ℕ → ℕ

_+_ : ℕ → ℕ → ℕ
zero + a = a
suc a + b = suc (a + b)

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

infix 4 _≡_

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

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


------------------------------------------------------------------------------
-- Axiomatic PA properties
------------------------------------------------------------------------------

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

module PA.Axiomatic.Standard.PropertiesI where

open import Common.FOL.Relation.Binary.EqReasoning

open import PA.Axiomatic.Standard.Base

------------------------------------------------------------------------------
-- Congruence properties

succCong : ∀ {m n} → m ≡ n → succ m ≡ succ n
succCong refl = refl

+-leftCong : ∀ {m n o} → m ≡ n → m + o ≡ n + o
+-leftCong refl = refl

+-rightCong : ∀ {m n o} → n ≡ o → m + n ≡ m + o
+-rightCong refl = refl

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

+-leftIdentity : ∀ n → zero + n ≡ n
+-leftIdentity = PA₃

+-rightIdentity : ∀ n → n + zero ≡ n
+-rightIdentity = ℕ-ind A A0 is
  where
  A : ℕ → Set
  A i = i + zero ≡ i

  A0 : A zero
  A0 = +-leftIdentity zero

  is : ∀ i → A i → A (succ i)
  is i ih = succ i + zero   ≡⟨ PA₄ i zero ⟩
            succ (i + zero) ≡⟨ succCong ih ⟩
            succ i          ∎

+-asocc : ∀ m n o → m + n + o ≡ m + (n + o)
+-asocc m n o = ℕ-ind A A0 is m
  where
  A : ℕ → Set
  A i = i + n + o ≡ i + (n + o)

  A0 : A zero
  A0 = zero + n + o   ≡⟨ +-leftCong (+-leftIdentity n) ⟩
       n + o          ≡⟨ sym (+-leftIdentity (n + o)) ⟩
       zero + (n + o) ∎

  is : ∀ i → A i → A (succ i)
  is i ih = succ i + n + o     ≡⟨ +-leftCong (PA₄ i n) ⟩
            succ (i + n) + o   ≡⟨ PA₄ (i + n) o ⟩
            succ (i + n + o)   ≡⟨ succCong ih ⟩
            succ (i + (n + o)) ≡⟨ sym (PA₄ i (n + o)) ⟩
            succ i + (n + o)   ∎

x+Sy≡S[x+y] : ∀ m n → m + succ n ≡ succ (m + n)
x+Sy≡S[x+y] m n = ℕ-ind A A0 is m
  where
  A : ℕ → Set
  A i = i + succ n ≡ succ (i + n)

  A0 : A zero
  A0 = zero + succ n   ≡⟨ +-leftIdentity (succ n) ⟩
       succ n          ≡⟨ succCong (sym (+-leftIdentity n)) ⟩
       succ (zero + n) ∎

  is : ∀ i → A i → A (succ i)
  is i ih = succ i + succ n     ≡⟨ PA₄ i (succ n) ⟩
            succ (i + succ n)   ≡⟨ succCong ih ⟩
            succ (succ (i + n)) ≡⟨ succCong (sym (PA₄ i n)) ⟩
            succ (succ i + n)   ∎

+-comm : ∀ m n → m + n ≡ n + m
+-comm m n = ℕ-ind A A0 is m
  where
  A : ℕ → Set
  A i = i + n ≡ n + i

  A0 : A zero
  A0 = zero + n ≡⟨ +-leftIdentity n ⟩
       n        ≡⟨ sym (+-rightIdentity n) ⟩
       n + zero ∎

  is : ∀ i → A i → A (succ i)
  is i ih = succ i + n   ≡⟨ PA₄ i n ⟩
            succ (i + n) ≡⟨ succCong ih ⟩
            succ (n + i) ≡⟨ sym (x+Sy≡S[x+y] n i) ⟩
            n + succ i   ∎


module List.Order.Bounded {A : Set}(_≤_ : A → A → Set)  where

open import Bound.Total A
open import Bound.Total.Order _≤_
open import Data.List

data _≤*_ : List A → Bound → Set where
  lenx : {t : Bound} → [] ≤* t
  lecx : {t : Bound}{x : A}{xs : List A} → LeB (val x) t → xs ≤* t → (x ∷ xs) ≤* t

data _*≤_ : Bound → List A → Set where
  genx : {b : Bound} → b *≤ []
  gecx : {b : Bound}{x : A}{xs : List A} → LeB b (val x) → b *≤ xs → b *≤ (x ∷ xs)


module Id1 where

import Level
open import Data.Empty using (⊥)
open import Data.Unit using (⊤)
open import Data.Bool using (Bool)
open import Data.Sum using (_⊎_)
open import Data.Nat
open import Data.Product
open import Data.Vec
open import Function using (id)

-- Study identity types from first principles

-- As we have seen for the previous types, we need to define the type,
-- its constructors, and then focus on the recursion and induction
-- principles. All computations and all properties of the identity
-- type should be derivable from these (recursion and induction)
-- principles.

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

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

-- We have to write (refl x) for some x. This is different from the
-- Agda library which leaves the 'x' implicit

infix 4 _≡_

{--
Convention:
multiplicative          precedence 7
additive                precedence 6
equality and comparison precedence 4
--}

-- Simple examples

private
  p₁ : 3 ≡ 3
  p₁ = refl 3

  p₂ : 3 * 1 ≡ 1 + 2
  p₂ = refl (4 ∸ 1)

-- Let's try to derive the recursion principle for identity
-- types... This type has one constructor just like ⊤ in some sense.
-- Recall the recursion principle for ⊤:
-- rec⊤ : (C : Set) → C → (v : ⊤) → C

-- So at first approximation, the recursion principle for ≡ looks like:

--
-- rec≡ : (C : Set) → C → ({A : Set} {x y : A} (p : x ≡ y) → C)
--

-- In the case of ⊤, we wanted to map the element of ⊤ to an element
-- of C. For ≡, we also want to map the element of (x ≡ y) to an
-- element of C. Note that the element of (x ≡ y) is some kind of
-- relation between x and y so it makes sense to insist that the
-- target C is also a relation between x and y, i.e., we map relations
-- to relations.

-- So as a second approximation, the recursion principle for ≡ looks like:

--
-- rec≡ : {A : Set} {x y : A} →
--        (R : A → A → Set) → R x y → (p : x ≡ y) → R x y
--

-- In the case of ⊤, the second argument to the recursion operation
-- specified an element of C which would serve as the target for
-- tt. Now in the case of ≡, we want to specify an element of R x y
-- which would be the target of refl. This requires two adjustments:
-- first the second argument of type (R x y) makes no sense in general
-- as we don't want to insist that the relation R is universal (i.e.,
-- holds between arbitrary x and y). Second we must insist that the
-- relation R is reflexive.

rec≡ : {A : Set} →
       (R : A → A → Set) {reflexiveR : {a : A} → R a a} →
       ({x y : A} (p : x ≡ y) → R x y)
rec≡ R {reflR} (refl y) = reflR {y}

-- A special case of reflexive relations on A is the class of
-- functions from C a -> C a for some predicate C. Let's specialize
-- the above recursion principle to this special case.

rec≡S : {A : Set} {C : A → Set} →
        ({x y : A} (p : x ≡ y) → C x → C y)
rec≡S {C = C} p = rec≡ (λ a b → C a → C b) {id} p

-- Or we can prove the specialized version directly (rename to subst)

subst : {A : Set} {C : A → Set} →
        ({x y : A} (p : x ≡ y) → C x → C y)
subst {x = x} {y = .x} (refl .x) = id

-- So the recursion principle for the identity type says
-- equals may be substituted for equals OR
-- indiscernability of identicals OR
-- every type family respects equality

-- Examples:

private

  ex₁ : ∀ {n} → (p : n + 0 ≡ n) → (n + 0 > 0) → (n > 0)
  ex₁ {n} p = subst {C = λ m → m > 0} {n + 0} {n} p

  ex₂ : ∀ {A n} → (p : n + 0 ≡ n) → (Vec A (n + 0)) → (Vec A n)
  ex₂ {A} {n} p = subst {C = λ m → Vec A m} {n + 0} {n} p

  {--

  From Data.Nat library:

  data _≤_ : Rel ℕ Level.zero where
    z≤n : ∀ {n}                 → zero  ≤ n
    s≤s : ∀ {m n} (m≤n : m ≤ n) → suc m ≤ suc n

  --}

  ≤-reflexive : {a : ℕ} → a ≤ a
  ≤-reflexive {zero} = z≤n
  ≤-reflexive {suc a} = s≤s (≤-reflexive {a})

  ex₃ : ∀ {n} → (p : n + 0 ≡ n) → (n + 0 ≤ n)
  ex₃ {n} = rec≡ {ℕ} (_≤_) {≤-reflexive} {n + 0} {n}

------------------------------------------------------------------------------
-- Now let's look at the induction principle for identity types

-- Our usual idiom is to use the same code for the recursion principle
-- and just make the eliminator a dependent function

-- Let's look at rec≡ again

-- rec≡ : {A : Set} →
--        (R : A → A → Set) {reflexiveR : {a : A} → R a a} →
--        ({x y : A} (p : x ≡ y) → R x y)
-- rec≡ R {reflR} (refl y) = reflR {y}

-- The relation R is already dependent on x and y; we just need to
-- make it dependent on p too

ind≡ : {A : Set} →
       (R : (x : A) → (y : A) → (p : x ≡ y) → Set)
       {reflexiveR : {a : A} → R a a (refl a)} →
       ({x y : A} (p : x ≡ y) → R x y p)
ind≡ R {reflR} (refl y) = reflR {y}

-- Changing some implicit argument to being explicit and vice-versa,
-- and changing names of bound variables we get:

J : {A : Set} →
    (R : {x y : A} → (p : x ≡ y) → Set)
    (r : (a : A) → R (refl a)) →
    ({a b : A} (p : a ≡ b) → R p)
J R r (refl y) = r y

-- Examples

sym : {A : Set} {x y : A} → (x ≡ y) → (y ≡ x)
sym = J (λ {x} {y} p → y ≡ x) (λ a → refl a)

-- Next we want to prove:
-- trans : {A : Set} {x y z : A} → (x ≡ y) → (y ≡ z) → (x ≡ z)
-- if we try to directly use J we discover that the definition of R
-- (λ {x} {y} p → y ≡ z → x ≡ z)
-- refers to an unbound z

trans' : {A : Set} {x y : A} → (x ≡ y) → ((z : A) → (q : y ≡ z) → (x ≡ z))
trans' {A} =
  J (λ {x} {y} p → ((z : A) → (q : y ≡ z) → (x ≡ z)))
    (λ a z → id)

-- then

trans : {A : Set} {x y z : A} → (x ≡ y) → (y ≡ z) → (x ≡ z)
trans {A} {x} {y} {z} p q = trans' {A} {x} {y} p z q

-- trans' refl q will simplify to q because we did induction on the first argument

idR : {A : Set} {x y : A} (q : x ≡ y) → trans (refl x) q ≡ q
idR q = refl q

-- but trans' p refl will NOT simplify

-- idL : {A : Set} {x y : A} (p : x ≡ y) → trans p (refl y) ≡ p
-- idL p = refl p -- does not work

-- We can do induction on the right and get the reverse situation
-- OR we can do induction twice and lose BOTH and ONLY get
-- trans refl refl = refl
-- Even though this seems "worse", it is symmetric at least and easy to work is.

trans2' : {A : Set} {x y : A} → (x ≡ y) → ((z : A) → (q : y ≡ z) → (x ≡ z))
trans2' {A} =
  J (λ {x} {y} p → ((z : A) → (q : y ≡ z) → (x ≡ z)))
    (λ a z → J (λ {x'} {y'} q → x' ≡ y') (λ b → refl b))

trans2 : {A : Set} {x y z : A} → (x ≡ y) → (y ≡ z) → (x ≡ z)
trans2 {A} {x} {y} {z} p q = trans2' {A} {x} {y} p z q

idLR : {A : Set} {a : A} → trans2 (refl a) (refl a) ≡ refl a
idLR {A} {a} = refl (refl a)

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

-- If we restrict ourselves to proofs about "points" like numbers,
-- booleans, etc. all we are saying is that if we normalize the
-- calculation for each point they each reduce to same identical
-- result. Things get much more interesting if we start thinking about
-- identity in higher universes... So for example, say we want to
-- prove that groups are the same, in that case we might have to prove
-- that two types are the same etc. Unfortunately J by itself is
-- helpless here... This motivates the univalence axiom to be discussed next...

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


{-

This is the Agda formalization of

      NOTIONS OF ANONYMOUS EXISTENCE IN MARTIN-LOF TYPE THEORY

                              by

Nicolai Kraus, Martin Escardo, Thierry Coquand, Thorsten Altenkirch

This file stays very close to the article. Because of this, not all
proofs are given in the way that is most elegant for a formalization.
In fact, often re-ordering statements would lead to a shorter
presentation. The order that we have chosen in the article makes our
results, as we hope, understandable and gives sufficient motivation.

This file type check with Agda 2.4.2.5.
-}

module INDEX_NotionsOfAnonymousExistence where

-- We use the following library files:

open import library.Basics hiding (Type ; Σ)
open import library.types.Sigma
open import library.types.Pi
open import library.types.Bool
open import library.NType2
open import library.types.Paths

-- OUR FORMALIZATION

-- Section 1: Introduction
-- (no formalization)

-- Section 2: Preliminaries
open import Sec2preliminaries

-- Section 3: Hedberg's Theorem
open import Sec3hedberg

-- Section 4: Collapsibility implies H-Stability
open import Sec4hasConstToSplit

-- Section 5: Factorizing Weakly Constant Functions
open import Sec5factorConst

-- Section 6: Populatedness
open import Sec6populatedness

-- Section 7: Taboos and Counter-Models
open import Sec7taboos

-- Section 8: Propositional Truncation with Judgmental Computation Rule
open import Sec8judgmentalBeta

-- Section 9: Conclusion and Open Problems
-- (no formalization)


{-# OPTIONS --allow-unsolved-metas #-}
------------------------------------------------------------------------------
------------------------------------------------------------------------------
-- CS410 2017/18 Exercise 1  VECTORS AND FRIENDS (worth 25%)
------------------------------------------------------------------------------
------------------------------------------------------------------------------

-- NOTE (19/9/17) This file is currently incomplete: more will arrive on
-- GitHub.

-- MARK SCHEME (transcribed from paper): the (m) numbers add up to slightly
-- more than 25, so should be taken as the maximum number of marks losable on
-- the exercise. In fact, I did mark it negatively, but mostly because it was
-- done so well (with Agda's help) that it was easier to find the errors.

------------------------------------------------------------------------------
-- Dependencies
------------------------------------------------------------------------------

open import CS410-Prelude

------------------------------------------------------------------------------
-- Vectors
------------------------------------------------------------------------------

data Vec (X : Set) : Nat -> Set where  -- like lists, but length-indexed
  []   :                              Vec X zero
  _,-_ : {n : Nat} -> X -> Vec X n -> Vec X (suc n)
infixr 4 _,-_   -- the "cons" operator associates to the right

-- I like to use the asymmetric ,- to remind myself that the element is to
-- the left and the rest of the list is to the right.

-- Vectors are useful when there are important length-related safety
-- properties.

------------------------------------------------------------------------------
-- Heads and Tails
------------------------------------------------------------------------------

-- We can rule out nasty head and tail errors by insisting on nonemptiness!

--??--1.1-(2)-----------------------------------------------------------------

vHead : {X : Set}{n : Nat} -> Vec X (suc n) -> X
vHead xs = {!!}

vTail : {X : Set}{n : Nat} -> Vec X (suc n) -> Vec X n
vTail xs = {!!}

vHeadTailFact :  {X : Set}{n : Nat}(xs : Vec X (suc n)) ->
                 (vHead xs ,- vTail xs) == xs
vHeadTailFact xs = {!!}

--??--------------------------------------------------------------------------

------------------------------------------------------------------------------
-- Concatenation and its Inverse
------------------------------------------------------------------------------

--??--1.2-(2)-----------------------------------------------------------------

_+V_ : {X : Set}{m n : Nat} -> Vec X m -> Vec X n -> Vec X (m +N n)
xs +V ys = {!!}
infixr 4 _+V_

vChop : {X : Set}(m : Nat){n : Nat} -> Vec X (m +N n) -> Vec X m * Vec X n
vChop m xs = {!!}

vChopAppendFact : {X : Set}{m n : Nat}(xs : Vec X m)(ys : Vec X n) ->
                  vChop m (xs +V ys) == (xs , ys)
vChopAppendFact xs ys = {!!}

--??--------------------------------------------------------------------------

------------------------------------------------------------------------------
-- Map, take I
------------------------------------------------------------------------------

-- Implement the higher-order function that takes an operation on
-- elements and does it to each element of a vector. Use recursion
-- on the vector.
-- Note that the type tells you the size remains the same.

-- Show that if the elementwise function "does nothing", neither does
-- its vMap. "map of identity is identity"

-- Show that two vMaps in a row can be collapsed to just one, or
-- "composition of maps is map of compositions"

--??--1.3-(2)-----------------------------------------------------------------

vMap : {X Y : Set} -> (X -> Y) -> {n : Nat} -> Vec X n -> Vec Y n
vMap f xs = {!!}

vMapIdFact : {X : Set}{f : X -> X}(feq : (x : X) -> f x == x) ->
             {n : Nat}(xs : Vec X n) -> vMap f xs == xs
vMapIdFact feq xs = {!!}

vMapCpFact : {X Y Z : Set}{f : Y -> Z}{g : X -> Y}{h : X -> Z}
               (heq : (x : X) -> f (g x) == h x) ->
             {n : Nat}(xs : Vec X n) ->
               vMap f (vMap g xs) == vMap h xs
vMapCpFact heq xs = {!!}

--??--------------------------------------------------------------------------

------------------------------------------------------------------------------
-- vMap and +V
------------------------------------------------------------------------------

-- Show that if you've got two vectors of Xs and a function from X to Y,
-- and you want to concatenate and map, it doesn't matter which you do
-- first.

--??--1.4-(1)-----------------------------------------------------------------

vMap+VFact : {X Y : Set}(f : X -> Y) ->
             {m n : Nat}(xs : Vec X m)(xs' : Vec X n) ->
             vMap f (xs +V xs') == (vMap f xs +V vMap f xs')
vMap+VFact f xs xs' = {!!}

--??--------------------------------------------------------------------------

-- Think about what you could prove, relating vMap with vHead, vTail, vChop...
-- Now google "Philip Wadler" "Theorems for Free"

------------------------------------------------------------------------------
-- Applicative Structure (giving mapping and zipping cheaply)
------------------------------------------------------------------------------

--??--1.5-(2)-----------------------------------------------------------------

-- HINT: you will need to override the default invisibility of n to do this.
vPure : {X : Set} -> X -> {n : Nat} -> Vec X n
vPure x {n} = {!!}

_$V_ : {X Y : Set}{n : Nat} -> Vec (X -> Y) n -> Vec X n -> Vec Y n
fs $V xs = {!!}
infixl 3 _$V_  -- "Application associates to the left,
               --  rather as we all did in the sixties." (Roger Hindley)

-- Pattern matching and recursion are forbidden for the next two tasks.

-- implement vMap again, but as a one-liner
vec : {X Y : Set} -> (X -> Y) -> {n : Nat} -> Vec X n -> Vec Y n
vec f xs = {!!}

-- implement the operation which pairs up corresponding elements
vZip : {X Y : Set}{n : Nat} -> Vec X n -> Vec Y n -> Vec (X * Y) n
vZip xs ys = {!!}

--??--------------------------------------------------------------------------

------------------------------------------------------------------------------
-- Applicative Laws
------------------------------------------------------------------------------

-- According to "Applicative programming with effects" by
--   Conor McBride and Ross Paterson
-- some laws should hold for applicative functors.
-- Check that this is the case.

--??--1.6-(2)-----------------------------------------------------------------

vIdentity : {X : Set}{f : X -> X}(feq : (x : X) -> f x == x) ->
            {n : Nat}(xs : Vec X n) -> (vPure f $V xs) == xs
vIdentity feq xs = {!!}

vHomomorphism : {X Y : Set}(f : X -> Y)(x : X) ->
                {n : Nat} -> (vPure f $V vPure x) == vPure (f x) {n}
vHomomorphism f x {n} = {!!}

vInterchange : {X Y : Set}{n : Nat}(fs : Vec (X -> Y) n)(x : X) ->
               (fs $V vPure x) == (vPure (_$ x) $V fs)
vInterchange fs x = {!!}

vComposition : {X Y Z : Set}{n : Nat}
               (fs : Vec (Y -> Z) n)(gs : Vec (X -> Y) n)(xs : Vec X n) ->
               (vPure _<<_ $V fs $V gs $V xs) == (fs $V (gs $V xs))
vComposition fs gs xs = {!!}

--??--------------------------------------------------------------------------

------------------------------------------------------------------------------
-- Order-Preserving Embeddings (also known in the business as "thinnings")
------------------------------------------------------------------------------

-- What have these to do with Pascal's Triangle?

data _<=_ : Nat -> Nat -> Set where
  oz :                          zero  <= zero
  os : {n m : Nat} -> n <= m -> suc n <= suc m
  o' : {n m : Nat} -> n <= m ->     n <= suc m

-- Find all the values in each of the following <= types.
-- This is a good opportunity to learn to use C-c C-a with the -l option
--   (a.k.a. "google the type" without "I feel lucky")
-- The -s n option also helps.

--??--1.7-(1)-----------------------------------------------------------------

all0<=4 : Vec (0 <= 4) {!!}
all0<=4 = {!!}

all1<=4 : Vec (1 <= 4) {!!}
all1<=4 = {!!}

all2<=4 : Vec (2 <= 4) {!!}
all2<=4 = {!!}

all3<=4 : Vec (3 <= 4) {!!}
all3<=4 = {!!}

all4<=4 : Vec (4 <= 4) {!!}
all4<=4 = {!!}

-- Prove the following. A massive case analysis "rant" is fine.

no5<=4 : 5 <= 4 -> Zero
no5<=4 th = {!!}

--??--------------------------------------------------------------------------

------------------------------------------------------------------------------
-- Order-Preserving Embeddings Select From Vectors
------------------------------------------------------------------------------

-- Use n <= m to encode the choice of n elements from an m-Vector.
-- The os constructor tells you to take the next element of the vector;
-- the o' constructor tells you to omit the next element of the vector.

--??--1.8-(2)-----------------------------------------------------------------

_<?=_ : {X : Set}{n m : Nat} -> n <= m -> Vec X m
                     -> Vec X n
th <?= xs = {!!}

-- it shouldn't matter whether you map then select or select then map

vMap<?=Fact : {X Y : Set}(f : X -> Y)
              {n m : Nat}(th : n <= m)(xs : Vec X m) ->
              vMap f (th <?= xs) == (th <?= vMap f xs)
vMap<?=Fact f th xs = {!!}

--??--------------------------------------------------------------------------

------------------------------------------------------------------------------
-- Our Favourite Thinnings
------------------------------------------------------------------------------

-- Construct the identity thinning and the empty thinning.

--??--1.9-(1)-----------------------------------------------------------------

oi : {n : Nat} -> n <= n
oi {n}  = {!!}

oe : {n : Nat} -> 0 <= n
oe {n}  = {!!}

--??--------------------------------------------------------------------------

-- Show that all empty thinnings are equal to yours.

--??--1.10-(1)----------------------------------------------------------------

oeUnique : {n : Nat}(th : 0 <= n) -> th == oe
oeUnique i = {!!}

--??--------------------------------------------------------------------------

-- Show that there are no thinnings of form big <= small  (TRICKY)
-- Then show that all the identity thinnings are equal to yours.
-- Note that you can try the second even if you haven't finished the first.
-- HINT: you WILL need to expose the invisible numbers.
-- HINT: check CS410-Prelude for a reminder of >=

--??--1.11-(3)----------------------------------------------------------------

oTooBig : {n m : Nat} -> n >= m -> suc n <= m -> Zero
oTooBig {n} {m} n>=m th = {!!}

oiUnique : {n : Nat}(th : n <= n) -> th == oi
oiUnique th = {!!}

--??--------------------------------------------------------------------------

-- Show that the identity thinning selects the whole vector

--??--1.12-(1)----------------------------------------------------------------

id-<?= : {X : Set}{n : Nat}(xs : Vec X n) -> (oi <?= xs) == xs
id-<?= xs = {!!}

--??--------------------------------------------------------------------------

------------------------------------------------------------------------------
-- Composition of Thinnings
------------------------------------------------------------------------------

-- Define the composition of thinnings and show that selecting by a
-- composite thinning is like selecting then selecting again.
-- A small bonus applies to minimizing the length of the proof.
-- To collect the bonus, you will need to think carefully about
-- how to make the composition as *lazy* as possible.

--??--1.13-(3)----------------------------------------------------------------

_o>>_ : {p n m : Nat} -> p <= n -> n <= m -> p <= m
th o>> th' = {!!}

cp-<?= : {p n m : Nat}(th : p <= n)(th' : n <= m) ->
         {X : Set}(xs : Vec X m) ->
         ((th o>> th') <?= xs) == (th <?= (th' <?= xs))
cp-<?= th th' xs = {!!}

--??--------------------------------------------------------------------------

------------------------------------------------------------------------------
-- Thinning Dominoes
------------------------------------------------------------------------------

--??--1.14-(3)----------------------------------------------------------------

idThen-o>> : {n m : Nat}(th : n <= m) -> (oi o>> th) == th
idThen-o>> th = {!!}

idAfter-o>> : {n m : Nat}(th : n <= m) -> (th o>> oi) == th
idAfter-o>> th = {!!}

assoc-o>> : {q p n m : Nat}(th0 : q <= p)(th1 : p <= n)(th2 : n <= m) ->
            ((th0 o>> th1) o>> th2) == (th0 o>> (th1 o>> th2))
assoc-o>> th0 th1 th2 = {!!}

--??--------------------------------------------------------------------------

------------------------------------------------------------------------------
-- Vectors as Arrays
------------------------------------------------------------------------------

-- We can use 1 <= n as the type of bounded indices into a vector and do
-- a kind of "array projection". First we select a 1-element vector from
-- the n-element vector, then we take its head to get the element out.

vProject : {n : Nat}{X : Set} -> Vec X n -> 1 <= n -> X
vProject xs i = vHead (i <?= xs)

-- Your (TRICKY) mission is to reverse the process, tabulating a function
-- from indices as a vector. Then show that these operations are inverses.

--??--1.15-(3)----------------------------------------------------------------

-- HINT: composition of functions
vTabulate : {n : Nat}{X : Set} -> (1 <= n -> X) -> Vec X n
vTabulate {n} f = {!!}

-- This should be easy if vTabulate is correct.
vTabulateProjections : {n : Nat}{X : Set}(xs : Vec X n) ->
                       vTabulate (vProject xs) == xs
vTabulateProjections xs = {!!}

-- HINT: oeUnique
vProjectFromTable : {n : Nat}{X : Set}(f : 1 <= n -> X)(i : 1 <= n) ->
                    vProject (vTabulate f) i == f i
vProjectFromTable f i = {!!}

--??--------------------------------------------------------------------------


-- Simple test to check if constraint solving for injective
-- functions is working.
module Injectivity where

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

_+_ : Nat -> Nat -> Nat
zero  + m = m
suc n + m = suc (n + m)

{-# BUILTIN NATURAL Nat  #-}
{-# BUILTIN ZERO    zero #-}
{-# BUILTIN SUC     suc  #-}
{-# BUILTIN NATPLUS _+_  #-}

infixr 40 _::_
data List (A : Set) : Set where
  []   : List A
  _::_ : A -> List A -> List A

foldr : {A B : Set} -> (A -> B -> B) -> B -> List A -> B
foldr f z []        = z
foldr f z (x :: xs) = f x (foldr f z xs)

data U : Set where
  nat  : U
  list : U -> U

El : U -> Set
El nat      = Nat
El (list a) = List (El a)

sum : {a : U} -> El a -> Nat
sum {nat}    n  = n
sum {list a} xs = foldr (\a b -> sum a + b) zero xs

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

test₁ = sum (1 :: 2 :: 3 :: [])

ok₁ : test₁ == 6
ok₁ = refl

test₂ = sum ((1 :: []) :: (3 :: 5 :: []) :: [])

ok₂ : test₂ == 9
ok₂ = refl


open import Common.Prelude
open import Common.Equality

infixr 5 _∷_

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

record Eq (A : Set) : Set where
  field
    _==_ : (x y : A) → Maybe (x ≡ y)

open Eq {{...}}

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

eqNat : ∀ n m → Maybe (n ≡ m)
eqNat zero zero = just refl
eqNat zero (suc m) = nothing
eqNat (suc n) zero = nothing
eqNat (suc n) (suc m) with eqNat n m
eqNat (suc n) (suc m) | nothing = nothing
eqNat (suc n) (suc .n) | just refl = just refl

eqVec : ∀ {A n} {{EqA : Eq A}} (xs ys : Vec A n) → Maybe (xs ≡ ys)
eqVec [] [] = just refl
eqVec (x ∷ xs) ( y ∷  ys) with x == y    | eqVec xs ys
eqVec (x ∷ xs) ( y ∷  ys)    | nothing   | _         = nothing
eqVec (x ∷ xs) ( y ∷  ys)    | _         | nothing   = nothing
eqVec (x ∷ xs) (.x ∷ .xs)    | just refl | just refl = just refl

eqSigma : ∀ {A B} {{EqA : Eq A}} {{EqB : ∀ {x} → Eq (B x)}} (x y : Σ A B) → Maybe (x ≡ y)
eqSigma (x , y) (x₁ , y₁) with x == x₁
eqSigma (x , y) (x₁ , y₁) | nothing = nothing
eqSigma (x , y) (.x , y₁) | just refl with y == y₁
eqSigma (x , y) (.x , y₁) | just refl | nothing = nothing
eqSigma (x , y) (.x , .y) | just refl | just refl = just refl

instance
  EqNat : Eq Nat
  EqNat = record { _==_ = eqNat }

  EqVec : ∀ {A n} {{_ : Eq A}} → Eq (Vec A n)
  EqVec = record { _==_ = eqVec }

  EqSigma : ∀ {A B} {{_ : Eq A}} {{_ : ∀ {x} → Eq (B x)}} → Eq (Σ A B)
  EqSigma = record { _==_ = eqSigma }

cmpSigma : (xs ys : Σ Nat (Vec Nat)) → Maybe (xs ≡ ys)
cmpSigma xs ys = xs == ys


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

open import Level using (_⊔_; suc)
open import Relation.Unary using (Pred)

open import Categories.Category.Core using (Category)
open import Categories.Functor.Core using (Functor)
open import Categories.Morphism using (Iso)

record HasDagger {o ℓ e} (C : Category o ℓ e) : Set (o ⊔ ℓ ⊔ e) where
  open Category C
  infix 10 _†

  field
    _† : ∀ {A B} → A ⇒ B → B ⇒ A
    †-identity : ∀ {A} → id {A} † ≈ id
    †-homomorphism : ∀ {A B C} {f : A ⇒ B} {g : B ⇒ C} → (g ∘ f) † ≈ f † ∘ g †
    †-resp-≈ : ∀ {A B} {f g : A ⇒ B} → f ≈ g → f † ≈ g †
    †-involutive : ∀ {A B} (f : A ⇒ B) → f † † ≈ f

  †-Functor : Functor op C
  †-Functor = record
    { F₀ = λ A → A
    ; F₁ = _†
    ; identity = †-identity
    ; homomorphism = †-homomorphism
    ; F-resp-≈ = †-resp-≈
    }

  isUnitary : ∀ {A B} → Pred (A ⇒ B) e
  isUnitary f = Iso C f (f †)

  isSelfAdjoint : ∀ {A} → Pred (A ⇒ A) e
  isSelfAdjoint f = f † ≈ f

record DaggerCategory o ℓ e : Set (suc (o ⊔ ℓ ⊔ e)) where
  field
    C : Category o ℓ e
    hasDagger : HasDagger C

  open Category C public
  open HasDagger hasDagger public


------------------------------------------------------------------------
-- The Agda standard library
--
-- A bunch of properties about natural number operations
------------------------------------------------------------------------

module Data.Nat.Properties.Simple where

open import Data.Nat as Nat
open import Function
open import Relation.Binary.PropositionalEquality as PropEq
  using (_≡_; _≢_; refl; sym; cong; cong₂)
open PropEq.≡-Reasoning
open import Data.Product
open import Data.Sum

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

+-assoc : ∀ m n o → (m + n) + o ≡ m + (n + o)
+-assoc zero    _ _ = refl
+-assoc (suc m) n o = cong suc $ +-assoc m n o

+-right-identity : ∀ n → n + 0 ≡ n
+-right-identity zero = refl
+-right-identity (suc n) = cong suc $ +-right-identity n

+-suc : ∀ m n → m + suc n ≡ suc (m + n)
+-suc zero    n = refl
+-suc (suc m) n = cong suc (+-suc m n)

+-comm : ∀ m n → m + n ≡ n + m
+-comm zero    n = sym $ +-right-identity n
+-comm (suc m) n =
  begin
    suc m + n
  ≡⟨ refl ⟩
    suc (m + n)
  ≡⟨ cong suc (+-comm m n) ⟩
    suc (n + m)
  ≡⟨ sym (+-suc n m) ⟩
    n + suc m
  ∎

+-*-suc : ∀ m n → m * suc n ≡ m + m * n
+-*-suc zero    n = refl
+-*-suc (suc m) n =
  begin
    suc m * suc n
  ≡⟨ refl ⟩
    suc n + m * suc n
  ≡⟨ cong (λ x → suc n + x) (+-*-suc m n) ⟩
    suc n + (m + m * n)
  ≡⟨ refl ⟩
    suc (n + (m + m * n))
  ≡⟨ cong suc (sym $ +-assoc n m (m * n)) ⟩
    suc (n + m + m * n)
  ≡⟨ cong (λ x → suc (x + m * n)) (+-comm n m) ⟩
    suc (m + n + m * n)
  ≡⟨ cong suc (+-assoc m n (m * n)) ⟩
    suc (m + (n + m * n))
  ≡⟨ refl ⟩
    suc m + suc m * n
  ∎

*-right-zero : ∀ n → n * 0 ≡ 0
*-right-zero zero = refl
*-right-zero (suc n) = *-right-zero n

*-comm : ∀ m n → m * n ≡ n * m
*-comm zero    n = sym $ *-right-zero n
*-comm (suc m) n =
  begin
    suc m * n
  ≡⟨ refl ⟩
    n + m * n
  ≡⟨ cong (λ x → n + x) (*-comm m n) ⟩
    n + n * m
  ≡⟨ sym (+-*-suc n m) ⟩
    n * suc m
  ∎

distribʳ-*-+ : ∀ m n o → (n + o) * m ≡ n * m + o * m
distribʳ-*-+ m zero    o = refl
distribʳ-*-+ m (suc n) o =
  begin
    (suc n + o) * m
  ≡⟨ refl ⟩
    m + (n + o) * m
  ≡⟨ cong (_+_ m) $ distribʳ-*-+ m n o ⟩
    m + (n * m + o * m)
  ≡⟨ sym $ +-assoc m (n * m) (o * m) ⟩
    m + n * m + o * m
  ≡⟨ refl ⟩
    suc n * m + o * m
  ∎

*-assoc : ∀ m n o → (m * n) * o ≡ m * (n * o)
*-assoc zero    n o = refl
*-assoc (suc m) n o =
  begin
    (suc m * n) * o
  ≡⟨ refl ⟩
    (n + m * n) * o
  ≡⟨ distribʳ-*-+ o n (m * n) ⟩
    n * o + (m * n) * o
  ≡⟨ cong (λ x → n * o + x) $ *-assoc m n o ⟩
    n * o + m * (n * o)
  ≡⟨ refl ⟩
    suc m * (n * o)
  ∎


-- statically checked sorted lists
-- see http://www2.tcs.ifi.lmu.de/~abel/DepTypes.pdf

module SortedList where

open import Data.Nat using (ℕ; zero; suc; _+_; _*_)
open import Data.Bool using (Bool; true; false)

----------------------------------------------------------------------
-- Curry-Howard stuff

Proposition = Set

-- intentionally blank. signifies the empty set in the type system.
data Absurd : Proposition where

-- tt = trivially true
data Truth : Proposition where
  tt : Truth

-- ∧ = conjunction
data _∧_ (A B : Proposition) : Proposition where
    _,_ : A → B → A ∧ B

fst : {A B : Proposition} → A ∧ B → A
fst (a , b) = a

snd : {A B : Proposition} → A ∧ B → B
snd (a , b) = b

-- Cartesian product = conjunction
_×_ = _∧_

-- ∨ = disjunction
data _∨_ (A B : Proposition) : Proposition where
  inl : A → A ∨ B
  inr : B → A ∨ B

-- given: A or B is true, A implies C, B implies C. then C is true.
case : {A B C : Proposition} → A ∨ B → (A → C) → (B → C) → C
case (inl a) f g = f a
case (inr b) f g = g b

-- map booleans to propositions by mapping true to Truth and false to Absurd
True : Bool → Proposition
True true = Truth
True false = Absurd

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

_≤_ : ℕ → ℕ → Bool
zero ≤ n = true
suc m ≤ zero = false
suc m ≤ suc n = m ≤ n

-- proposition: ≤ is reflexive. proof: induction.
refl≤ : (n : ℕ) → True (n ≤ n)
refl≤ zero = tt
refl≤ (suc n) = refl≤ n

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

data SortedList : ℕ → Set where
  ∅ : SortedList zero
  ⋉ : {n : ℕ} (m : ℕ) → True (n ≤ m) → SortedList n → SortedList m

-- the arguments to ⋉ are
-- m : a natural number to prepend to the given sorted list xs
-- p : a proof that m (the new head) is ≥ head xs
-- xs : a list such that head xs = n

-- for constant natural numbers, proofs that n ≤ m are trivial since
-- ≤ is decidable; this is why we pass in `tt` in the examples below

-- examples:
one : ℕ
one = suc zero

s1 = ⋉ one tt (⋉ zero tt ∅)
-- s2 = ⋉ zero tt (⋉ one tt ∅) -- fails statically, as desired
s3 = ⋉ one tt s1       -- normal form: ⋉ 1 tt (⋉ 1 tt (⋉ 0 tt ∅))
s4 = ⋉ (suc one) tt s1 -- normal form: ⋉ 2 tt (⋉ 1 tt (⋉ 0 tt ∅))


module Haskell.Prim.Tuple where

open import Agda.Builtin.List

open import Haskell.Prim

private
  variable
    as : List Set

--------------------------------------------------
-- Tuples

infixr 5 _∷_
data Tuple : List Set → Set where
  []  : Tuple []
  _∷_ : a → Tuple as → Tuple (a ∷ as)

infix 3 _×_ _×_×_

_×_ : (a b : Set) → Set
a × b = Tuple (a ∷ b ∷ [])

_×_×_ : (a b c : Set) → Set
a × b × c = Tuple (a ∷ b ∷ c ∷ [])

infix -1 _,_ _,_,_

pattern _,_     x y     = x Tuple.∷ y Tuple.∷ []
pattern _,_,_   x y z   = x Tuple.∷ y Tuple.∷ z Tuple.∷ []

uncurry : (a → b → c) → a × b → c
uncurry f (x , y) = f x y

curry : (a × b → c) → a → b → c
curry f x y = f (x , y)

fst : a × b → a
fst (x , _) = x

snd : a × b → b
snd (_ , y) = y

first : (a → b) → a × c → b × c
first f (x , y) = f x , y

second : (a → b) → c × a → c × b
second f (x , y) = x , f y

_***_ : (a → b) → (c → d) → a × c → b × d
(f *** g) (x , y) = f x , g y


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

open import LogicalFormulae
open import Functions.Definition
open import Lists.Definition
open import Lists.Monad
open import Boolean.Definition

module Lists.Filter.AllTrue where

allTrue : {a b : _} {A : Set a} (f : A → Set b) (l : List A) → Set b
allTrue f [] = True'
allTrue f (x :: l) = f x && allTrue f l

allTrueConcat : {a b : _} {A : Set a} (f : A → Set b) (l m : List A) → allTrue f l → allTrue f m → allTrue f (l ++ m)
allTrueConcat f [] m fl fm = fm
allTrueConcat f (x :: l) m (fst ,, snd) fm = fst ,, allTrueConcat f l m snd fm

allTrueFlatten : {a b : _} {A : Set a} (f : A → Set b) (l : List (List A)) → allTrue (λ i → allTrue f i) l → allTrue f (flatten l)
allTrueFlatten f [] pr = record {}
allTrueFlatten f ([] :: ls) pr = allTrueFlatten f ls (_&&_.snd pr)
allTrueFlatten f ((x :: l) :: ls) ((fx ,, fl) ,, snd) = fx ,, allTrueConcat f l (flatten ls) fl (allTrueFlatten f ls snd)

allTrueMap : {a b c : _} {A : Set a} {B : Set b} (pred : B → Set c) (f : A → B) (l : List A) → allTrue (pred ∘ f) l → allTrue pred (map f l)
allTrueMap pred f [] pr = record {}
allTrueMap pred f (x :: l) pr = _&&_.fst pr ,, allTrueMap pred f l (_&&_.snd pr)

allTrueExtension : {a b : _} {A : Set a} (f g : A → Set b) (l : List A) → ({x : A} → f x → g x) → allTrue f l → allTrue g l
allTrueExtension f g [] pred t = record {}
allTrueExtension f g (x :: l) pred (fg ,, snd) = pred {x} fg ,, allTrueExtension f g l pred snd

allTrueTail : {a b : _} {A : Set a} (pred : A → Set b) (x : A) (l : List A) → allTrue pred (x :: l) → allTrue pred l
allTrueTail pred x l (fst ,, snd) = snd

filter : {a : _} {A : Set a} (l : List A) (f : A → Bool) → List A
filter [] f = []
filter (x :: l) f with f x
filter (x :: l) f | BoolTrue = x :: filter l f
filter (x :: l) f | BoolFalse = filter l f


{-

          Types Summer School 2007

                 Bertinoro
             Aug 19 - 31, 2007

                   Agda

                Ulf Norell

-}

-- Now we're getting somewhere! Inductive families of datatypes.

module Families where

-- You can import modules defined in other files.
-- More details later...
-- open import Nat

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

_+_ : Nat -> Nat -> Nat
zero + m = m
suc n + m = suc (n + m)

-- Think of an inductive family...

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

infixr 40 _::_

-- Some simple functions
head : {A : Set}{n : Nat} -> Vec A (suc n) -> A
head (x :: _) = x  -- no need for a [] case

-- Does the definition look familiar?
map : {A B : Set}{n : Nat} -> (A -> B) -> Vec A n -> Vec B n
map f []        = []
map f (x :: xs) = f x :: map f xs

infixr 40 _++_

_++_ : {A : Set}{n m : Nat} -> Vec A n -> Vec A m -> Vec A (n + m)
[]        ++ ys = ys
(x :: xs) ++ ys = x :: (xs ++ ys)

-- Why does this type check? Let's walk through it slowly.
-- When pattern matching on the first vector, n is instantiated.

-- What happens if we make the lengths explicit?

cat : {A : Set}(n m : Nat) -> Vec A n -> Vec A m -> Vec A (n + m)
cat .zero    m []              ys = ys
cat .(suc n) m (_::_ {n} x xs) ys = x :: (cat n m xs ys)

-- Patterns which get instantiated by pattern matching on other stuff
-- get tagged by a dot. If you erase all the dotted things you get a
-- well-formed linear first-order pattern.

-- Inside the dot we could have arbitrary terms. For instance,

data Image_∋_ {A B : Set}(f : A -> B) : B -> Set where
  im : (x : A) -> Image f ∋ f x

inv : {A B : Set}(f : A -> B)(y : B) -> Image f ∋ y -> A
inv f .(f x) (im x) = x

-- Let's do some other interesting families.

-- The identity type.
data _==_ {A : Set} : A -> A -> Set where
  refl : (x : A) -> x == x

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

-- Finite sets

{-

Fin zero        -
Fin (suc zero)  fzero
Fin 2           fzero, fsuc fzero

-}

data Fin : Nat -> Set where
  fzero : {n : Nat} -> Fin (suc n)
  fsuc  : {n : Nat} -> Fin n -> Fin (suc n)

_!_ : {A : Set}{n : Nat} -> Vec A n -> Fin n -> A
[]        ! ()
(x :: xs) ! fzero  = x
(x :: xs) ! fsuc i = xs ! i

{-

  What's next?

-}

-- Actually, inductive families are sufficiently fun that
-- you'll never get bored, but there's even more fun to be had.

-- Move on to: Filter.agda


------------------------------------------------------------------------------
-- Inductive PA properties
------------------------------------------------------------------------------

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

module PA.Inductive.PropertiesI where

open import PA.Inductive.Base
open import PA.Inductive.Relation.Binary.EqReasoning

------------------------------------------------------------------------------
-- Congruence properties

succCong : ∀ {m n} → m ≡ n → succ m ≡ succ n
succCong refl = refl

+-leftCong : ∀ {m n o} → m ≡ n → m + o ≡ n + o
+-leftCong refl = refl

+-rightCong : ∀ {m n o} → n ≡ o → m + n ≡ m + o
+-rightCong refl = refl

------------------------------------------------------------------------------
-- Peano's third axiom.
P₃ : ∀ {m n} → succ m ≡ succ n → m ≡ n
P₃ refl = refl

-- Peano's fourth axiom.
P₄ : ∀ {n} → zero ≢ succ n
P₄ ()

x≢Sx : ∀ {n} → n ≢ succ n
x≢Sx {zero} ()
x≢Sx {succ n} h = x≢Sx (P₃ h)

+-leftIdentity : ∀ n → zero + n ≡ n
+-leftIdentity n = refl

-- Adapted from the Agda standard library 0.8.1 (see
-- Data.Nat.Properties.Simple.+-rightIdentity).
+-rightIdentity : ∀ n → n + zero ≡ n
+-rightIdentity zero     = refl
+-rightIdentity (succ n) = succCong (+-rightIdentity n)

-- Adapted from the Agda standard library_0.8.1 (see
-- Data.Nat.Properties.Simple.+-assoc).
+-assoc : ∀ m n o → m + n + o ≡ m + (n + o)
+-assoc zero     _ _ = refl
+-assoc (succ m) n o = succCong (+-assoc m n o)

-- Adapted from the Agda standard library 0.8.1 (see
-- Data.Nat.Properties.Simple.+-suc).
x+Sy≡S[x+y] : ∀ m n → m + succ n ≡ succ (m + n)
x+Sy≡S[x+y] zero     _ = refl
x+Sy≡S[x+y] (succ m) n = succCong (x+Sy≡S[x+y] m n)

-- Adapted from the Agda standard library 0.8.1 (see
-- Data.Nat.Properties.Simple.+-comm).
+-comm : ∀ m n → m + n ≡ n + m
+-comm zero     n = sym (+-rightIdentity n)
+-comm (succ m) n = succ (m + n) ≡⟨ succCong (+-comm m n) ⟩
                    succ (n + m) ≡⟨ sym (x+Sy≡S[x+y] n m) ⟩
                    n + succ m   ∎


module Unique where

open import Category

module Uniq (ℂ : Cat) where

  private open module C = Cat ℂ

  -- We say that f ∈! P iff f is the unique arrow satisfying P.
  data _∈!_ {A B : Obj}(f : A ─→ B)(P : A ─→ B -> Set) : Set where
    unique : (forall g -> P g -> f == g) -> f ∈! P

  itsUnique : {A B : Obj}{f : A ─→ B}{P : A ─→ B -> Set} ->
	      f ∈! P -> (g : A ─→ B) -> P g -> f == g
  itsUnique (unique h) = h

  data ∃! {A B : Obj}(P : A ─→ B -> Set) : Set where
    witness : (f : A ─→ B) -> f ∈! P -> ∃! P

  getWitness : {A B : Obj}{P : A ─→ B -> Set} -> ∃! P -> A ─→ B
  getWitness (witness w _) = w

  uniqueWitness : {A B : Obj}{P : A ─→ B -> Set}(u : ∃! P) ->
		  getWitness u ∈! P
  uniqueWitness (witness _ u) = u

  witnessEqual : {A B : Obj}{P : A ─→ B -> Set} -> ∃! P ->
		 {f g : A ─→ B} -> P f -> P g -> f == g
  witnessEqual u {f} {g} pf pg = trans (sym hf) hg
    where
      h = getWitness u

      hf : h == f
      hf = itsUnique (uniqueWitness u) f pf

      hg : h == g
      hg = itsUnique (uniqueWitness u) g pg


{-# OPTIONS --rewriting #-}

module RewritingNat where

open import Common.Equality

{-# BUILTIN REWRITE _≡_ #-}

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

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

plusAssoc : ∀ x {y z : Nat} → ((x + y) + z) ≡ (x + (y + z))
plusAssoc zero = refl
plusAssoc (suc x) {y} {z} rewrite plusAssoc x {y} {z} = refl

plus0T : Set
plus0T = ∀{x} → (x + zero) ≡ x

plusSucT : Set
plusSucT = ∀{x y} → (x + (suc y)) ≡ suc (x + y)

postulate
  plus0p : plus0T
  {-# REWRITE plus0p #-}

  plusSucp : plusSucT

{-# REWRITE plusSucp plusAssoc #-}

plus0 : plus0T
plus0 = refl

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

-- Needs REWRITE plus0p plusSucp
reverseAcc : ∀{A n m} → Vec A n → Vec A m → Vec A (n + m)
reverseAcc [] acc = acc
reverseAcc (x ∷ xs) acc = reverseAcc xs (x ∷ acc)

append : ∀{A n m} → Vec A n → Vec A m → Vec A (n + m)
append []       ys = ys
append (x ∷ xs) ys = x ∷ append xs ys

-- Note: appendAssoc needs REWRITE plusAssoc to be well-typed.
appendAssoc : ∀{A n m l} (u : Vec A n) {v : Vec A m}{w : Vec A l} →
  append (append u v) w ≡ append u (append v w)
appendAssoc [] = refl
appendAssoc (x ∷ xs) {v} {w} rewrite appendAssoc xs {v} {w} = refl


{-# OPTIONS --type-in-type #-}
module Record where

infixr 2 _,_
record Σ (A : Set)(B : A → Set) : Set where
  constructor _,_
  field fst : A
        snd : B fst

open Σ

data ⊤ : Set where
  tt : ⊤

∃ : {A : Set}(B : A → Set) → Set
∃ B = Σ _ B

infix 10 _≡_

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

trans : ∀ {A B C}{a : A}{b : B}{c : C} → a ≡ b → b ≡ c → a ≡ c
trans refl p = p

sym : ∀ {A B}{a : A}{b : B} → a ≡ b → b ≡ a
sym refl = refl

resp : ∀ {A}{B : A → Set}{a a' : A} →
       (f : (a : A) → B a) → a ≡ a' → f a ≡ f a'
resp f refl = refl

Cat : Set
Cat =
  ∃ λ (Obj : Set) →
  ∃ λ (Hom : Obj → Obj → Set) →
  ∃ λ (id : ∀ X → Hom X X) →
  ∃ λ (_○_ : ∀ {X Y Z} → Hom Y Z → Hom X Y → Hom X Z) →
  ∃ λ (idl : ∀ {X Y}{f : Hom X Y} → id Y ○ f ≡ f) →
  ∃ λ (idr : ∀ {X Y}{f : Hom X Y} → f ○ id X ≡ f) →
  ∃ λ (assoc : ∀ {W X Y Z}{f : Hom W X}{g : Hom X Y}{h : Hom Y Z} →
                (h ○ g) ○ f ≡ h ○ (g ○ f)) →
  ⊤

Obj : (C : Cat) → Set
Obj C = fst C

Hom : (C : Cat) → Obj C → Obj C → Set
Hom C = fst (snd C)

id : (C : Cat) → ∀ X → Hom C X X
id C = fst (snd (snd C))

comp : (C : Cat) → ∀ {X Y Z} → Hom C Y Z → Hom C X Y → Hom C X Z
comp C = fst (snd (snd (snd C)))

idl : (C : Cat) → ∀ {X Y}{f : Hom C X Y} → comp C (id C Y) f ≡ f
idl C = fst (snd (snd (snd (snd C))))

idr : (C : Cat) → ∀ {X Y}{f : Hom C X Y} → comp C f (id C X) ≡ f
idr C = fst (snd (snd (snd (snd (snd C)))))

assoc : (C : Cat) → ∀ {W X Y Z}{f : Hom C W X}{g : Hom C X Y}{h : Hom C Y Z} →
        comp C (comp C h g) f ≡ comp C h (comp C g f)
assoc C = fst (snd (snd (snd (snd (snd (snd C))))))


module 747Negation where

-- Library

open import Relation.Binary.PropositionalEquality using (_≡_; refl) -- added last
open import Data.Nat using (ℕ; zero; suc)
open import Data.Empty using (⊥; ⊥-elim)
open import Data.Sum using (_⊎_; inj₁; inj₂)
open import Data.Product using (_×_; proj₁; proj₂)

-- Negation is defined as implying false.

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

-- if both ¬ A and A hold, then ⊥ holds (not surprisingly).

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

¬-elim = {!!}

infix 3 ¬_

-- Double negation introduction.

¬¬-intro : ∀ {A : Set}
  → A
    -----
  → ¬ ¬ A

¬¬-intro = {!!}

-- Double negation cannot be eliminated in intuitionistic logic.

-- Triple negation elimination.

¬¬¬-elim : ∀ {A : Set}
  → ¬ ¬ ¬ A
    -------
  → ¬ A

¬¬¬-elim = {!!}

-- One direction of the contrapositive.

contraposition : ∀ {A B : Set}
  → (A → B)
    -----------
  → (¬ B → ¬ A)

contraposition = {!!}

-- The other direction cannot be proved in intuitionistic logic.

-- not-equal-to.

_≢_ : ∀ {A : Set} → A → A → Set
x ≢ y  =  ¬ (x ≡ y)

_ : 1 ≢ 2
_ = {!!}

-- One of the first-order Peano axioms.

peano : ∀ {m : ℕ} → zero ≢ suc m
peano = {!!}

-- Copied from 747Isomorphism.

postulate
  extensionality : ∀ {A B : Set} {f g : A → B}
    → (∀ (x : A) → f x ≡ g x)
      -----------------------
    → f ≡ g

-- Two proofs of ⊥ → ⊥ which look different but are the same
-- (assuming extensionality).

id : ⊥ → ⊥
id x = x

id′ : ⊥ → ⊥
id′ ()

id≡id′ : id ≡ id′
id≡id′ = extensionality (λ())

-- Assuming extensionality, any two proofs of a negation are the same

assimilation : ∀ {A : Set} (¬x ¬x′ : ¬ A) → ¬x ≡ ¬x′
assimilation ¬x ¬x′ = extensionality λ x → ⊥-elim (¬x x)

-- Strict inequality (copied from 747Relations).

infix 4 _<_

data _<_ : ℕ → ℕ → Set where

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

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

-- 747/PLFA exercise: NotFourLTThree (1 point)
-- Show ¬ (4 < 3).

¬4<3 : ¬ (4 < 3)
¬4<3 = {!!}

-- 747/PLFA exercise: LTIrrefl (1 point)
-- < is irreflexive (never reflexive).

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

-- 747/PLFA exercise: LTTrich (3 points)
-- Show that strict inequality satisfies trichotomy,
-- in the sense that exactly one of the three possibilities holds.
-- Here is the expanded definition of trichotomy.

data Trichotomy (m n : ℕ) : Set where
  is-< : m < n → ¬ m ≡ n → ¬ n < m → Trichotomy m n
  is-≡ : m ≡ n → ¬ m < n → ¬ n < m → Trichotomy m n
  is-> : n < m → ¬ m ≡ n → ¬ m < n → Trichotomy m n

<-trichotomy : ∀ (m n : ℕ) → Trichotomy m n
<-trichotomy m n = {!!}

-- PLFA exercise: one of DeMorgan's Laws as isomorphism
-- ⊎-dual-× : ∀ {A B : Set} → ¬ (A ⊎ B) ≃ (¬ A) × (¬ B)
-- Expand negation as implies-false, then look in 747Relations
-- for a law of which this is a special case.

-- What about ¬ (A × B) ≃ (¬ A) ⊎ (¬ B)?
-- Answer: RHS implies LHS but converse cannot be proved in intuitionistic logic.

-- Intuitionistic vs classical logic.

-- The law of the excluded middle (LEM, or just em) cannot be
-- proved in intuitionistic logic.
-- But we can add it, and get classical logic.

-- postulate
--  em : ∀ {A : Set} → A ⊎ ¬ A

-- How do we know this does not give a contradiction?
-- The following theorem of intuitionistic logic demonstrates this.
-- (The proof is compact, but takes some thought.)

em-irrefutable : ∀ {A : Set} → ¬ ¬ (A ⊎ ¬ A)
em-irrefutable = {!!}

-- PLFA exercise: classical equivalences
-- Excluded middle cannot be proved in intuitionistic logic,
-- but adding it is consistent and gives classical logic.
-- Here are four other classical theorems with the same property.
-- You can show that each of them is logically equivalent to all the others.
-- You do not need to prove twenty implications, since implication is transitive.
-- But there is a lot of choice as to how to proceed!

-- Excluded Middle
em = ∀ {A : Set} → A ⊎ ¬ A

-- Double Negation Elimination
dne = ∀ {A : Set} → ¬ ¬ A → A

-- Peirce’s Law
peirce =  ∀ {A B : Set} → ((A → B) → A) → A

-- Implication as disjunction
iad =  ∀ {A B : Set} → (A → B) → ¬ A ⊎ B

-- De Morgan:
dem = ∀ {A B : Set} → ¬ (¬ A × ¬ B) → A ⊎ B

-- End of classical five exercise.

-- Definition: a formula is stable if double negation holds for it.

Stable : Set → Set
Stable A = ¬ ¬ A → A

-- PLFA exercise: every negated formula is stable.
-- This is triple negation elimination.

-- PLFA exercise: the conjunction of two stable formulas is stable.
-- This is the version of DeMorgan's Law that is a special case, above.

-- Where negation sits in the standard library.

import Relation.Nullary using (¬_)
import Relation.Nullary.Negation using (contraposition)

-- Unicode used in this chapter:

{-

  ¬  U+00AC  NOT SIGN (\neg)
  ≢  U+2262  NOT IDENTICAL TO (\==n)

-}


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

open import Level using (Level)

open import Relation.Binary.PropositionalEquality
open ≡-Reasoning

open import Data.Nat using (ℕ)
open import Data.Vec using (Vec; foldr; zipWith; map)

open import FLA.Algebra.Structures
open import FLA.Algebra.Properties.Field

module FLA.Algebra.LinearAlgebra where

private
  variable
    ℓ : Level
    A : Set ℓ
    m n p q : ℕ

module _ {ℓ : Level} {A : Set ℓ} ⦃ F : Field A ⦄ where
  open Field F

  -- Vector addition
  _+ⱽ_ : Vec A n → Vec A n → Vec A n
  _+ⱽ_ = zipWith _+_

  -- Vector substraction
  _-ⱽ_ : Vec A n → Vec A n → Vec A n
  a -ⱽ b = a +ⱽ (map (-_) b)

  -- Vector Hadamard product
  _*ⱽ_ : Vec A n → Vec A n → Vec A n
  _*ⱽ_ = zipWith _*_

  -- Multiply vector by a constant
  _∘ⱽ_ : A → Vec A n → Vec A n
  c ∘ⱽ v = map (c *_) v

  -- Match the fixity of Haskell
  infixl  6 _+ⱽ_
  infixl  6 _-ⱽ_
  infixl  7 _*ⱽ_
  infixl 10 _∘ⱽ_

  sum : Vec A n → A
  sum = foldr _ _+_ 0ᶠ

  -- Inner product
  ⟨_,_⟩ : Vec A n → Vec A n → A
  ⟨ v₁ , v₂ ⟩ = sum (v₁ *ⱽ v₂)


module x05isomorphism where

{-
------------------------------------------------------------------------------
Isomorphism: Isomorphism and Embedding

isomorphism
- way of asserting two types are equal

embedding
- way of asserting that one type is smaller than another

apply isomorphisms in next chapter to show 'product' and 'sum' satisfy properties
similar to associativity, commutativity, and distributivity
-}

import Relation.Binary.PropositionalEquality as Eq
open        Eq                  using (_≡_; refl; cong; cong-app)
open        Eq.≡-Reasoning
open import Data.Nat            using (ℕ; zero; suc; _+_)
open import Data.Nat.Properties using (+-comm)

{-
------------------------------------------------------------------------------
LAMBDA EXPRESSIONS : ANONYMOUS FUNS

λ{ P₁ → N₁; ⋯ ; Ppₙ → Np }

equivalent def by equations

f P₁ = N₁
⋯
f Pp = Npₙ

where
- P are patterns    (left-hand sides of an equation)
- N are expressions (right-hand side of an equation)

for case of one equation and pattern is a variable:

λ x → N

or

λ (x : A) → N

equivalent to

λ{x → N}

------------------------------------------------------------------------------
Function composition
-}

-- first apply f, then apply g to result
_∘_ : ∀ {A B C : Set} → (B → C) → (A → B) → (A → C)
(g ∘ f) x  = g (f x)

-- equivalent
_∘′_ : ∀ {A B C : Set} → (B → C) → (A → B) → (A → C)
g ∘′ f  =  λ x → g (f x)

{-
------------------------------------------------------------------------------
EXTENSIONALITY : only way to distinguish functions is by applying them

If two functions applied to same arg always give same result, then they are same.

converse of cong-app

Agda does not presume extensionality, so
-}

postulate
  extensionality : ∀ {A B : Set} {f g : A → B}
    → (∀ (x : A) → f x ≡ g x)
      -----------------------
    →              f   ≡ g

{-
Postulating extensionality does not lead to difficulties.
It is known to be consistent with the theory that underlies Agda.

example
-}

-- version that matches on right
_+′_ : ℕ → ℕ → ℕ
m +′ zero  = m
m +′ suc n = suc (m +′ n)

-- using commutativity, show + and +′ always return same result for same arg
same-app : ∀ (m n : ℕ) → m +′ n ≡ m + n
same-app m n                --     (m +′ n) ≡      m + n
  rewrite +-comm m n        --     (m +′ n) ≡      n + m
  = helper m n
 where
  helper : ∀ (m n : ℕ) → m +′ n ≡ n + m
  helper m   zero  = refl
  helper m (suc n)          -- suc (m +′ n) ≡ suc (n + m)
    = cong suc (helper m n)

-- now assert + and +′ to be indistinguishable (via two applications of extensionality)
same : _+′_ ≡ _+_
same = extensionality (λ m → extensionality (λ n → same-app m n))

{-
to postulate extensionality in what follows
(and to postulate extensionality for dependent functions):
-}

-- type of f and g has changed from A → B to ∀ (x : A) → B x
postulate
  ∀-extensionality : ∀ {A : Set} {B : A → Set} {f g : ∀(x : A) → B x}
    → (∀ (x : A) → f x ≡ g x)
      -----------------------
    →              f   ≡ g

{-
------------------------------------------------------------------------------
ISOMORPHISM : sets are isomorphic if they are in one-to-one correspondence

formal definition:
-}

infix 0 _≃_

-- RECORD
-- isomorphism between sets A and B consists of four things
record _≃_ (A B : Set) : Set where
  field
    to      : A → B                       -- function from A to B
    from    : B → A                       -- function from B to A
    from∘to : ∀ (x : A) → from (to x) ≡ x -- evidence asserting 'from' is a  left-inverse for 'to'
    to∘from : ∀ (y : B) → to (from y) ≡ y -- evidence asserting 'from' is a right-inverse for 'to'
open _≃_ -- makes field names 'to', etc., available without needing to write '_≃_.to'

{-
from ∘ to AND to ∘ from are identities

record declaration behaves similar to single-constructor data declaration
(there are minor differences - see Connectives):
-}
data _≃′_ (A B : Set): Set where
  mk-≃′ : ∀ (to      : A → B)
        → ∀ (from    : B → A)
        → ∀ (from∘to : (∀ (x : A) → from (to x) ≡ x))
        → ∀ (to∘from : (∀ (y : B) → to (from y) ≡ y))
        → A ≃′ B

to′      : ∀ {A B : Set} → (A ≃′ B) → (A → B)
to′      (mk-≃′ f g g∘f f∘g) = f

from′    : ∀ {A B : Set} → (A ≃′ B) → (B → A)
from′    (mk-≃′ f g g∘f f∘g) = g

from∘to′ : ∀ {A B : Set} → (A≃B : A ≃′ B) → (∀ (x : A) → from′ A≃B (to′ A≃B x) ≡ x)
from∘to′ (mk-≃′ f g g∘f f∘g) = g∘f

to∘from′ : ∀ {A B : Set} → (A≃B : A ≃′ B) → (∀ (y : B) → to′ A≃B (from′ A≃B y) ≡ y)
to∘from′ (mk-≃′ f g g∘f f∘g) = f∘g

{-
construct record values via

record
  { to      = f
  ; from    = g
  ; from∘to = g∘f
  ; to∘from = f∘g
  }

corresponds to using the constructor of the corresponding inductive type

mk-≃′ f g g∘f f∘g

------------------------------------------------------------------------------
ISOMORPHISM is an EQUIVALENCE : REFLEXIVE, SYMMETRIC, and TRANSITIVE
-}

-- REFLEXIVE
≃-refl : ∀ {A : Set}
    -----
  → A ≃ A
≃-refl =
  record
    { to      = λ{x → x}    -- bind to identity function
    ; from    = λ{y → y}    -- ditto
    -- refl next is proof since for left inverse, from (to x) simplifies to x, and vice versa
    ; from∘to = λ{x → refl} -- bound to fun that discards arg; returns refl
    ; to∘from = λ{y → refl} -- ditto
    }

-- SYMMETRIC : swap roles of to/from and from∘to/to∘from
≃-sym : ∀ {A B : Set}
  → A ≃ B
    -----
  → B ≃ A
≃-sym A≃B =
  record
    { to      = from    A≃B
    ; from    = to      A≃B
    ; from∘to = to∘from A≃B
    ; to∘from = from∘to A≃B
    }

-- TRANSITIVE : compose to/from and use equational reasoning to combine inverses
≃-trans : ∀ {A B C : Set}
  → A ≃ B
  → B ≃ C
    -----
  → A ≃ C
≃-trans A≃B B≃C =
  record
    { to       = to   B≃C ∘ to   A≃B
    ; from     = from A≃B ∘ from B≃C
    ; from∘to  = λ{x →
      begin
        (from A≃B ∘ from B≃C) ((to B≃C ∘ to A≃B) x)   ≡⟨⟩
         from A≃B  (from B≃C   (to B≃C  (to A≃B  x))) ≡⟨ cong (from A≃B) (from∘to B≃C (to A≃B x)) ⟩
         from A≃B                       (to A≃B  x)   ≡⟨ from∘to A≃B x ⟩
                                                 x
      ∎}
    ; to∘from = λ{y →
      begin
        (to B≃C ∘ to A≃B) ((from A≃B ∘ from B≃C) y)   ≡⟨⟩
         to B≃C  (to A≃B   (from A≃B  (from B≃C  y))) ≡⟨ cong (to B≃C) (to∘from A≃B (from B≃C y)) ⟩
         to B≃C                       (from B≃C  y)   ≡⟨ to∘from B≃C y ⟩
                                                 y
      ∎}
     }
{-
------------------------------------------------------------------------------
EQUATIONAL REASONING FOR ISOMORPHISM

Essentially copy previous definition of equality for isomorphism.
Omit the form that corresponds to _≡⟨⟩_,
since simple isomorphisms arise less often than simple equalities
-}

module ≃-Reasoning where

  infix  1 ≃-begin_
  infixr 2 _≃⟨_⟩_
  infix  3 _≃-∎

  ≃-begin_ : ∀ {A B : Set}
    → A ≃ B
      -----
    → A ≃ B
  ≃-begin A≃B = A≃B

  _≃⟨_⟩_ : ∀ (A : Set) {B C : Set}
    → A ≃ B
    → B ≃ C
      -----
    → A ≃ C
  A ≃⟨ A≃B ⟩ B≃C = ≃-trans A≃B B≃C

  _≃-∎ : ∀ (A : Set)
      -----
    → A ≃ A
  A ≃-∎ = ≃-refl

open ≃-Reasoning

{-
------------------------------------------------------------------------------
EMBEDDING : WEAKENING of ISOMORPHISM : EMBEDDING SHOWS 1ST TYPE INCLUDED IN SECOND
i.e., there is many-to-one correspondence between second type and first
-}

infix 0 _≲_
record _≲_ (A B : Set) : Set where
  field
    to      : A → B
    from    : B → A
    from∘to : ∀ (x : A) → from (to x) ≡ x
open _≲_

{-
same as isomorphism, except it omits 'to∘from' field
- says 'from' is left-inverse for 'to', but not a right-inverse

EMBEDDING IS NOT SYMMETRIC

proofs of REFLEXIVE and TRANSITIVE same as ISOMORPHISM except omitting one unneeded case
-}

-- REFLEXIVE
≲-refl : ∀ {A : Set} → A ≲ A
≲-refl =
  record
    { to      = λ{x → x}
    ; from    = λ{y → y}
    ; from∘to = λ{x → refl}
    }

-- TRANSITIVE
≲-trans : ∀ {A B C : Set} → A ≲ B → B ≲ C → A ≲ C
≲-trans A≲B B≲C =
  record
    { to      = λ{x → to   B≲C (to   A≲B x)}
    ; from    = λ{y → from A≲B (from B≲C y)}
    ; from∘to = λ{x →
      begin
        from A≲B (from B≲C (to B≲C (to A≲B x))) ≡⟨ cong (from A≲B) (from∘to B≲C (to A≲B x)) ⟩
        from A≲B                   (to A≲B x)   ≡⟨ from∘to A≲B x ⟩
                                           x
      ∎}
     }
{-
weak form of ANTI-SYMMETRY
if two types embed in each other, and embedding functions correspond, they are isomorphic
-}

≲-antisym : ∀ {A B : Set}
  → (A≲B : A ≲ B)
  → (B≲A : B ≲ A)
  → (to   A≲B ≡ from B≲A)
  → (from A≲B ≡ to   B≲A)
    -------------------
  → A ≃ B
≲-antisym A≲B B≲A to≡from from≡to =
  record
    { to      = to      A≲B
    ; from    = from    A≲B
    ; from∘to = from∘to A≲B
    ; to∘from = λ{y →
      begin
        to   A≲B (from A≲B y)   ≡⟨ cong (to A≲B) (cong-app from≡to y) ⟩
        to   A≲B (to   B≲A y)   ≡⟨ cong-app to≡from (to B≲A y) ⟩
        from B≲A (to   B≲A y)   ≡⟨ from∘to B≲A y ⟩
                           y
      ∎}
    }

{-
First three components are copied from the embedding.
The last combines left inverse of B ≲ A with the equivalences of the 'to' and 'from' components
from the two embeddings to obtain the right inverse of the isomorphism.

------------------------------------------------------------------------------
Equational reasoning for embedding
-}

module ≲-Reasoning where

  infix  1 ≲-begin_
  infixr 2 _≲⟨_⟩_
  infix  3 _≲-∎

  ≲-begin_ : ∀ {A B : Set}
    → A ≲ B
      -----
    → A ≲ B
  ≲-begin A≲B = A≲B

  _≲⟨_⟩_ : ∀ (A : Set) {B C : Set}
    → A ≲ B
    →     B ≲ C
      -----
    → A ≲     C
  A ≲⟨ A≲B ⟩ B≲C = ≲-trans A≲B B≲C

  _≲-∎ : ∀ (A : Set)
      -----
    → A ≲ A
  A ≲-∎ = ≲-refl

open ≲-Reasoning

{-
------------------------------------------------------------------------------
Exercise ≃-implies-≲ (practice) Show that every isomorphism implies an embedding. TODO

postulate
  ≃-implies-≲ : ∀ {A B : Set}
    → A ≃ B
      -----
    → A ≲ B
-- Your code goes here

------------------------------------------------------------------------------
Exercise _⇔_ (practice) Define equivalence of propositions TODO
(also known as “if and only if”) as follows:

record _⇔_ (A B : Set) : Set where
  field
    to   : A → B
    from : B → A
Show that equivalence is reflexive, symmetric, and transitive.

-- Your code goes here

------------------------------------------------------------------------------
Exercise Bin-embedding (stretch) TODO

Bin and Bin-laws define a datatype Bin of bitstrings representing natural numbers
with functions

to : ℕ → Bin
from : Bin → ℕ

that satisfy

from (to n) ≡ n

Using the above, establish that there is an embedding of ℕ into Bin.

-- Your code goes here

Why do to and from not form an isomorphism?

------------------------------------------------------------------------------
Standard library

import Function             using (_∘_)
import Function.Inverse     using (_↔_)
import Function.LeftInverse using (_↞_)

The standard library _↔_ and _↞_ correspond to our _≃_ and _≲_, respectively,
but those in the standard library are less convenient,
since they depend on a nested record structure
and are parameterised with regard to an arbitrary notion of equivalence.

------------------------------------------------------------------------------
Unicode
This chapter uses the following unicode:

∘  U+2218  RING OPERATOR              (\o, \circ, \comp)
λ  U+03BB  GREEK SMALL LETTER LAMBDA  (\lambda, \Gl)
≃  U+2243  ASYMPTOTICALLY EQUAL TO    (\~-)
≲  U+2272  LESS-THAN OR EQUIVALENT TO (\<~)
⇔ U+21D4  LEFT RIGHT DOUBLE ARROW    (\<=>)
-}


module hott.types.int where

open import hott.functions
open import hott.core
import hott.types.nat as nat

open nat using (ℕ)

data ℤ : Type₀ where
  zero : ℤ
  +ve  : ℕ → ℤ
  -ve  : ℕ → ℤ

fromNat : ℕ → ℤ
fromNat nat.zero = zero
fromNat (nat.succ n) = +ve n

neg : ℤ → ℤ
neg zero = zero
neg (+ve n) = -ve n
neg (-ve n) = +ve n

suc : ℤ → ℤ
suc zero                 = +ve 0
suc (+ve x)              = +ve (nat.succ x)
suc (-ve 0)              = zero
suc (-ve (nat.succ x))   = -ve x

pred : ℤ → ℤ
pred zero                 = -ve 0
pred (-ve x)              = -ve (nat.succ x)
pred (+ve 0)              = zero
pred (+ve (nat.succ x))   = +ve x

suc∘pred~id : suc ∘ pred ~ id
suc∘pred~id zero               = refl
suc∘pred~id (+ve 0)            = refl
suc∘pred~id (+ve (nat.succ x)) = refl
suc∘pred~id (-ve x)            = refl

pred∘suc~id : pred ∘ suc ~ id
pred∘suc~id zero               = refl
pred∘suc~id (+ve x)            = refl
pred∘suc~id (-ve 0)            = refl
pred∘suc~id (-ve (nat.succ x)) = refl


module #8 where

{-
  Define multiplication and exponentiation using recN. Verify that (N, +, 0, ×, 1) is
  a semiring using only indN. You will probably also need to use symmetry and transitivity of
  equality, Lemmas 2.1.1 and 2.1.2.
-}

open import Data.Nat

recₙ : ∀{c}{C : Set c} → C → (ℕ → C → C) → ℕ → C
recₙ c₀ cₛ zero = c₀
recₙ c₀ cₛ (suc n) = cₛ n (recₙ c₀ cₛ n)

mul-recₙ : ℕ → ℕ → ℕ
mul-recₙ n = recₙ 0 (λ _ z → z + n)

exp-recₙ : ℕ → ℕ → ℕ
exp-recₙ n = recₙ 1 (λ _ z → z * n)

ind-ℕ : ∀{k}{C : ℕ → Set k} → C zero → ((n : ℕ) → C n → C (suc n)) → (n : ℕ) → C n
ind-ℕ c0 cs zero = c0
ind-ℕ c0 cs (suc n) = cs n (ind-ℕ c0 cs n)

record Semiring (X : Set) : Set where
  field
    ε : X
    _⊕_ : X → X → X
    _⊛_ : X → X → X
open Semiring {{...}} public

natIsSemiring : Semiring ℕ
natIsSemiring = record { ε = zero
                       ; _⊕_ = _+_
                       ; _⊛_ = _*_
                       }

{- Semiring Laws Follow -}


------------------------------------------------------------------------------
-- Properties related with the group commutator
------------------------------------------------------------------------------

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

module GroupTheory.Commutator.PropertiesI where

open import Common.FOL.Relation.Binary.EqReasoning

open import GroupTheory.Base
open import GroupTheory.Commutator
open import GroupTheory.PropertiesI

------------------------------------------------------------------------------
-- Kurosh (1960), p. 99.
commutatorInverse : ∀ a b → [ a , b ] · [ b , a ] ≡ ε
commutatorInverse a b =
  a ⁻¹ · b ⁻¹ · a · b · (b ⁻¹ · a ⁻¹ · b · a)
    ≡⟨ assoc (a ⁻¹ · b ⁻¹ · a) b (b ⁻¹ · a ⁻¹ · b · a) ⟩
  a ⁻¹ · b ⁻¹ · a · (b · (b ⁻¹ · a ⁻¹ · b · a))
    ≡⟨ ·-rightCong (·-rightCong (assoc (b ⁻¹ · a ⁻¹) b a)) ⟩
  a ⁻¹ · b ⁻¹ · a · (b · (b ⁻¹ · a ⁻¹ · (b · a)))
    ≡⟨ ·-rightCong (·-rightCong (assoc (b ⁻¹) (a ⁻¹) (b · a))) ⟩
  a ⁻¹ · b ⁻¹ · a · (b · (b ⁻¹ · (a ⁻¹ · (b · a))))
    ≡⟨ ·-rightCong (sym (assoc b (b ⁻¹) (a ⁻¹ · (b · a)))) ⟩
  a ⁻¹ · b ⁻¹ · a · (b · b ⁻¹ · (a ⁻¹ · (b · a)))
    ≡⟨ ·-rightCong (·-leftCong (rightInverse b)) ⟩
  a ⁻¹ · b ⁻¹ · a · (ε · (a ⁻¹ · (b · a)))
    ≡⟨ ·-rightCong (leftIdentity (a ⁻¹ · (b · a))) ⟩
  a ⁻¹ · b ⁻¹ · a · (a ⁻¹ · (b · a))
    ≡⟨ assoc (a ⁻¹ · b ⁻¹) a (a ⁻¹ · (b · a)) ⟩
  a ⁻¹ · b ⁻¹ · (a · (a ⁻¹ · (b · a)))
    ≡⟨ ·-rightCong (sym (assoc a (a ⁻¹) (b · a))) ⟩
  a ⁻¹ · b ⁻¹ · (a · a ⁻¹ · (b · a))
    ≡⟨ ·-rightCong (·-leftCong (rightInverse a)) ⟩
  a ⁻¹ · b ⁻¹ · (ε · (b · a))
    ≡⟨ ·-rightCong (leftIdentity (b · a)) ⟩
  a ⁻¹ · b ⁻¹ · (b · a)
    ≡⟨ assoc (a ⁻¹) (b ⁻¹) (b · a) ⟩
  a ⁻¹ · (b ⁻¹ · (b · a))
     ≡⟨ ·-rightCong (sym (assoc (b ⁻¹) b a)) ⟩
  a ⁻¹ · ((b ⁻¹ · b) · a)
     ≡⟨ ·-rightCong (·-leftCong (leftInverse b)) ⟩
  a ⁻¹ · (ε · a)
     ≡⟨ ·-rightCong (leftIdentity a) ⟩
  a ⁻¹ · a
     ≡⟨ leftInverse a ⟩
  ε ∎

------------------------------------------------------------------------------
-- References
--
-- Kurosh, A. G. (1960). The Theory of Groups. 2nd
-- ed. Vol. 1. Translated and edited by K. A. Hirsch. Chelsea
-- Publising Company.


------------------------------------------------------------------------------
-- Even predicate
------------------------------------------------------------------------------

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

module FOTC.Even where

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

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

data Even : D → Set where
  ezero :                  Even zero
  enext : ∀ {n} → Even n → Even (succ₁ (succ₁ n))

Even-ind : (A : D → Set) →
           A zero →
           (∀ {n} → A n → A (succ₁ (succ₁ n))) →
           ∀ {n} → Even n → A n
Even-ind A A0 h ezero      = A0
Even-ind A A0 h (enext En) = h (Even-ind A A0 h En)

Even→N : ∀ {n} → Even n → N n
Even→N ezero      = nzero
Even→N (enext En) = nsucc (nsucc (Even→N En))


open import x1-Base

module x4-Nat where

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

data _≤_ : Rel ℕ where
  z≤n : ∀ {x}   → zero ≤ x
  s≤s : ∀ {x y} →     x ≤     y
                → suc x ≤ suc y

≤-suc : ∀ {x y} → suc x ≤ suc y
                →     x ≤     y
≤-suc (s≤s x≤y) = x≤y

_≤?_ : Decidable _≤_
zero  ≤? _      = left  z≤n
suc _ ≤? zero   = right λ()
suc x ≤? suc y with x ≤? y
... | left  x≤y = left  (s≤s x≤y)
... | right x>y = right (λ sx≤sy → x>y (≤-suc sx≤sy))

open import x3-PropositionalEquality using (_≡_; refl; cong; equivalence)

antisym : ∀ {x y} → x ≤ y → y ≤ x → x ≡ y
antisym  z≤n       z≤n      = refl
antisym (s≤s x≤y) (s≤s y≤x) = cong suc (antisym x≤y y≤x)

trans : ∀ {x y z} → x ≤ y → y ≤ z → x ≤ z
trans  z≤n             _  = z≤n
trans (s≤s x≤y) (s≤s y≤z) = s≤s (trans x≤y y≤z)

total : ∀ x y → Either (x ≤ y) (y ≤ x)
total  zero        _ = left  z≤n
total (suc x)   zero = right z≤n
total (suc x) (suc y) with total x y
... | left  x≤y      = left  (s≤s x≤y)
... | right y≤x      = right (s≤s y≤x)

reflexive : ∀ {x y} → x ≡ y → x ≤ y
reflexive {zero}  refl = z≤n
reflexive {suc _} refl = s≤s (reflexive refl)

totalOrder : TotalOrder _≡_ _≤_
totalOrder = record
  { antisym     = antisym
  ; trans       = trans
  ; total       = total
  ; reflexive   = reflexive
  ; equivalence = equivalence
  }


-- exercises-01-monday.agda

open import Data.Nat

variable
  A B C : Set

-- Exercise 1

add3 : ℕ → ℕ
add3 x = x + 3

tw : (A → A) → A → A
tw f n = f (f n) -- tw = λ f n → f (f n)

-- evaluate: "tw tw add3 1"; derive the result (in a comment) step by step
{-
    tw tw add3 1 =
  = tw (tw add3) 1 =
  = (tw add3) (tw add3 1) =
  = (tw add3) (add3 (add3 1))
  = tw add3 7 =
  = add3 (add3 7) =
  = 13
-}

-- Exercise 2

-- derive lambda terms with the following types

f₀ : (A → B) → (B → C) → (A → C)
f₀ f g a = g (f a)

f₁ : (A → B) → ((A → C) → C) → ((B → C) → C)
f₁ f g h = g λ a -> h (f a)

f₂ : (A → B → C) → B → A → C
f₂ f b a = f a b

-- Exercise 3

-- derive a function tw-c which behaves the same as tw using only S, K (and I
-- which is defined using S and K below).

K : A → B → A
K = λ a b → a

S : (A → B → C) → (A → B) → A → C
S = λ f g x → f x (g x)

-- I = λ x → x
I : A → A
I {A} = S K (K {B = A})

{-
    λ f n → f (f n) =
  = λ f → λ n → f (f n) =
  = λ f → S (λ n → f) (λ n → f n) =
  = λ f → S (K f) f =
  = S (λ f → S (K f) (λ f → f) =
  = S (S (λ f → S) (λ f → (K f)) I =
  = S (S (K S) K) I =
-}

tw-c : (A → A) → A → A
tw-c = S (S (K S) K) I


{-# OPTIONS --sized-types #-}
module SNat.Order where

open import Size
open import SNat

data _≤_ : {ι ι' : Size} → SNat {ι} → SNat {ι'} → Set where
  z≤n : {ι ι' : Size}
                   → (n : SNat {ι'})
                   →  _≤_ (zero {ι}) n
  s≤s : {ι ι' : Size}{m : SNat {ι}}{n : SNat {ι'}}
                   → m ≤ n
                   → (succ m) ≤ (succ n)

data _≅_ : {ι ι' : Size} → SNat {ι} → SNat {ι'} → Set where
  z≅z : {ι ι' : Size}
                   → zero {ι} ≅ zero {ι'}
  s≅s : {ι ι' : Size}{m : SNat {ι}}{n : SNat {ι'}}
                   → m ≅ n
                   → succ m ≅ succ n

data _≤′_ : {ι ι' : Size} → SNat {ι} → SNat {ι'} → Set where
  ≤′-eq : {ι ι' : Size}{m : SNat {ι}}{n : SNat {ι'}}
                   → m ≅ n
                   → m ≤′ n
  ≤′-step : {ι ι' : Size}{m : SNat {ι}}{n : SNat {ι'}}
                   → m ≤′ n
                   → m ≤′ succ n


module Prelude.Fin where

open import Prelude.Nat
open import Prelude.Equality
open import Prelude.Decidable
open import Prelude.Ord
open import Prelude.Bool
open import Prelude.Function
open import Prelude.Number
open import Prelude.Nat.Properties using (suc-inj)

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

finToNat : ∀ {@erased n} → Fin n → Nat
finToNat  zero   = zero
finToNat (suc i) = suc (finToNat i)

finToNat-inj : ∀ {@erased n} {i j : Fin n} → finToNat i ≡ finToNat j → i ≡ j
finToNat-inj {i = zero } {zero } p = refl
finToNat-inj {i = zero } {suc j} ()
finToNat-inj {i = suc i} {zero } ()
finToNat-inj {i = suc i} {suc j} p rewrite finToNat-inj (suc-inj p) = refl

natToFin : ∀ {n} (m : Nat) {{m<n : IsTrue (lessNat m n)}} → Fin n
natToFin {zero }  _   {{}}
natToFin {suc n}  zero   = zero
natToFin {suc n} (suc m) = suc (natToFin m)

instance
  NumberFin : ∀ {n} → Number (Fin n)
  Number.Constraint (NumberFin {n}) k = IsTrue (lessNat k n)
  fromNat {{NumberFin}} = natToFin

--- Equality ---

fsuc-inj : ∀ {@erased n} {i j : Fin n} → Fin.suc i ≡ suc j → i ≡ j
fsuc-inj refl = refl

private
  eqFin : ∀ {@erased n} (i j : Fin n) → Dec (i ≡ j)
  eqFin  zero    zero    = yes refl
  eqFin  zero   (suc  j) = no λ ()
  eqFin (suc i)  zero    = no λ ()
  eqFin (suc i) (suc  j) with eqFin i j
  eqFin (suc i) (suc .i) | yes refl = yes refl
  eqFin (suc i) (suc  j) | no neq   = no λ eq → neq (fsuc-inj eq)

instance
  EqFin : ∀ {n} → Eq (Fin n)
  _==_ {{EqFin}} = eqFin

--- Ord ---

instance
  OrdFin : ∀ {n} → Ord (Fin n)
  OrdFin = OrdBy finToNat-inj

  OrdLawsFin : ∀ {n} → Ord/Laws (Fin n)
  OrdLawsFin = OrdLawsBy finToNat-inj


------------------------------------------------------------------------------
-- Data and postulates
------------------------------------------------------------------------------

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

-- Are the FOTC natural numbers defined by data and postulates the
-- same?

module DataPostulate where

------------------------------------------------------------------------------
postulate
  D    : Set
  zero : D
  succ : D → D

-- The FOTC natural numbers using data.
data N : D → Set where
  zN :               N zero
  sN : ∀ {n} → N n → N (succ n)

N-ind : (P : D → Set) →
        P zero →
        (∀ {n} → N n → P n → P (succ n)) →
        ∀ {n} → N n → P n
N-ind P P0 h zN      = P0
N-ind P P0 h (sN Nn) = h Nn (N-ind P P0 h Nn)

-- The FOTC natural numbers using postulates (we chose 'M' by 'Model').
postulate
  M    : D → Set
  zM   : M zero
  sM   : ∀ {n} → M n → M (succ n)
  M-ind : (P : D → Set) →
          P zero →
          (∀ {n} → M n → P n → P (succ n)) →
          ∀ {n} → M n → P n

------------------------------------------------------------------------------
-- The predicates

-- From the data predicate to the postulated one: Using the induction
-- principle.
nat-D2P : ∀ {n} → N n → M n
nat-D2P = N-ind M zM (λ _ Mn → sM Mn)

-- From the data predicate to the postulated one: Using pattern
-- matching.
nat-D2P' : ∀ {n} → N n → M n
nat-D2P' zN      = zM
nat-D2P' (sN Nn) = sM (nat-D2P' Nn)

-- From the postulated predicate to the data one.
nat-P2D : ∀ {n} → M n → N n
nat-P2D = M-ind N zN (λ _ Nn → sN Nn)

------------------------------------------------------------------------------
-- The induction principles

-- The postulated inductive principle from the data one.
D2P-ind : (P : D → Set) → P zero →
          (∀ {n} → M n → P n → P (succ n)) →
          ∀ {n} → M n → P n
D2P-ind P P0 ih Mn = N-ind P P0 (λ {_} Nn → ih (nat-D2P Nn)) (nat-P2D Mn)

-- The data inductive principle from the postulated one.
P2D-ind : (P : D → Set) → P zero →
          (∀ {n} → N n → P n → P (succ n)) →
          ∀ {n} → N n → P n
P2D-ind P P0 ih Nn = M-ind P P0 (λ {_} Mn → ih (nat-P2D Mn)) (nat-D2P Nn)


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

open import List.Permutation.Base A
open import Data.List
open import Data.Product renaming (_×_ to _∧_)

refl∼ : {xs : List A} → xs ∼ xs
refl∼ {[]}     = ∼[]
refl∼ {x ∷ xs} = ∼x /head /head refl∼

sym∼ : {xs ys : List A} → xs ∼ ys → ys ∼ xs
sym∼ ∼[] = ∼[]
sym∼ (∼x xs/x⟶xs' ys/x⟶ys' xs'∼ys') = ∼x ys/x⟶ys' xs/x⟶xs' (sym∼ xs'∼ys')

lemma// : {x y : A}{xs ys zs : List A} → xs / x ⟶ ys → ys / y ⟶ zs → ∃ (λ ws → xs / y ⟶ ws ∧ ws / x ⟶ zs)
lemma//  (/head {x = x}) (/head {xs = xs}) = x ∷ xs , /tail /head , /head
lemma// (/head {x = x}) (/tail {x = u} {ys = us'} us/y⟶us') = x ∷ u ∷ us' , /tail (/tail us/y⟶us') , /head
lemma// (/tail {xs = us} us/x⟶us') /head = us , /head , us/x⟶us'
lemma// (/tail {x = u} us/x⟶us') (/tail us'/y⟶us'')
    with lemma// us/x⟶us' us'/y⟶us''
... | ws' , us/y⟶ws' , ws'/x⟶us'' = u ∷ ws' , /tail us/y⟶ws' ,  /tail ws'/x⟶us''

lemma∼/∷ : {x : A}{xs ys : List A} → (x ∷ xs) ∼ ys → ∃ (λ ys' → ys / x ⟶ ys' ∧ xs ∼ ys')
lemma∼/∷  (∼x {ys' = vs'} /head ys/x⟶vs' xs∼vs') = vs' , ys/x⟶vs' , xs∼vs'
lemma∼/∷  (∼x (/tail xs/u⟶us') ys/u⟶vs' x∷us'∼vs')
    with lemma∼/∷ x∷us'∼vs'
... | _ , vs'/x⟶zs , us'∼zs
    with lemma// ys/u⟶vs' vs'/x⟶zs
... | ws , ys/x⟶ws , ws/u⟶zs = ws , ys/x⟶ws , ∼x xs/u⟶us' ws/u⟶zs us'∼zs

lemma∼/ : {x : A}{xs xs' ys : List A} → xs ∼ ys → xs / x  ⟶ xs' →
                   ∃ (λ ys' → ys / x ⟶ ys' ∧ xs' ∼ ys')
lemma∼/ u∷us∼ys /head = lemma∼/∷ u∷us∼ys
lemma∼/ u∷us∼ys (/tail us/x⟶xs')
    with lemma∼/∷ u∷us∼ys
... | _ , ys/u⟶ys' , us∼ys'
    with lemma∼/ us∼ys' us/x⟶xs'
... | _ , ys'/x⟶vs , xs'∼vs
    with lemma// ys/u⟶ys' ys'/x⟶vs
... | ws , ys/x⟶ws , ws/u⟶vs = ws , ys/x⟶ws , ∼x /head ws/u⟶vs xs'∼vs

trans∼ : {xs ys zs : List A} → xs ∼ ys → ys ∼ zs → xs ∼ zs
trans∼ ∼[] ∼[] = ∼[]
trans∼ ∼[] (∼x .{xs = []} () zs/x⟶zs' ys'∼zs')
trans∼ {zs = zs} (∼x {ys = ys} xs/x⟶xs' ys/x⟶ys' xs'∼ys') ys∼zs
    with lemma∼/ {xs = ys} ys∼zs ys/x⟶ys'
... | _ , zs/x⟶us , ys'∼us = ∼x xs/x⟶xs' zs/x⟶us (trans∼ xs'∼ys' ys'∼us)


module HC-Lec1 where

-- ==============================================================================
-- Lecture 1 : Programs and Proofs
-- https://www.youtube.com/watch?v=O4oczQry9Jw&t=1412s

------------------------------------------------------------------------------
-- some basic logical types

-- 13:22 -- like Haskell Void
data Zero : Set where
  -- No constructors, so no inhabitants
  -- Represents logical impossibility.

-- 16:45 -- like Haskell ()
record One : Set where
  constructor <> -- added in video Lecture 2 4:50
  -- This record has no fields.
  -- This record has exactly one inhabitant.

-- 18:42 -- like Haskell Either
data _+_ (S : Set) (T : Set) : Set where
  inl : S -> S + T -- left  constructor
  inr : T -> S + T -- right constructor

-- 24:50 -- like Haskell pair ( , )
record _*_ (S : Set) (T : Set) : Set where
  constructor _,_ -- added in video Lecture 2 4:58
  field
    fst : S
    snd : T

------------------------------------------------------------------------------
-- examples

-- 28:36
comm-* : {A : Set} {B : Set} -> A * B -> B * A
comm-* record { fst = a ; snd = b } = record { fst = b ; snd = a }

-- 43:00
assocLR-+ : {A B C : Set} -> (A + B) + C -> A + (B + C)
assocLR-+ (inl (inl a)) =      inl a
assocLR-+ (inl (inr b)) = inr (inl b)
assocLR-+      (inr c)  = inr (inr c)

-- 47:34
-- If you can arrive at a contradiction, then you can derive any conclusion.
-- Given a Zero, must produce an X for ANY X.
-- But there are no inhabitants of Zero.
-- So use 'absurd' pattern that indicates something that is IMPOSSIBLE.
naughtE : {X : Set} -> Zero -> X
naughtE ()

-- standard composition: f << g is "f after g"
_<<_ : {X Y Z : Set} -> (Y -> Z) -> (X -> Y) -> (X -> Z)
(f << g) x = f (g x)

-- diagrammatic composition: f >> g is "f then g"
_>>_ : {X Y Z : Set} -> (X -> Y) -> (Y -> Z) -> (X -> Z)
                     --       ^^^^^^^^          dominoes!
(f >> g) x = g (f x)

-- infix application
_$_ : {S : Set}{T : S -> Set}(f : (x : S) -> T x)(s : S) -> T s
f $ s = f s
infixl 2 _$_

-- ==============================================================================
-- Lecture 2 : more Programs and Proof, Introducing "with"
-- https://www.youtube.com/watch?v=qcVZxQTouDk

-- 2:25
_$*_ : {A A' B B' : Set} -> (A -> A') -> (B -> B') -> A * B -> A' * B'
(a→a' $* b→b') (a , b) = (a→a' a) , (b→b' b)

-- 6:53
_$+_ : {A A' B B' : Set} -> (A -> A') -> (B -> B') -> A + B -> A' + B'
(a→a' $+ b→b') (inl a) = inl (a→a' a)
(a→a' $+ b→b') (inr b) = inr (b→b' b)

-- 8:52 -- like Haskell const ; this is pure for applicative functor needing an E
combinatorK : {A E : Set} -> A -> E -> A
combinatorK a _ = a

-- 11:25 -- this is application
combinatorS : {S T E : Set} -> (E -> S -> T) -> (E -> S) -> E -> T
combinatorS e→s→t e→s e = e→s→t e (e→s e)

-- 14:50
idK : {X : Set} -> X -> X
idK x = combinatorK x x

-- 19:00
idSKK : {X : Set} -> X -> X
idSKK {X} = combinatorS combinatorK (combinatorK {E = X}) -- 'Zero' and 'One' also work

id : {X : Set} -> X -> X
-- id x = x -- is the easy way; let's do it a funny way to make a point
id = combinatorS combinatorK (combinatorK {_} {Zero})
--                          no choice for -^   ^^^^- could be anything

-- 30:25
-- naughtE

------------------------------------------------------------------------------
-- from logic to data

-- 32:05

data Nat : Set where
  zero : Nat
  suc  : Nat -> Nat -- recursive data type
{-# BUILTIN NATURAL Nat #-} -- enables decimal notation

-- 32:58
_+N_ : Nat -> Nat -> Nat
zero  +N y = y
suc x +N y = suc (x +N y)

four : Nat
four = 2 +N 2

------------------------------------------------------------------------------
-- and back to logic

-- 36:46
data _==_ {X : Set} : X -> X -> Set where
  refl : (x : X) -> x == x -- the relation that is "only reflexive"
{-# BUILTIN EQUALITY _==_ #-}

see4 : (2 +N 2) == 4
see4 = refl 4

-- 42:35
-- application of equalities
_=$=_ : {X Y : Set} {f f' : X -> Y} {x x' : X}
     -> f   == f'
     ->   x ==    x'
     -> f x == f' x
refl f =$= refl x = refl (f x)

------------------------------------------------------------------------------
-- computing types

-- 45:00
_>=_ : Nat -> Nat -> Set
x     >= zero  = One     -- i.e., true
zero  >= suc y = Zero    -- i.e., false
suc x >= suc y = x >= y

--a0 : 2 >= 4
--a0 = {!!}

a1 : 4 >= 2
a1 = <>

refl->= : (n : Nat) -> n >= n
refl->=  zero   = <>
refl->= (suc n) = refl->= n

trans->= : (x y z : Nat) -> x >= y -> y >= z  -> x >= z
trans->= zero     zero        z  x>=y y>=z = y>=z
trans->= (suc x)  zero    zero   x>=y y>=z = <>
trans->= (suc x) (suc y)  zero   x>=y y>=z = <>
trans->= (suc x) (suc y) (suc z) x>=y y>=z = trans->= x y z x>=y y>=z

------------------------------------------------------------------------------
-- construction by proof

-- 47:38

record Sg (S : Set) (T : S -> Set) : Set where -- Sg is short for "Sigma"
  constructor _,_
  field
    fst : S       -- a value
    snd : T fst   -- some evidence about that value

difference : (m n : Nat) -> m >= n -> Sg Nat λ d -> m == (n +N d)
difference      m   zero   m>=n = m , refl m
difference  zero   (suc n) ()
difference (suc m) (suc n) m>=n
  with difference m n m>=n
...| d , e
   = d , xxx m n d e
 where
  xxx : ∀ (m n d : Nat) -> m == (n +N d) -> suc m == suc (n +N d)
  xxx m n d p rewrite p = refl (suc (n +N d))

-- ==============================================================================
-- Lecture 3 : Proof by induction
-- https://www.youtube.com/watch?v=8xFT9FPlm18

-- 6:20
-- Nat with zero, +N and assocLR-+ form a monoid.

-- 8:48
zero-+N : (n : Nat) -> (zero +N n) == n
zero-+N n = refl n -- by definition

-- 9:36
-- version in video
-- +N-zero' : (n : Nat) -> (n +N zero) == n
-- +N-zero'  zero   = refl zero -- by definition
-- +N-zero' (suc n) = refl suc =$= +N-zero' n -- TODO : does not compile

-- HC alternate version
+N-zero : (n : Nat) -> (n +N zero) == n
+N-zero  zero   = refl zero -- by definition
+N-zero (suc n)
  with +N-zero n
...| n+N0==n
  rewrite n+N0==n
   = refl (suc n)

-- 26:00
-- version in video
-- assocLR-+N' : (x y z : Nat) -> ((x +N y) +N z) == (x +N (y +N z))
-- assocLR-+N'  zero   y z = refl (y +N z)
-- assocLR-+N' (suc x) y z = refl suc =$= assocLR-+N' x y z -- TODO : does not compile

-- 30:21
assocLR-+N : (x y z : Nat) -> ((x +N y) +N z) == (x +N (y +N z))
assocLR-+N  zero   y z = refl (y +N z)
assocLR-+N (suc x) y z
  rewrite assocLR-+N x y z
  = refl (suc (x +N (y +N z)))

------------------------------------------------------------------------------
-- computing types

-- 34:46
refl->=' : (n : Nat) -> n >= n
refl->='  zero   = <>
refl->=' (suc n) = refl->=' n

-- 41:00
trans->=' : (x y z : Nat) -> x >= y -> y >= z  -> x >= z
-- start with 'z'
trans->='      x       y   zero   x>=y y>=z = <>
trans->=' (suc x) (suc y) (suc z) x>=y y>=z = trans->=' x y z x>=y y>=z

-- ==============================================================================
-- Lecture 4 : Sigma, Difference, Vector Take
-- https://www.youtube.com/watch?v=OZeDRtRmgkw

-- 0:46 Sigma type (see above)

-- 5:10 -- make _*_ from Sg
_*'_ : (S : Set) -> (T : Set) -> Set
s *' t = Sg s λ _ -> t

-- 10:55 difference (see above)
difference' : (m n : Nat) -> m >= n -> Sg Nat λ d -> m == (n +N d)
-- 1st clause of >= matches on right, so start with 'n'
difference'      m   zero   m>=n = m , refl m
difference' (suc m) (suc n) m>=n
  with difference' m n m>=n
...| d , m==n+Nd
  rewrite m==n+Nd
  = d , refl (suc (n +N d)) -- video also uses refl suc =$= m==n+Nd

-- 27:24 -- pattern match on proof of equation ; here 'm==n+Nd'
difference'' : (m n : Nat) -> m >= n -> Sg Nat λ d -> m == (n +N d)
-- 1st clause of >= matches on right, so start with 'n'
difference''      m   zero   m>=n = m , refl m
difference'' (suc m) (suc n) m>=n
  with difference'' m n m>=n
...| d , m==n+Nd
  with m==n+Nd
... | refl .(n +N d) = d , (refl (suc (n +N d)))

tryMe     = difference 42 37
-- dontTryMe = difference 37 42 {!!}

------------------------------------------------------------------------------
-- things to remember to say

{-
-- 34:22 : = VIZ ==
=  : makes a definition (part of Agda programming language)
== : makes a type (by user built definition)

function type is both IMPLICATION and UNIVERSAL QUANTIFICATION : why call Pi?

why is Sigma called Sigma?

-- 38:50 : B or not B
must be able to return a
- inl B      for any B : not possible because nothing known about B
- inR B→Zero for any B : not possible because Zero has no elements
exMiddle : {B : Set} -> B + (B -> Zero)
exMiddle = ?

-- 40:45
-- not possible to "look inside" 'notAandB' to determine 'inl' or 'inr'
deMorgan : {A B : Set} -> ((A * B) -> Zero) -> (A -> Zero) + (B -> Zero)
deMorgan notAandB = {!!}
-}


-- A DSL example in the language Agda: "polynomial types"
module TypeDSL where
open import Data.Empty
open import Data.Unit
open import Data.Sum
open import Data.Product
open import Data.Nat

data E : Set1 where
  Add   : E -> E -> E
  Mul   : E -> E -> E
  Zero  : E
  One   : E

eval : E -> Set
eval (Add x y)  = (eval x) ⊎ (eval y)
eval (Mul x y)  = (eval x) × (eval y)
eval Zero       = ⊥
eval One        = ⊤

two   = Add One One
three = Add One two

test1 : eval One
test1 = tt

false : eval two
false = inj₁ tt
true : eval two
true = inj₂ tt

test3 : eval three
test3 = inj₁ tt

card : E -> ℕ
card (Add x y)  = card x + card y
card (Mul x y)  = card x * card y
card Zero       = 0
card One        = 1

open import Data.Vec as V

variable
    m n : ℕ
    A B : Set

enumAdd : Vec A m -> Vec B n -> Vec (A ⊎ B) (m + n)
enumAdd xs ys = V.map inj₁ xs ++ V.map inj₂ ys

-- cartesianProduct
enumMul : Vec A m → Vec B n → Vec (A × B) (m * n)
enumMul xs ys = concat (V.map  (\a -> V.map  ((a ,_)) ys)  xs)

enumerate : (t : E) -> Vec (eval t) (card t)
enumerate (Add x y)  =  enumAdd  (enumerate x) (enumerate y)
enumerate (Mul x y)  =  enumMul  (enumerate x) (enumerate y)
enumerate Zero       =  []
enumerate One        =  [ tt ]

test : Vec (eval three) 3
test = enumerate three
-- inj₁ tt ∷ inj₂ (inj₁ tt) ∷ inj₂ (inj₂ tt) ∷ []

-- Exercise: add a constructor for function types to the syntax E


-- Problem 4: ``50 shades of continuity''

{-
C(f)        =  ∀ c : X. Cat(f,c)
Cat(f,c)    =  ∀ ε > 0. ∃ δ > 0. Q(f,c,ε,δ)
Q(f,c,ε,δ)  =  ∀ x : X.  abs(x - c) < δ  ⇒  abs(f x - f c) < ε

C'(f)       =  ∃ getδ : X -> RPos -> RPos. ∀ c : X. ∀ ε > 0. Q(f,c,ε,getδ c ε)

4a: Define UC(f):

UC(f) = ∀ ε > 0. ∃ δ > 0. ∀ y : X. Q(f,y,ε,δ)

4b: Define UC'(f):

UC'(f) = ∃ newδ : RPos -> RPos. ∀ ε > 0. ∀ y : X. Q(f,y,ε,newδ ε)

The function |newδ| computes a suitable "global" |δ| from any |ε|,
which shows |Q| for any |y|.

4c: Prove |∀ f : X -> ℝ. UC'(f) => C'(f)|.

The proof is a function from a pair (newδ, puc) to a pair (getδ, pc).

proof f (newδ, puc) = (getδ, pc)
  where  getδ c ε = newδ ε
         pc c ε = puc ε c   -- (1)

The type of (1) is

  Q(f,c,ε,newδ ε)
=
  Q(f,c,ε,getδ c ε)

which is the type of |pc c ε|.

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

Below is a self-contained proof in Agda just to check the above. It is
not part of the exam question.

-}

postulate
  R RPos : Set
  abs : R -> RPos
  _-_ : R -> R -> R
  _<_ : RPos -> RPos -> Set

X = R  -- to avoid trouble with lack of subtyping

record Sigma (A : Set) (B : A -> Set) : Set where
  constructor _,_
  field
    fst : A
    snd : B fst

Q : (X -> R) -> X -> RPos -> RPos -> Set
Q f c ε δ  =  (x : X) -> (abs(  x -   c) < δ)  ->
                         (abs(f x - f c) < ε)

Cat : (X -> R) -> X -> Set
Cat f c    =  (ε : RPos) -> Sigma RPos (\δ ->
                                  Q f c ε δ)

C : (X -> R) -> Set
C f        =  (c : X) -> Cat f c

C' : (X -> R) -> Set
C' f =  Sigma (X -> RPos -> RPos) (\getδ ->
              (c : X) -> (ε : RPos) -> Q f c ε (getδ c ε))

UC : (X -> R) -> Set
UC f = (ε : RPos) -> Sigma RPos (\δ ->
                           (y : X) -> Q f y ε δ)

UC' : (X -> R) -> Set
UC' f = Sigma (RPos -> RPos) (\newδ ->
              (ε : RPos) -> (y : X) -> Q f y ε (newδ ε))

proof : (f : X -> R) -> UC' f -> C' f
proof f (newδ , puc) = (getδ , pc)
  where  getδ  = \c -> newδ
         pc    = \c ε -> puc ε c


module BSTree  {A : Set}(_≤_ : A → A → Set) where

open import BTree {A}

data _⊴*_ : A → BTree → Set where
  gelf : {x : A}
                   → x ⊴* leaf
  gend : {x y : A}{l r : BTree}
                   → x ≤ y
                   → x ⊴* l
                   → x ⊴* (node y l r)

data _*⊴_ : BTree → A → Set where
  lelf : {x : A}
                   → leaf *⊴ x
  lend : {x y : A}{l r : BTree}
                   → y ≤ x
                   → r *⊴ x
                   → (node y l r) *⊴ x

data BSTree : BTree → Set where
  slf : BSTree leaf
  snd : {x : A}{l r : BTree}
                   → BSTree l
                   → BSTree r
                   → l *⊴ x
                   → x ⊴* r
                   → BSTree (node x l r)


----------------------------------------------------------------------
-- 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   --
--                                                                  --
-- Definition of natural numbers and operations on them.            --
----------------------------------------------------------------------

module Basics.Nat where

open import Basics.Bool

-- Nat represents natural numbers (starting with 0)
data Nat : Set where
  zero : Nat
  suc  : Nat → Nat

-- We define a constant 1 as it will be useful later on
one : Nat
one = suc zero

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

infixl 6 _+_

-- Comparisons needed in our code
_<_ : Nat → Nat → Bool
n     < zero  = false
zero  < suc n = true
suc n < suc m = n < m

_≥_ : Nat → Nat → Bool
m     ≥ zero  = true
zero  ≥ suc n = false
suc m ≥ suc n = m ≥ n

infixl 4 _<_ _≥_


import      Lvl
open import Structure.Operator.Vector
open import Structure.Setoid
open import Type

module Structure.Operator.Vector.LinearCombination
  {ℓᵥ ℓₛ ℓᵥₑ ℓₛₑ}
  {V : Type{ℓᵥ}} ⦃ equiv-V : Equiv{ℓᵥₑ}(V) ⦄
  {S : Type{ℓₛ}} ⦃ equiv-S : Equiv{ℓₛₑ}(S) ⦄
  {_+ᵥ_ : V → V → V}
  {_⋅ₛᵥ_ : S → V → V}
  {_+ₛ_ _⋅ₛ_ : S → S → S}
  ⦃ vectorSpace : VectorSpace(_+ᵥ_)(_⋅ₛᵥ_)(_+ₛ_)(_⋅ₛ_) ⦄
  where

open VectorSpace(vectorSpace)

open import Data.Tuple using (_⨯_ ; _,_)
open import Functional using (id ; _∘_ ; _∘₂_ ; _$_ ; swap ; _on₂_)
open import Function.Equals
open import Logic
open import Logic.Predicate
open import Numeral.CoordinateVector as Vec using () renaming (Vector to Vec)
open import Numeral.Finite
open import Numeral.Natural
open import Sets.ExtensionalPredicateSet as PredSet using (PredSet ; _∈_ ; [∋]-binaryRelator)
open import Structure.Function.Domain
open import Syntax.Function

private variable ℓ ℓₗ : Lvl.Level
private variable n : ℕ

-- A linear combination constructed from a sequence of vectors and a sequence of scalars.
-- Linear combination of 0 scalars and vectors are the zero vector.
-- Linear combination of 1 scalar and vector is just scalar on vector multiplication.
-- Example: LinearCombination {4} sf vf = (sf[0] ⋅ₛᵥ vf[0]) +ᵥ (sf[1] ⋅ₛᵥ vf[1]) +ᵥ (sf[2] ⋅ₛᵥ vf[2]) +ᵥ (sf[3] ⋅ₛᵥ vf[3])
-- Inlined definition:
--   LinearCombination {0}       _  _  = 𝟎ᵥ
--   LinearCombination {1}       vf sf = Vec.proj(sf)(0) ⋅ₛᵥ Vec.proj(vf)(0)
--   LinearCombination {𝐒(𝐒(n))} vf sf = (Vec.proj(sf)(0) ⋅ₛᵥ Vec.proj(vf)(0)) +ᵥ (LinearCombination {𝐒(n)} (Vec.tail vf) (Vec.tail sf))
linearCombination : Vec(n)(V) → Vec(n)(S) → V
linearCombination = Vec.reduceOrᵣ(_+ᵥ_) 𝟎ᵥ ∘₂ Vec.map₂(_⋅ᵥₛ_)

-- Whether the two specified vectors are linearly dependent or not.
-- TODO: Is this definition neccessary?
LinearlyDependentPair : V → V → Stmt
LinearlyDependentPair v₁ v₂ = ∃{Obj = S ⨯ S}(\{(s₁ , s₂) → s₁ ⋅ₛᵥ v₁ ≡ s₂ ⋅ₛᵥ v₂})


{-# BUILTIN NATURAL ℕ #-}

module the-naturals where

import Relation.Binary.PropositionalEquality as Eq
open Eq using (_≡_; refl)
open Eq.≡-Reasoning using (begin_; _≡⟨⟩_; _∎)

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

-- the naturals
data ℕ : Set where
  zero : ℕ
  suc  : ℕ → ℕ

-- addition
_+_ : ℕ → ℕ → ℕ
zero + n = n
(suc m) + n = suc (m + n)

-- multiplication
_*_ : ℕ → ℕ → ℕ
zero    * n  =  zero
(suc m) * n  =  n + (m * n)

-- monus ( subtraction for the naturals )
_∸_ : ℕ → ℕ → ℕ
m     ∸ zero   =  m
zero  ∸ suc n  =  zero
suc m ∸ suc n  =  m ∸ n


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

open import LogicalFormulae
open import Sets.EquivalenceRelations
open import Setoids.Setoids

module Setoids.Product {m n o p : _} {A : Set m} {B : Set n} (R : Setoid {m} {o} A) (S : Setoid {n} {p} B) where

open Setoid

productSetoid : Setoid (A && B)
_∼_ (productSetoid) (a ,, b) (c ,, d) = (Setoid._∼_ R a c) && (Setoid._∼_ S b d)
Equivalence.reflexive (eq (productSetoid)) {(a ,, b)} = Equivalence.reflexive (Setoid.eq R) ,, Equivalence.reflexive (Setoid.eq S)
Equivalence.symmetric (eq (productSetoid)) {(a ,, b)} {(c ,, d)} (fst ,, snd) = Equivalence.symmetric (Setoid.eq R) fst ,, Equivalence.symmetric (Setoid.eq S) snd
Equivalence.transitive (eq (productSetoid)) {a ,, b} {c ,, d} {e ,, f} (fst1 ,, snd1) (fst2 ,, snd2) = Equivalence.transitive (Setoid.eq R) fst1 fst2 ,, Equivalence.transitive (Setoid.eq S) snd1 snd2

productLift : {r s : A} {t u : B} → (Setoid._∼_ R r s) → (Setoid._∼_ S t u) → Setoid._∼_ productSetoid (r ,, t) (s ,, u)
_&&_.fst (productLift r=s t=u) = r=s
_&&_.snd (productLift r=s t=u) = t=u