{-

Part 3: Univalence and the SIP

• Univalence from ua and uaβ
• Transporting with ua
• The SIP as a consequence of ua

-}
{-# OPTIONS --cubical #-}
module Part3 where

open import Cubical.Core.Glue public
  using ( Glue ; glue ; unglue ; lineToEquiv )

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

open import Part1
open import Part2

-- A key concept in HoTT/UF is univalence. As we have seen earlier in
-- the week this is assumed as an axiom in HoTT. In Cubical Agda it is
-- instead provable and has computational content. This means that
-- transporting with paths constructed using univalence reduces as
-- opposed to HoTT where they would be stuck. This simplifies some
-- proofs and make it possible to actually do concrete computations
-- using univalence.

-- The part of univalence which is most useful for our applications is
-- to be able to turn equivalences (written _≃_ and defined as a Σ-type
-- of a function and a proof that it has contractible fibers) into
-- paths:
ua : {A B : Type ℓ} → A ≃ B → A ≡ B
ua {A = A} {B = B} e i = Glue B (λ { (i = i0) → (A , e)
                                   ; (i = i1) → (B , idEquiv B) })

-- This term is defined using "Glue types" which were introduced in
-- the CCHM paper. We won't have time to go into details about them
-- today, but for practical applications one can usually forget about
-- them and use ua as a black box. There are multiple useful lemmas in
-- Cubical.Foundations.Univalence and Cubical.Foundations.Transport
-- which are helpful when reasoning about ua which don't require
-- knowing what Glue types are.

-- The important point is that transporting along the path constructed
-- using ua applies the function underlying the equivalence. This is
-- easily proved using transportRefl:
uaβ : (e : A ≃ B) (x : A) → transport (ua e) x ≡ fst e x
uaβ e x = transportRefl (equivFun e x)

-- Note that for concrete types this typically hold definitionally,
-- but for an arbitrary equivalence e we have to prove it.

-- The fact that we have both ua and uaβ suffices to be able to prove
-- the standard formulation of univalence. For details see:
--
--   Cubical.Foundations.Univalence

-- The standard way of constructing equivalences is to start with an
-- isomorphism and then improve it into an equivalence. The lemma in
-- the library which does this is
--
--   isoToEquiv : {A B : Type ℓ} → Iso A B → A ≃ B

-- Composing this with ua lets us directly turn isomorphisms into paths:
--
--   isoToPath : {A B : Type ℓ} → Iso A B → A ≡ B

-- Time for an example!

-- Booleans
data Bool : Type₀ where
  false true : Bool

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

notPath : Bool ≡ Bool
notPath = isoToPath (iso not not rem rem)
  where
  rem : (b : Bool) → not (not b) ≡ b
  rem false = refl
  rem true  = refl

_ : transport notPath true ≡ false
_ = refl

-- Another example, integers:

open import Cubical.Data.Int hiding (_+_ ; +-assoc)

sucPath : Int ≡ Int
sucPath = isoToPath (iso sucInt predInt sucPred predSuc)

_ : transport sucPath (pos 0) ≡ pos 1
_ = refl

_ : transport (sucPath ∙ sucPath) (pos 0) ≡ pos 2
_ = refl

_ : transport (sym sucPath) (pos 0) ≡ negsuc 0
_ = refl

-------------------------------------------------------------------------
-- The structure identity principle

-- Combining subst and ua lets us transport any structure on A to get
-- a structure on an equivalent type B
substEquiv : (S : Type ℓ → Type ℓ') (e : A ≃ B) → S A → S B
substEquiv S e = subst S (ua e)

-- Example with binary numbers:

open import Cubical.Data.BinNat.BinNat renaming (ℕ≃binnat to ℕ≃Bin ; binnat to Bin)
open import Cubical.Data.Nat

T : Set → Set
T X = Σ[ _+_ ∈ (X → X → X) ] ((x y z : X) → x + (y + z) ≡ (x + y) + z)

TBin : T Bin
TBin = substEquiv T ℕ≃Bin (_+_ , +-assoc)

_+Bin_ : Bin → Bin → Bin
_+Bin_  = fst TBin

+Bin-assoc : (m n o : Bin) → m +Bin (n +Bin o) ≡ (m +Bin n) +Bin o
+Bin-assoc = snd TBin

-- This is however not always what we want as _+Bin_ will translate
-- its input to unary numbers, add, and then translate back. Instead
-- we want to use efficient addition on binary numbers, but get the
-- associativity proof for free. So what we really want is to
-- characterize the equality of T-structured types, i.e. we want a
-- proof that two types equipped with T-structures are equal if there
-- is a T-structure preserving equivalence between them. This is the
-- usual meaning of the *structure identity principle* (SIP). This
-- implies in particular that the type of paths of
-- monoids/groups/rings/R-modules/... is equivalent to the type of
-- monoid/group/ring/R-module/... preserving equivalences.

-- We formalize this and much more using a cubical version of the SIP in:
--
-- Internalizing Representation Independence with Univalence
-- Carlo Angiuli, Evan Cavallo, Anders Mörtberg, Max Zeuner
-- https://arxiv.org/abs/2009.05547
--
-- The binary numbers example with efficient addition is spelled out
-- in detail in Section 2.1.1 of:
--
-- https://www.doi.org/10.1017/S0956796821000034
-- (Can be downloaded from: https://staff.math.su.se/anders.mortberg/papers/cubicalagda2.pdf)


module _ where

open import Common.Prelude
open import Lib.Vec

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

sum : ∀ {n} → Vec Nat n → Nat
sum (x ∷ xs) = x + sum xs
sum [] = 0

foldl : ∀ {A}{B : Nat → Set} → (∀ {n} → B n → A → B (suc n)) → B 0 → ∀ {n} → Vec A n → B n
foldl {B = B} f z (x ∷ xs) = foldl {B = λ n → B (suc n)} f (f z x) xs
foldl f z [] = z

reverse : ∀ {A n} → Vec A n → Vec A n
reverse = foldl {B = Vec _} (λ xs x → x ∷ xs) []

downFrom : ∀ n → Vec Nat n
downFrom zero = []
downFrom (suc n) = n ∷ downFrom n

main : IO Unit
main = printNat (sum (reverse (downFrom 6000)))


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

open import Data.List
open import List.Permutation.Base A
open import Size
open import SList

lemma-⊕-/ : {xs ys : List A}{x y : A} → xs / x ⟶ ys → unsize A (_⊕_ A (size A xs) (y ∙ snil)) / x ⟶ unsize A (_⊕_ A (size A ys) (y ∙ snil))
lemma-⊕-/ /head = /head
lemma-⊕-/ (/tail xs/x⟶xs') = /tail (lemma-⊕-/ xs/x⟶xs')

lemma-⊕∼ : {xs ys : List A}(x : A) → xs ∼ ys → (x ∷ xs) ∼ unsize A (_⊕_ A (size A ys) (x ∙ snil))
lemma-⊕∼ x ∼[] = ∼x /head /head ∼[]
lemma-⊕∼ x (∼x xs/x⟶xs' ys/x⟶ys' xs'∼ys') = ∼x (/tail xs/x⟶xs') (lemma-⊕-/ ys/x⟶ys') (lemma-⊕∼ x xs'∼ys')

lemma-size-unsize : {ι : Size}(x : A) → (xs : SList A {ι}) → (unsize A (_⊕_ A (size A (unsize A xs)) (x ∙ snil))) ∼ unsize A (_⊕_ A xs (x ∙ snil))
lemma-size-unsize x snil = ∼x /head /head ∼[]
lemma-size-unsize x (y ∙ ys) = ∼x /head  /head (lemma-size-unsize x ys)


module Nat where

open import Prelude
open import Star

Nat : Set
Nat = Star One _ _

zero : Nat
zero = ε

suc : Nat -> Nat
suc n = _ • n

infixl 50 _+_ _-_
infixl 60 _*_

_+_ : Nat -> Nat -> Nat
_+_ = _++_

_*_ : Nat -> Nat -> Nat
x * y = bind id (\ _ -> y) x

_-_ : Nat -> Nat -> Nat
n       - ε       = n
ε       - m       = ε
(_ • n) - (_ • m) = n - m

test : Nat
test = suc (suc zero) * suc (suc zero)


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

module Pi-reasoning where

open import Data.Empty
open import Data.Unit hiding (_≟_)
open import Data.Bool hiding (_≟_)
open import Data.Nat
open import Data.List
open import Data.Sum hiding (map)
open import Data.Product hiding (map)
open import Level hiding (suc)
open import Relation.Nullary
open import Relation.Binary
open import Algebra
open import Relation.Binary.PropositionalEquality using (_≡_; refl)
open import Relation.Binary.PropositionalEquality as PropEq using(sym; trans)
import Algebra.FunctionProperties as FunctionProperties
-- open import Algebra.FunctionProperties
open import Algebra.Structures

open import Pi-abstract-machine

------------------------------------------------------------------------------
-- Decidable equality

-- normalize a type to a natural number

size : B → ℕ
size ZERO = 0
size ONE = 1
size (PLUS b₁ b₂) = size b₁ + size b₂
size (TIMES b₁ b₂) = size b₁ * size b₂

-- normalize a value to a number

normalize : {b : B} → VB b → ℕ
normalize {ZERO} ()
normalize {ONE} unitB = 0
normalize {PLUS b₁ b₂} (inlB v) = normalize {b₁} v
normalize {PLUS b₁ b₂} (inrB v) = size b₁ + normalize {b₂} v
normalize {TIMES b₁ b₂} (pairB v₁ v₂) = size b₂ * normalize {b₁} v₁ + normalize {b₂} v₂

-- decidable equality of our values: normalize and compare the
-- underlying natural numbers. This is justified by the fact that the
-- natural numbers are a model of commutative semirings.
-- Note that we can't compare at different types so easily, they have
-- to have the same size, something not worth dealing with right now
vb= : {b : B} → (v₁ : VB b) → (v₂ : VB b) → Set
vb= {b} v₁ v₂ = (normalize {b} v₁) ≡ (normalize {b} v₂)

vb-Equivalence : {b : B} → IsEquivalence (vb= {b})
vb-Equivalence = record
  { refl = refl
  ; sym = PropEq.sym
  ; trans = PropEq.trans }

vb== : {b : B} → Decidable {A = VB b} vb=
vb== {b} x y = (normalize {b} x) ≟ (normalize {b} y)

-- generate all values of a type

values : (b : B) → List (VB b)
values ZERO = []
values ONE = [ unitB ]
values (PLUS b₁ b₂) = map inlB (values b₁) ++ map inrB (values b₂)
values (TIMES b₁ b₂) = concatMap (λ v₁ → map (pairB v₁) (values b₂)) (values b₁)

-- B is a Setoid

VB-is-Setoid : {b : B} → Setoid Level.zero Level.zero
VB-is-Setoid {b} = record
  { Carrier = VB b
  ; _≈_ = vb=
  ; isEquivalence = vb-Equivalence
  }

-- equality of combinators:
-- two combinators are equal if they map equal values to equal values
-- best do this via proving that vb= generates a decidable equivalence
{-
⟺=bool : {b₁ b₂ : B} → (b₁ ⟺ b₂) → (b₁ ⟺ b₂) → Bool
⟺=bool {b₁} {b₂} f g =
  and (zipWith vb= (map (eval f) vs) (map (eval g) vs))
  where vs = values b₁

data _⟺=_ : {b₁ b₂ : B} → (b₁ ⟺ b₂) → (b₁ ⟺ b₂) → Set where
  id⟺= : {b₁ b₂ : B} → (f : b₁ ⟺ b₂) → (f ⟺= f)
  sym⟺= : {b₁ b₂ : B} → (f : b₁ ⟺ b₂) → (g : b₁ ⟺ b₂) → ( f ⟺= g ) → (g ⟺= f)

-- verifies that the given combinators relates the given values

data _s⟷_ : B → B → Set where
  sid⟷ : {b : B} {v₁ : VB b} {v₂ : VB b} {p : T (vb= (eval (iso id⟷) v₁) v₂)} → (b s⟷ b)

⟺=IsEquivalence : IsEquivalence _s⟷_
⟺=IsEquivalence = record {
    refl = srefl ;
    sym = {!!} ;
    trans = {!!}
  }
  where srefl : {b : B} {v : VB b} → b s⟷ b
        srefl {b} {v} = sid⟷ {b} {v} {v} {{!!}}

-- <-> : B -> B -> Set with constructors id : {b : B} -> (b <-> b)
-- IsEquivalence <->
--   refl = id

-- R= : B -> B -> Set with constructos
-}

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

{--
testT = PLUS ONE (PLUS ONE ONE)
test1 = normalize {testT} (inlB unitB)
test2 = normalize {testT} (inrB (inlB unitB))
test3 = normalize {testT} (inrB (inrB unitB))

testT = PLUS ZERO (PLUS ONE ONE)
test1 = normalize {testT} (inrB (inlB unitB))
test2 = normalize {testT} (inrB (inrB unitB))

testT = TIMES (PLUS ONE ONE) ZERO
test1 = size testT

testT = TIMES (PLUS ONE ONE) (PLUS ONE (PLUS ONE ONE))
test1 = normalize {testT} (pairB (inlB unitB) (inlB unitB))
test2 = normalize {testT} (pairB (inrB unitB) (inlB unitB))
test3 = normalize {testT} (pairB (inlB unitB) (inrB (inlB unitB)))
test4 = normalize {testT} (pairB (inrB unitB) (inrB (inlB unitB)))
test5 = normalize {testT} (pairB (inlB unitB) (inrB (inrB unitB)))
test6 = normalize {testT} (pairB (inrB unitB) (inrB (inrB unitB)))

BOOL = PLUS ONE ONE
test = ⟺= {BOOL} {BOOL} (iso swap₊ ◎ iso swap₊) (iso id⟷)

test1 : (iso swap₊) ⟺= (iso swap₊)
test1 = check
          {PLUS ONE ONE} {PLUS ONE ONE}
          (iso swap₊) (iso swap₊)
          tt

The following does NOT typecheck which is good. Agda rejected my
nonsense claim that id is equivalent to swap+

test2 : (iso swap₊) ⟺= (iso id⟷)
test2 = check
          {PLUS ONE ONE} {PLUS ONE ONE}
          (iso swap₊) (iso id⟷)
          tt

--}


module Numeral.Natural.Oper.Comparisons.Proofs where

open import Data.Boolean.Stmt
open import Data.Boolean
open import Logic.Propositional
open import Numeral.Natural
open import Numeral.Natural.Oper.Comparisons
open import Numeral.Natural.Oper.Proofs
open import Relator.Equals

[≤?]-𝟎 : ∀{n} → IsTrue(𝟎 ≤? n)
[≤?]-𝟎 = [⊤]-intro

[≤?]-𝐒 : ∀{n} → IsTrue(n ≤? 𝐒(n))
[≤?]-𝐒 {𝟎}   = [⊤]-intro
[≤?]-𝐒 {𝐒 n} = [≤?]-𝐒 {n}

[<?]-𝟎 : ∀{n} → IsTrue(𝟎 <? 𝐒(n))
[<?]-𝟎 {𝟎}   = [⊤]-intro
[<?]-𝟎 {𝐒 n} = [<?]-𝟎 {n}

[<?]-𝐒 : ∀{n} → IsTrue(n <? 𝐒(n))
[<?]-𝐒 {𝟎}   = [⊤]-intro
[<?]-𝐒 {𝐒 n} = [<?]-𝐒 {n}

[≤?]-reflexivity : ∀{n} → IsTrue(n ≤? n)
[≤?]-reflexivity {𝟎}    = [⊤]-intro
[≤?]-reflexivity {𝐒(n)} = [≤?]-reflexivity {n}

[<?]-positive : ∀{n} → (𝟎 <? n) ≡ positive?(n)
[<?]-positive {𝟎}    = [≡]-intro
[<?]-positive {𝐒(_)} = [≡]-intro
{-# REWRITE [<?]-positive #-}

[<?]-positive-any : ∀{m n} → ⦃ _ : IsTrue(m <? n) ⦄ → IsTrue(positive?(n))
[<?]-positive-any {𝟎}   {n}   ⦃ p ⦄ = p
[<?]-positive-any {𝐒 m} {𝐒 n} ⦃ p ⦄ = [⊤]-intro

[≤?]-positive : ∀{n} → (𝐒(𝟎) ≤? n) ≡ positive?(n)
[≤?]-positive {𝟎}    = [≡]-intro
[≤?]-positive {𝐒(_)} = [≡]-intro

[≢?]-positive : ∀{n} → (n ≢? 𝟎) ≡ positive?(n)
[≢?]-positive {𝟎}    = [≡]-intro
[≢?]-positive {𝐒(_)} = [≡]-intro

[<?]-to-[≤?] : ∀{a b} → ((a <? b) ≡ (𝐒(a) ≤? b))
[<?]-to-[≤?] {𝟎}   {𝟎}    = [≡]-intro
[<?]-to-[≤?] {𝟎}   {𝐒(_)} = [≡]-intro
[<?]-to-[≤?] {𝐒(_)}{𝟎}    = [≡]-intro
[<?]-to-[≤?] {𝐒(a)}{𝐒(b)} = [<?]-to-[≤?] {a}{b}

[≡?]-zero : ∀{n} → (n ≡? 𝟎) ≡ zero?(n)
[≡?]-zero {𝟎}    = [≡]-intro
[≡?]-zero {𝐒(_)} = [≡]-intro


module tests.Arith where

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

test : Nat
test = 4

foobar : Nat -> Nat
foobar Z = Z
foobar (S n) = S (S n)

main : IO Unit
main =
--  n <- readNat ,
  printNat 0 ,,
  printNat (0 + 1) ,,
  printNat (1 * 2) ,,
  printNat (S (S (S (S Z))) - S Z) ,,
  printNat test    ,,
  printNat (foobar 4) ,,
--  printNat n ,,
  return unit


module bool-thms where

open import bool
open import eq
open import sum
open import empty
open import level

~~-elim : ∀ (b : 𝔹) → ~ ~ b ≡ b
~~-elim tt = refl
~~-elim ff = refl

&&-idem : ∀ {b} → b && b ≡ b
&&-idem{tt} = refl
&&-idem{ff} = refl

||-idem : ∀{b} → b || b ≡ b
||-idem{tt} = refl
||-idem{ff} = refl

||≡ff₁ : ∀ {b1 b2} → b1 || b2 ≡ ff → ff ≡ b1
||≡ff₁ {ff} p = refl
||≡ff₁ {tt} p = sym p

||≡ff₂ : ∀ {b1 b2} → b1 || b2 ≡ ff → b2 ≡ ff
||≡ff₂ {tt} ()
||≡ff₂ {ff}{tt} ()
||≡ff₂ {ff}{ff} p = refl

||-tt : ∀ (b : 𝔹) → b || tt ≡ tt
||-tt tt = refl
||-tt ff = refl

||-cong₁ : ∀ {b1 b1' b2} → b1 ≡ b1' → b1 || b2 ≡ b1' || b2
||-cong₁ refl = refl

||-cong₂ : ∀ {b1 b2 b2'} → b2 ≡ b2' → b1 || b2 ≡ b1 || b2'
||-cong₂ p rewrite p = refl

ite-same : ∀{ℓ}{A : Set ℓ} →
           ∀(b : 𝔹) (x : A) →
           (if b then x else x) ≡ x
ite-same tt x = refl
ite-same ff x = refl

ite-arg : ∀{ℓ ℓ'}{A : Set ℓ}{B : Set ℓ'} → (f : A → B)(b : 𝔹)(x y : A) → (f (if b then x else y)) ≡ (if b then f x else f y)
ite-arg f tt x y = refl
ite-arg f ff x y = refl

𝔹-contra : ff ≡ tt → ∀{ℓ} {P : Set ℓ} → P
𝔹-contra ()

||-split : ∀ {b b' : 𝔹} → b || b' ≡ tt → b ≡ tt ⊎ b' ≡ tt
||-split{tt}{tt} p = inj₁ refl
||-split{tt}{ff} p = inj₁ refl
||-split{ff}{tt} p = inj₂ refl
||-split{ff}{ff} ()

𝔹-dec : ∀ (b : 𝔹) → b ≡ tt ⊎ b ≡ ff
𝔹-dec tt = inj₁ refl
𝔹-dec ff = inj₂ refl

&&-snd : {p1 p2 : 𝔹} → p1 && p2 ≡ tt → p2 ≡ tt
&&-snd{tt} p = p
&&-snd{ff} ()

&&-fst : {p1 p2 : 𝔹} → p1 && p2 ≡ tt → p1 ≡ tt
&&-fst{tt} p = refl
&&-fst{ff} ()

&&-combo : {p1 p2 : 𝔹} → p1 ≡ tt → p2 ≡ tt → p1 && p2 ≡ tt
&&-combo{tt} pr1 pr2 = pr2
&&-combo{ff} pr1 pr2 = 𝔹-contra pr1

&&-ff : ∀(b : 𝔹) → b && ff ≡ ff
&&-ff tt = refl
&&-ff ff = refl

ff≡tt : ff ≡ tt → ⊥ {lzero}
ff≡tt ()


module Numeral.Natural where

import      Lvl
open import Type

-- The set of natural numbers (0,..).
-- Positive integers including zero.
data ℕ : Type{Lvl.𝟎} where
  𝟎 : ℕ      -- Zero
  𝐒 : ℕ → ℕ -- Successor function (Intuitively: 𝐒(n) = n+1)
{-# BUILTIN NATURAL ℕ #-}

pattern 𝟏 = ℕ.𝐒(𝟎)
{-# DISPLAY ℕ.𝐒(𝟎) = 𝟏 #-}

-- Limited predecessor function
-- Intuitively: 𝐏(n) = max(0,n-1)
𝐏 : ℕ → ℕ
𝐏(𝟎)    = 𝟎
𝐏(𝐒(n)) = n


{-
This second-order signature was created from the following second-order syntax description:

syntax PDiff | PD

type
  * : 0-ary

term
  zero  : * | 𝟘
  add   : *  *  ->  * | _⊕_ l20
  one   : * | 𝟙
  mult  : *  *  ->  * | _⊗_ l20
  neg   : *  ->  * | ⊖_ r50
  pd : *.*  *  ->  * | ∂_∣_

theory
  (𝟘U⊕ᴸ) a |> add (zero, a) = a
  (𝟘U⊕ᴿ) a |> add (a, zero) = a
  (⊕A) a b c |> add (add(a, b), c) = add (a, add(b, c))
  (⊕C) a b |> add(a, b) = add(b, a)
  (𝟙U⊗ᴸ) a |> mult (one, a) = a
  (𝟙U⊗ᴿ) a |> mult (a, one) = a
  (⊗A) a b c |> mult (mult(a, b), c) = mult (a, mult(b, c))
  (⊗D⊕ᴸ) a b c |> mult (a, add (b, c)) = add (mult(a, b), mult(a, c))
  (⊗D⊕ᴿ) a b c |> mult (add (a, b), c) = add (mult(a, c), mult(b, c))
  (𝟘X⊗ᴸ) a |> mult (zero, a) = zero
  (𝟘X⊗ᴿ) a |> mult (a, zero) = zero
  (⊖N⊕ᴸ) a |> add (neg (a), a) = zero
  (⊖N⊕ᴿ) a |> add (a, neg (a)) = zero
  (⊗C) a b |> mult(a, b) = mult(b, a)
  (∂⊕) a : * |> x : * |- d0 (add (x, a)) = one
  (∂⊗) a : * |> x : * |- d0 (mult(a, x)) = a
  (∂C) f : (*,*).* |> x : *  y : * |- d1 (d0 (f[x,y])) = d0 (d1 (f[x,y]))
  (∂Ch₂) f : (*,*).*  g h : *.* |> x : * |- d0 (f[g[x], h[x]]) = add (mult(pd(z. f[z, h[x]], g[x]), d0(g[x])), mult(pd(z. f[g[x], z], h[x]), d0(h[x])))
  (∂Ch₁) f g : *.* |> x : * |- d0 (f[g[x]]) = mult (pd (z. f[z], g[x]), d0(g[x]))
-}

module PDiff.Signature where

open import SOAS.Context

open import SOAS.Common

open import SOAS.Syntax.Signature *T public
open import SOAS.Syntax.Build *T public

-- Operator symbols
data PDₒ : Set where
  zeroₒ addₒ oneₒ multₒ negₒ pdₒ : PDₒ

-- Term signature
PD:Sig : Signature PDₒ
PD:Sig = sig λ
  {  zeroₒ   → ⟼₀ *
  ;  addₒ    → (⊢₀ *) , (⊢₀ *) ⟼₂ *
  ;  oneₒ    → ⟼₀ *
  ;  multₒ   → (⊢₀ *) , (⊢₀ *) ⟼₂ *
  ;  negₒ    → (⊢₀ *) ⟼₁ *
  ;  pdₒ  → (* ⊢₁ *) , (⊢₀ *) ⟼₂ *
  }

open Signature PD:Sig public


open import bool

module list-merge-sort (A : Set) (_<A_ : A → A → 𝔹) where

open import braun-tree A _<A_
open import eq
open import list
open import nat
open import nat-thms

merge : (l1 l2 : 𝕃 A) → 𝕃 A
merge [] ys = ys
merge xs [] = xs
merge (x :: xs) (y :: ys) with x <A y
merge (x :: xs) (y :: ys) | tt = x :: (merge xs (y :: ys))
merge (x :: xs) (y :: ys) | ff = y :: (merge (x :: xs) ys)

merge-sort-h : ∀{n : ℕ} → braun-tree' n → 𝕃 A
merge-sort-h (bt'-leaf a) = [ a ]
merge-sort-h (bt'-node l r p) = merge (merge-sort-h l) (merge-sort-h r)

merge-sort : 𝕃 A → 𝕃 A
merge-sort [] = []
merge-sort (a :: as) with 𝕃-to-braun-tree' a as
merge-sort (a :: as) | t = merge-sort-h t


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

open import Categories.Category

open import Function
open import Relation.Binary.PropositionalEquality as ≡

Discrete : ∀ {a} (A : Set a) → Category a a a
Discrete A = record
  { Obj       = A
  ; _⇒_       = _≡_
  ; _≈_       = _≡_
  ; id        = refl
  ; _∘_       = flip ≡.trans
  ; assoc     = λ {_ _ _ _ g} → sym (trans-assoc g)
  ; sym-assoc = λ {_ _ _ _ g} → trans-assoc g
  ; identityˡ = λ {_ _ f} → trans-reflʳ f
  ; identityʳ = refl
  ; identity² = refl
  ; equiv     = isEquivalence
  ; ∘-resp-≈  = λ where
    refl refl → refl
  }


module Logic.Propositional.Xor where

open import Logic.Propositional
open import Logic
import      Lvl

-- TODO: Is it possible write a general construction for arbitrary number of xors? Probably by using rotate₃Fn₃Op₂?
data _⊕₃_⊕₃_ {ℓ₁ ℓ₂ ℓ₃} (P : Stmt{ℓ₁}) (Q : Stmt{ℓ₂}) (R : Stmt{ℓ₃}) : Stmt{ℓ₁ Lvl.⊔ ℓ₂ Lvl.⊔ ℓ₃} where
  [⊕₃]-intro₁ : P     → (¬ Q) → (¬ R) → (P ⊕₃ Q ⊕₃ R)
  [⊕₃]-intro₂ : (¬ P) → Q     → (¬ R) → (P ⊕₃ Q ⊕₃ R)
  [⊕₃]-intro₃ : (¬ P) → (¬ Q) → R     → (P ⊕₃ Q ⊕₃ R)


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

module Data.Vec where

open import Data.Nat
open import Data.Fin using (Fin; zero; suc)
open import Data.List as List using (List)
open import Data.Product using (_×_; _,_)

------------------------------------------------------------------------
-- Types

infixr 5 _∷_

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

infix 4 _∈_ _[_]=_

data _∈_ {a : Set} : a → {n : ℕ} → Vec a n → Set where
  here  : ∀ {n} {x}   {xs : Vec a n} → x ∈ x ∷ xs
  there : ∀ {n} {x y} {xs : Vec a n} (x∈xs : x ∈ xs) → x ∈ y ∷ xs

data _[_]=_ {a : Set} : {n : ℕ} → Vec a n → Fin n → a → Set 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

------------------------------------------------------------------------
-- Some operations

head : ∀ {a n} → Vec a (1 + n) → a
head (x ∷ xs) = x

tail : ∀ {a n} → Vec a (1 + n) → Vec a n
tail (x ∷ xs) = xs

[_] : ∀ {a} → a → Vec a 1
[ x ] = x ∷ []

infixr 5 _++_

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

map : ∀ {a b n} → (a → b) → Vec a n → Vec b n
map f []       = []
map f (x ∷ xs) = f x ∷ map f xs

zipWith :  ∀ {a b c n}
        → (a → b → c) → Vec a n → Vec b n → Vec c n
zipWith _⊕_ []       []       = []
zipWith _⊕_ (x ∷ xs) (y ∷ ys) = (x ⊕ y) ∷ zipWith _⊕_ xs ys

zip : ∀ {a b n} → Vec a n → Vec b n → Vec (a × b) n
zip = zipWith _,_

replicate : ∀ {a n} → a → Vec a n
replicate {n = zero}  x = []
replicate {n = suc n} x = x ∷ replicate x

foldr :  ∀ {a} (b : ℕ → Set) {m}
      → (∀ {n} → a → b n → b (suc n))
      → b zero
      → Vec a m → b m
foldr b _⊕_ n []       = n
foldr b _⊕_ n (x ∷ xs) = x ⊕ foldr b _⊕_ n xs

foldr₁ :  ∀ {a : Set} {m}
       → (a → a → a) → Vec a (suc m) → a
foldr₁ _⊕_ (x ∷ [])     = x
foldr₁ _⊕_ (x ∷ y ∷ ys) = x ⊕ foldr₁ _⊕_ (y ∷ ys)

foldl :  ∀ {a : Set} (b : ℕ → Set) {m}
      → (∀ {n} → b n → a → b (suc n))
      → b zero
      → Vec a m → b m
foldl b _⊕_ n []       = n
foldl b _⊕_ n (x ∷ xs) = foldl (λ n → b (suc n)) _⊕_ (n ⊕ x) xs

foldl₁ :  ∀ {a : Set} {m}
       → (a → a → a) → Vec a (suc m) → a
foldl₁ _⊕_ (x ∷ xs) = foldl _ _⊕_ x xs

concat : ∀ {a m n} → Vec (Vec a m) n → Vec a (n * m)
concat []         = []
concat (xs ∷ xss) = xs ++ concat xss

infixr 5 _++'_

data SplitAt {a : Set} (m : ℕ) {n : ℕ} : Vec a (m + n) → Set where
  _++'_ : (xs : Vec a m) (ys : Vec a n) → SplitAt m (xs ++ ys)

splitAt : ∀ {a} m {n} (xs : Vec a (m + n)) → SplitAt m xs
splitAt zero    xs                = [] ++' xs
splitAt (suc m) (x ∷ xs)          with splitAt m xs
splitAt (suc m) (x ∷ .(ys ++ zs)) | ys ++' zs = (x ∷ ys) ++' zs

take : ∀ {a} m {n} → Vec a (m + n) → Vec a m
take m xs with splitAt m xs
take m .(xs ++ ys) | xs ++' ys = xs

drop : ∀ {a} m {n} → Vec a (m + n) → Vec a n
drop m xs with splitAt m xs
drop m .(xs ++ ys) | xs ++' ys = ys

data Group {a : Set} (n k : ℕ) : Vec a (n * k) → Set where
  concat' : (xss : Vec (Vec a k) n) → Group n k (concat xss)

group : ∀ {a} n k (xs : Vec a (n * k)) → Group n k xs
group zero    k []                  = concat' []
group (suc n) k xs                  with splitAt k xs
group (suc n) k .(ys ++ zs)         | ys ++' zs with group n k zs
group (suc n) k .(ys ++ concat zss) | ys ++' ._ | concat' zss = concat' (ys ∷ zss)

reverse : ∀ {a n} → Vec a n → Vec a n
reverse {a} = foldl (Vec a) (λ rev x → x ∷ rev) []

sum : ∀ {n} → Vec ℕ n → ℕ
sum = foldr _ _+_ 0

toList : ∀ {a n} → Vec a n → List a
toList []       = List.[]
toList (x ∷ xs) = List._∷_ x (toList xs)

fromList : ∀ {a} → (xs : List a) → Vec a (List.length xs)
fromList List.[]         = []
fromList (List._∷_ x xs) = x ∷ fromList xs

-- Snoc.

infixl 5 _∷ʳ_

_∷ʳ_ : ∀ {a n} → Vec a n → a → Vec a (1 + n)
[]       ∷ʳ y = [ y ]
(x ∷ xs) ∷ʳ y = x ∷ (xs ∷ʳ y)

infixl 5 _∷ʳ'_

data InitLast {a : Set} (n : ℕ) : Vec a (1 + n) → Set where
  _∷ʳ'_ : (xs : Vec a n) (x : a) → InitLast n (xs ∷ʳ x)

initLast : ∀ {a n} (xs : Vec a (1 + n)) → InitLast n xs
initLast {n = zero}  (x ∷ [])         = [] ∷ʳ' x
initLast {n = suc n} (x ∷ xs)         with initLast xs
initLast {n = suc n} (x ∷ .(ys ∷ʳ y)) | ys ∷ʳ' y = (x ∷ ys) ∷ʳ' y

init : ∀ {a n} → Vec a (1 + n) → Vec a n
init xs with initLast xs
init .(ys ∷ʳ y) | ys ∷ʳ' y = ys

last : ∀ {a n} → Vec a (1 + n) → a
last xs with initLast xs
last .(ys ∷ʳ y) | ys ∷ʳ' y = y

infixl 1 _>>=_

_>>=_ : ∀ {A B m n} → Vec A m → (A → Vec B n) → Vec B (m * n)
xs >>= f = concat (map f xs)

infixl 4 _⊛_

_⊛_ : ∀ {A B m n} → Vec (A → B) m → Vec A n → Vec B (m * n)
fs ⊛ xs = fs >>= λ f → map f xs

-- Interleaves the two vectors.

infixr 5 _⋎_

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

lookup : ∀ {a n} → Fin n → Vec a n → a
lookup zero    (x ∷ xs) = x
lookup (suc i) (x ∷ xs) = lookup i xs

-- Update.

infixl 6 _[_]≔_

_[_]≔_ : ∀ {A n} → Vec A n → Fin n → A → Vec A n
[]       [ ()    ]≔ y
(x ∷ xs) [ zero  ]≔ y = y ∷ xs
(x ∷ xs) [ suc i ]≔ y = x ∷ xs [ i ]≔ y

-- Generates a vector containing all elements in Fin n. This function
-- is not placed in Data.Fin since Data.Vec depends on Data.Fin.

allFin : ∀ n → Vec (Fin n) n
allFin zero    = []
allFin (suc n) = zero ∷ map suc (allFin n)


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

module Categories.Functor.Continuous where

open import Level
open import Data.Product using (Σ)

open import Categories.Category
open import Categories.Functor
import Categories.Category.Construction.Cones as Con
import Categories.Diagram.Cone.Properties as Conₚ
import Categories.Diagram.Limit as Lim
import Categories.Morphism as Mor

private
  variable
    o ℓ e : Level
    C D E J : Category o ℓ e

-- G preserves the limit of F.
LimitPreserving : (G : Functor C D) {F : Functor J C} (L : Lim.Limit F) → Set _
LimitPreserving {C = C} {D = D} G {F} L = Σ (Lim.Limit (G ∘F F)) λ L′ → G.F₀ (Lim.Limit.apex L) ≅ Lim.Limit.apex L′
  where module F = Functor F
        module G = Functor G
        open Mor D

-- continuous functors preserves all limits.
Continuous : ∀ o ℓ e (G : Functor C D) → Set _
Continuous {C = C} o ℓ e G = ∀ {J : Category o ℓ e} {F : Functor J C} (L : Lim.Limit F) → LimitPreserving G L


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

open import lib.Basics
open import lib.NType2
open import lib.types.TLevel
open import lib.types.Sigma
open import lib.types.Pi

module lib.types.Groupoid where

record GroupoidStructure {i j} {El : Type i} (Arr : El → El → Type j)
  (_ : ∀ x y → has-level 0 (Arr x y)) : Type (lmax i j) where
  field
    id : ∀ {x} → Arr x x
    inv : ∀ {x y} → Arr x y → Arr y x
    comp : ∀ {x y z} → Arr x y → Arr y z → Arr x z
    unit-l : ∀ {x y} (a : Arr x y) → comp id a == a
    unit-r : ∀ {x y} (a : Arr x y) → comp a id == a
    assoc   : ∀ {x y z w} (a : Arr x y) (b : Arr y z) (c : Arr z w)
              → comp (comp a b) c == comp a (comp b c)
    inv-r    : ∀ {x y} (a : Arr x y) → (comp a (inv a)) == id
    inv-l    : ∀ {x y } (a : Arr x y) → (comp (inv a) a) == id

record Groupoid {i j} : Type (lsucc (lmax i j)) where
  constructor groupoid
  field
    El : Type i
    Arr : El → El → Type j
    Arr-level : ∀ x y → has-level 0 (Arr x y)
    groupoid-struct : GroupoidStructure Arr Arr-level


module Ints.Add.Comm where

open import Ints
open import Nats.Add.Comm

open import Equality

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

private

  a+b=b+a : ∀ a b → a + b ≡ b + a
  a+b=b+a (+ a) (+ b) = + (a :+: b)
    ≡⟨ cong +_ (nat-add-comm a b) ⟩ + (b :+: a) QED
  a+b=b+a (+    a  ) (-[1+ b ])
    rewrite nat-add-comm a b = refl
  a+b=b+a (-[1+ a ]) (+    b  )
    rewrite nat-add-comm a b = refl
  a+b=b+a (-[1+ a ]) (-[1+ b ])
    rewrite nat-add-comm a b = refl

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

int-add-comm : ∀ a b → a + b ≡ b + a
int-add-comm = a+b=b+a


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

-- The Hom Functor from C.op × C to Setoids,
-- the two 1-argument version fixing one object
-- and some notation for the version where the category must be made explicit

open import Data.Product
open import Function using () renaming (_∘_ to _∙_)

open import Categories.Category
open import Categories.Functor hiding (id)
open import Categories.Functor.Bifunctor
open import Categories.Category.Instance.Setoids
import Categories.Morphism.Reasoning as MR

open import Relation.Binary using (Setoid)

module Hom {o ℓ e} (C : Category o ℓ e) where
  open Category C
  open MR C

  Hom[-,-] : Bifunctor (Category.op C) C (Setoids ℓ e)
  Hom[-,-] = record
    { F₀           = F₀′
    ; F₁           = λ where
      (f , g) → record
        { _⟨$⟩_ = λ h → g ∘ h ∘ f
        ; cong  = ∘-resp-≈ʳ ∙ ∘-resp-≈ˡ
        }
    ; identity     = identity′
    ; homomorphism = homomorphism′
    ; F-resp-≈     = F-resp-≈′
    }
    where F₀′ : Obj × Obj → Setoid ℓ e
          F₀′ (A , B) = hom-setoid {A} {B}
          open HomReasoning

          identity′ : {A : Obj × Obj} {x y : uncurry _⇒_ A} → x ≈ y → id ∘ x ∘ id ≈ y
          identity′ {A} {x} {y} x≈y = begin
            id ∘ x ∘ id ≈⟨ identityˡ ⟩
            x ∘ id      ≈⟨ identityʳ ⟩
            x           ≈⟨ x≈y ⟩
            y           ∎

          homomorphism′ : ∀ {X Y Z : Σ Obj (λ x → Obj)}
                            {f : proj₁ Y ⇒ proj₁ X × proj₂ X ⇒ proj₂ Y}
                            {g : proj₁ Z ⇒ proj₁ Y × proj₂ Y ⇒ proj₂ Z}
                            {x y : proj₁ X ⇒ proj₂ X} →
                            x ≈ y →
                            (proj₂ g ∘ proj₂ f) ∘ x ∘ proj₁ f ∘ proj₁ g ≈
                            proj₂ g ∘ (proj₂ f ∘ y ∘ proj₁ f) ∘ proj₁ g
          homomorphism′ {f = f₁ , f₂} {g₁ , g₂} {x} {y} x≈y = begin
            (g₂ ∘ f₂) ∘ x ∘ f₁ ∘ g₁   ≈˘⟨ refl⟩∘⟨ assoc ⟩
            (g₂ ∘ f₂) ∘ (x ∘ f₁) ∘ g₁ ≈⟨ pullʳ (pullˡ (∘-resp-≈ʳ (∘-resp-≈ˡ x≈y))) ⟩
            g₂ ∘ (f₂ ∘ y ∘ f₁) ∘ g₁   ∎

          F-resp-≈′ : ∀ {A B : Σ Obj (λ x → Obj)}
                        {f g : Σ (proj₁ B ⇒ proj₁ A) (λ x → proj₂ A ⇒ proj₂ B)} →
                        Σ (proj₁ f ≈ proj₁ g) (λ x → proj₂ f ≈ proj₂ g) →
                        {x y : proj₁ A ⇒ proj₂ A} →
                        x ≈ y → proj₂ f ∘ x ∘ proj₁ f ≈ proj₂ g ∘ y ∘ proj₁ g
          F-resp-≈′ {f = f₁ , f₂} {g₁ , g₂} (f₁≈g₁ , f₂≈g₂) {x} {y} x≈y = begin
            f₂ ∘ x ∘ f₁ ≈⟨ f₂≈g₂ ⟩∘⟨ x≈y ⟩∘⟨ f₁≈g₁ ⟩
            g₂ ∘ y ∘ g₁ ∎

  open Functor Hom[-,-]
  open Equiv
  open HomReasoning

  Hom[_,-] : Obj → Functor C (Setoids ℓ e)
  Hom[_,-] = appˡ Hom[-,-]

  Hom[-,_] : Obj → Contravariant C (Setoids ℓ e)
  Hom[-,_] = appʳ Hom[-,-]

-- Notation for when the ambient Category must be specified explicitly.
module _ {o ℓ e} (C : Category o ℓ e) where
  open Category C
  open Hom C

  Hom[_][-,-] : Bifunctor (Category.op C) C (Setoids ℓ e)
  Hom[_][-,-] = Hom[-,-]

  Hom[_][_,-] : Obj → Functor C (Setoids ℓ e)
  Hom[_][_,-] B = Hom[ B ,-]

  Hom[_][-,_] : Obj → Contravariant C (Setoids ℓ e)
  Hom[_][-,_] B = Hom[-, B ]


------------------------------------------------------------------------
-- Some derivable properties
------------------------------------------------------------------------

open import Algebra

module Algebra.Props.DistributiveLattice
         (dl : DistributiveLattice)
         where

open DistributiveLattice dl
import Algebra.Props.Lattice as L; open L lattice public
open import Algebra.Structures
import Algebra.FunctionProperties as P; open P _≈_
import Relation.Binary.EqReasoning as EqR; open EqR setoid
open import Data.Function
open import Data.Product

∨-∧-distrib : _∨_ DistributesOver _∧_
∨-∧-distrib = ∨-∧-distribˡ , ∨-∧-distribʳ
  where
  ∨-∧-distribˡ : _∨_ DistributesOverˡ _∧_
  ∨-∧-distribˡ x y z = begin
    x ∨ y ∧ z          ≈⟨ ∨-comm _ _ ⟩
    y ∧ z ∨ x          ≈⟨ ∨-∧-distribʳ _ _ _ ⟩
    (y ∨ x) ∧ (z ∨ x)  ≈⟨ ∨-comm _ _ ⟨ ∧-pres-≈ ⟩ ∨-comm _ _ ⟩
    (x ∨ y) ∧ (x ∨ z)  ∎

∧-∨-distrib : _∧_ DistributesOver _∨_
∧-∨-distrib = ∧-∨-distribˡ , ∧-∨-distribʳ
  where
  ∧-∨-distribˡ : _∧_ DistributesOverˡ _∨_
  ∧-∨-distribˡ x y z = begin
    x ∧ (y ∨ z)                ≈⟨ sym (proj₂ absorptive _ _) ⟨ ∧-pres-≈ ⟩ refl ⟩
    (x ∧ (x ∨ y)) ∧ (y ∨ z)    ≈⟨ (refl ⟨ ∧-pres-≈ ⟩ ∨-comm _ _) ⟨ ∧-pres-≈ ⟩ refl ⟩
    (x ∧ (y ∨ x)) ∧ (y ∨ z)    ≈⟨ ∧-assoc _ _ _ ⟩
    x ∧ ((y ∨ x) ∧ (y ∨ z))    ≈⟨ refl ⟨ ∧-pres-≈ ⟩ sym (proj₁ ∨-∧-distrib _ _ _) ⟩
    x ∧ (y ∨ x ∧ z)            ≈⟨ sym (proj₁ absorptive _ _) ⟨ ∧-pres-≈ ⟩ refl ⟩
    (x ∨ x ∧ z) ∧ (y ∨ x ∧ z)  ≈⟨ sym $ proj₂ ∨-∧-distrib _ _ _ ⟩
    x ∧ y ∨ x ∧ z              ∎

  ∧-∨-distribʳ : _∧_ DistributesOverʳ _∨_
  ∧-∨-distribʳ x y z = begin
    (y ∨ z) ∧ x    ≈⟨ ∧-comm _ _ ⟩
    x ∧ (y ∨ z)    ≈⟨ ∧-∨-distribˡ _ _ _ ⟩
    x ∧ y ∨ x ∧ z  ≈⟨ ∧-comm _ _ ⟨ ∨-pres-≈ ⟩ ∧-comm _ _ ⟩
    y ∧ x ∨ z ∧ x  ∎

-- The dual construction is also a distributive lattice.

∧-∨-isDistributiveLattice : IsDistributiveLattice _≈_ _∧_ _∨_
∧-∨-isDistributiveLattice = record
  { isLattice    = ∧-∨-isLattice
  ; ∨-∧-distribʳ = proj₂ ∧-∨-distrib
  }

∧-∨-distributiveLattice : DistributiveLattice
∧-∨-distributiveLattice = record
  { _∧_                   = _∨_
  ; _∨_                   = _∧_
  ; isDistributiveLattice = ∧-∨-isDistributiveLattice
  }


-- 2010-09-06 Andreas

module IrrelevantApplication where

-- an unknown function that does not use its second argument

postulate
  f : {A B : Set} -> A -> .B -> A

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

-- the second argument is irrelevant for equality

proofIrr : {A : Set}{x y z : A} -> f x y == f x z
proofIrr = refl

-- irrelevant arguments (like x) may appear as arguments to irrelevant func.s

id : {A B : Set} -> (.A -> B) -> .A -> B
id g x = g x

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

-- t = pId id

record Prod (A B : Set) : Set where
  constructor _,_
  field
    fst : A
    snd : B

-- matching an irrelevant record is ok as long as fields are use irrelevantly
irrElim : {A B C : Set} → .(Prod A B) → (.A → .B → C) → C
irrElim (a , b) f = f a b

lemma : {A B C : Set}(a : A)(b : B)(f : .A -> .B -> C) -> irrElim (a , b) f == f a b
lemma a b f = refl


module Numeral.Finite.Conversions where

import      Lvl
open import Data using (Empty ; Unit ; <>)
open import Data.Boolean using (Bool ; 𝐹 ; 𝑇)
open import Data.Tuple using (_,_)
open import Logic.Propositional using (_↔_)
open import Numeral.Finite
open import Numeral.Natural
open import Syntax.Number

private variable ℓ : Lvl.Level

empty : 𝕟(0) ↔ Empty{ℓ}
empty = (\()) , (\())

unit : 𝕟(1) ↔ Unit{ℓ}
unit = (\{<> → 0}) , (\{𝟎 → <>})

bool : 𝕟(2) ↔ Bool
bool = (\{𝐹 → 0 ; 𝑇 → 1}) , (\{𝟎 → 𝐹 ; (𝐒(𝟎)) → 𝑇})


------------------------------------------------------------------------
-- The Agda standard library
--
-- Some derivable properties
------------------------------------------------------------------------

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

open import Algebra

module Algebra.Properties.AbelianGroup
  {a ℓ} (G : AbelianGroup a ℓ) where

open AbelianGroup G
open import Function
open import Relation.Binary.Reasoning.Setoid setoid

------------------------------------------------------------------------
-- Publicly re-export group properties

open import Algebra.Properties.Group group public

------------------------------------------------------------------------
-- Properties of abelian groups

xyx⁻¹≈y : ∀ x y → x ∙ y ∙ x ⁻¹ ≈ y
xyx⁻¹≈y x y = begin
  x ∙ y ∙ x ⁻¹    ≈⟨ ∙-congʳ $ comm _ _ ⟩
  y ∙ x ∙ x ⁻¹    ≈⟨ assoc _ _ _ ⟩
  y ∙ (x ∙ x ⁻¹)  ≈⟨ ∙-congˡ $ inverseʳ _ ⟩
  y ∙ ε           ≈⟨ identityʳ _ ⟩
  y               ∎

⁻¹-∙-comm : ∀ x y → x ⁻¹ ∙ y ⁻¹ ≈ (x ∙ y) ⁻¹
⁻¹-∙-comm x y = begin
  x ⁻¹ ∙ y ⁻¹ ≈˘⟨ ⁻¹-anti-homo-∙ y x ⟩
  (y ∙ x) ⁻¹  ≈⟨ ⁻¹-cong $ comm y x ⟩
  (x ∙ y) ⁻¹  ∎


import Relation.Binary.PropositionalEquality as Eq
open Eq using (_≡_; refl; sym; trans; cong; cong₂; _≢_)
open import Data.Empty using (⊥; ⊥-elim)
open import Data.List using (List; []; _∷_; takeWhile; dropWhile)
open import Data.List.All using (All; []; _∷_)
open import Data.Bool using (Bool; true; false; T)
open import Data.Unit using (⊤; tt)
open import Relation.Nullary using (¬_)
open import Function using (_∘_)

module TakeDropBool (A : Set) (P : A → Bool) where

  Head : ∀ {A : Set} → (A → Bool) → List A → Set
  Head P []       =  ⊥
  Head P (c ∷ s)  =  T (P c)

  data Book (x : A) (b : Bool) : Set where
    book : P x ≡ b → Book x b

  boo : ∀ (x : A) → Book x (P x)
  boo x = book refl

  dropWhile-lemma : ∀ (s : List A) → ¬ Head P (dropWhile P s)
  dropWhile-lemma []                                         =  λ()
  dropWhile-lemma (c ∷ s) with P c    | boo c
  ...                        | true   | _                    =  dropWhile-lemma s
  ...                        | false  | book eq  rewrite eq  =  λ()

  takeWhile-lemma : ∀ (s : List A) → All (T ∘ P) (takeWhile P s)
  takeWhile-lemma []                                         =  []
  takeWhile-lemma (c ∷ s) with P c    | boo c
  ...                        | false  | _                    =  []
  ...                        | true   | book eq rewrite eq   =  {! tt!} ∷ takeWhile-lemma s

{-  Hole 0
Goal: T (P c)
————————————————————————————————————————————————————————————
s  : List A
eq : P c ≡ true
c  : A
P  : A → Bool
A  : Set
-}


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

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

module GroupTheory.Commutator.PropertiesATP where

open import GroupTheory.Base
open import GroupTheory.Commutator

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

-- From: A. G. Kurosh. The Theory of Groups, vol. 1. Chelsea Publising
-- Company, 2nd edition, 1960. p. 99.
postulate commutatorInverse : ∀ a b → [ a , b ] · [ b , a ] ≡ ε
{-# ATP prove commutatorInverse #-}

-- If the commutator is associative, then commutator of any two
-- elements lies in the center of the group, i.e. a [b,c] = [b,c] a.
-- From: TPTP 6.4.0 problem GRP/GRP024-5.p.
postulate commutatorAssocCenter : (∀ a b c → commutatorAssoc a b c) →
                                  (∀ a b c → a · [ b , c ] ≡ [ b , c ] · a)
{-# ATP prove commutatorAssocCenter #-}


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

module Categories.Functor.Instance.01-Truncation where

-- (0,1)-trucation of categories as a functor from Cats to Posets.
--
-- This is the right-adjoint of the inclusion functor from Posets to
-- Cats (see Categories.Functor.Adjoint.Instance.01-Truncation)

open import Level using (_⊔_)
open import Function using (flip)
open import Data.Product as Prod using (_,_; _×_)
open import Relation.Binary.OrderMorphism using (_⇒-Poset_)
open import Relation.Binary using (Poset)

open import Categories.Category using (Category; _[_≈_])
open import Categories.Functor hiding (id)
open import Categories.Category using (Category)
open import Categories.Category.Instance.Cats using (Cats)
open import Categories.Category.Instance.Posets using (Posets)
import Categories.Morphism as Morphism
open import Categories.NaturalTransformation.NaturalIsomorphism
  using (NaturalIsomorphism; _≃_)

Trunc : ∀ {o ℓ e} → Functor (Cats o ℓ e) (Posets o ℓ ℓ)
Trunc {o} {ℓ} {e} = record
   { F₀           = Trunc₀
   ; F₁           = Trunc₁
   ; identity     = λ {C} → id C , id C
   ; homomorphism = λ {_ _ C} → id C , id C
   ; F-resp-≈     = TruncRespNI
   }
   where
     open Functor

     -- The choice of _≈_ below may seem a bit arbitrary.  The
     -- rationale is as follows:
     --
     -- Since we are defining an Agda stdlib-style poset, we have to
     -- pick an equality on the carrier set, i.e. on objects.  But
     -- objects do not come with an equality in this library (that's
     -- considered evil), so we pick isomorphism.  In a poset, any
     -- pair of morphisms f : X ⇒ Y and g : Y ⇒ X constitute an
     -- isomorphism between X and Y.  Hence the definition of _≈_.

     Trunc₀ : Category o ℓ e → Poset o ℓ ℓ
     Trunc₀ C = record
       { Carrier           = Obj
       ; _≈_               = λ x y → x ⇒ y × y ⇒ x
       ; _≤_               = _⇒_
       ; isPartialOrder    = record
         { isPreorder      = record
           { isEquivalence = record
             { refl        = id , id
             ; sym         = Prod.swap
             ; trans       = Prod.zip (flip _∘_) _∘_
             }
           ; reflexive     = Prod.proj₁
           ; trans         = flip _∘_
           }
         ; antisym         = _,_
         }
       }
       where open Category C

     Trunc₁ : ∀ {C D} → Functor C D → Trunc₀ C ⇒-Poset Trunc₀ D
     Trunc₁ F = record { fun = F₀ F ; monotone = F₁ F }

     TruncRespNI : ∀ {C D : Category o ℓ e} {F G : Functor C D} →
                   F ≃ G → Posets o ℓ ℓ [ Trunc₁ F ≈ Trunc₁ G ]
     TruncRespNI μ {X} = ⇒.η X , ⇐.η X
       where open NaturalIsomorphism μ

     open Category


{- Binary natural numbers (Anders Mörtberg, Jan. 2019)

This file defines two representations of binary numbers. We prove that
they are equivalent to unary numbers and univalence is then used to
transport both programs and properties between the representations.
This is an example of how having computational univalence can be
useful for practical programming.

The first definition is [Binℕ] and the numbers are essentially lists
of 0/1 with no trailing zeroes (in little-endian format). The main
definitions and examples are:

- Equivalence between Binℕ and ℕ ([Binℕ≃ℕ]) with an equality obtained
  using univalence ([Binℕ≡ℕ]).

- Addition on Binℕ defined by transporting addition on ℕ to Binℕ
  ([_+Binℕ_]) along Binℕ≡ℕ together with a proof that addition on Binℕ
  is associative obtained by transporting the proof for ℕ ([+Binℕ-assoc]).

- Functions testing whether a binary number is odd or even in O(1)
  ([oddBinℕ], [evenBinℕ]) and the corresponding functions for ℕ
  obtained by transport. Proof that odd numbers are not even
  transported from Binℕ to ℕ ([oddℕnotEvenℕ]).

- An example of the structure identity principle for natural number
  structures ([NatImpl]). We first prove that Binℕ≡ℕ lifts to natural
  number structures ([NatImplℕ≡Binℕ]) and we then use this to
  transport "+-suc : m + suc n ≡ suc (m + n)" from ℕ to Binℕ ([+Binℕ-suc]).

- An example of program/data refinement using the structure identity
  principle where we transport a property that is infeasible to prove
  by computation for ℕ ([propDoubleℕ]):

      2^20 * 2^10 = 2^5 * (2^15 * 2^10)

  from the corresponding result on Binℕ which is proved instantly by
  refl ([propDoubleBinℕ]).

These examples are inspired from an old cubicaltt formalization:

https://github.com/mortberg/cubicaltt/blob/master/examples/binnat.ctt

which itself is based on an even older cubical formalization (from 2014):

https://github.com/simhu/cubical/blob/master/examples/binnat.cub

The second representation is more non-standard and inspired by:

https://github.com/RedPRL/redtt/blob/master/library/cool/nats.red

Only some of the experiments have been done for this representation,
but it has the virtue of being a bit simpler to prove equivalent to
ℕ. The same representation can be found in:

http://www.cs.bham.ac.uk/~mhe/agda-new/BinaryNaturals.html

-}
{-# OPTIONS --cubical --no-exact-split --safe #-}
module Cubical.Data.BinNat.BinNat where

open import Cubical.Core.Glue

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

open import Cubical.Data.Nat
open import Cubical.Data.Bool
open import Cubical.Data.Empty

open import Cubical.Relation.Nullary

-- Positive binary numbers
data Pos : Type₀ where
  pos1 : Pos
  x0   : Pos → Pos
  x1   : Pos → Pos

sucPos : Pos → Pos
sucPos pos1    = x0 pos1
sucPos (x0 ps) = x1 ps
sucPos (x1 ps) = x0 (sucPos ps)

Pos→ℕ : Pos → ℕ
Pos→ℕ pos1    = suc zero
Pos→ℕ (x0 ps) = doubleℕ (Pos→ℕ ps)
Pos→ℕ (x1 ps) = suc (doubleℕ (Pos→ℕ ps))

posInd : {P : Pos → Type₀} → P pos1 → ((p : Pos) → P p → P (sucPos p)) → (p : Pos) → P p
posInd {P} h1 hs ps = f ps
  where
  H : (p : Pos) → P (x0 p) → P (x0 (sucPos p))
  H p hx0p = hs (x1 p) (hs (x0 p) hx0p)

  f : (ps : Pos) → P ps
  f pos1    = h1
  f (x0 ps) = posInd (hs pos1 h1) H ps
  f (x1 ps) = hs (x0 ps) (posInd (hs pos1 h1) H ps)

Pos→ℕsucPos : (p : Pos) → Pos→ℕ (sucPos p) ≡ suc (Pos→ℕ p)
Pos→ℕsucPos pos1   = refl
Pos→ℕsucPos (x0 p) = refl
Pos→ℕsucPos (x1 p) = λ i → doubleℕ (Pos→ℕsucPos p i)

zero≠Pos→ℕ : (p : Pos) → ¬ (zero ≡ Pos→ℕ p)
zero≠Pos→ℕ p = posInd (λ prf → znots prf) hs p
  where
  hs : (p : Pos) → ¬ (zero ≡ Pos→ℕ p) → zero ≡ Pos→ℕ (sucPos p) → ⊥
  hs p neq ieq = ⊥-elim (znots (ieq ∙ (Pos→ℕsucPos p)))

ℕ→Pos : ℕ → Pos
ℕ→Pos zero          = pos1
ℕ→Pos (suc zero)    = pos1
ℕ→Pos (suc (suc n)) = sucPos (ℕ→Pos (suc n))

ℕ→PosSuc : ∀ n → ¬ (zero ≡ n) → ℕ→Pos (suc n) ≡ sucPos (ℕ→Pos n)
ℕ→PosSuc zero neq    = ⊥-elim (neq refl)
ℕ→PosSuc (suc n) neq = refl

Pos→ℕ→Pos : (p : Pos) → ℕ→Pos (Pos→ℕ p) ≡ p
Pos→ℕ→Pos p = posInd refl hs p
  where
  hs : (p : Pos) → ℕ→Pos (Pos→ℕ p) ≡ p → ℕ→Pos (Pos→ℕ (sucPos p)) ≡ sucPos p
  hs p hp =
    ℕ→Pos (Pos→ℕ (sucPos p)) ≡⟨ cong ℕ→Pos (Pos→ℕsucPos p) ⟩
    ℕ→Pos (suc (Pos→ℕ p))    ≡⟨ ℕ→PosSuc (Pos→ℕ p) (zero≠Pos→ℕ p) ⟩
    sucPos (ℕ→Pos (Pos→ℕ p)) ≡⟨ cong sucPos hp ⟩
    sucPos p ∎

ℕ→Pos→ℕ : (n : ℕ) → Pos→ℕ (ℕ→Pos (suc n)) ≡ suc n
ℕ→Pos→ℕ zero    = refl
ℕ→Pos→ℕ (suc n) =
  Pos→ℕ (sucPos (ℕ→Pos (suc n))) ≡⟨ Pos→ℕsucPos (ℕ→Pos (suc n)) ⟩
  suc (Pos→ℕ (ℕ→Pos (suc n)))    ≡⟨ cong suc (ℕ→Pos→ℕ n) ⟩
  suc (suc n) ∎

-- Binary numbers
data Binℕ : Type₀ where
  binℕ0   : Binℕ
  binℕpos : Pos → Binℕ

ℕ→Binℕ : ℕ → Binℕ
ℕ→Binℕ zero    = binℕ0
ℕ→Binℕ (suc n) = binℕpos (ℕ→Pos (suc n))

Binℕ→ℕ : Binℕ → ℕ
Binℕ→ℕ binℕ0       = zero
Binℕ→ℕ (binℕpos x) = Pos→ℕ x

ℕ→Binℕ→ℕ : (n : ℕ) → Binℕ→ℕ (ℕ→Binℕ n) ≡ n
ℕ→Binℕ→ℕ zero          = refl
ℕ→Binℕ→ℕ (suc zero)    = refl
ℕ→Binℕ→ℕ (suc (suc n)) =
    Pos→ℕ (sucPos (ℕ→Pos (suc n))) ≡⟨ Pos→ℕsucPos (ℕ→Pos (suc n)) ⟩
    suc (Pos→ℕ (ℕ→Pos (suc n)))    ≡⟨ cong suc (ℕ→Binℕ→ℕ (suc n)) ⟩
    suc (suc n) ∎

Binℕ→ℕ→Binℕ : (n : Binℕ) → ℕ→Binℕ (Binℕ→ℕ n) ≡ n
Binℕ→ℕ→Binℕ binℕ0 = refl
Binℕ→ℕ→Binℕ (binℕpos p) = posInd refl (λ p _ → rem p) p
  where
  rem : (p : Pos) → ℕ→Binℕ (Pos→ℕ (sucPos p)) ≡ binℕpos (sucPos p)
  rem p =
    ℕ→Binℕ (Pos→ℕ (sucPos p))       ≡⟨ cong ℕ→Binℕ (Pos→ℕsucPos p) ⟩
    binℕpos (ℕ→Pos (suc (Pos→ℕ p))) ≡⟨ cong binℕpos ((ℕ→PosSuc (Pos→ℕ p) (zero≠Pos→ℕ p)) ∙
                                                              (cong sucPos (Pos→ℕ→Pos p))) ⟩
    binℕpos (sucPos p) ∎

Binℕ≃ℕ : Binℕ ≃ ℕ
Binℕ≃ℕ = isoToEquiv (iso Binℕ→ℕ ℕ→Binℕ ℕ→Binℕ→ℕ Binℕ→ℕ→Binℕ)

-- Use univalence (in fact only "ua") to get an equality from the
-- above equivalence
Binℕ≡ℕ : Binℕ ≡ ℕ
Binℕ≡ℕ = ua Binℕ≃ℕ

sucBinℕ : Binℕ → Binℕ
sucBinℕ binℕ0       = binℕpos pos1
sucBinℕ (binℕpos x) = binℕpos (sucPos x)

Binℕ→ℕsuc : (x : Binℕ) → suc (Binℕ→ℕ x) ≡ Binℕ→ℕ (sucBinℕ x)
Binℕ→ℕsuc binℕ0       = refl
Binℕ→ℕsuc (binℕpos x) = sym (Pos→ℕsucPos x)

-- We can transport addition on ℕ to Binℕ
_+Binℕ_ : Binℕ → Binℕ → Binℕ
_+Binℕ_ = transport (λ i → Binℕ≡ℕ (~ i) → Binℕ≡ℕ (~ i) → Binℕ≡ℕ (~ i)) _+_

-- Test: 4 + 1 = 5
private
  _ : binℕpos (x0 (x0 pos1)) +Binℕ binℕpos pos1 ≡ binℕpos (x1 (x0 pos1))
  _ = refl

-- It is easy to test if binary numbers are odd
oddBinℕ : Binℕ → Bool
oddBinℕ binℕ0            = false
oddBinℕ (binℕpos pos1)   = true
oddBinℕ (binℕpos (x0 _)) = false
oddBinℕ (binℕpos (x1 _)) = true

evenBinℕ : Binℕ → Bool
evenBinℕ n = oddBinℕ (sucBinℕ n)

-- And prove the following property (without induction)
oddBinℕnotEvenBinℕ : (n : Binℕ) → oddBinℕ n ≡ not (evenBinℕ n)
oddBinℕnotEvenBinℕ binℕ0            = refl
oddBinℕnotEvenBinℕ (binℕpos pos1)   = refl
oddBinℕnotEvenBinℕ (binℕpos (x0 x)) = refl
oddBinℕnotEvenBinℕ (binℕpos (x1 x)) = refl

-- It is also easy to define and prove the property for unary numbers,
-- however the definition uses recursion and the proof induction
private
  oddn : ℕ → Bool
  oddn zero    = true
  oddn (suc x) = not (oddn x)

  evenn : ℕ → Bool
  evenn n = not (oddn n)

  oddnSuc : (n : ℕ) → oddn n ≡ not (evenn n)
  oddnSuc zero    = refl
  oddnSuc (suc n) = cong not (oddnSuc n)

-- So what we can do instead is to transport the odd test from Binℕ to
-- ℕ along the equality
oddℕ : ℕ → Bool
oddℕ = transport (λ i → Binℕ≡ℕ i → Bool) oddBinℕ

evenℕ : ℕ → Bool
evenℕ = transport (λ i → Binℕ≡ℕ i → Bool) evenBinℕ

-- We can then also transport the property
oddℕnotEvenℕ : (n : ℕ) → oddℕ n ≡ not (evenℕ n)
oddℕnotEvenℕ =
  let -- We first build a path from oddBinℕ to oddℕ. When i=1 this is
      -- "transp (λ j → Binℕ≡ℕ j → Bool) i0 oddBinℕ" (i.e. oddℕ)
      oddp : PathP (λ i → Binℕ≡ℕ i → Bool) oddBinℕ oddℕ
      oddp i = transp (λ j → Binℕ≡ℕ (i ∧ j) → Bool) (~ i) oddBinℕ

      -- We then build a path from evenBinℕ to evenℕ
      evenp : PathP (λ i → Binℕ≡ℕ i → Bool) evenBinℕ evenℕ
      evenp i = transp (λ j → Binℕ≡ℕ (i ∧ j) → Bool) (~ i) evenBinℕ
  in -- Then transport oddBinℕnotEvenBinℕ in a suitable equality type
     -- When i=0 this is "(n : Binℕ) → oddBinℕ n ≡ not (evenBinℕ n)"
     -- When i=1 this is "(n : ℕ) → oddℕ n ≡ not (evenℕ n)"
     transport (λ i → (n : Binℕ≡ℕ i) → oddp i n ≡ not (evenp i n)) oddBinℕnotEvenBinℕ

-- We can do the same for natural numbers:

-- First construct the path
addp : PathP (λ i → Binℕ≡ℕ (~ i) → Binℕ≡ℕ (~ i) → Binℕ≡ℕ (~ i)) _+_ _+Binℕ_
addp i = transp (λ j → Binℕ≡ℕ (~ i ∨ ~ j) → Binℕ≡ℕ (~ i ∨ ~ j) → Binℕ≡ℕ (~ i ∨ ~ j)) (~ i) _+_

-- Then transport associativity:
+Binℕ-assoc : ∀ m n o → m +Binℕ (n +Binℕ o) ≡ (m +Binℕ n) +Binℕ o
+Binℕ-assoc =
  transport (λ i → (m n o : Binℕ≡ℕ (~ i))
                 → addp i m (addp i n o) ≡ addp i (addp i m n) o) +-assoc

-- We can also define what it means to be an implementation of natural
-- numbers and use this to transport properties between different
-- implementation of natural numbers. This can be seen as a special
-- case of the structure identity principle: any property that holds
-- for one structure also holds for an equivalent one.

-- An implementation of natural numbers (i.e. a "natural number
-- structure") has a zero and successor.
record NatImpl (A : Type₀) : Type₀ where
  field
    z : A
    s : A → A
open NatImpl

NatImplℕ : NatImpl ℕ
z NatImplℕ = zero
s NatImplℕ = suc

NatImplBinℕ : NatImpl Binℕ
z NatImplBinℕ = binℕ0
s NatImplBinℕ = sucBinℕ

-- Using the equality between binary and unary numbers we can get an
-- equality between the two implementations of the NatImpl interface
NatImplℕ≡Binℕ : PathP (λ i → NatImpl (Binℕ≡ℕ (~ i))) NatImplℕ NatImplBinℕ
z (NatImplℕ≡Binℕ i) = transp (λ j → Binℕ≡ℕ (~ i ∨ ~ j)) (~ i) zero
s (NatImplℕ≡Binℕ i) =
  λ x → glue (λ { (i = i0) → suc x
                ; (i = i1) → sucBinℕ x })
             -- We need to do use and hcomp to do and endpoint
             -- correction as "suc (unglue x)" connects "suc x"
             -- with "suc (Binℕ→ℕ x)" along i (which makes sense as
             -- x varies from ℕ to Binℕ along i), but we need
             -- something from "suc x" to "Binℕ→ℕ (sucBinℕ x)" for
             -- the glue to be well-formed
             (hcomp (λ j → λ { (i = i0) → suc x
                             ; (i = i1) → Binℕ→ℕsuc x j })
                    (suc (unglue (i ∨ ~ i) x)))

-- We then use this to transport +-suc from unary to binary numbers
+Binℕ-suc : ∀ m n → m +Binℕ sucBinℕ n ≡ sucBinℕ (m +Binℕ n)
+Binℕ-suc =
  transport (λ i → (m n : Binℕ≡ℕ (~ i))
                 → addp i m (NatImplℕ≡Binℕ i .s n) ≡ NatImplℕ≡Binℕ i .s (addp i m n)) +-suc

-- Doubling experiment: we define a notion of "doubling structure" and
-- transport a proof that is proved directly using refl for binary
-- numbers to unary numbers. This is an example of program/data
-- refinement: we can use univalence to prove properties about
-- inefficient data-structures using efficient ones.

-- Doubling structures
record Double {ℓ} (A : Type ℓ) : Type (ℓ-suc ℓ) where
  field
    -- doubling function computing 2 * x
    double : A → A
    -- element to double
    elt : A
open Double

-- Compute: 2^n * x
doubles : ∀ {ℓ} {A : Type ℓ} (D : Double A) → ℕ → A → A
doubles D n x = iter n (double D) x

Doubleℕ : Double ℕ
double Doubleℕ = doubleℕ
elt Doubleℕ    = n1024
  where
  -- 1024 = 2^8 * 2^2 = 2^10
  n1024 : ℕ
  n1024 = doublesℕ 8 4

-- The doubling operation on binary numbers is O(1), while for unary
-- numbers it is O(n). What is of course even more problematic is that
-- we cannot handle very big unary natural numbers, but with binary
-- there is no problem to represent very big numbers
doubleBinℕ : Binℕ → Binℕ
doubleBinℕ binℕ0       = binℕ0
doubleBinℕ (binℕpos x) = binℕpos (x0 x)

DoubleBinℕ : Double Binℕ
double DoubleBinℕ = doubleBinℕ
elt DoubleBinℕ    = bin1024
  where
  -- 1024 = 2^10 = 10000000000₂
  bin1024 : Binℕ
  bin1024 = binℕpos (x0 (x0 (x0 (x0 (x0 (x0 (x0 (x0 (x0 (x0 pos1))))))))))

-- As these function don't commute strictly we have to prove it
-- separately and insert it in the proof of DoubleBinℕ≡Doubleℕ below
-- (just like we had to in NatImplℕ≡NatImplBinℕ
Binℕ→ℕdouble : (x : Binℕ) → doubleℕ (Binℕ→ℕ x) ≡ Binℕ→ℕ (doubleBinℕ x)
Binℕ→ℕdouble binℕ0       = refl
Binℕ→ℕdouble (binℕpos x) = refl

-- We use the equality between Binℕ and ℕ to get an equality of
-- doubling structures
DoubleBinℕ≡Doubleℕ : PathP (λ i → Double (Binℕ≡ℕ i)) DoubleBinℕ Doubleℕ
double (DoubleBinℕ≡Doubleℕ i) =
  λ x → glue (λ { (i = i0) → doubleBinℕ x
                ; (i = i1) → doubleℕ x })
             (hcomp (λ j → λ { (i = i0) → Binℕ→ℕdouble x j
                             ; (i = i1) → doubleℕ x })
                    (doubleℕ (unglue (i ∨ ~ i) x)))
elt (DoubleBinℕ≡Doubleℕ i) = transp (λ j → Binℕ≡ℕ (i ∨ ~ j)) i (Doubleℕ .elt)

-- We can now use transport to prove a property that is too slow to
-- check with unary numbers. We define the property we want to check
-- as a record so that Agda does not try to unfold it eagerly.
record propDouble {ℓ} {A : Type ℓ} (D : Double A) : Type ℓ where
  field
  -- 2^20 * e = 2^5 * (2^15 * e)
    proof : doubles D 20 (elt D) ≡ doubles D 5 (doubles D 15 (elt D))
open propDouble

-- The property we want to prove takes too long to typecheck for ℕ:
-- propDoubleℕ : propDouble Doubleℕ
-- propDoubleℕ = refl

-- With binary numbers it is instant
propDoubleBinℕ : propDouble DoubleBinℕ
proof propDoubleBinℕ = refl

-- By transporting the proof along the equality we then get it for
-- unary numbers
propDoubleℕ : propDouble Doubleℕ
propDoubleℕ = transport (λ i → propDouble (DoubleBinℕ≡Doubleℕ i)) propDoubleBinℕ

--------------------------------------------------------------------------------
--
-- Alternative encoding of binary natural numbers inspired by:
-- https://github.com/RedPRL/redtt/blob/master/library/cool/nats.red
--
-- This representation makes the equivalence with ℕ a bit easier to
-- prove, but the doubling example wouldn't work as nicely as we
-- cannot define it as an O(1) operation

data binnat : Type₀ where
  zero     : binnat            -- 0
  consOdd  : binnat → binnat   -- 2^n + 1
  consEven : binnat → binnat   -- 2^{n+1}

binnat→ℕ : binnat → ℕ
binnat→ℕ zero         = 0
binnat→ℕ (consOdd n)  = suc (doubleℕ (binnat→ℕ n))
binnat→ℕ (consEven n) = suc (suc (doubleℕ (binnat→ℕ n)))

suc-binnat : binnat → binnat
suc-binnat zero         = consOdd zero
suc-binnat (consOdd n)  = consEven n
suc-binnat (consEven n) = consOdd (suc-binnat n)

ℕ→binnat : ℕ → binnat
ℕ→binnat zero    = zero
ℕ→binnat (suc n) = suc-binnat (ℕ→binnat n)

binnat→ℕ-suc : (n : binnat) → binnat→ℕ (suc-binnat n) ≡ suc (binnat→ℕ n)
binnat→ℕ-suc zero         = refl
binnat→ℕ-suc (consOdd n)  = refl
binnat→ℕ-suc (consEven n) = λ i → suc (doubleℕ (binnat→ℕ-suc n i))

ℕ→binnat→ℕ : (n : ℕ) → binnat→ℕ (ℕ→binnat n) ≡ n
ℕ→binnat→ℕ zero    = refl
ℕ→binnat→ℕ (suc n) = (binnat→ℕ-suc (ℕ→binnat n)) ∙ (cong suc (ℕ→binnat→ℕ n))

suc-ℕ→binnat-double : (n : ℕ) → suc-binnat (ℕ→binnat (doubleℕ n)) ≡ consOdd (ℕ→binnat n)
suc-ℕ→binnat-double zero    = refl
suc-ℕ→binnat-double (suc n) = λ i → suc-binnat (suc-binnat (suc-ℕ→binnat-double n i))

binnat→ℕ→binnat : (n : binnat) → ℕ→binnat (binnat→ℕ n) ≡ n
binnat→ℕ→binnat zero        = refl
binnat→ℕ→binnat (consOdd n) =
           (suc-ℕ→binnat-double (binnat→ℕ n)) ∙ (cong consOdd (binnat→ℕ→binnat n))
binnat→ℕ→binnat (consEven n) =
           (λ i → suc-binnat (suc-ℕ→binnat-double (binnat→ℕ n) i)) ∙ (cong consEven (binnat→ℕ→binnat n))

ℕ≃binnat : ℕ ≃ binnat
ℕ≃binnat = isoToEquiv (iso ℕ→binnat binnat→ℕ binnat→ℕ→binnat ℕ→binnat→ℕ)

ℕ≡binnat : ℕ ≡ binnat
ℕ≡binnat = ua ℕ≃binnat

-- We can transport addition on ℕ to binnat
_+binnat_ : binnat → binnat → binnat
_+binnat_ = transport (λ i → ℕ≡binnat i → ℕ≡binnat i → ℕ≡binnat i) _+_

-- Test: 4 + 1 = 5
_ : consEven (consOdd zero) +binnat consOdd zero ≡ consOdd (consEven zero)
_ = refl

oddbinnat : binnat → Bool
oddbinnat zero         = false
oddbinnat (consOdd _)  = true
oddbinnat (consEven _) = false

oddℕ' : ℕ → Bool
oddℕ' = transport (λ i → ℕ≡binnat (~ i) → Bool) oddbinnat

-- The NatImpl example for this representation of binary numbers
private
  NatImplbinnat : NatImpl binnat
  z NatImplbinnat = zero
  s NatImplbinnat = suc-binnat

  -- Note that the s case is a bit simpler as no end-point correction
  -- is necessary (things commute strictly)
  NatImplℕ≡NatImplbinnat : PathP (λ i → NatImpl (ℕ≡binnat i)) NatImplℕ NatImplbinnat
  z (NatImplℕ≡NatImplbinnat i) = transp (λ j → ℕ≡binnat (i ∨ ~ j)) i zero
  s (NatImplℕ≡NatImplbinnat i) =
    λ x → glue (λ { (i = i0) → suc x
                  ; (i = i1) → suc-binnat x })
               (suc-binnat (unglue (i ∨ ~ i) x))

  oddSuc : (n : binnat) → oddbinnat n ≡ not (oddbinnat (suc-binnat n))
  oddSuc zero         = refl
  oddSuc (consOdd _)  = refl
  oddSuc (consEven _) = refl

  oddℕSuc' : (n : ℕ) → oddℕ' n ≡ not (oddℕ' (suc n))
  oddℕSuc' =
    let eq : (i : I) → ℕ≡binnat (~ i) → Bool
        eq i = transp (λ j → ℕ≡binnat (~ i ∨ ~ j) → Bool) (~ i) oddbinnat
    in transport
         (λ i → (n : ℕ≡binnat (~ i)) → eq i n ≡ not (eq i (NatImplℕ≡NatImplbinnat (~ i) .NatImpl.s n)))
         oddSuc


{-# OPTIONS --without-K #-}
-- Finite types and paths between them
module FT where

open import Data.Empty
open import Data.Unit
open import Data.Nat
open import Data.Sum
open import Data.Product

infixl 10 _◎_

------------------------------------------------------------------------------
-- Finite types

data FT : Set where
  ZERO  : FT
  ONE   : FT
  PLUS  : FT → FT → FT
  TIMES : FT → FT → FT

⟦_⟧ : FT → Set
⟦ ZERO ⟧ = ⊥
⟦ ONE ⟧ = ⊤
⟦ PLUS B₁ B₂ ⟧ = ⟦ B₁ ⟧ ⊎ ⟦ B₂ ⟧
⟦ TIMES B₁ B₂ ⟧ = ⟦ B₁ ⟧ × ⟦ B₂ ⟧

------------------------------------------------------------------------------
-- Generalized paths are pi-combinators

data _⇛_ : FT → FT → Set where
  -- additive structure
  unite₊⇛  : { b : FT } → PLUS ZERO b ⇛ b

  uniti₊⇛  : { b : FT } → b ⇛ PLUS ZERO b
  swap₊⇛   : { b₁ b₂ : FT } → PLUS b₁ b₂ ⇛ PLUS b₂ b₁
  assocl₊⇛ : { b₁ b₂ b₃ : FT } → PLUS b₁ (PLUS b₂ b₃) ⇛ PLUS (PLUS b₁ b₂) b₃
  assocr₊⇛ : { b₁ b₂ b₃ : FT } → PLUS (PLUS b₁ b₂) b₃ ⇛ PLUS b₁ (PLUS b₂ b₃)
  -- multiplicative structure
  unite⋆⇛  : { b : FT } → TIMES ONE b ⇛ b
  uniti⋆⇛  : { b : FT } → b ⇛ TIMES ONE b
  swap⋆⇛   : { b₁ b₂ : FT } → TIMES b₁ b₂ ⇛ TIMES b₂ b₁
  assocl⋆⇛ : { b₁ b₂ b₃ : FT } →
             TIMES b₁ (TIMES b₂ b₃) ⇛ TIMES (TIMES b₁ b₂) b₃
  assocr⋆⇛ : { b₁ b₂ b₃ : FT } →
             TIMES (TIMES b₁ b₂) b₃ ⇛ TIMES b₁ (TIMES b₂ b₃)
  -- distributivity
  distz⇛   : { b : FT } → TIMES ZERO b ⇛ ZERO
  factorz⇛ : { b : FT } → ZERO ⇛ TIMES ZERO b
  dist⇛    : { b₁ b₂ b₃ : FT } →
            TIMES (PLUS b₁ b₂) b₃ ⇛ PLUS (TIMES b₁ b₃) (TIMES b₂ b₃)
  factor⇛  : { b₁ b₂ b₃ : FT } →
            PLUS (TIMES b₁ b₃) (TIMES b₂ b₃) ⇛ TIMES (PLUS b₁ b₂) b₃
  -- congruence
  id⇛    : { b : FT } → b ⇛ b
  sym⇛   : { b₁ b₂ : FT } → (b₁ ⇛ b₂) → (b₂ ⇛ b₁)
  _◎_    : { b₁ b₂ b₃ : FT } → (b₁ ⇛ b₂) → (b₂ ⇛ b₃) → (b₁ ⇛ b₃)
  _⊕_    : { b₁ b₂ b₃ b₄ : FT } →
           (b₁ ⇛ b₃) → (b₂ ⇛ b₄) → (PLUS b₁ b₂ ⇛ PLUS b₃ b₄)
  _⊗_    : { b₁ b₂ b₃ b₄ : FT } →
           (b₁ ⇛ b₃) → (b₂ ⇛ b₄) → (TIMES b₁ b₂ ⇛ TIMES b₃ b₄)

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

-- An alternative interpretation, as a Functor.
⟦_⟧′ : FT → (Set → Set)
⟦ ZERO ⟧′ A = ⊥
⟦ ONE ⟧′ A = A
⟦ PLUS B₁ B₂ ⟧′ A = ⟦ B₁ ⟧′ A ⊎ ⟦ B₂ ⟧′ A
⟦ TIMES B₁ B₂ ⟧′ A = ⟦ B₁ ⟧′ A × ⟦ B₂ ⟧′ A

{--

Not used

BOOL-FT : Set
BOOL-FT = ⟦ PLUS ONE ONE ⟧

true-FT : BOOL-FT
true-FT = inj₁ tt

false-FT : BOOL-FT
false-FT = inj₂ tt

witness : (B : FT) → Maybe ⟦ B ⟧
witness ZERO = nothing
witness ONE = just tt
witness (PLUS B₁ B₂) with witness B₁ | witness B₂
... | nothing | nothing = nothing
... | nothing | just b  = just (inj₂ b)
... | just b  | _ = just (inj₁ b)
witness (TIMES B₁ B₂) with witness B₁ | witness B₂
... | nothing | _ = nothing
... | just b  | nothing = nothing
... | just b₁ | just b₂ = just (b₁ , b₂)

elems : (B : FT) → List ⟦ B ⟧
elems ZERO          = []
elems ONE           = [ tt ]
elems (PLUS B₁ B₂)  = map inj₁ (elems B₁) ++ map inj₂ (elems B₂)
elems (TIMES B₁ B₂) = concatMap
                        (λ e₁ → map (λ e₂ → (e₁ , e₂)) (elems B₂))
                        (elems B₁)

expandF : {B₁ B₂ : FT} → (⟦ B₁ ⟧ → ⟦ B₂ ⟧) → List (⟦ B₁ ⟧ × ⟦ B₂ ⟧)
expandF {B₁} {B₂} f = map (λ e → (e , f e)) (elems B₁)

test0 : List ((⊤ × BOOL-FT) × BOOL-FT)
test0 = expandF (unite⋆ {BOOL-FT})

--}


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

open import Setoids.Setoids
open import Groups.Definition
open import Sets.EquivalenceRelations

module Groups.Lemmas {a b : _} {A : Set a} {_·_ : A → A → A} {S : Setoid {a} {b} A} (G : Group S _·_) where

open Setoid S
open Group G
open Equivalence eq

groupsHaveLeftCancellation : (x y z : A) → (x · y) ∼ (x · z) → y ∼ z
groupsHaveLeftCancellation x y z pr = o
  where
  _^-1 = inverse
  j : ((x ^-1) · x) · y ∼ (x ^-1) · (x · z)
  j = transitive (symmetric (+Associative {x ^-1} {x} {y})) (+WellDefined ~refl pr)
  k : ((x ^-1) · x) · y ∼ ((x ^-1) · x) · z
  k = transitive j +Associative
  l : 0G · y ∼ ((x ^-1) · x) · z
  l = transitive (+WellDefined (symmetric invLeft) ~refl) k
  m : 0G · y ∼ 0G · z
  m = transitive l (+WellDefined invLeft ~refl)
  n : y ∼ 0G · z
  n = transitive (symmetric identLeft) m
  o : y ∼ z
  o = transitive n identLeft

groupsHaveRightCancellation : (x y z : A) → (y · x) ∼ (z · x) → y ∼ z
groupsHaveRightCancellation x y z pr = transitive m identRight
  where
  _^-1 = inverse
  i : (y · x) · (x ^-1) ∼ (z · x) · (x ^-1)
  i = +WellDefined pr ~refl
  j : y · (x · (x ^-1)) ∼ (z · x) · (x ^-1)
  j = transitive +Associative i
  j' : y · 0G ∼ (z · x) · (x ^-1)
  j' = transitive (+WellDefined ~refl (symmetric invRight)) j
  k : y ∼ (z · x) · (x ^-1)
  k = transitive (symmetric identRight) j'
  l : y ∼ z · (x · (x ^-1))
  l = transitive k (symmetric +Associative)
  m : y ∼ z · 0G
  m = transitive l (+WellDefined ~refl invRight)

rightInversesAreUnique : {x : A} → {y : A} → (y · x) ∼ 0G → y ∼ (inverse x)
rightInversesAreUnique {x} {y} f = transitive i (transitive j (transitive k (transitive l m)))
  where
  _^-1 = inverse
  i : y ∼ y · 0G
  j : y · 0G ∼ y · (x · (x ^-1))
  k : y · (x · (x ^-1)) ∼ (y · x) · (x ^-1)
  l : (y · x) · (x ^-1) ∼ 0G · (x ^-1)
  m : 0G · (x ^-1) ∼ x ^-1
  i = symmetric identRight
  j = +WellDefined ~refl (symmetric invRight)
  k = +Associative
  l = +WellDefined f ~refl
  m = identLeft

leftInversesAreUnique : {x : A} → {y : A} → (x · y) ∼ 0G → y ∼ (inverse x)
leftInversesAreUnique {x} {y} f = rightInversesAreUnique {x} {y} l
  where
    _^-1 = inverse
    i : y · (x · y) ∼ y · 0G
    i' : y · (x · y) ∼ y
    j : (y · x) · y ∼ y
    k : (y · x) · y ∼ 0G · y
    l : y · x ∼ 0G
    i = +WellDefined ~refl f
    i' = transitive i identRight
    j = transitive (symmetric +Associative) i'
    k = transitive j (symmetric identLeft)
    l = groupsHaveRightCancellation y (y · x) 0G k

invTwice : (x : A) → (inverse (inverse x)) ∼ x
invTwice x = symmetric (rightInversesAreUnique {x ^-1} {x} invRight)
  where
  _^-1 = inverse

replaceGroupOp : {a b c d w x y z : A} → (Setoid._∼_ S a c) → (Setoid._∼_ S b d) → (Setoid._∼_ S w y) → (Setoid._∼_ S x z) → Setoid._∼_ S (a · b) (w · x) → Setoid._∼_ S (c · d) (y · z)
replaceGroupOp a~c b~d w~y x~z pr = transitive (symmetric (+WellDefined a~c b~d)) (transitive pr (+WellDefined w~y x~z))

replaceGroupOpRight : {a b c x : A} → (Setoid._∼_ S a (b · c)) → (Setoid._∼_ S c x) → (Setoid._∼_ S a (b · x))
replaceGroupOpRight a~bc c~x = transitive a~bc (+WellDefined reflexive c~x)

inverseWellDefined : {x y : A} → (x ∼ y) → (inverse x) ∼ (inverse y)
inverseWellDefined {x} {y} x~y = groupsHaveRightCancellation x (inverse x) (inverse y) q
  where
    p : inverse x · x ∼ inverse y · y
    p = transitive invLeft (symmetric invLeft)
    q : inverse x · x ∼ inverse y · x
    q = replaceGroupOpRight {_·_ (inverse x) x} {inverse y} {y} {x} p (symmetric x~y)

transferToRight : {a b : A} → (a · (inverse b)) ∼ 0G → a ∼ b
transferToRight {a} {b} ab-1 = transitive (symmetric (invTwice a)) (transitive u (invTwice b))
  where
    t : inverse a ∼ inverse b
    t = symmetric (leftInversesAreUnique ab-1)
    u : inverse (inverse a) ∼ inverse (inverse b)
    u = inverseWellDefined t

transferToRight' : {a b : A} → (a · b) ∼ 0G → a ∼ (inverse b)
transferToRight' {a} {b} ab-1 = transferToRight lemma
  where
    lemma : a · (inverse (inverse b)) ∼ 0G
    lemma = transitive (+WellDefined reflexive (invTwice b)) ab-1

transferToRight'' : {a b : A} → Setoid._∼_ S a b → (a · (inverse b)) ∼ 0G
transferToRight'' {a} {b} a~b = transitive (+WellDefined a~b reflexive) invRight

invInv : {x : A} → (inverse (inverse x)) ∼ x
invInv {x} = symmetric (transferToRight' invRight)

invIdent : (inverse 0G) ∼ 0G
invIdent = symmetric (transferToRight' identLeft)

swapInv : {x y : A} → (inverse x) ∼ y → x ∼ (inverse y)
swapInv {x} {y} -x=y = transitive (symmetric invInv) (inverseWellDefined -x=y)

identityIsUnique : (e : A) → ((b : A) → ((b · e) ∼ b)) → (e ∼ 0G)
identityIsUnique thing fb = transitive (symmetric identLeft) (fb 0G)

invContravariant : {x y : A} → (Setoid._∼_ S (Group.inverse G (x · y)) ((Group.inverse G y) · (Group.inverse G x)))
invContravariant {x} {y} = ans
  where
    _^-1 = inverse
    otherInv = (y ^-1) · (x ^-1)
    many+Associatives : x · ((y · (y ^-1)) · (x ^-1)) ∼ (x · y) · ((y ^-1) · (x ^-1))
    oneMult : (x · y) · otherInv ∼ x · (x ^-1)
    many+Associatives = transitive +Associative (transitive (+WellDefined +Associative reflexive) (symmetric +Associative))
    oneMult = symmetric (transitive (+WellDefined reflexive (transitive (symmetric identLeft) (+WellDefined (symmetric invRight) reflexive))) many+Associatives)
    otherInvIsInverse : (x · y) · otherInv ∼ 0G
    otherInvIsInverse = transitive oneMult invRight
    ans : (x · y) ^-1 ∼ (y ^-1) · (x ^-1)
    ans = symmetric (leftInversesAreUnique otherInvIsInverse)

equalsDoubleImpliesZero : {x : A} → (x · x) ∼ x → x ∼ 0G
equalsDoubleImpliesZero 2x=x = transitive (symmetric identLeft) (transitive (+WellDefined (symmetric invLeft) reflexive) (transitive (symmetric +Associative) (transitive (+WellDefined reflexive 2x=x) invLeft)))

invZeroImpliesZero : {x : A} → (inverse x) ∼ 0G → x ∼ 0G
invZeroImpliesZero {x} pr = transitive (symmetric (invTwice x)) (transitive (inverseWellDefined pr) invIdent)


module x09-747Decidable-hc where

-- Library

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

-- Copied from 747Isomorphism.
record _⇔_ (A B : Set) : Set where
  field
    to   : A → B
    from : B → A
open _⇔_

-- Copied from 747Relations.

infix 4 _<_

data _<_ : ℕ → ℕ → Set where

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

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

-- examples proving inequalities and their negations

2≤4 : 2 ≤ 4
2≤4 = s≤s (s≤s z≤n)

¬4≤2 : ¬ (4 ≤ 2)
¬4≤2 = λ { (s≤s (s≤s ())) }

-- Bool values (computation)
data Bool : Set where
  true  : Bool
  false : Bool

-- Boolean comparison function
infix 4 _≤ᵇ_

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

-- PLFA steps through these computations using equational reasoning.

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

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

-- Relating evidence and computation.

-- Boolean types (evidence)
T : Bool → Set
T true  = ⊤
T false = ⊥

T→≡ : ∀ (b : Bool) → T b → b ≡ true
T→≡ true tt = refl

≡→T : ∀ {b : Bool} → b ≡ true → T b
≡→T refl = tt

≤ᵇ→≤ : ∀ (m n : ℕ) → T (m ≤ᵇ n) → m ≤ n
≤ᵇ→≤  zero    zero   t = z≤n
≤ᵇ→≤  zero   (suc n) t = z≤n
≤ᵇ→≤ (suc m) (suc n) t = s≤s (≤ᵇ→≤ m n t)

≤→≤ᵇ : ∀ {m n : ℕ} → m ≤ n → T (m ≤ᵇ n)
≤→≤ᵇ {zero} {zero}      z≤n  = tt
≤→≤ᵇ {zero} {suc n}     z≤n  = tt
≤→≤ᵇ               (s≤s m≤n) = ≤→≤ᵇ m≤n

-- computation and evidence

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

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

-- helpers for defining _≤?_ (use these so examples will normalize)

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

¬s≤s : ∀ {m n : ℕ} → ¬ (m ≤ n) → ¬ (suc m ≤ suc n)
¬s≤s  {zero}  {zero} ¬m≤n = λ        sucm≤sucn  → ¬m≤n z≤n
¬s≤s  {zero} {suc n} ¬m≤n = λ        sucm≤sucn  → ¬m≤n z≤n
¬s≤s {suc m}  {zero} ¬m≤n = λ { (s≤s sucm≤sucn) → ¬m≤n sucm≤sucn }
¬s≤s {suc m} {suc n} ¬m≤n = λ { (s≤s sucm≤sucn) → ¬m≤n (s≤s (inv-s≤s sucm≤sucn)) }

-- Decidable ≤.

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

-- can also evaluate the LHS of these tests via C-c C-n
_ : 2 ≤? 4 ≡ yes (s≤s  (s≤s  z≤n))
_ = refl
_ : 4 ≤? 2 ≡ no (¬s≤s (¬s≤s ¬s≤z))
_ = refl

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

¬z<z : ¬ (zero < zero)
¬z<z = λ ()

¬s<s : ∀ {m n : ℕ} → ¬ (m < n) → ¬ (suc m < suc n)
¬s<s ¬m<n = λ { (s<s sucm<sucn) → ¬m<n sucm<sucn }

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

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

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

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

_≡ℕ?_ : ∀ (m n : ℕ) → Dec (m ≡ n)
zero  ≡ℕ? zero  = yes refl
zero  ≡ℕ? suc n = no (λ ())
suc m ≡ℕ? zero  = no (λ ())
suc m ≡ℕ? suc n
  with m ≡ℕ? n
... | yes m≡n = yes (cong suc m≡n)
... | no ¬m≡n = no  λ { refl → ¬m≡n refl }

-- reusing ≤ᵇ and proofs of equivalence with ≤ to decide ≤
_≤?′_ : ∀ (m n : ℕ) → Dec (m ≤ n)
m ≤?′ n with m ≤ᵇ n | ≤ᵇ→≤ m n | ≤→≤ᵇ {m} {n}
... | true  | ⊤→m≤n |     _ = yes (⊤→m≤n tt)
... | false |     _ | m≤n→⊥ = no  (λ m≤n → m≤n→⊥ m≤n)

-- extract Bool value from Dec (aka "isYes")
⌊_⌋ : ∀ {A : Set} → Dec A → Bool
⌊ yes x ⌋ = true
⌊ no  x ⌋ = false

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

-- If D is Dec A, then T ⌊ D ⌋ is inhabited exactly when A is inhabited.
toWitness : ∀ {A : Set} {D : Dec A} → T ⌊ D ⌋ → A
toWitness {_} {yes a} t = a

fromWitness : ∀ {A : Set} {D : Dec A} → A → T ⌊ D ⌋
fromWitness {_} {yes _} _ = tt
fromWitness {_} {no ¬A} a = ¬A a

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

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

fromWitnessFalse : ∀ {A : Set} {D : Dec A} → ¬ A → T (isNo D)
fromWitnessFalse {_} {yes A } ¬A = ¬A A
fromWitnessFalse {A} {no ¬A'} ¬A = tt

-- Agda standard library definitions for use of these.

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

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

-- concrete examples

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

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

-- BEST PRACTICE : use Decidables instead of Booleans.

-- Logical connectives for Decidables.

infixr 6 _∧_

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

infixr 6 _×-dec_

_×-dec_ : ∀ {A B : Set} → Dec A → Dec B → Dec (A × B)
yes A ×-dec yes B = yes ⟨ A , B ⟩
yes _ ×-dec no ¬B = no (λ A×B → ¬B (proj₂ A×B))
no ¬A ×-dec yes B = no (λ A×B → ¬A (proj₁ A×B))
no  _ ×-dec no ¬B = no (λ A×B → ¬B (proj₂ A×B))

infixr 5 _∨_

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

infixr 5 _⊎-dec_

_⊎-dec_ : ∀ {A B : Set} → Dec A → Dec B → Dec (A ⊎ B)
yes A ⊎-dec yes _ = yes (inj₁ A)
yes A ⊎-dec no  _ = yes (inj₁ A)
no  _ ⊎-dec yes B = yes (inj₂ B)
no ¬A ⊎-dec no ¬B = no (λ { (inj₁ A) → ¬A A ; (inj₂ B) → ¬B B } )

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

¬? : ∀ {A : Set} → Dec A → Dec (¬ A)
¬? (yes A) = no (λ ¬A → ¬A A)
¬? (no ¬A) = yes ¬A

-- Boolean version of implication
_⊃_ : Bool → Bool → Bool
true  ⊃ true  = true
true  ⊃ false = false
false ⊃ _     = true

_→-dec_ : ∀ {A B : Set} → Dec A → Dec B → Dec (A → B)
_     →-dec yes B = yes (λ   _ →  B)
no ¬A →-dec     _ = yes (λ A   → ⊥-elim (¬A A))
yes A →-dec no ¬B = no  (λ A→B → ¬B (A→B A))

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

∧-× : ∀ {A B : Set} (x : Dec A) (y : Dec B) → ⌊ x ⌋ ∧ ⌊ y ⌋ ≡ ⌊ x ×-dec y ⌋
∧-× (no  _) (no  _) = refl
∧-× (no  _) (yes _) = refl
∧-× (yes _) (no  _) = refl
∧-× (yes _) (yes _) = refl -- true ≡ true

∨-× : ∀ {A B : Set} (x : Dec A) (y : Dec B) → ⌊ x ⌋ ∨ ⌊ y ⌋ ≡ ⌊ x ⊎-dec y ⌋
∨-× (no  _) (no  _) = refl
∨-× (no  _) (yes _) = refl
∨-× (yes _) (no  _) = refl
∨-× (yes _) (yes _) = refl

not-¬ : ∀ {A : Set} (x : Dec A) → not ⌊ x ⌋ ≡ ⌊ ¬? x ⌋
not-¬ (yes _) = refl
not-¬ (no  _) = refl

-- 747/PLFA exercise: iff-erasure.

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

_⇔-dec_ : ∀ {A B : Set} → Dec A → Dec B → Dec (A ⇔ B)
yes A ⇔-dec yes B = yes (record { to = λ _ → B ; from = λ _ → A })
yes A ⇔-dec no ¬B = no  (λ A⇔B → ¬B (to   A⇔B A))
no ¬A ⇔-dec yes B = no  (λ A⇔B → ¬A (from A⇔B B))
no ¬A ⇔-dec no ¬B = yes (record { to = λ A → ⊥-elim (¬A A) ; from = λ B → ⊥-elim (¬B B) })

iff-⇔ : ∀ {A B : Set} (x : Dec A) (y : Dec B) → ⌊ x ⌋ iff ⌊ y ⌋ ≡ ⌊ x ⇔-dec y ⌋
iff-⇔ (yes _) (yes _) = refl
iff-⇔ (yes _) (no  _) = refl
iff-⇔ (no  _) (yes _) = refl
iff-⇔ (no ¬A) (no ¬B) = refl

-- proof by reflection (i.g., get Agda to construct proofs at compile time)

-- guarded version of monus
minus : (m n : ℕ) (n≤m : n ≤ m) → ℕ
minus      m   zero          _  = m
minus (suc m) (suc n) (s≤s m≤n) = minus m n m≤n

-- but must provide proofs
_ : minus 5 3 (s≤s (s≤s (s≤s z≤n))) ≡ 2
_ = refl

-- Agda will fill in an implicit record type if it can fill in all fields.
-- Since ⊤ is defined as a record type with no fields...
-- then Agda will compute a value of type True (n ≤? m).
_-_ : (m n : ℕ) {n≤m : True (n ≤? m)} → ℕ
_-_ m n {n≤m} = minus m n (toWitness n≤m)

-- then proofs no longer needed
_ : 5 - 3 ≡ 2
_ = refl

-- Use above to get Agda to compute parts of proofs that would be annoying for us to provide.


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

open import Relation.Binary using (Poset)

-- A thin (or posetal) category is a category with at most one
-- morphism between any pair of objects.
--
-- As explained on nLab:
--
--   "Up to isomorphism, a thin category is the same thing as a
--   proset. Up to equivalence, a thin category is the same thing as a
--   poset. (...) (It is really a question of whether you're working
--   with strict categories, which are classified up to isomorphism,
--   or categories as such, which are classified up to equivalence.)"
--
--                  -- https://ncatlab.org/nlab/show/thin+category
--
-- Since
--
--  1. posets in the standard library are defined up to an underlying
--     equivalence/setoid, but
--
--  2. categories in this library do not have a notion of equality on
--     objects (i.e. objects are considered up to isomorphism),
--
-- it makes sense to work with the weaker notion of thin categories
-- here, i.e. those generated by posets rather than prosets.  This
-- means that the core of a thin category (the groupoid consisting of
-- all its isomorphism) is just the setoid underlying the
-- corresponding poset.
--
-- (See Categories.Adjoint.Instance.PosetCore for more details.)

module Categories.Category.Construction.Thin {o ℓ₁ ℓ₂} e (P : Poset o ℓ₁ ℓ₂) where

open import Level
open import Data.Unit using (⊤)
open import Function using (flip)

open import Categories.Category
import Categories.Morphism as Morphism

open Poset P

Thin : Category o ℓ₂ e
Thin = record
  { Obj       = Carrier
  ; _⇒_       = _≤_
  ; _≈_       = λ _ _ → Lift e ⊤
  ; id        = refl
  ; _∘_       = flip trans
  ; assoc     = _
  ; identityˡ = _
  ; identityʳ = _
  ; equiv     = _
  ; ∘-resp-≈  = _
  }

module EqIsIso where

  open Category Thin hiding (_≈_)
  open Morphism Thin using (_≅_)
  open _≅_

  -- Equivalent elements of |P| are isomorphic objects of |Thin P|.

  ≈⇒≅ : ∀ {x y : Obj} → x ≈ y → x ≅ y
  ≈⇒≅ x≈y = record
    { from = reflexive x≈y
    ; to   = reflexive (Eq.sym x≈y)
    }

  ≅⇒≈ : ∀ {x y : Obj} → x ≅ y → x ≈ y
  ≅⇒≈ x≅y = antisym (from x≅y) (to x≅y)


module Numeral.Natural.Relation.Order.Decidable where

open import Functional
open import Logic.IntroInstances
open import Logic.Propositional.Theorems
open import Numeral.Natural
open import Numeral.Natural.Oper.Comparisons
open import Numeral.Natural.Oper.Proofs
open import Numeral.Natural.Relation.Order
open import Numeral.Natural.Relation.Order.Proofs
open import Relator.Equals
open import Relator.Equals.Proofs
open import Structure.Function.Domain
open import Type.Properties.Decidable

instance
  [≡]-decider : Decider(2)(_≡_)(_≡?_)
  [≡]-decider {𝟎}  {𝟎}   = true [≡]-intro
  [≡]-decider {𝟎}  {𝐒 y} = false \()
  [≡]-decider {𝐒 x}{𝟎}   = false \()
  [≡]-decider {𝐒 x}{𝐒 y} = step{f = id} (true ∘ [≡]-with(𝐒)) (false ∘ contrapositiveᵣ (injective(𝐒))) ([≡]-decider {x}{y})

instance
  [≤]-decider : Decider(2)(_≤_)(_≤?_)
  [≤]-decider {𝟎} {𝟎} = true [≤]-minimum
  [≤]-decider {𝟎} {𝐒 y} = true [≤]-minimum
  [≤]-decider {𝐒 x} {𝟎} = false \()
  [≤]-decider {𝐒 x} {𝐒 y} = step{f = id} (true ∘ \p → [≤]-with-[𝐒] ⦃ p ⦄) (false ∘ contrapositiveᵣ [≤]-without-[𝐒]) ([≤]-decider {x}{y})

[<]-decider : Decider(2)(_<_)(_<?_)
[<]-decider {𝟎} {𝟎} = false (λ ())
[<]-decider {𝟎} {𝐒 y} = true (succ min)
[<]-decider {𝐒 x} {𝟎} = false (λ ())
[<]-decider {𝐒 x} {𝐒 y} = step{f = id} (true ∘ succ) (false ∘ contrapositiveᵣ [≤]-without-[𝐒]) ([<]-decider {x} {y})


module Thesis.SIRelBigStep.Syntax where

open import Data.Nat

open import Thesis.SIRelBigStep.Types public

data Primitive : (τ : Type) → Set where
  succ : Primitive (nat ⇒ nat)
  add : Primitive (pair nat nat ⇒ nat)

data Const : (τ : Type) → Set where
  lit : (n : ℕ) → Const nat

data Term (Γ : Context) (τ : Type) : Set
-- Source values
data SVal (Γ : Context) : (τ : Type) → Set where
  var : ∀ {τ} →
    (x : Var Γ τ) →
    SVal Γ τ
  abs : ∀ {σ τ}
    (t : Term (σ • Γ) τ) →
    SVal Γ (σ ⇒ τ)
  cons : ∀ {τ1 τ2}
    (sv1 : SVal Γ τ1)
    (sv2 : SVal Γ τ2) →
    SVal Γ (pair τ1 τ2)
  const : ∀ {τ} → (c : Const τ) → SVal Γ τ

data Term (Γ : Context) (τ : Type) where
  val :
    SVal Γ τ →
    Term Γ τ
  primapp : ∀ {σ}
    (p : Primitive (σ ⇒ τ)) →
    (sv : SVal Γ σ) →
    Term Γ τ
  -- we use de Bruijn indices, so we don't need binding occurrences.
  app : ∀ {σ}
    (vs : SVal Γ (σ ⇒ τ)) →
    (vt : SVal Γ σ) →
    Term Γ τ
  lett : ∀ {σ}
    (s : Term Γ σ) →
    (t : Term (σ • Γ) τ) →
    Term Γ τ


module Dave.Algebra.Naturals.Exponentiation where
  open import Dave.Algebra.Naturals.Definition
  open import Dave.Algebra.Naturals.Multiplication
  open import Dave.Algebra.Naturals.Addition

  _^_ : ℕ → ℕ → ℕ
  a ^ zero = 1
  a ^ suc b = (a ^ b) * a

  infixl 8 _^_

  ^-distribₗ : ∀ (m n p : ℕ) → m ^ (n + p) ≡ (m ^ n) * (m ^ p)
  ^-distribₗ m zero p = refl
  ^-distribₗ m (suc n) p = begin
    m ^ (suc n + p) ≡⟨⟩
    m ^ suc (n + p) ≡⟨⟩
    (m ^ (n + p)) * m ≡⟨ cong (λ a → a * m) (^-distribₗ m n p) ⟩
    (m ^ n) * (m ^ p) * m ≡⟨ IsCommutativeMonoid.swap021 ℕ-*-IsCommutativeMonoid (m ^ n) (m ^ p) m ⟩
    (m ^ n) * m * (m ^ p) ≡⟨⟩
    (m ^ n) * (m ^ 1) * (m ^ p) ≡⟨ cong (λ a → a * (m ^ p)) (sym (^-distribₗ m n 1)) ⟩
    (m ^ (n + 1)) * (m ^ p) ≡⟨ cong (λ a → (m ^ a) * (m ^ p)) (+-add1ᵣ n) ⟩
    (m ^ suc n) * (m ^ p) ∎

  ^-distribᵣ : ∀ (m n p : ℕ) → (m * n) ^ p ≡ (m ^ p) * (n ^ p)
  ^-distribᵣ m n zero = refl
  ^-distribᵣ m n (suc p) = begin
     (m * n) ^ suc p ≡⟨⟩
     ((m * n) ^ p) * (m * n) ≡⟨ cong (λ a → a * (m * n)) (^-distribᵣ m n p) ⟩
     (m ^ p) * (n ^ p) * (m * n) ≡⟨ sym (IsSemigroup.assoc ℕ-*-IsSemigroup ((m ^ p) * (n ^ p)) m n) ⟩
     (m ^ p) * (n ^ p) * m * n ≡⟨ cong (λ a → a * n) (IsCommutativeMonoid.swap021 ℕ-*-IsCommutativeMonoid (m ^ p) (n ^ p) m) ⟩
     (m ^ p) * m * (n ^ p) * n ≡⟨ IsSemigroup.assoc ℕ-*-IsSemigroup ((m ^ p) * m) (n ^ p) n ⟩
     (m ^ p) * m * ((n ^ p) * n) ≡⟨⟩
     (m ^ p) * (m ^ 1) * ((n ^ p) * (n ^ 1)) ≡⟨ cong (λ a → a * ((n ^ p) * (n ^ 1))) (sym (^-distribₗ m p 1)) ⟩
     (m ^ (p + 1)) * ((n ^ p) * (n ^ 1)) ≡⟨ cong (λ a → (m ^ a) * ((n ^ p) * (n ^ 1))) (+-add1ᵣ p) ⟩
     (m ^ suc p) * ((n ^ p) * (n ^ 1)) ≡⟨ cong (λ a → (m ^ suc p) * a) (sym (^-distribₗ n p 1)) ⟩
     (m ^ suc p) * (n ^ (p + 1)) ≡⟨ cong (λ a → (m ^ suc p) * (n ^ a)) (+-add1ᵣ p) ⟩
     (m ^ suc p) * (n ^ suc p) ∎

  ^-*-assoc : ∀ (m n p : ℕ) → (m ^ n) ^ p ≡ m ^ (n * p)
  ^-*-assoc m n zero = sym (begin
    m ^ (n * zero) ≡⟨ cong (λ a → m ^ a) (*-zero n) ⟩
    1 ∎)
  ^-*-assoc m n (suc p) = begin
    (m ^ n) ^ suc p ≡⟨⟩
    (m ^ n) ^ p * (m ^ n) ≡⟨ cong (λ a → a * (m ^ n)) (^-*-assoc m n p) ⟩
    m ^ (n * p) * (m ^ n) ≡⟨ sym (^-distribₗ m (n * p) n) ⟩
    m ^ (n * p + n) ≡⟨ cong (λ a → m ^ a ) (sym (*-distrib1ᵣ-+ₗ n p)) ⟩
    m ^ (n * (p + 1)) ≡⟨ cong (λ a → m ^ (n * a)) (+-add1ᵣ p) ⟩
    m ^ (n * suc p) ∎


module Nat where

open import Base

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

_=N_ : Nat -> Nat -> Set
zero  =N zero  = True
zero  =N suc _ = False
suc _ =N zero  = False
suc n =N suc m = n =N m

refN : Refl _=N_
refN {zero}  = T
refN {suc n} = refN {n}

symN : Sym _=N_
symN {zero}{zero} p   = p
symN {suc n}{suc m} p = symN {n}{m} p
symN {zero}{suc _} ()
symN {suc _}{zero} ()

transN : Trans _=N_
transN {zero }{zero }{zero } p _ = p
transN {suc n}{suc m}{suc l} p q = transN {n}{m}{l} p q
transN {zero }{zero }{suc _} _ ()
transN {zero }{suc _}{_    } () _
transN {suc _}{zero }{_    } () _
transN {suc _}{suc _}{zero } _ ()


{-# OPTIONS --copattern --safe --no-sized-types --guardedness #-}
module Copattern where

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

record Stream (A : Set) : Set where
  coinductive
  field
    head : A
    tail : Stream A
open Stream public

-- | Bisimulation as equality
record _==_ {A : Set} (x : Stream A) (y : Stream A) : Set where
  coinductive
  field
    refl-head : head x ≡ head y
    refl-tail : tail x == tail y
open _==_ public

module Introduction where

  ones : Stream ℕ
  head ones = suc zero
  tail ones = ones

  repeat : {A : Set} -> A -> Stream A
  repeat {A} a = P
    where
    P : Stream A
    head P = a
    tail P = repeat a

  even : ∀ {A} -> Stream A -> Stream A
  even {A} a = P
    where
    P : Stream A
    head P = head a
    tail P = even (tail (tail a))

  odd : ∀ {A} -> Stream A -> Stream A
  odd {A} a = P
    where
    P : Stream A
    head P = head (tail a)
    tail P = odd (tail (tail a))

module Bisimulation where
  open Introduction

  refl′ : ∀ {A} -> (a : Stream A) -> a == a
  refl′ a = f
    where
    f : a == a
    refl-head f = refl
    refl-tail f = refl′ (tail a)

  oddEven : ∀ {A} -> (a : Stream A) -> odd a == even (tail a)
  oddEven a = f
    where
    f : odd a == even (tail a)
    refl-head f = refl
    refl-tail f = oddEven ((tail (tail a)))

module Merge where
  open Bisimulation
  open Introduction

  merge : ∀ {A} -> Stream A -> Stream A -> Stream A
  merge {A} a b = ma
    where
    ma : Stream A
    head ma = head a
    tail ma = merge b (tail a)

  -- Merge! Even! Odd!
  moe : ∀ {A} -> (a : Stream A) -> (merge (even a) (odd a) == a)
  moe a = f
    where
    f : merge (even a) (odd a) == a
    refl-head f = refl
    refl-head (refl-tail f) = refl
    refl-tail (refl-tail f) = moe (tail (tail a))


module plfa.part1.Induction where

import Relation.Binary.PropositionalEquality as Eq

open Eq using (_≡_; refl; cong; sym)
open Eq.≡-Reasoning
open import Data.Nat using (ℕ; zero; suc; _+_; _*_; _∸_)

+-assoc : ∀ (m n p : ℕ) → (m + n) + p ≡ m + (n + p)
+-assoc zero n p =
  begin
    (zero + n) + p
  ≡⟨⟩
    n + p
  ≡⟨⟩
    zero + (n + p)
  ∎
+-assoc (suc m) n p =
  begin
    (suc m + n) + p
  ≡⟨⟩
    suc (m + n) + p
  ≡⟨⟩
    suc ((m + n) + p)

  -- A relation is said to be a congruence for
  -- a given function if it is preserved by applying that function

  -- If e is evidence that x ≡ y,
  -- then cong f e is evidence that f x ≡ f y,
  -- for any function f

  -- The correspondence between proof by induction and
  -- definition by recursion is one of the most appealing
  -- aspects of Agda

  -- cong : ∀ (f : A → B) {x y} → x ≡ y → f x ≡ f y
  --           ^- suc               ^- (m + n) + p ≡ m + (n + p)
  -- ----------------------------------------------------------- (=> implies)
  -- suc ((m + n) + p) ≡ suc (m + (n + p))

  ≡⟨ cong suc (+-assoc m n p) ⟩
    suc (m + (n + p))

  -- cong : ∀ (f : A → B) {x y} → x ≡ y → f x ≡ f y
  -- cong f refl = refl

  ≡⟨⟩
    suc m + (n + p)
  ∎

+-assoc-2 : ∀ (n p : ℕ) → (2 + n) + p ≡ 2 + (n + p)
+-assoc-2 n p =
  begin
    (2 + n) + p
  ≡⟨⟩
    suc (1 + n) + p
  ≡⟨⟩
    suc ((1 + n) + p)
  ≡⟨ cong suc (+-assoc-1 n p) ⟩
    suc (1 + (n + p))
  ≡⟨⟩
    2 + (n + p)
  ∎
  where
  +-assoc-1 : ∀ (n p : ℕ) -> (1 + n) + p ≡ 1 + (n + p)
  +-assoc-1 n p =
    begin
      (1 + n) + p
    ≡⟨⟩
      suc (0 + n) + p
    ≡⟨⟩
      suc ((0 + n) + p)
    ≡⟨ cong suc (+-assoc-0 n p) ⟩
      suc (0 + (n + p))
    ≡⟨⟩
      1 + (n + p)
    ∎
    where
      +-assoc-0 : ∀ (n p : ℕ) → (0 + n) + p ≡ 0 + (n + p)
      +-assoc-0 n p =
        begin
          (0 + n) + p
        ≡⟨⟩
          n + p
        ≡⟨⟩
          0 + (n + p)
        ∎

+-identityᴿ : ∀ (m : ℕ) → m + zero ≡ m
+-identityᴿ zero =
  begin
    zero + zero
  ≡⟨⟩
    zero
  ∎
+-identityᴿ (suc m) =
  begin
    suc m + zero
  ≡⟨⟩
    suc (m + zero)
  ≡⟨ cong suc (+-identityᴿ m) ⟩
    suc m
  ∎

+-suc : ∀ (m n : ℕ) → m + suc n ≡ suc (m + n)
+-suc zero n =
  begin
    zero + suc n
  ≡⟨⟩
    suc n
  ≡⟨⟩
    suc (zero + n)
  ∎
+-suc (suc m) n =
  begin
    suc m + suc n
  ≡⟨⟩
    suc (m + suc n)
  ≡⟨ cong suc (+-suc m n) ⟩
    suc (suc (m + n))
  ≡⟨⟩
    suc (suc m + n)
  ∎

+-comm : ∀ (m n : ℕ) → m + n ≡ n + m
+-comm m zero =
  begin
    m + zero
  ≡⟨ +-identityᴿ m ⟩
    m
  ≡⟨⟩
    zero + m
  ∎
+-comm m (suc n) =
  begin
    m + suc n
  ≡⟨ +-suc m n ⟩
    suc (m + n)
  ≡⟨ cong suc (+-comm m n) ⟩
    suc (n + m)
  ≡⟨⟩
    suc n + m
  ∎

-- Rearranging

-- We can apply associativity to
-- rearrange parentheses however we like

+-rearrange
  : ∀ (m n p q : ℕ)
  → (m + n) + (p + q) ≡ m + (n + p) + q
+-rearrange m n p q =
  begin
    (m + n) + (p + q)
  ≡⟨ +-assoc m n (p + q) ⟩
    m + (n + (p + q))

  ≡⟨ cong (m +_) (sym (+-assoc n p q)) ⟩
    m + ((n + p) + q)

  -- +-assoc : (m + n) + p ≡ m + (n + p)
  -- sym (+-assoc) : m + (n + p) ≡ (m + n) + p

  ≡⟨ sym (+-assoc m (n + p) q) ⟩
    (m + (n + p)) + q
  ∎

-- Associativity with rewrite

-- Rewriting avoids not only chains of
-- equations but also the need to invoke cong

+-assoc' : ∀ (m n p : ℕ) → (m + n) + p ≡ m + (n + p)
+-assoc' zero n p                           = refl
+-assoc' (suc m) n p rewrite +-assoc' m n p = refl

+-identity' : ∀ (n : ℕ) → n + zero ≡ n
+-identity' zero = refl
+-identity' (suc n) rewrite +-identity' n = refl

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

+-comm' : ∀ (m n : ℕ) → m + n ≡ n + m
+-comm' m zero rewrite +-identity' m = refl
+-comm' m (suc n) rewrite +-suc' m n | +-comm' m n = refl

-- Building proofs interactively

+-assoc'' : ∀ (m n p : ℕ) → (m + n) + p ≡ m + (n + p)
+-assoc'' zero n p = refl
+-assoc'' (suc m) n p rewrite +-assoc'' m n p = refl

-- Exercise

-- Note:
-- sym -- rewrites the left side of the Goal

+-swap : ∀ (m n p : ℕ) → m + (n + p) ≡ n + (m + p)
+-swap zero n p = refl
+-swap (suc m) n p rewrite
    +-assoc'' m n p
  | +-suc n (m + p)
  | +-swap m n p
  = refl

-- (suc m + n) * p ≡ suc m * p + n * p
-- p + (m * p + n * p) ≡ p + m * p + n * p

*-distrib-+ : ∀ (m n p : ℕ) → (m + n) * p ≡ m * p + n * p
*-distrib-+ zero n p = refl
*-distrib-+ (suc m) n p rewrite
    *-distrib-+ m n p
  | sym (+-assoc p (m * p) (n * p))
  = refl

-- (n + m * n) * p ≡ n * p + m * (n * p)

*-assoc : ∀ (m n p : ℕ) → (m * n) * p ≡ m * (n * p)
*-assoc zero n p = refl
*-assoc (suc m) n p rewrite
    *-distrib-+ n (m * n) p
  | *-assoc m n p
  = refl


{-# OPTIONS --cubical --safe --postfix-projections #-}

module Cardinality.Finite.Structure where

open import Prelude
open import Data.Fin
open import Data.Nat
open import Data.Nat.Properties

private
  variable
    n m : ℕ

liftˡ : ∀ n m → Fin m → Fin (n + m)
liftˡ zero    m x = x
liftˡ (suc n) m x = fs (liftˡ n m x)

liftʳ : ∀ n m → Fin n → Fin (n + m)
liftʳ (suc n) m f0     = f0
liftʳ (suc n) m (fs x) = fs (liftʳ n m x)

mapl : (A → B) → A ⊎ C → B ⊎ C
mapl f (inl x) = inl (f x)
mapl f (inr x) = inr x

fin-sum-to : ∀ n m → Fin n ⊎ Fin m → Fin (n + m)
fin-sum-to n m = either (liftʳ n m) (liftˡ n m)

fin-sum-from : ∀ n m → Fin (n + m) →  Fin n ⊎ Fin m
fin-sum-from zero    m x      = inr x
fin-sum-from (suc n) m f0     = inl f0
fin-sum-from (suc n) m (fs x) = mapl fs (fin-sum-from n m x)

mapl-distrib : ∀ {a b c d} {A : Type a} {B : Type b} {C : Type c} {D : Type d} (xs : A ⊎ B) (h : A → C) (f : C → D) (g : B → D) → either′ f g (mapl h xs) ≡ either′ (f ∘′ h) g xs
mapl-distrib (inl x) h f g = refl
mapl-distrib (inr x) h f g = refl

either-distrib : ∀ {d} {D : Type d} (f : A → C) (g : B → C) (h : C → D) (xs : A ⊎ B) → either′ (h ∘ f) (h ∘ g) xs ≡ h (either′ f g xs)
either-distrib f g h (inl x) = refl
either-distrib f g h (inr x) = refl

open import Path.Reasoning

fin-sum-to-from : ∀ n m x → fin-sum-to n m (fin-sum-from n m x) ≡ x
fin-sum-to-from zero    m x      = refl
fin-sum-to-from (suc n) m f0     = refl
fin-sum-to-from (suc n) m (fs x) =
  fin-sum-to (suc n) m (mapl fs (fin-sum-from n m x)) ≡⟨ mapl-distrib (fin-sum-from n m x) fs (liftʳ (suc n) m) (liftˡ (suc n) m) ⟩
  either (liftʳ (suc n) m ∘ fs) (liftˡ (suc n) m) (fin-sum-from n m x) ≡⟨⟩
  either (fs ∘ liftʳ n m) (fs ∘ liftˡ n m) (fin-sum-from n m x) ≡⟨ either-distrib (liftʳ n m) (liftˡ n m) fs (fin-sum-from n m x) ⟩
  fs (either (liftʳ n m) (liftˡ n m) (fin-sum-from n m x)) ≡⟨ cong fs (fin-sum-to-from n m x) ⟩
  fs x ∎

-- fin-sum-from-to : ∀ n m x → fin-sum-from n m (fin-sum-to n m x) ≡ x
-- fin-sum-from-to n m (inl x) = {!!}
-- fin-sum-from-to n m (inr x) = {!!}

-- fin-sum : ∀ n m → Fin n ⊎ Fin m ⇔ Fin (n + m)
-- fin-sum n m .fun = fin-sum-to n m
-- fin-sum n m .inv = fin-sum-from n m
-- fin-sum n m .rightInv = fin-sum-to-from n m
-- fin-sum n m .leftInv = fin-sum-from-to n m


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

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

module Rings.Homomorphisms.Kernel {a b c d : _} {A : Set a} {B : Set c} {S : Setoid {a} {b} A} {T : Setoid {c} {d} B} {_+1_ _*1_ : A → A → A} {_+2_ _*2_ : B → B → B} {R1 : Ring S _+1_ _*1_} {R2 : Ring T _+2_ _*2_} {f : A → B} (fHom : RingHom R1 R2 f) where

open import Groups.Homomorphisms.Kernel (RingHom.groupHom fHom)

ringKernelIsIdeal : Ideal R1 groupKernelPred
Ideal.isSubgroup ringKernelIsIdeal = groupKernelIsSubgroup
Ideal.accumulatesTimes ringKernelIsIdeal {x} {y} fx=0 = transitive (RingHom.ringHom fHom) (transitive (Ring.*WellDefined R2 fx=0 reflexive) (transitive (Ring.*Commutative R2) (Ring.timesZero R2)))
  where
    open Setoid T
    open Equivalence eq


-- modular arithmetic

module nat-mod where

open import eq
open import nat

infix 8 _≡_mod_

data _≡_mod_ : ℕ → ℕ → ℕ → Set where
  mod-refl : ∀ {n k} → n ≡ n mod k
  mod-add : ∀ {n m k} → n ≡ m mod k → n + k ≡ m mod k
  mod-symm : ∀ {n m k} → n ≡ m mod k → m ≡ n mod k

{-
mod-trans : ∀ {n m o k} → n ≡ m mod k → m ≡ o mod k → n ≡ o mod k
mod-trans{n}{.n}{o}{k} mod-refl p2 = {!!}
mod-trans}{m}{o}{k} (mod-add p1) p2 = {!!}
mod-trans{n}{m}{o}{k} (mod-symm p1) p2 = {!!}
-}


------------------------------------------------------------------------
-- The delay monad, defined coinductively, with a sized type parameter
------------------------------------------------------------------------

{-# OPTIONS --sized-types #-}

module Delay-monad.Sized where

open import Equality.Propositional
open import Prelude
open import Prelude.Size

open import Bijection equality-with-J using (_↔_)

-- The delay monad.

mutual

  data Delay {a} (A : Size → Type a) (i : Size) : Type a where
    now   : A i        → Delay A i
    later : Delay′ A i → Delay A i

  record Delay′ {a} (A : Size → Type a) (i : Size) : Type a where
    coinductive
    field
      force : {j : Size< i} → Delay A j

open Delay′ public

module _ {a} {A : Size → Type a} where

  mutual

    -- A non-terminating computation.

    never : ∀ {i} → Delay A i
    never = later never′

    never′ : ∀ {i} → Delay′ A i
    force never′ = never

  -- Removes a later constructor, if possible.

  drop-later : Delay A ∞ → Delay A ∞
  drop-later (now   x) = now x
  drop-later (later x) = force x

  -- An unfolding lemma for Delay.

  Delay↔ : ∀ {i} → Delay A i ↔ A i ⊎ Delay′ A i
  Delay↔ = record
    { surjection = record
      { logical-equivalence = record
        { to   = λ { (now x) → inj₁ x; (later x) → inj₂ x }
        ; from = [ now , later ]
        }
      ; right-inverse-of = [ (λ _ → refl) , (λ _ → refl) ]
      }
    ; left-inverse-of = λ { (now _) → refl; (later _) → refl }
    }


module Oscar.Data.Proposextensequality where

open import Oscar.Data.Proposequality using (_≡_)
open import Oscar.Level

infix 4 _≡̇_
_≡̇_ : ∀ {a} {A : Set a} {b} {B : A → Set b} → ((x : A) → B x) → ((x : A) → B x) → Set (a ⊔ b)
f ≡̇ g = ∀ x → f x ≡ g x


open import Formalization.PredicateLogic.Signature

module Formalization.PredicateLogic.Classical.Semantics (𝔏 : Signature) {ℓₘ} where
open Signature(𝔏)

import      Lvl
open import Data.Boolean
open import Data.ListSized
open import Numeral.Natural
open import Type

private variable args : ℕ

-- Model.
-- A model decides which propositional constants that are true or false.
-- A model in a signature `s` consists of a domain and interpretations of the function/relation symbols in `s`.
-- Also called: Structure.
-- Note: A model satisfying `∀{args} → Empty(Prop args)` is called an "Algebraic structure".
record Model : Type{ℓₚ Lvl.⊔ ℓₒ Lvl.⊔ Lvl.𝐒(ℓₘ)} where
  field
    Domain : Type{ℓₘ}                                  -- The type of objects that quantifications quantifies over and functions/relations maps from.
    function : Obj(args) → List(Domain)(args) → Domain -- Maps Obj to a n-ary function (n=0 is interpreted as a constant).
    relation : Prop(args) → List(Domain)(args) → Bool  -- Maps Prop to a boolean n-ary relation (n=0 is interpreted as a proposition).

open Model public using() renaming (Domain to dom ; function to fn ; relation to rel)


module Computability.Data.Nat.Iteration where

open import Computability.Prelude

iterate : {A : Set} → (A → A) → ℕ → A → A
iterate f zero a = a
iterate f (suc n) a = f (iterate f n a)

split-iterate : {A : Set}(f : A → A)(a : A)
              → (n m : ℕ)
              → iterate f (n + m) a ≡ iterate f n (iterate f m a)
split-iterate f a zero m = refl
split-iterate f a (suc n) m rewrite split-iterate f a n m = refl