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

open import Categories.Category.Core

module Categories.Category.Construction.KaroubiEnvelope.Properties {o ℓ e} (𝒞 : Category o ℓ e) where

open import Data.Product using (_,_)

open import Categories.Functor renaming (id to idF)
open import Categories.Functor.Properties

open import Categories.Category.Construction.KaroubiEnvelope

open import Categories.Morphism.Idempotent
import Categories.Morphism.Idempotent.Bundles as BundledIdem

open Category 𝒞
open Equiv

--------------------------------------------------------------------------------
-- Some facts about embedding 𝒞 into it's Karoubi Envelope

KaroubiEmbedding : Functor 𝒞 (KaroubiEnvelope 𝒞)
KaroubiEmbedding = record
  { F₀ = λ X → record
    { obj = X
    ; isIdempotent = record
      { idem = id
      ; idempotent = identity²
      }
    }
  ; F₁ = λ f → record
    { hom = f
    ; absorbˡ = identityˡ
    ; absorbʳ = identityʳ
    }
  ; identity = refl
  ; homomorphism = refl
  ; F-resp-≈ = λ eq → eq
  }

private
  module KaroubiEmbedding = Functor KaroubiEmbedding

karoubi-embedding-full : Full KaroubiEmbedding
karoubi-embedding-full = record
  { from = record
    { _⟨$⟩_ = λ f → BundledIdem.Idempotent⇒.hom f
    ; cong = λ eq → eq
    }
  ; right-inverse-of = λ _ → refl
  }

karoubi-embedding-faithful : Faithful KaroubiEmbedding
karoubi-embedding-faithful f g eq = eq

karoubi-embedding-fully-faithful : FullyFaithful KaroubiEmbedding
karoubi-embedding-fully-faithful = karoubi-embedding-full , karoubi-embedding-faithful

--------------------------------------------------------------------------------
-- Some facts about splitting idempotents

-- All idempotents in the Karoubi Envelope are split
idempotent-split : ∀ {A} → Idempotent (KaroubiEnvelope 𝒞) A → SplitIdempotent (KaroubiEnvelope 𝒞) A
idempotent-split {A} I = record
  { idem = idem
  ; isSplitIdempotent = record
    { obj = record
      { isIdempotent = record
        { idem = idem.hom
        ; idempotent = idempotent
        }
      }
    ; retract = record
      { hom = idem.hom
      ; absorbˡ = idempotent
      ; absorbʳ = idem.absorbʳ
      }
    ; section = record
      { hom = idem.hom
      ; absorbˡ = idem.absorbˡ
      ; absorbʳ = idempotent
      }
    ; retracts = idempotent
    ; splits = idempotent
    }
  }
  where
    module A = BundledIdem.Idempotent A
    open Idempotent I
    module idem = BundledIdem.Idempotent⇒ idem


module Lec2Start where

open import Lec1Done

------------------------------------------------------------------------------
-- Vectors  -- the star of exercise 1
------------------------------------------------------------------------------

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

------------------------------------------------------------------------------
-- Taking a Prefix of a Vector
------------------------------------------------------------------------------

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

------------------------------------------------------------------------------
-- Things to Prove
------------------------------------------------------------------------------

{-+}
vTakeIdFact : (n : Nat){X : Set}(xs : Vec X n) ->
              vTake n n (refl->= n) xs == xs
vTakeIdFact n xs = {!!}

vTakeCpFact : (m n p : Nat)(m>=n : m >= n)(n>=p : n >= p)
              {X : Set}(xs : Vec X m) ->
              vTake m p (trans->= m n p m>=n n>=p) xs ==
                vTake n p n>=p (vTake m n m>=n xs)
{- hit p first: why? -}
vTakeCpFact m n p m>=n n>=p xs = {!!}
{+-}

------------------------------------------------------------------------------
-- Splittings (which bear some relationship to <= from ex1)
------------------------------------------------------------------------------

data _<[_]>_ : Nat -> Nat -> Nat -> Set where
  zzz : zero <[ zero ]> zero
  lll : {l m r : Nat} ->      l <[     m ]> r
                      ->  suc l <[ suc m ]> r
  rrr : {l m r : Nat} ->      l <[     m ]>     r
                      ->      l <[ suc m ]> suc r

{-+}
_>[_]<_ : {X : Set}{l m r : Nat} ->
          Vec X l -> l <[ m ]> r -> Vec X r ->
          Vec X m
xl >[ nnn ]< xr = {!!}
{+-}

{-+}
data FindSplit {X : Set}{l m r : Nat}(nnn : l <[ m ]> r)
     : (xs : Vec X m) -> Set where
  splitBits : (xl : Vec X l)(xr : Vec X r) -> FindSplit nnn (xl >[ nnn ]< xr)
{+-}

{-+}
findSplit : {X : Set}{l m r : Nat}(nnn : l <[ m ]> r)(xs : Vec X m) ->
            FindSplit nnn xs
findSplit nnn xs = {!!}
{+-}

------------------------------------------------------------------------------
-- what I should remember to say
------------------------------------------------------------------------------

-- What's the difference between m>=n and m >= n ?
   {- m>=n (without spaces) is just an identifier; it could be anything,
      but it has been chosen to be suggestive of its *type* which is
      m >= n (with spaces) which is the proposition that m is at least n.
      By "proposition", I mean "type with at most one inhabitant", where
      we care more about whether there is an inhabitant or not than which
      one (because there's never a choice). Finished code does not show
      us the types of its components, and that's not always a good thing.
      Here, by picking nice names, we get something of an aide-memoire. -}

-- What does (x ,-_) mean?
   {- It's a "left section". Right sections (_,- xs) also exist sometimes.
      Why only sometimes? -}

-- "Why is it stuck?"
   {- Proof by induction isn't just flailing about, you know? The trick is
      to pick the case analysis that provokes the "stuck" programs to do a
      step of computation. Then the same reasoning that justifies the
      termination of the program will justify the induction in a proof
      about it. -}


open import Relation.Binary.Core

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

open import BBHeap _≤_ hiding (flatten)
open import BBHeap.Heapify _≤_ tot≤ trans≤
open import BHeap _≤_ hiding (flatten)
open import BHeap.Order _≤_
open import BHeap.Order.Properties _≤_
open import BHeap.Properties _≤_
open import Bound.Lower A
open import Data.List
open import OList _≤_

flatten : {b : Bound}(h : BHeap b) → Acc h → OList b
flatten lf _ = onil
flatten (nd {x = x} b≤x l r) (acc rs) = :< b≤x (flatten (merge tot≤ l r) (rs (merge tot≤ l r) (lemma-merge≤′ tot≤ b≤x l r)))

heapsort : List A → OList bot
heapsort xs = flatten (relax (heapify xs)) (≺-wf (relax (heapify xs)))


module Point where

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

record Point : Set where
  field
    x : Nat
    y : Nat

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

open Point renaming (x to getX; y to getY)

<_,_> : Nat -> Nat -> Point
< x , y > = record { x = x; y = y }

η : (p : Point) -> p == record { x = getX p; y = getY p }
η p = refl

swap : Point -> Point
swap p = < getY p , getX p >

swap-idem : (p : Point) -> swap (swap p) == p
swap-idem p = refl


open import Relation.Binary.Core

module InsertSort.Impl2.Correctness.Order {A : Set}
                  (_≤_ : A → A → Set)
                  (tot≤ : Total _≤_)  where

open import Data.List
open import Function using (_∘_)
open import InsertSort.Impl2 _≤_ tot≤
open import List.Sorted _≤_
open import OList _≤_
open import OList.Properties _≤_

theorem-insertSort-sorted : (xs : List A) → Sorted (forget (insertSort xs))
theorem-insertSort-sorted = lemma-olist-sorted ∘ insertSort


module LinkedList where

open import Data.Unit using (⊤; tt)
open import Data.Empty using (⊥)
open import Data.Nat
import      Data.Fin as Fin
open import Data.Fin
  using (Fin)
  renaming (zero to Fzero; suc to Fsuc)
open import Relation.Binary.PropositionalEquality as PropEq
  using (_≡_; refl; cong)
open import Relation.Nullary using (¬_)
open import Relation.Nullary using (Dec; yes; no; ¬_)
open import Relation.Nullary.Decidable using (False)

data LinkedList (A : Set) : Set where
    [] : LinkedList A
    _∷_ : A → LinkedList A → LinkedList A

--------------------------------------------------------------------------------
-- to ℕ

⟦_⟧ : ∀ {A} → LinkedList A → ℕ
⟦     [] ⟧ = zero
⟦ x ∷ xs ⟧ = suc ⟦ xs ⟧

--------------------------------------------------------------------------------
-- predicates

null : ∀ {A} → LinkedList A → Set
null []      = ⊤
null (_ ∷ _) = ⊥

null? : ∀ {A} → (xs : LinkedList A) → Dec (null xs)
null? []       = yes tt
null? (x ∷ xs) = no (λ z → z)

--------------------------------------------------------------------------------
-- operations

incr : ∀ {A} → A → LinkedList A → LinkedList A
incr = _∷_

decr : ∀ {A} → (xs : LinkedList A) → False (null? xs) → LinkedList A
decr []       ()
decr (x ∷ xs) p = xs

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

elemAt : ∀ {A} → (xs : LinkedList A) → Fin ⟦ xs ⟧ → A
elemAt []       ()
elemAt (x ∷ xs) Fzero    = x
elemAt (x ∷ xs) (Fsuc i) = elemAt xs i


module LecDiff where

open import CS410-Prelude
open import CS410-Nat
open import LecSigma

data Data : Set1 where
  _+D_ _*D_  : Data -> Data -> Data
  label      : Set -> Data
  rec        : Data

infixr 4 _+D_
infixr 5 _*D_

[[_]] : Data -> Set -> Set
[[ S +D T ]]   R  = [[ S ]] R + [[ T ]] R
[[ S *D T ]]   R  = [[ S ]] R * [[ T ]] R
[[ label X ]]  R  = X
[[ rec ]]      R  = R

data Mu (D : Data) : Set where
  <_> : [[ D ]] (Mu D) -> Mu D

-- example: Natural Numbers

NAT : Data
NAT = label One +D rec

pattern ZERO  = < inl <> >
pattern SUC n = < inr n >

#_ : Nat -> Mu NAT
# zero = ZERO
# (suc n) = SUC (# n)

_+DN_ : Mu NAT -> Mu NAT -> Mu NAT
ZERO  +DN n  = n
SUC m +DN n  = SUC (m +DN n)

_<=DN_ : Mu NAT -> Mu NAT -> Two
ZERO   <=DN  n      =  tt
SUC m  <=DN  ZERO   =  ff
SUC m  <=DN  SUC n  =  m <=DN n

-- example: binary trees with nodes labelled by numbers

BST : Data
BST = label One  +D  rec *D label (Mu NAT) *D rec

pattern LEAF = < inl <> >
pattern NODE l n r = < inr (l , n , r) >

insert : Mu NAT -> Mu BST -> Mu BST
insert x LEAF          = NODE LEAF x LEAF
insert x (NODE l y r)  with x <=DN y
insert x (NODE l y r)  | tt = NODE (insert x l) y r
insert x (NODE l y r)  | ff = NODE l y (insert x r)

myBST : Mu BST
myBST = NODE (NODE (NODE LEAF (# 1) LEAF) (# 2) LEAF)
             (# 4)
             (NODE (NODE LEAF (# 5) LEAF) (# 7) LEAF)

myBST' : Mu BST
myBST' = insert (# 3) myBST

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

Diff : Data -> Data
Diff (S +D T)   = Diff S +D Diff T
Diff (S *D T)   = Diff S *D T  +D  S *D Diff T
Diff (label X)  = label Zero
Diff rec        = label One

plug : {R : Set}(D : Data) -> [[ Diff D ]] R -> R -> [[ D ]] R
plug (S +D T) (inl s') r = inl (plug S s' r)
plug (S +D T) (inr t') r = inr (plug T t' r)
plug (S *D T) (inl (s' , t)) r = plug S s' r , t
plug (S *D T) (inr (s , t')) r = s , plug T t' r
plug (label X) () r
plug rec       <> r = r

Shape : Data -> Set
Shape D = [[ D ]] One

Positions : (D : Data) -> Shape D -> Set
Positions (D +D E) (inl d) = Positions D d
Positions (D +D E) (inr e) = Positions E e
Positions (D *D E) (d , e) = Positions D d + Positions E e
Positions (label X) x = Zero
Positions rec <> = One


module plfa.part1.Induction where

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

_ : (3 + 4) + 5 ≡ 3 + (4 + 5)
_ =
  begin
    (3 + 4) + 5
  ≡⟨⟩
    7 + 5
  ≡⟨⟩
    12
  ≡⟨⟩
    3 + 9
  ≡⟨⟩
    3 + (4 + 5)
  ∎

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

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

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

+-identityʳ : ∀ (m : ℕ) → m + zero ≡ m
+-identityʳ m rewrite +-commu m zero = refl

+-swap : ∀ (m n p : ℕ) → m + (n + p) ≡ n + (m + p)
+-swap m n p rewrite +-commu m (n + p)
             rewrite +-assoc n p m
             rewrite +-commu p m = refl

*-assoc : ∀ (m n p : ℕ) → (m + n) * p ≡ m * p + n * p
*-assoc zero n p = refl
*-assoc (suc m) n p
  rewrite +-commu (suc m) n
  rewrite +-assoc p (m * p) (n * p) = cong (λ n → p + n) (*-assoc m n p)


module Numeric.Nat.Properties where

open import Prelude hiding (less-antisym; less-antirefl; leq-antisym)
open import Prelude.Nat.Properties public
open import Tactic.Nat

--- Subtraction ---

sub-less : {a b : Nat} → a ≤ b → b - a + a ≡ b
sub-less {zero} _ = auto
sub-less {suc a} (diff! k) = auto

sub-underflow : (a b : Nat) → a ≤ b → a - b ≡ 0
sub-underflow a ._ (diff! k) = auto

sub-leq : (a b : Nat) → a - b ≤ a
sub-leq a b with compare a b
sub-leq a ._ | less    (diff! k) = diff a auto
sub-leq a .a | equal    refl     = diff a auto
sub-leq ._ b | greater (diff! k) = diff b auto

--- LessNat ---

fast-diff : {a b : Nat} → a < b → a < b
fast-diff {a} {b} a<b = diff (b - suc a) (eraseEquality $ by (sub-less {suc a} {b} (by a<b)))
{-# INLINE fast-diff #-}

infixr 0 _⟨<⟩_ _⟨≤⟩_

_⟨<⟩_ : ∀ {x y z} → LessNat x y → LessNat y z → LessNat x z
diff! a ⟨<⟩ diff! b = diff (suc (b + a)) auto

less-antirefl : ∀ {a b : Nat} → a < b → ¬ (a ≡ b)
less-antirefl (diff! k) eq = refute eq

less-not-geq : ∀ {a b : Nat} → a < b → b ≤ a → ⊥
less-not-geq (diff d eq) (diff! d₁) = refute eq

less-raa : {a b : Nat} → ¬ (suc a > b) → a < b
less-raa {a} {b} a≱b with compare a b
less-raa a≱b | less    a<b = a<b
less-raa a≱b | equal  refl = ⊥-elim (a≱b auto)
less-raa a≱b | greater a>b = ⊥-elim (a≱b (by a>b))

_⟨≤⟩_ : {a b c : Nat} → a ≤ b → b ≤ c → a ≤ c
diff! k ⟨≤⟩ diff! k₁ = auto

private
  leq-mul-r′ : ∀ a b → NonZero b → a ≤ a * b
  leq-mul-r′ _  zero ()
  leq-mul-r′ a (suc b) _ = auto

leq-mul-r : ∀ a b {{_ : NonZero b}} → a ≤ a * b
leq-mul-r a b = fast-diff (leq-mul-r′ _ b it)

-- Used for the well-founded induction over factorisation.
less-mul-l : {a b : Nat} → a > 1 → b > 1 → a < a * b
less-mul-l (diff! k) (diff! j) = auto

less-mul-r : {a b : Nat} → a > 1 → b > 1 → b < a * b
less-mul-r (diff! k) (diff! j) = auto

add-nonzero-l : ∀ a b {{_ : NonZero a}} → NonZero (a + b)
add-nonzero-l zero    b {{}}
add-nonzero-l (suc a) b = _

add-nonzero-r : ∀ a b {{_ : NonZero b}} → NonZero (a + b)
add-nonzero-r zero    zero {{}}
add-nonzero-r zero    (suc b) = _
add-nonzero-r (suc a) b       = _

mul-nonzero : ∀ a b {{nza : NonZero a}} {{nzb : NonZero b}} → NonZero (a * b)
mul-nonzero zero    b    {{nza = ()}}
mul-nonzero (suc a) zero {{nzb = ()}}
mul-nonzero (suc a) (suc b) = _

mul-nonzero-l : ∀ a b {{_ : NonZero (a * b)}} → NonZero a
mul-nonzero-l 0 _ {{}}
mul-nonzero-l (suc _) _ = _

mul-nonzero-r : ∀ a b {{_ : NonZero (a * b)}} → NonZero b
mul-nonzero-r a b {{nz}} = mul-nonzero-l b a {{transport NonZero auto nz}}

mul-unit-l : ∀ a b {{_ : NonZero b}} → a * b ≡ b → a ≡ 1
mul-unit-l 1 _ _ = refl
mul-unit-l 0 .0 {{}} refl
mul-unit-l (suc (suc a)) zero {{}} _
mul-unit-l (suc (suc a)) (suc b) ab=b = refute ab=b

mul-unit-r : ∀ a b {{_ : NonZero a}} → a * b ≡ a → b ≡ 1
mul-unit-r a b ab=a = mul-unit-l b a (mul-commute b a ⟨≡⟩ ab=a)


{-

          Types Summer School 2007

                 Bertinoro
             Aug 19 - 31, 2007

                   Agda

                Ulf Norell

-}

module Filter where

open import Nat

data Bool : Set where
  false : Bool
  true  : Bool

infixr 40 _::_

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

filter : {A : Set} -> (A -> Bool) -> List A -> List A
filter p [] = []
filter p (x :: xs) with p x
filter p (x :: xs) | true  = x :: filter p xs
filter p (x :: xs) | false = filter p xs

infix 20 _⊆_

data _⊆_ {A : Set} : List A -> List A -> Set where
  stop : [] ⊆ []
  drop : forall {xs y ys} -> xs ⊆ ys -> xs ⊆ y :: ys
  keep : forall {x xs ys} -> xs ⊆ ys -> x :: xs ⊆ x :: ys

subset : {A : Set}(p : A -> Bool)(xs : List A) -> filter p xs ⊆ xs
subset p []        = stop
subset p (x :: xs) with p x
... | true = keep (subset p xs)
... | false = drop (subset p xs)

{-
subset p (x :: xs) with p x
subset p (x :: xs) | true  = keep (subset p xs)
subset p (x :: xs) | false = drop (subset p xs)
-}


import      Lvl
open import Type

module Type.Singleton.Proofs {ℓ : Lvl.Level} {X : Type{ℓ}} where

open import Functional
open import Function.Domains
open import Logic.Predicate
open import Relator.Equals
open import Relator.Equals.Proofs
open import Type.Properties.Empty
open import Type.Singleton
open import Type.Properties.Singleton
open import Structure.Type.Identity

instance
  -- There is always a construction of a singleton type
  Singleton-existence : ∀{x : X} → Singleton(x)
  Singleton-existence {x} = [∃]-intro(x) ⦃ [≡]-intro ⦄

instance
  -- There is an unique construction of a singleton type
  Singleton-is-unit : ∀{x : X} → IsUnit(Singleton(x))
  Singleton-is-unit {x} = intro (Singleton-existence{x}) (g{x}) where
    A : ∀{y x : X} → (y ≡ x) → Type{ℓ}
    A {y}{x} (xy-proof) = ([∃]-intro y ⦃ xy-proof ⦄ ≡ Singleton-existence{x})

    f : ∀{x : X} → A{x}{x}([≡]-intro {_}{_} {x})
    f{x} = [≡]-intro {_}{_} {Singleton-existence{x}}

    Φ : ∀{y x : X}{xy-proof : (y ≡ x)} → ([∃]-intro y ⦃ xy-proof ⦄ ≡ Singleton-existence{x})
    Φ {y}{x}{xy-proof} = idElim(_≡_ {T = X}) (A)(f) {y}{x}(xy-proof)

    g : ∀{x : X}{σ : Singleton(x)} → (σ ≡ Singleton-existence{x})
    g{x}{[∃]-intro y ⦃ proof ⦄} = Φ{y}{x}{proof}


module BuildingBlock where

open import Data.Nat

--------------------------------------------------------------------------------
-- Binomial Tree

-- NodeList C n : list of C indexed from 0 to n
data NodeList (C : ℕ → Set) : ℕ → Set where
    Nil : C 0 → NodeList C 0
    Cons : ∀ {n} → C (suc n) → NodeList C n → NodeList C (suc n)

data BinomialTree (A : Set) : ℕ → Set where
    Leaf : A → BinomialTree A 0
    Node : ∀ {n} → A → NodeList (BinomialTree A) n → BinomialTree A (suc n)

-- examples
private
    ein : BinomialTree ℕ 0
    ein = Leaf 0

    zwei : BinomialTree ℕ 1
    zwei = Node 1
            (Nil (Leaf 0))

    fier' : BinomialTree ℕ 2
    fier' = Node 0
            (Cons (Node 1
                (Nil (Leaf 2)))
            (Nil (Leaf 3)))

--------------------------------------------------------------------------------
-- Pennants

data CompleteBinaryTree (A : Set) : ℕ → Set where
    Leaf : A → CompleteBinaryTree A 0
    Node : ∀ {n}  → A
                → CompleteBinaryTree A n
                → CompleteBinaryTree A n
                → CompleteBinaryTree A (suc n)

data Pennants (A : Set) : ℕ → Set where
    Leaf : A → Pennants A 0
    Node : ∀ {n}  → A
                → CompleteBinaryTree A n
                → Pennants A n

-- examples
private
    zweiP : Pennants ℕ 2
    zweiP = Node 0 (Node 1
                    (Node 2
                        (Leaf 3)
                        (Leaf 4))
                    (Node 5
                        (Leaf 6) (Leaf 7)))


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

-- The category of group objects with a cartesian category

open import Categories.Category
open import Categories.Category.Cartesian

module Categories.Category.Construction.Groups {o ℓ e} {𝒞 : Category o ℓ e} (C : Cartesian 𝒞) where

open import Level

open import Categories.Category.BinaryProducts 𝒞
open import Categories.Morphism.Reasoning 𝒞
open import Categories.Object.Group C
open import Categories.Object.Product.Morphisms 𝒞

open Category 𝒞
open Cartesian C
open BinaryProducts products
open Equiv
open HomReasoning
open Group using (μ)
open Group⇒

Groups : Category (o ⊔ ℓ ⊔ e) (ℓ ⊔ e) e
Groups = record
  { Obj = Group
  ; _⇒_ = Group⇒
  ; _≈_ = λ f g → arr f ≈ arr g
  ; id = record
    { arr = id
    ; preserves-μ = identityˡ ○ introʳ (id×id product)
    ; preserves-η = identityˡ
    ; preserves-ι = id-comm-sym
    }
  ; _∘_ = λ f g → record
    { arr = arr f ∘ arr g
    ; preserves-μ = glue (preserves-μ f) (preserves-μ g) ○ ∘-resp-≈ʳ ⁂∘⁂
    ; preserves-η = glueTrianglesˡ (preserves-η f) (preserves-η g)
    ; preserves-ι = glue (preserves-ι f) (preserves-ι g)
    }
  ; assoc = assoc
  ; sym-assoc = sym-assoc
  ; identityˡ = identityˡ
  ; identityʳ = identityʳ
  ; identity² = identity²
  ; equiv = record
    { refl = refl
    ; sym = sym
    ; trans = trans
    }
  ; ∘-resp-≈ = ∘-resp-≈
  }


module #4 where

open import Data.Nat
open import Data.Product

{-
Exercise 1.4. Assuming as given only the iterator for natural numbers

iter : ∏ C → (C → C) → N → C
      C:U

with the defining equations

        iter(C, c0, cs, 0) :≡ c0
  iter(C, c0, cs, succ(n)) :≡ cs(iter(C, c0, cs, n)),

derive a function having the type of the recursor recN. Show that the defining equations of the
recursor hold propositionally for this function, using the induction principle for N.
-}

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

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

rec : ∀{k}{C : Set k} → C → (ℕ → C → C) → ℕ → C
rec {i}{C} c0 f n = proj₂ (iter z (λ p → (suc (proj₁ p) , f (proj₁ p) (proj₂ p))) n)
  where
    z : ℕ × C
    z = (0 , c0)


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

module Demos.Binary where

open import Data.Nat
open import Testers
open import Prelude

infixl 5 _1𝕓 _2𝕓
data 𝔹 : Type where
  0𝕓  : 𝔹
  _1𝕓 : 𝔹 → 𝔹
  _2𝕓 : 𝔹 → 𝔹

⟦_⇓⟧ : 𝔹 → ℕ
⟦ 0𝕓 ⇓⟧ = 0
⟦ n 1𝕓 ⇓⟧ = 1 + ⟦ n ⇓⟧ * 2
⟦ n 2𝕓 ⇓⟧ = 2 + ⟦ n ⇓⟧ * 2

inc : 𝔹 → 𝔹
inc 0𝕓 = 0𝕓 1𝕓
inc (xs 1𝕓) = xs 2𝕓
inc (xs 2𝕓) = inc xs 1𝕓

⟦_⇑⟧ : ℕ → 𝔹
⟦ zero  ⇑⟧ = 0𝕓
⟦ suc n ⇑⟧ = inc ⟦ n ⇑⟧

inc-suc : ∀ x → ⟦ inc x ⇓⟧ ≡ suc ⟦ x ⇓⟧
inc-suc 0𝕓     i = 1
inc-suc (x 1𝕓) i = 2 + ⟦ x ⇓⟧ * 2
inc-suc (x 2𝕓) i = suc (inc-suc x i * 2)

inc-2*-1𝕓 : ∀ n → inc ⟦ n * 2 ⇑⟧ ≡ ⟦ n ⇑⟧ 1𝕓
inc-2*-1𝕓 zero    i = 0𝕓 1𝕓
inc-2*-1𝕓 (suc n) i = inc (inc (inc-2*-1𝕓 n i))

𝔹-rightInv : ∀ x → ⟦ ⟦ x ⇑⟧ ⇓⟧ ≡ x
𝔹-rightInv zero    = refl
𝔹-rightInv (suc x) = inc-suc ⟦ x ⇑⟧ ; cong suc (𝔹-rightInv x)

𝔹-leftInv : ∀ x → ⟦ ⟦ x ⇓⟧ ⇑⟧ ≡ x
𝔹-leftInv 0𝕓 = refl
𝔹-leftInv (x 1𝕓) =           inc-2*-1𝕓 ⟦ x ⇓⟧  ; cong _1𝕓 (𝔹-leftInv x)
𝔹-leftInv (x 2𝕓) = cong inc (inc-2*-1𝕓 ⟦ x ⇓⟧) ; cong _2𝕓 (𝔹-leftInv x)

ℕ⇔𝔹 : 𝔹 ⇔ ℕ
ℕ⇔𝔹 .fun = ⟦_⇓⟧
ℕ⇔𝔹 .inv = ⟦_⇑⟧
ℕ⇔𝔹 .rightInv = 𝔹-rightInv
ℕ⇔𝔹 .leftInv = 𝔹-leftInv


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

module Data.Quiver.Paths where

-- Paths in a Quiver.
--
-- This is almost the same as the 'paths' in a relation, as defined in
-- Relation.Binary.Construct.Closure.ReflexiveTransitive
-- but here the relation is typed, and that has to be respected. So this
-- is somewhat duplicated

open import Level
open import Data.Quiver
open import Relation.Binary using (Rel; IsEquivalence; Setoid)
import Relation.Binary.Reasoning.Setoid as EqR
open import Relation.Binary.Construct.Closure.ReflexiveTransitive
open import Relation.Binary.PropositionalEquality as ≡ using (_≡_)

module Paths {o ℓ e : Level} (Q : Quiver o ℓ e) where
  open Quiver Q hiding (setoid)

  private
    variable
      A B : Obj

  infix 4 _≈*_
  data _≈*_ : (p q : Star _⇒_ A B) → Set (o ⊔ ℓ ⊔ e) where
    ε : {A : Obj} → _≈*_ {A} ε ε
    _◅_ : {A B C : Obj} {x y : A ⇒ B} {p q : Star _⇒_ B C} (x≈y : x ≈ y) (p≈q : p ≈* q) → x ◅ p ≈* y ◅ q

  refl : {p : Star _⇒_ A B} → p ≈* p
  refl {p = ε} = ε
  refl {p = x ◅ p} = Equiv.refl ◅ refl

  sym : {p q : Star _⇒_ A B} → p ≈* q → q ≈* p
  sym ε = ε
  sym (x≈y ◅ eq) = Equiv.sym x≈y ◅ sym eq

  ≡⇒≈* : {p q : Star _⇒_ A B} → p ≡ q → p ≈* q
  ≡⇒≈* ≡.refl = refl

  ≡⇒≈ : {p q : A ⇒ B} → p ≡ q → p ≈ q
  ≡⇒≈ ≡.refl = Equiv.refl

  trans : {p q r : Star _⇒_ A B} → p ≈* q → q ≈* r → p ≈* r
  trans ε ε = ε
  trans (x≈y ◅ ss) (y≈z ◅ tt) = Equiv.trans x≈y y≈z ◅ trans ss tt

  isEquivalence : IsEquivalence (λ (p q : Star _⇒_ A B) → p ≈* q)
  isEquivalence = record { refl = refl ; sym = sym ; trans = trans }

  setoid : Obj → Obj → Setoid (o ⊔ ℓ) (o ⊔ ℓ ⊔ e)
  setoid A B = record { _≈_ = _≈*_ ; isEquivalence = isEquivalence {A} {B} }

  -- convenient to define here
  --
  -- FIXME: this should go into the standard library at
  -- Relation.Binary.Construct.Closure.ReflexiveTransitive.Properties
  ◅◅-identityʳ : (f : Star _⇒_ A B) → f ◅◅ ε ≈* f
  ◅◅-identityʳ ε = ε
  ◅◅-identityʳ (x ◅ f) = Equiv.refl ◅ ◅◅-identityʳ f

  module PathEqualityReasoning {A B} where
    open EqR (setoid A B) public


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

interleaved mutual

  data Even : Nat → Set
  data Odd  : Nat → Set

  -- base cases: 0 is Even, 1 is Odd
  constructor
    even-zero : Even zero
    odd-one   : Odd (suc zero)

  -- step case: suc switches the even/odd-ness
  constructor
    even-suc : ∀ {n} → Odd n → Even (suc n)
    odd-suc  : ∀ {n} → Even n → Odd (suc n)


module Vec where

open import SHE-Prelude

data Nat : Set where
  z : Nat
  s : Nat -> Nat

data Vec (X : Set) : Nat -> Set where
  vNil : Vec X z
  _:-_ : forall {n} ->
         X -> Vec X n -> Vec X (s n)

_+N_ : Nat -> Nat -> Nat
z  +N n = n
s m +N n = s (m +N n)

_vappend_ : forall {X m n} -> Vec X m -> Vec X n -> Vec X (m +N n)
vNil vappend ys = ys
(x :- xs) vappend ys = x :- (xs vappend ys)

vec : forall {n X} -> X -> Vec X n
vec {z} x = vNil
vec {s n} x = x :- vec x

_N>=_ : Nat -> Nat -> Set
m N>= z = One
z N>= s n  = Zero
s m N>= s n = m N>= n

vtake : {X : Set}{m : Nat}(n : Nat) -> m N>= n -> Vec X m -> Vec X n
vtake (s n) () vNil
vtake z p xs = vNil
vtake (s n) p (x :- xs) = x :- (vtake n p xs)

VecApp : forall {n} -> Applicative \X -> Vec X n
VecApp {n} = record
  { pure  = vec
  ; _<*>_ = vapp
  } where
    vapp : forall {n X Y} ->
       Vec (X -> Y) n -> Vec X n -> Vec Y n
    vapp vNil vNil = vNil
    vapp (f :- fs) (x :- xs) = f x :- vapp fs xs

v1 : Vec Nat (s (s (s z)))
v1 = Applicative.pure VecApp z

v2 : Vec Nat (s z)
v2 = vtake (s z) <> v1

v3 : Vec Nat (s z)
v3 = vec {s z} z

v5 : Vec Nat (s z)
v5 = vtake (s z) <> (z :- (z :- vNil))

v6 : Vec Nat (s z)
v6 = vtake (s z) <> (z :- (z :- vNil))


------------------------------------------------------------------------
-- Properties of functions, such as associativity and commutativity
------------------------------------------------------------------------

-- These properties can (for instance) be used to define algebraic
-- structures.

open import Relation.Binary

-- The properties are specified using the following relation as
-- "equality".

module Algebra.FunctionProperties {A} (_≈_ : Rel A) where

open import Data.Product

------------------------------------------------------------------------
-- Unary and binary operations

open import Algebra.FunctionProperties.Core public

------------------------------------------------------------------------
-- Properties of operations

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

Commutative : Op₂ A → Set
Commutative _∙_ = ∀ x y → (x ∙ y) ≈ (y ∙ x)

LeftIdentity : A → Op₂ A → Set
LeftIdentity e _∙_ = ∀ x → (e ∙ x) ≈ x

RightIdentity : A → Op₂ A → Set
RightIdentity e _∙_ = ∀ x → (x ∙ e) ≈ x

Identity : A → Op₂ A → Set
Identity e ∙ = LeftIdentity e ∙ × RightIdentity e ∙

LeftZero : A → Op₂ A → Set
LeftZero z _∙_ = ∀ x → (z ∙ x) ≈ z

RightZero : A → Op₂ A → Set
RightZero z _∙_ = ∀ x → (x ∙ z) ≈ z

Zero : A → Op₂ A → Set
Zero z ∙ = LeftZero z ∙ × RightZero z ∙

LeftInverse : A → Op₁ A → Op₂ A → Set
LeftInverse e _⁻¹ _∙_ = ∀ x → (x ⁻¹ ∙ x) ≈ e

RightInverse : A → Op₁ A → Op₂ A → Set
RightInverse e _⁻¹ _∙_ = ∀ x → (x ∙ (x ⁻¹)) ≈ e

Inverse : A → Op₁ A → Op₂ A → Set
Inverse e ⁻¹ ∙ = LeftInverse e ⁻¹ ∙ × RightInverse e ⁻¹ ∙

_DistributesOverˡ_ : Op₂ A → Op₂ A → Set
_*_ DistributesOverˡ _+_ =
  ∀ x y z → (x * (y + z)) ≈ ((x * y) + (x * z))

_DistributesOverʳ_ : Op₂ A → Op₂ A → Set
_*_ DistributesOverʳ _+_ =
  ∀ x y z → ((y + z) * x) ≈ ((y * x) + (z * x))

_DistributesOver_ : Op₂ A → Op₂ A → Set
* DistributesOver + = (* DistributesOverˡ +) × (* DistributesOverʳ +)

_IdempotentOn_ : Op₂ A → A → Set
_∙_ IdempotentOn x = (x ∙ x) ≈ x

Idempotent : Op₂ A → Set
Idempotent ∙ = ∀ x → ∙ IdempotentOn x

IdempotentFun : Op₁ A → Set
IdempotentFun f = ∀ x → f (f x) ≈ f x

_Absorbs_ : Op₂ A → Op₂ A → Set
_∙_ Absorbs _∘_ = ∀ x y → (x ∙ (x ∘ y)) ≈ x

Absorptive : Op₂ A → Op₂ A → Set
Absorptive ∙ ∘ = (∙ Absorbs ∘) × (∘ Absorbs ∙)

Involutive : Op₁ A → Set
Involutive f = ∀ x → f (f x) ≈ x


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

open import Algebra

module Algebra.Props.Group (g : Group) where

open Group g
import Algebra.FunctionProperties as P; open P _≈_
import Relation.Binary.EqReasoning as EqR; open EqR setoid
open import Data.Function
open import Data.Product

⁻¹-involutive : ∀ x → x ⁻¹ ⁻¹ ≈ x
⁻¹-involutive x = begin
  x ⁻¹ ⁻¹               ≈⟨ sym $ proj₂ identity _ ⟩
  x ⁻¹ ⁻¹ ∙ ε           ≈⟨ refl ⟨ ∙-pres-≈ ⟩ sym (proj₁ inverse _) ⟩
  x ⁻¹ ⁻¹ ∙ (x ⁻¹ ∙ x)  ≈⟨ sym $ assoc _ _ _ ⟩
  x ⁻¹ ⁻¹ ∙ x ⁻¹ ∙ x    ≈⟨ proj₁ inverse _ ⟨ ∙-pres-≈ ⟩ refl ⟩
  ε ∙ x                 ≈⟨ proj₁ identity _ ⟩
  x                     ∎

left-identity-unique : ∀ x y → x ∙ y ≈ y → x ≈ ε
left-identity-unique x y eq = begin
  x              ≈⟨ sym (proj₂ identity x) ⟩
  x ∙ ε          ≈⟨ refl ⟨ ∙-pres-≈ ⟩ sym (proj₂ inverse y) ⟩
  x ∙ (y ∙ y ⁻¹) ≈⟨ sym (assoc x y (y ⁻¹)) ⟩
  (x ∙ y) ∙ y ⁻¹ ≈⟨ eq ⟨ ∙-pres-≈ ⟩ refl ⟩
       y  ∙ y ⁻¹ ≈⟨ proj₂ inverse y ⟩
  ε              ∎

right-identity-unique : ∀ x y → x ∙ y ≈ x → y ≈ ε
right-identity-unique x y eq = begin
  y              ≈⟨ sym (proj₁ identity y) ⟩
  ε          ∙ y ≈⟨ sym (proj₁ inverse x) ⟨ ∙-pres-≈ ⟩ refl ⟩
  (x ⁻¹ ∙ x) ∙ y ≈⟨ assoc (x ⁻¹) x y ⟩
  x ⁻¹ ∙ (x ∙ y) ≈⟨ refl ⟨ ∙-pres-≈ ⟩ eq ⟩
  x ⁻¹ ∙  x      ≈⟨ proj₁ inverse x ⟩
  ε              ∎

identity-unique : ∀ {x} → Identity x _∙_ → x ≈ ε
identity-unique {x} id = left-identity-unique x x (proj₂ id x)


module Numeral.Natural.Relation.Order.Category where

open import Data.Tuple as Tuple using (_⨯_ ; _,_)
open import Functional
open import Logic
open import Logic.Propositional
open import Logic.IntroInstances
import      Lvl
open import Numeral.Natural
open import Numeral.Natural.Relation.Order
open import Numeral.Natural.Relation.Order.Proofs
open import Relator.Equals
open import Relator.Equals.Proofs.Equiv
import      Structure.Categorical.Names as Names
open import Structure.Categorical.Properties
open import Structure.Category
import      Structure.Function.Names as Names
open import Structure.Operator
open import Structure.Relator.Properties
open import Type

instance
  [≤]-identityₗ : Morphism.Identityₗ{Obj = ℕ}(\{x} → swap(transitivity(_≤_) {x})) (reflexivity(_≤_))
  [≤]-identityₗ = Morphism.intro proof where
    proof : Names.Morphism.Identityₗ{Obj = ℕ}(\{x} → swap(transitivity(_≤_) {x})) (reflexivity(_≤_))
    proof {𝟎}   {y}   {min} = [≡]-intro
    proof {𝐒 x} {𝐒 y} {succ p} = [≡]-with succ (proof {x}{y} {p})

instance
  [≤]-identityᵣ : Morphism.Identityᵣ{Obj = ℕ}(\{x} → swap(transitivity(_≤_) {x})) (reflexivity(_≤_))
  [≤]-identityᵣ = Morphism.intro proof where
    proof : Names.Morphism.Identityᵣ{Obj = ℕ}(\{x} → swap(transitivity(_≤_) {x})) (reflexivity(_≤_))
    proof {𝟎}   {y}   {min} = [≡]-intro
    proof {𝐒 x} {𝐒 y} {succ p} = [≡]-with (p ↦ [≤]-with-[𝐒] ⦃ p ⦄) (proof {x}{y} {p})

instance
  [≤]-associativity : Morphism.Associativity{Obj = ℕ}(\{x} → swap(transitivity(_≤_) {x}))
  [≤]-associativity = Morphism.intro proof where
    proof : Names.Morphism.Associativity{Obj = ℕ}(\{x} → swap(transitivity(_≤_) {x}))
    proof {.𝟎}     {.𝟎}     {.𝟎}     {w}      {min}    {min}    {min}    = [≡]-intro
    proof {.𝟎}     {.𝟎}     {.(𝐒 _)} {.(𝐒 _)} {succ _} {min}    {min}    = [≡]-intro
    proof {.𝟎}     {.(𝐒 _)} {.(𝐒 _)} {.(𝐒 _)} {succ _} {succ _} {min}    = [≡]-intro
    proof {.(𝐒 _)} {.(𝐒 _)} {.(𝐒 _)} {.(𝐒 _)} {succ _} {succ _} {succ _} = [≡]-with succ proof

instance
  [≤]-category : Category(_≤_)
  Category._∘_ [≤]-category = swap(transitivity(_≤_))
  Category.id  [≤]-category = reflexivity(_≤_)
  Category.binaryOperator [≤]-category = intro(\{[≡]-intro [≡]-intro → [≡]-intro})


module Data.Nat.Properties where

import Prelude
import Logic.Base
import Logic.Relations
import Logic.Equivalence
import Logic.Operations as Operations
import Logic.Identity
import Logic.ChainReasoning
import Data.Nat
import Data.Bool

open Prelude
open Data.Nat
open Logic.Base
open Logic.Relations
open Logic.Identity
open Data.Bool

module Proofs where

  module Ops = Operations.MonoEq {Nat} Equiv
  open Ops

  module Chain = Logic.ChainReasoning.Poly.Homogenous _≡_ (\x -> refl) (\x y z -> trans)
  open Chain

  +zero : (n : Nat) -> n + zero ≡ n
  +zero  zero   = refl
  +zero (suc n) = cong suc (+zero n)

  +suc : (n m : Nat) -> n + suc m ≡ suc (n + m)
  +suc  zero   m = refl
  +suc (suc n) m = cong suc (+suc n m)

  +commute : Commutative _+_
  +commute x  zero   = +zero x
  +commute x (suc y) = trans (+suc x y) (cong suc (+commute x y))

  +assoc : Associative _+_
  +assoc  zero   y z = refl
  +assoc (suc x) y z = cong suc (+assoc x y z)

  *zero : (n : Nat) -> n * zero ≡ zero
  *zero  zero   = refl
  *zero (suc n) = *zero n

  *suc : (x y : Nat) -> x * suc y ≡ x + x * y
  *suc  zero   y = refl
  *suc (suc x) y =
    chain> suc x * suc y
       === suc (y + x * suc y)   by refl
       === suc (x + (y + x * y)) by cong suc
        ( chain> y + x * suc y
             === y + (x + x * y)  by cong (_+_ y) (*suc x y)
             === (y + x) + x * y  by +assoc y x (x * y)
             === (x + y) + x * y  by cong (flip _+_ (x * y)) (+commute y x)
             === x + (y + x * y)  by sym (+assoc x y (x * y))
        )
       === suc x + suc x * y     by refl

  *commute : (x y : Nat) -> x * y ≡ y * x
  *commute x  zero   = *zero x
  *commute x (suc y) = trans (*suc x y) (cong (_+_ x) (*commute x y))

  one* : (x : Nat) -> 1 * x ≡ x
  one* x = +zero x

  *one : (x : Nat) -> x * 1 ≡ x
  *one x = trans (*commute x 1) (one* x)

  *distrOver+L : (x y z : Nat) -> x * (y + z) ≡ x * y + x * z
  *distrOver+L  zero   y z = refl
  *distrOver+L (suc x) y z =
    chain> suc x * (y + z)
       === (y + z) + x * (y + z)      by refl
       === (y + z) + (x * y + x * z)  by cong (_+_ (y + z)) ih
       === ((y + z) + x * y) + x * z  by +assoc (y + z) (x * y) (x * z)
       === (y + (z + x * y)) + x * z  by cong (flip _+_ (x * z)) (sym (+assoc y z (x * y)))
       === (y + (x * y + z)) + x * z  by cong (\w -> (y + w) + x * z) (+commute z (x * y))
       === ((y + x * y) + z) + x * z  by cong (flip _+_ (x * z)) (+assoc y (x * y) z)
       === (y + x * y) + (z + x * z)  by sym (+assoc (y + x * y) z (x * z))
       === suc x * y + suc x * z      by refl
    where
      ih = *distrOver+L x y z

  *distrOver+R : (x y z : Nat) -> (x + y) * z ≡ x * z + y * z
  *distrOver+R  zero   y z = refl
  *distrOver+R (suc x) y z =
    chain> (suc x + y) * z
       === z + (x + y) * z      by refl
       === z + (x * z + y * z)  by cong (_+_ z) (*distrOver+R x y z)
       === (z + x * z) + y * z  by +assoc z (x * z) (y * z)
       === suc x * z + y * z    by refl

  *assoc : Associative _*_
  *assoc  zero   y z = refl
  *assoc (suc x) y z =
    chain> suc x * (y * z)
       === y * z + x * (y * z)  by refl
       === y * z + (x * y) * z  by cong (_+_ (y * z)) ih
       === (y + x * y) * z      by sym (*distrOver+R y (x * y) z)
       === (suc x * y) * z      by refl
    where
      ih = *assoc x y z

  ≤refl : (n : Nat) -> IsTrue (n ≤ n)
  ≤refl  zero   = tt
  ≤refl (suc n) = ≤refl n

  <implies≤ : (n m : Nat) -> IsTrue (n < m) -> IsTrue (n ≤ m)
  <implies≤  zero    m      h = tt
  <implies≤ (suc n)  zero   ()
  <implies≤ (suc n) (suc m) h = <implies≤ n m h

  n-m≤n : (n m : Nat) -> IsTrue (n - m ≤ n)
  n-m≤n  zero    m      = tt
  n-m≤n (suc n)  zero   = ≤refl n
  n-m≤n (suc n) (suc m) = <implies≤ (n - m) (suc n) (n-m≤n n m)

--   mod≤ : (n m : Nat) -> IsTrue (mod n (suc m) ≤ m)
--   mod≤  zero   m = tt
--   mod≤ (suc n) m = mod≤ (n - m) m

open Proofs public


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

module Experiment.SumFin where

open import Data.Empty
open import Data.Unit
open import Data.Sum
open import Data.Nat
open import Data.Nat.Properties
open import Relation.Binary.PropositionalEquality

private
  variable
    k : ℕ

Fin : ℕ → Set
Fin zero    = ⊥
Fin (suc n) = ⊤ ⊎ (Fin n)

pattern fzero  = inj₁ tt
pattern fsuc n = inj₂ n

finj : Fin k → Fin (suc k)
finj {suc k} fzero    = fzero
finj {suc k} (fsuc n) = fsuc (finj {k} n)

toℕ : Fin k → ℕ
toℕ {suc k} (inj₁ tt) = zero
toℕ {suc k} (inj₂ x)  = suc (toℕ {k} x)

toℕ-injective : {m n : Fin k} → toℕ m ≡ toℕ n → m ≡ n
toℕ-injective {suc k} {fzero}  {fzero}  _ = refl
toℕ-injective {suc k} {fzero} {fsuc x} ()
toℕ-injective {suc k} {fsuc m} {fzero} ()
toℕ-injective {suc k} {fsuc m} {fsuc x} p = cong fsuc (toℕ-injective (suc-injective p))


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

-- 'Heterogeneous' identity morphism and some laws about them.

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

open import Level
open import Relation.Binary.PropositionalEquality

import Categories.Morphism as Morphism

open Category C
open Morphism C

-- If Agda was an extensional type theory, any pair of morphisms
--
--   f : A ⇒ B   and   g : A ⇒ C,
--
-- where `A ≡ B`, would belong to the same homset, even if `A` and `B`
-- are not definitionally equal.  In particular, the identity on `B`
-- could be given the type |id {B} : B ⇒ C|.
--
-- But Agda is an intensional type theory, so the identity cannot have
-- this type, in general.  Instead one needs to manually 'transport'
-- |id {B}| into the homset |B ⇒ C|.  Given |p : B ≡ C| one obtains
--
--   subst (B ⇒_) p (id {B})
--
-- Morphisms like thes are no longer identities (in the strict
-- sense) but they still enjoy many of the properties identities do.
--
-- To make this precise, this module introduces a notion of
-- 'heterogeneous identity', which is an identity morphism whose
-- domain and codomain are propositionally equal (but not necessarily
-- syntically equal).

-- A heterogeneous identity is just the transport of an identity
-- along a 'strict' equation of objects.

hid : ∀ {A B} (p : A ≡ B) → A ⇒ B
hid {A} p = subst (A ⇒_) p id

-- Lemmas about heterogeneous identities

hid-refl : ∀ {A : Obj} → hid refl ≈ id {A}
hid-refl = Equiv.refl

hid-trans : ∀ {A B C} (p : B ≡ C) (q : A ≡ B) →
            hid p ∘ hid q ≈ hid (trans q p)
hid-trans refl refl = identityˡ

hid-symˡ : ∀ {A B} (p : A ≡ B) → hid (sym p) ∘ hid p ≈ id {A}
hid-symˡ refl = identityˡ

hid-symʳ : ∀ {A B} (p : A ≡ B) → hid p ∘ hid (sym p) ≈ id {B}
hid-symʳ refl = identityˡ

hid-iso : ∀ {A B} (p : A ≡ B) → Iso (hid p) (hid (sym p))
hid-iso p = record { isoˡ = hid-symˡ p ; isoʳ = hid-symʳ p }

hid-cong : ∀ {A B} {p q : A ≡ B} → p ≡ q → hid p ≈ hid q
hid-cong refl = Equiv.refl

-- Transporting the domain/codomain is the same as
-- pre/post-composing with heterogeneous identity.

hid-subst-dom : ∀ {A B C} (p : A ≡ B) (f : B ⇒ C) →
                subst (_⇒ C) (sym p) f ≈ f ∘ hid p
hid-subst-dom refl f = Equiv.sym identityʳ

hid-subst-cod : ∀ {A B C} (f : A ⇒ B) (p : B ≡ C) →
                subst (A ⇒_) p f ≈ hid p ∘ f
hid-subst-cod f refl = Equiv.sym identityˡ

hid-subst₂ : ∀ {A B C D} (p : A ≡ B) (q : C ≡ D) (f : A ⇒ C) →
             subst₂ (_⇒_) p q f ≈ hid q ∘ f ∘ hid (sym p)
hid-subst₂ refl refl f = Equiv.sym (Equiv.trans identityˡ identityʳ)


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

{-
  Properties regarding Morphisms of a category:
  - Regular Monomorphism
  - Regular Epimorphism

  https://ncatlab.org/nlab/show/regular+epimorphism

  These are defined here rather than in Morphism, as this
  might cause import cycles (and make the dependency graph
  very odd).
-}
open import Categories.Category.Core

module Categories.Morphism.Regular {o ℓ e} (𝒞 : Category o ℓ e) where

open import Level

open import Categories.Morphism 𝒞
open import Categories.Diagram.Equalizer 𝒞
open import Categories.Diagram.Coequalizer 𝒞

open Category 𝒞

private
  variable
    A B : Obj
    f : A ⇒ B

record RegularMono (f : A ⇒ B) : Set (o ⊔ ℓ ⊔ e) where
  field
    { C } : Obj
    g : B ⇒ C
    h : B ⇒ C
    equalizer : IsEqualizer f h g

record RegularEpi (f : A ⇒ B) : Set (o ⊔ ℓ ⊔ e) where
  field
    { C } : Obj
    h : C ⇒ A
    g : C ⇒ A
    coequalizer : IsCoequalizer h g f

RegularMono⇒Mono : RegularMono f → Mono f
RegularMono⇒Mono regular = IsEqualizer⇒Mono equalizer
  where
    open RegularMono regular

RegularEpi⇒Epi : RegularEpi f → Epi f
RegularEpi⇒Epi regular = IsCoequalizer⇒Epi coequalizer
  where
    open RegularEpi regular


module 040-monoid where

-- We need semigroups.

open import 030-semigroup

-- The next useful structure is a monoid, which is a semigroup with
-- (left and right) identity element.

record Monoid
  {M : Set}
  (_==_ : M -> M -> Set)
  (_*_ : M -> M -> M)
  (id : M)
  : Set1 where

  field
    semigroup : SemiGroup _==_ _*_
    r*id==r : ∀ {r} -> (r * id) == r
    id*r==r : ∀ {r} -> (id * r) == r

  open SemiGroup semigroup public

  -- Should we define powers? We cannot do this yet: we need natural
  -- numbers first, which we do not have yet.

  -- Let us prove some facts.

  -- Identity can occur on either side of the equality.
  r==r*id : ∀ {r} -> r == (r * id)
  r==r*id = symm r*id==r
  r==id*r : ∀ {r} -> r == (id * r)
  r==id*r = symm id*r==r

  -- The identity element is unique (both left and right).
  idleftunique : ∀ {r} -> (∀ {s} -> (r * s) == s) -> (r == id)
  idleftunique r*s==s = trans r==r*id r*s==s

  idrightunique : ∀ {r} -> (∀ {s} -> (s * r) == s) -> (r == id)
  idrightunique s*r==s = trans r==id*r s*r==s


-- Andreas, 2013-10-21
-- There was a bug in Rules/Builtin such that NATEQUALS' equations
-- would be checked at type Nat instead of Bool.
-- This bug surfaced only because of today's refactoring in Conversion,
-- because then I got a strange unsolved constraint  true == true : Nat.

module NatEquals where

import Common.Level

data Bool : Set where
  true false : Bool

{-# BUILTIN BOOL  Bool  #-}
{-# BUILTIN TRUE  true  #-}
{-# BUILTIN FALSE false #-}

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

{-# BUILTIN NATURAL Nat #-}

infix 40 _=?=_

_=?=_ : Nat -> Nat -> Bool
zero  =?= zero  = true
zero  =?= suc _ = false
suc _ =?= zero  = false
suc n =?= suc m = n =?= m

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


-- This file defines instances for natural numbers and integers to
-- overload various operations.

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

module Instances where

-- imports from stdlib.
import Data.Nat as Nat
import Data.Integer as Int
import Data.Integer.DivMod as IDM
import Data.Nat.DivMod as NDM

-- imports from local.
open import Typeclasses public

-- Natural numbers form a semiring.
instance
  SMℕ : SemiRing Nat.ℕ
  SMℕ ._+_ = Nat._+_
  SMℕ ._*_ = Nat._*_
  SMℕ .0# = 0
  SMℕ .1# = 1

-- Integers form a semiring.
instance
  SMℤ : SemiRing Int.ℤ
  SMℤ ._+_ = Int._+_
  SMℤ ._*_ = Int._*_
  SMℤ .0# = Int.0ℤ
  SMℤ .1# = Int.1ℤ

-- The set of intergers is a ring.
instance
  Ringℤ : Ring Int.ℤ
  Ringℤ .sra = SMℤ
  Ringℤ .-_ = Int.-_

-- The usual order on ℕ is decidable.
instance
  DOℕ : DecOrd Nat.ℕ
  DOℕ ._≤_   = Nat._≤_
  DOℕ ._≤?_  = Nat._≤?_
  DOℕ ._<_   = Nat._<_
  DOℕ ._<?_  = Nat._<?_

-- The usual order on ℤ is decidable.
instance
  DOℤ : DecOrd Int.ℤ
  DOℤ ._≤_   = Int._≤_
  DOℤ ._≤?_  = Int._≤?_
  DOℤ ._<_   = Int._<_
  DOℤ ._<?_  = Int._<?_

-- ℕ has NonZero stucture on it defined in Data.Nat.Base.
instance
  NZTℕ : NonZeroTypeclass Nat.ℕ
  NZTℕ .NonZero = Nat.NonZero

-- ℤ has NonZero stucture on it defined in Data.Integer.Base.
  NZTℤ : NonZeroTypeclass Int.ℤ
  NZTℤ .NonZero = Int.NonZero

-- div and mod function on ℕ. They are defined in Data.Nat.DivMod.
instance
  DMℕ : DivMod Nat.ℕ
  DMℕ .NZT = NZTℕ
  DMℕ ._/_ = NDM._/_
  DMℕ ._%_ = NDM._%_

-- div and mod function on ℤ. They are defined in Data.Integer.DivMod.
instance
  DMℤ : DivMod Int.ℤ
  DMℤ .NZT = NZTℤ
  DMℤ ._/_ = IDM._div_
  DMℤ ._%_ n d = Int.+ (n IDM.mod d)

-- Identity function can be used as the rank function.
instance
  Rankℕ : Rank Nat.ℕ
  Rankℕ .rank x = x

-- Absolute value function can be used as the rank function.
instance
  Rankℤ : Rank Int.ℤ
  Rankℤ .rank = Int.∣_∣


{-# OPTIONS --cubical --safe #-}
module Cubical.Data.Nat.GCD where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Function
open import Cubical.Foundations.HLevels
open import Cubical.Foundations.Equiv
open import Cubical.Foundations.Isomorphism

open import Cubical.Induction.WellFounded

open import Cubical.Data.Fin
open import Cubical.Data.Sigma as Σ
open import Cubical.Data.NatPlusOne

open import Cubical.HITs.PropositionalTruncation as PropTrunc

open import Cubical.Data.Nat.Base
open import Cubical.Data.Nat.Properties
open import Cubical.Data.Nat.Order
open import Cubical.Data.Nat.Divisibility

private
  variable
    m n d : ℕ

-- common divisors

isCD : ℕ → ℕ → ℕ → Type₀
isCD m n d = (d ∣ m) × (d ∣ n)

isPropIsCD : isProp (isCD m n d)
isPropIsCD = isProp× isProp∣ isProp∣

symCD : isCD m n d → isCD n m d
symCD (d∣m , d∣n) = (d∣n , d∣m)

-- greatest common divisors

isGCD : ℕ → ℕ → ℕ → Type₀
isGCD m n d = (isCD m n d) × (∀ d' → isCD m n d' → d' ∣ d)

GCD : ℕ → ℕ → Type₀
GCD m n = Σ ℕ (isGCD m n)

isPropIsGCD : isProp (isGCD m n d)
isPropIsGCD = isProp× isPropIsCD (isPropΠ2 (λ _ _ → isProp∣))

isPropGCD : isProp (GCD m n)
isPropGCD (d , dCD , gr) (d' , d'CD , gr') =
  ΣProp≡ (λ _ → isPropIsGCD) (antisym∣ (gr' d dCD) (gr d' d'CD))

symGCD : isGCD m n d → isGCD n m d
symGCD (dCD , gr) = symCD dCD , λ { d' d'CD → gr d' (symCD d'CD) }

divsGCD : m ∣ n → isGCD m n m
divsGCD p = (∣-refl refl , p) , λ { d (d∣m , _) → d∣m }

-- The base case of the Euclidean algorithm
zeroGCD : ∀ m → isGCD m 0 m
zeroGCD m = divsGCD (∣-zeroʳ m)

private
  lem₁ : prediv d (suc n) → prediv d (m % suc n) → prediv d m
  lem₁ {d} {n} {m} (c₁ , p₁) (c₂ , p₂) = (q * c₁ + c₂) , p
    where r = m % suc n; q = n%k≡n[modk] m (suc n) .fst
          p = (q * c₁ + c₂) * d     ≡⟨ sym (*-distribʳ (q * c₁) c₂ d) ⟩
              (q * c₁) * d + c₂ * d ≡⟨ cong (_+ c₂ * d) (sym (*-assoc q c₁ d))  ⟩
              q * (c₁ * d) + c₂ * d ≡[ i ]⟨ q * (p₁ i) + (p₂ i) ⟩
              q * (suc n)  + r      ≡⟨ n%k≡n[modk] m (suc n) .snd ⟩
              m                     ∎

  lem₂ : prediv d (suc n) → prediv d m → prediv d (m % suc n)
  lem₂ {d} {n} {m} (c₁ , p₁) (c₂ , p₂) = c₂ ∸ q * c₁ , p
    where r = m % suc n; q = n%k≡n[modk] m (suc n) .fst
          p = (c₂ ∸ q * c₁) * d               ≡⟨ ∸-distribʳ c₂ (q * c₁) d ⟩
              c₂ * d ∸ (q * c₁) * d           ≡⟨ cong (c₂ * d ∸_) (sym (*-assoc q c₁ d)) ⟩
              c₂ * d ∸ q * (c₁ * d)           ≡[ i ]⟨ p₂ i ∸ q * (p₁ i) ⟩
              m      ∸ q * (suc n)            ≡⟨ cong (_∸ q * (suc n)) (sym (n%k≡n[modk] m (suc n) .snd)) ⟩
              (q * (suc n) + r) ∸ q * (suc n) ≡⟨ cong (_∸ q * (suc n)) (+-comm (q * (suc n)) r) ⟩
              (r + q * (suc n)) ∸ q * (suc n) ≡⟨ ∸-cancelʳ r zero (q * (suc n)) ⟩
              r ∎

-- The inductive step of the Euclidean algorithm
stepGCD : isGCD (suc n) (m % suc n) d
        → isGCD m       (suc n)     d
fst (stepGCD ((d∣n , d∣m%n) , gr)) = PropTrunc.map2 lem₁ d∣n d∣m%n , d∣n
snd (stepGCD ((d∣n , d∣m%n) , gr)) d' (d'∣m , d'∣n) = gr d' (d'∣n , PropTrunc.map2 lem₂ d'∣n d'∣m)

-- putting it all together using well-founded induction

euclid< : ∀ m n → n < m → GCD m n
euclid< = WFI.induction <-wellfounded λ {
  m rec zero    p → m , zeroGCD m ;
  m rec (suc n) p → let d , dGCD = rec (suc n) p (m % suc n) (n%sk<sk m n)
                     in d , stepGCD dGCD }

euclid : ∀ m n → GCD m n
euclid m n with n ≟ m
... | lt p = euclid< m n p
... | gt p = Σ.mapʳ symGCD (euclid< n m p)
... | eq p = m , divsGCD (∣-refl (sym p))

isContrGCD : ∀ m n → isContr (GCD m n)
isContrGCD m n = euclid m n , isPropGCD _

-- the gcd operator on ℕ

gcd : ℕ → ℕ → ℕ
gcd m n = euclid m n .fst

gcdIsGCD : ∀ m n → isGCD m n (gcd m n)
gcdIsGCD m n = euclid m n .snd


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

open import LogicalFormulae
open import Groups.Definition
open import Groups.Abelian.Definition
open import Setoids.Setoids
open import Vectors
open import Numbers.Naturals.Semiring
open import Sets.EquivalenceRelations

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

open Setoid S
open Equivalence eq
open Group G

vecEquiv : {n : ℕ} → Vec A n → Vec A n → Set b
vecEquiv {zero} [] [] = True'
vecEquiv {succ n} (x ,- v1) (y ,- v2) = (x ∼ y) && vecEquiv v1 v2

private
  vecEquivRefl : {n : ℕ} → (x : Vec A n) → vecEquiv x x
  vecEquivRefl [] = record {}
  vecEquivRefl (x ,- xs) = reflexive ,, vecEquivRefl xs

  vecEquivSymm : {n : ℕ} → (x y : Vec A n) → vecEquiv x y → vecEquiv y x
  vecEquivSymm [] [] record {} = record {}
  vecEquivSymm (x ,- xs) (y ,- ys) (fst ,, snd) = symmetric fst ,, vecEquivSymm _ _ snd

  vecEquivTrans : {n : ℕ} → (x y z : Vec A n) → vecEquiv x y → vecEquiv y z → vecEquiv x z
  vecEquivTrans [] [] [] x=y y=z = record {}
  vecEquivTrans (x ,- xs) (y ,- ys) (z ,- zs) (fst1 ,, snd1) (fst2 ,, snd2) = transitive fst1 fst2 ,, vecEquivTrans xs ys zs snd1 snd2

vectorSetoid : (n : ℕ) → Setoid (Vec A n)
Setoid._∼_ (vectorSetoid n) = vecEquiv {n}
Equivalence.reflexive (Setoid.eq (vectorSetoid n)) {x} = vecEquivRefl x
Equivalence.symmetric (Setoid.eq (vectorSetoid n)) {x} {y} = vecEquivSymm x y
Equivalence.transitive (Setoid.eq (vectorSetoid n)) {x} {y} {z} = vecEquivTrans x y z

vectorAdd : {n : ℕ} → Vec A n → Vec A n → Vec A n
vectorAdd [] [] = []
vectorAdd (x ,- v1) (y ,- v2) = (x + y) ,- (vectorAdd v1 v2)

private
  addWellDefined : {n : ℕ} → (m k x y : Vec A n) → Setoid._∼_ (vectorSetoid n) m x → Setoid._∼_ (vectorSetoid n) k y → Setoid._∼_ (vectorSetoid n) (vectorAdd m k) (vectorAdd x y)
  addWellDefined [] [] [] [] m=x k=y = record {}
  addWellDefined (m ,- ms) (k ,- ks) (x ,- xs) (y ,- ys) (m=x ,, ms=xs) (k=y ,, ks=ys) = +WellDefined m=x k=y ,, addWellDefined ms ks xs ys ms=xs ks=ys

  addAssoc : {n : ℕ} → (x y z : Vec A n) → Setoid._∼_ (vectorSetoid n) (vectorAdd x (vectorAdd y z)) (vectorAdd (vectorAdd x y) z)
  addAssoc [] [] [] = record {}
  addAssoc (x ,- xs) (y ,- ys) (z ,- zs) = +Associative ,, addAssoc xs ys zs

  vecIdentRight : {n : ℕ} → (a : Vec A n) → Setoid._∼_ (vectorSetoid n) (vectorAdd a (vecPure 0G)) a
  vecIdentRight [] = record {}
  vecIdentRight (x ,- a) = identRight ,, vecIdentRight a

  vecIdentLeft : {n : ℕ} → (a : Vec A n) → Setoid._∼_ (vectorSetoid n) (vectorAdd (vecPure 0G) a) a
  vecIdentLeft [] = record {}
  vecIdentLeft (x ,- a) = identLeft ,, vecIdentLeft a

  vecInvLeft : {n : ℕ} → (a : Vec A n) → Setoid._∼_ (vectorSetoid n) (vectorAdd (vecMap inverse a) a) (vecPure 0G)
  vecInvLeft [] = record {}
  vecInvLeft (x ,- a) = invLeft ,, vecInvLeft a

  vecInvRight : {n : ℕ} → (a : Vec A n) → Setoid._∼_ (vectorSetoid n) (vectorAdd a (vecMap inverse a)) (vecPure 0G)
  vecInvRight [] = record {}
  vecInvRight (x ,- a) = invRight ,, vecInvRight a

vectorGroup : {n : ℕ} → Group (vectorSetoid n) (vectorAdd {n})
Group.+WellDefined vectorGroup {m} {n} {x} {y} = addWellDefined m n x y
Group.0G vectorGroup = vecPure 0G
Group.inverse vectorGroup x = vecMap inverse x
Group.+Associative vectorGroup {x} {y} {z} = addAssoc x y z
Group.identRight vectorGroup {a} = vecIdentRight a
Group.identLeft vectorGroup {a} = vecIdentLeft a
Group.invLeft vectorGroup {a} = vecInvLeft a
Group.invRight vectorGroup {a} = vecInvRight a

abelianVectorGroup : {n : ℕ} → AbelianGroup G → AbelianGroup (vectorGroup {n})
AbelianGroup.commutative (abelianVectorGroup grp) {[]} {[]} = record {}
AbelianGroup.commutative (abelianVectorGroup grp) {x ,- xs} {y ,- ys} = AbelianGroup.commutative grp ,, AbelianGroup.commutative (abelianVectorGroup grp) {xs} {ys}


module Data.Vec.Any {a} {A : Set a} where
  open import Level using (_⊔_)
  open import Relation.Nullary
  open import Data.Fin
  open import Data.Nat as ℕ hiding (_⊔_)
  open import Data.Vec as Vec using (Vec; _∷_; [])
  open import Relation.Unary renaming (_⊆_ to _⋐_) using (Decidable)
  open import Function.Inverse using (_↔_)
  open import Relation.Binary.PropositionalEquality using (_≡_; _≢_)
  import Relation.Binary.PropositionalEquality as P
  open import Relation.Nullary using (¬_; yes; no)
  import Relation.Nullary.Decidable as Dec
  open import Data.Empty using (⊥-elim)
  open import Data.Product using (∃ ; ,_ )
  import Data.List.Any as ListAny

  data Any {p}(P : A → Set p) : ∀ {n} → Vec A n → Set (a ⊔ p) where
    here  : ∀ {n x}{xs : Vec A n} → P x → Any P (x ∷ xs)
    there : ∀ {n x}{xs : Vec A n} → Any P xs → Any P (x ∷ xs)
  open Any public

  map : ∀ {p q} {P : A → Set p} {Q : A → Set q} {n} {xs : Vec A n} →
    P ⋐ Q → Any P xs → Any Q xs
  map g (here px) =   here (g px)
  map g (there pxs) = there (map g pxs)

  tail : ∀ {p} {P : A → Set p}{x n} {xs : Vec A n} → ¬ P x → Any P (x ∷ xs) → Any P xs
  tail ¬px (here px) = ⊥-elim (¬px px)
  tail ¬px (there pxs) = pxs

  any :  ∀ {p} {P : A → Set p} → Decidable P → ∀ {n} → Decidable (Any P {n})
  any p [] = no λ()
  any p (x ∷ xs) with p x
  any p (x ∷ xs) | yes px = yes (here px)
  any p (x ∷ xs) | no ¬px = Dec.map′ there (tail ¬px) (any p xs)

  index : ∀ {p}{P : A → Set p}{n}{xs : Vec A n} → Any P xs → Fin n
  index (here px) = zero
  index (there pxs) = suc (index pxs)

  satisfied : ∀ {p}{P : A → Set p}{n}{xs : Vec A n} → Any P xs → ∃ P
  satisfied (here px) = , px
  satisfied (there pxs) = satisfied pxs

  Any↔ListAny : ∀ {p}{P : A → Set p}{n}{xs : Vec A n} →
    Any P xs ↔ ListAny.Any P (Vec.toList xs)
  Any↔ListAny {P = P} = record {
        to = P.→-to-⟶ to
      ; from =  P.→-to-⟶ from
      ; inverse-of = record {
            left-inverse-of = left-inverse
          ; right-inverse-of = right-inverse
        }
    }
    where
      to : ∀ {n}{xs : Vec A n} → Any P xs → ListAny.Any P (Vec.toList xs)
      to (here px) = ListAny.here px
      to (there pxs) = ListAny.there (to pxs)

      from : ∀ {n}{xs : Vec A n} → ListAny.Any P (Vec.toList xs) → Any P xs
      from {xs = []} ()
      from {xs = x ∷ xs} (ListAny.here px) = here px
      from {xs = x ∷ xs} (ListAny.there pxs) = there (from pxs)

      left-inverse : ∀ {n}{xs : Vec A n}(p : Any P xs) → from (to p) P.≡ p
      left-inverse (here px) = P.refl
      left-inverse (there pxs) = P.cong there (left-inverse pxs)

      right-inverse : ∀ {n}{xs : Vec A n}(p : ListAny.Any P (Vec.toList xs)) → to (from p) P.≡ p
      right-inverse {xs = []} ()
      right-inverse {xs = x ∷ xs} (ListAny.here px) = P.refl
      right-inverse {xs = x ∷ xs} (ListAny.there pxs) = P.cong ListAny.there (right-inverse pxs)


open import FRP.JS.Nat using ( ℕ ; _+_ ; _≤_ ; _<_ ; _≟_ )
open import FRP.JS.True using ( True ; False )

module FRP.JS.Nat.Properties where

postulate
  ≤-impl-≯ : ∀ {m n} → True (m ≤ n) → False (n < m)
  ≤≠-impl-< : ∀ {m n} → True (m ≤ n) → False (m ≟ n) → True (m < n)
  <-impl-s≤ : ∀ {m n} → True (m < n) → True (1 + m ≤ n)
  ≤-bot : ∀ {n} → True (0 ≤ n)


module DefinitionalEquality where

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

subst : {A : Set}(P : A -> Set){x y : A} -> x == y -> P y -> P x
subst {A} P refl p = p

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

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

-- This formulation of the associativity law guarantees that for closed n, but
-- possibly open m and p the law holds definitionally.

assoc : (n : Nat) -> (\m p -> n + (m + p)) == (\m p -> (n + m) + p)
assoc zero    = refl
assoc (suc n) = subst (\ ∙ -> f ∙ == f (\m p -> ((n + m) + p)))
                      (assoc n) refl
  where
    f = \(g : Nat -> Nat -> Nat)(m p : Nat) -> suc (g m p)


------------------------------------------------------------------------------
-- Twice funcion
------------------------------------------------------------------------------

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

module FOTC.Twice where

open import Common.FOL.Relation.Binary.EqReasoning

open import FOTC.Base

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

module HigherOrder where

  -- We cannot translate this function as a definition because it is
  -- higher-order.
  twice : (D → D) → D → D
  twice f x = f (f x)
  -- {-# ATP definition twice #-}

  postulate twice-succ : ∀ n → twice succ₁ n ≡ succ₁ (succ₁ n)
  -- {-# ATP prove twice-succ #-}

module FirstOrderAxiom where

  postulate
    twice    : D → D → D
    twice-eq : ∀ f x → twice f x ≡ f · (f · x)
  {-# ATP axiom twice-eq #-}

  twice-succI : ∀ n → twice succ n ≡ succ · (succ · n)
  twice-succI n = twice succ n      ≡⟨ twice-eq succ n ⟩
                  succ · (succ · n) ∎

  postulate twice-succATP : ∀ n → twice succ n ≡ succ · (succ · n)
  {-# ATP prove twice-succATP #-}

module FirstOrderDefinition where

  twice : D → D → D
  twice f x = f · (f · x)
  {-# ATP definition twice #-}

  twice-succI : ∀ n → twice succ n ≡ succ · (succ · n)
  twice-succI n = refl

  postulate twice-succATP : ∀ n → twice succ n ≡ succ · (succ · n)
  {-# ATP prove twice-succATP #-}


open import Relation.Binary.Core

module BHeap.Height {A : Set}
                  (_≤_ : A → A → Set)
                  (tot≤ : Total _≤_) where

open import Bound.Lower A
open import Bound.Lower.Order _≤_
open import BHeap _≤_
open import BHeap.Properties _≤_
open import Data.Nat renaming (_≤_ to _≤ₙ_)
open import Data.Nat.Properties
open import Data.Sum
open import Relation.Binary
open import Relation.Binary.PropositionalEquality hiding (trans)

open DecTotalOrder decTotalOrder hiding (refl)

theorem-height-merge : {b : Bound}{x : A}(b≤x : LeB b (val x))(l r : BHeap (val x)) → height (merge tot≤ l r) ≤ₙ height (nd b≤x l r)
theorem-height-merge _ lf r = ≤-step (reflexive refl)
theorem-height-merge _ l lf rewrite lemma-merge-lf tot≤ l
    with total (height l) zero
... | inj₁ hl≤0 rewrite antisym hl≤0 z≤n = ≤-step (reflexive refl)
... | inj₂ 0≤hl = ≤-step (reflexive refl)
theorem-height-merge b≤x (nd {x = y} x≤y l r) (nd {x = y'} x≤y' l' r')
    with tot≤ y y' | total (height (nd x≤y l r)) (height (nd x≤y' l' r'))
... | inj₁ y≤y' | inj₁ hylr≤hy'l'r'
    with total (height (merge tot≤ l r)) (height (nd (lexy y≤y') l' r'))
... | inj₁ hmlr≤hy'l'r' = reflexive refl
... | inj₂ hy'l'r'≤hmlr rewrite antisym (trans (theorem-height-merge x≤y l r) hylr≤hy'l'r') hy'l'r'≤hmlr = reflexive refl
theorem-height-merge b≤x (nd {x = y} x≤y l r) (nd {x = y'} x≤y' l' r') | inj₁ y≤y' | inj₂ hy'l'r'≤hylr
    with total (height (merge tot≤ l r)) (height (nd (lexy y≤y') l' r'))
... | inj₁ hmlr≤hy'l'r' = s≤s hy'l'r'≤hylr
... | inj₂ hy'l'r'≤hmlr = s≤s (theorem-height-merge x≤y l r)
theorem-height-merge b≤x (nd {x = y} x≤y l r) (nd {x = y'} x≤y' l' r') | inj₂ y'≤y | inj₁ hylr≤hy'l'r'
    with total (height (nd (lexy y'≤y) l r)) (height (merge tot≤ l' r'))
... | inj₁ hylr≤hml'r' = s≤s (theorem-height-merge x≤y' l' r')
... | inj₂ hml'r'≤hylr = s≤s hylr≤hy'l'r'
theorem-height-merge b≤x (nd {x = y} x≤y l r) (nd {x = y'} x≤y' l' r') | inj₂ y'≤y | inj₂ hy'l'r'≤hylr
    with total (height (nd (lexy y'≤y) l r)) (height (merge tot≤ l' r'))
... | inj₁ hylr≤hml'r' rewrite antisym (trans (theorem-height-merge x≤y' l' r') hy'l'r'≤hylr) hylr≤hml'r' = reflexive refl
... | inj₂ hml'r'≤hylr = reflexive refl


module x03-842Relations-hc-2 where

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

------------------------------------------------------------------------------
-- inequality : ≤

data _≤_ : ℕ → ℕ → Set where

  z≤n : ∀ {n : ℕ}
      --------
    → zero ≤ n

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

infix 4 _≤_

_ : 2 ≤ 4 -- multiple 'refine' will do this automatically
_ = s≤s (s≤s z≤n)

_ : 2 ≤ 4 -- implicit args
_ = s≤s {1} {3} (s≤s {0} {2} z≤n)

_ : 2 ≤ 4 -- named implicit args
_ = s≤s {m = 1} {n = 3} (s≤s {m = 0} {n = 2} z≤n)

_ : 2 ≤ 4 -- some implicit named args
_ = s≤s {n = 3} (s≤s {m = 0} z≤n)

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

inv-z≤n : ∀ {m : ℕ}
  → m ≤ zero
    --------
  → m ≡ zero
inv-z≤n z≤n = refl

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

--------------------------------------------------
-- transitive
≤-trans : ∀ {m n p : ℕ} -- note implicit arguments
  → m ≤ n
  → n ≤ p
    -----
  → m ≤ p
≤-trans  z≤n           n≤p  = z≤n
≤-trans (s≤s m≤n) (s≤s n≤p) = s≤s (≤-trans m≤n n≤p)

≤-trans′ : ∀ (m n p : ℕ) -- without implicit arguments
  → m ≤ n
  → n ≤ p
    -----
  → m ≤ p
≤-trans′      .0      _       _
         z≤n n≤p            = z≤n
≤-trans′ (suc m) (suc n) (suc p)
        (s≤s m≤n) (s≤s n≤p) = s≤s (≤-trans′ m n p m≤n n≤p)

--------------------------------------------------
-- antisymmetry

≤-antisym : ∀ {m n : ℕ}
  → m ≤ n
  → n ≤ m
    -----
  → m ≡ n
≤-antisym      z≤n       z≤n = refl
≤-antisym (s≤s m≤n) (s≤s n≤m) rewrite ≤-antisym m≤n n≤m = refl

--------------------------------------------------
-- total ordering def with parameters

data Total (m n : ℕ) : Set where

  forward :
      m ≤ n
      ---------
    → Total m n

  flipped :
      n ≤ m
      ---------
    → Total m n

-- equivalent def without parameters
data Total′ : ℕ → ℕ → Set where

  forward′ : ∀ {m n : ℕ}
    → m ≤ n
      ----------
    → Total′ m n

  flipped′ : ∀ {m n : ℕ}
    → n ≤ m
      ----------
    → Total′ m n

-- prove ≤ is a total order -- using WITH
≤-total : ∀ (m n : ℕ) → Total m n
≤-total  zero        n = forward z≤n
≤-total (suc m)  zero  = flipped z≤n
≤-total (suc m) (suc n) with ≤-total m n
... | forward x        = forward (s≤s x)
... | flipped x        = flipped (s≤s x)

≤-total′ : ∀ (m n : ℕ) → Total m n -- using helper defined in 'where'
≤-total′  zero        n  = forward z≤n
≤-total′ (suc m)  zero   = flipped z≤n
≤-total′ (suc m) (suc n) = helper (≤-total m n)
  where
    helper : Total m n → Total (suc m) (suc n)
    helper (forward x) = forward (s≤s x)
    helper (flipped x) = flipped (s≤s x)

-- same but split on n first
≤-totalN : ∀ (m n : ℕ) → Total m n
≤-totalN      m   zero   = flipped z≤n
≤-totalN zero         n  = forward z≤n
≤-totalN (suc m) (suc n) with ≤-totalN m n
... | forward x = forward (s≤s x)
... | flipped x = flipped (s≤s x)

--------------------------------------------------
-- monotonicity of + with respect to ≤

-- inequality added on right
+-monoʳ-≤ : ∀ (m p q : ℕ)
  →     p ≤     q
    -------------
  → m + p ≤ m + q
+-monoʳ-≤  zero   p q p≤q = p≤q
+-monoʳ-≤ (suc m) p q p≤q           -- suc  m + p  ≤ suc  m + q
                                    -- suc (m + p) ≤ suc (m + q)
  = s≤s (+-monoʳ-≤ m p q p≤q)  -- can be done by refine then recurse

-- inequality added on left
+-monoˡ-≤ : ∀ (p q m : ℕ)
  → p     ≤ q
    -------------
  → p + m ≤ q + m
+-monoˡ-≤ p q m p≤q  -- p + m ≤ q + m
  rewrite
    +-comm p m       -- m + p ≤ q + m
  | +-comm q m       -- m + p ≤ m + q
  = +-monoʳ-≤ m p q p≤q

-- combine above
+-mono-≤ : ∀ (m n p q : ℕ)
  → m     ≤ n
  →     p ≤     q
    -------------
  → m + p ≤ n + q
+-mono-≤ m n p q m≤n p≤q = ≤-trans (+-monoʳ-≤ m p q p≤q ) (+-monoˡ-≤ m n q m≤n)

--------------------------------------------------
-- monotonicity of *

m≤n→n≡0→n≡0 : ∀ (m : ℕ) → m ≤ zero → m ≡ 0
m≤n→n≡0→n≡0 zero m≤0 = refl

-- inequality multiplied on right
*-monoʳ-≤ : ∀ (m p q : ℕ)
  →     p ≤     q
    -------------
  → m * p ≤ m * q
*-monoʳ-≤ zero   p       q  p≤q = z≤n
*-monoʳ-≤ m   zero       q  p≤q -- m *  zero ≤ m * q
  rewrite
    *-zeroʳ m                   --         0 ≤ m * q
  = z≤n
*-monoʳ-≤ m      p    zero  p≤q -- m *     p ≤ m * zero
  rewrite
    *-zeroʳ m                   -- m *     p ≤ 0
  | m≤n→n≡0→n≡0 p p≤q           -- m *     0 ≤ 0
  | *-zeroʳ m                   --         0 ≤ 0
  = z≤n
*-monoʳ-≤ m (suc p) (suc q) p≤q -- m * suc p ≤ m * suc q
  rewrite
    *-comm m (suc p)            -- m + p * m ≤ m * suc q
  | *-comm m (suc q)            -- m + p * m ≤ m + q * m
  | *-comm p m                  -- m + m * p ≤ m + q * m
  | *-comm q m                  -- m + m * p ≤ m + m * q
  = +-monoʳ-≤ m (m * p) (m * q) (*-monoʳ-≤ m p q (inv-s≤s p≤q))

-- inequality multiplied on left
*-monoˡ-≤ : ∀ (p q m : ℕ)
  → p     ≤ q
    -------------
  → p * m ≤ q * m
*-monoˡ-≤  p q m p≤q  -- p * m ≤ q * m
  rewrite
    *-comm p m        -- m * p ≤ q * m
  | *-comm q m        -- m * p ≤ m * q
  = *-monoʳ-≤ m p q p≤q

*-mono-≤ : ∀ (m n p q : ℕ)
  → m     ≤ n
  →     p ≤     q
    -------------
  → m * p ≤ n * q
*-mono-≤ m n p q m≤n p≤q = ≤-trans (*-monoʳ-≤ m p q p≤q ) (*-monoˡ-≤ m n q m≤n)

------------------------------------------------------------------------------
-- strict inequality : <

infix 4 _<_

data _<_ : ℕ → ℕ → Set where

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

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

<-trans : ∀ {m n p : ℕ}
        → m < n
        → n < p
        -------
        → m < p
<-trans  z<s    (s<s y) = z<s
<-trans (s<s x) (s<s y) = s<s (<-trans x y)

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

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

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

m≡n→sucm≡sucn : ∀ (m n : ℕ) → m ≡ n → suc m ≡ suc n
m≡n→sucm≡sucn  zero    zero   p = refl
m≡n→sucm≡sucn  zero   (suc n) ()
m≡n→sucm≡sucn (suc m)  zero   ()
m≡n→sucm≡sucn (suc m) (suc n) p = cong suc (m≡n→sucm≡sucn m n (suc-injective p))

<-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 = is-< (s<s m<n)
... | is-≡ m≡n = is-≡ (m≡n→sucm≡sucn m n m≡n)
... | is-> n<m = is-> (s<s n<m)

------------------------------------------------------------------------------
-- monotonicity of + with respect to <

-- all I did was copy the +-monoʳ-≤ proof and replace ≤ with < - it worked
-- inequality added on right
+-monoʳ-< : ∀ (m p q : ℕ)
  →     p <     q
    -------------
  → m + p < m + q
+-monoʳ-<  zero   p q p<q = p<q
+-monoʳ-< (suc m) p q p<q
  = s<s (+-monoʳ-< m p q p<q)

-- inequality added on left
+-monoˡ-< : ∀ (p q m : ℕ)
  → p     < q
    -------------
  → p + m < q + m
+-monoˡ-< p q m p<q
  rewrite
    +-comm p m
  | +-comm q m
  = +-monoʳ-< m p q p<q

-- combine above
+-mono-< : ∀ (m n p q : ℕ)
  → m     < n
  →     p <     q
    -------------
  → m + p < n + q
+-mono-< m n p q m<n p<q = <-trans (+-monoʳ-< m p q p<q ) (+-monoˡ-< m n q m<n)

------------------------------------------------------------------------------
-- Proofs showing relation between strict inequality and inequality.
-- (Do the proofs in the order below, to avoid induction for two of the four proofs.)

--------------------------------------------------
-- turn ≤ into <

≤-<-to : ∀ {m n : ℕ}
       → m ≤     n
       → m < suc n
≤-<-to  {zero}  {zero}  z≤n      = z<s
≤-<-to  {zero} {suc n}  z≤n      = z<s
≤-<-to {suc m} {suc n} (s≤s m≤n) = s<s (≤-<-to m≤n)
--- removing unneeded stuff
≤-<-to' : ∀ {m n : ℕ}
        → m ≤     n
        → m < suc n
≤-<-to'                 z≤n      = z<s
≤-<-to'                (s≤s m≤n) = s<s (≤-<-to' m≤n)

≤-<--to′ : ∀ {m n : ℕ}
         → suc m ≤ n
         →     m < n
≤-<--to′ (s≤s sm≤n) = ≤-<-to sm≤n

--------------------------------------------------
-- turn < into ≤

≤-<-from : ∀ {m n : ℕ}
         →     m < n
         → suc m ≤ n
≤-<-from  z<s      = s≤s z≤n
≤-<-from (s<s m<n) = s≤s (≤-<-from m<n)

≤-<-from′ : ∀ {m n : ℕ}
          → m < suc n
          → m ≤     n
≤-<-from′  z<s       = z≤n
≤-<-from′ (s<s m<sn) = ≤-<-from m<sn

------------------------------------------------------------------------------
-- use the above to give a proof of <-trans that uses ≤-trans

m<n→m<sucn : ∀ {m n : ℕ} → m < n → m < suc n
m<n→m<sucn  z<s      = z<s
m<n→m<sucn (s<s m<n) = s<s (m<n→m<sucn m<n)

<-trans' : ∀ {m n p : ℕ}
        → m < n
        →     n < p
        -------
        → m <     p
<-trans' m<n n<p = ≤-<--to′ (≤-trans (≤-<-from m<n) ( ≤-<-from′ (m<n→m<sucn n<p)))

------------------------------------------------------------------------------
-- Mutually recursive datatypes. Specify types first, then definitions.

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

-- HC : added 'E' suffix to constructors
data even where

  zeroE :
      ---------
      even zero

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

-- HC : added 'O' suffix to constructor
data odd where

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

-------------------------
-- Mutually recursive proofs.  Specify types first, then implementations.

e+e≡e : ∀ {m n : ℕ}
  → even  m
  → even      n
    ------------
  → even (m + n)

o+e≡o : ∀ {m n : ℕ}
  → odd  m
  → even     n
    -----------
  → odd (m + n)

e+e≡e  zeroE   en =               en
e+e≡e (sucE x) en = sucE (o+e≡o x en)

o+e≡o (sucO x) en = sucO (e+e≡e x en)

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

o+o≡e : ∀ {m n : ℕ}
  → odd   m
  → odd       n
  --------------
  → even (m + n)

e+o≡o : ∀ {m n : ℕ}
  → even m
  → odd      n
    -----------
  → odd (m + n)

e+o≡o  zeroE   on = on
e+o≡o (sucE m) (sucO n) = sucO (o+o≡e m (sucO n))

o+o≡e (sucO m) on = sucE (e+o≡o m on)


module Prelude.Bool.Properties where

open import Prelude.Equality
open import Prelude.Bool
open import Prelude.Decidable
open import Prelude.Empty
open import Prelude.Variables

de-morg-neg-conj : (a b : Bool) → not (a && b) ≡ (not a || not b)
de-morg-neg-conj true true = refl
de-morg-neg-conj false true = refl
de-morg-neg-conj true false  = refl
de-morg-neg-conj false false  = refl

de-morg-neg-disj : (a b : Bool) → not (a || b) ≡ (not a && not b)
de-morg-neg-disj true true = refl
de-morg-neg-disj false true = refl
de-morg-neg-disj true false = refl
de-morg-neg-disj false false = refl

x||true : (x : Bool) → (x || true) ≡ true
x||true true = refl
x||true false = refl

x&&false : (x : Bool) → (x && false) ≡ false
x&&false true = refl
x&&false false = refl

IsTrue⇒≡ : IsTrue x → x ≡ true
IsTrue⇒≡ true = refl

IsFalse⇒≡ : IsFalse x → x ≡ false
IsFalse⇒≡ false = refl

not[x]≡false⇒x≡true : not x ≡ false → x ≡ true
not[x]≡false⇒x≡true {true} _ = refl
not[x]≡false⇒x≡true {false} ()

not[x]≡true⇒x≡false : not x ≡ true → x ≡ false
not[x]≡true⇒x≡false {true} ()
not[x]≡true⇒x≡false {false} _ = refl

-- Properties of ==? --
module _ {a} {A : Set a} {{EqA : Eq A}} where

  ==?-reflexive : (x : A) → (x ==? x) ≡ true
  ==?-reflexive x with  x == x
  ...| yes refl = refl
  ...| no notEq = ⊥-elim (notEq refl)

  ≡⇒==? : {x y : A} → (x ≡ y) → (x ==? y) ≡ true
  ≡⇒==? {x = x} {y = y} refl with x == y
  ...| yes refl = refl
  ...| no a≢b = ⊥-elim (a≢b refl)

  ≢⇒==? : {x y : A} → x ≢ y → (x ==? y) ≡ false
  ≢⇒==? {x = x} {y = y} x≢y with x == y
  ...| yes x≡y = ⊥-elim (x≢y x≡y)
  ...| no _ = refl

  ==?⇒≡ : {x y : A} → (x ==? y) ≡ true → x ≡ y
  ==?⇒≡ {x = x} {y = y} ==?≡true
    with x == y
  ...| yes x≡y = x≡y
  ...| no x≢y with (≢⇒==? x≢y) | ==?≡true
  ...| _ | ()

  ==?≡false⇒≢ : {a b : A} → (a ==? b) ≡ false → a ≢ b
  ==?≡false⇒≢ {a = a} {b = b} ==?≡false
    with a == b
  ...| no ¬eq = ¬eq
  ...| yes eq with ≡⇒==? | ==?≡false
  ...| _ | ()


{-# OPTIONS --safe #-}
module Sol01 where

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

fibAux : ℕ -> ℕ -> ℕ -> ℕ
fibAux a b 0 = a
fibAux a b (suc n) = fibAux b (a + b) n

fib2 : ℕ -> ℕ
fib2 = fibAux 0 1

fib : ℕ -> ℕ
fib 0 = 0
fib 1 = 1
fib (suc (suc n)) = fib (suc n) + fib n

lemma : ∀ (a b c d n : ℕ) → fibAux (a + c) (b + d) n ≡ fibAux a b n + fibAux c d n
lemma a b c d zero = refl
lemma a b c d (suc n) rewrite sym (+-assoc (a + c) b d) | +-assoc a c b | +-comm c b | sym (+-assoc a b c) | +-assoc (a + b) c d = lemma b (a + b) d (c + d) n

fibEq : (n : ℕ) -> fib2 n ≡ fib n
fibEq zero = refl
fibEq (suc zero) = refl
fibEq (suc (suc n)) rewrite lemma 0 1 1 1 n | fibEq n | fibEq (suc n) | +-comm (fib n) (fib (suc n)) = refl


open import Prelude
open import Nat

module List where
  data List (A : Set) : Set where
    [] : List A
    _::_ : A → List A → List A

  map : {A B : Set} → (A → B) → (List A) → List B
  map f [] = []
  map f (x :: L) = (f x) :: map f L

  foldr : {A B : Set} → (A → B → B) → B → List A → B
  foldr f b [] = b
  foldr f b (x :: l) = f x (foldr f b l)

  -- list  membership
  data _∈_ {A : Set} : A → List A → Set where
    ∈h : {x : A} {l : List A} → x ∈ (x :: l)
    ∈t : {x y : A} {l : List A} → x ∈ l → x ∈ y :: l

  infixr 99 _::_

  data Unique {A B : Set} (f : A → B) : List A → Set where
    U[] : Unique f []
    U:: : {x : A} {xs : List A}
           → Unique f xs
           → (f x ∈ map f xs → ⊥)
           → Unique f (x :: xs)

  L : List (Nat × Nat)
  L = ((1 , 9) :: (2 , 9) :: [])

  ex1 : Unique π1 L
  ex1 = U:: (U:: U[] notemp) notin
    where
      notemp : {x : Nat} → x ∈ [] → ⊥
      notemp ()

      notin : 1 ∈ (2 :: []) → ⊥
      notin (∈t p) = notemp p

  ex2 : Unique π2 L → ⊥
  ex2 (U:: p x) = x ∈h

  maxl : List Nat → Nat
  maxl = foldr max 0

  -- addmax : {L : List Nat} (p : Unique (\x → x) L) → Unique (\x → x) ((1+ (maxl L)) :: L)
  -- addmax U[] = U:: U[] (λ ())
  -- addmax (U:: p x₁) with addmax p
  -- ... | ih = U:: (U:: p x₁) (λ x → x₁ {!!})


module Numeric.Nat.Sqrt where

open import Prelude hiding (_<?_)
open import Numeric.Nat.Properties
open import Tactic.Nat
open import Numeric.Nat.BinarySearch

data Sqrt (n : Nat) : Set where
  root : ∀ r → r ^ 2 ≤ n → n < suc r ^ 2 → Sqrt n

getSqrt : ∀ {n} → Sqrt n → Nat
getSqrt (root r _ _) = r

private
  infix 4 _<?_
  _<?_ : (a b : Nat) → Dec (a < b)
  a <?  b with compare a b
  a <?  b | less    a<b = yes a<b
  a <? .a | equal  refl = no (λ a<a → refute a<a)
  a <?  b | greater a>b = no (λ a<b → less-antisym {A = Nat} a>b a<b)

sqrt : (n : Nat) → Sqrt n
sqrt 0 = root 0 (diff! 0) (diff! 0)  -- just to avoid unfolding neutral application
sqrt n with binarySearch 0 n (λ r → n <? r ^ 2)
sqrt n | here k !n< n< _ _ = root k (less-raa (λ lt → !n< (by lt))) n<
sqrt 0 | none _ = root 0 (diff! 0) (diff! 0)
sqrt 1 | none _ = root 1 (diff! 0) (diff! 2)
sqrt (suc (suc n)) | none !n<n² = ⊥-elim (!n<n² auto)
sqrt n | below (diff _ ())
sqrt n | bad-range (diff _ ())

sqrt! : Nat → Nat
sqrt! n = getSqrt (sqrt n)

sqrt-below : ∀ n → sqrt! n ^ 2 ≤ n
sqrt-below n with sqrt n
... | root _ lo _ = lo

sqrt-above : ∀ n → suc (sqrt! n) ^ 2 > n
sqrt-above n with sqrt n
... | root _ _ hi = hi


-- Written by P. Hausmann
module Vec where

open import IO
open import Data.Vec
open import Data.Nat
open import Data.Nat.Show
open import Level using (0ℓ)

Matrix : Set -> ℕ -> ℕ -> Set
Matrix a n m = Vec (Vec a m) n

madd : {n m : ℕ} -> Matrix ℕ m n -> Matrix ℕ m n -> Matrix ℕ m n
madd a b = map (λ x → \y -> map _+_ x ⊛ y) a ⊛ b

idMatrix : {n : ℕ} -> Matrix ℕ n n
idMatrix {zero} = []
idMatrix {suc n} = (1 ∷ (replicate zero)) ∷ (map (λ x → zero ∷ x) idMatrix)

transposeM : {n m : ℕ} {a : Set} -> Matrix a m n -> Matrix a n m
transposeM {zero} {zero} a₁ = []
transposeM {zero} {suc m} {a} x = []
transposeM {suc n} {zero} a₁ = replicate []
transposeM {suc n} {suc m} {a} (_∷_ x₁ x₂) with map head (x₁ ∷ x₂)
... | vm = vm ∷ (map _∷_ (tail x₁) ⊛ transposeM (map tail x₂))

-- We use quite small numbers right now, as with big number the computation
-- gets very slow (at least in MAlonzo)
-- correct result : 109
compute : ℕ
compute = sum (map sum g)
  where m : Matrix ℕ 3 3
        m = (3 ∷ 5 ∷ 9 ∷ []) ∷
              (12 ∷ 0 ∷ 7 ∷ []) ∷ (11 ∷ 2 ∷ 4 ∷ []) ∷ []
        g : Matrix ℕ 3 3
        g = madd (transposeM (transposeM m)) (transposeM (madd m idMatrix))

main = run {0ℓ} (putStrLn (show compute))


open import Relation.Binary.PropositionalEquality

open import Data.Nat
open import Data.Nat.Properties using (+-suc)

open import Data.Product renaming (_×_ to _∧_)
open import Data.Sum renaming (_⊎_ to _∨_ ; inj₁ to left ; inj₂ to right)

{- 5.1 Extrinsic approach -}

div2 : ℕ → ℕ
div2 zero = zero
div2 (suc zero) = zero
div2 (suc (suc n)) = 1 + div2 n

test5 : ℕ
test5 = div2 (suc (suc (suc (suc (suc zero)))))

suc-≡ : {m n : ℕ} → (m ≡ n) → (suc m ≡ suc n)
suc-≡ refl = refl

div2-correct : (n : ℕ) → (2 * div2 n ≡ n) ∨ (suc (2 * div2 n) ≡ n)
div2-correct zero = left refl
div2-correct (suc zero) = right refl
div2-correct (suc (suc n)) with div2-correct n
div2-correct (suc (suc n)) | left even rewrite +-suc (div2 n) (div2 n + 0) = left (suc-≡ (suc-≡ even))
div2-correct (suc (suc n)) | right odd rewrite +-suc (div2 n) (div2 n + 0) = right (suc-≡ (suc-≡ odd))

{- 5.2 Intrinsic approach -}

{- There might be a more elegant way to rewrite this rather than using trans directly here -}
div2' : (n : ℕ) → Σ ℕ (λ q → (2 * q ≡ n) ∨ (suc (2 * q) ≡ n))
div2' zero = zero , (left refl)
div2' (suc zero) = zero , (right refl)
div2' (suc (suc n)) with proj₂ (div2' n)
...                 | left even =
                            1 + proj₁ (div2' n) ,
                            left ( suc-≡ (trans (+-suc (proj₁ (div2' n)) (proj₁ (div2' n) + 0)) (suc-≡ even) ))
...                 | right odd =
                            1 + proj₁ (div2' n) ,
                            right (suc-≡ (suc-≡ (trans (+-suc (proj₁ (div2' n)) (proj₁ (div2' n) + 0)) odd)))


open import Relation.Binary.Core

module PLRTree.Heap.Properties {A : Set}
                     (_≤_ : A → A → Set)
                     (trans≤ : Transitive _≤_) where

open import PLRTree {A}
open import PLRTree.Heap _≤_

lemma-≤-≤* : {x y : A}{t : PLRTree} → x ≤ y → y ≤* t → x ≤* t
lemma-≤-≤* {x = x} _ (lf≤* _) = lf≤* x
lemma-≤-≤* x≤y (nd≤* y≤z y≤*l y≤*r) = nd≤* (trans≤ x≤y y≤z) (lemma-≤-≤* x≤y y≤*l) (lemma-≤-≤* x≤y y≤*r)


-- This module introduces implicit arguments.

module Implicit where

-- In Agda you can omit things that the type checker can figure out for itself.
-- This is a crucial feature in a monomorphic language, since you would
-- otherwise be overwhelmed by type arguments.

-- Let's revisit the identity function from 'Introduction.Basics'.

id' : (A : Set) -> A -> A
id' A x = x

-- Since Agda is monomorphic we have to take the type A as an argument. So when
-- using the identity function we have to provide the type explicitly.

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

one : Nat
one = id' Nat (suc zero)

-- Always having to provide the type argument to the identity function would of
-- course be very tedious, and seemingly unnecessary. We would expect the type
-- checker to be able to figure out what it should be by looking at the second
-- argument. And indeed the type checker can do this.

-- One way of indicating that the type checker will have figure something out
-- for itself is to write an underscore (_) instead of the term. So when
-- applying the identity function we can write

two : Nat
two = id' _ (suc one)

-- Now the type checker will try to figure out what the _ should be, and in
-- this case it will have no problems doing so. If it should fail to infer the
-- value of an _ it will issue an error message.

-- In the case of the identity function we expect the type argument to always
-- be inferrable so it would be nice if we could avoid having to write the _.
-- This can be achieved by declaring the first argument as an implicit
-- argument.

id : {A : Set} -> A -> A        -- implicit arguments are enclosed in curly braces
id x = x  -- now we don't have to mention A in the left-hand side

three : Nat
three = id (suc two)

-- If, for some reason, an implicit argument cannot be inferred it can be given
-- explicitly by enclosing it in curly braces :

four : Nat
four = id {Nat} (suc three)

-- To summarise we give a bunch of possible variants of the identity function
-- and its use.

-- Various definitions of the identity function. Definitions 0 through 3 are
-- all equivalent, as are definitions 4 through 6.

id0 : (A : Set) -> A -> A
id0 A x = x

id1 : (A : Set) -> A -> A
id1 _ x = x     -- in left-hand sides _ means "don't care"

id2 : (A : Set) -> A -> A
id2 = \A x -> x

id3 = \(A : Set)(x : A) -> x  -- the type signature can be omitted for definitions
                          -- of the form x = e if the type of e can be
                          -- inferred.

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

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

id6 : {A : Set} -> A -> A
id6 = \x -> x

id7 = \{A : Set}(x : A) -> x

id8 : {A : Set} -> A -> A
id8 = \{A} x -> x        -- this doesn't work since the type checker assumes
                            -- that the implicit A has been has been omitted in
                            -- the left-hand side (as in id6).

-- Various uses of the identity function.
zero0 = id0 Nat zero
zero1 = id0 _   zero  -- in right-hand sides _ means "go figure"

zero2 = id4       zero
zero3 = id4 {Nat} zero
zero4 = id4 {_}   zero  -- This is equivalent to zero2, but it can be useful if
                        -- a function has two implicit arguments and you need
                        -- to provide the second one (when you provide an
                        -- implicit argument explicitly it is assumed to be the
                        -- left-most one).

-- In this module we have looked at implicit arguments as a substitute for
-- polymorphism. The implicit argument mechanism is more general than that and
-- not limited to inferring the values of type arguments. For more information
-- on implicit arguments see, for instance
--  'Introduction.Data.ByRecursion'


module Data.Num.Bijection where

open import Data.Num.Core
open import Data.Num.Surjection
open import Data.Num.Injection

open import Data.Nat
open import Data.Empty using (⊥)
open import Data.Unit using (⊤; tt)

open import Function.Bijection
open Bijective

open import Relation.Nullary
open import Relation.Nullary.Decidable
open import Relation.Nullary.Negation

data BijectionView : ℕ → ℕ → ℕ → Set where
    Bij     : ∀ {b d o} → SurjCond b d o → InjCond b d o → BijectionView b d o
    NonSurj : ∀ {b d o} → NonSurjCond b d o              → BijectionView b d o
    NonInj  : ∀ {b d o} → NonInjCond b d o               → BijectionView b d o

bijectionView : (b d o : ℕ) → BijectionView b d o
bijectionView b d o with surjectionView b d o | injectionView b d o
bijectionView b d o | Surj c₁    | Inj c₂    = Bij c₁ c₂
bijectionView b d o | Surj _     | NonInj c₁ = NonInj c₁
bijectionView b d o | NonSurj c₁ | _         = NonSurj c₁

IsBijective : ℕ → ℕ → ℕ → Set
IsBijective b d o with bijectionView b d o
IsBijective b d o | Bij _ _   = ⊤
IsBijective b d o | NonSurj _ = ⊥
IsBijective b d o | NonInj _  = ⊥

SurjCond∧InjCond⇒Bijective : ∀ {b} {d} {o} → SurjCond b d o → InjCond b d o → Bijective (Num⟶ℕ b d o)
SurjCond∧InjCond⇒Bijective surjCond injCond = record
    { injective = InjCond⇒Injective injCond
    ; surjective = SurjCond⇒Surjective surjCond
    }

NonSurjCond⇏Bijective : ∀ {b} {d} {o} → NonSurjCond b d o → ¬ (Bijective (Num⟶ℕ b d o))
NonSurjCond⇏Bijective reason claim = NonSurjCond⇏Surjective reason (surjective claim)

NonInjCond⇏Bijective : ∀ {b} {d} {o} → NonInjCond b d o → ¬ (Bijective (Num⟶ℕ b d o))
NonInjCond⇏Bijective reason claim = NonInjCond⇏Injective reason (injective claim)

Bijective? : ∀ b d o → Dec (Bijective (Num⟶ℕ b d o))
Bijective? b d o with bijectionView b d o
Bijective? b d o | Bij surjCond injCond = yes (record
    { injective = InjCond⇒Injective injCond
    ; surjective = SurjCond⇒Surjective surjCond
    })
Bijective? b d o | NonSurj reason       = no (NonSurjCond⇏Bijective reason)
Bijective? b d o | NonInj reason        = no (NonInjCond⇏Bijective reason)


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

-- Category of (Agda) Sets, and partial functions (modelled using Maybe).
-- Note that unlike for basic categories, this is named after the morphisms instead of the objects.

open import Data.Maybe using (Maybe; nothing; just; _>>=_; maybe)
open import Level
open import Relation.Binary using (Setoid)
open import Relation.Binary.PropositionalEquality as ≡
  using (_≗_; refl)

open import Categories.Category

private
  variable
    o : Level
    A B C D : Set o
    f g h : A → Maybe B

  _∘′_ : (B → Maybe C) → (A → Maybe B) → A → Maybe C
  f ∘′ g = λ a → g a >>= f

  ∘′-assoc : {h : C → Maybe D} {g : B → Maybe C} {f : A → Maybe B} → (h ∘′ g) ∘′ f ≗ h ∘′ (g ∘′ f)
  ∘′-assoc {h = h} {g} {f} a with f a
  ... | nothing = refl
  ... | just b = refl

  idˡ : {A B : Set o} {f : A → Maybe B} → just ∘′ f ≗ f
  idˡ {f = f} a = maybe {B = λ b → (b >>= just) ≡.≡ b} (λ x → refl) refl (f a)

  resp : {A B C : Set o} {f h : B → Maybe C} {g i : A → Maybe B} →
    f ≗ h → g ≗ i → (f ∘′ g) ≗ (h ∘′ i)
  resp {f = f} {h} {g} {i} f≡h g≡i a with g a | i a | g≡i a
  ... | just x | just .x | refl = f≡h x
  ... | just x | nothing | ()
  ... | nothing | just x | ()
  ... | nothing | nothing | _ = refl

PartialFunctions : ∀ o → Category (suc o) o o
PartialFunctions o = record
  { Obj = Set o
  ; _⇒_ = λ a b → a → Maybe b
  ; _≈_ = _≗_
  ; id = just
  ; _∘_ = _∘′_
  ; assoc = λ {_} {_} {_} {_} {f} {g} {h} → ∘′-assoc {h = h} {g} {f}
  ; sym-assoc = λ {_} {_} {_} {_} {f} {g} {h} a → ≡.sym (∘′-assoc {h = h} {g} {f} a)
  ; identityˡ = idˡ
  ; identityʳ = λ _ → refl
  ; identity² = idˡ
  ; equiv = λ {A} {B} → Setoid.isEquivalence (≡._→-setoid_ A (Maybe B))
  ; ∘-resp-≈ = resp
  }


module OList.Properties {A : Set}(_≤_ : A → A → Set) where

open import Data.List
open import Bound.Lower A
open import Bound.Lower.Order _≤_
open import List.Sorted _≤_
open import OList _≤_

lemma-olist-sorted : {b : Bound} → (xs : OList b) → Sorted (forget xs)
lemma-olist-sorted onil = nils
lemma-olist-sorted (:< {x = x} _ onil) = singls x
lemma-olist-sorted (:< b≤x (:< (lexy x≤y) ys)) = conss x≤y (lemma-olist-sorted (:< (lexy x≤y) ys))


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

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

open VectorSpace(vectorSpace)

open import Data.Tuple using (_⨯_ ; _,_)
open import Logic
open import Logic.Predicate
open import Numeral.CoordinateVector as Vec using () renaming (Vector to Vec)
open import Numeral.Finite
open import Numeral.Natural
open import Sets.ExtensionalPredicateSet as PredSet using (PredSet ; _∈_ ; [∋]-binaryRelator)
import      Structure.Operator.Vector.FiniteDimensional as FiniteDimensional
open import Structure.Operator.Vector.LinearCombination ⦃ vectorSpace = vectorSpace ⦄
open import Syntax.Function

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

InfiniteDimensional = ∀{n} → ∃(vf ↦ FiniteDimensional.Spanning ⦃ vectorSpace = vectorSpace ⦄ {n}(vf))

-- TODO: Not sure if correct
-- This states that all finite sequences `vf` of length `n` (in terms of `Vec`) that consists of elements from the set `vs` satisfies `P`.
-- This can be used in infinite-dimensional vector spaces to define linear independence, span and basis by: `∃(n ↦ AllFiniteSubsets(n)(P)(vs))`
AllFiniteSubsets : (n : ℕ) → (Vec(n)(V) → Stmt{ℓ}) → (PredSet{ℓₗ}(V) → Stmt)
AllFiniteSubsets(n) P(vs) = (∀{vf : Vec(n)(V)} ⦃ distinct : Vec.Distinct(vf) ⦄ → (∀{i : 𝕟(n)} → (Vec.proj(vf)(i) ∈ vs)) → P(vf))

LinearlyIndependent : PredSet{ℓₗ}(V) → Stmt
LinearlyIndependent(vs) = ∃(n ↦ AllFiniteSubsets(n)(FiniteDimensional.LinearlyIndependent)(vs))

Spanning : PredSet{ℓₗ}(V) → Stmt
Spanning(vs) = ∃(n ↦ AllFiniteSubsets(n)(FiniteDimensional.Spanning)(vs))

-- Also called: Hamel basis (TODO: I think)
Basis : PredSet{ℓₗ}(V) → Stmt
Basis(vs) = ∃(n ↦ AllFiniteSubsets(n)(FiniteDimensional.Basis)(vs))


module Computability.Data.Fin.Opposite where

open import Computability.Prelude
open import Data.Nat using (_≤_; _<_; s≤s; z≤n)
open import Data.Nat.Properties using (≤-step)
open import Data.Fin using (Fin; zero; suc; inject₁; fromℕ; fromℕ<; toℕ; opposite)

opposite-fromℕ : ∀ k → opposite (fromℕ k) ≡ zero
opposite-fromℕ zero = refl
opposite-fromℕ (suc k) rewrite opposite-fromℕ k = refl

opposite-inject₁-suc : ∀{k}(i : Fin k) → opposite (inject₁ i) ≡ suc (opposite i)
opposite-inject₁-suc zero = refl
opposite-inject₁-suc (suc i) rewrite opposite-inject₁-suc i = refl

opposite-opposite : ∀{k}(i : Fin k) → opposite (opposite i) ≡ i
opposite-opposite {suc k} zero rewrite opposite-fromℕ k = refl
opposite-opposite (suc i)
  rewrite opposite-inject₁-suc (opposite i)
        | opposite-opposite i = refl

opposite-fromℕ< : ∀ a b (lt : a < b) → opposite (fromℕ< (≤-step lt)) ≡ suc (opposite (fromℕ< lt))
opposite-fromℕ< zero .(suc _) (s≤s le) = refl
opposite-fromℕ< (suc a) .(suc _) (s≤s le) rewrite opposite-fromℕ< _ _ le = refl


module Data.Either.Setoid where

import      Lvl
open import Data.Either as Either
open import Data.Either.Equiv
open import Logic
open import Logic.Propositional
open import Structure.Function.Domain
open import Structure.Function
open import Structure.Relator.Equivalence
open import Structure.Relator.Properties
open import Structure.Setoid
open import Type

private variable ℓ ℓₑ ℓₑ₁ ℓₑ₂ : Lvl.Level
private variable A B : Type{ℓ}

module _ ⦃ equiv-A : Equiv{ℓₑ₁}(A) ⦄ ⦃ equiv-B : Equiv{ℓₑ₂}(B) ⦄ where
  data EitherEquality : (A ‖ B) → (A ‖ B) → Stmt{Lvl.of(A) Lvl.⊔ Lvl.of(B) Lvl.⊔ ℓₑ₁ Lvl.⊔ ℓₑ₂} where
    Left  : ∀{x y} → (x ≡ y) → EitherEquality(Left  x)(Left  y)
    Right : ∀{x y} → (x ≡ y) → EitherEquality(Right x)(Right y)

  EitherEquality-elim : ∀{ℓ}{P : ∀{ab₁ ab₂ : (A ‖ B)} → EitherEquality ab₁ ab₂ → Type{ℓ}} → (∀{x y : A} → (xy : (x ≡ y)) → P(Left xy)) → (∀{x y : B} → (xy : (x ≡ y)) → P(Right xy)) → ∀{ab₁ ab₂ : (A ‖ B)} → (eq : EitherEquality ab₁ ab₂) → P(eq)
  EitherEquality-elim l r (Left  p) = l p
  EitherEquality-elim l r (Right p) = r p

  EitherEquality-not-Left-Right : ∀{a : A}{b : B} → ¬(EitherEquality (Left a) (Right b))
  EitherEquality-not-Left-Right ()

  instance
    Either-equiv : Equiv(A ‖ B)
    Equiv._≡_ Either-equiv = EitherEquality
    Reflexivity.proof (Equivalence.reflexivity (Equiv.equivalence Either-equiv)) {Left  _} = Left (reflexivity(_≡_))
    Reflexivity.proof (Equivalence.reflexivity (Equiv.equivalence Either-equiv)) {Right _} = Right (reflexivity(_≡_))
    Symmetry.proof (Equivalence.symmetry (Equiv.equivalence Either-equiv)) {.(Left _)} {.(Left _)} (Left p) = Left (symmetry(_≡_) p)
    Symmetry.proof (Equivalence.symmetry (Equiv.equivalence Either-equiv)) {.(Right _)} {.(Right _)} (Right p) = Right (symmetry(_≡_) p)
    Transitivity.proof (Equivalence.transitivity (Equiv.equivalence Either-equiv)) {.(Left _)} {.(Left _)} {.(Left _)} (Left xy) (Left yz) = Left (transitivity(_≡_) xy yz)
    Transitivity.proof (Equivalence.transitivity (Equiv.equivalence Either-equiv)) {.(Right _)} {.(Right _)} {.(Right _)} (Right xy) (Right yz) = Right (transitivity(_≡_) xy yz)

  instance
    Left-function : Function ⦃ equiv-A ⦄ ⦃ Either-equiv ⦄ (Left)
    Function.congruence Left-function = Left

  instance
    Right-function : Function ⦃ equiv-B ⦄ ⦃ Either-equiv ⦄ (Right)
    Function.congruence Right-function = Right

  instance
    Left-injectivity : Injective(Left {A = A}{B = B})
    Injective.proof Left-injectivity (Left p) = p

  instance
    Right-injectivity : Injective(Right {A = A}{B = B})
    Injective.proof Right-injectivity (Right p) = p

  instance
    EitherEquality-extensionality : Extensionality(Either-equiv)
    Extensionality.Left-Right-inequality EitherEquality-extensionality ()


module Data.BinaryTree.Properties where

import      Lvl
open import Data hiding (empty)
open import Data.BinaryTree
open import Data.Boolean
open import Functional as Fn
open import Logic.Propositional
open import Numeral.Natural
open import Type

private variable ℓ ℓᵢ ℓₗ ℓₙ ℓₒ : Lvl.Level
private variable n : ℕ
private variable N N₁ N₂ L T A B : Type{ℓ}

-- A tree is full when every node has no or all children.
data Full {L : Type{ℓₗ}}{N : Type{ℓₙ}} : BinaryTree L N → Type{ℓₗ Lvl.⊔ ℓₙ} where
  leaf   : ∀{l} → Full(Leaf l)
  single : ∀{a}{l₁ l₂} → Full(Node a (Leaf l₁) (Leaf l₂))
  step   : ∀{al ar a}{cll clr crl crr} → Full(Node al cll clr) → Full(Node ar crl crr) → Full(Node a (Node al cll clr) (Node ar crl crr))

-- A tree is perfect at depth `n` when all leaves are at height `n`.
-- In other words, a tree is perfect when all leaves are at the same height.
data Perfect {L : Type{ℓₗ}}{N : Type{ℓₙ}} : BinaryTree L N → ℕ → Type{ℓₗ Lvl.⊔ ℓₙ} where
  leaf : ∀{l} → Perfect(Leaf l)(𝟎)
  step : ∀{a}{l r}{h} → Perfect(l)(h) → Perfect(r)(h) → Perfect(Node a l r)(𝐒(h))

data Complete {L : Type{ℓₗ}}{N : Type{ℓₙ}} : BinaryTree L N → ℕ → Bool → Type{ℓₗ Lvl.⊔ ℓₙ} where
  perfect-leaf : ∀{l} → Complete(Leaf l)(𝟎)(𝑇)
  imperfect-leaf : ∀{l} → Complete(Leaf l)(𝐒(𝟎))(𝐹)
  step₀ : ∀{a}{l r}{h} → Complete(l)(h)(𝐹) → Complete(r)(h)(𝐹) → Complete(Node a l r)(𝐒(h))(𝐹)
  step₁ : ∀{a}{l r}{h} → Complete(l)(h)(𝑇) → Complete(r)(h)(𝐹) → Complete(Node a l r)(𝐒(h))(𝐹)
  step₂ : ∀{a}{l r}{h} → Complete(l)(h)(𝑇) → Complete(r)(h)(𝑇) → Complete(Node a l r)(𝐒(h))(𝑇)

data DepthOrdered {L : Type{ℓₗ}}{N : Type{ℓₙ}} (_≤_ : N → N → Type{ℓₒ}) : BinaryTree L N → Type{ℓₗ Lvl.⊔ ℓₙ Lvl.⊔ ℓₒ} where
  leaf : ∀{l} → DepthOrdered(_≤_)(Leaf l)
  step : ∀{a}{l₁ l₂} → DepthOrdered(_≤_)(Node a (Leaf l₁) (Leaf l₂))
  stepₗ : ∀{a al ar}{l}{rl rr} → (a ≤ al) → DepthOrdered(_≤_)(Node al rl rr)
                                          → DepthOrdered(_≤_)(Node a (Leaf l) (Node ar rl rr))
  stepᵣ : ∀{a al ar}{l}{ll lr} → (a ≤ ar) → DepthOrdered(_≤_)(Node ar ll lr)
                                          → DepthOrdered(_≤_)(Node a (Node al ll lr) (Leaf l))
  stepₗᵣ : ∀{a al ar}{ll lr rl rr} → (a ≤ al) → DepthOrdered(_≤_)(Node al ll lr)
                                   → (a ≤ ar) → DepthOrdered(_≤_)(Node ar rl rr)
                                   → DepthOrdered(_≤_)(Node a (Node al ll lr) (Node ar rl rr))

Heap : ∀{L : Type{ℓₗ}}{N : Type{ℓₙ}} → (N → N → Type{ℓₒ}) → BinaryTree L N → ℕ → Bool → Type
Heap(_≤_) tree height perfect = DepthOrdered(_≤_)(tree) ∧ Complete(tree)(height)(perfect)


module Solution where

open import Data.Empty
open import Data.List
open import Data.Nat
open import Data.Bool hiding (_≟_)
open import Relation.Nullary
open import Relation.Binary.PropositionalEquality

data Subseq : List ℕ → List ℕ → Set where
  subseq-nil  :                            Subseq [] []
  subseq-take : ∀ a xs ys → Subseq xs ys → Subseq (a ∷ xs) (a ∷ ys)
  subseq-drop : ∀ a xs ys → Subseq xs ys → Subseq xs (a ∷ ys)

_⊂_ : List ℕ → List ℕ → Set
_⊂_ = Subseq

subseq-match : (xs ys : List ℕ) → Bool
subseq-match [] ys = true
subseq-match (x ∷ xs) [] = false
subseq-match (x ∷ xs) (y ∷ ys) with x ≟ y
... | yes _ = subseq-match xs ys
... | no  _ = subseq-match (x ∷ xs) ys

_⊂*_ : List ℕ → List ℕ → Bool
_⊂*_ = subseq-match

-- silly : ∀ (a : ℕ) (xs ys : List ℕ) → xs ⊂* ys ≡ (a ∷ xs) ⊂* (a ∷ ys)
-- silly a xs ys = ?

subseq-match⇒subseq : ∀ xs ys → xs ⊂* ys ≡ true → xs ⊂ ys
subseq-match⇒subseq []       []       H = subseq-nil
subseq-match⇒subseq []       (y ∷ ys) H = subseq-drop y [] ys (subseq-match⇒subseq [] ys H)
subseq-match⇒subseq (x ∷ xs) (y ∷ ys) H with x ≟ y
... | yes P rewrite sym P = subseq-take x xs ys (subseq-match⇒subseq xs ys H)
... | no  _               = subseq-drop y (x ∷ xs) ys (subseq-match⇒subseq (x ∷ xs) ys H)

subseq⇒subseq-match : ∀ xs ys → xs ⊂ ys → xs ⊂* ys ≡ true
subseq⇒subseq-match .[] .[] subseq-nil = refl
subseq⇒subseq-match (x ∷ xs) .(a ∷ ys) (subseq-take a xs ys H) with x ≟ a
... | yes refl  = subseq⇒subseq-match xs ys H
... | no absurd = ⊥-elim (absurd refl)
subseq⇒subseq-match [] .(a ∷ ys) (subseq-drop a .[] ys H) = refl
subseq⇒subseq-match (x ∷ xs) .(a ∷ ys) (subseq-drop a .(x ∷ xs) ys H) with x ≟ a
... | yes refl = {!!}
... | no _ = {!!}


------------------------------------------------------------------------
-- Divisibility and coprimality
------------------------------------------------------------------------

module Data.Integer.Divisibility where

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

-- Divisibility.

infix 4 _∣_

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

-- Coprimality.

Coprime : Rel ℤ
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)