-- binary search trees (not balanced)

open import bool
open import bool-thms2
open import eq
open import maybe
open import product
open import product-thms
open import bool-relations using (transitive ; total)

module bst (A : Set) (_≤A_ : A → A → 𝔹)
           (≤A-trans : transitive _≤A_)
           (≤A-total : total _≤A_) where

open import bool-relations _≤A_ hiding (transitive ; total)
open import minmax _≤A_ ≤A-trans ≤A-total

data bst : A → A → Set where
  bst-leaf : ∀ {l u : A} → l ≤A u ≡ tt → bst l u
  bst-node : ∀ {l l' u' u : A}(d : A) →
               bst l' d → bst d u' →
               l ≤A l' ≡ tt → u' ≤A u ≡ tt →
               bst l u

-- find a node which is isomorphic (_=A_) to d and return it; or else return nothing
bst-search : ∀{l u : A}(d : A) → bst l u → maybe (Σ A (λ d' → d iso𝔹 d' ≡ tt))
bst-search d (bst-leaf _) = nothing
bst-search d (bst-node d' L R _ _) with keep (d ≤A d')
bst-search d (bst-node d' L R _ _) | tt , p1 with keep (d' ≤A d)
bst-search d (bst-node d' L R _ _) | tt , p1 | tt , p2 = just (d' , iso𝔹-intro p1 p2)
bst-search d (bst-node d' L R _ _) | tt , p1 | ff , p2 = bst-search d L
bst-search d (bst-node d' L R _ _) | ff , p1 = bst-search d R

bst-dec-lb : ∀ {l l' u' : A} → bst l' u' → l ≤A l' ≡ tt → bst l u'
bst-dec-lb (bst-leaf p) q = bst-leaf (≤A-trans q p)
bst-dec-lb (bst-node d L R p1 p2) q = bst-node d L R (≤A-trans q p1) p2

bst-inc-ub : ∀ {l' u' u : A} → bst l' u' → u' ≤A u ≡ tt → bst l' u
bst-inc-ub (bst-leaf p) q = bst-leaf (≤A-trans p q)
bst-inc-ub (bst-node d L R p1 p2) q = bst-node d L R p1 (≤A-trans p2 q)

bst-insert : ∀{l u : A}(d : A) → bst l u → bst (min d l) (max d u)
bst-insert d (bst-leaf p) = bst-node d (bst-leaf ≤A-refl) (bst-leaf ≤A-refl) min-≤1 max-≤1
bst-insert d (bst-node d' L R p1 p2) with keep (d ≤A d')
bst-insert d (bst-node d' L R p1 p2) | tt , p with bst-insert d L
bst-insert d (bst-node d' L R p1 p2) | tt , p | L' rewrite p =
  bst-node d' L' (bst-inc-ub R (≤A-trans p2 max-≤2)) (min2-mono p1) ≤A-refl
bst-insert d (bst-node d' L R p1 p2) | ff , p with bst-insert d R
bst-insert d (bst-node d' L R p1 p2) | ff , p | R' rewrite p =
  bst-node d' (bst-dec-lb L p1) R' min-≤2 (max2-mono p2)


module Numeral.Matrix.Relations where

open import Data.Tuple as Tuple using (_,_)
open import Logic.Predicate
open import Logic
open import Numeral.Matrix hiding (module SquareMatrix)
open import Numeral.Matrix.OverField
import      Relator.Equals as Eq
open import Structure.Operator.Field
open import Structure.Operator.Monoid
open import Structure.Operator.Properties
open import Structure.Setoid
open import Syntax.Function
open import Type

module SquareMatrix {ℓ ℓₑ} {d} {T : Type{ℓ}} ⦃ equiv : Equiv{ℓₑ}(T) ⦄ where
  record Symmetric(M : SquareMatrix(d)(T)) : Stmt{ℓₑ} where
    constructor intro
    field proof : ∀{x y} → Matrix.proj M(x , y) ≡ Matrix.proj M(y , x)

  module _ {_▫_ : T → T → T} ⦃ monoid : Monoid(_▫_) ⦄ where
    record Diagonal(M : SquareMatrix(d)(T)) : Stmt{ℓₑ} where
      constructor intro
      field proof : ∀{x y} → (x Eq.≢ y) → (Matrix.proj M(x , y) ≡ Monoid.id monoid)

    record Scalar (s : T) (M : SquareMatrix(d)(T)) : Stmt{ℓₑ} where
      constructor intro
      field
        ⦃ diagonal ⦄ : Diagonal(M)
        proof : ∀{x} → (Matrix.proj M(x , x) ≡ s)

  module _ {_+ₛ_ _⋅ₛ_ : T → T → T} ⦃ field-structure : Field(_+ₛ_)(_⋅ₛ_) ⦄ where
    record Similar(A B : SquareMatrix(d)(T)) : Stmt{ℓₑ} where
      constructor intro
      field proof : ∃(P ↦ ∃{Obj = Invertible(P)}(inver ↦ B ≡ inv(P) ⨯ A ⨯ P))

    record Diagonalizable(M : SquareMatrix(d)(T)) : Stmt{ℓₑ} where
      constructor intro
      field proof : ∃(P ↦ ∃{Obj = Invertible(P)}(inver ↦ Diagonal(inv(P) ⨯ M ⨯ P)))


{-

        Agda Implementors' Meeting VI

                  Göteborg
             May 24 - 30, 2007

                Hello Agda!

                Ulf Norell

-}

-- Something which is rather useful is the ability to pattern match
-- on intermediate computations. That's where the with-construct comes
-- in.

module TestWith where

-- open import Nat
open import PreludeNat hiding(_==_; even; odd)
open import PreludeShow

{-

  Basic idea

-}

-- The basic principle is that you can add argument to your
-- function on the fly. For instance,

data Maybe (A : Set) : Set where
  nothing : Maybe A
  just    : A -> Maybe A

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

compare : (n m : Nat) -> Maybe (n == m)
compare  zero   zero   = just refl
compare (suc _) zero   = nothing
compare  zero  (suc _) = nothing
compare (suc n)(suc m) with compare n m
compare (suc n)(suc .n) | just refl = just refl
compare (suc n)(suc m)  | nothing   = nothing

-- To add more than one argument separate by |
silly : Nat -> Nat
silly zero = zero
silly (suc n) with n | n
silly (suc n) | zero | suc m = m  -- the values of the extra argument are
                                  -- not taken into consideration
silly (suc n) | _    | _     = n

{-

  The parity example

-}

-- This is a cute example of what you can do with with.

data Parity : Nat -> Set where
  even : (k : Nat) -> Parity (k * 2)
  odd  : (k : Nat) -> Parity (1 + k * 2)

parity : (n : Nat) -> Parity n
parity zero = even 0
parity (suc n) with parity n
parity (suc .(    k * 2)) | even k = odd k
parity (suc .(1 + k * 2)) | odd  k = even (suc k)

half : Nat -> Nat
half n with parity n
half .(    k * 2) | even k = k
half .(1 + k * 2) | odd  k = k

mainS = showNat (half 44)
{-

  What's next?

-}

-- Move on to: Modules.agda


------------------------------------------------------------------------
-- The Agda standard library
--
-- Divisibility and coprimality
------------------------------------------------------------------------

module Data.Integer.Divisibility where

open import Function
open import Data.Integer
open import Data.Integer.Properties
import Data.Nat.Divisibility as ℕ
import Data.Nat.Coprimality as ℕ
open import Level
open import Relation.Binary
open import Relation.Binary.PropositionalEquality

-- Divisibility.

infix 4 _∣_

_∣_ : Rel ℤ zero
_∣_ = ℕ._∣_ on ∣_∣

-- Coprimality.

Coprime : Rel ℤ zero
Coprime = ℕ.Coprime on ∣_∣

-- If i divides jk and is coprime to j, then it divides k.

coprime-divisor : ∀ i j k → Coprime i j → i ∣ j * k → i ∣ k
coprime-divisor i j k c eq =
  ℕ.coprime-divisor c (subst (ℕ._∣_ ∣ i ∣) (abs-*-commute j k) eq)


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

module SetoidEquiv where

open import Level using (Level; _⊔_)
open import Function.Equality using (_∘_; _⟶_; _⟨$⟩_)
open import Relation.Binary using (Setoid; module Setoid)
open import Relation.Binary.PropositionalEquality as P using (setoid)

open Setoid

infix 4 _≃S_

------------------------------------------------------------------------------
-- A setoid gives us a set and an equivalence relation on that set.
-- A common equivalence relation that is used on setoids is ≡

-- In general, two setoids are equivalent if:

record _≃S_ {ℓ₁ ℓ₂ ℓ₃ ℓ₄ : Level} (A : Setoid ℓ₁ ℓ₂) (B : Setoid ℓ₃ ℓ₄) :
  Set (ℓ₁ ⊔ ℓ₂ ⊔ ℓ₃ ⊔ ℓ₄) where
  constructor equiv
  field
    f : A ⟶ B
    g : B ⟶ A
    α : ∀ {x y} → _≈_ B x y → _≈_ B ((f ∘ g) ⟨$⟩ x) y
    β : ∀ {x y} → _≈_ A x y → _≈_ A ((g ∘ f) ⟨$⟩ x) y

-- Abbreviation for the special case in which the equivalence relation
-- is just ≡:

_≃S≡_ : ∀ {ℓ₁} → (A B : Set ℓ₁) → Set ℓ₁
A ≃S≡ B = (P.setoid A) ≃S (P.setoid B)

-- Two equivalences between setoids are themselves equivalent if

record _≋_ {ℓ₁} {A B : Set ℓ₁} (eq₁ eq₂ : A ≃S≡ B) : Set ℓ₁ where
  constructor equivS
  field
    f≡ : ∀ (x : A) → P._≡_ (_≃S_.f eq₁ ⟨$⟩ x) (_≃S_.f eq₂ ⟨$⟩ x)
    g≡ : ∀ (x : B) → P._≡_ (_≃S_.g eq₁ ⟨$⟩ x) (_≃S_.g eq₂ ⟨$⟩ x)
    -- note that this appears to be redundant (especially when looking
    -- at the proofs), but having both f and g is needed for inference
    -- of other aspects to succeed.

id≋ : ∀ {ℓ} {A B : Set ℓ} {x : A ≃S≡ B} → x ≋ x
id≋ = record { f≡ = λ x → P.refl ; g≡ = λ x → P.refl }

sym≋ : ∀ {ℓ} {A B : Set ℓ} {x y : A ≃S≡ B} → x ≋ y → y ≋ x
sym≋ (equivS f≡ g≡) = equivS (λ a → P.sym (f≡ a)) (λ b → P.sym (g≡ b))

trans≋ : ∀ {ℓ} {A B : Set ℓ} {x y z : A ≃S≡ B} → x ≋ y → y ≋ z → x ≋ z
trans≋ (equivS f≡ g≡) (equivS h≡ i≡) =
   equivS (λ a → P.trans (f≡ a) (h≡ a)) (λ b → P.trans (g≡ b) (i≡ b))

-- The set of equivalences between setoids is itself is a setoid
-- WARNING: this is not generic, but specific to ≡-Setoids of functions.

≃S-Setoid : ∀ {ℓ₁} → (A B : Set ℓ₁) → Setoid ℓ₁ ℓ₁
≃S-Setoid {ℓ₁} A B = record
  { Carrier = AS ≃S BS
  ; _≈_ = _≋_
  ; isEquivalence = record
    { refl = id≋
    ; sym = sym≋
    ; trans = trans≋
    }
  }
  where
    open _≃S_
    AS = P.setoid A
    BS = P.setoid B

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


module z01-fp-with-booleans where

open import bool

{-
data 𝔹 : Set where
  tt : 𝔹
  ff : 𝔹

˜_ : 𝔹 → 𝔹
˜ tt = ff
˜ ff = tt

if_then_else_ : ∀ {ℓ} {A : Set ℓ} → 𝔹 → A → A → A
if tt then t else f = t
if ff then t else f = f
-}

-- load / type-check file
-- C-c, C-l

-- check type of expression
-- C-c, C-d ; then prompt for expression

------------------------------------------------------------------------------
-- p 24 1.8 Exercises

z01-1-8-01a : 𝔹
z01-1-8-01a = tt && (ff xor ~ ff)

z01-1-8-01b : 𝔹
z01-1-8-01b = ~ tt && (ff imp ff)

z01-1-8-01c : 𝔹
z01-1-8-01c = if tt xor tt then ff else ff

-- 1-8-4
data day : Set where
 mon : day
 tue : day
 wed : day
 thu : day
 fri : day
 sat : day
 sun : day

-- 1-8-5
nextday : day → day
nextday mon = tue
nextday tue = wed
nextday wed = thu
nextday thu = fri
nextday fri = sat
nextday sat = sun
nextday sun = mon

-- 1-8-6
data suit : Set where
  hearts   : suit
  spades   : suit
  diamonds : suit
  clubs    : suit

-- 1-8-7
is-red : suit → 𝔹
is-red hearts   = tt
is-red spades   = ff
is-red diamonds = tt
is-red clubs    = ff


import Relation.Binary.PropositionalEquality as Eq
open Eq using (_≡_; refl; cong)
open Eq.≡-Reasoning using (begin_; _≡⟨⟩_; _≡⟨_⟩_; _∎)
open import Data.Nat using (ℕ; zero; suc)

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

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

{-
Goal: ℕ
————————————————————————————————————————————————————————————
n : ℕ
-}

{-
Goal: ℕ
————————————————————————————————————————————————————————————
n : ℕ
m : ℕ
-}


-- Problem 2: Multiplication for matrices (from the matrix algebra DSL).

module P2 where

-- 2a: Type the variables in the text.
-- (This answer uses Agda syntax, but that is not required.)

postulate Nat : Set
postulate V : Nat -> Set -> Set
postulate Fin : Nat -> Set

Op : Set -> Set
Op a = a -> a -> a

postulate sum : {n : Nat} {a : Set} -> Op a -> V n a -> a
postulate zipWith : {n : Nat} {a : Set} -> Op a -> V n a -> V n a -> V n a

data M (m n : Nat) (a : Set) : Set where
  matrix : (Fin m -> Fin n -> a) -> M m n a

record Dummy (a : Set) : Set where
  field
    m : Nat
    n : Nat
    A : M m n a
    p : Nat
    B : M n p a
    i : Fin m
    j : Fin p

-- 2b: Type |mul| and |proj|

postulate
  proj : {m n : Nat} {a : Set} -> Fin m -> Fin n -> M m n a -> a

mul  : {m n p : Nat} {a : Set} -> Op a -> Op a ->
       M m n a -> M n p a -> M m p a

-- 2c: Implement |mul|.

postulate
  row : {m n : Nat} {a : Set} -> Fin m -> M m n a -> V n a
  col : {m n : Nat} {a : Set} -> Fin n -> M m n a -> V m a

mul addE mulE A B = matrix (\i j ->
                      sum addE (zipWith mulE (row i A) (col j B)))


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

open import Functions.Definition
open import Rings.Homomorphisms.Definition
open import Groups.Homomorphisms.Definition
open import Setoids.Setoids
open import Rings.Definition
open import Sets.EquivalenceRelations
open import Groups.QuotientGroup.Definition

module Rings.Quotients.Definition {a b c d : _} {A : Set a} {B : Set b} {S : Setoid {a} {c} A} {T : Setoid {b} {d} B} {_+A_ _*A_ : A → A → A} {_+B_ _*B_ : B → B → B} (R : Ring S _+A_ _*A_) (R2 : Ring T _+B_ _*B_) {underf : A → B} (f : RingHom R R2 underf) where

open import Groups.QuotientGroup.Lemmas (Ring.additiveGroup R) (Ring.additiveGroup R2) (RingHom.groupHom f)

quotientByRingHom : Ring (quotientGroupSetoid (Ring.additiveGroup R) (RingHom.groupHom f)) _+A_ _*A_
Ring.additiveGroup quotientByRingHom = quotientGroupByHom (Ring.additiveGroup R) (RingHom.groupHom f)
Ring.*WellDefined quotientByRingHom fr=ft fs=fu = quotientGroupLemma (Ring.additiveGroup R) (RingHom.groupHom f) (transitive (RingHom.ringHom f) (transitive (Ring.*WellDefined R2 (quotientGroupLemma' (Ring.additiveGroup R) (RingHom.groupHom f) fr=ft) (quotientGroupLemma' (Ring.additiveGroup R) (RingHom.groupHom f) fs=fu)) (symmetric (RingHom.ringHom f))))
  where
    open Setoid T
    open Equivalence eq
Ring.1R quotientByRingHom = Ring.1R R
Ring.groupIsAbelian quotientByRingHom = quotientGroupLemma (Ring.additiveGroup R) (RingHom.groupHom f) (GroupHom.wellDefined (RingHom.groupHom f) (Ring.groupIsAbelian R))
Ring.*Associative quotientByRingHom = quotientGroupLemma (Ring.additiveGroup R) (RingHom.groupHom f) (GroupHom.wellDefined (RingHom.groupHom f) (Ring.*Associative R))
Ring.*Commutative quotientByRingHom = quotientGroupLemma (Ring.additiveGroup R) (RingHom.groupHom f) (GroupHom.wellDefined (RingHom.groupHom f) (Ring.*Commutative R))
Ring.*DistributesOver+ quotientByRingHom = quotientGroupLemma (Ring.additiveGroup R) (RingHom.groupHom f) (GroupHom.wellDefined (RingHom.groupHom f) (Ring.*DistributesOver+ R))
Ring.identIsIdent quotientByRingHom = quotientGroupLemma (Ring.additiveGroup R) (RingHom.groupHom f) (GroupHom.wellDefined (RingHom.groupHom f) (Ring.identIsIdent R))

projectionMapIsHom : RingHom R quotientByRingHom id
RingHom.preserves1 projectionMapIsHom = quotientGroupLemma (Ring.additiveGroup R) (RingHom.groupHom f) (Equivalence.reflexive (Setoid.eq T))
RingHom.ringHom projectionMapIsHom = quotientGroupLemma (Ring.additiveGroup R) (RingHom.groupHom f) (Equivalence.reflexive (Setoid.eq T))
RingHom.groupHom projectionMapIsHom = projectionMapIsGroupHom


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

open import Relation.Binary.Core

module Definitions
  {a ℓ} {A : Set a}   -- The underlying set
  (_≈_ : Rel A ℓ)     -- The underlying equality
  where

open import Algebra.Core
open import Data.Product
open import Algebra.Definitions

-- (x²y)x = x²(yx)
JordanIdentity: : Op₂ A → Set _
JordanIdentity: _∙_ = ∀ x y → (((x ∙ x) ∙ y) ∙ x) ≈ (((x ∙ x) ∙ y) ∙ x)

-- x = xyx
PesudoInverse₁ : Op₂ A → Set _
PesudoInverse₁ _∙_ = ∀ x y → ((x ∙ y) ∙ x) ≈ x

-- y = yxy
PseudoInverse₂ : Op₂ A → Set _
PseudoInverse₂ _∙_ = ∀ x y → ((y ∙ x) ∙ y) ≈ y

PseudoInverse : Op₂ A → Set _
PseudoInverse ∙ = (PesudoInverse₁ ∙) × (PseudoInverse₂ ∙)

-- JacobiIdentity is (x ∙ (y ∙ z)) + ((y ∙ (z ∙ x)) + (z ∙ (x ∙ y))) = 0
-- Using the antisymmetry property Jacobi identity may be rewritten as a modification of the associative property

JacobiIdentity : Op₂ A → Op₂ A → Set _
JacobiIdentity _∙_  _-_ = ∀ x y z → (x ∙ (y ∙ z)) ≈ ((y ∙ (z ∙ x)) - (z ∙ (x ∙ y)))


module Human.Nat where

open import Human.Bool

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

{-# BUILTIN NATURAL Nat #-}

infix  4 _==_ _<_
infixl 6 _+_ _-_
infixl 7 _*_
-- add theses guys on infixl 7: _div_ _%_

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

{-# BUILTIN NATPLUS _+_ #-}

_-_ : Nat → Nat → Nat
n     - zero = n
zero  - suc m = zero
suc n - suc m = n - m

{-# BUILTIN NATMINUS _-_ #-}

_*_ : Nat → Nat → Nat
zero  * m = zero
suc n * m = m + n * m

{-# BUILTIN NATTIMES _*_ #-}

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

{-# BUILTIN NATEQUALS _==_ #-}

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

{-# BUILTIN NATLESS _<_ #-}

div-helper : (k m n j : Nat) → Nat
div-helper k m  zero    j      = k
div-helper k m (suc n)  zero   = div-helper (suc k) m n m
div-helper k m (suc n) (suc j) = div-helper k       m n j

{-# BUILTIN NATDIVSUCAUX div-helper #-}

mod-helper : (k m n j : Nat) → Nat
mod-helper k m  zero    j      = k
mod-helper k m (suc n)  zero   = mod-helper 0       m n m
mod-helper k m (suc n) (suc j) = mod-helper (suc k) m n j

{-# BUILTIN NATMODSUCAUX mod-helper #-}


module Sec2 where
open import Sec4
data Bool : Set where
  T : Bool
  F : Bool

_∣∣_ : Bool → Bool → Bool
_ ∣∣ F = F
_ ∣∣ T = T

_&_ : Bool → Bool → Bool
_ & F = F
F & T = F
T & T = T

_==>_ : Bool → Bool → Bool
F ==> _ = T
T ==> F = F
T ==> T = T

not : Bool -> Bool
not T = F
not F = T

data ℕ : Set where
  Z : ℕ
  S : ℕ → ℕ

_+_ : ∀ (m : ℕ) → ∀ (n : ℕ) → ℕ
Z + m = m
(S n) + m = S (n + m)

_*_ : ℕ → ℕ → ℕ
Z * m = Z
(S n) * m = (n * m) + m

{-# BUILTIN NATURAL ℕ #-}
{-# BUILTIN BOOL Bool #-}

_≤_ : ℕ → ℕ → Bool
Z ≤ _ = T
(S n) ≤ Z = F
(S n) ≤ (S m) = n ≤ m

_<_ : ℕ → ℕ → Bool
Z < (S _) = T
Z < Z = F
(S n) < (S m) = n < m
(S n) < Z = F

_≥_ : ℕ → ℕ → Bool
m ≥ n = n ≤ m

_>_ : ℕ → ℕ → Bool
m > n = n < m

-- XXX: == on Nat
_==_ : ℕ → ℕ → Bool
x == y = (x ≥ y) & (x ≤ y)

_-_ : ℕ → ℕ → ℕ
Z - _ = Z
(S n) - Z = (S n)
(S n) - (S m) = n - m

K : {A B : Set} → A → B → A
K x _ = x

SC : {A B C : Set} → (A → B → C) → (A → B) → A → C
SC f g x = f x (g x)

-- XXX: The list type
data List (A : Set) : Set where
  []  : List A
  _∷_ : A → List A → List A

length : {A : Set} → List A → ℕ
length [] = Z
length (x ∷ m) = 1 + length m

test : List ℕ
test = 2 ∷ (3 ∷ [])

test1 : ℕ
test1 = length test

data So : Bool → Set where
  ok : So T

private head : {A : Set} → (x : List A) → So ((length x) ≥ 1) → A
head [] ()
head (x ∷ x₁) _ = x

private tail : {A : Set} → (x : List A) → So ((length x) ≥ 1) → List A
tail [] ()
tail (x ∷ x₁) _ = x₁

if_then_else_ : {A : Set} → Bool → A → A → A
if T then x else _ = x
if F then _ else y = y

private filter : {A : Set} → (A → Bool) → List A → List A
filter cmp [] = []
filter cmp (x ∷ x₁) = if (cmp x)
                      then x ∷ (filter cmp x₁)
                      else filter cmp x₁

_++_ : {A : Set} →  List A → List A → List A
[] ++ r = r
(x ∷ l) ++ r = x ∷ (l ++ r)

insert : (a : ℕ) → (List ℕ) → (List ℕ)
insert a [] = (a ∷ [])
insert a (x ∷ l) = if (a ≤ x)
                   then (a ∷ (x ∷ l))
                   else (x ∷ (insert a l))

tt2 : List ℕ
tt2 = insert 9 (0 ∷ (8 ∷ []))

private foldl : {A : Set} → (A → A → A) → List A → A → A
foldl _ [] y = y
foldl f (x ∷ x₁) y = foldl f x₁ (f x y)

-- XXX: injective tuple
data _+′_  (A B : Set) : Set where
  inl : (x : A) → A +′ B
  inr : (x : B) → A +′ B

case : {A B C : Set} → (A +′ B) → (f₁ : (A → C)) → (f₂ : (B → C)) → C
case (inl x) f₁ _ = f₁ x
case (inr x) _ f₂ = f₂ x

-- XXX: Proof of transitivity of >
T> : (a b c : ℕ) → So (a > b) → So (b > c) → So (a > c)
T> Z Z Z () y
T> Z Z (S c) () y
T> Z (S b) c () y
T> (S a) Z Z ok ()
T> (S a) Z (S c) ok ()
T> (S a) (S b) Z x y = ok
T> (S a) (S b) (S c) x y = T> a b c x y

-- XXX: Tuple type
data _Π_ (A B : Set) : Set where
  <_,_> : (x : A) → (y : B) → A Π B

private zip : {A B : Set} → (xs : List A) → (ys : List B) → So ((length xs) == (length ys)) → List (A Π B)
zip [] [] k = []
zip [] (x ∷ ys) ()
zip (x ∷ xs) [] ()
zip (x ∷ xs) (y ∷ ys) k = < x , y > ∷ zip xs ys k

-- TODO: Write unzip later on
-- unzip : {A B : Set} → List (A Π B) → (List A Π List B)
-- unzip xs = {!!}

test5 : List (ℕ Π ℕ)
test5 = zip ((1 ∷ [])) (2 ∷ []) ok

infix 4 _≡_
data _≡_ {a} {A : Set a} (x : A) : A → Set a where
  refl : x ≡ x
{-# BUILTIN EQUALITY _≡_  #-}
{-# BUILTIN REFL     refl #-}

-- XXX: Transitivity of ℕ
ℕ-trans : ∀ {x y z : ℕ} → (x ≡ y) → (y ≡ z) → (x ≡ z)
ℕ-trans refl refl = refl

-- XXX: Symmetry of ℕ
sym : ∀ {x y : ℕ} → (x ≡ y) → (y ≡ x)
sym refl = refl

-- XXX: Congruence of ℕ
cong : ∀ {x y : ℕ} → (x ≡ y) → (1 + x) ≡ (1 + y)
cong refl = refl

plus-z : ∀ (y : ℕ) → ((y + Z) ≡ y)
plus-z Z = refl
plus-z (S y) = cong (plus-z y)

assoc-+ : ∀ (a b c : ℕ) → ((a + b) + c) ≡ (a + (b + c))
assoc-+ Z y z = refl
assoc-+ (S x) y z = cong (assoc-+ x y z)

t1 : ∀ (x y : ℕ) → (x + S y) ≡ S (x + y)
t1 Z y = refl
t1 (S x) y = cong (t1 x y)

-- See this: https://github.com/dvanhorn/play/blob/master/agda/Rewrite.agda
-- for examples of rewrite.
-- Also read: http://agda.readthedocs.io/en/latest/language/with-abstraction.html#generalisation
commute-+ : ∀ (x y : ℕ) → ((x + y) ≡ (y + x))
commute-+ Z y rewrite plus-z y = refl
commute-+ (S x) y rewrite t1 y x = cong (commute-+ x y)

mult-z : ∀ (y : ℕ) → ((y * Z) ≡ Z)
mult-z Z = refl
mult-z (S y) rewrite plus-z (y * Z) = mult-z y

lemma-1 : ∀ {a b : ℕ} → ∀ (n : ℕ) → (a ≡ b) → (n + a ≡ n + b)
lemma-1 _ refl = refl

c-* : ∀ (m n : ℕ) → (m * S n) ≡ (m * n) + m
c-* Z n rewrite commute-+ (n * Z) Z
                | mult-z n = refl
c-* (S m) n rewrite
            commute-+ (m * S n) (S n)
            | commute-+ ((m * n) + n) (S m)
            | commute-+ m ((m * n) + n)
            | assoc-+ (m * n) n m
            | commute-+  (m * n) (n + m)
            | assoc-+ n m (m * n)
            | commute-+ m (m * n)
            = cong (lemma-1 n (c-* m n))

commute-* : ∀ (m n : ℕ) → (m * n) ≡ (n * m)
commute-* m Z = mult-z m
commute-* m (S n) rewrite c-* m n
                          | commute-+ (m * n) m
                          | commute-+ (n * m) m = lemma-1 m (commute-* m n)

lemma-2 : ∀ (m n x : ℕ) → (m + n) * x ≡ ((m * x) + (n * x))
lemma-2 m n Z rewrite mult-z (m + n)
              | mult-z m
              | mult-z n = refl
lemma-2 m n (S x) rewrite c-* (m + n) x
                  | c-* m x
                  | c-* n x
                  | assoc-+ (m * x) m ((n * x) + n)
                  | commute-+ m ((n * x) + n)
                  | assoc-+ (n * x) n m
                  | commute-+ n m
                  | commute-+ (n * x) (m + n)
                  | commute-+ (m * x) ((m + n) + (n * x))
                  | assoc-+ (m + n) (n * x) (m * x)
                  | commute-+ (m + n) ((n * x) + (m * x))
                  | commute-+ (n * x) (m * x)
                  | commute-+ ((m * x) + (n * x)) (m + n)
                  | commute-+ ((m + n) * x) (m + n) = lemma-1 (m + n) (lemma-2 m n x)

assoc-* : ∀ (a b c : ℕ) → ((a * b) * c) ≡ (a * (b * c))
assoc-* Z b c = refl
assoc-* (S a) b c rewrite lemma-2 (a * b) b c
                  | commute-+ ((a * b) * c) (b * c)
                  | commute-+ (a * (b * c)) (b * c) = lemma-1 (b * c) (assoc-* a b c)

distributivity-+-* : ∀ (a b c : ℕ) → (a * (b + c)) ≡ ((a * b) + (a * c))
distributivity-+-* a b c rewrite commute-* a (b + c)
                         | commute-* a b
                         | commute-* a c
                         | lemma-2 b c a = refl

-- XXX: factorial function on naturals
fact : ∀ (x : ℕ) → ℕ
fact Z = (S Z)
fact (S Z) = (S Z)
fact (S x) = x * (fact x)

-- TODO: Relation on ℕ and >
_>⋆_ : ℕ → ℕ → Prop
Z >⋆ Z = ⊥
S x >⋆ Z = ⊤
Z >⋆ S y = ⊥
S x >⋆ S y = x >⋆ y

lem : (m n : ℕ) → (p : n >⋆ Z) → (m + n) >⋆ 0
lem Z n p = p
lem (S m) n p = ⋆

-- XXX: Theorem; factorial of any natural number is > 0
-- XXX: page-124, problem 4.35, Type Theory and functional programming
thm : ∀ (x : ℕ) → (fact x) >⋆ Z
thm Z = ⋆
thm (S Z) = ⋆
thm (S (S x)) = lem (x * fact (S x)) (fact (S x)) (thm (S x))

_<=_ : ∀ (m n : ℕ) → Prop
Z <= n = ⊤
S m <= Z = ⊥
S m <= S n = m <= n

-- symm : ∀ (m n : ℕ) → (p : m <= n) → (n <= m)
-- symm Z Z p = ⋆
-- symm Z (S n) p = {!!}
-- symm (S m) Z p = ⋆
-- symm (S m) (S n) p = symm m n p

transm : ∀ (m n p : ℕ) → (m <= n) → (n <= p) → (m <= p)
transm Z n p p1 p2 = ⋆
transm (S m) Z Z p1 p2 = p1
transm (S m) (S n) Z p1 p2 = p2
transm (S m) Z (S p) () p2
transm (S m) (S n) (S p) p1 p2 = transm m n p p1 p2

-- Show that 2 + 3 ≡ 3 + 2
eqq : 2 + 3 ≡ 3 + 2
eqq = refl


-- Decidability in the context of types means that it is possible to decide whether a type is empty or have inhabitants.
-- In the case of it having inhabitants, it is possible to extract a witness of the type.
-- Note: When using the types as propositions interpretation of types as a logic system, decidability is equivalent to excluded middle.
module Type.Properties.Decidable where

open import Data
open import Data.Tuple.RaiseTypeᵣ
import      Lvl
import      Lvl.MultiFunctions as Lvl
open import Data.Boolean using (Bool ; 𝑇 ; 𝐹)
open import Function.Multi
open import Logic.Predicate
open import Numeral.Natural
open import Type

private variable ℓ ℓₚ : Lvl.Level
private variable A B C P Q : Type{ℓ}

-- Decider₀(P)(b) states that the boolean value b decides whether the type P is empty or inhabited.
-- When interpreting P as a proposition, the boolean value b decides the truth value of P.
-- Base case of Decider.
data Decider₀ {ℓ} (P : Type{ℓ}) : Bool → Type{Lvl.𝐒(ℓ)} where
  true  : P                  → Decider₀(P)(𝑇)
  false : (P → Empty{Lvl.𝟎}) → Decider₀(P)(𝐹)

-- Elimination rule of Decider₀.
elim : ∀{P} → (Proof : ∀{b} → Decider₀{ℓₚ}(P)(b) → Type{ℓ}) → ((p : P) → Proof(true p)) → ((np : P → Empty) → Proof(false np)) → (∀{b} → (d : Decider₀(P)(b)) → Proof(d))
elim _ fp fnp (true  p)  = fp p
elim _ fp fnp (false np) = fnp np

step : ∀{f : Bool → Bool} → (P → Decider₀(Q)(f(𝑇))) → ((P → Empty) → Decider₀(Q)(f(𝐹))) → (∀{b} → Decider₀(P)(b) → Decider₀(Q)(f(b)))
step{f = f} = elim (\{b} _ → Decider₀(_)(f(b)))

-- Decider(n)(P)(f) states that the values of the n-ary function f decides whether the values of P is empty or inhabited for a given number of arguments.
-- When interpreting P as an n-ary predicate (proposition), the n-ary function f decides the truth values of P.
Decider : (n : ℕ) → ∀{ℓ}{ℓ𝓈}{As : Types{n}(ℓ𝓈)} → (As ⇉ Type{ℓ}) → (As ⇉ Bool) → Type{Lvl.𝐒(ℓ) Lvl.⊔ Lvl.⨆(ℓ𝓈)}
Decider(0)           = Decider₀
Decider(1)       P f = ∀{x} → Decider₀(P(x))(f(x))
Decider(𝐒(𝐒(n))) P f = ∀{x} → Decider(𝐒(n))(P(x))(f(x))

-- Whether there is a boolean decider for the inhabitedness of a type function.
Decidable : (n : ℕ) → ∀{ℓ}{ℓ𝓈}{As : Types{n}(ℓ𝓈)} → (As ⇉ Type{ℓ}) → Type
Decidable(n)(P) = ∃(Decider(n)(P))

-- The boolean n-ary inhabitedness decider function for a decidable n-ary type function.
decide : (n : ℕ) → ∀{ℓ}{ℓ𝓈}{As : Types{n}(ℓ𝓈)} → (P : As ⇉ Type{ℓ}) → ⦃ dec : Decidable(n)(P) ⦄ → (As ⇉ Bool)
decide(_)(_) ⦃ dec ⦄ = [∃]-witness dec


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

open import Level
open import Data.Product using (Σ; _,_; Σ-syntax; proj₁; proj₂)

open import Categories.Category
open import Categories.Category.CartesianClosed

module _ {o ℓ e} {𝒞 : Category o ℓ e} (𝓥 : CartesianClosed 𝒞) where
  open Category 𝒞
  open CartesianClosed 𝓥
  open HomReasoning

  PointSurjective : ∀ {A X Y : Obj} → (X ⇒ Y ^ A) → Set (ℓ ⊔ e)
  PointSurjective {A = A} {X = X} {Y = Y} ϕ =
    ∀ (f : A ⇒ Y) → Σ[ x ∈ ⊤ ⇒ X ] (∀ (a : ⊤ ⇒ A) → eval′ ∘ first ϕ ∘ ⟨ x , a ⟩  ≈ f ∘ a)

  lawvere-fixed-point : ∀ {A B : Obj} → (ϕ : A ⇒ B ^ A) → PointSurjective ϕ → (f : B ⇒ B) → Σ[ s ∈ ⊤ ⇒ B ] f ∘ s ≈ s
  lawvere-fixed-point {A = A} {B = B} ϕ surjective f = g ∘ x , g-fixed-point
    where
      g : A ⇒ B
      g = f ∘ eval′ ∘ ⟨ ϕ , id ⟩

      x : ⊤ ⇒ A
      x = proj₁ (surjective  g)

      g-surjective : eval′ ∘ first ϕ ∘ ⟨ x , x ⟩ ≈ g ∘ x
      g-surjective = proj₂ (surjective g) x

      lemma : ∀ {A B C D} → (f : B ⇒ C) → (g : B ⇒ D) → (h : A ⇒ B) → (f ⁂ g) ∘ ⟨ h , h ⟩ ≈ ⟨ f , g ⟩ ∘ h
      lemma f g h = begin
        (f ⁂ g) ∘ ⟨ h , h ⟩ ≈⟨  ⁂∘⟨⟩ ⟩
        ⟨ f ∘ h , g ∘ h ⟩   ≈˘⟨ ⟨⟩∘ ⟩
        ⟨ f , g ⟩ ∘ h       ∎

      g-fixed-point : f ∘ (g ∘ x) ≈ g ∘ x
      g-fixed-point = begin
        f ∘ g ∘ x                        ≈⟨  refl⟩∘⟨ sym g-surjective ⟩
        f ∘ eval′ ∘ first ϕ ∘ ⟨ x , x ⟩  ≈⟨ refl⟩∘⟨ refl⟩∘⟨ lemma ϕ id x ⟩
        f ∘ eval′ ∘ ⟨ ϕ , id ⟩ ∘ x       ≈˘⟨ ∘-resp-≈ˡ sym-assoc ○ assoc ○ assoc ⟩
        (f ∘ eval′ ∘ ⟨ ϕ , id ⟩) ∘ x     ≈⟨ refl ⟩
        g ∘ x                            ∎


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

module Ch2-5 where

open import Level hiding (lift)

open import Ch2-1
open import Ch2-2
open import Ch2-3
open import Ch2-4

open import Data.Product
open import Function using (_∘_; id)

-- Example 2.5.1 (equivalence)
Example-2-5-1 : ∀ {a b} {A : Set a} {B : Set b}
  → (a a' : A) (b b' : B)
  → ((a , b) ≡ (a' , b')) ≅ ((a ≡ a') × (b ≡ b'))
Example-2-5-1 {_} {_} {A} {B} a a' b b' = f , f-isequiv

  where
    f : ∀ {a b a' b'} → (a , b) ≡ (a' , b') → a ≡ a' × b ≡ b'
    f {a} {b} {a'} {b'} eq = J (A × B) D d (a , b) (a' , b') eq
      where
        D : (x y : A × B) → (p : x ≡ y) → Set _
        D (a , b) (a' , b') p = a ≡ a' × b ≡ b'

        d : (x : A × B) → D x x refl
        d x = refl , refl

    f-isequiv : isequiv f
    f-isequiv = (g , α) , (g , β)
      where
        g : ∀ {a b a' b'} → a ≡ a' × b ≡ b' → (a , b) ≡ (a' , b')
        g {a} {b} {a'} {b'} (fst , snd) = J A D d a a' fst b b' snd
          where
            D : (a a' : A) → (p : a ≡ a') → Set _
            D a a' p = (b b' : B) (q : b ≡ b') → (a , b) ≡ (a' , b')

            d : (x : A) → D x x refl
            d x b b' q = J B E e b b' q
              where
                E : (b b' : B) → (q : b ≡ b') → Set _
                E b b' q = (x , b) ≡ (x , b')

                e : (x : B) → E x x refl
                e x = refl

        α : f ∘ g ~ id
        α (fst , snd) = J A D d a a' fst b b' snd
          where
            D : (x y : A) (p : x ≡ y) → Set _
            D x y p = (x' y' : B) (snd : x' ≡ y')
              → (f ∘ g) (p , snd) ≡ ((p , snd))

            d : (x : A) → D x x refl
            d x x' y' q = J B E e x' y' q
              where
                E : (x' y' : B) (q : x' ≡ y') → Set _
                E x' y' q = (f ∘ g) (refl , q) ≡ ((refl , q))

                e : (x' : B) → E x' x' refl
                e x' = refl

        β : g ∘ f ~ id
        β p = J (A × B) D d (a , b) (a' , b') p
          where
            D : (x y : A × B) (p : x ≡ y) → Set _
            D x y p = (g ∘ f) p ≡ p

            d : (x : A × B) → D x x refl
            d x = refl


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

module Stream where
open import Level as Level using (zero)
import Relation.Binary as BinRel
open import Relation.Binary as BinRel hiding (Setoid; Rel)
open import Relation.Binary.PropositionalEquality as PE

Setoid = BinRel.Setoid Level.zero Level.zero

open import Data.Nat using (ℕ; zero; suc)
open import PropsAsTypes

record Stream (A : Set) : Set where
  coinductive
  field
    hd  : A
    tl  : Stream A
open Stream public

coiter : {X A : Set} → (X → A × X) → (X → Stream A)
coiter c x .hd  = π₁ (c x)
coiter c x .tl  = coiter c (π₂ (c x))

δ : ∀{A} → ℕ → Stream A → Stream A
δ 0        s = s
δ (suc n)  s = δ n (s .tl)

_at_ : ∀{A} → Stream A → ℕ → A
s at n = (δ n s) .hd

module Bisim (A : Set) where

  infix 2 _~_

  record _~_ (s t : Stream A) : Prop where
    coinductive
    field
      hd≡  : s .hd  ≡  t .hd
      tl~  : s .tl  ~  t .tl
  open _~_ public

  isBisim : Rel (Stream A) → Prop
  isBisim _R_ = ∀ s t → s R t → (s .hd ≡ t .hd) ∧ (s .tl R t .tl)

  ∃-bisim→~ :  ∀ {_R_} → isBisim _R_ →
               ∀ (s t : Stream A) → s R t → s ~ t
  ∃-bisim→~ R-isBisim s t q .hd≡  = ∧-elim₁ (R-isBisim s t q)
  ∃-bisim→~ R-isBisim s t q .tl~  =
    ∃-bisim→~ R-isBisim (s .tl) (t .tl) (∧-elim₂ (R-isBisim s t q))

  bisim→ext-≡ : ∀ {s t} → s ~ t → (∀ n → s at n ≡ t at n)
  bisim→ext-≡ p zero     = p .hd≡
  bisim→ext-≡ p (suc n)  = bisim→ext-≡ (p .tl~) n

  s-bisim-refl : ∀ {s : Stream A} → s ~ s
  s-bisim-refl      .hd≡  = PE.refl
  s-bisim-refl {s}  .tl~  = s-bisim-refl {s .tl}

  s-bisim-sym : ∀ {s t : Stream A} → s ~ t → t ~ s
  s-bisim-sym p .hd≡  = PE.sym       (p .hd≡)
  s-bisim-sym p .tl~  = s-bisim-sym  (p .tl~)

  s-bisim-trans : ∀ {r s t : Stream A} → r ~ s → s ~ t → r ~ t
  s-bisim-trans p q .hd≡  = PE.trans       (p .hd≡)  (q .hd≡)
  s-bisim-trans p q .tl~  = s-bisim-trans  (p .tl~)  (q .tl~)

  stream-setoid : Setoid
  stream-setoid = record
    { Carrier = Stream A
    ; _≈_ = _~_
    ; isEquivalence = record
      { refl   = s-bisim-refl
      ; sym    = s-bisim-sym
      ; trans  = s-bisim-trans
      }
    }

  import Relation.Binary.EqReasoning as EqR

  module ~-Reasoning where
    module _ where
      open EqR (stream-setoid) public
        hiding (_≡⟨_⟩_) renaming (_≈⟨_⟩_ to _~⟨_⟩_; begin_ to begin_; _∎ to _∎)


module split where

import Relation.Binary.PropositionalEquality as Eq
open Eq using (_≡_; refl; sym; trans; cong)
open Eq.≡-Reasoning
open import Data.Nat using (ℕ; zero; suc; _+_; _*_; _∸_; _≤_; s≤s; z≤n; _≤?_)
open import Relation.Nullary using (¬_; Dec; yes; no)
open import Data.Product using (_×_; ∃; ∃-syntax) renaming (_,_ to ⟨_,_⟩)
open import Function using (_∘_)

open import lists using (List; []; _∷_; [_]; [_,_]; [_,_,_]; [_,_,_,_]; All; Decidable)

-- リストのマージ
-- xs と ys を使って zs を組み立てる
data merge {A : Set} : (xs ys zs : List A) → Set where
  [] :
      --------------
      merge [] [] []

  left-∷ : ∀ {x xs ys zs}
    → merge xs ys zs
      --------------------------
    → merge (x ∷ xs) ys (x ∷ zs)

  right-∷ : ∀ {y xs ys zs}
    → merge xs ys zs
      --------------------------
    → merge xs (y ∷ ys) (y ∷ zs)

_ : merge [ 1 , 4 ] [ 2 , 3 ] [ 1 , 2 , 3 , 4 ]
_ = left-∷ (right-∷ (right-∷ (left-∷ [])))

-- リストの分割
-- 述語Pが成り立つ場合はxs、そうでない場合はysとして分割する (scalaでいうpartition)
split : ∀ {A : Set} {P : A → Set} (P? : Decidable P) (zs : List A)
  → ∃[ xs ] ∃[ ys ] (merge xs ys zs × All P xs × All (¬_ ∘ P) ys)
split P? []                                                                 = ⟨ [] ,     ⟨ [] ,     ⟨ [] ,        ⟨ [] ,       [] ⟩ ⟩ ⟩ ⟩
split P? (z ∷ zs) with P? z   | split P? zs
...                  | yes Pz | ⟨ xs , ⟨ ys , ⟨ m , ⟨ Pxs , ¬Pys  ⟩  ⟩  ⟩ ⟩ = ⟨ z ∷ xs , ⟨ ys ,     ⟨ left-∷ m ,  ⟨ Pz ∷ Pxs , ¬Pys ⟩ ⟩ ⟩ ⟩
...                  | no ¬Pz | ⟨ xs , ⟨ ys , ⟨ m , ⟨ Pxs , ¬Pys  ⟩  ⟩  ⟩ ⟩ = ⟨ xs ,     ⟨ z ∷ ys , ⟨ right-∷ m , ⟨ Pxs ,      ¬Pz ∷ ¬Pys ⟩ ⟩ ⟩ ⟩

-- 0と等しい1以上の自然数は存在しない
¬z≡n : ∀ {n : ℕ} → ¬ (zero ≡ suc n)
¬z≡n ()

-- m = n が成り立たなければ (m + 1) = (n + 1) も成り立たない
¬s≡s : ∀ {m n : ℕ} → ¬ (m ≡ n) → ¬ (suc m ≡ suc n)
¬s≡s ¬m≡n refl = ¬m≡n refl

-- decidableを使った、2つの自然数が等しいかどうか判定する関数
_≡ℕ?_ : ∀ (m n : ℕ) → Dec (m ≡ n)
zero  ≡ℕ? zero                = yes refl
zero  ≡ℕ? suc n               = no ¬z≡n
suc m ≡ℕ? zero                = no (λ ())
suc m ≡ℕ? suc n with m ≡ℕ? n
...                | yes refl = yes refl
...                | no ¬m≡n  = no (¬s≡s ¬m≡n)

-- テスト
-- リストの要素を3とそれ以外とに分ける
_ : split (_≡ℕ? 3) [ 3 , 0 , 3 , 1 ]
  ≡ ⟨ [ 3 , 3 ] , ⟨ [ 0 , 1 ] , ⟨ (left-∷ (right-∷ (left-∷ (right-∷ [])))) , ⟨ refl ∷ refl ∷ [] , ¬z≡n ∷ (¬s≡s ¬z≡n) ∷ [] ⟩ ⟩ ⟩ ⟩
_ = refl


open import Relation.Binary.Core

module Heapsort.Impl2.Correctness.Permutation {A : Set}
                  (_≤_ : A → A → Set)
                  (tot≤ : Total _≤_)
                  (trans≤ : Transitive _≤_) where

open import BBHeap _≤_ hiding (forget) renaming (flatten to flatten')
open import BBHeap.Compound _≤_
open import BBHeap.Drop _≤_ tot≤ trans≤
open import BBHeap.Drop.Properties _≤_ tot≤ trans≤
open import BBHeap.Heapify _≤_ tot≤ trans≤
open import BBHeap.Insert _≤_ tot≤ trans≤
open import BBHeap.Insert.Properties _≤_ tot≤ trans≤
open import BBHeap.Order _≤_
open import BBHeap.Order.Properties _≤_
open import Bound.Lower A
open import Bound.Lower.Order _≤_
open import Data.List
open import Heapsort.Impl2 _≤_ tot≤ trans≤
open import List.Permutation.Base A
open import List.Permutation.Base.Equivalence A
open import OList _≤_
open import Order.Total _≤_ tot≤

lemma-flatten-flatten' : {b : Bound}(h : BBHeap b)(accₕ : Acc h) → forget (flatten h accₕ) ∼ flatten' h
lemma-flatten-flatten' leaf _ = ∼[]
lemma-flatten-flatten' (left {l = l} {r = r} b≤x l⋘r) (acc rs) = ∼x /head /head (trans∼ (lemma-flatten-flatten' (drop⋘ b≤x l⋘r) (rs (drop⋘ b≤x l⋘r) (lemma-drop≤′ (cl b≤x l⋘r)))) (lemma-drop⋘∼ b≤x l⋘r))
lemma-flatten-flatten' (right {l = l} {r = r} b≤x l⋙r) (acc rs) = ∼x /head /head (trans∼ (lemma-flatten-flatten' (drop⋙ b≤x l⋙r) (rs (drop⋙ b≤x l⋙r) (lemma-drop≤′ (cr b≤x l⋙r)))) (lemma-drop⋙∼ b≤x l⋙r))

lemma-flatten'-flatten : {b : Bound}(h : BBHeap b)(accₕ : Acc h) → (flatten' h) ∼ (forget (flatten h accₕ))
lemma-flatten'-flatten h tₕ = sym∼ (lemma-flatten-flatten' h tₕ)

theorem-heapsort∼ : (xs : List A) → xs ∼ forget (heapsort xs)
theorem-heapsort∼ [] = ∼[]
theorem-heapsort∼ (x ∷ xs) =
                     let h = heapify xs ;
                          accₕ = ≺-wf h ;
                          hᵢ = insert lebx h ;
                          accₕᵢ = ≺-wf hᵢ ;
                          xs∼fh = theorem-heapsort∼ xs ;
                          fh∼f'h = lemma-flatten-flatten' h accₕ ;
                          xs∼f'h = trans∼ xs∼fh fh∼f'h ;
                          xxs∼xf'h = ∼x /head /head xs∼f'h ;
                          xf'h∼f'hᵢ = lemma-insert∼ lebx h ;
                          xxs∼f'hᵢ = trans∼ xxs∼xf'h xf'h∼f'hᵢ ;
                          f'hᵢ∼fhᵢ = lemma-flatten'-flatten hᵢ accₕᵢ
                      in trans∼ xxs∼f'hᵢ f'hᵢ∼fhᵢ


{-# OPTIONS --copatterns #-}

module Copatterns where

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

repeat : {A : Set}(a : A) -> Stream A
head (repeat a) = a
tail (repeat a) = repeat a

map : {A B : Set}(f : A -> B)(as : Stream A) -> Stream B
head (map f as) = f (head as)
tail (map f as) = map f (tail as)

iterate : {A : Set}(f : A -> A)(a : A) -> Stream A
head (iterate f a) = a
tail (iterate f a) = iterate f (f a)

scanl : {A B : Set} -> (B -> A -> B) -> B -> Stream A -> Stream B
head (scanl f b as) = b
tail (scanl f b as) = scanl f (f b (head as)) (tail as)

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

nats : Stream Nat
nats = iterate suc zero

alternate : Stream Nat
(      head alternate ) = zero
(head (tail alternate)) = suc zero
(tail (tail alternate)) = alternate

record _×_ (A B : Set) : Set where
  field
    fst : A
    snd : B
open _×_

build : {A S : Set} → (S → A × S) -> S -> Stream A
head (build step s) = fst (step s)
tail (build step s) = build step (snd (step s))
-- build step s = mapSnd (build step) (step s)

build1 : {A S : Set} → (S → A × S) -> S -> Stream A
build1 step s = record
  { head = fst (step s)
  ; tail = build1 step (snd (step s))
  }

build2 : {A S : Set} → (S → A × S) -> S -> Stream A
build2 step s = record
  { head = fst p
  ; tail = build2 step (snd p)
  }
  where p = step s

mapSnd : {A B C : Set}(f : B → C) → A × B → A × C
fst (mapSnd f p) = fst p
snd (mapSnd f p) = f (snd p)

record Str (A : Set) : Set where
  field
    out : A × Str A
open Str

build' : {A S : Set} → (S → A × S) -> S -> Stream A
out (build' step s) = mapSnd (build' step) (step s)


-- A brief Agda tutorial.
-- Martín Escardó, 7 Sep 2012 (updated to be compatible with Agda 2.4.2 2 Oct 2014).
--
-- Agda is a computer-implemented dialect of Martin-Löf type theory.
-- It can both check and run proofs.
--
-- Propositions are types (also called sets, indicated by the keyword
-- Set), and their witnesses or proofs are programs.
--
-- If one ignores this view/encoding of propositions, Agda is simply a
-- strongly typed, pure, functional programming language with
-- dependent types and other kinds of fancy types.
--
-- All programs normalize in Agda.
---
-- Gödel's system T is included in Agda, but Platek-Scott-Plotkin's
-- PCF is not.  But Agda is much more expressive than system T: it
-- defines many more functions ℕ → ℕ, for example, and encodes much
-- higher ordinals.

-- The Agda wiki http://wiki.portal.chalmers.se/agda/agda.php tells
-- you how to install Agda and get started with editing.
--
-- I recommend the tutorial paper
---    http://www.cse.chalmers.se/~ulfn/papers/afp08/tutorial.pdf,
-- among others available at
--     http://wiki.portal.chalmers.se/agda/agda.php?n=Main.Documentation
--
-- See also the standard library
--     http://www.cse.chalmers.se/~nad/listings/lib-0.6/README.html
-- which we will not use in this tutorial.

module EscardoTutorial where

-- An inductive definition:

data ℕ : Set where
 zero : ℕ
 succ : ℕ → ℕ

-- This notation uses unicode UTF-8. To enter unicode characters in emacs in Agda mode, see
-- http://wiki.portal.chalmers.se/agda/agda.php?n=Main.QuickGuideToEditingTypeCheckingAndCompilingAgdaCode
-- (usually LaTeX syntax works).

-- Could instead write the following, which is equivalent with a
-- different notation, using ascii characters only:

data N : Set where
 zero : N
 succ : N -> N
 one  : N

-- But we will use the first definition. (Later we may prove that ℕ
-- and N are isomorphic, as an exercise.)

-- Our first function, inductively defined:

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

-- We can define a simple-recursion combinator:

rec : (X : Set) → X → (X → X) → (ℕ → X)
rec X x f zero = x
rec X x f (succ n) = f(rec X x f n)

-- Or the primitive-recursion combinator:

prim-rec : (X : Set) → X → (ℕ → X → X) → ℕ → X
prim-rec X x f zero = x
prim-rec X x f (succ n) = f n (prim-rec X x f n)

-- Addition can then be instead defined as:

_+₁_ : ℕ → ℕ → ℕ
x +₁ y = rec ℕ x succ y

-- We are using a subscript to indicate a different version. An
-- identifier is a sequence of unicode (UTF-8 encoding) characters not
-- containing white space or reserved characters @.(){};_.
--
-- Quoting from the agda wiki,
-- http://wiki.portal.chalmers.se/agda/pmwiki.php?n=ReferenceManual.LexicalMatters:
--
-- Furthermore, the following set of reserved words cannot be used as name parts.
--
-- ->         :         =        ?        \           |          →         ∀   --     λ
-- abstract   data      forall   hiding   import      in         infix     infixl   infixr
-- let        module    mutual   open     postulate   primitive  private   public   record
-- renaming   rewrite   using    where    with
-- Prop       Set[0–9]* [0–9]+
--
-- This means that strings like x:A and A→B are valid names. To write
-- the type signature and the function type, white space have to be
-- inserted: x : A, and A → B.
--

-- To illustrate some features, another equivalent definition is this:

rec₁ : (X : Set) → X → (X → X) → (ℕ → X)
rec₁ X x f = h
 where
  h : ℕ → X
  h zero = x
  h (succ n) = f(h n)

-- Indentation matters.

-- The parameter X of the definition of rec/rec₁ may be made implicit,
-- and this is sensible:

rec₂ : {X : Set} → X → (X → X) → (ℕ → X)
rec₂ {X} x f = h
 where
  h : ℕ → X
  h zero = x
  h (succ n) = f(h n)

-- Now we can define addition omitting the type ℕ:

_+₂_ : ℕ → ℕ → ℕ
x +₂ y = rec₂ x succ y

-- Agda then infers (by unification) that this is the only possibly
-- choice for the implicit argument.

-- In cases when the inference fails, or when you want to implicitly
-- supply the implicit parameter for emphasis, you can write:

_+₃_ : ℕ → ℕ → ℕ
x +₃ y = rec₂ {ℕ} x succ y

-- You can also write:

_+₄_ : ℕ → ℕ → ℕ
_+₄_ x y = rec₂ {ℕ} x succ y

-- or even, using η-contraction:

_+₅_ : ℕ → ℕ → ℕ
_+₅_ x = rec₂ {ℕ} x succ

-- or:

_+₆_ : ℕ → ℕ → ℕ
_+₆_ = λ x → rec₂ {ℕ} x succ

-- or, using only ascii characters:

_+₇_ : ℕ → ℕ → ℕ
_+₇_ = \x -> rec₂ {ℕ} x succ

-- I prefer the original definition.

-- You can also declare an associativity and precedence for (the
-- various versions of) _+_ if you wish (valid from now on):

infixl 5 _+_

-- Since we are discussing syntax, let also do:

-- {-# BUILTIN NATURAL ℕ #-}
{-# BUILTIN NATURAL N #-}

-- This allows you to write e.g. 0 to mean zero and 3 to mean
-- Succ(Succ(Succ zero)).

-- So far we have a few definitions. We want to prove something about
-- them.

-- Agda uses the Brouwer-Heyting-Kolmogorov-Curry-Howard
-- representation of propositions as types.
--
-- Types are called sets in Agda syntax, with the keyword "Set".
-- (And in the early accounts by Martin-Löf too.)
--
-- So a proposition is a set.
--
--    * A set may be empty: this represents "false".
--
--    * Or it may have an element: any inhabited set represents "true".
--
-- So a proposition may be true in many ways: an element of its
-- representing set is called a "witness" or a "realizer" or "a
-- proof".
--
--
-- A predicate on a type X is a function A : X → Set.
-- For each element x : X it gives a set A x representing a
-- proposition.
--
--
-- * The BHKCH intepretation of implication:
--
--     A realizer of the proposition "A implies B" is a function that
--     given any realizer of A produces a realizer of B.
--
--     Thus, the function type (A → B), built-in in Martin-Löf theory
--     and in Agda, codes implication.
--
--
-- * The BHKCH intepretation of universal quantification:
--
--     A realizer of "for all x in X, A x" is a function that
--     transforms any x in X into a realizer of A x.
--
--     The interpretation of universal quantification is given by
--     dependent products, again built-in in Martin-Löf theory and in
--     Agda.
--
--     In Martin-Löf type theory, it is written Π.  In Agda, the
--     notation (x : X) → A x is used, where A : X → Set.
--
--     It is the type of functions that map any x : X to an element y : A x.
--     Notice that the type of the output depends on the input.
--
--     Agda allows you to write ∀(x : X) → A x to mean (x : X) → A x.
--     When types can be inferred by Agda, you can also write ∀ x → A x.
--
-- * The BHKCH intepretation of existential quantification:
--
--     A realizer of "there is x in X s.t. A x" is a pair (x , a)
--     where x is in X and a is a realizer of A x.
--
--     In Martin-Löf type theory, Σ is used to define the
--     interpretation of existential quantification.
--
--     In Agda we need to (inductively) define it ourselves:

data Σ {X : Set} (A : X → Set) : Set where
     _,_ : (x₀ : X) → A x₀ → Σ \(x : X) → A x

-- Read Σ \(x : X) → A x as the sum of the sets A x for x : X.  Agda
-- is "intensional", but it uses the η rule.  So Σ \(x : X) → A x is
-- the same as Σ {X} A, because A is the same thing as \(x : X) → A x,
-- and because X can be inferred now, as it is given in the definition
-- \(x : X) → A x.

π₀ : {X : Set} {A : X → Set} → (Σ \(x : X) → A x) → X
π₀(x , a) = x

π₁ : {X : Set} {A : X → Set} → (z : Σ \(x : X) → A x) → A(π₀ z)
π₁(x , a) = a

-- Martin-Löf instead works with the following elimination rule, which
-- is a dependently type version of "uncurrying":

Σ-elim : {X : Set} → {Y : X → Set} →
         {A : (Σ \(x : X) → Y x) → Set}

   → (∀(x : X) → ∀(y : Y x) → A(x , y))
   → ∀(t : (Σ \(x : X) → Y x)) → A t

Σ-elim f(x , y) = f x y

-- Notice that Σ-elim defines the projections:

π₀' : {X : Set} {A : X → Set} → (Σ \(x : X) → A x) → X
π₀' = Σ-elim (λ x a → x)

π₁' : {X : Set} {A : X → Set} → (z : Σ \(x : X) → A x) → A(π₀ z)
π₁' = Σ-elim (λ x a → a)

-- The converse holds if we assume "surjective-pairing", a form of the
-- η-rule for sums. Now this may be confusing: the way we defined Σ
-- using "data" doesn't give you that. But if you define Σ using a
-- record, then you do get that. See
-- http://www.cs.bham.ac.uk/~mhe/agda/SetsAndFunctions.html

-- Cartesian products are a special case of dependent sums, where Y
-- doesn't depend on x : X, which represent conjunctions in the BHKCH
-- interpretation of logic:

_×_ : Set → Set → Set
X × Y = Σ \(x : X) → Y

-- It is also useful to introduce ∃-notation:

∃ : {X : Set} → (A : X → Set) → Set
∃ = Σ

-- We have developed enough material to be able to formulate and prove
-- our first theorem: the Axiom of Choice:

AC : {X Y : Set} {A : X → Y → Set} →

 (∀(x : X) → ∃ \(y : Y) → A x y) → ∃ \(f : X → Y) → ∀(x : X) → A x (f x)

AC g = (λ x → π₀(g x)) , (λ x → π₁(g x))

-- We have a dependently typed version as well (not to be confused
-- with dependent choice, which I will discuss later), with the same
-- proof:

AC' : {X : Set} {Y : X → Set} {A : (x : X) → Y x → Set} →

 (∀(x : X) → ∃ \(y : Y x) → A x y) → ∃ \(f : ((x : X) → Y x)) → ∀(x : X) → A x (f x)

AC' g = ((λ x → π₀(g x)) , (λ x → π₁(g x)))

-- I find the following use of an implicit argument useful in order
-- to achieve a notation close to Martin-Löf's.

Π : {X : Set} → (Y : X → Set) → Set
Π {X} Y = (x : X) → Y x

-- For example the axiom of choice becomes less surprising when we
-- realize that it amounts to

AC-in-ML-notation : {X : Set} {Y : X → Set} {A : (x : X) → Y x → Set} →

 (Π \(x : X) → Σ \(y : Y x) → A x y) → Σ \(f : ((x : X) → Y x)) → Π \(x : X) → A x (f x)

AC-in-ML-notation g = ((λ x → π₀(g x)) , (λ x → π₁(g x)))

-- (The axiom of choice usually fails in a topos, but the above always
-- holds. In fact, the function AC-in-ML-notation is a
-- (pointwise) isomorphism. Exercise: define its inverse in Agda.)

-- Let's return to the natural numbers.
-- We can also write an induction combinator:

induction : {A : ℕ → Set} →

 A zero → (∀(k : ℕ) → A k → A(succ k)) → ∀(n : ℕ) → A n

induction base step 0 = base
induction base step (succ n) = step n (induction base step n)

-- Notice that the realizer of the principle of induction has the same
-- definition as primitive recursion. Only the types are different:
-- that of primitive recursion is less general, and that of induction
-- is the dependent-type generalization.

prim-rec' : {X : Set} → X → (ℕ → X → X) → ℕ → X
prim-rec' = induction

-- The empty type, representing the false proposition.

data ∅ : Set where
 -- no constructors given

-- The "elimintation rule of false", or "ex-falso quod libet", or the
-- function from the empty set to any set:

from-∅ : {X : Set} → ∅ → X
from-∅ ()

-- This is our first encounter of "()" patterns. They assert that a
-- case is impossible (and Agda checks that), or that no constructor
-- is available to perform a match. All uses of () can be reduced to
-- from-∅, but sometimes it is clearer to use the "()" pattern.

-- The type with one element, giving one way of representing the true
-- proposition:

data ① : Set where
 * : ①

-- This is something like the terminal object:

to-① : {X : Set} → X → ①
to-① x = *

-- * The BHKCH intepretation of disjunction is the binary co-product,
--   inductively defined. It is natural to use the symbol "+" to
--   denote the co-product, but in Agda there is no overloading other than
--   constructors defined in (different) "data" definitions. So let's
--   use "⨄" as in the standard library

data _⨄_ (X₀ X₁ : Set) : Set where
 in₀ : X₀ → X₀ ⨄ X₁
 in₁ : X₁ → X₀ ⨄ X₁

-- These constructors correspond to the introduction rules of disjunction.
-- Definition by cases corresponds to the elimination rule:

cases : {X₀ X₁ Y : Set} → (X₀ → Y) → (X₁ → Y) → (X₀ ⨄ X₁ → Y)
cases f₀ f₁ (in₀ x₀) = f₀ x₀
cases f₀ f₁ (in₁ x₁) = f₁ x₁

-- See Bove & Dybjer's paper "Dependent types at work" for
-- a dependently typed version of this:
-- http://www.cse.chalmers.se/~ulfn/papers/afp08/tutorial.pdf
-- Alternatively, work it out yourself as an exercise.

-- Binary co-products can be alternatively defined from sums and the
-- booleans in the presence of the "universe" Set.
--
-- First define the set of binary digits (the booleans with another
-- notation and perspective):

data ② : Set where
 ₀ : ②
 ₁ : ②

-- This amounts to if-then-else:

②-cases : {X : Set} → X → X → ② → X
②-cases x₀ x₁ ₀ = x₀
②-cases x₀ x₁ ₁ = x₁

-- Here is the dependently-typed version:

dep-②-cases : {X : ② → Set} → X ₀ → X ₁ → ((i : ②) → X i)
dep-②-cases x₀ x₁ ₀ = x₀
dep-②-cases x₀ x₁ ₁ = x₁

-- The following has the same definition but a different type:

②-Cases : Set → Set → ② → Set
②-Cases X₀ X₁ ₀ = X₀
②-Cases X₀ X₁ ₁ = X₁

-- Agda has universe polymorphism, but I won't mention it in this
-- tutorial. It requires to rewrite all code we have written and we
-- will write in this tutorial, everytime with a parameter for a
-- universe level. Explore the standard library to see how this works.

_⨄'_ : Set → Set → Set
X₀ ⨄' X₁ = Σ \(i : ②) → ②-Cases X₀ X₁ i

in₀' : {X₀ X₁ : Set} → X₀ → X₀ ⨄' X₁
in₀' x₀ = (₀ , x₀)

in₁' : {X₀ X₁ : Set} → X₁ → X₀ ⨄' X₁
in₁' x₁ = (₁ , x₁)

cases' : {X₀ X₁ Y : Set} → (X₀ → Y) → (X₁ → Y) → (X₀ ⨄' X₁ → Y)
cases' {X₀} {X₁} {Y} f₀ f₁ = h
 where
  Y' : X₀ ⨄' X₁ → Set
  Y' z = Y

  f : (i : ②) → (x : ②-Cases X₀ X₁ i) → Y'(i , x)
  f = dep-②-cases f₀ f₁

  g : (z : X₀ ⨄' X₁) → Y' z
  g = Σ-elim {②} {②-Cases X₀ X₁} {Y'} f

  h : X₀ ⨄' X₁ → Y
  h = g

-- * The BHKCH intepretation of equality:
--
--     Howards idea: x = y is interpreted by a type that is empty if x
--     and y are equal, and has precisely one element if not.
--
--     In set theory (classical or constructive), this can be written
--     { z ∈ 1 | x = y }, where 1 is a singleton, say {0}.
--
--     But notice that this cannot be written down in Martin-Löf's
--     type theory, and already presuposes a notion of equality to be
--     available.
--
--     Martin-Löf's idea: inductively define this type. This is the
--     so-called identity type, which is complicated and hence we will
--     look at it later.

-- Using the universe Set, one can easily define equality on the
-- natural numbers by induction and show that the Martin-Löf induction
-- priciple J holds for this notion of equality on ℕ.

-- Notice that we use four stacked bars to denote the equality type on
-- the type ℕ. Later we will use three to denote the equality type, or
-- identity type, for any type (and in particular ℕ again).

infix 3 _≣_

_≣_ : ℕ → ℕ → Set
0 ≣ 0 = ①
(succ m) ≣ 0 = ∅
0 ≣ (succ n) = ∅
(succ m) ≣ (succ n) = m ≣ n

Reflℕ : ∀ n → n ≣ n
Reflℕ 0 = *
Reflℕ (succ n) = IH
 -- Notice that we needed to inhabit the set ((succ m) ≣ (succ n))
 -- in this case, but we instead inhabited the set (m ≣ n) using IH.
 -- This works because, by definition, ((succ m) ≣ (succ n)) is (m ≣ n).
 where
  IH : n ≣ n
  IH = Reflℕ n

-- We next show that _≣_ is the least reflexive relation on ℕ:

weak-Jℕ : (A : ℕ → ℕ → Set) → (∀ n → A n n) →  ∀ m n → m ≣ n → A m n
weak-Jℕ A φ 0 0 * = φ 0
weak-Jℕ A φ 0 (succ n) ()
weak-Jℕ A φ (succ m) 0 ()
weak-Jℕ A φ (succ m) (succ n) e = weak-Jℕ A' φ' m n e
 where
  A' : ℕ → ℕ → Set
  A' m n = A (succ m) (succ n)
  φ' : ∀ n → A' n n
  φ' n = φ(succ n)

-- If you don't like "()" patterns, you can use the function from-∅
-- (defined above using "()" patterns):

weak-Jℕ' : (A : ℕ → ℕ → Set) → (∀ n → A n n) →  ∀ m n → m ≣ n → A m n
weak-Jℕ' A φ 0 0 * = φ 0
weak-Jℕ' A φ 0 (succ n) e = from-∅ e
weak-Jℕ' A φ (succ m) 0 e = from-∅ e
weak-Jℕ' A φ (succ m) (succ n) e =
 weak-Jℕ' (λ m n → A(succ m)(succ n)) (λ n → φ(succ n)) m n e

-- There is a stronger, dependent(ly typed) version of weak-Jℕ:

Jℕ : (A : (m n : ℕ) → m ≣ n → Set)

   → (∀ n → A n n (Reflℕ n)) →  ∀ m n → ∀(e : m ≣ n) → A m n e

Jℕ A φ 0 0 * = φ 0
Jℕ A φ 0 (succ n) ()
Jℕ A φ (succ m) 0 ()
Jℕ A φ (succ m) (succ n) e =
 Jℕ (λ m n → A (succ m) (succ n)) (λ n → φ(succ n)) m n e

-- Of course we could have defined instead the weak version from the
-- strong one:

weak-Jℕ'' : (A : (m n : ℕ) → Set) → (∀ n → A n n) →  ∀ m n → m ≣ n → A m n
weak-Jℕ'' A = Jℕ (λ m n e → A m n)

-- Jℕ can be regarded as an induction principle for equality on the
-- type ℕ. Several properties of ≣ can be proved using J without
-- reference to the inductive structure of the the type ℕ, and often
-- its weak version suffices.

symℕ : (x y : ℕ) → x ≣ y → y ≣ x
symℕ = weak-Jℕ A φ
 where
  A : (x y : ℕ) → Set
  A x y = y ≣ x
  φ : (x : ℕ) → x ≣ x
  φ = Reflℕ

transℕ : (x y z : ℕ) → x ≣ y → y ≣ z → x ≣ z
transℕ x y z r s =  transℕ' x y r z s
 where
  transℕ' : (x y : ℕ) → x ≣ y → (z : ℕ) → y ≣ z → x ≣ z
  transℕ' = weak-Jℕ A φ
   where
    A : (x y : ℕ) → Set
    A x y = ∀(z : ℕ) → y ≣ z → x ≣ z
    φ : (x : ℕ) → A x x
    φ x z s = s

substℕ : (P : ℕ → Set) → (x y : ℕ) → x ≣ y → P x → P y
substℕ P = weak-Jℕ A φ
 where
  A : (x y : ℕ) → Set
  A x y = P x → P y
  φ : (x : ℕ) → A x x
  φ x p = p

-- Transitivity can be proved using substitution:

sym-transℕ : (x y z : ℕ) → x ≣ y → x ≣ z → y ≣ z
sym-transℕ x y z = rearrange z x y
 where
  rearrange : (z x y : ℕ) → x ≣ y → x ≣ z → y ≣ z
  rearrange z = substℕ (λ x → x ≣ z)

transℕ' : (x y z : ℕ) → x ≣ y → y ≣ z → x ≣ z
transℕ' x y z r s = sym-transℕ y x z (symℕ x y r) s

congℕ→ℕ : (f : ℕ → ℕ) → (x x' : ℕ) → x ≣ x' → f x ≣ f x'
congℕ→ℕ f = weak-Jℕ (λ x x' → f x ≣ f x') (λ x → Reflℕ(f x))

-- As another example, we show that addition is commutative:

zero-is-left-neutral : ∀ n → 0 + n ≣ n
zero-is-left-neutral 0 = *
zero-is-left-neutral (succ n) = IH
             -- We need to inhabit the type (0 + succ n ≣ succ n).
             -- Expanding the definitions,
             --   (0 + succ n ≣ succ n) =
             --   (succ(0 + n) ≣ succ n) =
             --   (0 + n ≣ n).
             -- Here "=" is definitional equality, silently applied by Agda.
 where
  IH : 0 + n ≣ n
  IH = zero-is-left-neutral n

-- Equivalently:

zero-is-left-neutral' : ∀ n → 0 + n ≣ n
zero-is-left-neutral' = induction base step
 where
  base : ①
  base = *
  step : ∀ n → 0 + n ≣ n → 0 + n ≣ n
  step n e = e

-- This with the following shows that, of course, it is equivalent to
-- define addition by induction on the first argument. The proof is by
-- induction on the second argument, following the definition of _+_.

addition-on-first : ∀ m n → (succ m) + n ≣ succ(m + n)
addition-on-first m 0 = Reflℕ m
addition-on-first m (succ n) = IH
 where
  IH : succ m + n ≣ succ(m + n)
  IH = addition-on-first m n

-- Because the situation is symmetric, we can choose any of the two
-- arguments to perform the induction in the following theorem:

addition-commutative : ∀ m n → m + n ≣ n + m
addition-commutative 0 n = zero-is-left-neutral n
addition-commutative (succ m) n = lemma
 where
  IH : m + n ≣ n + m
  IH = addition-commutative m n
  claim : succ(m + n) ≣ succ(n + m)
  claim = congℕ→ℕ succ (m + n) (n + m) IH
  lemma : succ m + n ≣ succ (n + m)
  lemma = transℕ (succ m + n) (succ(m + n)) (succ (n + m))
                 (addition-on-first m n) claim

-- Exercise. Prove the Peano axioms that are not covered above.

-- The above theorem "Jℕ" motivates Martin-Löf's inductive definition
-- of the identity type for any type X:

data _≡_ {X : Set} : X → X → Set where
 refl : {x : X} → x ≡ x

-- Martin-Löf's notation is the following:

Id : (X : Set) → X → X → Set
Id X x y  =  x ≡ y

Refl : (X : Set) → (x : X) → Id X x x
Refl X x = refl {X} {x}

-- The induction principle is as for equality on ℕ defined earlier:

J : {X : Set} → (A : (x x' : X) → x ≡ x' → Set)

   → (∀(x : X) → A x x refl) →  ∀{x x' : X} → ∀(r : x ≡ x') → A x x' r

J A f {x} refl = f x

-- In Agda, one can prove the unique-of-identity proofs principle K by
-- pattern matching:

K : {X : Set} → ∀{x x' : X} → ∀(r s : x ≡ x') → r ≡ s
K refl refl = refl

-- This is not provable in intensional Martin-Löf type theory (Hofmann
-- & Streicher's groupoid interpretation paper).
--
-- However, it is known that the following is provable in MLTT:

pseudo-K : {X : Set} → ∀{x x' : X} → ∀(r : x ≡ x') → (x , refl) ≡ (x' , r)
pseudo-K {X} = J {X} A (λ x → refl)
 where
  A : ∀(x x' : X) → x ≡ x' → Set
  A x x' r = _≡_ {Σ \(x' : X) → x ≡ x'} (x , refl) (x' , r)

-- It has been shown that types with decidable equality, such as ℕ and
-- the booleans, satisfy the K-rule. Moreover, for ℕ it can be easily
-- proved by induction (exercise, which we may eventually do).

-- Conor McBride proved that having the K-rule is equivalent to having
-- pattern matching over refl, which Agda does. But this can be
-- disabled in Agda using the pragma {-# OPTIONS --without-K #-}.
-- Without this pragma, many definitions by pattern matching,
-- including that of J, are accepted, but that of K, and other
-- definitions that require K, are not.

-- Exercise: formulate and prove sym, subst, trans, cong, generalizing
-- the above development for ℕ. Define a weak version of J from J, and
-- use this in your proofs.

-- The propositional "axiom of function extensionality" is

Extensionality : Set₁
Extensionality =
 ∀(X Y : Set) → ∀(f g : X → Y) → (∀(x : X) → f x ≡ g x) → f ≡ g

-- Here we have used the second universe. The first is Set = Set₀.  We
-- have Set₀ : Set₁, Set₁ : Set₂, and so on. The "small" sets (or
-- types) live in Set₀. The large set Extensionality lives in Set₁
-- because it quantifies over elements of Set₀.

-- It is neither possible to show that the set Extensionality is
-- inhabited or that it is empty. That is, the extensionality axiom is
-- independent of MLTT. We can, if we wish, postulate it, or rather
-- postulate an inhabitant:

postulate ext : Extensionality

-- But then ext behaves like a constant, with no computation rules for
-- it. Reduction gets stuck when it encounters this case.

-- The principle of excluded middle is independent of MLTT.

EM : Set₁
EM = ∀(X : Set) → X ⨄ (X → ∅)

-- Notice that (X → ∅) represents negation because ∅ represents false.
-- Notice also that the independence of EM follows from that of
-- Extensionality if we don't have the above postulate.

-- It would be good, too good, to have an inhabitant of EM without
-- violating the computational character of MLTT. It would solve
-- Hilbert's decision problem for large fragments of mathematics,
-- including Peano arithmetic. It would amount to an algorithm for
-- deciding whether a proposition has a realizer, or its negation has
-- a realizer, and would also give the corresponding realizer. As is
-- well known, this is not possible, and this is why EM cannot be
-- inhabited in MLTT.

-- This is not to say that EM is false in MLTT.
-- In fact the set (EM → ∅) cannot be inhabited in MLTT either. This
-- is because MLTT is compatible with classical mathematics (like
-- Bishop mathematics). Set theory, say ZF with an inaccessible
-- cardinal modeling the universe, or with a stack of inaccessible
-- cardinals modelling a hierarchy of universes, can be used to give a
-- model of MLTT in which EM is inhabited (by simply using the
-- principle of excluded middle of ZF, whose consistency is not
-- disputed, even by constructive mathematicians).

-- The negation of EM is also consistent, because recursive models
-- of MLTT, in which an inhabitant of EM needs to be given by an
-- algorithm, exist, so that EM is empty and hence (EM → ∅) is
-- inhabited in such models. There are also (classical and
-- constructive) models in which all functions are continuous. In
-- those models, (EM → ∅) has an inhabitant too.

-- So it is very inaccurate to say that excluded middle "doesn't hold"
-- in Martin-Löf type theory.  What we have is that EM is independent
-- of MLTT. Independence is a meta-theoretical property, which cannot
-- be written down in MLTT itself, of course. Formalized versions of
-- the assertions "all functions are computable" and "all functions
-- are continuous" are also independent. In constructive mathematics
-- in the style of Bishop or Martin-Löf, in which compatibility with
-- classical and computational mathematics is desired, it is very easy
-- to find independent statements, as there are plenty of theorems
-- that hold classically but have no computable realizers (EM is one).

-- To be continued.

Jℕeq : (A : (m n : ℕ) → m ≣ n → Set) → (φ : (∀ n → A n n (Reflℕ n))) →  ∀ m
     → Jℕ A φ m m (Reflℕ m) ≡ φ m
Jℕeq A φ zero = refl
Jℕeq A φ (succ m) = Jℕeq (λ m n → A (succ m) (succ n)) (λ n → φ(succ n)) m

Jℕeq17 : (A : (m n : ℕ) → m ≣ n → Set) → (φ : (∀ n → A n n (Reflℕ n)))
     → Jℕ A φ 17 17 (Reflℕ 17) ≡ φ 17
Jℕeq17 A φ = refl


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

open import Categories.Category
open import Categories.Category.Monoidal

module Categories.Category.Monoidal.Symmetric {o ℓ e} {C : Category o ℓ e} (M : Monoidal C) where

open import Level

open import Data.Product using (Σ; _,_)

open import Categories.Functor.Bifunctor
open import Categories.NaturalTransformation.NaturalIsomorphism

open import Categories.Morphism C
open import Categories.Category.Monoidal.Braided M
open Category C
open Commutation

private
  variable
    X Y Z : Obj

-- symmetric monoidal category
-- commutative braided monoidal category
record Symmetric : Set (levelOfTerm M) where
  field
    braided : Braided

  module braided = Braided braided
  open braided public

  private
    B : ∀ {X Y} → X ⊗₀ Y ⇒ Y ⊗₀ X
    B {X} {Y} = braiding.⇒.η (X , Y)

  field
    commutative : B {X} {Y} ∘ B {Y} {X} ≈ id

  braided-iso : X ⊗₀ Y ≅ Y ⊗₀ X
  braided-iso = record
    { from = B
    ; to   = B
    ; iso  = record
      { isoˡ = commutative
      ; isoʳ = commutative
      }
    }


{- 2010-09-28 Andreas, example from Alan Jeffery, see Issue 336 -}

module WhyWeNeedTypedLambda where

data Bool : Set where
  true false : Bool

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

bool : {b : Bool} -> F b -> Bool
bool {b} _ = b

{-
-- untyped lambda leaves some yellow
-- the problem  \ x -> x : F ?b  is postponed
bla : Bool
bla = bool (\ x -> x)
-}

-- typed lambda succeeds
-- \ (x : _) -> x infers as ?X -> ?X, yielding constraint F ?b = ?X -> ?X
bla' : Bool
bla' = bool (\ (x : _) -> x)


module Everything where

-- Categories
import Categories.Category

-- 2-categories
-- XXX need to finish the last 3 laws
import Categories.2-Category

-- The strict 2-category of categories
-- XXX laws not proven yet
-- import Categories.2-Category.Categories

-- Adjunctions between functors
import Categories.Adjunction

-- The Agda Set category
import Categories.Agda

-- The fact that one version of it is cocomplete
import Categories.Agda.ISetoids.Cocomplete

-- The arrow category construction on any category
import Categories.Arrow

-- Bifunctors (functors from a product category)
import Categories.Bifunctor

-- Natural transformations between bifunctors
import Categories.Bifunctor.NaturalTransformation

-- The category of (small) categories
import Categories.Categories

-- Cat has products
import Categories.Categories.Products

-- Closed categories
import Categories.Closed

-- Cocones
import Categories.Cocone

-- The category of cocones under a diagram (functor)
import Categories.Cocones

-- Coends
import Categories.Coend

-- Coequalizers
import Categories.Coequalizer

-- Colimits
import Categories.Colimit

-- Comma categories
import Categories.Comma

-- Comonads, defined directly (not as monads on the opposite category)
import Categories.Comonad

-- The cofree construction that gives a comonad for any functor
import Categories.Comonad.Cofree

-- Cones
import Categories.Cone

-- The category of cones over a diagram (functor)
import Categories.Cones

-- A coherent equivalence relation over the objects of a category
import Categories.Congruence

-- Discrete categories (they only have objects and identity morphisms)
import Categories.Discrete

-- Ends
import Categories.End

-- Enriched categories
import Categories.Enriched

-- Equalizers
import Categories.Equalizer

-- Strong equivalence
import Categories.Equivalence.Strong

-- Fibrations
import Categories.Fibration

-- Free category on a graph
import Categories.Free

-- The free category construction is a functor from Gph to Cat
import Categories.Free.Functor

-- Functors
import Categories.Functor

-- F-algebra (TODO: maybe the module should be renamed)
import Categories.Functor.Algebra

-- The category of F-algebras of a functor
import Categories.Functor.Algebras

-- An F-coalgebra
import Categories.Functor.Coalgebra

-- Constant functor
import Categories.Functor.Constant

-- The category of F-coalgebras of a functor
import Categories.Functor.Coalgebras

-- The diagonal functor (C → C × C, or same thing with an arbitrary indexed product)
import Categories.Functor.Diagonal

-- Strong functor equivalence
-- XXX doesn't seem to work because of the double negative in Full?
-- import Categories.Functor.Equivalence.Strong

-- The hom functor, mapping pairs of objects to the morphisms between them
import Categories.Functor.Hom

-- Monoidal functors (similar to Haskell's Applicative class)
import Categories.Functor.Monoidal

-- Products as functors
import Categories.Functor.Product

-- Properties of general functors
import Categories.Functor.Properties

-- Representable functors
import Categories.Functor.Representable

-- Functor categories (of functors between two categories and natural transformations between them)
import Categories.FunctorCategory

-- The category of graphs and graph homomorphisms (Gph)
import Categories.Graphs

-- The underlying graph of a category (forgetful functor Cat ⇒ Gph)
import Categories.Graphs.Underlying

-- The Grothendieck construction on categories (taking a Sets-valued functor and building a category containing all values)
import Categories.Grothendieck

-- The globe category, used for defining globular sets (with a presheaf on it)
import Categories.Globe

-- Globular sets
import Categories.GlobularSet

-- Left Kan extensions
import Categories.Lan

-- Small categories exist as large categories too
import Categories.Lift

-- Limits
import Categories.Limit

-- Monads, defined as simple triples of a functor and two natural transformations
import Categories.Monad

-- A monad algebra
import Categories.Monad.Algebra

-- The category of all algebras of a monad
import Categories.Monad.Algebras

-- The Eilenberg-Moore category for any monad
import Categories.Monad.EilenbergMoore

-- The Kleisli category for any monad
import Categories.Monad.Kleisli

-- Strong monads
import Categories.Monad.Strong

-- Monoidal categories, with an associative bi(endo)functor and an identity object
import Categories.Monoidal

-- A braided monoidal category (one that gives you a swap operation, but isn't quite commutative)
import Categories.Monoidal.Braided

-- A cartesian monoidal category (monoidal category whose monoid is the product with a terminal object)
import Categories.Monoidal.Cartesian

-- Closed monoidal categories, which are simply monoidal categories that are
-- also closed, such that the laws "fit"
import Categories.Monoidal.Closed

-- Both of the above. Separated into its own module because we can do many
-- interesting things with them.
import Categories.Monoidal.CartesianClosed

-- Simple definitions about morphisms, such as mono, epi, and iso
import Categories.Morphisms

-- Cartesian morphisms (used mostly for fibrations)
import Categories.Morphism.Cartesian

-- Families of morphisms indexed by a set
import Categories.Morphism.Indexed

-- Natural isomorphisms, defined as an isomorphism of natural transformations
import Categories.NaturalIsomorphism

-- Natural transformations
import Categories.NaturalTransformation

import Categories.DinaturalTransformation

-- Properties of the opposite category
import Categories.Opposite

--------------------------------------------------------------------------------
-- Objects
--------------------------------------------------------------------------------

-- The coproduct of two objects
import Categories.Object.Coproduct

-- A category has all binary coproducts
import Categories.Object.BinaryCoproducts

-- A category has all finite coproducts
import Categories.Object.Coproducts

-- An exponential object
import Categories.Object.Exponential

-- A choice of B^A for a given B and any A
import Categories.Object.Exponentiating

-- B^— is adjoint to its opposite
import Categories.Object.Exponentiating.Adjunction

-- B^— as a functor
import Categories.Object.Exponentiating.Functor

-- A family of objects indexed by a set
import Categories.Object.Indexed

-- An initial object
import Categories.Object.Initial

-- The product of two objects
import Categories.Object.Product

-- The usual nice constructions on products, conditionalized on existence
import Categories.Object.Product.Morphisms

-- All binary products
import Categories.Object.BinaryProducts

-- Products of a nonempty list of objects and the ability to reassociate them massively
import Categories.Object.BinaryProducts.N-ary

-- All finite products
import Categories.Object.Products
import Categories.Object.Products.Properties

-- Products of a list of objects and the ability to reassociate them massively
import Categories.Object.Products.N-ary

-- The product of a family of objects
import Categories.Object.IndexedProduct

-- All products of indexed families
import Categories.Object.IndexedProducts

-- Subobject classifiers (for topoi)
import Categories.Object.SubobjectClassifier

-- Terminal object
import Categories.Object.Terminal

-- A^1 and 1^A always exist
import Categories.Object.Terminal.Exponentials

-- A chosen 1^A exists
import Categories.Object.Terminal.Exponentiating

-- A×1 always exists
import Categories.Object.Terminal.Products

-- Zero object (initial and terminal)
import Categories.Object.Zero

-- A category containing n copies of objects/morphisms/equalities of another category
import Categories.Power

-- Demonstrations that Power categories are the same as functors from discrete categories
import Categories.Power.Functorial

-- Natural transformations for functors to/from power categories
import Categories.Power.NaturalTransformation

-- A preorder gives rise to a category
import Categories.Preorder

-- A presheaf (functor from C^op to V)
import Categories.Presheaf

-- The category of presheaves (a specific functor category)
import Categories.Presheaves

-- The product of two categories
import Categories.Product
import Categories.Product.Properties

-- Projection functors from a product category to its factors
import Categories.Product.Projections

-- Profunctors
import Categories.Profunctor

-- Pullbacks in a category
import Categories.Pullback

-- Pushouts in a category
import Categories.Pushout

-- All categories can have a slice category defined on them
import Categories.Slice

-- Utilities for gluing together commutative squares (and triangles)
-- (and other common patterns of equational reasoning)
import Categories.Square

-- The terminal category (a terminal object in the category of small categories)
import Categories.Terminal

-- A topos
import Categories.Topos

-- The Yoneda lemma
import Categories.Yoneda


------------------------------------------------------------------------
-- Convenient syntax for equational reasoning
------------------------------------------------------------------------

-- Example use:

-- n*0≡0 : ∀ n → n * 0 ≡ 0
-- n*0≡0 zero    = refl
-- n*0≡0 (suc n) =
--   begin
--     suc n * 0
--   ≈⟨ byDef ⟩
--     n * 0 + 0
--   ≈⟨ n+0≡n _ ⟩
--     n * 0
--   ≈⟨ n*0≡0 n ⟩
--     0
--   ∎

open import Relation.Binary

module Relation.Binary.EqReasoning (s : Setoid) where

open Setoid s
import Relation.Binary.PreorderReasoning as PreR
open PreR preorder public
       renaming ( _∼⟨_⟩_  to _≈⟨_⟩_
                ; _≈⟨_⟩_  to _≡⟨_⟩_
                )


module plfa.part1.Midterm where

import Relation.Binary.PropositionalEquality as Eq
open Eq using (_≡_; refl; cong; sym)
-- you can add any import definitions that you need
open Eq.≡-Reasoning using (begin_; _≡⟨⟩_; _≡⟨_⟩_; _∎)
open import Data.Nat using (ℕ; zero; suc; _+_; _*_; _≤_; _>_; z≤n; s≤s; _≤?_; _<?_; _^_)
open import Data.Nat.Properties using (+-assoc; +-suc; +-comm; *-comm)
open import Relation.Nullary using (yes; no; Dec)

-- used for rewrite
simplify : ∀ {A : Set} (x : A) → x ≡ x
simplify x = refl

sum : ℕ → ℕ
sum 0 = 0
sum n@(suc sn) = sum sn + n

-- Problem 1
-- remove the "postulate" and prove this theorem, which is a version of
--   sum n ≡ n * (n - 1) / 2

--- my solution from Induction HW, copied here instead of importing for ease of grading
*-distrib-+ : ∀ (m n p : ℕ) →  (m + n) * p ≡ m * p + n * p
*-distrib-+ zero n p =
  begin
    (zero + n) * p
  ≡⟨⟩
   n * p
  ≡⟨⟩
   zero + n * p
  ≡⟨⟩
   zero * p + n * p
  ∎
*-distrib-+ (suc m) n p =
  begin
    (suc m + n) * p
  ≡⟨⟩
   (suc (m + n)) * p
  ≡⟨⟩
   p + ((m + n) * p)
  ≡⟨ cong (λ x -> p + x) (*-distrib-+ m n p) ⟩
   p + (m * p + n * p)
  ≡⟨ sym (+-assoc p (m * p) (n * p))⟩
   (p + m * p) + n * p
  ≡⟨⟩
   suc m * p + n * p
  ∎

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

simple : ∀ (n : ℕ) → (sum n) * 2 ≡ (suc n) * n
simple zero = refl
simple (suc n) =
  begin
    (sum (suc n)) * 2
  ≡⟨⟩
    ((sum n) + (suc n)) * 2
  ≡⟨ cong (λ x -> x) (*-distrib-+ (sum n) (suc n) 2 )⟩
    (sum n) * 2 + (suc n) * 2
  ≡⟨ cong (λ x -> x + (suc n) * 2) (simple (n))⟩
    (suc n) * n + (suc n) * 2
  ≡⟨ cong (λ x → x + (suc n) * 2) (*-comm (suc n) n)⟩
    n * (suc n) + (suc n) * 2
  ≡⟨ cong (λ x → n * (suc n) + x) (*-comm (suc n) 2)⟩
    n * (suc n) + 2 * (suc n)
  ≡⟨ cong (λ x → x) (sym (*-distrib-+ n 2 (suc n)))⟩
    (n + 2) * (suc n)
  ≡⟨⟩
    (n + suc 1) * (suc n)
  ≡⟨ cong (λ x → x * (suc n)) (+-suc n 1)⟩
    (suc (n + 1)) * (suc n)
  ≡⟨ cong (λ x → (suc (x)) * (suc n)) (1-suc n)⟩
    (suc (suc n)) * (suc n)
  ∎

-- Problem 2
-- remove the postulate and implement this function, which gives an Natural
-- number approximation of square root

if_then_else_ : { A : Set }
  → Dec A
  → ℕ
  → ℕ
  → ℕ
if yes A then a else b = a
if no A then a else b = b

sqrt : ℕ → ℕ

rt_sub_ : ℕ → ℕ → ℕ
rt_sub_ n  sqrtn = if ((suc n) <? (((sqrtn) + 1) ^ 2)) then (sqrtn) else ((sqrtn) + 1)

sqrt 0 = 0
sqrt (suc n) = rt n sub (sqrt n)

-- you can run these test cases
_ : sqrt 0 ≡ 0
_ = refl
_ : sqrt 1 ≡ 1
_ = refl
_ : sqrt 2 ≡ 1
_ = refl
_ : sqrt 3 ≡ 1
_ = refl
_ : sqrt 4 ≡ 2
_ = refl
_ : sqrt 5 ≡ 2
_ = refl
_ : sqrt 6 ≡ 2
_ = refl
_ : sqrt 7 ≡ 2
_ = refl
_ : sqrt 8 ≡ 2
_ = refl
_ : sqrt 9 ≡ 3
_ = refl
_ : sqrt 10 ≡ 3
_ = refl
_ : sqrt 11 ≡ 3
_ = refl
_ : sqrt 12 ≡ 3
_ = refl
_ : sqrt 13 ≡ 3
_ = refl
_ : sqrt 14 ≡ 3
_ = refl
_ : sqrt 15 ≡ 3
_ = refl
_ : sqrt 16 ≡ 4
_ = refl
_ : sqrt 17 ≡ 4
_ = refl
_ : sqrt 18 ≡ 4
_ = refl
_ : sqrt 19 ≡ 4
_ = refl
_ : sqrt 20 ≡ 4
_ = refl
_ : sqrt 21 ≡ 4
_ = refl
_ : sqrt 22 ≡ 4
_ = refl
_ : sqrt 23 ≡ 4
_ = refl
_ : sqrt 24 ≡ 4
_ = refl
_ : sqrt 24 ≡ 4
_ = refl
_ : sqrt 24 ≡ 4
_ = refl
_ : sqrt 25 ≡ 5
_ = refl
_ : sqrt 26 ≡ 5
_ = refl
_ : sqrt 27 ≡ 5
_ = refl

_ : sqrt 100 ≡ 10
_ = refl
_ : sqrt 101 ≡ 10
_ = refl


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

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

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

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

data _≤_ : ℕ → ℕ → Set where
  zero : ∀ {n}                → zero  ≤ n
  suc  : ∀ {m n} (le : m ≤ n) → suc m ≤ suc n

_<_ : ℕ → ℕ → Set
m < n = suc m ≤ n

toℕ : ∀ {n} → Fin n → ℕ
toℕ zero    = zero
toℕ (suc i) = suc (toℕ i)

fromℕ≤ : ∀ {m n} → m < n → Fin n
fromℕ≤ (suc zero)       = zero
fromℕ≤ (suc (suc m≤n)) = suc (fromℕ≤ (suc m≤n))

-- If we treat constructors as inert this fails to solve. Not entirely sure why.
fromℕ≤-toℕ : ∀ {m} (i : Fin m) (i<m : toℕ i < m) → fromℕ≤ i<m ≡ i
fromℕ≤-toℕ zero    (suc zero)       = refl
fromℕ≤-toℕ (suc i) (suc (suc m≤n)) = cong suc (fromℕ≤-toℕ i (suc m≤n))


module Numeral.PositiveInteger where

import Lvl
open import Syntax.Number
open import Data.Boolean.Stmt
open import Functional
open import Numeral.Natural.Oper.Comparisons
open import Numeral.Natural as ℕ using (ℕ)
open import Type

data ℕ₊ : Type{Lvl.𝟎} where
 𝟏 : ℕ₊
 𝐒 : ℕ₊ → ℕ₊

ℕ₊-to-ℕ : ℕ₊ → ℕ
ℕ₊-to-ℕ (𝟏)    = ℕ.𝐒(ℕ.𝟎)
ℕ₊-to-ℕ (𝐒(n)) = ℕ.𝐒(ℕ₊-to-ℕ (n))

ℕ-to-ℕ₊ : (n : ℕ) → ⦃ _ : IsTrue(positive?(n)) ⦄ → ℕ₊
ℕ-to-ℕ₊ (ℕ.𝟎)         ⦃ ⦄
ℕ-to-ℕ₊ (ℕ.𝐒(ℕ.𝟎))    ⦃ _ ⦄ = 𝟏
ℕ-to-ℕ₊ (ℕ.𝐒(ℕ.𝐒(x))) ⦃ p ⦄ = 𝐒(ℕ-to-ℕ₊ (ℕ.𝐒(x)) ⦃ p ⦄)

instance
  ℕ₊-numeral : Numeral(ℕ₊)
  Numeral.restriction-ℓ (ℕ₊-numeral) = Lvl.𝟎
  Numeral.restriction   (ℕ₊-numeral) (n) = IsTrue(positive?(n))
  num ⦃ ℕ₊-numeral ⦄ (n) ⦃ proof ⦄ = ℕ-to-ℕ₊ (n) ⦃ proof ⦄

𝐒-from-ℕ : ℕ → ℕ₊
𝐒-from-ℕ (ℕ.𝟎)    = 𝟏
𝐒-from-ℕ (ℕ.𝐒(n)) = 𝐒(𝐒-from-ℕ(n))

𝐏-to-ℕ : ℕ₊ → ℕ
𝐏-to-ℕ (𝟏)    = ℕ.𝟎
𝐏-to-ℕ (𝐒(n)) = ℕ.𝐒(𝐏-to-ℕ(n))


{- Agda can check termination of Stream transducer operations.
   (Created: Andreas Abel, 2008-12-01
    at Agda Intensive Meeting 9 in Sendai, Japan.
    I acknowledge the support by AIST and JST.)

Stream transducers have been described in:

  N. Ghani, P. Hancock, and D. Pattinson,
  Continuous functions on final coalgebras.
  In Proc. CMCS 2006, Electr. Notes in Theoret. Comp. Sci., 2006.

They have been modelled by mixed equi-(co)inductive sized types in

  A. Abel,
  Mixed Inductive/Coinductive Types and Strong Normalization.
  In APLAS 2007, LNCS 4807.

Here we model them by mutual data/codata and mutual recursion/corecursion.
 -}

module StreamProcEat where

open import Common.Coinduction

data Stream (A : Set) : Set where
  cons : A -> ∞ (Stream A) -> Stream A

-- Stream Transducer: Trans A B
-- intended semantics: Stream A -> Stream B

mutual

  data Trans (A B : Set) : Set where
    〈_〉 : ∞ (Trans' A B) -> Trans A B

  data Trans' (A B : Set) : Set where
    get : (A -> Trans' A B) -> Trans' A B
    put : B -> Trans A B -> Trans' A B

out : forall {A B} -> Trans A B -> Trans' A B
out 〈 p 〉 = ♭ p

-- evaluating a stream transducer ("stream eating")

mutual

  -- eat is defined by corecursion into Stream B
  eat  : forall {A B} -> Trans A B -> Stream A -> Stream B
  eat 〈 sp 〉 as = eat' (♭ sp) as

  -- eat' is defined by a local recursion on Trans' A B
  eat' : forall {A B} -> Trans' A B -> Stream A -> Stream B
  eat' (get f) (cons a as) = eat' (f a) (♭ as)
  eat' (put b sp) as = cons b (♯ eat sp as)

-- composing two stream transducers

mutual

  -- comb is defined by corecursion into Trans A B
  comb : forall {A B C} -> Trans A B -> Trans B C -> Trans A C
  comb 〈 p1 〉 〈 p2 〉 = 〈 ♯ comb' (♭ p1) (♭ p2) 〉

  -- comb' preforms a local lexicographic recursion on (Trans' B C, Trans' A B)
  comb' : forall {A B C} -> Trans' A B -> Trans' B C -> Trans' A C
  comb' (put b p1) (get f)    = comb' (out p1) (f b)
  comb' (put b p1) (put c p2) = put c (comb p1 p2)
  comb' (get f)    p2         = get (\ a -> comb' (f a) p2)


module DifferentArities where

open import Common.Equality
open import Common.Prelude

f : Nat → Nat → Nat
f zero      = λ x → x
f (suc n) m = f n (suc m)

testf1 : f zero ≡ λ x → x
testf1 = refl

testf2 : ∀ {n m} → f (suc n) m ≡ f n (suc m)
testf2 = refl

testf3 : f 4 5 ≡ 9
testf3 = refl

-- Andreas, 2015-01-21 proper matching on additional argument

Sum : Nat → Set
Sum 0       = Nat
Sum (suc n) = Nat → Sum n

sum : (acc : Nat) (n : Nat) → Sum n
sum acc 0         = acc
sum acc (suc n) 0 = sum acc n
sum acc (suc n) m = sum (m + acc) n

nzero : (n : Nat) → Sum n
nzero 0 = 0
nzero (suc n) m = nzero n

mult :  (acc : Nat) (n : Nat) → Sum n
mult acc 0         = acc
mult acc (suc n) 0 = nzero n
mult acc (suc n) m = mult (m * acc) n


module #9 where

{-
  Define the type family Fin : N → U mentioned at the end of §1.3, and the dependent
  function fmax : ∏(n:N) Fin(n + 1) mentioned in §1.4.
-}

open import Data.Nat

data Fin : ℕ → Set where
  FZ : {n : ℕ} → Fin (suc n)
  FS : {n : ℕ} → Fin n → Fin (suc n)

fmax : (n : ℕ) → Fin (n + 1)
fmax zero = FZ
fmax (suc n) = FS (fmax n)


module Data.MoreNatProp where

open import Relation.Binary.PropositionalEquality
  using (_≡_ ; refl ; cong)
open import Data.Nat as Nat
  using (ℕ ; suc ; zero ; _≤′_ ; _≤_ ; _+_ ; s≤s ; z≤n ; ≤′-refl ;
         ≤′-step ; _⊔_)
open import Data.Nat.Properties as NatP
  using (≤⇒≤′ ; ≤′⇒≤ ;  m≤m+n ; s≤′s ; ≤-stepsˡ ; ≤⇒pred≤)
open import Data.Nat.Properties.Simple as NatPS
  using (+-comm ; +-suc)

≤-trans : ∀ {x y z} -> x ≤ y -> y ≤ z -> x ≤ z
≤-trans z≤n       _         = z≤n
≤-trans (s≤s m≤n) (s≤s n≤o) = s≤s (≤-trans m≤n n≤o)

≤′-trans : ∀ {x y z} -> x ≤′ y -> y ≤′ z -> x ≤′ z
≤′-trans xy yz = ≤⇒≤′ (≤-trans (≤′⇒≤ xy) (≤′⇒≤ yz))

≤′+r : ∀ {x y z} -> x ≤′ y -> z + x  ≤′ z + y
≤′+r {x} {y} {zero} x≤′y = x≤′y
≤′+r {x} {y} {suc z} x≤′y = s≤′s (≤′+r {x} {y} {z} x≤′y)

≤′+l : ∀ {x y z} -> x ≤′ y -> x + z ≤′ y + z
≤′+l {x} {y} {z} x≤′y rewrite +-comm x z | +-comm y z = ≤′+r{x}{y}{z} x≤′y

≡is≤′ : ∀ {p q} -> p ≡ q -> p ≤′ q
≡is≤′ p≡q rewrite p≡q = ≤′-refl

≤+b : ∀ x y z w -> x ≤ z -> y ≤ w -> x + y ≤ z + w
≤+b .0 y z w Nat.z≤n y≤w = ≤-stepsˡ z y≤w
≤+b .(suc x) y .(suc z) w (Nat.s≤s{x}{z} x≤z) y≤w = s≤s (≤+b x y z w x≤z y≤w)

≤′+b : ∀ x y z w -> x ≤′ z -> y ≤′ w -> x + y ≤′ z + w
≤′+b x y z w x≤′z y≤′w = ≤⇒≤′ (≤+b x y z w (≤′⇒≤ x≤′z) (≤′⇒≤ y≤′w))

suc≤′⇒≤′ : ∀ x y -> suc x ≤′ y -> x ≤′ y
suc≤′⇒≤′ x .(suc x) ≤′-refl = ≤′-step ≤′-refl
suc≤′⇒≤′ x (suc n) (≤′-step sucx≤′y) = ≤′-step (suc≤′⇒≤′ x n sucx≤′y)

⊔-sym : ∀ n m -> n ⊔ m ≡ m ⊔ n
⊔-sym zero zero = refl
⊔-sym zero (suc m) = refl
⊔-sym (suc n) zero = refl
⊔-sym (suc n) (suc m) = cong suc (⊔-sym n m)


module Structure where
  -- Structures in meta-functions.
  module Function' where -- TODO: Temporary naming fix with tick
    module Properties ⦃ signature : Signature ⦄ where
      Type : Domain → Domain → Function → Formula
      Type(X)(Y)(f) = ∀ₛ(X)(x ↦ f(x) ∈ Y)

      Closed : Domain → Function → Formula
      Closed(S)(f) = Type(S)(S)(f)

      Injective'' : Domain → Function → Formula
      Injective''(A)(f) = ∀ₛ(A)(x ↦ ∀ₛ(A)(y ↦ (f(x) ≡ f(y)) ⟶ (x ≡ y)))

      Surjective'' : Domain → Domain → Function → Formula
      Surjective''(A)(B)(f) = ∀ₛ(B)(y ↦ ∃ₛ(A)(x ↦ f(x) ≡ y))

      Bijective'' : Domain → Domain → Function → Formula
      Bijective''(A)(B)(f) =
        Injective''(A)(f)
        ∧ Surjective''(A)(B)(f)

      Preserving₁'' : Domain → Function → Function → Function → Formula
      Preserving₁''(A)(f)(g₁)(g₂) = ∀ₛ(A)(x ↦ f(g₁(x)) ≡ g₂(f(x)))

      Preserving₂'' : Domain → Domain → Function → BinaryOperator → BinaryOperator → Formula
      Preserving₂''(A)(B)(f)(_▫₁_)(_▫₂_) = ∀ₛ(A)(x ↦ ∀ₛ(B)(y ↦ f(x ▫₁ y) ≡ (f(x) ▫₂ f(y))))

  module Relator where
    module Properties where
      Reflexivity : Domain → BinaryRelator → Formula
      Reflexivity(S)(_▫_) = ∀ₛ(S)(x ↦ x ▫ x)

      Irreflexivity : Domain → BinaryRelator → Formula
      Irreflexivity(S)(_▫_) = ∀ₛ(S)(x ↦ ¬(x ▫ x))

      Symmetry : Domain → BinaryRelator → Formula
      Symmetry(S)(_▫_) = ∀ₛ(S)(x ↦ ∀ₛ(S)(y ↦ (x ▫ y) ⟶ (y ▫ x)))

      Asymmetry : Domain → BinaryRelator → Formula
      Asymmetry(S)(_▫_) = ∀ₛ(S)(x ↦ ∀ₛ(S)(y ↦ (x ▫ y) ⟶ ¬(y ▫ x)))

      Antisymmetry : Domain → BinaryRelator → Formula
      Antisymmetry(S)(_▫_) = ∀ₛ(S)(x ↦ ∀ₛ(S)(y ↦ (x ▫ y)∧(y ▫ x) ⟶ (x ≡ y)))

      Transitivity : Domain → BinaryRelator → Formula
      Transitivity(S)(_▫_) = ∀ₛ(S)(x ↦ ∀ₛ(S)(y ↦ ∀ₛ(S)(z ↦ (x ▫ y)∧(y ▫ z) ⟶ (x ▫ z))))

      Equivalence : Domain → BinaryRelator → Formula
      Equivalence(S)(_▫_) =
        Reflexivity(S)(_▫_)
        ∧ Symmetry(S)(_▫_)
        ∧ Transitivity(S)(_▫_)

      SymmetricallyTotal : Domain → BinaryRelator → Formula
      SymmetricallyTotal(S)(_▫_) = ∀ₛ(S)(x ↦ ∀ₛ(S)(y ↦ (x ▫ y) ∨ (y ▫ x)))

  module Ordering where
    open Relator.Properties

    Minima : Domain → BinaryRelator → Domain → Formula
    Minima(S)(_≤_)(min) = ∀ₛ(S)(x ↦ min ≤ x)

    Maxima : Domain → BinaryRelator → Domain → Formula
    Maxima(S)(_≤_)(max) = ∀ₛ(S)(x ↦ x ≤ max)

    module _  ⦃ signature : Signature ⦄ where
      open Signature ⦃ ... ⦄

      lowerBounds : Domain → BinaryRelator → Domain → Domain
      lowerBounds(S)(_≤_)(Sₛ) = filter(S)(Minima(S)(_≤_))

      upperBounds : Domain → BinaryRelator → Domain → Domain
      upperBounds(S)(_≤_)(Sₛ) = filter(S)(Maxima(S)(_≤_))

      interval : Domain → BinaryRelator → Domain → Domain → Domain
      interval(S)(_≤_) (a)(b) = filter(S)(s ↦ (a ≤ s) ∧ (s ≤ b))

      Bounded : Domain → BinaryRelator → Domain → Domain → Formula
      Bounded(S)(_≤_) (a)(b) = ∀ₛ(S)(s ↦ (a ≤ s) ∧ (s ≤ b))

      Infima : Domain → BinaryRelator → Domain → Domain → Formula
      Infima(S)(_≤_)(Sₛ)(inf) = Maxima(lowerBounds(S)(_≤_)(Sₛ))(_≤_)(inf)

      Suprema : Domain → BinaryRelator → Domain → Domain → Formula
      Suprema(S)(_≤_)(Sₛ)(sup) = Minima(upperBounds(S)(_≤_)(Sₛ))(_≤_)(sup)

    module Weak where
      PartialOrder : Domain → BinaryRelator → Formula
      PartialOrder(S)(_≤_) =
        Reflexivity(S)(_≤_)
        ∧ Antisymmetry(S)(_≤_)
        ∧ Transitivity(S)(_≤_)

      TotalOrder : Domain → BinaryRelator → Formula
      TotalOrder(S)(_≤_) =
        PartialOrder(S)(_≤_)
        ∧ SymmetricallyTotal(S)(_≤_)

    module Strict where
      Order : Domain → BinaryRelator → Formula
      Order(S)(_<_) =
        Irreflexivity(S)(_<_)
        ∧ Asymmetry(S)(_<_)
        ∧ Transitivity(S)(_<_)

      Dense : Domain → BinaryRelator → Formula
      Dense(S)(_<_) = ∀ₛ(S)(x ↦ ∀ₛ(S)(y ↦ (x < y) ⟶ ∃ₛ(S)(z ↦ (x < z)∧(z < y))))

  module Operator where
    module Properties where
      AssociativityPattern : Domain → Domain → Domain → BinaryOperator → BinaryOperator → BinaryOperator → BinaryOperator → Formula
      AssociativityPattern(x)(y)(z)(_▫₁_)(_▫₂_)(_▫₃_)(_▫₄_) = (((x ▫₁ y) ▫₂ z) ≡ (x ▫₃ (y ▫₄ z)))

      DistributivityₗPattern : Domain → Domain → Domain → BinaryOperator → BinaryOperator → BinaryOperator → BinaryOperator → BinaryOperator → Formula
      DistributivityₗPattern(x)(y)(z)(_▫₁_)(_▫₂_)(_▫₃_)(_▫₄_)(_▫₅_) = (x ▫₁ (y ▫₂ z)) ≡ ((x ▫₃ y) ▫₄ (x ▫₅ z))

      DistributivityᵣPattern : Domain → Domain → Domain → BinaryOperator → BinaryOperator → BinaryOperator → BinaryOperator → BinaryOperator → Formula
      DistributivityᵣPattern(x)(y)(z)(_▫₁_)(_▫₂_)(_▫₃_)(_▫₄_)(_▫₅_) = ((x ▫₂ y) ▫₁ z) ≡ ((x ▫₃ z) ▫₄  (y ▫₅ z))

      Type : BinaryOperator → Domain → Domain → Domain → Formula
      Type(_▫_)(X)(Y)(Z) = ∀ₛ(X)(x ↦ ∀ₛ(Y)(y ↦ (x ▫ y) ∈ Z))

      Closed : Domain → BinaryOperator → Formula
      Closed(S)(_▫_) = Type(_▫_)(S)(S)(S)

      Commutativity : Domain → BinaryOperator → Formula
      Commutativity(S)(_▫_) = ∀ₛ(S)(x ↦ ∀ₛ(S)(y ↦ (x ▫ y) ≡ (y ▫ x)))

      Associativity : Domain → BinaryOperator → Formula
      Associativity(S)(_▫_) = ∀ₛ(S)(x ↦ ∀ₛ(S)(y ↦ ∀ₛ(S)(z ↦ AssociativityPattern(x)(y)(z)(_▫_)(_▫_)(_▫_)(_▫_))))

      Identityₗ : Domain → BinaryOperator → Domain → Formula
      Identityₗ(S)(_▫_)(id) = ∀ₛ(S)(x ↦ (id ▫ x) ≡ x)

      Identityᵣ : Domain → BinaryOperator → Domain → Formula
      Identityᵣ(S)(_▫_)(id) = ∀ₛ(S)(x ↦ (x ▫ id) ≡ x)

      Identity : Domain → BinaryOperator → Domain → Formula
      Identity(S)(_▫_)(id) = Identityₗ(S)(_▫_)(id) ∧ Identityᵣ(S)(_▫_)(id)

      Invertibleₗ : Domain → BinaryOperator → Domain → Formula
      Invertibleₗ(S)(_▫_)(id) = ∀ₛ(S)(x ↦ ∃ₛ(S)(x⁻¹ ↦ (x⁻¹ ▫ x) ≡ id))

      Invertibleᵣ : Domain → BinaryOperator → Domain → Formula
      Invertibleᵣ(S)(_▫_)(id) = ∀ₛ(S)(x ↦ ∃ₛ(S)(x⁻¹ ↦ (x ▫ x⁻¹) ≡ id))

      Invertible : Domain → BinaryOperator → Domain → Formula
      Invertible(S)(_▫_)(id) = ∀ₛ(S)(x ↦ ∃ₛ(S)(x⁻¹ ↦ ((x⁻¹ ▫ x) ≡ id) ∧ ((x ▫ x⁻¹) ≡ id)))

      Distributivityₗ : Domain → BinaryOperator → BinaryOperator → Formula
      Distributivityₗ(S)(_▫₁_)(_▫₂_) = ∀ₛ(S)(x ↦ ∀ₛ(S)(y ↦ ∀ₛ(S)(z ↦ DistributivityₗPattern(x)(y)(z)(_▫₁_)(_▫₂_)(_▫₁_)(_▫₂_)(_▫₁_))))

      Distributivityᵣ : Domain → BinaryOperator → BinaryOperator → Formula
      Distributivityᵣ(S)(_▫₁_)(_▫₂_) = ∀ₛ(S)(x ↦ ∀ₛ(S)(y ↦ ∀ₛ(S)(z ↦ DistributivityᵣPattern(x)(y)(z)(_▫₁_)(_▫₂_)(_▫₁_)(_▫₂_)(_▫₁_))))

      Distributivity : Domain → BinaryOperator → BinaryOperator → Formula
      Distributivity(S)(_▫₁_)(_▫₂_) = Distributivityₗ(S)(_▫₁_)(_▫₂_) ∧ Distributivityᵣ(S)(_▫₁_)(_▫₂_)

      Compatibility : Domain → Domain → BinaryOperator → BinaryOperator → Formula
      Compatibility(A)(B)(_▫₁_)(_▫₂_) = ∀ₛ(A)(a₁ ↦ ∀ₛ(A)(a₂ ↦ ∀ₛ(B)(b ↦ AssociativityPattern(a₁)(a₂)(b)(_▫₁_)(_▫₁_)(_▫₂_)(_▫₁_))))

      Semigroup : Domain → BinaryOperator → Formula
      Semigroup(S)(_▫_) =
        Closed(S)(_▫_)
        ∧ Associativity(S)(_▫_)

      Monoid : Domain → BinaryOperator → Formula
      Monoid(S)(_▫_) =
        Semigroup(S)(_▫_)
        ∧ ∃ₛ(S)(Identity(S)(_▫_))

      Group : Domain → BinaryOperator → Formula
      Group(S)(_▫_) =
        Monoid(S)(_▫_)
        ∧ ∀ₛ(S)(id ↦ Identity(S)(_▫_)(id) ⟶ Invertible(S)(_▫_)(id))

      CommutativeGroup : Domain → BinaryOperator → Formula
      CommutativeGroup(S)(_▫_) =
        Group(S)(_▫_)
        ∧ Commutativity(S)(_▫_)

      Rng : Domain → BinaryOperator → BinaryOperator → Formula
      Rng(S)(_▫₁_)(_▫₂_) =
        CommutativeGroup(S)(_▫₁_)
        ∧ Semigroup(S)(_▫₂_)
        ∧ Distributivity(S)(_▫₂_)(_▫₁_)

      Ring : Domain → BinaryOperator → BinaryOperator → Formula
      Ring(S)(_▫₁_)(_▫₂_) =
        CommutativeGroup(S)(_▫₁_)
        ∧ Monoid(S)(_▫₂_)
        ∧ Distributivity(S)(_▫₂_)(_▫₁_)

      module _  ⦃ signature : Signature ⦄ where
        open Signature ⦃ ... ⦄

        Field : Domain → BinaryOperator → BinaryOperator → Formula
        Field(S)(_▫₁_)(_▫₂_) =
          CommutativeGroup(S)(_▫₁_)
          ∧ ∀ₛ(S)(id₁ ↦ Identity(S)(_▫₁_)(id₁) ⟶ CommutativeGroup(S ∖ singleton(id₁))(_▫₂_))
          ∧ Distributivity(S)(_▫₂_)(_▫₁_)

        VectorSpace : Domain → Domain → BinaryOperator → BinaryOperator → BinaryOperator → BinaryOperator → Formula
        VectorSpace(V)(S)(_+ᵥ_)(_⋅ₛᵥ_)(_+ₛ_)(_⋅ₛ_) =
          CommutativeGroup(V)(_+ᵥ_)
          ∧ Field(S)(_+ₛ_)(_⋅ₛ_)
          ∧ ∀ₛ(S)(id ↦ Identity(S)(_⋅ₛ_)(id) ⟶ Identityₗ(V)(_⋅ₛᵥ_)(id))
          ∧ Compatibility(S)(V)(_⋅ₛᵥ_)(_⋅ₛ_)
          ∧ ∀ₛ(S)(s ↦ ∀ₛ(V)(v₁ ↦ ∀ₛ(V)(v₂ ↦ DistributivityₗPattern(s)(v₁)(v₂)(_⋅ₛᵥ_)(_+ᵥ_)(_⋅ₛᵥ_)(_+ᵥ_)(_⋅ₛᵥ_))))
          ∧ ∀ₛ(S)(s₁ ↦ ∀ₛ(S)(s₂ ↦ ∀ₛ(V)(v ↦ DistributivityᵣPattern(s₁)(s₂)(v)(_⋅ₛᵥ_)(_+ᵥ_)(_⋅ₛᵥ_)(_+ᵥ_)(_⋅ₛᵥ_))))

  module Numeral where
    module Natural ⦃ signature : Signature ⦄ where
      open Signature ⦃ ... ⦄

      FormulaInduction : Domain → Domain → Function → (Domain → Formula) → Formula
      FormulaInduction(ℕ)(𝟎)(𝐒) (φ) = (φ(𝟎) ∧ ∀ₛ(ℕ)(n ↦ φ(n) ⟶ φ(𝐒(n)))) ⟶ ∀ₛ(ℕ)(φ)

      SetInduction : Domain → Domain → Function → Formula
      SetInduction(ℕ)(𝟎)(𝐒) = ∀ₗ(X ↦ ((𝟎 ∈ X) ∧ ∀ₛ(ℕ)(n ↦ (n ∈ X) ⟶ (𝐒(n) ∈ X))) ⟶ (ℕ ⊆ X))
      -- TODO: Can be expressed as ∀ₗ(X ↦ Inductive(X) ⟶ (ℕ ⊆ X))

      -- A set ℕ which can be constructed ℕ-inductively.
      Peano : Domain → Domain → Function → Formula
      Peano(ℕ)(𝟎)(𝐒) =
        (𝟎 ∈ ℕ)
        ∧ Function'.Properties.Closed(ℕ)(𝐒)
        ∧ Function'.Properties.Injective''(ℕ)(𝐒)
        ∧ ∀ₛ(ℕ)(n ↦ 𝐒(n) ≢ 𝟎)
        ∧ SetInduction(ℕ)(𝟎)(𝐒)


module x07-747Negation-hc where

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

------------------------------------------------------------------------------
-- NEGATION : defined as implying false
-- import Relation.Nullary using (¬_)
¬_ : Set → Set
¬ A = A → ⊥
infix 3 ¬_

-- if both ¬ A and A hold, then ⊥ holds
¬-elim : ∀ {A : Set}
  → ¬ A
  → A
    ---
  → ⊥
¬-elim ¬a a = ¬a a

-- double negation introduction (cannot be eliminated in intuitionistic logic)
¬¬-intro : ∀ {A : Set}
  → A
    -----
  → ¬ ¬ A
-- ¬¬-intro a     ¬a = ¬a a -- agda with auto split/fill to this
¬¬-intro    a = λ ¬a → ¬a a -- easier to understand with ¬ def using anon λ

-- triple negation elimination
¬¬¬-elim : ∀ {A : Set}
  → ¬ ¬ ¬ A
    -------
  → ¬ A
-- ¬¬¬-elim ¬¬¬a     a = ¬-elim ¬¬¬a (¬¬-intro a)
¬¬¬-elim    ¬¬¬a = λ a → ¬-elim ¬¬¬a (¬¬-intro a)

-- import Relation.Nullary.Negation using (contraposition)
-- one direction of the contrapositive
-- the other direction cannot be proved in intuitionistic logic
contraposition : ∀ {A B : Set}
  → (A → B)
    -----------
  → (¬ B → ¬ A)
-- contraposition a→b     ¬b     a = ¬b (a→b a)
contraposition    a→b = λ ¬b → λ a → ¬b (a→b a)

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

_ : 1 ≢ 2
_ = λ ()

-- a first-order Peano axioms
peano : ∀ {m : ℕ} → zero ≢ suc m
peano ()

open import x05-842Isomorphism-hc using (extensionality)

-- two proofs of ⊥ → ⊥
-- they look different but are the same (assuming extensionality)
id : ⊥ → ⊥
id x = x

id′ : ⊥ → ⊥
id′ ()

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

-- assuming extensionality, any two proofs of a negation are the same
assimilation : ∀ {A : Set} (¬x ¬x′ : ¬ A) → ¬x ≡ ¬x′
assimilation ¬x ¬x′ = extensionality λ x → ⊥-elim (¬x x)

-- BEGIN: Strict inequality (copied from 747Relations).
infix 4 _<_

data _<_ : ℕ → ℕ → Set where

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

  s<s : ∀ {m n : ℕ}
    → m < n
      -------------
    → suc m < suc n
-- END: Strict inequality (copied from 747Relations).

-- NotFourLTThree
¬4<3 : ¬ (4 < 3)
¬4<3 (s<s (s<s (s<s ())))

-- < is irreflexive (never reflexive)
¬n<n : ∀ (n : ℕ) → ¬ (n < n)
-- ¬n<n (suc n)       (s<s n<n) = ¬n<n n n<n
¬n<n    (suc n) = λ { (s<s n<n) → ¬n<n n n<n }

-- 747/PLFA exercise: LTTrich (3 points)
-- Prove that strict inequality satisfies trichotomy : exactly one of the three possibilities holds.
data Trichotomy (m n : ℕ) : Set where
  is-< : m < n → ¬ m ≡ n → ¬ n < m → Trichotomy m n
  is-≡ : m ≡ n → ¬ m < n → ¬ n < m → Trichotomy m n
  is-> : n < m → ¬ m ≡ n → ¬ m < n → Trichotomy m n

open import x03-842Relations-hc-2 using (suc-injective; m≡n→sucm≡sucn)

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

<-trichotomy : ∀ (m n : ℕ) → Trichotomy m n
<-trichotomy zero     zero   = is-≡ refl (λ ()) (λ ())
<-trichotomy zero    (suc n) = is-< z<s  (λ ()) (λ ())
<-trichotomy (suc m)  zero   = is-> z<s  (λ ()) (λ ())
<-trichotomy (suc m) (suc n) with <-trichotomy m n
... | is-< m<n ¬m≡n ¬n<m = is-< (s<s m<n)
                                (λ sucm≡sucn → ¬m≡n (suc-injective sucm≡sucn))
                                (λ sucn<sucm → ¬n<m (inv-s<s       sucn<sucm))
... | is-≡ m≡n ¬m<n ¬n<m = is-≡ (m≡n→sucm≡sucn m n m≡n)
                                (λ sucm<sucn → ¬m<n (inv-s<s       sucm<sucn))
                                (λ sucn<sucm → ¬n<m (inv-s<s       sucn<sucm))
... | is-> n<m ¬m≡n ¬m<n = is-> (s<s n<m)
                                (λ sucm≡sucn → ¬m≡n (suc-injective sucm≡sucn))
                                (λ sucm<sucn → ¬m<n (inv-s<s       sucm<sucn))

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

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

-- Intuitionistic vs classical logic.

-- The law of the excluded middle (LEM, or just em) cannot be proved in intuitionistic logic.
-- LEM can be added to intuitionistic logic to get classical logic.

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

-- 'em-irrefutable' theorem of intuitionistic logic demonstrates
-- that 'em' does not give a contradiction?
em-irrefutable : ∀ {A : Set} → ¬ ¬ (A ⊎ ¬ A)
em-irrefutable = λ z → z (inj₂ (λ x → z (inj₁ x)))

-- PLFA exercise: classical equivalences TODO
-- Here are four other classical theorems that can be added and are consisstent in IT.
-- Prove each is logically equivalent to all the others.
-- It is NOT necessary to prove twenty implications, since implication is transitive.
-- There is a lot of choice as to how to proceed.

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

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

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

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

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

-- End of classical five exercise.

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

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

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

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


module dependentProduct2 where

postulate A : Set
postulate B : A -> Set

data AB : Set where
  p : (a : A) -> B a -> AB

π0 : AB -> A
π0 (p a b) = a

π1 : (ab : AB) -> B (π0 ab)
π1 (p a b) = b

postulate a : A
postulate b : B a

ab : AB
ab = p a b

postulate ab' : AB

a' : A
a' = π0 ab'

b' : B a'
b' = π1 ab'