module with-equalities where

open import Agda.Builtin.List

open import Common.Bool
open import Common.Equality

module _ {A : Set} where

  filter : (A → Bool) → List A → List A
  filter p []       = []
  filter p (x ∷ xs) =
    if p x then x ∷ filter p xs else filter p xs

  filter-filter : ∀ p xs → filter p (filter p xs) ≡ filter p xs
  filter-filter p []       = refl
  filter-filter p (x ∷ xs) with p x in eq
  ... | false = filter-filter p xs -- easy
  ... | true -- second filter stuck on `p x`: rewrite by `eq`!
    rewrite eq = cong (x ∷_) (filter-filter p xs)

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

double : Nat → Set
double m = Σ Nat λ n → n + n ≡ m

-- 2*_ : Nat → Σ Nat double
-- 2*_ n with m ← n + n = m , n , {!!}
--  At this point we do not remember that m ≡ n + n and cannot
--  conclude the proof.

-- If only we could give a name to the proof that
-- `p ≡ e` after a `with p ← e` clause !

2*_ : Nat → Σ Nat double
2*_ n with m ← n + n in eq = m , n , eq

data ⊥ : Set where
⊥-elim : ⊥ → {A : Set} → A
⊥-elim ()

¬odd0 : ∀ n → 2 * n + 1 ≡ 0 → ⊥
¬odd0 zero    ()
¬odd0 (suc n) ()

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

module _ {A : Set} where

  oddhead : ∀ {n} → Vec A (2 * n + 1) → A
  oddhead {n} xs
    -- here we cannot split on `xs` because Agda does not know
    -- whether `2 * n + 1` can unify with `0` or not

    -- A possible solution: abstract over p and then match on xs.
--      with p ← (2 * n + 1) | xs
--  ... | x ∷ _ = x
--  ... | []    = {!!}

    -- The problem however is that Agda insists we should consider
    -- two cases: `xs = []` and `xs = x ∷ _`. And in the `[]` branch
    -- we only know that:
    -- p  : Nat
    -- n  : Nat
    -- xs : Vec A 0
    -- If only we had somehow recorded that `p ← (2 * n + 1)` happened!
    -- This is what the inspect construct allows us to do.

    with p ← (2 * n + 1) in eq | xs
  ... | x ∷ _ = x
  -- we can now use this equality proof to dismiss the impossible case.
  ... | []    = ⊥-elim (¬odd0 n eq)

  -- If you do not want to name the nat corresponding to `2 * n + 1`,
  -- you can use inspect together with an implicit with

  oddhead' : ∀ {n} → Vec A (2 * n + 1) → A
  oddhead' {n} xs with {2 * n + 1} in eq | xs
  ... | x ∷ _ = x
  ... | []    = ⊥-elim (¬odd0 n eq)


{-# OPTIONS --without-K #-}
module Computability.Enumeration.Base where

open import Computability.Prelude
open import Computability.Function

record Enumerable (A : Set) : Set where
  field
    enum : ℕ → A
    bijective : Bijective enum

open Enumerable

ℕ-Enumerable : Enumerable ℕ
enum ℕ-Enumerable n = n
proj₁ (bijective ℕ-Enumerable) eq = eq
proj₁ (proj₂ (bijective ℕ-Enumerable) y) = y
proj₂ (proj₂ (bijective ℕ-Enumerable) y) = refl


module Thesis.IntChanges where

open import Data.Integer.Base
open import Relation.Binary.PropositionalEquality

open import Thesis.Changes
open import Theorem.Groups-Nehemiah

private
  intCh = ℤ
instance
  intCS : ChangeStructure ℤ
intCS = record
  { Ch = ℤ
  ; ch_from_to_ = λ dv v1 v2 → v1 + dv ≡ v2
  ; isCompChangeStructure = record
    { isChangeStructure = record
      { _⊕_ = _+_
      ; fromto→⊕ = λ dv v1 v2 v2≡v1+dv → v2≡v1+dv
      ; _⊝_ = _-_
      ; ⊝-fromto = λ a b → n+[m-n]=m {a} {b}
      }
    ; _⊚_ = λ da1 da2 → da1 + da2
    ; ⊚-fromto = i⊚-fromto
    }
  }
  where
    i⊚-fromto : (a1 a2 a3 : ℤ) (da1 da2 : intCh) →
      a1 + da1 ≡ a2 → a2 + da2 ≡ a3 → a1 + (da1 + da2) ≡ a3
    i⊚-fromto a1 a2 a3 da1 da2 a1+da1≡a2 a2+da2≡a3
      rewrite sym (associative-int a1 da1 da2) | a1+da1≡a2 = a2+da2≡a3


{-# OPTIONS --cubical --safe #-}
module Cubical.Algebra.SymmetricGroup where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Equiv
open import Cubical.Foundations.HLevels
open import Cubical.Data.Sigma
open import Cubical.Data.Nat using (ℕ ; suc ; zero)
open import Cubical.Data.Fin using (Fin ; isSetFin)
open import Cubical.Data.Empty
open import Cubical.Relation.Nullary using (¬_)

open import Cubical.Structures.Group
open import Cubical.Structures.NAryOp

private
  variable
    ℓ ℓ' : Level

Symmetric-Group : (X : Type ℓ) → isSet X → Group
Symmetric-Group X isSetX =
  (X ≃ X) ,
  compEquiv ,
  (isOfHLevel≃ 2 isSetX isSetX , compEquiv-assoc) ,
  idEquiv X , (λ f → compEquivEquivId f , compEquivIdEquiv f) , λ f → invEquiv f , invEquiv-is-rinv f , invEquiv-is-linv f

-- Finite symmetrics groups

Sym : ℕ → Group
Sym n = Symmetric-Group (Fin n) isSetFin


------------------------------------------------------------------------------
-- Axiomatic Peano arithmetic base
------------------------------------------------------------------------------

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

-- Mendelson's axioms for first-order Peano arithmetic [Mendelson,
-- 1977, p. 155].

-- Elliott Mendelson. Introduction to mathematical logic. Chapman &
-- Hall, 4th edition, 1997, p. 155.

-- NB. These axioms formalize the propositional equality.

module PA.Axiomatic.Mendelson.Base where

infixl 7 _*_
infixl 6 _+_
infix  4 _≈_ _≉_

------------------------------------------------------------------------------
-- First-order logic (without equality)
open import Common.FOL.FOL public renaming ( D to ℕ )

-- Non-logical constants
postulate
  zero    : ℕ
  succ    : ℕ → ℕ
  _+_ _*_ : ℕ → ℕ → ℕ

-- The PA equality.
--
-- N.B. We use the symbol _≈_ for avoiding to use the
-- --no-internal-equality Apia option.
postulate _≈_ : ℕ → ℕ → Set

-- Inequality.
_≉_ : ℕ → ℕ → Set
x ≉ y = ¬ x ≈ y
{-# ATP definition _≉_ #-}

-- Proper axioms

-- S₁. m = n → m = o → n = o
-- S₂. m = n → succ m = succ n
-- S₃. 0 ≠ succ n
-- S₄. succ m = succ n → m = n
-- S₅. 0 + n = n
-- S₆. succ m + n = succ (m + n)
-- S₇. 0 * n = 0
-- S₈. succ m * n = (m * n) + n
-- S₉. P(0) → (∀n.P(n) → P(succ n)) → ∀n.P(n), for any wff P(n) of PA.

postulate
  S₁ : ∀ {m n o} → m ≈ n → m ≈ o → n ≈ o
  S₂ : ∀ {m n} → m ≈ n → succ m ≈ succ n
  S₃ : ∀ {n} → zero ≉ succ n
  S₄ : ∀ {m n} → succ m ≈ succ n → m ≈ n
  S₅ : ∀ n → zero + n ≈ n
  S₆ : ∀ m n → succ m + n ≈ succ (m + n)
  S₇ : ∀ n → zero * n ≈ zero
  S₈ : ∀ m n → succ m * n ≈ n + m * n
{-# ATP axioms S₁ S₂ S₃ S₄ S₅ S₆ S₇ S₈ #-}

-- S₉ is an axiom schema, therefore we do not translate it to TPTP.
postulate S₉ : (A : ℕ → Set) → A zero → (∀ n → A n → A (succ n)) → ∀ n → A n


module Lists where

open import Nats
open import Bools

open import Agda.Builtin.List public
  using (List; []; _∷_)

infixr 5 _++_ _∷ʳ_

[_] : ∀ {a} {A : Set a} → A → List A
[ x ] = x ∷ []

_++_ : ∀ {a} {A : Set a} → List A → List A → List A
[]       ++ ys = ys
(x ∷ xs) ++ ys = x ∷ (xs ++ ys)

_∷ʳ_ : ∀ {a} {A : Set a} → List A → A → List A
xs ∷ʳ x = xs ++ [ x ]

null : ∀ {a} {A : Set a} → List A → 𝔹
null []       = true
null (x ∷ xs) = false

reverse : ∀ {a} {A : Set a} → List A → List A
reverse [] = []
reverse (x ∷ xs) = reverse xs ∷ʳ x

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


{-# OPTIONS --type-in-type --no-pattern-matching #-}
open import Spire.IDarkwingDuck.Primitive
open import Spire.IDarkwingDuck.Derived
module Spire.IDarkwingDuck.Examples where

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

ℕR : Data
ℕR = Decl End End
  ("zero" ∷ "suc" ∷ [])
  (End tt , Rec tt (End tt) , tt)

ℕ : Set
ℕ = Form ℕR

zero : ℕ
zero = inj ℕR here

suc : ℕ → ℕ
suc = inj ℕR (there here)

VecR : Data
VecR = Decl
  (Arg Set λ _ → End)
  (λ _ → Arg ℕ λ _ → End)
  ("nil" ∷ "cons" ∷ [])
  (λ A →
    End (zero , tt)
  , IArg ℕ (λ n → Arg A λ _ → Rec (n , tt) (End (suc n , tt)))
  , tt
  )

Vec : (A : Set) → ℕ → Set
Vec = Form VecR

nil : {A : Set} → Vec A zero
nil = inj VecR here

cons : {A : Set} {n : ℕ} (x : A) (xs : Vec A n) → Vec A (suc n)
cons = inj VecR (there here)

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

add : ℕ → ℕ → ℕ
add = elim ℕR
  (λ n → ℕ → ℕ)
  (λ n → n)
  (λ m ih n → suc (ih n))

mult : ℕ → ℕ → ℕ
mult = elim ℕR
  (λ n → ℕ → ℕ)
  (λ n → zero)
  (λ m ih n → add n (ih n))

append : {A : Set} {m n : ℕ} (xs : Vec A m) (ys : Vec A n) → Vec A (add m n)
append {A} {m} {n} = elim VecR
  (λ m xs → (ys : Vec A n) → Vec A (add m n))
  (λ ys → ys)
  (λ x xs ih ys → cons x (ih ys))
  m

concat : {A : Set} {m n : ℕ} (xss : Vec (Vec A m) n) → Vec A (mult n m)
concat {A} {m} {n} = elim VecR
  (λ n xss → Vec A (mult n m))
  nil
  (λ xs xss ih → append xs ih)
  n

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

one : ℕ
one = suc zero

two : ℕ
two = suc one

three : ℕ
three = suc two

[1,2] : Vec ℕ two
[1,2] = cons one (cons two nil)

[3] : Vec ℕ one
[3] = cons three nil

[1,2,3] : Vec ℕ three
[1,2,3] = cons one (cons two (cons three nil))

test-append : [1,2,3] ≡ append [1,2] [3]
test-append = refl

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


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

module Deltaplus where

{- Chapter 9.2: Semi-Simplicial Types

   This file contains the definition of the index category
   for semi-simplicial with judgmental categorical laws: Δ₊
   In other words, we check Proposition 9.2.1.

   We want to keep it independent of the other files,
   so we do not import anything. -}

{- For simplicity, we only use the lowest universe
   (totally sufficient) -}
Type = Set

-- the empty type
data Empty : Type where

-- the unit type
data ⊤ : Type where
  * : ⊤

-- the natural numbers
data ℕ : Type where
  O : ℕ
  S : (n : ℕ) → ℕ

{- Finite types: these are the

   ===  OBJECTS of Δ₊ ===

-}
data Fin : ℕ → Type where
  fz : {n : ℕ} → Fin (S n)
  fs : {n : ℕ} → Fin n → Fin (S n)

-- >-relation on finite types
_>fin_ : {n : ℕ} → (i j : Fin n) → Set
fz >fin i = Empty
fs j >fin fz = ⊤
fs j >fin fs i = j >fin i

{- the proposition [we do not need to prove propositionality here, but
   we could prove it easily] that a function is increasing;
   this is the tricky part: it needs to be done in a way which ensures
   that composition will behave nicely (strictly associative etc) later -}
is-increasing : {m n : ℕ} → (Fin m → Fin n) → Type
is-increasing {m} {n} f = {j i : Fin m} → (j >fin i) → ((f j) >fin (f i))

infixr 1 _,_

record Σ (A : Type) (B : A → Type) : Type where
  constructor _,_
  field
    fst : A
    snd : B fst

{- Strictly increasing maps: these are the

   === MORPHISMS of Δ₊ ===

-}
_⇒+_ : ℕ → ℕ → Set
m ⇒+ n = Σ (Fin m → Fin n) is-increasing

_∘+_ : {l m n : ℕ} → (m ⇒+ n) → (l ⇒+ m) → (l ⇒+ n)
(g , p₂) ∘+ (f , p₁) = (λ i → g(f(i))) , (λ p → p₂ (p₁ p))

-- === IDENTITY MORPHISMS of Δ₊ ===

idΔ₊ : ∀ {n} → n ⇒+ n
idΔ₊ = (λ x → x) , (λ p → p)

{- Now, let us check that the categorical laws hold judgmentally.
   To do this, we use the usual notion of equality. -}

infix 3 _==_

data _==_ {A : Type} (a : A) : A → Type where
  idp : a == a

-- === IDENTITY LAWS ===

id-comp : ∀ {m n} → (f : m ⇒+ n) → (idΔ₊ ∘+ f) == f
id-comp f = idp

comp-id : ∀ {m n} → (f : m ⇒+ n) → (f ∘+ idΔ₊) == f
comp-id f = idp

-- === ASSOCIATIVITY LAW ===

comp-assoc : ∀ {i j m n} → (f : i ⇒+ j) → (g : j ⇒+ m) → (h : m ⇒+ n)
             → h ∘+ (g ∘+ f) == (h ∘+ g) ∘+ f
comp-assoc f g h = idp


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

open import Categories.Category

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

open Category C

import Categories.Morphism as M
private
  module Op = M op
open M C

open import Categories.Morphism.Properties C

private
  variable
    A B X Y : Obj
    f g h : A ⇒ B

Mono⇒op-Epi : Mono f → Op.Epi f
Mono⇒op-Epi mono = mono

Epi⇒op-Mono : Epi f → Op.Mono f
Epi⇒op-Mono epi = epi

Iso⇒op-Iso : Iso f g → Op.Iso g f
Iso⇒op-Iso iso = record
  { isoˡ = isoˡ
  ; isoʳ = isoʳ
  }
  where open Iso iso

op-Iso⇒Iso : Op.Iso g f → Iso f g
op-Iso⇒Iso iso = record
  { isoˡ = isoˡ
  ; isoʳ = isoʳ
  }
  where open Op.Iso iso

≅⇒op-≅ : A ≅ B → A Op.≅ B
≅⇒op-≅ A≅B = record
  { from = to
  ; to   = from
  ; iso  = record -- I don't understand why Agda doesn't allow me to apply Iso⇒op-Iso
    { isoˡ = isoˡ
    ; isoʳ = isoʳ
    }
  }
  where open _≅_ A≅B

op-≅⇒≅ : A Op.≅ B → A ≅ B
op-≅⇒≅ A≅B = record
  { from = to
  ; to   = from
  ; iso  = record
    { isoˡ = isoˡ
    ; isoʳ = isoʳ
    }
  }
  where open Op._≅_ A≅B


module BBHeap.Equality {A : Set}(_≤_ : A → A → Set) where

open import BBHeap _≤_
open import Bound.Lower A
open import Bound.Lower.Order _≤_

data _≈_ {b b' : Bound} : BBHeap b → BBHeap b' → Set where
  ≈leaf : leaf {b} ≈ leaf {b'}
  ≈left : {x x' : A}{l r : BBHeap (val x)}{l' r' : BBHeap (val x')}
                   (b≤x : LeB b (val x))
                   (b'≤x' : LeB b' (val x'))
                   (l⋘r : l ⋘ r)
                   (l'⋘r' : l' ⋘ r')
                   → l ≈ l'
                   → r ≈ r'
                   → left b≤x l⋘r ≈ left b'≤x' l'⋘r'
  ≈right : {x x' : A}{l r : BBHeap (val x)}{l' r' : BBHeap (val x')}
                   (b≤x : LeB b (val x))
                   (b'≤x' : LeB b' (val x'))
                   (l⋙r : l ⋙ r)
                   (l'⋙r' : l' ⋙ r')
                   → l ≈ l'
                   → r ≈ r'
                   → right b≤x l⋙r ≈ right b'≤x' l'⋙r'


module Lib.Vec where

open import Common.Nat renaming (zero to Z; suc to S)
open import Lib.Fin
open import Common.Unit
import Common.List -- using (List ; [] ; _∷_)

data Vec (A : Set) :  Nat -> Set where
  _∷_ : forall {n} -> A -> Vec A n -> Vec A (S n)
  []   : Vec A Z

infixr 30 _++_

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

snoc : {A : Set}{n : Nat} -> Vec A n -> A -> Vec A (S n)
snoc []        e = e ∷ []
snoc (x ∷ xs) e = x ∷ snoc xs e

length : {A : Set}{n : Nat} -> Vec A n -> Nat
length [] = Z
length (x ∷ xs) = 1 + length xs

length' : {A : Set}{n : Nat} -> Vec A n -> Nat
length' {n = n} _ = n

zipWith3 : ∀ {A B C D n} -> (A -> B -> C -> D) -> Vec A n -> Vec B n -> Vec C n -> Vec D n
zipWith3 f []        []        []        = []
zipWith3 f (x ∷ xs) (y ∷ ys) (z ∷ zs) = f x y z ∷ zipWith3 f xs ys zs

zipWith : ∀ {A B C n} -> (A -> B -> C) -> Vec A n -> Vec B n -> {u : Unit} -> Vec C n
zipWith _ [] [] = []
zipWith f (x ∷ xs) (y ∷ ys) = f x y ∷ zipWith f xs ys {u = unit}

_!_ : ∀ {A n} -> Vec A n -> Fin n -> A
(x ∷ xs) ! fz = x
(_ ∷ xs) ! fs n = xs ! n
[] ! ()

_[_]=_ : {A : Set}{n : Nat} -> Vec A n -> Fin n -> A -> Vec A n
(a ∷ as) [ fz ]= e = e ∷ as
(a ∷ as) [ fs n ]= e = a ∷ (as [ n ]= e)
[] [ () ]= e

map : ∀ {A B n}(f : A -> B)(xs : Vec A n) -> Vec B n
map f []        = []
map f (x ∷ xs) = f x ∷ map f xs

forgetL : {A : Set}{n : Nat} -> Vec A n -> Common.List.List A
forgetL [] = Common.List.[]
forgetL (x ∷ xs) = x Common.List.∷ forgetL xs

rem : {A : Set}(xs : Common.List.List A) -> Vec A (Common.List.length xs)
rem Common.List.[] = []
rem (x Common.List.∷ xs) = x ∷ rem xs


module Nat where

  import Prelude
  import Equiv
  import Datoid

  open Prelude
  open Equiv
  open Datoid

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

  one : Nat
  one = suc zero

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

  private
    eqNat : Nat -> Nat -> Bool
    eqNat zero    zero    = True
    eqNat (suc m) (suc n) = eqNat m n
    eqNat _       _       = False

    refl' : (x : Nat) -> T (eqNat x x)
    refl' zero    = unit
    refl' (suc n) = refl' n

    sym' : (x y : Nat) -> T (eqNat x y) -> T (eqNat y x)
    sym' zero     zero     _     = unit
    sym' (suc n1) (suc n2) eq    = sym' n1 n2 eq
    sym' (suc _)  zero     wrong = wrong
    sym' zero     (suc _)  wrong = wrong

    trans' : (x y z : Nat) -> T (eqNat x y) -> T (eqNat y z) -> T (eqNat x z)
    trans' zero     _        zero     _     _     = unit
    trans' (suc n1) (suc n2) (suc n3) eq12  eq23  = trans' n1 n2 n3 eq12 eq23
    trans' zero     (suc _)  _        wrong _     = absurdElim wrong
    trans' _        zero     (suc _)  _     wrong = absurdElim wrong
    trans' (suc _)  zero     _        wrong _     = absurdElim wrong
    trans' _        (suc _)  zero     _     wrong = absurdElim wrong

  decidableEquiv : DecidableEquiv Nat
  decidableEquiv = decEquiv (equiv (T' eqNat) refl' sym' trans')
                            (boolFunctionsDecidable eqNat)

  natDatoid : Datoid
  natDatoid = datoid Nat decidableEquiv


------------------------------------------------------------------------
-- Definitions of functions that generate list or vector
------------------------------------------------------------------------

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

module Math.Combinatorics.VecFunction where

-- agda-stdlib
open import Data.List
open import Data.List.NonEmpty as NE using (List⁺)
open import Data.Nat
import Data.Nat.Properties as ℕₚ
open import Data.Product as Prod using (_×_; _,_)
open import Data.Vec as Vec using (Vec; []; _∷_)
open import Function
open import Relation.Binary.PropositionalEquality hiding ([_])

-- agda-combinatorics
import Math.Combinatorics.ListFunction as ListFun

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

  applyEach : ∀ {n} → (A → A) → Vec A n → Vec (Vec A n) n
  applyEach f []       = []
  applyEach f (x ∷ xs) = (f x ∷ xs) ∷ Vec.map (x ∷_) (applyEach f xs)

module _ {a} {A : Set a} where
  -- combinations
  combinations : ∀ k → List A → List (Vec A k)
  combinations 0       xs       = [ [] ]
  combinations (suc k) []       = []
  combinations (suc k) (x ∷ xs) =
    map (x ∷_) (combinations k xs) ++ combinations (suc k) xs

  combinationsWithComplement : ∀ m {n} → Vec A (m + n) →
                               List (Vec A m × Vec A n)
  combinationsWithComplement 0                 xs       = [ [] , xs ]
  combinationsWithComplement m@(suc _) {0}     xs       =
    [ subst (Vec A) (ℕₚ.+-identityʳ m) xs , [] ]
  combinationsWithComplement (suc m)   {suc n} (x ∷ xs) =
    map (Prod.map₁ (x ∷_)) (combinationsWithComplement m xs) ++
    map (Prod.map₂ (x ∷_)) (combinationsWithComplement (suc m) xs′)
      where xs′ = subst (Vec A) (ℕₚ.+-suc m n) xs

  splits₂ : ∀ {n} → Vec A n → Vec (List A × List A) (1 + n)
  splits₂ []           = ([] , []) ∷ []
  splits₂ xxs@(x ∷ xs) = ([] , Vec.toList xxs) ∷
                         Vec.map (Prod.map₁ (x ∷_)) (splits₂ xs)

  splits : ∀ k → List A → List (Vec (List A) k)
  splits 0             xs = []
  splits 1             xs = [ xs ∷ [] ]
  splits (suc (suc k)) xs = concatMap f (splits (suc k) xs)
    where
    f : Vec (List A) (suc k) → List (Vec (List A) (suc (suc k)))
    f (ys ∷ yss) =
      map (λ { (as , bs) → as ∷ bs ∷ yss }) (ListFun.splits₂ ys)

  splits⁺₂ : ∀ {n} → Vec A (1 + n) → Vec (List⁺ A × List⁺ A) n
  splits⁺₂ (x ∷ [])     = []
  splits⁺₂ (x ∷ y ∷ xs) =
    (x NE.∷ [] , y NE.∷ Vec.toList xs) ∷
    Vec.map (Prod.map₁ (x NE.∷⁺_)) (splits⁺₂ (y ∷ xs))

  splits⁺ : ∀ k → List⁺ A → List (Vec (List⁺ A) k)
  splits⁺ 0             xs = []
  splits⁺ 1             xs = [ xs ∷ [] ]
  splits⁺ (suc (suc k)) xs = concatMap f (splits⁺ (suc k) xs)
    where
    f : Vec (List⁺ A) (suc k) → List (Vec (List⁺ A) (suc (suc k)))
    f (ys ∷ yss) =
      map (λ { (as , bs) → as ∷ bs ∷ yss }) (ListFun.splits⁺₂ ys)

  partitions : ∀ k → List A → List (Vec (List A) k)
  partitions 0       []       = [ [] ]
  partitions 0       (x ∷ xs) = []
  partitions (suc k) []       = []
  partitions (suc k) (x ∷ xs) =
    map ([ x ] ∷_) (partitions k xs) ++
    concatMap (Vec.toList ∘ applyEach (x ∷_)) (partitions (suc k) xs)


{-# OPTIONS --cubical-compatible #-}

data Bool : Set where
  true  : Bool
  false : Bool

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

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

infixr 5 _∷_

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

infix 4 _[_]=_

data _[_]=_ {a} {A : Set a} :
            {n : ℕ} → Vec A n → Fin n → A → Set a where
  here  : ∀ {n}     {x}   {xs : Vec A n} → x ∷ xs [ zero ]= x
  there : ∀ {n} {i} {x y} {xs : Vec A n}
          (xs[i]=x : xs [ i ]= x) → y ∷ xs [ suc i ]= x

Subset : ℕ → Set
Subset = Vec Bool

infix 4 _∈_

_∈_ : ∀ {n} → Fin n → Subset n → Set
x ∈ p = p [ x ]= true

drop-there : ∀ {s n x} {p : Subset n} → suc x ∈ s ∷ p → x ∈ p
drop-there (there x∈p) = x∈p

_∘_ : ∀ {a b c}
        {A : Set a} {B : A → Set b} {C : {x : A} → B x → Set c} →
        (∀ {x} (y : B x) → C y) → (g : (x : A) → B x) →
        ((x : A) → C (g x))
f ∘ g = λ x → f (g x)

data ⊥ : Set where

infix 3 ¬_

¬_ : ∀ {ℓ} → Set ℓ → Set ℓ
¬ P = P → ⊥

data Dec {p} (P : Set p) : Set p where
  yes : ( p :   P) → Dec P
  no  : (¬p : ¬ P) → Dec P

infix 4 _∈?_

_∈?_ : ∀ {n} x (p : Subset n) → Dec (x ∈ p)
zero  ∈? true  ∷ p = yes here
zero  ∈? false ∷ p = no  λ()
suc n ∈? s ∷ p       with n ∈? p
...                  | yes n∈p = yes (there n∈p)
...                  | no  n∉p = no  (n∉p ∘ drop-there)


module Logic where

data Bool : Set where
  true : Bool
  false : Bool

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

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


module Data.Vec.All.Properties.Extra {a p}{A : Set a}{P : A → Set p} where

open import Data.List using (List)
import Data.List.Relation.Unary.All as All
open import Data.Vec hiding (_[_]≔_)
open import Data.Vec.Relation.Unary.All hiding (lookup)
open import Data.Fin

all-fromList : ∀ {xs : List A} → All.All P xs → All P (fromList xs)
all-fromList All.[] = []
all-fromList (px All.∷ p) = px ∷ all-fromList p

_[_]≔_ : ∀ {n}{l : Vec A n} → All P l → (i : Fin n) → P (lookup l i)→ All P l
[] [ () ]≔ px
(px ∷ l) [ zero ]≔ px₁ = px₁ ∷ l
(px ∷ l) [ suc i ]≔ px₁ = px ∷ (l [ i ]≔ px₁)


------------------------------------------------------------------------
-- List equality
------------------------------------------------------------------------

module Data.List.Equality where

open import Data.List
open import Relation.Nullary
open import Relation.Binary

module Equality (S : Setoid) where

  open Setoid S renaming (_≈_ to _≊_)

  infixr 5 _∷_
  infix  4 _≈_

  data _≈_ : List carrier → List carrier → Set where
    []  : [] ≈ []
    _∷_ : ∀ {x xs y ys} (x≈y : x ≊ y) (xs≈ys : xs ≈ ys) →
          x ∷ xs ≈ y ∷ ys

  setoid : Setoid
  setoid = record
    { carrier = List carrier
    ; _≈_     = _≈_
    ; isEquivalence = record
      { refl  = refl'
      ; sym   = sym'
      ; trans = trans'
      }
    }
    where
    refl' : Reflexive _≈_
    refl' {[]}     = []
    refl' {x ∷ xs} = refl ∷ refl' {xs}

    sym' : Symmetric _≈_
    sym' []            = []
    sym' (x≈y ∷ xs≈ys) = sym x≈y ∷ sym' xs≈ys

    trans' : Transitive _≈_
    trans' []            []            = []
    trans' (x≈y ∷ xs≈ys) (y≈z ∷ ys≈zs) =
      trans x≈y y≈z ∷ trans' xs≈ys ys≈zs

  open Setoid setoid public hiding (_≈_)

module DecidableEquality (D : DecSetoid) where

  open DecSetoid D hiding (_≈_)
  open Equality setoid renaming (setoid to List-setoid)

  decSetoid : DecSetoid
  decSetoid = record
    { isDecEquivalence = record
      { isEquivalence = Setoid.isEquivalence List-setoid
      ; _≟_           = dec
      }
    }
    where
    dec : Decidable _≈_
    dec []       []       = yes []
    dec (x ∷ xs) (y ∷ ys) with x ≟ y | dec xs ys
    ... | yes x≈y | yes xs≈ys = yes (x≈y ∷ xs≈ys)
    ... | no ¬x≈y | _         = no helper
      where
      helper : ¬ _≈_ (x ∷ xs) (y ∷ ys)
      helper (x≈y ∷ _) = ¬x≈y x≈y
    ... | _       | no ¬xs≈ys = no helper
      where
      helper : ¬ _≈_ (x ∷ xs) (y ∷ ys)
      helper (_ ∷ xs≈ys) = ¬xs≈ys xs≈ys
    dec []       (y ∷ ys) = no λ()
    dec (x ∷ xs) []       = no λ()

  open DecSetoid decSetoid public

module PropositionalEquality {A : Set} where

  open import Relation.Binary.PropositionalEquality as PropEq
    using (_≡_) renaming (refl to ≡-refl)
  open Equality (PropEq.setoid A) public

  ≈⇒≡ : _≈_ ⇒ _≡_
  ≈⇒≡ []               = ≡-refl
  ≈⇒≡ (≡-refl ∷ xs≈ys) with ≈⇒≡ xs≈ys
  ≈⇒≡ (≡-refl ∷ xs≈ys) | ≡-refl = ≡-refl


module half where

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

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

{-# BUILTIN NATURAL ℕ #-}

half : ℕ → ℕ
half zero = zero
half (suc zero) = zero
half (suc (suc i)) = suc (half i)

_ : half 5 ≡ 2
_ = refl

data ℕₛ (n : Size) : Set where
  zero : ℕₛ n
  suc : (m : Size< n) → ℕₛ m → ℕₛ n

_ : ∀ {n} → ℕₛ n
_ = zero

_ : ∀ {n} (m : Size< n) → ℕₛ m → ℕₛ n
_ = suc

halfₛ : ∀ n → ℕₛ n → ℕₛ n
halfₛ n zero = zero
halfₛ n (suc m zero) = zero
halfₛ n (suc m (suc k i)) = suc k (halfₛ k i)


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

open import Data.Nat        using (ℕ; zero; suc; _+_; _*_; _≤_ ; _>_; _<_; _≥_; z≤n; s≤s)
open import Data.Sum        using (_⊎_; inj₁; inj₂)

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

module Nat where

-- Useful functions for natural numbers

_-_ : (n m : ℕ) → {m ≤ n} → ℕ
(n     - zero)  {z≤n}   = n
(suc n - suc m) {s≤s p} = _-_ n m {p}

_-_⟨_⟩ : (n m : ℕ) → (m ≤ n) → ℕ
_-_⟨_⟩ n m m≤n = _-_ n m {m≤n}

m+n-m=n : (m n : ℕ) → {m≤n : m ≤ n} → m + (n - m ⟨ m≤n ⟩) ≡ n
m+n-m=n zero    n       {z≤n}     = refl
m+n-m=n (suc m) (suc n) {s≤s m≤n} = cong suc (m+n-m=n m n {m≤n})

<-∨-≥ : (m n : ℕ) → m < n ⊎ m ≥ n
<-∨-≥ zero    zero    = inj₂ z≤n
<-∨-≥ zero    (suc n) = inj₁ (s≤s z≤n)
<-∨-≥ (suc m) zero    = inj₂ z≤n
<-∨-≥ (suc m) (suc n) with <-∨-≥ m n
... | inj₁ m<n = inj₁ (s≤s m<n)
... | inj₂ m≥n = inj₂ (s≤s m≥n)


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

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

module Boolean.Lemmas where

notNot : (x : Bool) → not (not x) ≡ x
notNot BoolTrue = refl
notNot BoolFalse = refl

notXor : (x y : Bool) → not (xor x y) ≡ xor (not x) y
notXor BoolTrue BoolTrue = refl
notXor BoolTrue BoolFalse = refl
notXor BoolFalse BoolTrue = refl
notXor BoolFalse BoolFalse = refl


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

data even : ℕ → Set
data odd : ℕ → Set

data even where
  zero : even zero
  suc : ∀ {n : ℕ} → odd n → even (suc n)
data odd where
  suc : ∀ {n : ℕ} → even n → odd (suc n)

mutual
  data even′ : ℕ → Set where
    zero : even′ zero
    suc : ∀ {n : ℕ} → odd′ n → even′ (suc n)
  data odd′ : ℕ → Set where
    suc : ∀ {n : ℕ} → even′ n → odd′ (suc n)

{-
/Users/wadler/sf/src/extra/Mutual.agda:3,6-10
Missing definition for even
-}


module Type.Properties.Singleton {ℓ ℓₑ} where

import      Lvl
open import Lang.Instance
open import Structure.Setoid
open import Type

-- A type is a singleton type when it has exactly one inhabitant (there is only one object with this type).
-- In other words: There is an unique inhabitant of type T.
-- Also called:
-- • "singleton type"
-- • "unit type"
-- • "contractible"
record IsUnit (T : Type{ℓ}) ⦃ _ : Equiv{ℓₑ}(T) ⦄ : Type{ℓ Lvl.⊔ ℓₑ} where
  constructor intro
  field
    unit : T
    uniqueness : ∀{x : T} → (x ≡ unit)
open IsUnit ⦃ ... ⦄ using (unit)


------------------------------------------------------------------------
-- Simple regular expression matcher
------------------------------------------------------------------------

open import Eq
open import Setoids
open import Prelude
import RegExps

module SimpleMatcher (D : Datoid) where

private
  open module D' = Datoid D
  open module S' = Setoid setoid
  open module R  = RegExps setoid

infix 4 _∈‿⟦_⟧¿

------------------------------------------------------------------------
-- A lemma

private

  lemma : forall {a x xs₂}
    -> (xs₁ : [ a ]) -> (xs₁ ++ x ∷ []) ++ xs₂ ≡ xs₁ ++ x ∷ xs₂
  lemma []       = refl
  lemma (x ∷ xs) = cong (\ys -> x ∷ ys) (lemma xs)

------------------------------------------------------------------------
-- Regular expression matcher

-- The type of _∈‿⟦_⟧¿ documents its soundness (assuming that the code
-- is terminating). To prove completeness more work is necessary.

matches-⊙¿ : forall xs₁ xs₂ re₁ re₂
             -> Maybe (xs₁ ++ xs₂ ∈‿⟦ re₁ ⊙ re₂ ⟧)

_∈‿⟦_⟧¿ : (xs : [ carrier ]) -> (re : RegExp) -> Maybe (xs ∈‿⟦ re ⟧)
[]     ∈‿⟦ ε ⟧¿         = just matches-ε
_ ∷ [] ∈‿⟦ • ⟧¿         = just matches-•
x ∷ [] ∈‿⟦ sym y ⟧¿     with x ≟ y
x ∷ [] ∈‿⟦ sym y ⟧¿     | yes eq = just (matches-sym eq)
x ∷ [] ∈‿⟦ sym y ⟧¿     | no _   = nothing
xs     ∈‿⟦ re₁ ∣ re₂ ⟧¿ with xs ∈‿⟦ re₁ ⟧¿
xs     ∈‿⟦ re₁ ∣ re₂ ⟧¿ | just m  = just (matches-∣ˡ m)
xs     ∈‿⟦ re₁ ∣ re₂ ⟧¿ | nothing with xs ∈‿⟦ re₂ ⟧¿
xs     ∈‿⟦ re₁ ∣ re₂ ⟧¿ | nothing | just m  = just (matches-∣ʳ m)
xs     ∈‿⟦ re₁ ∣ re₂ ⟧¿ | nothing | nothing = nothing
xs     ∈‿⟦ re₁ ⊙ re₂ ⟧¿ = matches-⊙¿ [] xs re₁ re₂
[]     ∈‿⟦ re ⋆ ⟧¿      = just (matches-⋆ (matches-∣ˡ matches-ε))
x ∷ xs ∈‿⟦ re ⋆ ⟧¿      with matches-⊙¿ (x ∷ []) xs re (re ⋆)
x ∷ xs ∈‿⟦ re ⋆ ⟧¿      | just m  = just (matches-⋆ (matches-∣ʳ m))
x ∷ xs ∈‿⟦ re ⋆ ⟧¿      | nothing = nothing
_      ∈‿⟦ _ ⟧¿         = nothing

matches-⊙¿ xs₁ xs₂ re₁ re₂ with xs₁ ∈‿⟦ re₁ ⟧¿ | xs₂ ∈‿⟦ re₂ ⟧¿
matches-⊙¿ xs₁ xs₂ re₁ re₂ | just m₁ | just m₂ = just (matches-⊙ m₁ m₂)
matches-⊙¿ xs₁ [] re₁ re₂ | _ | _ = nothing
matches-⊙¿ xs₁ (x ∷ xs₂) re₁ re₂ | _ | _ =
  subst (\xs -> Maybe (xs ∈‿⟦ re₁ ⊙ re₂ ⟧))
        (lemma xs₁)
        (matches-⊙¿ (xs₁ ++ x ∷ []) xs₂ re₁ re₂)


open import FRP.JS.Time.Core using ( Time )

module FRP.JS.RSet where

infixr 1 _⇒_

RSet : Set₁
RSet = Time → Set

_⇒_ : RSet → RSet → RSet
(A ⇒ B) t = A t → B t

⟨_⟩ : Set → RSet
⟨ A ⟩ t = A

⟦_⟧ : RSet → Set
⟦ A ⟧ = ∀ {t} → A t


------------------------------------------------------------------------
-- The Agda standard library
--
-- Indexed binary relations
------------------------------------------------------------------------

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

module Relation.Binary.Indexed.Core where

open import Function
open import Level
import Relation.Binary.Core as B
import Relation.Binary.Core as P

------------------------------------------------------------------------
-- Indexed binary relations

-- Heterogeneous.

REL : ∀ {i₁ i₂ a₁ a₂} {I₁ : Set i₁} {I₂ : Set i₂} →
      (I₁ → Set a₁) → (I₂ → Set a₂) → (ℓ : Level) → Set _
REL A₁ A₂ ℓ = ∀ {i₁ i₂} → A₁ i₁ → A₂ i₂ → Set ℓ

-- Homogeneous.

Rel : ∀ {i a} {I : Set i} → (I → Set a) → (ℓ : Level) → Set _
Rel A ℓ = REL A A ℓ

------------------------------------------------------------------------
-- Simple properties of indexed binary relations

-- Reflexivity.

Reflexive : ∀ {i a ℓ} {I : Set i} (A : I → Set a) → Rel A ℓ → Set _
Reflexive _ _∼_ = ∀ {i} → B.Reflexive (_∼_ {i})

-- Symmetry.

Symmetric : ∀ {i a ℓ} {I : Set i} (A : I → Set a) → Rel A ℓ → Set _
Symmetric _ _∼_ = ∀ {i j} → B.Sym (_∼_ {i} {j}) _∼_

-- Transitivity.

Transitive : ∀ {i a ℓ} {I : Set i} (A : I → Set a) → Rel A ℓ → Set _
Transitive _ _∼_ = ∀ {i j k} → B.Trans _∼_ (_∼_ {j}) (_∼_ {i} {k})

------------------------------------------------------------------------
-- Setoids

record IsEquivalence {i a ℓ} {I : Set i} (A : I → Set a)
                     (_≈_ : Rel A ℓ) : Set (i ⊔ a ⊔ ℓ) where
  field
    refl  : Reflexive A _≈_
    sym   : Symmetric A _≈_
    trans : Transitive A _≈_

  reflexive : ∀ {i} → P._≡_ ⟨ B._⇒_ ⟩ _≈_ {i}
  reflexive P.refl = refl

record Setoid {i} (I : Set i) c ℓ : Set (suc (i ⊔ c ⊔ ℓ)) where
  infix 4 _≈_
  field
    Carrier       : I → Set c
    _≈_           : Rel Carrier ℓ
    isEquivalence : IsEquivalence Carrier _≈_

  open IsEquivalence isEquivalence public


module Data.Vec where

open import Prelude
open import Data.Nat
open import Data.Fin hiding (_==_; _<_)
open import Logic.Structure.Applicative
open import Logic.Identity
open import Logic.Base

infixl 90 _#_
infixr 50 _::_
infixl 45 _!_ _[!]_

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

-- Indexing
_!_ : {n : Nat}{A : Set} -> Vec A n -> Fin n -> A
x :: xs ! fzero  = x
x :: xs ! fsuc i = xs ! i

-- Insertion
insert : {n : Nat}{A : Set} -> Fin (suc n) -> A -> Vec A n -> Vec A (suc n)
insert fzero	y  xs	    = y :: xs
insert (fsuc i) y (x :: xs) = x :: insert i y xs

-- Index view
data IndexView {A : Set} : {n : Nat}(i : Fin n) -> Vec A n -> Set where
   ixV : {n : Nat}{i : Fin (suc n)}(x : A)(xs : Vec A n) ->
	 IndexView i (insert i x xs)

_[!]_ : {A : Set}{n : Nat}(xs : Vec A n)(i : Fin n) -> IndexView i xs
x :: xs	[!] fzero  = ixV x xs
x :: xs [!] fsuc i = aux xs i (xs [!] i)
  where
    aux : {n : Nat}(xs : Vec _ n)(i : Fin n) ->
	  IndexView i xs -> IndexView (fsuc i) (x :: xs)
    aux .(insert i y xs) i (ixV y xs) = ixV y (x :: xs)

-- Build a vector from an indexing function (inverse of _!_)
build : {n : Nat}{A : Set} -> (Fin n -> A) -> Vec A n
build {zero } f = []
build {suc _} f = f fzero :: build (f ∘ fsuc)

-- Constant vectors
vec : {n : Nat}{A : Set} -> A -> Vec A n
vec {zero } _ = []
vec {suc m} x = x :: vec x

-- Vector application
_#_ : {n : Nat}{A B : Set} -> Vec (A -> B) n -> Vec A n -> Vec B n
[]	  # []	      = []
(f :: fs) # (x :: xs) = f x :: fs # xs

-- Vectors of length n form an applicative structure
ApplicativeVec : {n : Nat} -> Applicative (\A -> Vec A n)
ApplicativeVec {n} = applicative (vec {n}) (_#_ {n})

-- Map
map : {n : Nat}{A B : Set} -> (A -> B) -> Vec A n -> Vec B n
map f xs = vec f # xs

-- Zip
zip : {n : Nat}{A B C : Set} -> (A -> B -> C) -> Vec A n -> Vec B n -> Vec C n
zip f xs ys = vec f # xs # ys

module Elem where

  infix 40 _∈_ _∉_

  data _∈_ {A : Set}(x : A) : {n : Nat}(xs : Vec A n) -> Set where
    hd : {n : Nat}	 {xs : Vec A n}		  -> x ∈ x :: xs
    tl : {n : Nat}{y : A}{xs : Vec A n} -> x ∈ xs -> x ∈ y :: xs

  data _∉_ {A : Set}(x : A) : {n : Nat}(xs : Vec A n) -> Set where
    nl	: x ∉ []
    cns : {n : Nat}{y : A}{xs : Vec A n} -> x ≢ y -> x ∉ xs -> x ∉ y :: xs

  ∉=¬∈ : {A : Set}{x : A}{n : Nat}{xs : Vec A n} -> x ∉ xs -> ¬ (x ∈ xs)
  ∉=¬∈ nl	       ()
  ∉=¬∈ {A} (cns x≠x _) hd    = elim-False (x≠x refl)
  ∉=¬∈ {A} (cns _ ne) (tl e) = ∉=¬∈ ne e

  ∈=¬∉ : {A : Set}{x : A}{n : Nat}{xs : Vec A n} -> x ∈ xs -> ¬ (x ∉ xs)
  ∈=¬∉ e ne = ∉=¬∈ ne e

  find : {A : Set}{n : Nat} -> ((x y : A) -> x ≡ y \/ x ≢ y) ->
	 (x : A)(xs : Vec A n) -> x ∈ xs \/ x ∉ xs
  find _  _ []	      = \/-IR nl
  find eq y (x :: xs) = aux x y (eq y x) (find eq y xs) where
    aux : forall x y -> y ≡ x \/ y ≢ x -> y ∈ xs \/ y ∉ xs -> y ∈ x :: xs \/ y ∉ x :: xs
    aux x .x (\/-IL refl)  _	       = \/-IL hd
    aux x y  (\/-IR y≠x)  (\/-IR y∉xs) = \/-IR (cns y≠x y∉xs)
    aux x y  (\/-IR _)	  (\/-IL y∈xs) = \/-IL (tl y∈xs)

  delete : {A : Set}{n : Nat}(x : A)(xs : Vec A (suc n)) -> x ∈ xs -> Vec A n
  delete	   .x (x :: xs)  hd    = xs
  delete {A}{zero } _  ._	(tl ())
  delete {A}{suc _} y (x :: xs) (tl p) = x :: delete y xs p


{-# OPTIONS --without-K #-}
module Functoriality {a} {A : Set a} where

open import PathOperations
open import Types

ap⁻¹ : ∀ {b} {B : Set b} {x y : A} (f : A → B) (p : x ≡ y) →
  ap f (p ⁻¹) ≡ (ap f p) ⁻¹
ap⁻¹ f = J
  (λ _ _ p → ap f (p ⁻¹) ≡ ap f p ⁻¹)
  (λ _ → refl) _ _

ap· : ∀ {b} {B : Set b} {x y z : A} (f : A → B)
  (p : x ≡ y) (q : y ≡ z) →
  ap f (p · q) ≡ ap f p · ap f q
ap· {z = z} f = J
  (λ _ y p → (q : y ≡ z) → ap f (p · q) ≡ ap f p · ap f q)
  (λ _ _ → refl) _ _

ap-id : {x y : A} (p : x ≡ y) → ap id p ≡ p
ap-id = J (λ _ _ p → ap id p ≡ p) (λ _ → refl) _ _

ap-∘ : ∀ {b c} {B : Set b} {C : Set c} {x y : A}
  (f : B → C) (g : A → B) (p : x ≡ y) →
  ap (f ∘ g) p ≡ ap f (ap g p)
ap-∘ f g = J
  (λ _ _ p → ap (f ∘ g) p ≡ ap f (ap g p))
  (λ _ → refl) _ _


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

module Ch1 where

-- open import lib.Base
open import Base

-- warmup
module Eq-1-11-2 {i j} {A : Type i} {B : Type j} where

  -- import lib.types.Coproduct
  -- open import lib.types.Empty
  -- open import lib.types.Sigma

  -- If not A and not B, then not (A or B)
  deMorgan1 : (A → ⊥) × (B → ⊥) → (Coprod A B → ⊥)
  -- deMorgan1 (notA , notB) ab = {!!} -- {!!} becomes =>
  -- deMorgan1 (notA , notB) (inl x) = {!!} -- by cases, C-c C-c on param ab
  -- deMorgan1 (notA , notB) (inr x) = {!!}
  deMorgan1 (notA , notB) (inl a) = notA a -- the 'a part' of (A + B) → ⊥
  deMorgan1 (notA , notB) (inr b) = notB b

module Ex1-1 where

  {-
  Exercise 1.1. Given functions f : A -> B and g : B -> C, define their composite g o f : A ->  C.
  Show that we have h o (g o f ) == (h o g) o f
  -}

  _o_ : ∀ {i} {A B C : Type i} → (B → C) → (A → B) → A → C
  (g o f) x = g (f x)

  o-assoc : ∀ {i} {A B C D : Type i} →
    (h : C → D) → (g : B → C) → (f : A → B) →
    h o (g o f) == (h o g) o f
  o-assoc _ _ _ = idp -- "it's de proof"

module Ex1-2 where

  -- open import lib.types.Sigma

  -- Derive the recursion principle for products recA×B using only the projections, and
  -- verify that the definitional equalities are valid. Do the same for Σ-types.

  recAxB : ∀ {i} {A B C : Type i} →
    (A → B → C) → A × B → C
  recAxB f ab = f (fst ab) (snd ab)

  recAxB= : ∀ {i} {A B C : Type i}
    {f : A → B → C}
    {a : A} {b : B} →
    recAxB f (a , b) == f a b
  recAxB= = idp

  recA+B : ∀ {i j} {A : Type i} {B : Type j} {C : Type (lmax i j)} →
    (A → C) → (B → C) → (Coprod A B → C)
  recA+B f g (inl x) = f x
  recA+B f g (inr x) = g x

  recA+B= : {A B C : Type0}
    {f : A → C} {g : B → C}
    {a : A} {b : B} →
    (recA+B f g (inl a) == f a) × (recA+B f g (inr b) == g b)
  recA+B= = idp , idp

  recΣ : ∀ {i j} {A : Type i} {B : A → Type j} {C : Type (lmax i j)} →
    ((a : A) → B a → C) →
    Σ A B → C
  recΣ f ab = f (fst ab) (snd ab)

  recΣ= : ∀ {i j} {A : Type i} {B : A → Type j} {C : Type (lmax i j)}
    {f : (a : A) → B a → C}
    {a : A} {ba : B a} →
    recΣ f (a , ba) == f a ba
  recΣ= = idp

module Ex1-3 {i j} {A : Type i} {B : Type j} where

  -- open import lib.types.Sigma

  {- Derive the induction principle for products indA×B, using only the projections
  and the propositional uniqueness principle uppt. Verify that the definitional
  equalities are valid. Gen- eralize uppt to Σ-types, and do the same for Σ-types.
  -}

  -- book definition of uppt
  uppt-× : (ab : (A × B)) → (fst ab , snd ab) == ab
  uppt-× = λ _ → idp

  -- definition of induction principle the projections and the transported uniqueness principle
  -- (this was a confusing question to work out in Agda, since the transport is redundant / inferred by the typechecker)
  ind-× : (C :  (A × B) → Type (lmax i j)) →
    ((a : A ) → (b : B) → C (a , b)) → Π (A × B) C
  ind-× C g ab = transport C (uppt-× ab) (g (fst ab) (snd ab))

  -- (propositional) verification of defining equations
  ind-×= : (C :  (A × B) → Type (lmax i j)) →
    (g : ((a : A ) → (b : B) → C (a , b))) →
    ∀ {a b} → ind-× C g (a , b) == g a b
  ind-×= C g {a} {b} = -- idp
    ind-× C g (a , b) =⟨ idp ⟩
    transport C (uppt-× (a , b)) (g a b) =⟨ idp ⟩
    transport C idp (g a b) =⟨ idp ⟩
    g a b ∎

  -- book definition of induction principle using pattern matching
  pattern-match-ind-× : (C :  (A × B) → Type (lmax i j)) →
    Π A (λ x → Π B (λ y → C (x , y))) → Π (A × B) C
  pattern-match-ind-× _ g (a , b) = g a b

  -- alternative definition of uniqueness principle (from induction principle)
  ind-uppt-× : (x : (A × B)) → (fst x , snd x) == x
  ind-uppt-× = ind-× (λ z → z == z) (λ x x₁ → idp)

  -- validate definition for uppt
  uppt-×= : {x : (A × B)} → (uppt-× x) == (ind-uppt-× x)
  uppt-×= = idp

  -- uppt for Σ types
  upptΣ : {B : (a : A) → Type j} → (ab : Σ A B) → ab == (fst ab , snd ab)
  upptΣ _ = idp

module Ex1-4 where

  -- open import lib.types.Sigma

  {-
  Assuming as given only the iterator for natural numbers
  iter : ∏ C → (C → C) → N → C
       C:U
  with the defining equations
  iter(C, c0, cs, succ(n)) :≡ cs(iter(C, c0, cs, n)),
  derive a function having the type of the recursor recN. Show that the defining
  equations of the recursor hold propositionally for this function, using the
  induction principle for N.
  -}

  iter : {C : Type0} →
    C → (C → C) → ℕ → C
  iter c0 cs 0 = c0
  iter c0 cs (S n) = cs (iter c0 cs n)

  -- used in the definition of recNiter below to keep a count of the applications of a function
  sucApply : {C : Type0} → (ℕ → C → C) → ℕ × C → ℕ × C
  sucApply {C} cs = cs' where
    cs' : ℕ × C → ℕ × C
    cs' (n , c) = S n , cs n c

  {- Induction principle (dependent eliminator) for ℕ from the book:

  indN : ∏(C:N→U)C(0) → ∏(n:N)C(n) → C(succ(n)) → ∏(n:N)C(n)
  indN(C, c0, cs, 0) :≡ c0,
  indN(C, c0, cs, succ(n)) :≡ cs(n, indN(C, c0, cs, n)).
  -}
  indN : ∀ {i} {C : ℕ → Type i} →
    C 0 → ((n : ℕ) → C n → C (S n)) → (n : ℕ) → C n
  indN c0 cs 0 = c0
  indN c0 cs (S n) = cs n (indN c0 cs n)

  -- digression / warmup - inductive proof that evens-are-even

  -- nth even
  even : ℕ → ℕ
  even n = iter 0 (λ n → S (S n)) n

  S= : {m n : ℕ} → m == n → (S m == S n)
  S= idp = idp

  _*2 : ℕ → ℕ
  O *2 = O
  (S n) *2 = S (S (n *2))

  evens-are-even : (n : ℕ) → Σ ℕ (λ m → even n == m *2)
  evens-are-even = indN (0 , idp) inductiveCase where
    inductiveCase : (n : ℕ) → Σ ℕ (λ m → even n == m *2) → Σ ℕ (λ m → even (S n) == m *2)
    inductiveCase n (m , p) = S m , p'' where
      p' = S= p
      p'' = S= p'

  {- derive a function having the type of the recursor recN
  recN : ∏(C:U)C→(N→C→C)→N→C
  recN(C, c0, cs, 0) :≡ c0,
  recN(C, c0, cs, Sc(n)) :≡ cs(n, recN(C, c0, cs, n)).
  -}
  recNiter : {C : Type0} →
    C → (ℕ → C → C) → ℕ → C
  recNiter c0 cs n = snd (iter (0 , c0) cs' n) where
           cs' = sucApply cs

  {- Show that the defining
  equations of the recursor hold propositionally for this function, using the
  induction principle for N
  -}
  recNiter= : {C : Type0} {c0 : C} {cs : ℕ → C → C } →
    (n : ℕ) →
    (recNiter c0 cs (S n)) == (cs n (recNiter c0 cs n))
  recNiter= {C} {c0} {cs} n = cs= n'= -- or, as spelled out below (using equational reasoning from HoTT-Agda)
    -- recNiter c0 cs (S n) =⟨ idp ⟩
    -- snd (iter' (S n)) =⟨ idp ⟩
    -- snd (cs' (iter' n)) =⟨ idp ⟩
    -- snd (cs' (n' , snd (iter' n))) =⟨ idp ⟩
    -- cs n' (snd (iter' n)) =⟨ cs= n'= ⟩
    -- cs n (snd (iter' n)) =⟨ idp ⟩
    -- cs n (recNiter c0 cs n) ∎
    where
      cs' = sucApply cs

      iter' : ℕ → ℕ × C
      iter' = iter (0 , c0) cs'

      n' = fst (iter' n)

      -- proof that the first (counter) projection of the iter version of recN at n is just n
      fstIter'= : (n : ℕ) → (fst (iter (0 , c0) cs' n) == n)
      fstIter'= = indN idp inductiveCase where
        inductiveCase : (n : ℕ) →
          fst (iter' n) == n →
          fst (iter' (S n)) == S n
        inductiveCase m p = S= p -- or, as spelled out below
          -- fst (iter (0 , c0) cs' (S m)) =⟨ idp ⟩
          -- fst (cs' (iter (0 , c0) cs' m)) =⟨ idp ⟩
          -- fst (cs' (iter (0 , c0) cs' m)) =⟨ idp ⟩
          -- -- fst (cs' (fst (iter (0 , c0) cs' m) , _)) =⟨ idp ⟩ -- Agda loses track of some hidden
          -- -- fst (S (fst (iter (0 , c0) cs' m)) , _) =⟨ idp ⟩ -- type data here, thus double-protective comments
          -- S (fst (iter (0 , c0) cs' m)) =⟨ S= p ⟩
          -- S m ∎

      n'= : n' == n
      n'= = fstIter'= n

      cs= : ∀ {n m} {c : C} → n == m → cs n c == cs m c
      cs= idp = idp

-- recursor for Bool (used in next two exercises)
module RecBool where
  recBool : ∀ {i} {A : Type i} → A → A → Bool → A
  recBool x y true = x
  recBool x y false = y

module Ex1-5 where
  open RecBool
  {-
  Exercise 1.5. Show that if we define A + B :≡ ∑(x:2) rec2(U, A, B, x), then we can give a definition
  of indA+B for which the definitional equalities stated in §1.7 hold.
  -}
  _+_ : ∀ {i} → Type i → Type i → Type _
  A + B = Σ Bool (λ isA → recBool A B isA)

  inl-+ : ∀ {i} {A B : Type i} → A → A + B
  inl-+ a = true , a

  inr-+ : ∀ {i} {A B : Type i} → B → A + B
  inr-+ b = false , b

  ind-+ : ∀ {i j} {A B : Type i} (C : A + B → Type j) →
    ((a : A) → C (inl-+ a)) → ((b : B) → C (inr-+ b)) →
    (x : A + B) → C x
  ind-+ C g1 g2 (true , a) = g1 a
  ind-+ C g1 g2 (false , b) = g2 b

module Ex1-6 {i} {A B : Type i} where
  open RecBool
  open import FunExt
  {-
  Exercise 1.6. Show that if we define A × B :≡ ∏(x:2) rec2(U, A, B, x), then we can give a defini- tion of indA×B for which the definitional equalities stated in §1.5 hold propositionally (i.e. using equality types). (This requires the function extensionality axiom, which is introduced in §2.9.)
  -}

  _x_ : ∀ {i} → (A : Type i) → (B : Type i) → Type _
  A x B = Π Bool (λ ab → recBool A B ab)

  _,,_ : A → B → A x B
  _,,_ a b true = a
  _,,_ a b false = b

  fst-x : A x B → A
  fst-x ab = ab true

  snd-x : A x B → B
  snd-x ab = ab false

  uppt-x : (ab : (A x B)) → (fst-x ab ,, snd-x ab) == ab
  uppt-x ab = is-equiv.g fe h where -- (fst-x ab ,, snd-x ab) x == ab x
    fe = fun-ext ((fst-x ab ,, snd-x ab)) ab
    h : (c : Bool) → (fst-x ab ,, snd-x ab) c == ab c
    h true = idp
    h false = idp

  ind-x : ∀ {j} (C : A x B → Type j) →
    ((a : A) → (b : B) → C (a ,, b)) →
    (ab : A x B) → C ab
  ind-x C g ab = transport C (uppt-x ab) (g a b) where
    a = fst-x ab
    b = snd-x ab

module Ex1-7 where
  {-
  Exercise 1.7. Give an alternative derivation of ind′=A from ind=A which avoids the use of universes. (This is easiest
  using concepts from later chapters.)
  -}

  {-
  Section 1.12.2 "we can show that ind=A entails Lemmas2.3.1 and 3.11.8, and that these two principles imply ind′=A
  directly"
  -}

  {-
  Lemma 2.3.1 (Transport). Suppose that P is a type family over A and that p : x =A y. Then there is a function
    p∗ : P(x) → P(y).
  -}

  {-
  Lemma 3.11.8. For any A and any a : A, the type ∑(x:A)(a = x) is contractible.
  -}
  lemma-3-11-8 : ∀ {i} {A : Type i} (a : A) → is-contr (Σ A λ x → a == x)
  lemma-3-11-8 {_} {A} a = ((a , idp)) , λ { (x , p) → along {x} p } where
    along : {x : A}(p : a == x) → (a , idp) == (x , p)
    along idp = idp -- should really prove using ind== then ind='2 will indeed be based path induction from free
                    -- path induction

  ind='2 : ∀ {i j} {A : Type i} {a : A} →
    (D : (x : A) (p : a == x) → Type j) →
    D a idp →
    {x : A} (p : a == x) →
    D x p
  ind='2 {i} {j} {A} {a} D d {x} p = transport (λ { (x , p) → D x p}) (snd (lemma-3-11-8 a) (x , p)) d

module Ex1-14 where

  {- Exercise 1.14. Why do the induction principles for identity types not allow us to construct a
  function f : ∏(x:A) ∏(p:x=x)(p = reflx) with the defining equation f (x, reflx ) :≡ reflreflx ? -}

module Ex1-15 {i j} {A : Type i} {C : A → Type j} where
  {- Exercise 1.15. Show that indiscernability of identicals follows from path induction. -}

  f : ∀ {x y : A} (p : x == y) → C x → C y
  f idp = ind== (λ x y _ → C x → C y) (λ x → λ cx → cx) idp


module Example1 where

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

{-# BUILTIN NATURAL Nat #-}

data _==_ {l} {a : Set l} : a -> a -> Set l where
  refl : ∀{x} -> x == x

{-# BUILTIN EQUALITY _==_ #-}

cong : ∀{l} -> {A B : Set l} {x y : A} -> (f : A -> B) -> x == y -> f x == f y
cong f refl = refl

sym : ∀{l} {A : Set l} {x y : A} -> x == y -> y == x
sym refl = refl

_+_ : Nat -> Nat -> Nat
x + zero = x
x + suc y = suc (x + y)

_+₂_ : Nat -> Nat -> Nat
zero +₂ y = y
suc x +₂ y = {!!}

plus-right-identity : ∀{n} -> (n + 0) == n
plus-right-identity {n} = refl

plus-left-identity : (n : Nat) -> (0 + n) == n
plus-left-identity zero = refl
plus-left-identity (suc n) = cong suc (plus-left-identity n)

plus-comm : (m n : Nat) -> (m + n) == (n + m)
plus-comm m zero = sym (plus-left-identity m)
plus-comm m (suc n) = {!!}

plus-succ : ∀{m n} -> (m + suc n) == suc (m + n)
plus-succ = refl

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

replicate : ∀{A} -> (n : Nat) -> A -> Vec A n
replicate zero x = []
replicate (suc n) x = x ∷ replicate n x

data Pair (A B : Set) : Set where
  _,_ : A -> B -> Pair A B

zip : ∀{n A B} -> Vec A n -> Vec B n -> Vec (Pair A B) n
zip [] ys = []
zip {suc n} (x ∷ xs) (y ∷ ys) = replicate (suc n) (x , y)

map : ∀{n A B} -> (A -> B) -> Vec A n -> Vec B n
map f [] = []
map {suc n} f (x ∷ xs) = (f x) ∷ (map f xs) -- f x ∷ map f xs -- replicate (suc n) (f x)

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

map-id : ∀{n A} (xs : Vec A n) -> map id xs == xs
map-id [] = refl
map-id (x ∷ xs) = cong (_∷_ x) (map-id xs)

data Bool : Set where
  false true : Bool

not : Bool -> Bool
not false = true
not true = false

not-self-inverse : {x : Bool} -> not (not x) == x
not-self-inverse {false} = refl
not-self-inverse {true} = refl

data Empty : Set where

not-not-id : {x : Bool} -> not x == id x -> Empty
not-not-id {false} ()
not-not-id {true} ()


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

open import Level
open import Function renaming (id to id→; _∘_ to _●_) using ()

open import Categories.Category
open import Categories.Functor.Core public

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

Endofunctor : Category o ℓ e → Set _
Endofunctor C = Functor C C

id : ∀ {C : Category o ℓ e} → Functor C C
id {C = C} = record
  { F₀           = id→
  ; F₁           = id→
  ; identity     = Category.Equiv.refl C
  ; homomorphism = Category.Equiv.refl C
  ; F-resp-≈     = id→
  }

infixr 9 _∘F_

-- note that this definition could be shortened by inlining the definitions for
-- identity′ and homomorphism′, but the definitions below are simpler to understand.
_∘F_ : ∀ {C : Category o ℓ e} {D : Category o′ ℓ′ e′} {E : Category o″ ℓ″ e″}
    → Functor D E → Functor C D → Functor C E
_∘F_ {C = C} {D = D} {E = E} F G = record
  { F₀ = F.₀ ● G.₀
  ; F₁ = F.₁ ● G.₁
  ; identity = identity′
  ; homomorphism = homomorphism′
  ; F-resp-≈ =  F.F-resp-≈ ● G.F-resp-≈
  }
  where
  module C = Category C using (id)
  module D = Category D using (id)
  module E = Category E using (id; module HomReasoning)
  module F = Functor F
  module G = Functor G

  identity′ : ∀ {A} → E [ F.₁ (G.₁ (C.id {A})) ≈ E.id ]
  identity′ = begin
    F.₁ (G.₁ C.id) ≈⟨ F.F-resp-≈ G.identity ⟩
    F.₁ D.id       ≈⟨ F.identity ⟩
    E.id           ∎
    where open E.HomReasoning

  homomorphism′ : ∀ {X Y Z} {f : C [ X , Y ]} {g : C [ Y , Z ]}
                 → E [ F.₁ (G.₁ (C [ g ∘ f ])) ≈ E [ F.₁ (G.₁ g) ∘ F.₁ (G.₁ f) ] ]
  homomorphism′ {f = f} {g = g} = begin
    F.₁ (G.₁ (C [ g ∘ f ]))         ≈⟨ F.F-resp-≈ G.homomorphism ⟩
    F.₁ (D [ G.₁ g ∘ G.₁ f ])       ≈⟨ F.homomorphism ⟩
    E [ F.₁ (G.₁ g) ∘ F.₁ (G.₁ f) ] ∎
    where open E.HomReasoning


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

module Rewrite-with-doubly-indexed-equality where

open import Common.Level

infix 4 _≡_

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

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

sym : {A : Set}{x y : A} → x ≡ y → y ≡ x
sym refl = refl

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

infixl 6 _+_

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

plus-zero : ∀ n → n + zero ≡ n
plus-zero zero    = refl
plus-zero (suc n) rewrite plus-zero n = refl

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

-- Proving things about functions using rewrite
data IsRefl {A : Set}{x : A} : ∀ {y} → x ≡ y → Set where
  isRefl : IsRefl refl

plus-suc-isrefl : ∀ {n m} → IsRefl (plus-suc n m)
plus-suc-isrefl {zero } {m} = isRefl
plus-suc-isrefl {suc n} {m} rewrite plus-suc n m = isRefl

-- Multiple rewrites
com : ∀ n m → n + m ≡ m + n
com n zero    = plus-zero _
com n (suc m) rewrite plus-suc n m
                    | com n m
              = refl

-- rewrite followed by with
thm : ∀ a b c → a + (b + c) ≡ (c + b) + a
thm a b c rewrite com b c with c + b
... | cb = com a cb

data List A : Set where
  [] : List A
  _∷_ : (x : A)(xs : List A) → List A

infixr 30 _∷_ _++_

_++_ : ∀ {A} → List A → List A → List A
[]       ++ ys = ys
(x ∷ xs) ++ ys = x ∷ (xs ++ ys)

-- rewrite in parameterised module
module ListProps {A : Set} where

  append-nil : (xs : List A) → xs ++ [] ≡ xs
  append-nil []       = refl
  append-nil (x ∷ xs) rewrite append-nil xs = refl

  append-assoc : (as bs cs : List A) → (as ++ bs) ++ cs ≡ as ++ (bs ++ cs)
  append-assoc []       bs cs = refl
  append-assoc (a ∷ as) bs cs rewrite append-assoc as bs cs = refl

  -- With implicit arguments
  append-assoc′ : ∀ (as : List A) {bs cs} → (as ++ bs) ++ cs ≡ as ++ (bs ++ cs)
  append-assoc′ []       = refl
  append-assoc′ (a ∷ as) {bs}{cs} rewrite append-assoc′ as {bs} {cs} = refl

  reverse : List A → List A
  reverse []       = []
  reverse (x ∷ xs) = reverse xs ++ x ∷ []

  reverse-append : ∀ as bs → reverse (as ++ bs) ≡ reverse bs ++ reverse as
  reverse-append []       bs rewrite append-nil (reverse bs) = refl
  reverse-append (a ∷ as) bs rewrite reverse-append as bs
                          = append-assoc (reverse bs) _ _

  reverse-reverse : ∀ as → reverse (reverse as) ≡ as
  reverse-reverse []       = refl
  reverse-reverse (a ∷ as) rewrite reverse-append (reverse as) (a ∷ [])
                                 | reverse-reverse as
                           = refl

open ListProps

map : ∀ {A B} → (A → B) → List A → List B
map f []       = []
map f (x ∷ xs) = f x ∷ map f xs

_∘_ : {A : Set}{B : A → Set}{C : ∀ x → B x → Set}
      (f : ∀ {x} (y : B x) → C x y)(g : ∀ x → B x)
      (x : A) → C x (g x)
(f ∘ g) x = f (g x)

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

map-id : ∀ {A} (xs : List A) → map id xs ≡ xs
map-id []       = refl
map-id (x ∷ xs) rewrite map-id xs = refl

map-compose : ∀ {A B C} (f : B → C)(g : A → B)(xs : List A) →
              map (f ∘ g) xs ≡ (map f ∘ map g) xs
map-compose f g []       = refl
map-compose f g (x ∷ xs) rewrite map-compose f g xs = refl

map-append : ∀ {A B} (f : A → B) (xs ys : List A) →
             map f (xs ++ ys) ≡ map f xs ++ map f ys
map-append f []       ys = refl
map-append f (x ∷ xs) ys rewrite map-append f xs ys = refl

map-reverse : ∀ {A B} (f : A → B) (xs : List A) →
              map f (reverse xs) ≡ reverse (map f xs)
map-reverse f []       = refl
map-reverse f (x ∷ xs) rewrite map-append f (reverse xs) (x ∷ [])
                             | map-reverse f xs
                       = refl

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)

foldl : {A B : Set} → (B → A → B) → B → List A → B
foldl f z []       = z
foldl f z (x ∷ xs) = foldl f (f z x) xs

module FoldAssoc
  {A : Set}(_∙_ : A → A → A)
  (assoc : ∀ x y z → ((x ∙ y) ∙ z) ≡ (x ∙ (y ∙ z))) where

  smashr = foldr _∙_
  smashl = foldl _∙_

  foldr-append : ∀ ∅ z xs ys → (∀ x → (∅ ∙ x) ≡ x) →
                 smashr z (xs ++ ys) ≡ (smashr ∅ xs ∙ smashr z ys)
  foldr-append ∅ z []       ys idl = sym (idl _)
  foldr-append ∅ z (x ∷ xs) ys idl rewrite assoc x (smashr ∅ xs) (smashr z ys)
                                         | foldr-append ∅ z xs ys idl
                                   = refl

  foldl-plus : ∀ z₁ z₂ xs → smashl (z₁ ∙ z₂) xs ≡ (z₁ ∙ smashl z₂ xs)
  foldl-plus z₁ z₂ []       = refl
  foldl-plus z₁ z₂ (x ∷ xs) rewrite assoc z₁ z₂ x
                            = foldl-plus _ _ xs

  foldr=foldl : ∀ ∅ → (∀ x → (∅ ∙ x) ≡ (x ∙ ∅)) →
                ∀ xs → foldr _∙_ ∅ xs ≡ foldl _∙_ ∅ xs
  foldr=foldl ∅ id []       = refl
  foldr=foldl ∅ id (x ∷ xs) rewrite id x
                                  | foldl-plus x ∅ xs
                                  | foldr=foldl ∅ id xs
                            = refl

foldr-compose : ∀ {A B C : Set} (f : B → C → C) (z : C) (g : A → B) (xs : List A) →
                foldr (f ∘ g) z xs ≡ foldr f z (map g xs)
foldr-compose f z g []       = refl
foldr-compose f z g (x ∷ xs) rewrite foldr-compose f z g xs = refl

foldr-fusion : ∀ {A B C : Set} (f : B → C) (_⊕_ : A → B → B) (_⊗_ : A → C → C) (z : B) →
               (∀ x y → f (x ⊕ y) ≡ (x ⊗ f y)) →
               ∀ xs → f (foldr _⊕_ z xs) ≡ foldr _⊗_ (f z) xs
foldr-fusion f _⊕_ _⊗_ z distr []       = refl
foldr-fusion f _⊕_ _⊗_ z distr (x ∷ xs)
  rewrite sym (foldr-fusion f _⊕_ _⊗_ z distr xs)
  with    foldr _⊕_ z xs
...  |    y = distr x y


open import Data.Boolean
open import Type

module Data.BinaryTree.Heap {ℓ} {T : Type{ℓ}} (_≤?_ : T → T → Bool) where

import      Lvl
open import Data hiding (empty)
open import Data.BinaryTree

BinaryHeap = BinaryTree (Unit{Lvl.𝟎}) (T)

private variable ℓᵣ : Lvl.Level
private variable R : Type{ℓᵣ}

open import Data.Option
open import Data.Tuple as Tuple using (_⨯_ ; _,_)
open import Functional as Fn using (_∘_ ; _∘₂_ ; _$_)

merge : BinaryHeap → BinaryHeap → BinaryHeap
merge (Leaf <>)         (Leaf <>)      = Leaf <>
merge x@(Node _ _ _)    (Leaf <>)      = x
merge (Leaf <>)         y@(Node _ _ _) = y
merge x@(Node xa xl xr) y@(Node ya yl yr) with (xa ≤? ya) | (\_ → merge y xr) | (\_ → merge x yr)
... | 𝑇 | 𝑇-branch | _ = Node xa (𝑇-branch(<>{Lvl.𝟎})) xl
... | 𝐹 | _ | 𝐹-branch = Node ya (𝐹-branch(<>{Lvl.𝟎})) yl

insert : T → BinaryHeap → BinaryHeap
insert a = merge(singleton a)

pop : BinaryHeap → Option(T ⨯ BinaryHeap)
pop (Leaf <>)    = None
pop (Node a l r) = Some(a , merge l r)

{-# TERMINATING #-}
foldOrdered : (T → R → R) → R → BinaryHeap → R
foldOrdered(_▫_) id (Leaf <>)    = id
foldOrdered(_▫_) id (Node a l r) = a ▫ foldOrdered(_▫_) id (merge l r)

filterFold : (T → R → Option(R)) → R → BinaryHeap → (R ⨯ BinaryHeap)
filterFold (_▫_) r₀ (Leaf <>)    = (r₀ , Leaf <>)
filterFold (_▫_) r₀ (Node a l r)
  with (r₁ , il) ← filterFold (_▫_) r₀ l
  with (r₂ , ir) ← filterFold (_▫_) r₁ r
  with (a ▫ r₂)
... | Some r₃ = (r₃ , merge il ir)
... | None    = (r₂ , Node a il ir)

filter : (T → Bool) → BinaryHeap → BinaryHeap
filter f = Tuple.right ∘ filterFold (\{a <> → (\{𝐹 → None ; 𝑇 → Some <>}) $ f(a)}) (<>{Lvl.𝟎})

open import Data.List
import      Data.List.Functions as List

separate : (T → Bool) → BinaryHeap → (List(T) ⨯ BinaryHeap)
separate f = filterFold (\a l → (\{𝐹 → None ; 𝑇 → Some(a ⊰ l)}) $ f(a)) ∅

update : (T → Bool) → (T → T) → BinaryHeap → BinaryHeap
update p f a with (as , b) ← separate p a = List.foldᵣ insert b (List.map f as)


------------------------------------------------------------------------------
-- Propositional equality without using pattern matching on refl
------------------------------------------------------------------------------

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

module
  FOT.Common.FOL.Relation.Binary.PropositionalEquality.NoPatternMatchingOnRefl
  where

open import Common.FOL.FOL using ( D )

-- We add 3 to the fixities of the Agda standard library 0.8.1 (see
-- Relation/Binary/Core.agda).
infix 7 _≡_

------------------------------------------------------------------------------
-- The identity type on the universe of discourse.
data _≡_ (x : D) : D → Set where
  refl : x ≡ x

-- Elimination rule.
subst : (A : D → Set) → ∀ {x y} → x ≡ y → A x → A y
subst A refl Ax = Ax

-- Identity properties

sym : ∀ {x y} → x ≡ y → y ≡ x
sym {x} h = subst (λ y' → y' ≡ x) h refl

trans : ∀ {x y z} → x ≡ y → y ≡ z → x ≡ z
trans {x} h₁ h₂ = subst (_≡_ x) h₂ h₁

trans₂ : ∀ {w x y z} → w ≡ x → x ≡ y → y ≡ z → w ≡ z
trans₂ h₁ h₂ h₃ = trans (trans h₁ h₂) h₃

subst₂ : (A : D → D → Set) → ∀ {x₁ x₂ y₁ y₂} →
         x₁ ≡ y₁ → x₂ ≡ y₂ →
         A x₁ x₂ →
         A y₁ y₂
subst₂ A {x₁} {x₂} {y₁} {y₂} h₁ h₂ h₃ =
  subst (λ y₁' → A y₁' y₂) h₁ (subst (A x₁) h₂ h₃)

cong : (f : D → D) → ∀ {x y} → x ≡ y → f x ≡ f y
cong f {x} h = subst (λ x' → f x ≡ f x') h refl

cong₂ : (f : D → D → D) → ∀ {x₁ x₂ y₁ y₂} → x₁ ≡ y₁ → x₂ ≡ y₂ →
        f x₁ x₂ ≡ f y₁ y₂
cong₂ f {x₁} {x₂} {y₁} {y₂} h₁ h₂ =
  subst (λ x₁' → f x₁ x₂ ≡ f x₁' y₂)
        h₁
        (subst (λ x₂' → f x₁ x₂ ≡ f x₁ x₂') h₂ refl)


module List where

  import Prelude
  import Equiv
  import Datoid
  import Nat

  open Prelude
  open Equiv
  open Datoid
  open Nat

  data List (a : Set) : Set where
    nil  : List a
    _::_ : a -> List a -> List a

  map : {a b : Set} -> (a -> b) -> List a -> List b
  map f nil       = nil
  map f (x :: xs) = f x :: map f xs

  member : (a : Datoid) -> El a -> List (El a) -> Set
  member _ x nil       = Absurd
  member a x (y :: ys) = Either (rel' (datoidEq a) x y) (member a x ys)

  memberPreservesEq
    :  {a : Datoid}
    -> {x y : El a}
    -> datoidRel a x y
    -> (zs : List (El a))
    -> member a x zs
    -> member a y zs
  memberPreservesEq     xy nil       abs         = abs
  memberPreservesEq {a} xy (z :: zs) (left xz)   =
    left  (dTrans a (dSym a xy) xz)
  memberPreservesEq {a} xy (z :: zs) (right xzs) =
    right (memberPreservesEq {a} xy zs xzs)

  private
    noCopies' : (a : Datoid) -> (x y : El a) -> Dec (datoidRel a x y)
              -> Nat -> Nat
    noCopies' _ _ _ (left _)  n = suc n
    noCopies' _ _ _ (right _) n = n

  noCopies : (a : Datoid) -> El a -> List (El a) -> Nat
  noCopies a x nil       = zero
  noCopies a x (y :: ys) =
    noCopies' a x y (datoidDecRel a x y) (noCopies a x ys)

  NoDuplicates : (a : Datoid) -> List (El a) -> Set
  NoDuplicates _ nil      = Unit
  NoDuplicates a (x :: b) = Pair (Not (member a x b)) (NoDuplicates a b)

  private
    delete'
      : (a : Datoid)
      -> (x y : El a)
      -> Dec (datoidRel a x y)
      -> (ys delXYs : List (El a))
      -> List (El a)
    delete' _ _ _ (left _)  ys _      = ys
    delete' _ _ _ (right _) _  delXYs = delXYs

  -- Removes first occurrence if any.
  delete : (a : Datoid) -> El a -> List (El a) -> List (El a)
  delete a x nil       = nil
  delete a x (y :: ys) = delete' a x y (datoidDecRel a x y) ys (delete a x ys)

  private
    Perm : (a : Datoid) -> (xs ys : List (El a)) -> Set
    Perm a xs ys = forall z -> datoidRel natDatoid (noCopies a z xs)
                                                   (noCopies a z ys)

    refl' : {a : Datoid} -> (xs : List (El a)) -> Perm a xs xs
    refl' {a} xs = \z -> dRefl natDatoid {noCopies a z xs}

    sym' :  {a : Datoid} -> (xs ys : List (El a))
         -> Perm a xs ys -> Perm a ys xs
    sym' {a} xs ys xy =
      \z -> dSym natDatoid {noCopies a z xs} {noCopies a z ys} (xy z)

    trans' : {a : Datoid} -> (xs ys zs : List (El a))
           -> Perm a xs ys -> Perm a ys zs -> Perm a xs zs
    trans' {a} xs ys zs xy yz =
      \z -> dTrans natDatoid
                   {noCopies a z xs} {noCopies a z ys} {noCopies a z zs}
                   (xy z) (yz z)

    postulate
      dec' : {a : Datoid} -> (xs ys : List (El a))
             -> Either (Perm a xs ys) (Not (Perm a xs ys))

  Permutation : (a : Datoid) -> DecidableEquiv (List (El a))
  Permutation a = decEquiv (equiv (Perm a) (refl' {a}) (sym' {a}) (trans' {a})) (dec (dec' {a}))


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

open import LogicalFormulae
open import Setoids.Setoids
open import Groups.Definition
open import Groups.Homomorphisms.Definition
open import Groups.SymmetricGroups.Definition
open import Groups.Actions.Definition
open import Sets.EquivalenceRelations

module Groups.ActionIsSymmetry {a b c d : _} {A : Set a} {B : Set b} {S : Setoid {a} {c} A} {T : Setoid {b} {d} B} {_+_ : A → A → A} {G : Group S _+_} (gAction : GroupAction G T) where

open Group G
open GroupAction gAction

actionPermutation : (g : A) → SymmetryGroupElements T
actionPermutation g = sym {f = λ x → action g x} (record { inj = record { injective = inj ; wellDefined = actionWellDefined2 } ; surj = record { surjective = surj ; wellDefined = actionWellDefined2 } })
  where
    open Setoid T
    open Equivalence eq
    inj : {x y : B} → (Setoid._∼_ T (action g x) (action g y)) → Setoid._∼_ T x y
    inj {x} {y} gx=gy = transitive (symmetric identityAction) (transitive (transitive (symmetric (actionWellDefined1 (invLeft {g}))) (transitive (transitive associativeAction (transitive (actionWellDefined2 gx=gy) (symmetric associativeAction))) (actionWellDefined1 (invLeft {g})))) identityAction)
    surj : {x : B} → Sg B (λ a → action g a ∼ x)
    surj {x} = action (inverse g) x , transitive (symmetric associativeAction) (transitive (actionWellDefined1 invRight) identityAction)

actionPermutationMapIsHom : GroupHom G (symmetricGroup T) actionPermutation
GroupHom.groupHom actionPermutationMapIsHom = associativeAction
GroupHom.wellDefined actionPermutationMapIsHom x=y = actionWellDefined1 x=y


module Lec1Done where

-- the -- mark introduces a "comment to end of line"

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

data Zero : Set where
  -- to give a value in a data, choose one constructor
  -- there are no constructors
  -- so that's impossible

record One : Set where
  -- to give a value in a record type, fill all its fields
  -- there are no fields
  -- so that's trivial
  --   (can we have a constructor, for convenience?)
  constructor <>

{-# COMPILE GHC One = data () (()) #-}

data _+_ (S : Set)(T : Set) : Set where -- "where" wants an indented block
  -- to offer a choice of constructors, list them with their types
  inl : S -> S + T     -- constructors can pack up stuff
  inr : T -> S + T
  -- in Haskell, this was called "Either S T"

{-
record _*_ (S : Set)(T : Set) : Set where
  field -- introduces a bunch of fields, listed with their types
    fst : S
    snd : T
  -- in Haskell, this was called "(S, T)"
-}

-- _*_ IS GENERALIZED BY SIGMA

record Sg (S : Set)(T : S -> Set) : Set where  -- Sg is short for "Sigma"
  constructor _,_
  field -- introduces a bunch of fields, listed with their types
    fst : S
    snd : T fst
open Sg public -- brings fst and snd into scope hereafter unto all inheritors
-- make _*_ from Sg ?
_*_ : Set -> Set -> Set
S * T = Sg S \ _ -> T
infixr 4 _*_ _,_

------------------------------------------------------------------------------
-- some simple proofs
------------------------------------------------------------------------------

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

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)

_$*_ : {A A' B B' : Set} -> (A -> A') -> (B -> B') -> A * B -> A' * B'
(f $* g) record { fst = a ; snd = b } = record { fst = f a ; snd = g b }

-- record syntax is rather ugly for small stuff; can we have constructors?

_$+_ : {A A' B B' : Set} -> (A -> A') -> (B -> B') -> A + B -> A' + B'
(f $+ g) (inl a) = inl (f a)
(f $+ g) (inr b) = inr (g b)

combinatorK : {A E : Set} -> A -> E -> A
combinatorK = \ a _ -> a

combinatorS : {S T E : Set} -> (E -> S -> T) -> (E -> S) -> E -> T
combinatorS = \ f s e -> (f e) (s e)

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

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 _$_

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

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

{-# BUILTIN NATURAL Nat #-}
--  ^^^^^^^^^^^^^^^^^^^       this pragma lets us use decimal notation

_+N_ : Nat -> Nat -> Nat
zero  +N y = y
suc x +N y = suc (x +N y)      -- there are other choices

four : Nat
four = 2 +N 2

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

data _==_ {X : Set} : X -> X -> Set where
  refl : (x : X) -> x == x           -- the relation that's "only reflexive"

{-# BUILTIN EQUALITY _==_ #-}  -- we'll see what that's for, later

_=$=_ : {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)
infixl 2 _=$=_

zero-+N : (n : Nat) -> (zero +N n) == n
zero-+N n = refl n

+N-zero : (n : Nat) -> (n +N zero) == n
+N-zero zero     = refl zero
+N-zero (suc n)  = refl suc =$= +N-zero n

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

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

_>=_ : Nat -> Nat -> Set
x     >= zero   = One
zero  >= suc y  = Zero
suc x >= suc y  = x >= y

refl->= : (n : Nat) -> n >= n
refl->= zero    = record {}
refl->= (suc n) = refl->= n

trans->= : (x y z : Nat) -> x >= y -> y >= z -> x >= z
trans->=      x       y  zero    x>=y y>=z = record {}
trans->=      x  zero    (suc z) x>=y ()
trans->= zero    (suc y) (suc z) ()   y>=z
trans->= (suc x) (suc y) (suc z) x>=y y>=z = trans->= x y z x>=y y>=z

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

{- -- MOVED UP TO REPLACE _*_
record Sg (S : Set)(T : S -> Set) : Set where  -- Sg is short for "Sigma"
  constructor _,_
  field -- introduces a bunch of fields, listed with their types
    fst : S
    snd : T fst
-- make _*_ from Sg ?
_*_ : Set -> Set -> Set
S * T = Sg S \ _ -> T
-}

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
difference (suc m) (suc n) m>=n | d , q = d , (refl suc =$= q)

tryMe      = difference 42 37 _
-- don'tTryMe = difference 37 42 {!!}

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

-- why the single colon?

-- what's with all the spaces?

-- what's with identifiers mixing letters and symbols?

-- what's with all the braces?

-- what is Set?

-- are there any lowercase/uppercase conventions?

-- what's with all the underscores?
--   (i)   placeholders in mixfix operators
--   (ii)  don't care (on the left)
--   (iii) go figure (on the right)

-- why use arithmetic operators for types?

-- what's the difference between = and == ?

-- can't we leave out cases?

-- can't we loop?

-- the function type is both implication and universal quantification,
-- but why is it called Pi?

-- why is Sigma called Sigma?

-- B or nor B?


{-# OPTIONS --sized-types #-}
module SList (A : Set) where

open import Data.List
open import Data.Product
open import Size

data SList : {ι : Size} → Set where
  snil : {ι : Size}
                   → SList {↑ ι}
  _∙_ : {ι : Size}(x : A)
                   → SList {ι}
                   → SList {↑ ι}

size : List A → SList
size [] = snil
size (x ∷ xs) = x ∙ (size xs)

unsize : {ι : Size} → SList {ι} → List A
unsize snil = []
unsize (x ∙ xs) = x ∷ unsize xs

unsize× : {ι : Size} → SList {ι} × SList {ι} → List A × List A
unsize× (xs , ys) = unsize xs , unsize ys

_⊕_ : SList → SList → SList
snil ⊕ ys = ys
(x ∙ xs) ⊕ ys = x ∙ (xs ⊕ ys)


-- Andreas, 2015-07-07 Let _ pattern be instantiable by an inaccessible pattern

module _ where

open import Common.Equality

-- These used to work and should still work:

transV1 : ∀{A : Set} (a b c : A) → a ≡ b → b ≡ c → a ≡ c
transV1 _ ._ ._ refl refl = refl

transV2 : ∀{A : Set} (a b c : A) → a ≡ b → b ≡ c → a ≡ c
transV2 ._ _ ._ refl refl = refl

transV3 : ∀{A : Set} (a b c : A) → a ≡ b → b ≡ c → a ≡ c
transV3 ._ ._ _ refl refl = refl

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

transH1 : ∀{A : Set}{a b c : A} → a ≡ b → b ≡ c → a ≡ c
transH1 {a = _}{b = ._}{c = ._} refl refl = refl

transH1' : ∀{A : Set}{a b c : A} → a ≡ b → b ≡ c → a ≡ c
transH1' {a = _} refl refl = refl

-- NEW: the following should also work:

transVNew : ∀{A : Set} (a b c : A) → a ≡ b → b ≡ c → a ≡ c
transVNew _ _ _ refl refl = refl

transHNew : ∀{A : Set}{a b c : A} → a ≡ b → b ≡ c → a ≡ c
transHNew {a = _}{b = _}{c = _} refl refl = refl


{- SAMPLE PROGRAMS IN SOURCE LANGUAGE -}

open import Preliminaries
open import Source
open import Pilot2
open import Translation
open import Interp
open import Preorder

module Samples where

  s2r : ∀ {Γ τ} → Γ Source.|- τ → (el ([ (⟨⟨ Γ ⟩⟩c) ]c ->p [ (|| τ ||) ]t))
  s2r p = interpE || p ||e

  -- this works
  {- dbl (n : nat) : nat = 2 * n -}
  dbl : ∀ {Γ} → Γ Source.|- (nat ->s nat)
  dbl = lam (rec (var i0) z (suc (suc (force (var (iS i0))))))

  -- this works
  {- add (m n : nat) : nat = m + n -}
  add : ∀ {Γ} → Γ Source.|- (nat ->s (nat ->s nat))
  add = lam (lam (rec (var (iS i0)) (var i0) (suc (force (var (iS i0))))))

  -- this works
  {- mult (m n : nat) : nat = m * n -}
  mult : ∀ {Γ} → Γ Source.|- (nat ->s (nat ->s nat))
  mult = lam (lam (rec (var (iS i0)) z (app (app add (var (iS (iS i0)))) (force (var (iS i0))))))

  -- this works
  {- pred (n : nat) : nat = predecessor of n -}
  pred : ∀ {Γ} → Γ Source.|- (nat ->s nat)
  pred = lam (rec (var i0) z (var i0))

  -- uhhhh
  fastfib : ∀ {Γ} → Γ Source.|- (nat ->s (nat ×s nat))
  fastfib =
    lam (rec (var i0) (prod z (suc z))
      (prod (split (force (var (iS i0))) (var (iS i0)))
        (app (app add (split (force (var (iS i0))) (var i0))) (split (force (var (iS i0))) (var (iS i0))))))

  -- hack : instead of having bool case analysis just do natural number recursion and return 1/0

  -- this works
  {- iszero (n : nat) : nat = z -> 1 | _ -> 0 -}
  isz : ∀ {Γ} → Γ Source.|- (nat ->s nat)
  isz = lam (rec (var i0) (suc z) z)

  -- this works
  {- leq (m n : nat) : nat = m ≤ n -}
  leq : ∀ {Γ} → Γ Source.|- (nat ->s (nat ->s nat))
  leq = lam (rec (var i0) (lam (suc z)) (lam (rec (var i0) z (app (force (var (iS (iS (iS (iS i0)))))) (var i0)))))

  -- this works
  {- eq (m n : nat) : nat = m = n -}
  eq : ∀ {Γ} → Γ Source.|- (nat ->s (nat ->s nat))
  eq = lam (rec (var i0) (lam (app isz (var i0))) (lam (rec (var i0) z (app (force (var (iS (iS (iS (iS i0)))))) (var i0)))))

  -- this works
  {- len (l : list τ) : nat = [] -> z | x :: xs -> 1 + len xs -}
  len : ∀ {Γ τ} → Γ Source.|- (list τ ->s nat)
  len = lam (listrec (var i0) z (suc (force (var (iS (iS i0))))))

  -- this works
  {- nth (n : nat) (l : list τ) : nat = [] -> 1 (return 1+len(l) if element not in list) | x :: xs -> if n = x then 0 else 1 + (nth n xs) -}
  nth : ∀ {Γ} → Γ Source.|- (list nat ->s (nat ->s nat))
  nth = lam (lam (listrec (var (iS i0)) (suc z) (rec (app (app eq (var (iS (iS (iS i0))))) (var i0)) (suc (force (var (iS (iS i0))))) z)))

  -- this works
  {- append (l1 l2 : list τ) : list τ = match l1 with [] -> l2 | x :: xs -> x :: (append xs ys) -}
  append : ∀ {Γ τ} → Γ Source.|- (list τ ->s (list τ ->s list τ))
  append = lam (lam (listrec (var (iS i0)) (var i0) (var i0 ::s force (var (iS (iS i0))))))

  -- this works
  {- rev (l : list τ) : list τ = [] -> [] | x :: xs -> append (rev xs) [x] -}
  rev : ∀ {Γ τ} → Γ Source.|- (list τ ->s list τ)
  rev = lam (listrec (var i0) nil (app (app append (force (var (iS (iS i0))))) (var i0 ::s nil)))

{-
  {- fast rev -}
  rev2piles : ∀ {Γ τ} → Γ Source.|- (list τ ->s (list τ ->s list τ))
  rev2piles = lam (lam (listrec (var (iS i0)) (var i0) (app (app rev2piles (var (iS i0))) (var i0 ::s var (iS (iS (iS i0)))))))
  fastrev : ∀ {Γ τ} → Γ Source.|- (list τ ->s list τ)
  fastrev = lam (app (app rev2piles (var i0)) nil)
-}

  -- this works
  {- insert (l : list nat) (el : nat) : list nat = [] -> [el] | x :: xs -> (leq el x -> el :: x :: xs | x :: (insert el xs)) -}
  insert : ∀ {Γ} → Γ Source.|- (list nat ->s (nat ->s list nat))
  insert = lam (lam (listrec (var (iS i0)) (var i0 ::s nil)
             (rec (app (app leq (var (iS (iS (iS i0))))) (var i0)) (var i0 ::s force (var (iS (iS i0))))
               (var (iS (iS (iS (iS (iS i0))))) ::s (var (iS (iS i0)) ::s var (iS (iS (iS i0))))))))

  -- this works
  {- insertion sort (l : list nat) : list nat = [] -> [] | x :: xs -> insert x (isort xs) -}
  isort : ∀ {Γ} → Γ Source.|- (list nat ->s list nat)
  isort = lam (listrec (var i0) nil (app (app insert (force (var (iS (iS i0))))) (var i0)))

  -- this works
  {- map (l : list τ) (f : τ → τ') : list τ = [] -> [] | x :: xs -> f x :: map f xs -}
  map : ∀ {Γ τ τ'} → Γ Source.|- ((τ ->s τ') ->s (list τ ->s list τ'))
  map = lam (lam (listrec (var i0) nil (app (var (iS (iS (iS (iS i0))))) (var i0) ::s force (var (iS (iS i0))))))

  dbl-trans : ∀ {Γ τ} → {!!} --el ([ (⟨⟨ Γ ⟩⟩c) ]c ->p [ (|| τ ||) ]t)
  dbl-trans {Γ} = {!|| dbl ||e!}

  example1 : ∀ {Γ τ} → {!!}
  example1 {Γ} {τ} = {!!} --copy and paste from this goal to the thing below
{-
  dbl-trans : ∀ {Γ} → ⟨⟨ Γ ⟩⟩c Pilot2.|- || nat ->s nat ||
  dbl-trans = prod 0C
                                     (lam
                                      (prod
                                       (plusC (l-proj (prod 0C (var i0)))
                                        (l-proj
                                         (rec (r-proj (prod 0C (var i0)))
                                          (prod (plusC 1C (l-proj (prod 0C z))) (r-proj (prod 0C z)))
                                          (prod
                                           (plusC 1C
                                            (l-proj
                                             (prod
                                              (l-proj
                                               (prod
                                                (l-proj
                                                 (prod
                                                  (plusC (l-proj (prod 0C (var (iS i0))))
                                                   (l-proj (r-proj (prod 0C (var (iS i0))))))
                                                  (r-proj (r-proj (prod 0C (var (iS i0)))))))
                                                (s
                                                 (r-proj
                                                  (prod
                                                   (plusC (l-proj (prod 0C (var (iS i0))))
                                                    (l-proj (r-proj (prod 0C (var (iS i0))))))
                                                   (r-proj (r-proj (prod 0C (var (iS i0))))))))))
                                              (s
                                               (r-proj
                                                (prod
                                                 (l-proj
                                                  (prod
                                                   (plusC (l-proj (prod 0C (var (iS i0))))
                                                    (l-proj (r-proj (prod 0C (var (iS i0))))))
                                                   (r-proj (r-proj (prod 0C (var (iS i0)))))))
                                                 (s
                                                  (r-proj
                                                   (prod
                                                    (plusC (l-proj (prod 0C (var (iS i0))))
                                                     (l-proj (r-proj (prod 0C (var (iS i0))))))
                                                    (r-proj (r-proj (prod 0C (var (iS i0))))))))))))))
                                           (r-proj
                                            (prod
                                             (l-proj
                                              (prod
                                               (l-proj
                                                (prod
                                                 (plusC (l-proj (prod 0C (var (iS i0))))
                                                  (l-proj (r-proj (prod 0C (var (iS i0))))))
                                                 (r-proj (r-proj (prod 0C (var (iS i0)))))))
                                               (s
                                                (r-proj
                                                 (prod
                                                  (plusC (l-proj (prod 0C (var (iS i0))))
                                                   (l-proj (r-proj (prod 0C (var (iS i0))))))
                                                  (r-proj (r-proj (prod 0C (var (iS i0))))))))))
                                             (s
                                              (r-proj
                                               (prod
                                                (l-proj
                                                 (prod
                                                  (plusC (l-proj (prod 0C (var (iS i0))))
                                                   (l-proj (r-proj (prod 0C (var (iS i0))))))
                                                  (r-proj (r-proj (prod 0C (var (iS i0)))))))
                                                (s
                                                 (r-proj
                                                  (prod
                                                   (plusC (l-proj (prod 0C (var (iS i0))))
                                                    (l-proj (r-proj (prod 0C (var (iS i0))))))
                                                   (r-proj (r-proj (prod 0C (var (iS i0)))))))))))))))))
                                       (r-proj
                                        (rec (r-proj (prod 0C (var i0)))
                                         (prod (plusC 1C (l-proj (prod 0C z))) (r-proj (prod 0C z)))
                                         (prod
                                          (plusC 1C
                                           (l-proj
                                            (prod
                                             (l-proj
                                              (prod
                                               (l-proj
                                                (prod
                                                 (plusC (l-proj (prod 0C (var (iS i0))))
                                                  (l-proj (r-proj (prod 0C (var (iS i0))))))
                                                 (r-proj (r-proj (prod 0C (var (iS i0)))))))
                                               (s
                                                (r-proj
                                                 (prod
                                                  (plusC (l-proj (prod 0C (var (iS i0))))
                                                   (l-proj (r-proj (prod 0C (var (iS i0))))))
                                                  (r-proj (r-proj (prod 0C (var (iS i0))))))))))
                                             (s
                                              (r-proj
                                               (prod
                                                (l-proj
                                                 (prod
                                                  (plusC (l-proj (prod 0C (var (iS i0))))
                                                   (l-proj (r-proj (prod 0C (var (iS i0))))))
                                                  (r-proj (r-proj (prod 0C (var (iS i0)))))))
                                                (s
                                                 (r-proj
                                                  (prod
                                                   (plusC (l-proj (prod 0C (var (iS i0))))
                                                    (l-proj (r-proj (prod 0C (var (iS i0))))))
                                                   (r-proj (r-proj (prod 0C (var (iS i0))))))))))))))
                                          (r-proj
                                           (prod
                                            (l-proj
                                             (prod
                                              (l-proj
                                               (prod
                                                (plusC (l-proj (prod 0C (var (iS i0))))
                                                 (l-proj (r-proj (prod 0C (var (iS i0))))))
                                                (r-proj (r-proj (prod 0C (var (iS i0)))))))
                                              (s
                                               (r-proj
                                                (prod
                                                 (plusC (l-proj (prod 0C (var (iS i0))))
                                                  (l-proj (r-proj (prod 0C (var (iS i0))))))
                                                 (r-proj (r-proj (prod 0C (var (iS i0))))))))))
                                            (s
                                             (r-proj
                                              (prod
                                               (l-proj
                                                (prod
                                                 (plusC (l-proj (prod 0C (var (iS i0))))
                                                  (l-proj (r-proj (prod 0C (var (iS i0))))))
                                                 (r-proj (r-proj (prod 0C (var (iS i0)))))))
                                               (s
                                                (r-proj
                                                 (prod
                                                  (plusC (l-proj (prod 0C (var (iS i0))))
                                                   (l-proj (r-proj (prod 0C (var (iS i0))))))
                                                  (r-proj (r-proj (prod 0C (var (iS i0))))))))))))))))))

  aaa : ∀ {Γ} → interpE (r-proj (dbl-trans {Γ})) == {!!}
  aaa = {!!}

  interp-dbl-trans : ∀ {Γ} → Monotone (fst [ ⟨⟨ Γ ⟩⟩c ]c) (fst [ ⟨⟨ nat ->s nat ⟩⟩ ]t) (snd [ ⟨⟨ Γ ⟩⟩c ]c) (snd [ ⟨⟨ nat ->s nat ⟩⟩ ]t)
  interp-dbl-trans {Γ} = monotone
                           (λ x →
                              monotone
                              (λ p₁ →
                                 (natrec (1 , 0) (λ n x₂ → S (fst x₂) , S (S (snd x₂))) p₁))
                              (λ a b c →
                                 nat-trans
                                 (fst (natrec (1 , 0) (λ n x₂ → S (fst x₂) , S (S (snd x₂))) a))
                                 (fst (natrec (1 , 0) (λ n x₂ → S (fst x₂) , S (S (snd x₂))) b))
                                 (fst (natrec (1 , 0) (λ n x₂ → S (fst x₂) , S (S (snd x₂))) b))
                                 (fst
                                  (♭h-fix-args (monotone (λ x₁ → 1 , 0) (λ x₁ y z₁ → <> , <>))
                                   (monotone
                                    (λ x₁ → S (fst (snd (fst x₁))) , S (S (snd (snd (fst x₁)))))
                                    (λ x₁ y z₁ → fst (snd (fst z₁)) , snd (snd (fst z₁))))
                                   ((x , a) , a) ((x , b) , b) c))
                                 (fst
                                  (♭h-fix-el (monotone (λ x₁ → 1 , 0) (λ x₁ y z₁ → <> , <>))
                                   (monotone
                                    (λ x₁ → S (fst (snd (fst x₁))) , S (S (snd (snd (fst x₁)))))
                                    (λ x₁ y z₁ → fst (snd (fst z₁)) , snd (snd (fst z₁))))
                                   ((x , a) , a) ((x , b) , b)
                                   ((Preorder-str.refl (snd [ ⟨⟨ Γ ⟩⟩c ]c) x , c) , c)))
                                 ,
                                 ♭nat-trans
                                 (snd (natrec (1 , 0) (λ n x₂ → S (fst x₂) , S (S (snd x₂))) a))
                                 (snd (natrec (1 , 0) (λ n x₂ → S (fst x₂) , S (S (snd x₂))) b))
                                 (snd (natrec (1 , 0) (λ n x₂ → S (fst x₂) , S (S (snd x₂))) b))
                                 (snd
                                  (♭h-fix-args (monotone (λ x₁ → 1 , 0) (λ x₁ y z₁ → <> , <>))
                                   (monotone
                                    (λ x₁ → S (fst (snd (fst x₁))) , S (S (snd (snd (fst x₁)))))
                                    (λ x₁ y z₁ → fst (snd (fst z₁)) , snd (snd (fst z₁))))
                                   ((x , a) , a) ((x , b) , b) c))
                                 (snd
                                  (♭h-fix-el (monotone (λ x₁ → 1 , 0) (λ x₁ y z₁ → <> , <>))
                                   (monotone
                                    (λ x₁ → S (fst (snd (fst x₁))) , S (S (snd (snd (fst x₁)))))
                                    (λ x₁ y z₁ → fst (snd (fst z₁)) , snd (snd (fst z₁))))
                                   ((x , a) , a) ((x , b) , b)
                                   ((Preorder-str.refl (snd [ ⟨⟨ Γ ⟩⟩c ]c) x , c) , c)))))
                           (λ x y z₁ w →
                              nat-trans
                              (fst (natrec (1 , 0) (λ n x₂ → S (fst x₂) , S (S (snd x₂))) w))
                              (fst (natrec (1 , 0) (λ n x₂ → S (fst x₂) , S (S (snd x₂))) w))
                              (fst (natrec (1 , 0) (λ n x₂ → S (fst x₂) , S (S (snd x₂))) w))
                              (fst
                               (♭h-fix-args (monotone (λ x₁ → 1 , 0) (λ x₁ y₁ z₂ → <> , <>))
                                (monotone
                                 (λ x₁ → S (fst (snd (fst x₁))) , S (S (snd (snd (fst x₁)))))
                                 (λ x₁ y₁ z₂ → fst (snd (fst z₂)) , snd (snd (fst z₂))))
                                ((x , w) , w) ((y , w) , w) (♭nat-refl w)))
                              (fst
                               (♭h-fix-el (monotone (λ x₁ → 1 , 0) (λ x₁ y₁ z₂ → <> , <>))
                                (monotone
                                 (λ x₁ → S (fst (snd (fst x₁))) , S (S (snd (snd (fst x₁)))))
                                 (λ x₁ y₁ z₂ → fst (snd (fst z₂)) , snd (snd (fst z₂))))
                                ((x , w) , w) ((y , w) , w) ((z₁ , ♭nat-refl w) , ♭nat-refl w)))
                              ,
                              ♭nat-trans
                              (snd (natrec (1 , 0) (λ n x₂ → S (fst x₂) , S (S (snd x₂))) w))
                              (snd (natrec (1 , 0) (λ n x₂ → S (fst x₂) , S (S (snd x₂))) w))
                              (snd (natrec (1 , 0) (λ n x₂ → S (fst x₂) , S (S (snd x₂))) w))
                              (snd
                               (♭h-fix-args (monotone (λ x₁ → 1 , 0) (λ x₁ y₁ z₂ → <> , <>))
                                (monotone
                                 (λ x₁ → S (fst (snd (fst x₁))) , S (S (snd (snd (fst x₁)))))
                                 (λ x₁ y₁ z₂ → fst (snd (fst z₂)) , snd (snd (fst z₂))))
                                ((x , w) , w) ((y , w) , w) (♭nat-refl w)))
                              (snd
                               (♭h-fix-el (monotone (λ x₁ → 1 , 0) (λ x₁ y₁ z₂ → <> , <>))
                                (monotone
                                 (λ x₁ → S (fst (snd (fst x₁))) , S (S (snd (snd (fst x₁)))))
                                 (λ x₁ y₁ z₂ → fst (snd (fst z₂)) , snd (snd (fst z₂))))
                                ((x , w) , w) ((y , w) , w) ((z₁ , ♭nat-refl w) , ♭nat-refl w))))
-}

{-
  {- halve (l : list nat) : (list nat * list nat) = splits a list in half -}
  halve : ∀ {Γ} → Γ Source.|- (list nat ->s (list nat ×s list nat))
  halve = lam (listrec (var i0)
            (prod nil nil)
            (listrec (var (iS i0))
              (prod (var i0 ::s nil) nil)
              (prod (var (iS (iS (iS i0))) ::s split (force (var (iS (iS i0)))) (var i0)) (var i0 ::s split (force (var (iS (iS i0)))) (var (iS i0))))))

  test : ∀ {Γ τ} → {!!}
  test {Γ} = {!s2r (app halve (z ::s (z ::s (z ::s nil))))!}

  {- merge (l1 l2 : list nat) : list nat =
       match l1 with
       [] -> l2
       x :: xs ->
         match l2 with
           [] -> x :: xs
           y :: ys ->
             x <= y -> x :: merge xs l2
             _ -> y :: merge l1 ys -}
  merge : ∀ {Γ} → Γ Source.|- ((list nat ×s list nat) ->s list nat)
  merge = lam (listrec (split (var i0) (var i0))
            (split (var i0) (var (iS i0)))
            (listrec (split (var (iS (iS (iS i0)))) (var (iS i0)))
              (split (var (iS (iS (iS i0)))) (var i0))
              (rec (app (app leq (var (iS (iS (iS i0))))) (var i0))
                (var (iS (iS (iS i0))) ::s force (var (iS (iS (iS (iS (iS i0)))))))
                (var i0 ::s app merge (prod (split (var (iS (iS (iS (iS (iS (iS (iS (iS i0))))))))) (var (iS i0))) (var (iS (iS (iS i0)))))))))

  {- mergesort (l : list nat) : list nat -}
  msort : ∀ {Γ} → Γ Source.|- (list nat ->s list nat)
  msort = lam (listrec (var i0)
            nil
            (listrec (var (iS i0))
              (var i0 ::s nil)
              (app merge (prod
                (app msort (split (app halve (var (iS (iS (iS (iS (iS (iS i0)))))))) (var i0)))
                (app msort (split (app halve (var (iS (iS (iS (iS (iS (iS i0)))))))) (var (iS i0))))))))
-}


{-# OPTIONS --without-K --safe #-}
open import Categories.Category

{- Definition of SubCategory of a given Category C.

  Here a SubCategory is defined via
  - an index set I
  - a mapping I → Obj (not necessarily injective)
  - a proof (as a unary relation) that for all a, b : A, all arrows U a ⇒ U b belong to the SubCategory
    (note that this is 'backwards' from SubCategory at https://ncatlab.org/nlab/show/subcategory
     which would be
     (∀ {x y : Obj} (f : x ⇒ y) → R f → ∃ (A × B) (λ (a , b) → U a × U b))
     and that would be awkward to work with.
  - a proof that all objects pointed to by I have identity arrows that belong
  - a proof that composable arrows in the SubCategory are closed under composition

  It is simpler to package up all of that into a single record.
-}
module Categories.Category.SubCategory {o ℓ e} (C : Category o ℓ e) where

open Category C
open HomReasoning using (refl; sym; trans)

open import Level
open import Data.Product

private
  variable
    i : Level

record SubCat {ℓ′} (I : Set i) : Set (o ⊔ ℓ ⊔ i ⊔ suc ℓ′) where
  field
    U : I → Obj
    R : {a b : I} → U a ⇒ U b → Set ℓ′
    Rid : {a : I} → R (id {U a})
    _∘R_ : {a b c : I} {f : U b ⇒ U c} {g : U a ⇒ U b} → R f → R g → R (f ∘ g)

SubCategory : {ℓ′ : Level} {I : Set i} → SubCat {ℓ′ = ℓ′} I → Category _ _ _
SubCategory {I = I} sc = let open SubCat sc in record
  { Obj       = I
  ; _⇒_       = λ a b → Σ (U a ⇒ U b) R
  ; _≈_       = λ f g → proj₁ f ≈ proj₁ g
  ; id        = id , Rid
  ; _∘_       = zip _∘_ _∘R_
  ; assoc     = assoc
  ; sym-assoc = sym-assoc
  ; identityˡ = identityˡ
  ; identityʳ = identityʳ
  ; identity² = identity²
  ; equiv     = record -- need to expand this out, else the levels don't work out
    { refl  = refl
    ; sym   = sym
    ; trans = trans
    }
  ; ∘-resp-≈  = ∘-resp-≈
  }

FullSubCategory : ∀ {I : Set i} → (U : I → Obj) → Category _ _ _
FullSubCategory {I = I} U = record
  { Obj       = I
  ; _⇒_       = λ x y → U x ⇒ U y
  ; _≈_       = _≈_
  ; id        = id
  ; _∘_       = _∘_
  ; assoc     = assoc
  ; sym-assoc = sym-assoc
  ; identityˡ = identityˡ
  ; identityʳ = identityʳ
  ; identity² = identity²
  ; equiv     = equiv
  ; ∘-resp-≈  = ∘-resp-≈
  }


module MLib.Semirings where

open import MLib.Prelude
open Algebra using (Semiring)

module _ {ℓ p} (semiring : Semiring ℓ p) where
  open Semiring semiring renaming (Carrier to S)

  pow : ℕ → S → S
  pow Nat.zero x = 1#
  pow (Nat.suc n) x = x * pow n x

  powsum : ℕ → S → S
  powsum Nat.zero x = 1#
  powsum (Nat.suc n) x = pow (Nat.suc n) x + powsum n x

  Q-stable : ℕ → S → Set p
  Q-stable q x = powsum (1 Nat.+ q) x ≈ powsum q x


module #16 where

{-
  Show that addition of natural numbers is commutative: ∏(i,j:N)(i + j = j + i).
-}

open import Data.Nat
open import Relation.Binary.PropositionalEquality
open Relation.Binary.PropositionalEquality.≡-Reasoning

l-commut₀ : (n : ℕ) → n + 0 ≡ n
l-commut₀ zero = refl
l-commut₀ (suc n) = cong suc (l-commut₀ n)

suc-in-the-middle-with-you : ∀ m n → m + suc n ≡ suc (m + n)
suc-in-the-middle-with-you zero n = refl
suc-in-the-middle-with-you (suc m) n = cong suc (suc-in-the-middle-with-you m n)

+-commutative : (m n : ℕ) → m + n ≡ n + m
+-commutative zero n = sym (l-commut₀ n)
+-commutative (suc m) n =
  begin
    (suc m) + n
      ≡⟨ refl ⟩
    suc (m + n)
      ≡⟨ cong suc (+-commutative m n) ⟩
    suc (n + m)
      ≡⟨ sym (suc-in-the-middle-with-you n m) ⟩
    n + (suc m)
  ∎