module Lib.Fin where

open import Lib.Nat
open import Lib.Bool
open import Lib.Id

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

fromNat : (n : Nat) -> Fin (suc n)
fromNat zero    = zero
fromNat (suc n) = suc (fromNat n)

toNat : {n : Nat} -> Fin n -> Nat
toNat zero    = zero
toNat (suc n) = suc (toNat n)

weaken : {n : Nat} -> Fin n -> Fin (suc n)
weaken zero    = zero
weaken (suc n) = suc (weaken n)

lem-toNat-weaken : forall {n} (i : Fin n) -> toNat i ≡ toNat (weaken i)
lem-toNat-weaken zero    = refl
lem-toNat-weaken (suc i) with toNat i | lem-toNat-weaken i
... | .(toNat (weaken i)) | refl = refl

lem-toNat-fromNat : (n : Nat) -> toNat (fromNat n) ≡ n
lem-toNat-fromNat zero = refl
lem-toNat-fromNat (suc n) with toNat (fromNat n) | lem-toNat-fromNat n
... | .n | refl = refl

finEq : {n : Nat} -> Fin n -> Fin n -> Bool
finEq  zero    zero   = true
finEq  zero   (suc _) = false
finEq (suc _)  zero   = false
finEq (suc i) (suc j) = finEq i j

-- A view telling you if a given element is the maximal one.
data MaxView {n : Nat} : Fin (suc n) -> Set where
  theMax : MaxView (fromNat n)
  notMax : (i : Fin n) -> MaxView (weaken i)

maxView : {n : Nat}(i : Fin (suc n)) -> MaxView i
maxView {zero} zero = theMax
maxView {zero} (suc ())
maxView {suc n} zero = notMax zero
maxView {suc n} (suc i) with maxView i
maxView {suc n} (suc .(fromNat n)) | theMax   = theMax
maxView {suc n} (suc .(weaken i))  | notMax i = notMax (suc i)

-- The non zero view

data NonEmptyView : {n : Nat} -> Fin n -> Set where
  ne : {n : Nat}{i : Fin (suc n)} -> NonEmptyView i

nonEmpty : {n : Nat}(i : Fin n) -> NonEmptyView i
nonEmpty zero    = ne
nonEmpty (suc _) = ne

-- The thinning view

thin : {n : Nat} -> Fin (suc n) -> Fin n -> Fin (suc n)
thin zero    j       = suc j
thin (suc i) zero    = zero
thin (suc i) (suc j) = suc (thin i j)

data EqView : {n : Nat} -> Fin n -> Fin n -> Set where
  equal    : {n : Nat}{i : Fin n} -> EqView i i
  notequal : {n : Nat}{i : Fin (suc n)}(j : Fin n) -> EqView i (thin i j)

compare : {n : Nat}(i j : Fin n) -> EqView i j
compare zero    zero    = equal
compare zero    (suc j) = notequal j
compare (suc i) zero    with nonEmpty i
...                | ne = notequal zero
compare (suc i) (suc j) with compare i j
compare (suc i) (suc .i)          | equal      = equal
compare (suc i) (suc .(thin i j)) | notequal j = notequal (suc j)


module Bin-embedding where

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

open import Isomorphism using (_≲_)

-- 2進数の表現
data Bin : Set where
  ⟨⟩ : Bin
  _O : Bin → Bin
  _I : Bin → Bin

-- 2進数のインクリメント
inc : Bin → Bin
inc ⟨⟩    = ⟨⟩ I
inc (b O) = b I
inc (b I) = inc b O

-- 自然数から2進数への変換
to : ℕ → Bin
to zero    = ⟨⟩ O
to (suc n) = inc (to n)

-- 2進数から自然数への変換
from : Bin → ℕ
from ⟨⟩    = zero
from (b O) = 2 * (from b)
from (b I) = 2 * (from b) + 1

2*n≡n+n : ∀ (n : ℕ) → 2 * n ≡ n + n
2*n≡n+n n rewrite +-identityʳ n = refl

+-suc-suc : ∀ (m n : ℕ) → (suc m) + (suc n) ≡ suc (suc (m + n))
+-suc-suc m n rewrite +-suc (suc m) n | +-assoc 1 m n = refl

from∘inc≡suc∘from : ∀ (b : Bin) → from (inc b) ≡ suc (from b)
from∘inc≡suc∘from ⟨⟩ = refl
from∘inc≡suc∘from (b O) rewrite +-suc (from (b O)) zero = cong suc (+-identityʳ (from (b O)))
from∘inc≡suc∘from (b I) rewrite from∘inc≡suc∘from b | 2*n≡n+n (suc (from b)) | +-suc-suc (from b) (from b) | sym (2*n≡n+n (from b)) | +-comm 1 (2 * (from b)) = refl

from∘to : ∀ (n : ℕ) → from (to n) ≡ n
from∘to zero = refl
from∘to (suc n) rewrite from∘inc≡suc∘from (to n) = cong suc (from∘to n)

Bin-embedding : ℕ ≲ Bin
Bin-embedding =
  record
    { to      = to
    ; from    = from
    ; from∘to = from∘to
    }


module Data.Boolean.Operators where

open import Data.Boolean

-- Definition of boolean operators with conventions from logic
module Logic where
  infixl 1005 _∧_
  infixl 1004 _∨_ _⊕_
  infixl 1003 _⟵_ _⟷_ _⟶_

  _∧_ : Bool → Bool → Bool
  _∧_ 𝑇 𝑇 = 𝑇
  _∧_ 𝐹 𝑇 = 𝐹
  _∧_ 𝑇 𝐹 = 𝐹
  _∧_ 𝐹 𝐹 = 𝐹

  _∨_ : Bool → Bool → Bool
  _∨_ 𝑇 𝑇 = 𝑇
  _∨_ 𝐹 𝑇 = 𝑇
  _∨_ 𝑇 𝐹 = 𝑇
  _∨_ 𝐹 𝐹 = 𝐹

  open Data.Boolean using () renaming (not to ¬) public

  _⊕_ : Bool → Bool → Bool
  _⊕_ 𝑇 𝑇 = 𝐹
  _⊕_ 𝐹 𝑇 = 𝑇
  _⊕_ 𝑇 𝐹 = 𝑇
  _⊕_ 𝐹 𝐹 = 𝐹

  _⟶_ : Bool → Bool → Bool
  _⟶_ 𝑇 𝑇 = 𝑇
  _⟶_ 𝐹 𝑇 = 𝑇
  _⟶_ 𝑇 𝐹 = 𝐹
  _⟶_ 𝐹 𝐹 = 𝑇

  _⟵_ : Bool → Bool → Bool
  _⟵_ 𝑇 𝑇 = 𝑇
  _⟵_ 𝐹 𝑇 = 𝐹
  _⟵_ 𝑇 𝐹 = 𝑇
  _⟵_ 𝐹 𝐹 = 𝑇

  _⟷_ : Bool → Bool → Bool
  _⟷_ 𝑇 𝑇 = 𝑇
  _⟷_ 𝐹 𝑇 = 𝐹
  _⟷_ 𝑇 𝐹 = 𝐹
  _⟷_ 𝐹 𝐹 = 𝑇

  _⊼_ : Bool → Bool → Bool
  _⊼_ 𝑇 𝑇 = 𝐹
  _⊼_ 𝐹 𝑇 = 𝑇
  _⊼_ 𝑇 𝐹 = 𝑇
  _⊼_ 𝐹 𝐹 = 𝑇

  _⊽_ : Bool → Bool → Bool
  _⊽_ 𝑇 𝑇 = 𝐹
  _⊽_ 𝐹 𝑇 = 𝐹
  _⊽_ 𝑇 𝐹 = 𝐹
  _⊽_ 𝐹 𝐹 = 𝑇

  ⊤ : Bool
  ⊤ = 𝑇

  ⊥ : Bool
  ⊥ = 𝐹

-- Definition of boolean operators with conventions from typical programming languages
module Programming where
  open Logic using () renaming
    (_∧_  to _&&_
    ; _∨_ to _||_
    ; ¬   to !
    ; _⟷_ to _==_
    ; _⊕_ to _!=_
    ; _⟶_ to _→?_
    ; _⟵_ to _←?_
    ) public


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

module hott.topology.loopspace where

open import hott.core
open import hott.types
open import hott.functions

-- The pointed loop space

Ω∙ : ∀{ℓ} → Type● ℓ → Type● ℓ
Ω∙ (A , a) = (a ≡ a , refl)

-- The loops space. It is obtained by suppressing the base point of
-- the corresponding pointed loop space.
Ω : ∀{ℓ} → Type● ℓ → Type ℓ
Ω = space ∘ Ω∙

--

-- The iterated pointed loop space

Ω̂∙ : ∀{ℓ}  → ℕ → Type● ℓ → Type● ℓ
Ω̂∙ = iterate Ω∙

-- The iterated loop space. It is obtained by suppressing the base
-- point of the iterated pointed loop space.

Ω̂ : ∀{ℓ}  → ℕ → Type● ℓ → Type ℓ
Ω̂ n = space ∘ Ω̂∙ n

-- Some short hands

Ω²∙ : ∀{ℓ} → Type● ℓ → Type● ℓ; Ω²∙ = Ω̂∙ 2
Ω³∙ : ∀{ℓ} → Type● ℓ → Type● ℓ; Ω³∙ = Ω̂∙ 3
Ω⁴∙ : ∀{ℓ} → Type● ℓ → Type● ℓ; Ω⁴∙ = Ω̂∙ 4
Ω⁵∙ : ∀{ℓ} → Type● ℓ → Type● ℓ; Ω⁵∙ = Ω̂∙ 5
Ω⁶∙ : ∀{ℓ} → Type● ℓ → Type● ℓ; Ω⁶∙ = Ω̂∙ 6
Ω⁷∙ : ∀{ℓ} → Type● ℓ → Type● ℓ; Ω⁷∙ = Ω̂∙ 7
Ω⁸∙ : ∀{ℓ} → Type● ℓ → Type● ℓ; Ω⁸∙ = Ω̂∙ 8
Ω⁹∙ : ∀{ℓ} → Type● ℓ → Type● ℓ; Ω⁹∙ = Ω̂∙ 9

Ω² : ∀{ℓ} → Type● ℓ → Type ℓ; Ω² = Ω̂ 2
Ω³ : ∀{ℓ} → Type● ℓ → Type ℓ; Ω³ = Ω̂ 3
Ω⁴ : ∀{ℓ} → Type● ℓ → Type ℓ; Ω⁴ = Ω̂ 4
Ω⁵ : ∀{ℓ} → Type● ℓ → Type ℓ; Ω⁵ = Ω̂ 5
Ω⁶ : ∀{ℓ} → Type● ℓ → Type ℓ; Ω⁶ = Ω̂ 6
Ω⁷ : ∀{ℓ} → Type● ℓ → Type ℓ; Ω⁷ = Ω̂ 7
Ω⁸ : ∀{ℓ} → Type● ℓ → Type ℓ; Ω⁸ = Ω̂ 8
Ω⁹ : ∀{ℓ} → Type● ℓ → Type ℓ; Ω⁹ = Ω̂ 9


module CS410-Prelude where

open import Agda.Primitive

----------------------------------------------------------------------------
-- Zero -- the empty type (logically, a false proposition)
----------------------------------------------------------------------------

data Zero : Set where

magic : forall {l}{A : Set l} -> Zero -> A
magic ()

----------------------------------------------------------------------------
-- One -- the type with one value (logically, a true proposition)
----------------------------------------------------------------------------

record One : Set where
  constructor <>
open One public
{-# COMPILED_DATA One () () #-}

----------------------------------------------------------------------------
-- Two -- the type of Boolean values
----------------------------------------------------------------------------

data Two : Set where tt ff : Two
{-# BUILTIN BOOL Two #-}
{-# BUILTIN TRUE tt #-}
{-# BUILTIN FALSE ff #-}
{-# COMPILED_DATA Two Bool True False #-}

-- nondependent conditional with traditional syntax
if_then_else_ : {l : Level}{X : Set l} -> Two -> X -> X -> X
if tt then t else e = t
if ff then t else e = e

-- dependent conditional cooked for partial application
caseTwo : forall {l}{P : Two -> Set l} -> P tt -> P ff -> (b : Two) -> P b
caseTwo t f tt = t
caseTwo t f ff = f

----------------------------------------------------------------------------
-- "Sigma" -- the type of dependent pairs, giving binary products and sums
----------------------------------------------------------------------------

record Sg {l : Level}(S : Set l)(T : S -> Set l) : Set l where
  constructor _,_
  field
    fst : S
    snd : T fst
open Sg public
_*_ : {l : Level} -> Set l -> Set l -> Set l
S * T = Sg S \ _ -> T
infixr 4 _,_ _*_

_+_ : Set -> Set -> Set
S + T = Sg Two (caseTwo S T)

pattern inl s = tt , s
pattern inr t = ff , t

----------------------------------------------------------------------------
-- "Equality" -- the type of evidence that things are the same
----------------------------------------------------------------------------

data _==_ {l}{X : Set l}(x : X) : X -> Set l where
  refl : x == x
infix 1 _==_
{-# BUILTIN EQUALITY _==_ #-}
{-# BUILTIN REFL refl #-}

sym : forall {l}{X : Set l}{x y : X} -> x == y -> y == x
sym refl = refl

-- this proof principle is useful for proving laws, don't use it for
-- fixing type problems in your programs

postulate ext : forall {l m}{A : Set l}{B : Set m}{f g : A -> B} ->
            (forall a -> f a == g a) -> f == g

----------------------------------------------------------------------------
-- functional plumbing
----------------------------------------------------------------------------

id : forall {l}{X : Set l} -> X -> X
id x = x

-- the type of composition can be generalized further
_o_ : forall {l}{X Y Z : Set l} -> (Y -> Z) -> (X -> Y) -> X -> Z
(f o g) x = f (g x)

_$_ : forall{l}{X Y : Set l} -> (X -> Y) -> X -> Y
f $ x = f x

----------------------------------------------------------------------------
-- lists
----------------------------------------------------------------------------

data List (X : Set) : Set where  -- X scopes over the whole declaration...
  []    : List X                 -- ...so you can use it here...
  _::_  : X -> List X -> List X  -- ...and here.
infixr 3 _::_
{-# COMPILED_DATA List [] [] (:) #-}
{-# BUILTIN LIST List #-}
{-# BUILTIN NIL [] #-}
{-# BUILTIN CONS _::_ #-}

----------------------------------------------------------------------------
-- chars and strings
----------------------------------------------------------------------------

postulate       -- this means that we just suppose the following things exist...
  Char : Set
  String : Set
{-# BUILTIN CHAR Char #-}
{-# COMPILED_TYPE Char Char #-}      -- ...and by the time we reach Haskell...
{-# BUILTIN STRING String #-}
{-# COMPILED_TYPE String String #-}  -- ...they *do* exist!

primitive       -- these are baked in; they even work!
  primCharEquality    : Char -> Char -> Two
  primStringAppend    : String -> String -> String
  primStringToList    : String -> List Char
  primStringFromList  : List Char -> String

---------------------------------------------------------------------------
-- COLOURS
---------------------------------------------------------------------------

-- We're going to be making displays from coloured text.

data Colour : Set where
  black red green yellow blue magenta cyan white : Colour
{-# COMPILED_DATA Colour HaskellSetup.Colour
      HaskellSetup.Black HaskellSetup.Red HaskellSetup.Green
      HaskellSetup.Yellow HaskellSetup.Blue HaskellSetup.Magenta
      HaskellSetup.Cyan HaskellSetup.White #-}


module Data.Nat.Literal where

open import Data.Nat using (ℕ; suc; zero)
open import Data.Fin using (Fin; suc; zero)
open import Data.Unit using (⊤)
open import Data.Empty using (⊥)
open import Agda.Builtin.FromNat using (Number; fromNat) public

_≤_ : ℕ → ℕ → Set
zero  ≤ n     = ⊤
suc m ≤ zero  = ⊥
suc m ≤ suc n = m ≤ n

instance
  ℕ-num : Number ℕ
  ℕ-num .Number.Constraint _ = ⊤
  ℕ-num .Number.fromNat n = n

instance
  Fin-num : {n : ℕ} → Number (Fin (suc n))
  Fin-num {n} .Number.Constraint m = m ≤ n
  Fin-num {n} .Number.fromNat m ⦃ p ⦄ = from m n p where
    from : (m n : ℕ) → m ≤ n → Fin (suc n)
    from zero _ _ = zero
    from (suc _) zero ()
    from (suc m) (suc n) p = suc (from m n p)


{-# OPTIONS --sized-types #-}
open import Relation.Binary.Core

module SelectSort.Correctness.Order  {A : Set}
                  (_≤_ : A → A → Set)
                  (tot≤ : Total _≤_)
                  (trans≤ : Transitive _≤_)  where

open import Data.List
open import Data.Product
open import Data.Sum
open import Function using (_∘_)
open import List.Sorted _≤_
open import Order.Total _≤_ tot≤
open import Size
open import SList
open import SList.Order _≤_
open import SList.Order.Properties _≤_
open import SelectSort _≤_ tot≤

lemma-select-≤ : {ι : Size}(x : A) → (xs : SList A {ι}) → proj₁ (select x xs) ≤ x
lemma-select-≤ x snil = refl≤
lemma-select-≤ x (y ∙ ys)
    with tot≤ x y
... | inj₁ x≤y = lemma-select-≤ x ys
... | inj₂ y≤x = trans≤ (lemma-select-≤ y ys) y≤x

lemma-select-*≤ : {ι : Size}(x : A) → (xs : SList A {ι}) → proj₁ (select x xs) *≤ proj₂ (select x xs)
lemma-select-*≤ x snil = genx
lemma-select-*≤ x (y ∙ ys)
    with tot≤ x y
... | inj₁ x≤y = gecx (trans≤ (lemma-select-≤ x ys) x≤y) (lemma-select-*≤ x ys)
... | inj₂ y≤x = gecx (trans≤ (lemma-select-≤ y ys) y≤x) (lemma-select-*≤ y ys)

lemma-select-≤-*≤ : {ι : Size}{b x : A}{xs : SList A {ι}} → b ≤ x → b *≤ xs → b ≤ proj₁ (select x xs) × b *≤ proj₂ (select x xs)
lemma-select-≤-*≤ b≤x genx = b≤x , genx
lemma-select-≤-*≤ {x = x} b≤x (gecx {x = y} b≤y b*≤ys)
    with tot≤ x y
... | inj₁ x≤y = proj₁ (lemma-select-≤-*≤ b≤x b*≤ys) , gecx (trans≤ b≤x x≤y) (proj₂ (lemma-select-≤-*≤ b≤x b*≤ys))
... | inj₂ y≤x = proj₁ (lemma-select-≤-*≤ b≤y b*≤ys) , gecx (trans≤ b≤y y≤x) (proj₂ (lemma-select-≤-*≤ b≤y b*≤ys))

lemma-selectSort-*≤ : {ι : Size}{x : A}{xs : SList A {ι}} → x *≤ xs → x *≤ selectSort xs
lemma-selectSort-*≤ genx = genx
lemma-selectSort-*≤ (gecx x≤y x*≤ys)
    with lemma-select-≤-*≤ x≤y x*≤ys
... | (x≤z , x*≤zs) = gecx x≤z (lemma-selectSort-*≤ x*≤zs)

lemma-selectSort-sorted : {ι : Size}(xs : SList A {ι}) → Sorted (unsize A (selectSort xs))
lemma-selectSort-sorted snil = nils
lemma-selectSort-sorted (x ∙ xs) = lemma-slist-sorted (lemma-selectSort-*≤ (lemma-select-*≤ x xs)) (lemma-selectSort-sorted (proj₂ (select x xs)))

theorem-selectSort-sorted : (xs : List A) → Sorted (unsize A (selectSort (size A xs)))
theorem-selectSort-sorted = lemma-selectSort-sorted ∘ (size A)


module Numeral.Natural.Oper.Comparisons where

import      Lvl
open import Data.Boolean
import      Data.Boolean.Operators
open        Data.Boolean.Operators.Programming
open import Numeral.Natural
open import Numeral.Sign

ℕbool : Bool → ℕ
ℕbool = if_then 1 else 0

-- Compare
_⋚?_ : ℕ → ℕ → (−|0|+)
𝟎    ⋚? 𝟎    = 𝟎
𝟎    ⋚? 𝐒(b) = ➖
𝐒(a) ⋚? 𝟎    = ➕
𝐒(a) ⋚? 𝐒(b) = a ⋚? b

-- Equality check
_≡?_ : ℕ → ℕ → Bool
a ≡? b = elim₃ 𝐹 𝑇 𝐹 (a ⋚? b)
{-# BUILTIN NATEQUALS _≡?_ #-}

-- Non-equality check
_≢?_ : ℕ → ℕ → Bool
x ≢? y = !(x ≡? y)

-- Positivity check
positive? : ℕ → Bool
positive? (𝟎)    = 𝐹
positive? (𝐒(_)) = 𝑇

-- Zero check
zero? : ℕ → Bool
zero? n = !(positive? n)

-- Lesser-than check
_<?_ : ℕ → ℕ → Bool
_    <? 𝟎    = 𝐹
𝟎    <? 𝐒(_) = 𝑇
𝐒(x) <? 𝐒(y) = (x <? y)
{-# BUILTIN NATLESS _<?_ #-}

-- Lesser-than or equals check
_≤?_ : ℕ → ℕ → Bool
x ≤? y = x <? 𝐒(y)

-- Greater-than check
_>?_ : ℕ → ℕ → Bool
x >? y = y <? x

-- Greater-than or equals check
_≥?_ : ℕ → ℕ → Bool
x ≥? y = y ≤? x


module LearnYouAn2 where

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

_+_ : ℕ → ℕ → ℕ

zero + n     = n
(suc n) + n′ = suc (n + n′)

data _even : ℕ → Set where
  ZERO : zero even
  STEP : ∀ x → x even → (suc (suc x)) even

-- To prove four is even
proof₁ : suc (suc (suc (suc zero))) even
proof₁ = STEP (suc (suc zero)) (STEP zero ZERO)

proof₂′ : (A : Set) → A → A
proof₂′ _ a = a

proof₂ : ℕ → ℕ
proof₂ = proof₂′ ℕ


module Nat where

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

  one : Nat
  one = suc zero


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

module hott.types.coproduct where

open import hott.core.universe

data _∐_ {ℓ₀ ℓ₁ : Level}
         (A : Type ℓ₀)
         (B : Type ℓ₁) : Type (ℓ₀ ⊔ ℓ₁)  where

     inl : (a : A) → A ∐ B -- left  introduction
     inr : (b : B) → A ∐ B -- right introduction

-- A more suggestive way of building elements of nested co-product
-- types. For example if we have a : A, b : B and c : C then the
-- expressions, a ∣∙, ∙∣ b ∣∙ and ∙∣ ∙∣ c are elements inl a, inr (inl
-- b) and inr (inr c) of A ∐ B ∐ C respectively.

_∣∙ : {ℓ₀ ℓ₁ : Level}{A : Type ℓ₀}{B : Type ℓ₁}
    → A → A ∐ B
_∣∙ = inl

∙∣_ : {ℓ₀ ℓ₁ : Level}{A : Type ℓ₀}{B : Type ℓ₁}
   → B → A ∐ B
∙∣_ = inr

infixr 0 ∙∣_
infixr 0 _∣∙

-- A more suggestive way of building a case by case analysis.
-- For example, one can just write f1 ∣ f2 ∣ f3
_∣_ : {a b c : Level}
      {A : Type a}
      {B : Type b}
      {C : Type c}
    → (A → C)
    → (B → C)
    → (A ∐ B → C)

(f ∣ g) (inl a) = f a
(f ∣ g) (inr b) = g b

infixr 0 _∐_
infixr 0 _∣_

-- Case by case analysis.
either : {ℓ₀ ℓ₁ ℓ₃ : Level}
         {A : Type ℓ₀}{B : Type ℓ₁}{C : Type ℓ₃}
       → (A → C) → (B → C) → (A ∐ B → C)
either f g (inl a) = f a
either f g (inr b) = g b


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

open import Bound.Lower A
open import Bound.Lower.Order _≤_
open import BTree {A} hiding (flatten)
open import Data.Nat hiding (_≤_)
open import Data.List
open import Data.Sum renaming (_⊎_ to _∨_)
open import Relation.Binary
open import Relation.Binary.Core
open import Relation.Binary.PropositionalEquality hiding (trans)

open DecTotalOrder decTotalOrder hiding (refl ; _≤_)

data BHeap : Bound → Set where
  lf : {b : Bound}
                   → BHeap b
  nd : {b : Bound}{x : A}
                   → LeB b (val x)
                   → (l r : BHeap (val x))
                   → BHeap b

forget : {b : Bound} → BHeap b → BTree
forget lf = leaf
forget (nd {x = x} _ l r) = node x (forget l) (forget r)

# : {b : Bound} → BHeap b → ℕ
# lf = zero
# (nd _ l r) = suc (# l + # r)

height : {b : Bound} → BHeap b → ℕ
height lf = zero
height (nd _ l r)
    with total (height l) (height r)
... | inj₁ hl≤hr = suc (height r)
... | inj₂ hr≤hl = suc (height l)

merge : {b : Bound} → Total _≤_ → (l r : BHeap b) → BHeap b
merge _ lf r = r
merge _ l lf = l
merge tot≤ (nd {x = x} b≤x l r) (nd {x = x'} b≤x' l' r')
    with tot≤ x x'
... | inj₁ x≤x' = nd b≤x (merge tot≤ l r) (nd (lexy x≤x') l' r')
... | inj₂ x'≤x = nd b≤x' (nd (lexy x'≤x) l r) (merge tot≤ l' r')

flatten : {b : Bound}(h : BHeap b) → List A
flatten lf = []
flatten (nd {x = x} b≤x l r) = x ∷ (flatten l ++ flatten r)


------------------------------------------------------------------------
-- The Agda standard library
--
-- Some examples showing where the natural numbers and some related
-- operations and properties are defined, and how they can be used
------------------------------------------------------------------------

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

module README.Data.Nat where

-- The natural numbers and various arithmetic operations are defined
-- in Data.Nat.

open import Data.Nat using (ℕ; _+_; _*_)

-- _*_ has precedence 7 over precedence 6 of _+_
-- precedence of both defined in module Agda.Builtin.Nat
ex₁ : ℕ
ex₁ = 1 + 3 * 4

-- Propositional equality and some related properties can be found
-- in Relation.Binary.PropositionalEquality.

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

ex₂ : 3 + 5 ≡ 2 * 4
ex₂ = refl

-- Data.Nat.Properties contains a number of properties about natural
-- numbers.

open import Data.Nat.Properties using (*-comm; +-identityʳ)

ex₃ : ∀ m n → m * n ≡ n * m
ex₃ m n = *-comm m n

-- The module ≡-Reasoning in Relation.Binary.PropositionalEquality
-- provides some combinators for equational reasoning.

open Relation.Binary.PropositionalEquality using (cong; module ≡-Reasoning)

ex₄ : ∀ m n → m * (n + 0) ≡ n * m
ex₄ m n = begin
  m * (n + 0)  ≡⟨ cong (_*_ m) (+-identityʳ n) ⟩
  m * n        ≡⟨ *-comm m n ⟩
  n * m        ∎
  where open ≡-Reasoning

-- The module SemiringSolver in Data.Nat.Solver contains a solver
-- for natural number equalities involving variables, constants, _+_
-- and _*_.

open import Data.Nat.Solver using (module +-*-Solver)
open +-*-Solver using (solve; _:*_; _:+_; con; _:=_)

ex₅ : ∀ m n → m * (n + 0) ≡ n * m
ex₅ = solve 2 (λ m n → m :* (n :+ con 0)  :=  n :* m) refl


module StalinSort where

  import Relation.Binary.PropositionalEquality as Eq
  open Eq using (_≡_; refl)
  open import Data.Nat using (ℕ; _≤_; _≤?_)
  open import Data.List using (List; _∷_; [])
  open import Relation.Nullary using (Dec; yes; no)

  -- Implementation of Stalin Sort
  stalinSort : List ℕ → List ℕ
  stalinSort [] = []
  stalinSort (x ∷ []) = x ∷ []
  stalinSort (x ∷ y ∷ zs) with x ≤? y
  ...| yes m≤n = x ∷ stalinSort (y ∷ zs)
  ...| no m≰n  = stalinSort (x ∷ zs)

  -- Example Test
  _ : stalinSort (2 ∷ 3 ∷ 5 ∷ 4 ∷ 6 ∷ []) ≡ (2 ∷ 3 ∷ 5 ∷ 6 ∷ [])
  _ = refl

  -------------------- Correctness of Stalin Sort -------------------------
  {-
     This section is only interesting for Logic and Formal Verification
     enthusiasts. Although I tried to sketch the formal proof that
     Stalin Sort always returns a Sorted List, there is a point in the proof
     that I couldn't solve yet. I declared it as a postulate, so somebody can
     try improving it by giving an lemma that remove the postulate and
     finish the proof =D
  -}

  -- A proof that x is less than all values in xs (thanks to Twan van Laarhoven)
  data _≤*_ (x : ℕ) : List ℕ → Set where
    []  : x ≤* []
    _∷_ : ∀ {y ys} → (x ≤ y) → y ≤* ys → x ≤* (y ∷ ys)

  -- Proof that a list is sorted (thanks to Twan van Laarhoven)
  data SortedList : List ℕ → Set where
    []  : SortedList []
    _∷_ : ∀ {x xs} → x ≤* xs → SortedList xs → SortedList (x ∷ xs)

  -- This is necessary to prove the correctness, I can't find a way yet ...
  postulate
    less-stalin : ∀ (x y : ℕ) (zs : List ℕ) → x ≤ y → x ≤* stalinSort (y ∷ zs)

  -- Proof that Stalin Sort returns a sorted list
  stalinSort-correctness : ∀ (xs : List ℕ) → SortedList (stalinSort xs)
  stalinSort-correctness [] = []
  stalinSort-correctness (x ∷ []) = [] ∷ []
  stalinSort-correctness (x ∷ y ∷ zs) with x ≤? y
  ...| yes m≤n = less-stalin x y zs m≤n ∷ (stalinSort-correctness (y ∷ zs))
  ...| no m≰n  = stalinSort-correctness (x ∷ zs)


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

open import LogicalFormulae
open import Setoids.Setoids
open import Functions.Definition
open import Functions.Lemmas
open import Agda.Primitive using (Level; lzero; lsuc; _⊔_)
open import Numbers.Naturals.Semiring
open import Numbers.Naturals.Order
open import Numbers.Integers.Integers
open import Numbers.Rationals.Definition
open import Sets.FinSet.Definition
open import Sets.FinSet.Lemmas
open import Sets.Cardinality.Finite.Definition
open import Groups.Definition
open import Groups.Groups
open import Groups.Abelian.Definition
open import Groups.FiniteGroups.Definition
open import Rings.Definition
open import Numbers.Modulo.Group
open import Numbers.Modulo.Definition
open import Semirings.Definition

module Groups.LectureNotes.Lecture1 where

ℤIsGroup : _
ℤIsGroup = ℤGroup

ℚIsGroup : _
ℚIsGroup = Ring.additiveGroup ℚRing

-- TODO: R is a group with +

integersMinusNotGroup : Group (reflSetoid ℤ) (_-Z_) → False
integersMinusNotGroup record { +WellDefined = wellDefined ; 0G = identity ; inverse = inverse ; +Associative = multAssoc ; identRight = multIdentRight ; identLeft = multIdentLeft ; invLeft = invLeft ; invRight = invRight } with multAssoc {nonneg 3} {nonneg 2} {nonneg 1}
integersMinusNotGroup record { +WellDefined = wellDefined ; 0G = identity ; inverse = inverse ; +Associative = multAssoc ; identRight = multIdentRight ; identLeft = multIdentLeft ; invLeft = invLeft ; invRight = invRight } | ()

negSuccInjective : {a b : ℕ} → (negSucc a ≡ negSucc b) → a ≡ b
negSuccInjective {a} {.a} refl = refl

nonnegInjective : {a b : ℕ} → (nonneg a ≡ nonneg b) → a ≡ b
nonnegInjective {a} {.a} refl = refl

integersTimesNotGroup : Group (reflSetoid ℤ) (_*Z_) → False
integersTimesNotGroup record { +WellDefined = wellDefined ; 0G = (nonneg zero) ; inverse = inverse ; +Associative = multAssoc ; identRight = multIdentRight ; identLeft = multIdentLeft ; invLeft = invLeft ; invRight = invRight } with multIdentLeft {negSucc 1}
... | ()
integersTimesNotGroup record { +WellDefined = wellDefined ; 0G = (nonneg (succ zero)) ; inverse = inverse ; +Associative = multAssoc ; identRight = multIdentRight ; identLeft = multIdentLeft ; invLeft = invLeft ; invRight = invRight } with invLeft {nonneg zero}
... | bl with inverse (nonneg zero)
integersTimesNotGroup record { +WellDefined = wellDefined ; 0G = (nonneg (succ zero)) ; inverse = inverse ; +Associative = multAssoc ; identRight = multIdentRight ; identLeft = multIdentLeft ; invLeft = invLeft ; invRight = invRight } | () | nonneg zero
integersTimesNotGroup record { +WellDefined = wellDefined ; 0G = (nonneg (succ zero)) ; inverse = inverse ; +Associative = multAssoc ; identRight = multIdentRight ; identLeft = multIdentLeft ; invLeft = invLeft ; invRight = invRight } | p | nonneg (succ x) = naughtE (nonnegInjective (transitivity (applyEquality nonneg (equalityCommutative (Semiring.productZeroRight ℕSemiring x))) p))
integersTimesNotGroup record { +WellDefined = wellDefined ; 0G = (nonneg (succ zero)) ; inverse = inverse ; +Associative = multAssoc ; identRight = multIdentRight ; identLeft = multIdentLeft ; invLeft = invLeft ; invRight = invRight } | () | negSucc x
integersTimesNotGroup record { +WellDefined = wellDefined ; 0G = (nonneg (succ (succ x))) ; inverse = inverse ; +Associative = multAssoc ; identRight = multIdentRight ; identLeft = multIdentLeft ; invLeft = invLeft ; invRight = invRight } with succInjective (negSuccInjective (multIdentLeft {negSucc 1}))
... | ()
integersTimesNotGroup record { +WellDefined = wellDefined ; 0G = (negSucc x) ; inverse = inverse ; +Associative = multAssoc ; identRight = multIdentRight ; identLeft = multIdentLeft ; invLeft = invLeft ; invRight = invRight } with multIdentLeft {nonneg 2}
integersTimesNotGroup record { +WellDefined = wellDefined ; 0G = (negSucc x) ; inverse = inverse ; +Associative = multAssoc ; identRight = multIdentRight ; identLeft = multIdentLeft ; invLeft = invLeft ; invRight = invRight } | ()

-- TODO: Q is not a group with *Q
-- TODO: Q without 0 is a group with *Q
-- TODO: {1, -1} is a group with *

ℤnIsGroup : (n : ℕ) → (0<n : 0 <N n) → _
ℤnIsGroup n pr = ℤnGroup n pr

-- Groups example 8.9 from lecture 1
data Weird : Set where
  e : Weird
  a : Weird
  b : Weird
  c : Weird

_+W_ : Weird → Weird → Weird
e +W t = t
a +W e = a
a +W a = e
a +W b = c
a +W c = b
b +W e = b
b +W a = c
b +W b = e
b +W c = a
c +W e = c
c +W a = b
c +W b = a
c +W c = e

+WAssoc : {x y z : Weird} → (x +W (y +W z)) ≡ (x +W y) +W z
+WAssoc {e} {y} {z} = refl
+WAssoc {a} {e} {z} = refl
+WAssoc {a} {a} {e} = refl
+WAssoc {a} {a} {a} = refl
+WAssoc {a} {a} {b} = refl
+WAssoc {a} {a} {c} = refl
+WAssoc {a} {b} {e} = refl
+WAssoc {a} {b} {a} = refl
+WAssoc {a} {b} {b} = refl
+WAssoc {a} {b} {c} = refl
+WAssoc {a} {c} {e} = refl
+WAssoc {a} {c} {a} = refl
+WAssoc {a} {c} {b} = refl
+WAssoc {a} {c} {c} = refl
+WAssoc {b} {e} {z} = refl
+WAssoc {b} {a} {e} = refl
+WAssoc {b} {a} {a} = refl
+WAssoc {b} {a} {b} = refl
+WAssoc {b} {a} {c} = refl
+WAssoc {b} {b} {e} = refl
+WAssoc {b} {b} {a} = refl
+WAssoc {b} {b} {b} = refl
+WAssoc {b} {b} {c} = refl
+WAssoc {b} {c} {e} = refl
+WAssoc {b} {c} {a} = refl
+WAssoc {b} {c} {b} = refl
+WAssoc {b} {c} {c} = refl
+WAssoc {c} {e} {z} = refl
+WAssoc {c} {a} {e} = refl
+WAssoc {c} {a} {a} = refl
+WAssoc {c} {a} {b} = refl
+WAssoc {c} {a} {c} = refl
+WAssoc {c} {b} {e} = refl
+WAssoc {c} {b} {a} = refl
+WAssoc {c} {b} {b} = refl
+WAssoc {c} {b} {c} = refl
+WAssoc {c} {c} {e} = refl
+WAssoc {c} {c} {a} = refl
+WAssoc {c} {c} {b} = refl
+WAssoc {c} {c} {c} = refl

weirdGroup : Group (reflSetoid Weird) _+W_
Group.+WellDefined weirdGroup = reflGroupWellDefined
Group.0G weirdGroup = e
Group.inverse weirdGroup t = t
Group.+Associative weirdGroup {r} {s} {t} = +WAssoc {r} {s} {t}
Group.identRight weirdGroup {e} = refl
Group.identRight weirdGroup {a} = refl
Group.identRight weirdGroup {b} = refl
Group.identRight weirdGroup {c} = refl
Group.identLeft weirdGroup {e} = refl
Group.identLeft weirdGroup {a} = refl
Group.identLeft weirdGroup {b} = refl
Group.identLeft weirdGroup {c} = refl
Group.invLeft weirdGroup {e} = refl
Group.invLeft weirdGroup {a} = refl
Group.invLeft weirdGroup {b} = refl
Group.invLeft weirdGroup {c} = refl
Group.invRight weirdGroup {e} = refl
Group.invRight weirdGroup {a} = refl
Group.invRight weirdGroup {b} = refl
Group.invRight weirdGroup {c} = refl

weirdAb : AbelianGroup weirdGroup
AbelianGroup.commutative weirdAb {e} {e} = refl
AbelianGroup.commutative weirdAb {e} {a} = refl
AbelianGroup.commutative weirdAb {e} {b} = refl
AbelianGroup.commutative weirdAb {e} {c} = refl
AbelianGroup.commutative weirdAb {a} {e} = refl
AbelianGroup.commutative weirdAb {a} {a} = refl
AbelianGroup.commutative weirdAb {a} {b} = refl
AbelianGroup.commutative weirdAb {a} {c} = refl
AbelianGroup.commutative weirdAb {b} {e} = refl
AbelianGroup.commutative weirdAb {b} {a} = refl
AbelianGroup.commutative weirdAb {b} {b} = refl
AbelianGroup.commutative weirdAb {b} {c} = refl
AbelianGroup.commutative weirdAb {c} {e} = refl
AbelianGroup.commutative weirdAb {c} {a} = refl
AbelianGroup.commutative weirdAb {c} {b} = refl
AbelianGroup.commutative weirdAb {c} {c} = refl

weirdProjection : Weird → FinSet 4
weirdProjection a = ofNat 0 (le 3 refl)
weirdProjection b = ofNat 1 (le 2 refl)
weirdProjection c = ofNat 2 (le 1 refl)
weirdProjection e = ofNat 3 (le zero refl)

weirdProjectionSurj : Surjection weirdProjection
weirdProjectionSurj fzero = a , refl
weirdProjectionSurj (fsucc fzero) = b , refl
weirdProjectionSurj (fsucc (fsucc fzero)) = c , refl
weirdProjectionSurj (fsucc (fsucc (fsucc fzero))) = e , refl
weirdProjectionSurj (fsucc (fsucc (fsucc (fsucc ()))))

weirdProjectionInj : (x y : Weird) → weirdProjection x ≡ weirdProjection y → Setoid._∼_ (reflSetoid Weird) x y
weirdProjectionInj e e fx=fy = refl
weirdProjectionInj e a ()
weirdProjectionInj e b ()
weirdProjectionInj e c ()
weirdProjectionInj a e ()
weirdProjectionInj a a fx=fy = refl
weirdProjectionInj a b ()
weirdProjectionInj a c ()
weirdProjectionInj b e ()
weirdProjectionInj b a ()
weirdProjectionInj b b fx=fy = refl
weirdProjectionInj b c ()
weirdProjectionInj c e ()
weirdProjectionInj c a ()
weirdProjectionInj c b ()
weirdProjectionInj c c fx=fy = refl

weirdFinite : FiniteGroup weirdGroup (FinSet 4)
SetoidToSet.project (FiniteGroup.toSet weirdFinite) = weirdProjection
SetoidToSet.wellDefined (FiniteGroup.toSet weirdFinite) x y = applyEquality weirdProjection
SetoidToSet.surj (FiniteGroup.toSet weirdFinite) = weirdProjectionSurj
SetoidToSet.inj (FiniteGroup.toSet weirdFinite) = weirdProjectionInj
FiniteSet.size (FiniteGroup.finite weirdFinite) = 4
FiniteSet.mapping (FiniteGroup.finite weirdFinite) = id
FiniteSet.bij (FiniteGroup.finite weirdFinite) = idIsBijective

weirdOrder : groupOrder weirdFinite ≡ 4
weirdOrder = refl

-- TODO: dihedral groups
-- TODO: matrix groups on R
-- TODO: general linear groups on R


module Data.Vec.Membership where

open import Data.Vec as Vec
open import Data.Vec.Any
open import Data.Vec.Any.Membership.Propositional
open import Data.Product as Prod hiding (map)
open import Function using (_∘_; id)

find : ∀ {a p}{A : Set a}{P : A → Set p}{n}{xs : Vec A n} →
  Any P xs → ∃ λ x → x ∈ xs × P x
-- find = Prod.map id (Prod.map ∈′→∈ id) ∘ find′
find (here px) = , here , px
find (there p) = Prod.map id (Prod.map there id) (find p)

lose : ∀ {a p}{A : Set a}{P : A → Set p}{n x}{xs : Vec A n} →
  x ∈ xs → P x → Any P xs
lose = lose′ ∘ ∈→∈′

open import Function.Related as Related public using (Kind; Symmetric-kind)
            renaming (implication to subset
              ;  reverse-implication to superset
              ;  equivalence to set
              ;  injection to subbag
              ;  reverse-injection to superbag
              ;  bijection to bag)

_∼[_]_ : ∀ {a m n}{A : Set a} → Vec A m → Kind → Vec A n → Set _
xs ∼[ k ] ys = ∀ {x} → (x ∈ xs) Related.∼[ k ] (x ∈ ys)


{-# OPTIONS --sized-types #-}
module SList.Order {A : Set}(_≤_ : A → A → Set) where

open import List.Sorted _≤_
open import Size
open import SList

data _*≤_ : {ι : Size} → A → SList A {ι} → Set where
  genx : {ι : Size}{b : A}
                   → (_*≤_) {↑ ι} b snil
  gecx : {ι : Size}{b x : A}{xs : SList A {ι}}
                   → b ≤ x
                   → b *≤ xs
                   → b *≤ (x ∙ xs)

data _≤*_ : {ι : Size} → SList A {ι} → A → Set where
  lenx : {ι : Size}{t : A}
                   → (_≤*_) {↑ ι} snil t
  lecx : {ι : Size}{x t : A}{xs : SList A {ι}}
                   → x ≤ t
                   → xs ≤* t
                   → (x ∙ xs) ≤* t


import Relation.Binary.PropositionalEquality as Eq
open Eq using (_≡_; refl; sym; trans; cong)
open Eq.≡-Reasoning
open import Data.Nat using (ℕ; zero; suc; _+_; _*_)
open import Data.Nat.Properties.Simple using (+-suc)
open import Data.Product using (∃; ∃-syntax; _,_)

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

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

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

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

∃-even : ∀ {n : ℕ} → even n → ∃[ m ] (2 * m ≡ n)
∃-odd  : ∀ {n : ℕ} →  odd n → ∃[ m ] (1 + 2 * m ≡ n)

∃-even even-zero =  zero , refl
∃-even (even-suc o) with ∃-odd o
...                    | m , refl = suc m , lemma m

∃-odd  (odd-suc e)  with ∃-even e
...                    | m , refl = m , refl

∃-even′ : ∀ {n : ℕ} → even n → ∃[ m ] (n ≡ 2 * m)
∃-odd′  : ∀ {n : ℕ} →  odd n → ∃[ m ] (n ≡ 1 + 2 * m)

∃-even′ even-zero =  zero , refl
∃-even′ (even-suc o) with ∃-odd′ o
...                     | m , eqn rewrite eqn | +-suc m (m + 0) = suc m , {!!}

∃-odd′  (odd-suc e)  with ∃-even′ e
...                     | m , eqn rewrite eqn = m , refl

data Even : ℕ → Set where
  ev0 : Even zero
  ev2 : ∀ {n} → Even n → Even (suc (suc n))

ev-ex : ∀ {n : ℕ} → Even n → ∃[ m ] (2 * m ≡ n)
ev-ex ev0 =  (zero , refl)
ev-ex (ev2 ev) with ev-ex ev
... | (m , refl) = (suc m , lemma m)


module algebra where

open import Relation.Binary.PropositionalEquality
open ≡-Reasoning

-- Goals are written as normalised

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

_+_ : ℕ → ℕ → ℕ
zero + y = y
suc x + y = suc (x + y)

record Semigroup (a : Set) : Set where
  field
    _⊛_ : a → a → a
    assoc : ∀ a b c → (a ⊛ b) ⊛ c ≡ a ⊛ (b ⊛ c)

record Monoid (a : Set) : Set where
  field
    semigroup : Semigroup a
  open Semigroup semigroup
  field
    e : a
    idl : ∀ a → e ⊛ a ≡ a
    idr : ∀ a → a ⊛ e ≡ a

record Group (a : Set) : Set where
  field
    monoid : Monoid a
  open Monoid monoid
  open Semigroup semigroup
  field
  -- TODO [aerben] fix this
    invl : ∀ a ∃ b → a ⊛ b ≡ e
    invr : ∀ a ∃ b → b ⊛ a ≡ e

record AbelianGroup (a : Set) : Set where
  field
    group : Group a
  open Group group
  open Monoid monoid
  open Semigroup semigroup
  field
    commutative : ∀ a b → a ⊛ b ≡ b ⊛ a

record CommutativeSemigroup (a : Set) : Set where
  field
    _⊛_ : a → a → a
    associative : ∀ a b c → (a ⊛ b) ⊛ c ≡ a ⊛ (b ⊛ c)
    commutative : ∀ a b → a ⊛ b ≡ b ⊛ a

plusAssociative : ∀ a b c -> (a + b) + c ≡ a + (b + c)
-- Goal: (b + c) ≡ (b + c)
-- Follows from reflexivity
plusAssociative zero b c = refl
-- Goal: suc ((a + b) + c) ≡ suc (a + (b + c))
-- Inductive step
-- Follows from induction assumption and congruence
plusAssociative (suc a) b c =
  begin
    suc ((a + b) + c)
  ≡⟨ cong suc (plusAssociative a b c) ⟩
    suc (a + (b + c))
  ∎

plusCommutativeLemma : ∀ a b -> a + suc b ≡ suc (a + b)
-- Goal: suc b ≡ suc b
-- Follows from reflexivity
plusCommutativeLemma zero b = refl
-- Goal: suc (a + suc b) ≡ suc (suc (a + b))
-- Inductive step
-- Follows from induction assumption and congruence
plusCommutativeLemma (suc a) b =
  begin
    suc (a + suc b)
  ≡⟨ cong suc (plusCommutativeLemma a b) ⟩
    suc (suc (a + b))
  ∎

plusCommutative : ∀ a b -> a + b ≡ b + a
-- Goal: zero ≡ zero
-- Follows from reflexivity
plusCommutative zero zero = refl
-- Goal: suc (a + zero) ≡ suc a
-- One-sided inductive step
-- Follows from induction assumption and congruence
plusCommutative (suc a) zero =
  begin
    suc (a + zero)
  ≡⟨ cong suc (plusCommutative a zero) ⟩
    suc a
  ∎
-- Goal: suc b ≡ suc (b + zero)
-- One-sided inductive step
-- Follows from induction assumption and congruence
plusCommutative zero (suc b) =
  begin
    suc b
  ≡⟨ cong suc (plusCommutative zero b) ⟩
    suc (b + zero)
  ∎
-- plusCommutative (suc a) (suc b) rewrite plusCommutativeAux a b | plusCommutativeAux b a = cong suc (cong suc (plusCommutative a b))
-- Goal: suc (a + suc b) ≡ suc (b + suc a)
plusCommutative (suc a) (suc b) =
  begin
    suc (a + suc b)
  ≡⟨ cong suc (plusCommutativeLemma a b) ⟩
    suc (suc (a + b))
  ≡⟨ cong suc (cong suc (plusCommutative a b)) ⟩
    suc (suc (b + a))
    -- Need to invoke symmetry since definitional equivalence does not guarantee it
  ≡⟨ cong suc (sym (plusCommutativeLemma b a)) ⟩
    suc (b + suc a)
  ∎

plusSemigroup : CommutativeSemigroup ℕ
plusSemigroup = record
  { _⊛_ = _+_
  ; associative = plusAssociative
  ; commutative = plusCommutative
  }


module bool where

------------------------
-- Datatypes
------------------------
data 𝔹 : Set where
  true  : 𝔹
  false : 𝔹

----------------------
-- AND
----------------------
infixr 6 _∧_
_∧_ : 𝔹 → 𝔹 → 𝔹
true  ∧ b  = b
false ∧ b = false

---------------------
-- OR
---------------------
infixr 5 _∨_
_∨_ : 𝔹 → 𝔹 → 𝔹
true  ∨ b = true
false ∨ b = b

--------------------
-- NEFATION
--------------------
infixr 7 ¬_
¬_ : 𝔹 → 𝔹
¬ true  = false
¬ false = true


module Data.Vec.Any.Membership.Propositional  where
  open import Relation.Binary.PropositionalEquality
  open import Data.Vec
  open import Data.Vec.Any hiding (map)
  open import Function.Inverse using (_↔_)
  open import Function using (_∘_)
  open import Data.Nat
  open import Data.Product hiding (map)
  import Data.Vec.Any.Membership as Mem
  open import Function.Related using (↔⇒)
  module _ {a} {A : Set a} where
    private module M = Mem (setoid A)
    open M public hiding (lose′)

    ∈′→∈ : ∀ {n x}{xs : Vec A n} → x ∈′ xs → x ∈ xs
    ∈′→∈ {xs = .(_ ∷ _)} (here refl) = here
    ∈′→∈ {xs = .(_ ∷ _)} (there p) = there (∈′→∈ p)

    ∈→∈′ : ∀ {n x}{xs : Vec A n} → x ∈ xs → x ∈′ xs
    ∈→∈′ {xs = .(_ ∷ _)} here = here refl
    ∈→∈′ {xs = .(_ ∷ _)} (there p) = there (∈→∈′ p)

    ∈↔∈′ : ∀ {n x}{xs : Vec A n} → x ∈ xs ↔ x ∈′ xs
    ∈↔∈′ = record {
         to = →-to-⟶ ∈→∈′
         ; from =  →-to-⟶ ∈′→∈
         ; inverse-of = record {
             left-inverse-of = left-inverse
           ; right-inverse-of = right-inverse
         }
         }
         where
           left-inverse : ∀ {n x}{xs : Vec A n}(p : x ∈ xs) → ∈′→∈ (∈→∈′ p) ≡ p
           left-inverse {xs = .(_ ∷ _)} here = refl
           left-inverse {xs = .(_ ∷ _)} (there p) = cong there (left-inverse p)

           right-inverse : ∀ {n x}{xs : Vec A n}(p : x ∈′ xs) → ∈→∈′ (∈′→∈ p) ≡ p
           right-inverse {xs = .(_ ∷ _)} (here refl) = refl
           right-inverse {xs = .(_ ∷ _)} (there p) = cong there (right-inverse p)

    ∈′→∈-there : ∀ {n x}{xs : Vec A n}(x∈′xs : x ∈′ xs) → ∈′→∈ (there {x = x} x∈′xs) ≡ there (∈′→∈ x∈′xs)
    ∈′→∈-there (here refl) = refl
    ∈′→∈-there (there p) rewrite ∈′→∈-there p = refl

    lose′ : ∀ {p}{P : A → Set p} {n x} {xs : Vec A n} →
      x ∈′ xs → P x → Any P xs
    lose′ {P = P} = M.lose′ (subst P)

  open import Function.Related as Related public using (Kind; Symmetric-kind)
              renaming (implication to subset
                     ;  reverse-implication to superset
                     ;  equivalence to set
                     ;  injection to subbag
                     ;  reverse-injection to superbag
                     ;  bijection to bag)
  infix 4 _∼[_]_
  _∼[_]_ : ∀ {a m n}{A : Set a} → Vec A m → Kind → Vec A n → Set _
  xs ∼[ k ] ys = ∀ {x} → (x ∈′ xs) Related.∼[ k ] (x ∈′ ys)

  bag-=⇒ : ∀ {k a m n} {A : Set a} {xs : Vec A m} {ys : Vec A n} →
           xs ∼[ bag ] ys → xs ∼[ k ] ys
  bag-=⇒ xs≈ys = ↔⇒ xs≈ys


module Examples where

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

data Bool : Set where
  true  : Bool
  false : Bool

if_then_else_ : {A : Set} -> Bool -> A -> A -> A
if true  then x else y = x
if false then x else y = y

not : Bool -> Bool
not x = if x then false else true

isZero : Nat -> Bool
isZero zero    = true
isZero (suc _) = false

F : Bool -> Set
F true  = Nat
F false = Bool

f : (x : Bool) -> F x -> F (not x)
f true n  = isZero n
f false b = if b then zero else suc zero

test : Bool
test = f ? zero


{-# OPTIONS --sized-types #-}
module SList.Order.Properties {A  : Set}(_≤_ : A → A → Set) where

open import List.Sorted _≤_
open import Size
open import SList
open import SList.Order _≤_

lemma-slist-sorted : {ι : Size}{x : A}{xs : SList A {ι}} → x *≤ xs → Sorted (unsize A xs) → Sorted (unsize A (x ∙ xs))
lemma-slist-sorted {x = x} genx nils = singls x
lemma-slist-sorted (gecx x≤y genx) (singls y) = conss x≤y (singls y)
lemma-slist-sorted (gecx x≤y x*≤zys ) syzys = conss x≤y syzys

lemma-sorted⊕ : {ι : Size}{x : A}{xs : SList A {ι}} → xs ≤* x → Sorted (unsize A xs) → Sorted (unsize A (_⊕_ A xs (x ∙ snil)))
lemma-sorted⊕ {x = x} {xs = snil} _ nils = singls x
lemma-sorted⊕ {x = x} {xs = y ∙ snil} (lecx y≤x _) (singls .y)  = conss y≤x (singls x)
lemma-sorted⊕ {xs = y ∙ (z ∙ ys)} (lecx y≤x zys≤*x) (conss y≤z szys) = conss y≤z (lemma-sorted⊕ zys≤*x szys)

lemma-⊕≤* : {ι : Size}{x t : A}{xs : SList A {ι}} → x ≤ t → xs ≤* t → (_⊕_ A xs (x ∙ snil)) ≤* t
lemma-⊕≤* x≤t lenx = lecx x≤t lenx
lemma-⊕≤* x≤t (lecx y≤t ys≤*t) = lecx y≤t (lemma-⊕≤* x≤t ys≤*t)


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

open import Categories.Category

module Categories.Category.Instance.Simplex where

open import Level
open import Data.Product
open import Data.Fin.Base using (Fin; _≤_)
open import Data.Nat.Base using (ℕ; z≤n; s≤s)
open import Function renaming (id to idF; _∘_ to _∙_)

open import Relation.Binary using (_=[_]⇒_)
open import Relation.Binary.PropositionalEquality

Δ : Category 0ℓ 0ℓ 0ℓ
Δ = record
  { Obj       = ℕ
  ; _⇒_       = λ m n → Σ (Fin m → Fin n) (λ f → _≤_ =[ f ]⇒ _≤_)
  ; _≈_       = λ { (f , mf) (g , mg) → ∀ x → f x ≡ g x }
  ; id        = idF , idF
  ; _∘_       = λ { (f , mf) (g , mg) → f ∙ g , mf ∙ mg }
  ; assoc     = λ _ → refl
  ; sym-assoc = λ _ → refl
  ; identityˡ = λ _ → refl
  ; identityʳ = λ _ → refl
  ; identity² = λ _ → refl
  ; equiv     = record
    { refl  = λ _ → refl
    ; sym   = λ eq x → sym (eq x)
    ; trans = λ eq₁ eq₂ x → trans (eq₁ x) (eq₂ x)
    }
  ; ∘-resp-≈  = λ {_ _ _ f g h i} eq₁ eq₂ x → trans (cong (λ t → proj₁ f t) (eq₂ x)) (eq₁ (proj₁ i x))
  }

open Category Δ

--------------------------------------------------------------------------------
-- Face + Degeneracy Maps

face-map : ∀ {n} → Fin (ℕ.suc n) → Fin n → Fin (ℕ.suc n)
face-map Fin.zero    k           = Fin.suc k
face-map (Fin.suc i) Fin.zero    = Fin.zero
face-map (Fin.suc i) (Fin.suc k) = Fin.suc (face-map i k)

face-mono : ∀ {n} → (i : Fin (ℕ.suc n)) → _≤_ =[ face-map i ]⇒ _≤_
face-mono Fin.zero    {_}         {_}         le       = s≤s le
face-mono (Fin.suc i) {Fin.zero}  {_}         _        = z≤n
face-mono (Fin.suc i) {Fin.suc _} {Fin.suc _} (s≤s le) = s≤s (face-mono i le)

face : ∀ {n} → Fin (ℕ.suc n) → n ⇒ ℕ.suc n
face i = face-map i , face-mono i

degeneracy-map : ∀ {n} → Fin n → Fin (ℕ.suc n) → Fin n
degeneracy-map Fin.zero    Fin.zero    = Fin.zero
degeneracy-map Fin.zero    (Fin.suc k) = k
degeneracy-map (Fin.suc i) Fin.zero    = Fin.zero
degeneracy-map (Fin.suc i) (Fin.suc k) = Fin.suc (degeneracy-map i k)

degeneracy-mono : ∀ {n} → (i : Fin n) → _≤_ =[ degeneracy-map i ]⇒ _≤_
degeneracy-mono Fin.zero    {Fin.zero}  {_}         _        = z≤n
degeneracy-mono Fin.zero    {Fin.suc _} {Fin.suc _} (s≤s le) = le
degeneracy-mono (Fin.suc i) {Fin.zero}  {_}         _        = z≤n
degeneracy-mono (Fin.suc i) {Fin.suc _} {Fin.suc _} (s≤s le) = s≤s (degeneracy-mono i le)

degeneracy : ∀ {n} → Fin n → ℕ.suc n ⇒ n
degeneracy i = degeneracy-map i , degeneracy-mono i


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

open import List.Permutation.Base A
open import List.Permutation.Base.Equivalence A
open import List.Permutation.Base.Preorder A
open import Data.List
open import Data.Product
open import Relation.Binary.PreorderReasoning ∼-preorder
open import Algebra
open import Algebra.Structures

lemma++/r : {x : A}{xs ys xs' : List A} → (xs / x ⟶ xs') → (xs ++ ys) / x ⟶ (xs' ++ ys)
lemma++/r /head = /head
lemma++/r (/tail xs/x⟶xs') = /tail (lemma++/r xs/x⟶xs')

lemma++/l : {y : A}{xs ys ys' : List A} → (ys / y ⟶ ys') → (xs ++ ys) / y ⟶ (xs ++ ys')
lemma++/l {xs = []} ys/y⟶ys' = ys/y⟶ys'
lemma++/l {xs = x ∷ xs} ys/y⟶ys' = /tail (lemma++/l {xs = xs} ys/y⟶ys')

lemma++/ : {y : A}{xs ys : List A} → (xs ++ y ∷ ys) / y ⟶ (xs ++ ys)
lemma++/ {xs = xs} = lemma++/l {xs = xs} /head

lemma++∼r : {xs xs' ys : List A} →  xs ∼ xs' → (xs ++ ys) ∼ (xs' ++ ys)
lemma++∼r {xs} {xs'} {[]} xs∼xs'
                   rewrite ((proj₂ (IsMonoid.identity (Monoid.isMonoid (monoid A)))) xs)
                            | ((proj₂ (IsMonoid.identity (Monoid.isMonoid (monoid A)))) xs') = xs∼xs'
lemma++∼r {xs} {xs'} {y ∷ ys} xs∼xs' =  ∼x (lemma++/ {y} {xs} {ys}) (lemma++/ {y} {xs'} {ys}) (lemma++∼r xs∼xs')

lemma++∼l : {xs ys ys' : List A} →  ys ∼  ys' → (xs ++ ys) ∼ (xs ++ ys')
lemma++∼l {xs = []} ys∼ys' = ys∼ys'
lemma++∼l {xs = x ∷ xs} ys∼ys' = ∼x /head /head (lemma++∼l {xs = xs} ys∼ys')

lemma++∼ : {xs ys xs' ys' : List A} →  xs ∼  xs' →  ys ∼ ys' → (xs ++ ys) ∼ (xs' ++ ys')
lemma++∼ {xs} {ys} {xs'} {ys'} xs∼xs' ys∼ys'
  = begin
     xs ++ ys
     ∼⟨ lemma++∼r xs∼xs'  ⟩
     xs' ++ ys
     ∼⟨ lemma++∼l {xs = xs'} ys∼ys'  ⟩
     xs' ++ ys'
    ∎


module AnyBoolean where
open import Data.Bool
open import Data.Nat
open import Data.List hiding (any)
open import Relation.Binary.PropositionalEquality

even : ℕ → Bool
even zero = true
even (suc zero) = false
even (suc (suc n)) = even n

test-6-even : even 6 ≡ true
test-6-even = refl

odd : ℕ → Bool
odd zero = false
odd (suc zero) = true
odd (suc (suc n)) = odd n

test-5-odd : odd 5 ≡ true
test-5-odd = refl

any : {A : Set} → (A → Bool) → List A → Bool
any _ [] = false
any p (x ∷ xs) with p x
... | true = true
... | false = any p xs

test-any-even-true :
  any even (3 ∷ 6 ∷ 9 ∷ []) ≡ true
test-any-even-true = refl

test-any-even-false :
  any even (3 ∷ 7 ∷ 9 ∷ []) ≡ false
test-any-even-false = refl

test-any-odd-true :
  any odd (4 ∷ 7 ∷ 10 ∷ []) ≡ true
test-any-odd-true = refl

test-any-odd-false :
  any odd (4 ∷ 8 ∷ 10 ∷ []) ≡ false
test-any-odd-false = refl


module Prelude.Nat.Properties where

open import Prelude.Bool
open import Prelude.Nat.Core
open import Prelude.Equality
open import Prelude.Semiring

suc-inj : ∀ {n m} → suc n ≡ suc m → n ≡ m
suc-inj refl = refl

--- Addition ---

add-zero-r : (n : Nat) → n + 0 ≡ n
add-zero-r zero    = refl
add-zero-r (suc n) = suc $≡ add-zero-r n

add-suc-r : (n m : Nat) → n + suc m ≡ suc (n + m)
add-suc-r zero    m = refl
add-suc-r (suc n) m = suc $≡ add-suc-r n m

add-commute : (a b : Nat) → a + b ≡ b + a
add-commute zero    b = sym (add-zero-r _)
add-commute (suc a) b = suc $≡ add-commute a b ⟨≡⟩ʳ add-suc-r b _

add-assoc : (a b c : Nat) → a + (b + c) ≡ a + b + c
add-assoc zero    b c = refl
add-assoc (suc a) b c = suc $≡ add-assoc a b c

add-inj₂ : (a b c : Nat) → a + b ≡ a + c → b ≡ c
add-inj₂ zero    b c eq = eq
add-inj₂ (suc a) b c eq = add-inj₂ a b c (suc-inj eq)

add-inj₁ : (a b c : Nat) → a + c ≡ b + c → a ≡ b
add-inj₁ a b c eq = add-inj₂ c a b (add-commute c a ⟨≡⟩ eq ⟨≡⟩ add-commute b c)

--- Subtraction ---

--- Multiplication ---

mul-one-r : (x : Nat) → x * 1 ≡ x
mul-one-r zero    = refl
mul-one-r (suc x) = suc $≡ mul-one-r x

mul-zero-r : (x : Nat) → x * 0 ≡ 0
mul-zero-r zero    = refl
mul-zero-r (suc x) = mul-zero-r x

mul-distr-r : (x y z : Nat) → (x + y) * z ≡ x * z + y * z
mul-distr-r zero    y z = refl
mul-distr-r (suc x) y z = z +_ $≡ mul-distr-r x y z ⟨≡⟩ add-assoc z _ _

private
  shuffle : (a b c d : Nat) → a + b + (c + d) ≡ a + c + (b + d)
  shuffle a b c d = add-assoc a _ _ ʳ⟨≡⟩
                    a +_ $≡ (add-assoc b c d ⟨≡⟩ _+ d $≡ add-commute b c ⟨≡⟩ʳ add-assoc c b d) ⟨≡⟩
                    add-assoc a _ _

mul-distr-l : (x y z : Nat) → x * (y + z) ≡ x * y + x * z
mul-distr-l zero    y z = refl
mul-distr-l (suc x) y z = y + z +_ $≡ mul-distr-l x y z ⟨≡⟩ shuffle y z (x * y) (x * z)

mul-assoc : (x y z : Nat) → x * (y * z) ≡ x * y * z
mul-assoc zero    y z = refl
mul-assoc (suc x) y z = y * z +_ $≡ mul-assoc x y z ⟨≡⟩ʳ mul-distr-r y (x * y) z

mul-commute : (x y : Nat) → x * y ≡ y * x
mul-commute x zero    = mul-zero-r x
mul-commute x (suc y) = mul-distr-l x 1 y ⟨≡⟩ _+ x * y $≡ mul-one-r x ⟨≡⟩ x +_ $≡ mul-commute x y

mul-inj₁ : (x y z : Nat) {{_ : NonZero z}} → x * z ≡ y * z → x ≡ y
mul-inj₁ x        y      zero {{}}
mul-inj₁ zero     zero   (suc z) eq = refl
mul-inj₁ zero    (suc y) (suc z) ()
mul-inj₁ (suc x) zero    (suc z) ()
mul-inj₁ (suc x) (suc y) (suc z) eq = suc $≡ mul-inj₁ x y (suc z) (add-inj₂ z _ _ (suc-inj eq))

mul-inj₂ : (x y z : Nat) {{_ : NonZero x}} → x * y ≡ x * z → y ≡ z
mul-inj₂ x y z eq = mul-inj₁ y z x (mul-commute y x ⟨≡⟩ eq ⟨≡⟩ mul-commute x z)


open import Relation.Binary.Core

module PLRTree.Insert {A : Set}
                     (_≤_ : A → A → Set)
                     (tot≤ : Total _≤_) where

open import Data.Sum
open import PLRTree {A}

insert : A → PLRTree → PLRTree
insert x leaf = node perfect x leaf leaf
insert x (node perfect y l r)
    with tot≤ x y | l | r
... | inj₁ x≤y | leaf | leaf = node right x (node perfect y leaf leaf) leaf
... | inj₁ x≤y | _ | _ = node left x (insert y l) r
... | inj₂ y≤x | leaf | leaf = node right y (node perfect x leaf leaf) leaf
... | inj₂ y≤x | _ | _ = node left y (insert x l) r
insert x (node left y l r)
    with tot≤ x y
... | inj₁ x≤y
    with insert y l
... | node perfect y' l' r' = node right x (node perfect y' l' r') r
... | t = node left x t r
insert x (node left y l r) | inj₂ y≤x
    with insert x l
... | node perfect y' l' r' = node right y (node perfect y' l' r') r
... | t = node left y t r
insert x (node right y l r)
    with tot≤ x y
... | inj₁ x≤y
    with insert y r
... | node perfect y' l' r' = node perfect x l (node perfect y' l' r')
... | t = node right x l t
insert x (node right y l r) | inj₂ y≤x
    with insert x r
... | node perfect y' l' r' = node perfect y l (node perfect y' l' r')
... | t = node right y l t


module plfa.part1.Bin where

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

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

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

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

from : Bin → ℕ
from ⟨⟩    = 0
from (b O) = 2 * from b
from (b I) = suc (2 * from b)

inc-suc-law : ∀ b → from (inc b) ≡ suc (from b)
inc-suc-law ⟨⟩ = refl
inc-suc-law (b O) = refl
inc-suc-law (b I) rewrite
    inc-suc-law b
  | +-suc (suc (from b)) ((from b) + 0) = refl

from-to-identity : ∀ n → from (to n) ≡ n
from-to-identity zero = refl
from-to-identity (suc n) rewrite
    inc-suc-law (to n)
  | from-to-identity n = refl


-- {-# OPTIONS -v tc.constr.findInScope:50 #-}
module 06-listEquality where

infixr 5 _∷_

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

data Bool : Set where
  true : Bool
  false : Bool

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

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

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

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

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

listEq : {A : Set} → Eq A → Eq (List A)
listEq {A} eqA = record { eq = eq' } where
  eq' : List A → List A → Bool
  eq' [] [] = true
  eq' (a ∷ as) (b ∷ bs) = and (Eq.eq eqA a b) (eq' as bs)
  eq' _ _ = false

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

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

open Eq {{...}}

test = eq (true ∷ false ∷ true ∷ []) (true ∷ false ∷ [])
  where listBoolEq = listEq eqBool


module z where

------------------------------------------------------------------------------
-- inductive data types and function that are defined by pattern matching

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

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

data List {ℓ} (A : Set ℓ) : Set ℓ where
  []   :                         List A
  _::_ : (x : A) (xs : List A) → List A

_#_ : {A : Set} → List A → List A → List A
[]        # ys =            ys
(x :: xs) # ys = x :: (xs # ys)

sum : List ℕ → List ℕ → List ℕ
sum       []        ys  =                   ys
sum (x :: xs)       []  =  x      ::     xs
sum (x :: xs) (y :: ys) = (x + y) :: sum xs ys

-- inductively defined predicates
-- P over S is a data type S -> Set

data _reverseOf_ {A : Set} : List A → List A → Set where
  rev-Λ :       []  reverseOf  []
  rev-t : {x : A} {xs ys : List A}
        →       xs  reverseOf  ys
        → (x :: xs) reverseOf (ys # (x :: []))

data _⊆_ {A : Set} : List A → List A → Set where
  sub-Λ     : [] ⊆ []
  sub-right : {n : A} {ys xs : List A}
            → ys ⊆ xs →       ys  ⊆ (n :: xs)
  sub-ind   : {n : A} {ys xs : List A}
            → ys ⊆ xs → (n :: ys) ⊆ (n :: xs)

------------------------------------------------------------------------------
-- coinductive records and copattern matching

-- inductive pair
record Pair (A B : Set) : Set where
  constructor _,_
  field
    fst : A
    snd : B

-- coinductive infinite list (e.g., "stream")
record Stream (A : Set) : Set where
  coinductive
  field
    hd :        A
    tl : Stream A
open Stream

-- functions cannot be defined inductively (by pattern matching).
-- use copattern matching [APTS13]
-- - specify how the result of the function will be observed

zeros : Stream ℕ
hd zeros = zero
tl zeros = zeros

natsFrom : ℕ → Stream ℕ
hd (natsFrom n) = n
tl (natsFrom n) = natsFrom (suc n)

sumS : Stream ℕ → Stream ℕ → Stream ℕ
hd (sumS a b) =       hd a + hd b
tl (sumS a b) = sumS (tl a) (tl b)

------------------------------------------------------------------------------
-- possibly infinite streams

--open import Codata.Thunk
open import Size
open import Relation.Unary

{-
A thunk is a coinductive record with only one field, the suspended computation.
Takes a function from Size to Set (e.g., Colist A).
Accessing forces the computation and implicitly decreases the size.
'Size < i' represents all the sizes smaller than i.
-}
record Thunk {ℓ} (F : Size → Set ℓ) (i : Size) : Set ℓ where
  coinductive
  field force : {j : Size< i} → F j
open Thunk public

-- 'Size' represents an approximation level.
-- - Can be ∞.
-- - Can help termination checker by tracking depth of data structures.
-- 'Thunk' simulates laziness
data Colist {a} (A : Set a) (i : Size) : Set a where
  []   : Colist A i
  _::_ : A → Thunk (Colist A) i → Colist A i

{-
Alternative Colist impl: follows pattern used for coinductive types.
To represent a structure which can be either finite or infinite, use a coinductive record
with a field representing the whole observation which can be made on the structure.
This field is typically a variant type, since the observation can take different shapes,
e.g., if colist is non-empty then observe the pair consisting of head and tail, otherwise nothing.
-}
open import Data.Maybe
open import Data.Product

record MyColist (A : Set) : Set where
  constructor CoL_
  coinductive
  field
    list : Maybe (A × MyColist A)

-- Either of these two approaches can be used for possibly infinite structures.

data StreamT {ℓ} (A : Set ℓ) (i : Size) : Set ℓ where
  _::_ : A → Thunk (StreamT A) i → StreamT A i

record MyStream_bis (A : Set) : Set where
  coinductive
  field
    stream : A × (MyStream_bis A)

------------------------------------------------------------------------------
-- equality properties

-- stdlib equality and properties

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

-- Each property is a function that takes proofs as input and returns a new proof.

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

trans : ∀ {A : Set} {x y z : A} → x ≡ y → y ≡ z → x ≡ z
trans refl refl = refl

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

subst : ∀ {A : Set} {x y : A} (P : A → Set) → x ≡ y → P x → P y
subst P refl px = px

------------------------------------------------------------------------------
-- Chapter 2 - Inductive reasoning

data _memberOf_ {A : Set} : A → List A → Set where
  mem-h : {x   : A} → {xs : List A} → x memberOf     (x            :: xs)
  mem-t : {x y : A} → {xs : List A} → x memberOf xs → x memberOf(y :: xs)


module Numeral.PositiveInteger.Oper where

open import Numeral.PositiveInteger

infixl 10010 _+_
infixl 10020 _⋅_
infixl 10030 _^_

-- Addition
_+_ : ℕ₊ → ℕ₊ → ℕ₊
x + 𝟏    = 𝐒(x)
x + 𝐒(y) = 𝐒(x + y)

-- Multiplication
_⋅_ : ℕ₊ → ℕ₊ → ℕ₊
x ⋅ 𝟏    = x
x ⋅ 𝐒(y) = x + (x ⋅ y)

-- Exponentiation
_^_ : ℕ₊ → ℕ₊ → ℕ₊
x ^ 𝟏    = x
x ^ 𝐒(y) = x ⋅ (x ^ y)

-- Factorial
_! : ℕ₊ → ℕ₊
𝟏 !    = 𝟏
𝐒(x) ! = 𝐒(x) ⋅ (x !)

open import Data.Option
open import Data.Option.Functions
-- Truncated subtraction
_−₀_ : ℕ₊ → ℕ₊ → Option(ℕ₊)
𝟏    −₀ _    = None
𝐒(x) −₀ 𝟏    = Some x
𝐒(x) −₀ 𝐒(y) = x −₀ y

open import Data.Boolean
open import Type
_≤?_ : ℕ₊ → ℕ₊ → Bool
𝟏    ≤? _    = 𝑇
𝐒(x) ≤? 𝟏    = 𝐹
𝐒(x) ≤? 𝐒(y) = x ≤? y


module Numeral.Natural.Induction{ℓ} where

open import Logic
open import Logic.Propositional
open import Functional
open import Numeral.Natural

-- The induction proof method on natural numbers
-- TODO: There seems to be a problem making i implicit with unsolved metas.
-- TODO: Maybe rename to elim because this is the elimination rule for ℕ
ℕ-elim : ∀{T : ℕ → Stmt{ℓ}} → T(𝟎) → ((i : ℕ) → T(i) → T(𝐒(i))) → ((n : ℕ) → T(n))
ℕ-elim {T} base step 𝟎      = base
ℕ-elim {T} base step (𝐒(n)) = step n (ℕ-elim {T} base step n)

[ℕ]-induction : ∀{φ : ℕ → Stmt{ℓ}} → φ(𝟎) → (∀(i : ℕ) → φ(i) → φ(𝐒(i))) → (∀{n} → φ(n))
[ℕ]-induction {φ} base step {n} = ℕ-elim {φ} base step n

[ℕ]-inductionᵢ : ∀{φ : ℕ → Stmt{ℓ}} → φ(𝟎) → (∀{i : ℕ} → φ(i) → φ(𝐒(i))) → (∀{n} → φ(n))
[ℕ]-inductionᵢ {φ} base step = [ℕ]-induction {φ} base (i ↦ step{i})


module Dave.Algebra.Naturals.Addition where
  open import Dave.Algebra.Naturals.Definition public
  open import Dave.Extensionality

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

  infixl 6 _+_

  {- Semigroup -}
  +-assoc : associative _+_
  +-assoc zero n p = refl
  +-assoc (suc m) n p = cong suc (+-assoc m n p)

  +-assoc' : associative _+_
  +-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) ≡⟨ cong suc (+-assoc' m n p) ⟩
    suc (m + (n + p)) ∎

  ℕ-+-IsSemigroup : IsSemigroup _+_
  IsSemigroup.assoc ℕ-+-IsSemigroup = +-assoc

  ℕ-+-Semigroup : Semigroup
  Semigroup.Carrier ℕ-+-Semigroup = ℕ
  Semigroup._·_ ℕ-+-Semigroup = _+_
  Semigroup.isSemigroup ℕ-+-Semigroup = ℕ-+-IsSemigroup

  {- Identity -}
  +-right-identity : right-identity _+_ 0
  +-right-identity zero = refl
  +-right-identity (suc n) = cong suc (+-right-identity n)

  +-left-identity : left-identity _+_ 0
  +-left-identity m = refl

  ℕ-+-HasIdentity : Identity _+_ 0
  Identity.left ℕ-+-HasIdentity = +-left-identity
  Identity.right ℕ-+-HasIdentity = +-right-identity

  {- Monoid -}
  ℕ-+-IsMonoid : IsMonoid _+_ 0
  IsMonoid.semigroup ℕ-+-IsMonoid = ℕ-+-IsSemigroup
  IsMonoid.identity ℕ-+-IsMonoid = ℕ-+-HasIdentity

  ℕ-+-Monoid : Monoid
  Monoid.Carrier ℕ-+-Monoid = ℕ
  Monoid._·_ ℕ-+-Monoid = _+_
  Monoid.e ℕ-+-Monoid = 0
  Monoid.isMonoid ℕ-+-Monoid = ℕ-+-IsMonoid

  {- Commutative Monoid -}
  +-suc : ∀ (m n : ℕ) → m + suc n ≡ suc (m + n)
  +-suc zero n = refl
  +-suc (suc m) n = cong suc (+-suc m n)

  +-comm : commutative _+_
  +-comm m zero = +-right-identity m
  +-comm m (suc n) = trans (+-suc m n) (cong suc (+-comm m n))

  +-comm' : commutative _+_
  +-comm' m zero = +-right-identity m
  +-comm' m (suc n) = begin
      (m + suc n) ≡⟨ +-suc m n ⟩
      suc (m + n) ≡⟨ cong suc (+-comm' m n) ⟩
      suc (n + m) ∎

  ℕ-+-IsCommutativeMonoid : IsCommutativeMonoid _+_ 0
  IsCommutativeMonoid.isSemigroup ℕ-+-IsCommutativeMonoid = ℕ-+-IsSemigroup
  IsCommutativeMonoid.leftIdentity ℕ-+-IsCommutativeMonoid = +-left-identity
  IsCommutativeMonoid.comm ℕ-+-IsCommutativeMonoid = +-comm

  {- Additional Theorems -}
  +-add1ᵣ : ∀ (m : ℕ) → m + 1 ≡ suc m
  +-add1ᵣ zero = refl
  +-add1ᵣ (suc m) = cong suc (+-add1ᵣ m)

  +-add1ₗ : ∀ (m : ℕ) → 1 + m ≡ suc m
  +-add1ₗ m = refl

  {- Another equal Addition Definition -}
  _+´_ : ℕ → ℕ → ℕ
  m +´ zero = m
  m +´ suc n = suc (m +´ n)

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

  +≡+´ : _+_ ≡ _+´_
  +≡+´ = extensionality (λ m → extensionality (λ n → app-+≡+´ m n))


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

module Basic_Types where

-- Already in the builtin's of agda, there are Π types, which is ∀, and lambda
-- abstraction, which is λ{ } and function types, which is →.

-- ------------------------------------
-- Some operations for function types
-- The curly brackts ∀{} should be viewed as contexts.

-- identity function
id : ∀ {A : Set} → A → A
id = λ{ x → x }

-- function composition
comp : ∀ {A B C : Set} → (B → C) → (A → B) → A → C
comp {A} {B} {C} = λ (f : B → C) (g : A → B) (x : A) → f (g x)
-- The judgemental equality of association of functions is builtin in agda,
-- i.e., all the rules of derivation in the basic language of type theory,
-- e.g., the β-, η- reduction is automatic in agda.

-- swapping the argument
swap : ∀ {A B : Set} {C : A → B → Set} →
      (∀ (a : A) (b : B) → C a b) → (∀ (b : B) (a : A) → C a b)
swap {A} {B} {C} = λ { p → λ (b : B) (a : A) → p a b }

-- ------------------------------------
-- the unit type
data 𝟙 : Set where
  ⋆ : 𝟙

𝟙-ind : ∀ {A : 𝟙 → Set} → ∀ (a : A ⋆) → ∀ (x : 𝟙) → A x
𝟙-ind {A} a = 𝟙-indhelper
  where 𝟙-indhelper : ∀ (x : 𝟙) → A x
        𝟙-indhelper ⋆ = a

-- ------------------------------------
-- the empty type
data 𝟘 : Set where

𝟘-ind : ∀ {A : 𝟘 → Set} → ∀ (x : 𝟘) → A x
𝟘-ind {A} ()

-- define negation
¬_ : ∀ (A : Set) → Set
¬ A = A → 𝟘

-- ------------------------------------
-- the boolean type
data 𝟚 : Set where
  tt ff : 𝟚

𝟚-ind : ∀ {A : 𝟚 → Set} → A ff → A tt → ∀ (x : 𝟚) → A x
𝟚-ind Aff _ ff = Aff
𝟚-ind _ Att tt = Att

-- ------------------------------------
-- natural numbers
data ℕ : Set where
  zero : ℕ
  succ : ℕ → ℕ

{-# BUILTIN NATURAL ℕ #-}

-- ℕ induction
ℕ-ind : ∀ {A : ℕ → Set} →
        ∀ (a : A 0) → (∀ (n : ℕ) → A n → A (succ n)) → ∀ (m : ℕ) → A m
ℕ-ind {A} a p = ℕ-indhelper
  where ℕ-indhelper : ∀ (m : ℕ) → A m
        ℕ-indhelper 0        = a
        ℕ-indhelper (succ n) = p n (ℕ-indhelper n)
-- From this exercise, we can actually see that the idea of induction is
-- builtin in agda, since we essentially use the induction builtin in agda
-- to prove ℕ-ind.

-- ℕ recursion, which is a special case for ℕ induction, where the type is not
-- dependent on ℕ
ℕ-rec : ∀ {A : Set} →
        ∀ (a : A) → (∀ (n : ℕ) → A → A) → ∀ (m : ℕ) → A
ℕ-rec {A} = ℕ-ind {λ { n → A }}

-- for example, we can use ℕ-rec to define addition
add : ℕ → ℕ → ℕ
add = ℕ-rec {ℕ → ℕ} (id {ℕ}) (λ (n : ℕ) (p : ℕ → ℕ) → comp succ p)

-- ------------------------------------
-- the sum type
record Σ (A : Set) (B : A → Set) : Set where
  constructor
    _,_
  field
    a : A
    b : B a

-- the two projections
π₁ : ∀ {A : Set} {B : A → Set} → Σ A B → A
π₁ (x , y) = x

π₂ : ∀ {A : Set} {B : A → Set} → ∀ (z : Σ A B) → B (π₁ z)
π₂ (x , y) = y

syntax Σ A (λ a → b) = Σ a ∶ A , b

-- Σ induction
Σ-ind : ∀ {A : Set} {B : A → Set} {P : Σ A B → Set} →
       (∀ (a : A) (b : B a) → P (a , b)) → ∀ (z : Σ A B) → P z
Σ-ind {A} {B} {P} = λ (f : ∀ (a : A) (b : B a) → P (a , b)) →
                    λ (z : Σ A B) → f (π₁ z) (π₂ z)

-- cartesion product type
_×_ : Set → Set → Set
A × B = Σ a ∶ A , B

×-ind : ∀ {A : Set} {B : Set} {P : A × B → Set} →
       (∀ (a : A) (b : B) → P (a , b)) → ∀ (z : A × B) → P z
×-ind {A} {B} {P} = Σ-ind {A} {λ (a : A) → B} {P}

-- ------------------------------------
-- the coproduct type

data _⊎_ (A : Set) (B : Set) : Set where
  inl : A → A ⊎ B
  inr : B → A ⊎ B

⊎-ind : ∀ {A : Set} {B : Set} {P : A ⊎ B → Set} →
       (∀ (a : A) → P (inl a)) → (∀ (b : B) → P (inr b)) →
        ∀ (u : A ⊎ B) → P u
⊎-ind f _ (inl x) = f x
⊎-ind _ g (inr y) = g y


module Structure.Setoid.Uniqueness where

import      Lvl
open import Functional
open import Logic
open import Logic.Propositional
open import Logic.Predicate
open import Structure.Setoid
open import Type

private variable ℓₗ ℓₗ₁ ℓₗ₂ : Lvl.Level

module _ {ℓ₁}{ℓ₂} where
  -- Definition of uniqueness of a property.
  -- This means that there is at most one element that satisfies this property.
  -- This is similiar to "Injective" for functions.
  Unique : ∀{Obj : Type{ℓ₁}}{ℓₗ} → ⦃ equiv : Equiv{ℓₗ}(Obj) ⦄ → (Pred : Obj → Stmt{ℓ₂}) → Stmt
  Unique {Obj = Obj} Pred = ∀{x y : Obj} → Pred(x) → Pred(y) → (x ≡ y)

  -- Definition of existence of an unique element satisfying a property.
  -- This means that there is one and only one element that satisfies this property.
  ∃! : ∀{Obj : Type{ℓ₁}}{ℓₗ} → ⦃ equiv : Equiv{ℓₗ}(Obj) ⦄ → (Pred : Obj → Stmt{ℓ₂}) → Stmt
  ∃! {Obj} Pred = ∃(Pred) ∧ Unique(Pred)

  [∃!]-intro : ∀{T} → ⦃ _ : Equiv{ℓₗ}(T) ⦄ → ∀{property} → ∃(property) → Unique{T}(property) → ∃!(property)
  [∃!]-intro = [∧]-intro

  [∃!]-existence : ∀{Obj} → ⦃ _ : Equiv{ℓₗ}(Obj) ⦄ → ∀{Pred} → ∃!{Obj}(Pred) → ∃(Pred)
  [∃!]-existence  = [∧]-elimₗ

  [∃!]-uniqueness : ∀{Obj} → ⦃ _ : Equiv{ℓₗ}(Obj) ⦄ → ∀{Pred} → ∃!{Obj}(Pred) → Unique(Pred)
  [∃!]-uniqueness = [∧]-elimᵣ

  [∃!]-witness : ∀{Obj} → ⦃ _ : Equiv{ℓₗ}(Obj) ⦄ → ∀{Pred} → ∃!{Obj}(Pred) → Obj
  [∃!]-witness e = [∃]-witness ([∃!]-existence e)

  [∃!]-proof : ∀{Obj} → ⦃ _ : Equiv{ℓₗ}(Obj) ⦄ → ∀{Pred} → (e : ∃!{Obj}(Pred)) → Pred([∃!]-witness(e))
  [∃!]-proof e = [∃]-proof ([∃!]-existence e)

  [∃!]-existence-eq : ∀{T} → ⦃ _ : Equiv{ℓₗ}(T) ⦄ → ∀{P} → (e : ∃!(P)) → ∀{x} → P(x) → (x ≡ [∃!]-witness e)
  [∃!]-existence-eq e {x} px = [∃!]-uniqueness e {x} {[∃!]-witness e} px ([∃!]-proof e)

  [∃!]-existence-eq-any : ∀{T} → ⦃ _ : Equiv{ℓₗ}(T) ⦄ → ∀{P} → (e : ∃!(P)) → ∀{x} → P(x) → ([∃!]-witness e ≡ x)
  [∃!]-existence-eq-any e {x} px = [∃!]-uniqueness e {[∃!]-witness e} {x} ([∃!]-proof e) px

  -- TODO: [∃!]-equivalence {T} property = ∃(a ↦ ∃{property(a)}(pa ↦ pa ∧ Uniqueness{T}(property){a}(pa)))


--------------------------------------------------------------------------------
-- This is part of Agda Inference Systems

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

module Examples.Colists.Auxiliary.MaxOf where

  max : ℕ → ℕ → ℕ
  max zero zero = zero
  max zero (suc y) = suc y
  max (suc x) zero = suc x
  max (suc x) (suc y) = suc (max x y)

  max-refl : (x y : ℕ) → (x ≡ max x y) ⊎ (y ≡ max x y)
  max-refl zero zero = inj₂ refl
  max-refl zero (suc y) = inj₂ refl
  max-refl (suc x) zero = inj₁ refl
  max-refl (suc x) (suc y) with max-refl x y
  max-refl (suc x) (suc y) | inj₁ eq = inj₁ (cong (λ x₁ → suc x₁) eq)
  max-refl (suc x) (suc y) | inj₂ eq = inj₂ (cong (λ x₁ → suc x₁) eq)

  max-refl-eq : ∀{x y z} → z ≡ max x y → z ≡ x ⊎ z ≡ y
  max-refl-eq {x} {y} {z} refl with max-refl x y
  max-refl-eq {x} {y} {.(max x y)} refl | inj₁ x₁ = inj₁ (sym x₁)
  max-refl-eq {x} {y} {.(max x y)} refl | inj₂ y₁ = inj₂ (sym y₁)

  max-self : ∀ {n} → n ≡ max n n
  max-self {zero} = refl
  max-self {suc n} = cong (λ x → suc x) max-self

  max-trans : ∀{x y z} → y ≡ max y z → x ≡ max x y → x ≡ max x z
  max-trans {zero} {zero} {zero} _ _ = refl
  max-trans {suc x} {zero} {zero} refl refl = refl
  max-trans {suc x} {suc y} {zero} refl _ = refl
  max-trans {suc x} {suc y} {suc z} eq eq1 =
    let eq-pred = cong pred eq in
    let eq1-pred = cong pred eq1 in
    cong suc (max-trans eq-pred eq1-pred)

  max-comm : ∀{x y z} → x ≡ max y z → x ≡ max z y
  max-comm {x} {zero} {zero} eq = eq
  max-comm {x} {suc y} {zero} eq = eq
  max-comm {x} {zero} {suc z} eq = eq
  max-comm {suc x} {suc y} {suc z} eq = cong suc (max-comm (cong pred eq))


{-# OPTIONS --sized-types #-}
open import Relation.Binary.Core

module BubbleSort.Correctness.Permutation {A : Set}
                  (_≤_ : A → A → Set)
                  (tot≤ : Total _≤_) where

open import BubbleSort _≤_ tot≤
open import Data.Product
open import Data.List
open import Data.Sum
open import List.Permutation.Base A
open import List.Permutation.Base.Equivalence A
open import Size
open import SList
open import SList.Properties A
open import SList.Concatenation A

lemma-swap*∼ : {ι : Size}(x : A) → (xs : SList A {ι}) → unsize A (x ∙ xs) ∼ unsize A (proj₂ (swap* x xs) ∙ proj₁ (swap* x xs))
lemma-swap*∼ x snil = ∼x /head /head ∼[]
lemma-swap*∼ x (y ∙ ys)
    with tot≤ x y
... | inj₁ x≤y = ∼x /head (/tail /head) (lemma-swap*∼ y ys)
... | inj₂ y≤x = ∼x (/tail /head) (/tail /head) (lemma-swap*∼ x ys)

lemma-bubbleSort∼ : {ι : Size}(xs : SList A {ι}) → unsize A xs ∼ unsize A (bubbleSort xs)
lemma-bubbleSort∼ snil = ∼[]
lemma-bubbleSort∼ (x ∙ xs) = trans∼ (lemma-swap*∼ x xs) (trans∼ (lemma-⊕∼ y (lemma-bubbleSort∼ ys)) (lemma-size-unsize y (bubbleSort ys)))
                  where sxxs = swap* x xs
                        ys = proj₁ sxxs
                        y = proj₂ sxxs

theorem-bubbleSort∼ : (xs : List A) → xs ∼ unsize A (bubbleSort (size A xs))
theorem-bubbleSort∼ xs = trans∼ (lemma-unsize-size xs) (lemma-bubbleSort∼ (size A xs))


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

module Data.Nat.Square where

open import Data.Nat
open import Data.Nat.Properties

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

_² : ℕ → ℕ
n ² = n * n

n^2≡n² : ∀ n → n ^ 2 ≡ n ²
n^2≡n² n = Eq.cong (n *_) (*-identityʳ n)

²-mono : _² Preserves _≤_ ⟶ _≤_
²-mono m≤n = *-mono-≤ m≤n m≤n


module Numeral.Natural.Relation where

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

Positive : ℕ → Stmt
Positive(n) = IsTrue(positive? n)

zero-not-positive : ¬ Positive(𝟎)
zero-not-positive ()

positive-not-zero : ∀{n} → ⦃ _ : Positive(n) ⦄ → (n ≢ 𝟎)
positive-not-zero {𝟎} ⦃ pos ⦄ _ = pos

non-zero-positive : ∀{n} → (n ≢ 𝟎) → Positive(n)
non-zero-positive {𝟎}   p = p [≡]-intro
non-zero-positive {𝐒 n} p = [⊤]-intro


open import Data.List

{- --- 6. Vectors --- -}

{- 6.1 Warmup -}

{- Problem: what do we return for the empty list ? -}
head2 : {A : Set} → List A → A
head2 [] = {!!}
head2 (x ∷ l) = x

{- 6.2 Definition -}
open import Data.Nat

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

{- 6.3 Head and tail -}
head-vec : {A : Set} → {n : ℕ} → Vec A (suc n) → A
head-vec (x :: v) = x

tail-vec : {A : Set} → {n : ℕ} → Vec A (suc n) → Vec A n
tail-vec (x :: v) = v

{- 6.4 Concatenation -}
concat-vec : {A : Set} → {m n : ℕ} → Vec A m → Vec A n → Vec A (m + n)
concat-vec [] v2 = v2
concat-vec (x :: v1) v2 = x :: (concat-vec v1 v2)

{- 6.5 Reversal -}
snoc-vec : {A : Set} → {n : ℕ} → A → Vec A n → Vec A (suc n)
snoc-vec a [] = a :: []
snoc-vec a (x :: v) = x :: (snoc-vec a v)

rev-vec : {A : Set} → {n : ℕ} → Vec A n → Vec A n
rev-vec [] = []
rev-vec (x :: v) = snoc-vec x (rev-vec v)

{- 6.6 Accessing an element -}
data Fin : ℕ → Set where
  zero : {n : ℕ} → Fin (suc n)
  suc : {n : ℕ} (i : Fin n) → Fin (suc n)

{- 6.7 Zipping -}
open import Data.Product hiding (zip)

zip-vec : {A : Set} → {n : ℕ} → Vec A n → Vec A n → Vec (A × A) n
zip-vec [] [] = []
zip-vec (x₁ :: y₁) (x₂ :: y₂) = (x₁ , x₂) :: (zip-vec y₁ y₂)


{-# OPTIONS  --sized-types --show-implicit #-}

module SizedNatAnnotated where

open import Size

data Nat : {i : Size} -> Set where
  zero : {i : Size} -> Nat {↑ i}
  suc  : {i : Size} -> Nat {i} -> Nat {↑ i}

-- subtraction is non size increasing
sub : {i : Size} -> Nat {i} -> Nat {∞} -> Nat {i}
sub .{↑ i} (zero {i})  n       = zero {i}
sub .{↑ i} (suc {i} m) zero    = suc {i} m
sub .{↑ i} (suc {i} m) (suc n) = sub {i} m n

-- div' m n  computes  ceiling(m/(n+1))
div' : {i : Size} -> Nat {i} -> Nat -> Nat {i}
div' .{↑ i} (zero {i})  n = zero {i}
div' .{↑ i} (suc {i} m) n = suc  {i} (div' {i} (sub {i} m n) n)


module Data.Nat.Etc where

open import Data.Nat
open import Data.Nat.Properties.Simple
open import Function
open import Relation.Nullary.Negation using (contradiction; contraposition)
open import Relation.Binary

open import Relation.Binary.PropositionalEquality as PropEq
    using (_≡_; _≢_; refl; cong; trans; sym)
open PropEq.≡-Reasoning

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

--------------------------------------------------------------------------------
-- Properties
--------------------------------------------------------------------------------

distrib-left-*-+ : ∀ m n o → m * (n + o) ≡ m * n + m * o
distrib-left-*-+ m n o =
        begin
            m * (n + o)
        ≡⟨ *-comm m (n + o) ⟩
            (n + o) * m
        ≡⟨ distribʳ-*-+ m n o ⟩
            n * m + o * m
        ≡⟨ cong (flip _+_ (o * m)) (*-comm n m) ⟩
            m * n + o * m
        ≡⟨ cong (_+_ (m * n)) (*-comm o m) ⟩
            m * n + m * o
        ∎
{-
no-zero-divisor : ∀ m n → m ≢ 0 → m * n ≡ 0 → n ≡ 0
no-zero-divisor zero    n       p q = contradiction q p
no-zero-divisor (suc m) zero    p q = refl
no-zero-divisor (suc m) (suc n) p ()

m^n≢0 : ∀ m n → {m≢0 : m ≢ 0} → m ^ n ≢ 0
m^n≢0 m zero    {p} = λ ()
m^n≢0 m (suc n) {p} = contraposition (no-zero-divisor m (m ^ n) p) (m^n≢0 m n {p})

m≰n⇒n<m : (m n : ℕ) → m ≰ n → m > n
m≰n⇒n<m zero n p = contradiction p (λ z → z z≤n)
m≰n⇒n<m (suc m) zero p = s≤s z≤n
m≰n⇒n<m (suc m) (suc n) p = s≤s (m≰n⇒n<m m n (λ z → p (s≤s z)))
-}

>⇒≰ : _>_ ⇒ _≰_
>⇒≰ {zero} ()
>⇒≰ {suc m} {zero} rel ()
>⇒≰ {suc m} {suc n} (s≤s rel) (s≤s x) = contradiction x (>⇒≰ rel)

>⇒≢ : _>_ ⇒ _≢_
>⇒≢ {zero}  ()      m≡n
>⇒≢ {suc m} {zero}   m>n ()
>⇒≢ {suc m} {suc n} (s≤s m>n) m≡n = >⇒≢ m>n (cong pred m≡n)

{-
≰⇒> : _≰_ ⇒ _>_
≰⇒> {zero}          z≰n with z≰n z≤n
... | ()
≰⇒> {suc m} {zero}  _   = s≤s z≤n
≰⇒> {suc m} {suc n} m≰n = s≤s (≰⇒> (m≰n ∘ s≤s))
-}
{-
    begin
        {!   !}
    ≡⟨ {!   !} ⟩
        {!   !}
    ≡⟨ {!   !} ⟩
        {!   !}
    ≡⟨ {!   !} ⟩
        {!   !}
    ≡⟨ {!   !} ⟩
        {!   !}
    ∎
-}


{-# OPTIONS --copatterns #-}

open import Common.Size
open import Common.Prelude
open import Common.Product renaming (proj₁ to fst; proj₂ to snd)

record Stream (i : Size) (A : Set) : Set where
  coinductive
  field force : ∀{j : Size< i} → A × Stream j A
open Stream

head : ∀{i A} → Stream (↑ i) A →  A
head s = fst (force s)

tail : ∀{i A} → Stream (↑ i) A → Stream i A
tail s = snd (force s)

smap : ∀{i A B} (f : A → B) → Stream i A → Stream i B
force (smap f s) with force s
... | a , as = f a , smap f as

scanl : ∀{i A B} (f : B → A → B) (b : B) (s : Stream i A) → Stream i B
force (scanl f b s) with force s
... | a , as = b , scanl f (f b a) as

_!_ : ∀{A} (s : Stream _ A) (n : Nat) → A
s ! zero  = head s
s ! suc n = tail s ! n

_!!_ : ∀{A} (s : Stream _ A) (n : Nat) → A
s !! n with force s
_ !! zero  | a , as = a
_ !! suc n | a , as = as !! n

nats : ∀{i} → Stream i Nat
force nats = 0 , smap suc nats

sums : Stream _ Nat
sums = scanl (_+_) 0 (tail nats)

main : IO Unit
main = printNat (sums ! 100)
-- Expected output, due to Gauss: 5050


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

syntax Prod | P

type
  _⊗_ : 2-ary | l40

term
  pair : α  β  ->  α ⊗ β | ⟨_,_⟩
  fst  : α ⊗ β  ->  α
  snd  : α ⊗ β  ->  β

theory
  (fβ) a : α  b : β |> fst (pair(a, b))      = a
  (sβ) a : α  b : β |> snd (pair(a, b))      = b
  (pη) p : α ⊗ β    |> pair (fst(p), snd(p)) = p
-}

module Prod.Signature where

open import SOAS.Context

-- Type declaration
data PT : Set where
  _⊗_ : PT → PT → PT
infixl 40 _⊗_

open import SOAS.Syntax.Signature PT public
open import SOAS.Syntax.Build PT public

-- Operator symbols
data Pₒ : Set where
  pairₒ fstₒ sndₒ : {α β : PT} → Pₒ

-- Term signature
P:Sig : Signature Pₒ
P:Sig = sig λ
  { (pairₒ {α}{β}) → (⊢₀ α) , (⊢₀ β) ⟼₂ α ⊗ β
  ; (fstₒ  {α}{β}) → (⊢₀ α ⊗ β) ⟼₁ α
  ; (sndₒ  {α}{β}) → (⊢₀ α ⊗ β) ⟼₁ β
  }

open Signature P:Sig public


------------------------------------------------------------------------------
-- Distributive laws on a binary operation (Stanovský example)
------------------------------------------------------------------------------

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

module DistributiveLaws.README where

------------------------------------------------------------------------------
-- Description

-- Let _·_ be a left-associative binary operation which satifies the
-- left and right distributive axioms:
--
-- ∀ x y z → x ∙ (y ∙ z) ≡ (x ∙ y) ∙ (x ∙ z)
-- ∀ x y z → (x ∙ y) ∙ z ≡ (x ∙ z) ∙ (y ∙ z).

-- We prove some properties of Stanovský (2008): Task B, Lemma 3,
-- Lemma 4, Lemma 5 (Task A) and Lemma 6.

------------------------------------------------------------------------------
-- The axioms
open import DistributiveLaws.Base

-- The interactive and combined proofs
open import DistributiveLaws.Lemma3-ATP
open import DistributiveLaws.Lemma4-ATP
open import DistributiveLaws.Lemma5-ATP
open import DistributiveLaws.Lemma6-ATP
open import DistributiveLaws.TaskB-AllStepsATP
open import DistributiveLaws.TaskB-HalvedStepsATP
open import DistributiveLaws.TaskB-I
open import DistributiveLaws.TaskB-TopDownATP

-- Unproven theorem by the ATPs
open import DistributiveLaws.TaskB.UnprovedATP

------------------------------------------------------------------------------
-- References:
--
-- Stanovský, David (2008). Distributive Groupoids are
-- Symmetrical-by-Medial: An Elementary Proof. Commentations
-- Mathematicae Universitatis Carolinae 49.4, pp. 541–546.


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

module Lecture3 where

import Lecture2
open Lecture2 public

data unit : U where
  star : unit

𝟙 = unit

ind-unit : {i : Level} {P : unit → UU i} → P star → ((x : unit) → P x)
ind-unit p star = p

data empty : U where

𝟘 = empty

ind-empty : {i : Level} {P : empty → UU i} → ((x : empty) → P x)
ind-empty ()

¬ : {i : Level} → UU i → UU i
¬ A = A → empty

data bool : U where
  true false : bool

not : bool → bool
not true = false
not false = true

ind-bool : {i : Level} {P : bool → UU i} → P true → P false → (x : bool) → P x
ind-bool Pt Pf true = Pt
ind-bool Pt Pf false = Pf

data coprod {i j : Level} (A : UU i) (B : UU j) : UU (i ⊔ j)  where
  inl : A → coprod A B
  inr : B → coprod A B

data Sigma {i j : Level} (A : UU i) (B : A → UU j) : UU (i ⊔ j) where
  dpair : (x : A) → (B x → Sigma A B)

Σ = Sigma

ind-Σ : {i j k : Level} {A : UU i} {B : A → UU j} {C : Σ A B → UU k} →
  ((x : A) (y : B x) → C (dpair x y)) → ((t : Σ A B) → C t)
ind-Σ f (dpair x y) = f x y

pr1 : {i j : Level} {A : UU i} {B : A → UU j} → Sigma A B → A
pr1 (dpair a b) = a

pr2 : {i j : Level} {A : UU i} {B : A → UU j} → (t : Sigma A B) → B (pr1 t)
pr2 (dpair a b) = b

weaken : {i j : Level} (A : UU i) (B : UU j) → (A → UU j)
weaken A B = λ a → B

prod : {i j : Level} (A : UU i) (B : UU j) → UU (i ⊔ j)
prod A B = Sigma A (λ a → B)

_×_ :  {i j : Level} (A : UU i) (B : UU j) → UU (i ⊔ j)
A × B = prod A B

-- WARNING, can't use pair in pattern matching as it's not recognized as a ctor
pair : {i j : Level} {A : UU i} {B : UU j} → A → (B → prod A B)
pair a b = dpair a b

-- Pointed types
U-pt : Type
U-pt = Sigma U (λ X → X)

-- Graphs
Gph : Type
Gph = Sigma U (λ X → (X → X → U))

-- Reflexive graphs
rGph : Type
rGph = Sigma U (λ X → Sigma (X → X → U) (λ R → (x : X) → R x x))

-- Finite sets
Fin : ℕ → U
Fin Nzero = empty
Fin (Nsucc n) = coprod (Fin n) unit

-- Observational equality on the natural numbers
EqN : ℕ → (ℕ → U)
EqN Nzero Nzero = 𝟙
EqN Nzero (Nsucc n) = 𝟘
EqN (Nsucc m) Nzero = 𝟘
EqN (Nsucc m) (Nsucc n) = EqN m n

-- The integers
ℤ : U
ℤ = coprod ℕ (coprod unit ℕ)
--         ^         ^^^^ ^
--     (-∞, -1]       0   [1, ∞)
--     -(n+1)              n+1

-- Inclusion of the negative integers
in-neg : ℕ → ℤ
in-neg n = inl n

-- Negative one
Zneg-one : ℤ
Zneg-one = in-neg Nzero

-- Zero
Zzero : ℤ
Zzero = inr (inl star)

-- One
Zone : ℤ
Zone = inr (inr Nzero)

-- Inclusion of the positive integers
in-pos : ℕ → ℤ
in-pos n = inr (inr n)

-- Since Agda is already strong with nested induction, I dont think we need this definition.
ind-ℤ : {i : Level} (P : ℤ → UU i) → P Zneg-one → ((n : ℕ) → P (inl n) → P (inl (Nsucc n))) → P Zzero → P Zone → ((n : ℕ) → P (inr (inr (n))) → P (inr (inr (Nsucc n)))) → (k : ℤ) → P k
ind-ℤ P p-1 p-S p0 p1 pS (inl Nzero) = p-1
ind-ℤ P p-1 p-S p0 p1 pS (inl (Nsucc x)) = p-S x (ind-ℤ P p-1 p-S p0 p1 pS (inl x))
ind-ℤ P p-1 p-S p0 p1 pS (inr (inl star)) = p0
ind-ℤ P p-1 p-S p0 p1 pS (inr (inr Nzero)) = p1
ind-ℤ P p-1 p-S p0 p1 pS (inr (inr (Nsucc x))) = pS x (ind-ℤ P p-1 p-S p0 p1 pS (inr (inr (x))))

Zsucc : ℤ → ℤ
Zsucc (inl Nzero) = Zzero
Zsucc (inl (Nsucc x)) = inl x
Zsucc (inr (inl star)) = Zone
Zsucc (inr (inr x)) = inr (inr (Nsucc x))

-- Exercise 3.1
-- In this exercise we were asked to show that (A + ¬A) implies (¬¬A → A).
-- In other words, we get double negation elimination for the types that are decidable
dne-dec : {i : Level} (A : UU i) → (coprod A (¬ A)) → (¬ (¬ A) → A)
dne-dec A (inl x) = λ f → x
dne-dec A (inr x) = λ f → ind-empty (f x)

-- Exercise 3.3
-- In this exercise we were asked to show that the observational equality on ℕ is an equivalence relation.
reflexive-EqN : (n : ℕ) → EqN n n
reflexive-EqN Nzero = star
reflexive-EqN (Nsucc n) = reflexive-EqN n

symmetric-EqN : (m n : ℕ) → EqN m n → EqN n m
symmetric-EqN Nzero Nzero t = t
symmetric-EqN Nzero (Nsucc n) t = t
symmetric-EqN (Nsucc n) Nzero t = t
symmetric-EqN (Nsucc m) (Nsucc n) t = symmetric-EqN m n t

transitive-EqN : (l m n : ℕ) → EqN l m → EqN m n → EqN l n
transitive-EqN Nzero Nzero Nzero s t = star
transitive-EqN (Nsucc n) Nzero Nzero s t = ind-empty s
transitive-EqN Nzero (Nsucc n) Nzero s t = ind-empty s
transitive-EqN Nzero Nzero (Nsucc n) s t = ind-empty t
transitive-EqN (Nsucc l) (Nsucc m) Nzero s t = ind-empty t
transitive-EqN (Nsucc l) Nzero (Nsucc n) s t = ind-empty s
transitive-EqN Nzero (Nsucc m) (Nsucc n) s t = ind-empty s
transitive-EqN (Nsucc l) (Nsucc m) (Nsucc n) s t = transitive-EqN l m n s t

-- Exercise 3.4
-- In this exercise we were asked to show that observational equality on the natural numbers is the least reflexive relation, in the sense that it implies all other reflexive relation. As we will see once we introduce the identity type, it follows that observationally equal natural numbers can be identified.

-- We first make an auxilary construction, where the relation is quantified over inside the scope of the variables n and m. This is to ensure that the inductive hypothesis is strong enough to make the induction go through.
least-reflexive-EqN' : {i : Level} (n m : ℕ)
                     (R : ℕ → ℕ → UU i) (ρ : (n : ℕ) → R n n) → EqN n m → R n m
least-reflexive-EqN' Nzero Nzero R ρ p = ρ Nzero
least-reflexive-EqN' Nzero (Nsucc m) R ρ = ind-empty
least-reflexive-EqN' (Nsucc n) Nzero R ρ = ind-empty
least-reflexive-EqN' (Nsucc n) (Nsucc m) R ρ =
  least-reflexive-EqN' n m (λ x y → R (Nsucc x) (Nsucc y)) (λ x → ρ (Nsucc x))

-- Now we solve the actual exercise by rearranging the order of the variables.
least-reflexive-EqN : {i : Level} {R : ℕ → ℕ → UU i}
  (ρ : (n : ℕ) → R n n) → (n m : ℕ) → EqN n m → R n m
least-reflexive-EqN ρ n m p = least-reflexive-EqN' n m _ ρ p

-- Exercise 3.5
-- In this exercise we were asked to show that any function on the natural numbers preserves observational equality. The quick solution uses the fact that observational equality is the least reflexive relation.
preserve_EqN : (f : ℕ → ℕ) (n m : ℕ) → (EqN n m) → (EqN (f n) (f m))
preserve_EqN f =
    least-reflexive-EqN {_} {λ x y → EqN (f x) (f y)}
      (λ x → reflexive-EqN (f x))

-- Exercise 3.6
-- In this exercise we were asked to construct the relations ≤ and < on the natural numbers, and show basic properties about them.

-- Definition of ≤
leqN : ℕ → ℕ → U
leqN Nzero Nzero = unit
leqN Nzero (Nsucc m) = unit
leqN (Nsucc n) Nzero = empty
leqN (Nsucc n) (Nsucc m) = leqN n m

_≤_ = leqN

-- Definition of <
leN : ℕ → ℕ → U
leN Nzero Nzero = empty
leN Nzero (Nsucc m) = unit
leN (Nsucc n) Nzero = empty
leN (Nsucc n) (Nsucc m) = leN n m

_<_ = leN

reflexive-leqN : (n : ℕ) → n ≤ n
reflexive-leqN Nzero = star
reflexive-leqN (Nsucc n) = reflexive-leqN n

anti-reflexive-leN : (n : ℕ) → ¬ (n < n)
anti-reflexive-leN Nzero = ind-empty
anti-reflexive-leN (Nsucc n) = anti-reflexive-leN n

transitive-leqN : (n m l : ℕ) → (n ≤ m) → (m ≤ l) → (n ≤ l)
transitive-leqN Nzero Nzero Nzero p q = reflexive-leqN Nzero
transitive-leqN Nzero Nzero (Nsucc l) p q = q
transitive-leqN Nzero (Nsucc m) Nzero p q = star
transitive-leqN Nzero (Nsucc m) (Nsucc l) p q = star
transitive-leqN (Nsucc n) Nzero l p q = ind-empty p
transitive-leqN (Nsucc n) (Nsucc m) Nzero p q = ind-empty q
transitive-leqN (Nsucc n) (Nsucc m) (Nsucc l) p q = transitive-leqN n m l p q

transitive-leN : (n m l : ℕ) → (leN n m) → (leN m l) → (leN n l)
transitive-leN Nzero Nzero Nzero p q = p
transitive-leN Nzero Nzero (Nsucc l) p q = q
transitive-leN Nzero (Nsucc m) Nzero p q = ind-empty q
transitive-leN Nzero (Nsucc m) (Nsucc l) p q = star
transitive-leN (Nsucc n) Nzero l p q = ind-empty p
transitive-leN (Nsucc n) (Nsucc m) Nzero p q = ind-empty q
transitive-leN (Nsucc n) (Nsucc m) (Nsucc l) p q = transitive-leN n m l p q

succ-leN : (n : ℕ) → leN n (Nsucc n)
succ-leN Nzero = star
succ-leN (Nsucc n) = succ-leN n

-- Exercise 3.7
-- With the construction of the divisibility relation we open the door to basic number theory.
divides : (d n : ℕ) → U
divides d n = Σ ℕ (λ m → EqN (d ** m) n)

-- Exercise 3.8
-- In this exercise we were asked to construct observational equality on the booleans. This construction is analogous to, but simpler than, the construction of observational equality on the natural numbers.
Eq2 : bool → bool → U
Eq2 true true = unit
Eq2 true false = empty
Eq2 false true = empty
Eq2 false false = unit

reflexive-Eq2 : (x : bool) → Eq2 x x
reflexive-Eq2 true = star
reflexive-Eq2 false = star

least-reflexive-Eq2 : {i : Level}
  (R : bool → bool → UU i) (ρ : (x : bool) → R x x)
  (x y : bool) → Eq2 x y → R x y
least-reflexive-Eq2 R ρ true true p = ρ true
least-reflexive-Eq2 R ρ true false p = ind-empty p
least-reflexive-Eq2 R ρ false true p = ind-empty p
least-reflexive-Eq2 R ρ false false p = ρ false

-- Exercise 3.9
-- In this exercise we were asked to show that 1 + 1 satisfies the induction principle of the booleans. In other words, type theory cannot distinguish the booleans from the type 1 + 1. We will see later that they are indeed equivalent types.
t0 : coprod unit unit
t0 = inl star

t1 : coprod unit unit
t1 = inr star

ind-coprod-unit-unit : {i : Level} {P : coprod unit unit → UU i} →
  P t0 → P t1 → (x : coprod unit unit) → P x
ind-coprod-unit-unit p0 p1 (inl star) = p0
ind-coprod-unit-unit p0 p1 (inr star) = p1

-- Exercise 3.10
-- In this exercise we were asked to define the relations ≤ and < on the integers. As a criterion of correctness, we were then also asked to show that the type of all integers l satisfying k ≤ l satisfy the induction principle of the natural numbers.
-- It turns out that this is a long exercise that requires to develop intermediate properties of the relation ≤, involving long proofs. None of them is really hard, but they are probably unintelligible because induction on the integers splits into so many cases.

leqZ : ℤ → ℤ → U
leqZ (inl Nzero) (inl Nzero) = unit
leqZ (inl Nzero) (inl (Nsucc x)) = empty
leqZ (inl Nzero) (inr l) = unit
leqZ (inl (Nsucc x)) (inl Nzero) = unit
leqZ (inl (Nsucc x)) (inl (Nsucc y)) = leqZ (inl x) (inl y)
leqZ (inl (Nsucc x)) (inr l) = unit
leqZ (inr k) (inl x) = empty
leqZ (inr (inl star)) (inr l) = unit
leqZ (inr (inr x)) (inr (inl star)) = empty
leqZ (inr (inr Nzero)) (inr (inr y)) = unit
leqZ (inr (inr (Nsucc x))) (inr (inr Nzero)) = empty
leqZ (inr (inr (Nsucc x))) (inr (inr (Nsucc y))) =
  leqZ (inr (inr (x))) (inr (inr (y)))

reflexive-leqZ : (k : ℤ) → leqZ k k
reflexive-leqZ (inl Nzero) = star
reflexive-leqZ (inl (Nsucc x)) = reflexive-leqZ (inl x)
reflexive-leqZ (inr (inl star)) = star
reflexive-leqZ (inr (inr Nzero)) = star
reflexive-leqZ (inr (inr (Nsucc x))) = reflexive-leqZ (inr (inr x))

transitive-leqZ : (k l m : ℤ) → leqZ k l → leqZ l m → leqZ k m
transitive-leqZ (inl Nzero) (inl Nzero) m p q = q
transitive-leqZ (inl Nzero) (inl (Nsucc x)) m p q = ind-empty p
transitive-leqZ (inl Nzero) (inr (inl star)) (inl Nzero) star q =
  reflexive-leqZ (inl Nzero)
transitive-leqZ (inl Nzero) (inr (inl star)) (inl (Nsucc x)) star q =
  ind-empty q
transitive-leqZ (inl Nzero) (inr (inl star)) (inr (inl star)) star q = star
transitive-leqZ (inl Nzero) (inr (inl star)) (inr (inr x)) star q = star
transitive-leqZ (inl Nzero) (inr (inr x)) (inl y) star q = ind-empty q
transitive-leqZ (inl Nzero) (inr (inr x)) (inr (inl star)) star q =
  ind-empty q
transitive-leqZ (inl Nzero) (inr (inr x)) (inr (inr y)) star q = star
transitive-leqZ (inl (Nsucc x)) (inl Nzero) (inl Nzero) star q = star
transitive-leqZ (inl (Nsucc x)) (inl Nzero) (inl (Nsucc y)) star q =
  ind-empty q
transitive-leqZ (inl (Nsucc x)) (inl Nzero) (inr m) star q = star
transitive-leqZ (inl (Nsucc x)) (inl (Nsucc y)) (inl Nzero) p q = star
transitive-leqZ (inl (Nsucc x)) (inl (Nsucc y)) (inl (Nsucc z)) p q =
  transitive-leqZ (inl x) (inl y) (inl z) p q
transitive-leqZ (inl (Nsucc x)) (inl (Nsucc y)) (inr m) p q = star
transitive-leqZ (inl (Nsucc x)) (inr y) (inl z) star q = ind-empty q
transitive-leqZ (inl (Nsucc x)) (inr y) (inr z) star q = star
transitive-leqZ (inr k) (inl x) m p q = ind-empty p
transitive-leqZ (inr (inl star)) (inr l) (inl x) star q = ind-empty q
transitive-leqZ (inr (inl star)) (inr l) (inr m) star q = star
transitive-leqZ (inr (inr x)) (inr (inl star)) m p q = ind-empty p
transitive-leqZ (inr (inr Nzero)) (inr (inr Nzero)) m p q = q
transitive-leqZ (inr (inr Nzero)) (inr (inr (Nsucc y))) (inl x) star q =
  ind-empty q
transitive-leqZ (inr (inr Nzero)) (inr (inr (Nsucc y))) (inr (inl star))
                star q =
  ind-empty q
transitive-leqZ (inr (inr Nzero)) (inr (inr (Nsucc y))) (inr (inr z))
                star q = star
transitive-leqZ (inr (inr (Nsucc x))) (inr (inr Nzero)) m p q = ind-empty p
transitive-leqZ (inr (inr (Nsucc x))) (inr (inr (Nsucc y))) (inl z) p q =
  ind-empty q
transitive-leqZ (inr (inr (Nsucc x))) (inr (inr (Nsucc y)))
  (inr (inl star)) p q = ind-empty q
transitive-leqZ (inr (inr (Nsucc x))) (inr (inr (Nsucc y)))
  (inr (inr Nzero)) p q = ind-empty q
transitive-leqZ (inr (inr (Nsucc x))) (inr (inr (Nsucc y)))
  (inr (inr (Nsucc z))) p q =
  transitive-leqZ (inr (inr x)) (inr (inr y)) (inr (inr z)) p q

succ-leqZ : (k : ℤ) → leqZ k (Zsucc k)
succ-leqZ (inl Nzero) = star
succ-leqZ (inl (Nsucc Nzero)) = star
succ-leqZ (inl (Nsucc (Nsucc x))) = succ-leqZ (inl (Nsucc x))
succ-leqZ (inr (inl star)) = star
succ-leqZ (inr (inr Nzero)) = star
succ-leqZ (inr (inr (Nsucc x))) = succ-leqZ (inr (inr x))

leqZ-succ-leqZ : (k l : ℤ) → leqZ k l → leqZ k (Zsucc l)
leqZ-succ-leqZ k l p = transitive-leqZ k l (Zsucc l) p (succ-leqZ l)

leZ : ℤ → ℤ → U
leZ (inl Nzero) (inl x) = empty
leZ (inl Nzero) (inr y) = unit
leZ (inl (Nsucc x)) (inl Nzero) = unit
leZ (inl (Nsucc x)) (inl (Nsucc y)) = leZ (inl x) (inl y)
leZ (inl (Nsucc x)) (inr y) = unit
leZ (inr x) (inl y) = empty
leZ (inr (inl star)) (inr (inl star)) = empty
leZ (inr (inl star)) (inr (inr x)) = unit
leZ (inr (inr x)) (inr (inl star)) = empty
leZ (inr (inr Nzero)) (inr (inr Nzero)) = empty
leZ (inr (inr Nzero)) (inr (inr (Nsucc y))) = unit
leZ (inr (inr (Nsucc x))) (inr (inr Nzero)) = empty
leZ (inr (inr (Nsucc x))) (inr (inr (Nsucc y))) =
  leZ (inr (inr x)) (inr (inr y))

fam-shift-leqZ : (k : ℤ) {i : Level} (P : (l : ℤ) → leqZ k l → UU i) → (l : ℤ) → (leqZ (Zsucc k) l) → UU i
fam-shift-leqZ k P l p = P l (transitive-leqZ k (Zsucc k) l (succ-leqZ k) p)

-- ind-Z-leqZ : (k : ℤ) {i : Level} (P : (l : ℤ) → (leqZ k l) → UU i) →
--   P k (reflexive-leqZ k) →
--   ((l : ℤ) (p : leqZ k l) → P l p → P (Zsucc l) (leqZ-succ-leqZ k l p)) →
--   (l : ℤ) (p : leqZ k l) → P l p
-- ind-Z-leqZ (inl Nzero) P pk pS (inl Nzero) star = pk
-- ind-Z-leqZ (inl Nzero) P pk pS (inl (Nsucc x)) ()
-- ind-Z-leqZ (inl Nzero) P pk pS (inr (inl star)) star = pS (inl Nzero) star pk
-- ind-Z-leqZ (inl Nzero) P pk pS (inr (inr Nzero)) star = pS (inr (inl star)) star (pS (inl Nzero) star pk)
-- ind-Z-leqZ (inl Nzero) P pk pS (inr (inr (Nsucc x))) star = pS (inr (inr x)) star (ind-Z-leqZ (inl Nzero) P pk pS (inr (inr x)) star)
-- ind-Z-leqZ (inl (Nsucc Nzero)) {i} P pk pS (inl Nzero) star = pS {!!} {!!} {!!}
-- ind-Z-leqZ (inl (Nsucc (Nsucc x))) {i} P pk pS (inl Nzero) star = {!!}
-- ind-Z-leqZ (inl (Nsucc x)) P pk pS (inl (Nsucc y)) p = {!!}
-- ind-Z-leqZ (inl (Nsucc x)) P pk pS (inr y) p = {!!}
-- ind-Z-leqZ (inr k) P pk pS l p = {!!}

-- Exercise 3.11
Zpred : ℤ → ℤ
Zpred (inl x) = inl (Nsucc x)
Zpred (inr (inl star)) = inl Nzero
Zpred (inr (inr Nzero)) = inr (inl star)
Zpred (inr (inr (Nsucc x))) = inr (inr x)

-- Exercise 3.12
Zadd : ℤ → ℤ → ℤ
Zadd (inl Nzero) l = Zpred l
Zadd (inl (Nsucc x)) l = Zpred (Zadd (inl x) l)
Zadd (inr (inl star)) l = l
Zadd (inr (inr Nzero)) l = Zsucc l
Zadd (inr (inr (Nsucc x))) l = Zsucc (Zadd (inr (inr x)) l)

Zneg : ℤ → ℤ
Zneg (inl x) = inr (inr x)
Zneg (inr (inl star)) = inr (inl star)
Zneg (inr (inr x)) = inl x


module L.Base.Nat.Properties where

open import L.Base.Nat
open import L.Base.Id.Core
open import L.Base.Id.Properties using (ap;sym;transport)

-- Properties of +
+-idl : ∀{x} → zero + x ≡ x
+-idl = refl

+-idr : ∀{x} → x + zero ≡ x
+-idr {x} = ind (λ n → n + zero ≡ n) refl (λ _ p → ap succ p) x

+-assoc : {x y z : Nat} → (x + y) + z ≡ x + (y + z)
+-assoc {x}{y}{z} = ind (λ n → (n + y) + z ≡ n + (y + z))
          refl (λ _ p → ap succ p) x

+-succ : {x y : Nat} → x + succ y ≡ succ (x + y)
+-succ {x}{y} = ind (λ n → n + succ y ≡ succ (n + y)) refl (λ _ p → ap succ p) x

+-comm : {x y : Nat} → x + y ≡ y + x
+-comm {x}{y} = ind (λ n → n + y ≡ y + n) (sym +-idr) (λ n p → sym
                (transport (λ q → y + succ n ≡ succ q) (sym p) +-succ)) x

-- Properties of *
*-zl : ∀{x} → zero * x ≡ zero
*-zl = refl

*-zr : ∀{x} → x * zero ≡ zero
*-zr {x} = ind (λ n → n * zero ≡ zero) refl (λ _ p → p) x

*-idl : ∀{x} → 1 * x ≡ x
*-idl = +-idr

*-idr : ∀{x} → x * 1 ≡ x
*-idr {x} = ind (λ n → n * 1 ≡ n) refl (λ _ p → ap succ p) x

*-distrib-+ : {x y z : Nat} → (x + y) * z ≡ x * z + y * z
*-distrib-+ {x}{y}{z} = ind (λ n → (n + y) * z ≡ n * z + y * z) refl
                        (λ m p → transport (λ s → z + (m + y) * z ≡ s)
                        (sym (+-assoc {z} {m * z} {y * z}))
                        (ap (λ k → z + k) p)) x

*-assoc : {x y z : Nat} → (x * y) * z ≡ x * (y * z)
*-assoc {x}{y}{z} = ind (λ n → (n * y) * z ≡ n * (y * z)) refl (λ n p
                    → transport (λ q → (y + n * y) * z ≡ y * z + q) p
                    (*-distrib-+ {y}{n * y})) x


module plfa.part1.Negation where

open import Relation.Binary.PropositionalEquality using (_≡_; refl)
open import Data.Nat using (ℕ; zero; suc; _<_)
open import Data.Empty using (⊥; ⊥-elim)
open import Data.Sum using (_⊎_; inj₁; inj₂)
open import Data.Product using (_×_; _,_)
open import plfa.part1.Isomorphism using (_≃_; extensionality)

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

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

infix 3 ¬_

¬¬-intro : ∀ {A : Set}
  → A
    -----
  → ¬ ¬ A
¬¬-intro x  =  λ{¬x → ¬x x}

¬¬¬-elim : ∀ {A : Set}
  → ¬ ¬ ¬ A
    -------
  → ¬ A
¬¬¬-elim ¬¬¬x  =  λ x → ¬¬¬x (¬¬-intro x)

contraposition : ∀ {A B : Set}
  → (A → B)
    -----------
  → (¬ B → ¬ A)
contraposition f ¬y x = ¬y (f x)

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

_ : 1 ≢ 2
_ = λ()

peano : ∀ {m : ℕ} → zero ≢ suc m
peano = λ()

id : ⊥ → ⊥
id x = x

id′ : ⊥ → ⊥
id′ ()

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

assimilation' : ∀ {A : Set} {¬x ¬x′ : ¬ A} → ¬x ≡ ¬x′
assimilation' {A} {¬x} {¬x′} = assimilation ¬x ¬x′

<-irreflexive : ∀ {n : ℕ} → ¬ (n < n)
<-irreflexive (Data.Nat.s≤s x) = <-irreflexive x

⊎-dual-× : ∀ {A B : Set} → ¬ (A ⊎ B) ≃ (¬ A) × (¬ B)
⊎-dual-× = record {
                  to = λ {x → (λ z → x (inj₁ z)) , λ x₁ → x (inj₂ x₁) };
                  from = λ { (fst , snd) (inj₁ x) → fst x ;
                             (fst , snd) (inj₂ y) → snd y} ;
                  from∘to = λ {¬x → assimilation'} ;
                  to∘from = λ { (fst , snd) → refl} }


module 110-natural-model where

open import 010-false-true
open import 020-equivalence
open import 100-natural

-- We prove that there is a model of the naturals within Agda's lambda
-- calculus. This also shows that the Peano axioms are consistent.

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

thm-ℕ-is-natural : Natural zero suc _≡_
thm-ℕ-is-natural = record {
  equiv = thm-≡-is-equivalence;
  sucn!=zero = sucn!=zero;
  sucinjective = sucinjective;
  cong = cong;
  induction = induction
  }
  where
    sucn!=zero : ∀ {r} -> suc r ≡ zero -> False
    sucn!=zero ()
    sucinjective : ∀ {r s} -> suc r ≡ suc s -> r ≡ s
    sucinjective refl = refl
    cong : ∀ {r s} -> r ≡ s -> suc r ≡ suc s
    cong refl = refl

    -- This is the only tricky bit: proving the principle of induction.
    induction : (p : ℕ -> Set) -> p zero -> (∀ n -> p n -> p (suc n)) -> ∀ n -> p n
    -- We first prove that p n holds for n equal to zero. This is just
    -- the base case.
    induction p base hypothesis zero = base
    -- Then we prove that p (suc n) holds, using induction on n, that is,
    -- we may assume that p n is proven, or more precisely, that
    -- "induction p base hypothesis n" is a proof of p n.
    induction p base hypothesis (suc n) =
      hypothesis n (induction p base hypothesis n)