{-

          Types Summer School 2007

                 Bertinoro
             Aug 19 - 31, 2007

                   Agda

                Ulf Norell

-}

-- Records are labeled sigma types.

module Records where

open import Nat
open import Bool

{-

  A very simple record.

-}

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

-- A record can be seen as a one constructor datatype. In this case:
data Point' : Set where
  mkPoint : (x : Nat)(y : Nat) -> Point'

-- There are a few differences, though:

-- To construct a record you use the syntax record { ..; x = e; .. }
origin : Point
origin = record { x = 0; y = 0 }

-- instead of
origin' : Point'
origin' = mkPoint 0 0

-- What's more interesting is that you get projection functions
-- for free when you declare a record. More precisely, you get a module
-- parameterised over a record, containing functions corresponding to the
-- fields. In the Point example you get:
{-
  module Point (p : Point) where
    x : Nat
    y : Nat
-}

-- So Point.x : Point -> Nat is the projection function for the field x.
getX : Point -> Nat
getX = Point.x

-- A nifty thing with having the projection functions in a module is that
-- you can apply the module to a record value, in effect opening the record.
sum : Point -> Nat
sum p = x + y
  where
   open module Pp = Point p

-- The final difference between records and datatypes is that we have
-- η-equality on records.

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

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

{-

  The empty record

-}

-- One interesting benefit of this is that we get a unit type with
-- η-equality.
record True : Set where

tt : True
tt = record{}

-- Now, since any element of True is equal to tt, metavariables of
-- type True will simply disappear. The following cute example exploits
-- this:

data False : Set where

NonZero : Nat -> Set
NonZero zero    = False
NonZero (suc _) = True

-- We make the proof that m is non-zero implicit.

_/_ : (n m : Nat){p : NonZero m} -> Nat
(n / zero) {}
zero  / suc m = zero
suc n / suc m = div (suc n) (suc m) m
  where
    div : Nat -> Nat -> Nat -> Nat
    div  zero    zero   c = suc zero
    div  zero   (suc y) c = zero
    div (suc x)  zero   c = suc (div x c c)
    div (suc x) (suc y) c = div x y c

-- Now, as long as we're dividing by things which are obviously
-- NonZero we can completely ignore the proof.

five = 17 / 3

{-

  A dependent record

-}

-- Of course, records can be dependent, and have parameters.
record ∃ {A : Set}(P : A -> Set) : Set where
  field
    witness : A
    proof   : P witness


open import Relation.Binary.Core

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

open import BSTree _≤_
open import BSTree.Properties _≤_ trans≤
open import BTree {A}
open import Data.List
open import Data.Sum
open import Function using (_∘_)
open import List.Sorted _≤_
open import TreeSort.Impl1 _≤_ tot≤

lemma-insert-*⊴ : {x y : A}{t : BTree} → x ≤ y → t *⊴ y → insert x t *⊴ y
lemma-insert-*⊴ x≤y lelf = lend x≤y lelf
lemma-insert-*⊴ {x = x}{t = node z l r} x≤y (lend z≤y r≤y)
    with tot≤ x z
... | inj₁ x≤z = lend z≤y r≤y
... | inj₂ z≤x = lend z≤y (lemma-insert-*⊴ x≤y r≤y)

lemma-insert-⊴* : {x y : A}{t : BTree} → y ≤ x → y ⊴* t → y ⊴* insert x t
lemma-insert-⊴* y≤x gelf = gend y≤x gelf
lemma-insert-⊴* {x = x} {t = node z l r} y≤x (gend y≤z y≤l)
    with tot≤ x z
... | inj₁ x≤z = gend y≤z (lemma-insert-⊴* y≤x y≤l)
... | inj₂ z≤x = gend y≤z y≤l

lemma-insert-bst : {t : BTree}(x : A) → BSTree t → BSTree (insert x t)
lemma-insert-bst x slf = snd slf slf lelf gelf
lemma-insert-bst x (snd {x = y} sl sr l≤y y≤r)
    with tot≤ x y
... | inj₁ x≤y = snd (lemma-insert-bst x sl) sr (lemma-insert-*⊴ x≤y l≤y) y≤r
... | inj₂ y≤x = snd sl (lemma-insert-bst x sr) l≤y (lemma-insert-⊴* y≤x y≤r)

lemma-treeSort-bst : (xs : List A) → BSTree (treeSort xs)
lemma-treeSort-bst [] = slf
lemma-treeSort-bst (x ∷ xs) = lemma-insert-bst x (lemma-treeSort-bst xs)

theorem-treeSort-sorted : (xs : List A) → Sorted (flatten (treeSort xs))
theorem-treeSort-sorted = lemma-bst-sorted ∘ lemma-treeSort-bst


module Isomorphism where

  import Sets
  open Sets

  infix 20 _≅_

  data _≅_ (A B : Set) : Set where
    iso : (i : A -> B)(j : B -> A) ->
	  (forall x -> j (i x) == x) ->
	  (forall y -> i (j y) == y) ->
	  A ≅ B

  refl-≅ : (A : Set) -> A ≅ A
  refl-≅ A = iso id id (\x -> refl) (\x -> refl)

  iso[×] : {A₁ A₂ B₁ B₂ : Set} -> A₁ ≅ A₂ -> B₁ ≅ B₂ -> A₁ [×] B₁ ≅ A₂ [×] B₂
  iso[×] (iso a₁₂ a₂₁ p₁₁ p₂₂) (iso b₁₂ b₂₁ q₁₁ q₂₂) =
    iso ab₁₂ ab₂₁ pq₁₁ pq₂₂ where

    ab₁₂ = a₁₂ <×> b₁₂
    ab₂₁ = a₂₁ <×> b₂₁

    pq₂₂ : (z : _ [×] _) -> ab₁₂ (ab₂₁ z) == z
    pq₂₂ < x , y > =
      subst (\ ∙ -> < ∙ , b₁₂ (b₂₁ y) > == < x , y >) (p₂₂ x)
      $ cong < x ,∙> (q₂₂ y)

    pq₁₁ : (z : _ [×] _) -> ab₂₁ (ab₁₂ z) == z
    pq₁₁ < x , y > =
      subst (\ ∙ -> < ∙ , b₂₁ (b₁₂ y) > == < x , y >) (p₁₁ x)
      $ cong < x ,∙> (q₁₁ y)

  iso[+] : {A₁ A₂ B₁ B₂ : Set} -> A₁ ≅ A₂ -> B₁ ≅ B₂ -> A₁ [+] B₁ ≅ A₂ [+] B₂
  iso[+] (iso a₁₂ a₂₁ p₁₁ p₂₂) (iso b₁₂ b₂₁ q₁₁ q₂₂) =
    iso ab₁₂ ab₂₁ pq₁₁ pq₂₂ where

    ab₁₂ = a₁₂ <+> b₁₂
    ab₂₁ = a₂₁ <+> b₂₁

    pq₂₂ : (z : _ [+] _) -> ab₁₂ (ab₂₁ z) == z
    pq₂₂ (inl x) = cong inl (p₂₂ x)
    pq₂₂ (inr y) = cong inr (q₂₂ y)

    pq₁₁ : (z : _ [+] _) -> ab₂₁ (ab₁₂ z) == z
    pq₁₁ (inl x) = cong inl (p₁₁ x)
    pq₁₁ (inr y) = cong inr (q₁₁ y)


open import Nat
open import Prelude
open import core
open import contexts

module htype-decidable where
  lemma-l : ∀{t1 t2 t4} → t1 ==> t2 == t1 ==> t4 → t2 == t4
  lemma-l refl = refl

  lemma-r : ∀{t1 t2 t3} → t1 ==> t2 == t3 ==> t2 → t1 == t3
  lemma-r refl = refl

  lemma-b : ∀{t1 t2 t3 t4} → t1 ==> t2 == t3 ==> t4 → t1 == t3
  lemma-b refl = refl

  htype-dec : (t1 t2 : htyp) → t1 == t2 + (t1 == t2 → ⊥)
  htype-dec b b = Inl refl
  htype-dec b ⦇-⦈ = Inr (λ ())
  htype-dec b (t2 ==> t3) = Inr (λ ())
  htype-dec ⦇-⦈ b = Inr (λ ())
  htype-dec ⦇-⦈ ⦇-⦈ = Inl refl
  htype-dec ⦇-⦈ (t2 ==> t3) = Inr (λ ())
  htype-dec (t1 ==> t2) b = Inr (λ ())
  htype-dec (t1 ==> t2) ⦇-⦈ = Inr (λ ())
  htype-dec (t1 ==> t2) (t3 ==> t4) with htype-dec t1 t3 | htype-dec t2 t4
  htype-dec (t1 ==> t2) (.t1 ==> .t2) | Inl refl | Inl refl = Inl refl
  htype-dec (t1 ==> t2) (.t1 ==> t4)  | Inl refl | Inr x₁   = Inr (λ x → x₁ (lemma-l x))
  htype-dec (t1 ==> t2) (t3 ==> .t2)  | Inr x    | Inl refl = Inr (λ x₁ → x (lemma-r x₁))
  htype-dec (t1 ==> t2) (t3 ==> t4)   | Inr x    | Inr x₁   = Inr (λ x₂ → x (lemma-b x₂))

  -- if an arrow is disequal, it disagrees in the first or second argument
  ne-factor : ∀{τ1 τ2 τ3 τ4} → (τ1 ==> τ2) ≠ (τ3 ==> τ4) → (τ1 ≠ τ3) + (τ2 ≠ τ4)
  ne-factor {τ1} {τ2} {τ3} {τ4} ne with htype-dec τ1 τ3 | htype-dec τ2 τ4
  ne-factor ne | Inl refl | Inl refl = Inl (λ x → ne refl)
  ne-factor ne | Inl x | Inr x₁ = Inr x₁
  ne-factor ne | Inr x | Inl x₁ = Inl x
  ne-factor ne | Inr x | Inr x₁ = Inl x


module fizzbuzz where

import Data.Nat        as N
import Data.Nat.DivMod as N
import Data.Nat.Show   as N
import Data.Bool       as B
import Data.Fin        as F
import Data.Unit       as U
import Data.String     as S
open import Data.Product using (_,_ ; _×_)
open import IO
open import Agda.Builtin.Coinduction
open import Relation.Nullary
open import Function

congruent : N.ℕ → N.ℕ → B.Bool
congruent n N.zero    = B.false
congruent n (N.suc m) with N._≟_ 0 $ F.toℕ (N._mod_ n (N.suc m) {U.tt})
... | yes _ = B.true
... | no  _ = B.false

_and_ : {A B : Set} → A → B → A × B
_and_ = _,_

fizzbuzz : N.ℕ → S.String
fizzbuzz N.zero    = "fizzbuzz"
fizzbuzz n with congruent n 3 and congruent n 5
... | B.true  , B.true   = "fizzbuzz"
... | B.true  , B.false  = "fizz"
... | B.false , B.true   = "buzz"
... | B.false , B.false  = N.show n

worker : N.ℕ → IO U.⊤
worker N.zero    = putStrLn $ fizzbuzz N.zero
worker (N.suc n) = ♯ worker n >> ♯ putStrLn (fizzbuzz $ N.suc n)

main = run $ worker 100


{-# OPTIONS --copatterns #-}

module LecStr where

open import CS410-Prelude
open import CS410-Nat
open import CS410-Functor

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

count : Nat -> Stream Nat
head (count n) = n
tail (count n) = count (suc n)

nats : Stream Nat
nats = count zero

poke : Nat
poke = head (tail (tail (tail nats)))

repeat : {X : Set} -> X -> Stream X
head (repeat x) = x
tail (repeat x) = repeat x

strApp : {S T : Set} -> Stream (S -> T) -> Stream S -> Stream T
head (strApp fs ss) = (head fs) (head ss)
tail (strApp fs ss) = strApp (tail fs) (tail ss)

strMap : {S T : Set} -> (S -> T) -> Stream S -> Stream T
strMap f ss = strApp (repeat f) ss

diagonal : {X : Set} -> Stream (Stream X) -> Stream X
head (diagonal xss) = head (head xss)
tail (diagonal xss) = diagonal (strMap tail (tail xss))

{- productivity checker rejects
fibo : Stream Nat
head fibo = 1
head (tail fibo) = 1
tail (tail fibo) = strApp (strApp (repeat _+N_) (tail fibo)) fibo
-}

data CoList' (X : Set) : Set
record CoList (X : Set) : Set where
  coinductive
  constructor thunk
  field
    force : CoList' X
data CoList' X where
  [] : CoList' X
  _::_ : X -> CoList X -> CoList' X

module CoListExamples where
  open CoList

  short : CoList Nat
  short = thunk (0 :: thunk (1 :: thunk (2 :: thunk [])))

  long : forall {X} -> Stream X -> CoList X
  force (long s) = head s :: long (tail s)

  _++_ : forall {X} -> CoList X -> CoList X -> CoList X
  force (xs ++ ys) with force xs
  force (xs ++ ys) | [] = force ys
  force (xs ++ ys) | x :: xs' = x :: (xs' ++ ys)

{-
  concat : forall {X} -> CoList (CoList X) -> CoList X
  force (concat xss) with force xss
  force (concat xss) | [] = []
  force (concat xss) | xs :: xss' with force xs
  force (concat xss) | xs :: xss' | [] = ? -- oops force (concat xss')
  force (concat xss) | xs :: xss' | x :: xs' = x :: concat (thunk (xs' :: xss'))
-}

-- nonempty CoLists
-- tails for Streams
-- " n.e. CoLists


------------------------------------------------------------------------------
-- Proving that two group theory formalisations are equivalents
------------------------------------------------------------------------------

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

-- We prove that group theory axioms based on the signature (G, ·, ε,)
-- (see for example [p. 39, 1]), i.e.

-- ∀ a b c. abc = a(bc)

-- ∀ a. εa = aε = a

-- ∀ a. ∃ a'. a'a = aa' = ε

-- are equivalents to the axioms based on the signature (G, ·, _⁻¹, ε,)
-- (see for example [2,3]), i.e.

-- ∀ a b c. abc = a(bc)

-- ∀ a. εa = aε  = a

-- ∀ a. a⁻¹a = aa⁻¹ = ε

-- [1] C. C. Chang and H. J. Keisler. Model Theory, volume 73 of Studies
--  in Logic and the Foundations of Mathematics. North-Holland, 3rd
--  edition, 3rd impression 1992.

-- [2] Agda standard library_0.8.1 (see Algebra/Structures.agda)

-- [3] Coq implementation
--     (http://coq.inria.fr/pylons/contribs/files/GroupTheory/v8.3/GroupTheory.g1.html)

module FOT.GroupTheory.FormalisationsSL where

open import Data.Product
open import Relation.Binary.PropositionalEquality

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

-- NB. We only write the proof for the left-inverse property.

infixl 10 _·_ -- The symbol is '\cdot'.

postulate
  G   : Set        -- The universe
  ε   : G          -- The identity element.
  _·_ : G → G → G  -- The binary operation.

-- Left-inverse property based on the signature (G, ·, ε,).
leftInverse₁ : Set
leftInverse₁ = ∀ a → Σ G (λ a' → a' · a ≡ ε)

-- Left-inverse property based on the signature (G, ·, _⁻¹, ε,).
infix  11 _⁻¹

postulate  _⁻¹ : G → G -- The inverse function.

leftInverse₂ : Set
leftInverse₂ = ∀ a → a ⁻¹ · a ≡ ε

-- From the left-inverse property based on the signature (G, ·, _⁻¹, ε,)
-- to the one based on the signature (G, ·, ε,).
leftInverse₂₋₁ : leftInverse₂ → leftInverse₁
leftInverse₂₋₁ h a = (a ⁻¹) , (h a)

-- From the left-inverse property based on the signature (G, ·, ε,) to
-- the one based on the signature (G, ·, _⁻¹, ε,).
--
-- In this case we prove the existence of the inverse function.
leftInverse₁₋₂ : leftInverse₁ → Σ (G → G) (λ f → ∀ a → f a · a ≡ ε)
leftInverse₁₋₂ h = f , prf
  where
  f : G → G  --  The inverse function.
  f a = proj₁ (h a)

  prf : ∀ a → f a · a ≡ ε
  prf a = proj₂ (h a)


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

open import LogicalFormulae
open import Setoids.Setoids
open import Functions.Definition
open import Sets.EquivalenceRelations
open import Rings.Definition

module Rings.Divisible.Definition {a b : _} {A : Set a} {S : Setoid {a} {b} A} {_+_ _*_ : A → A → A} (R : Ring S _+_ _*_) where

open Setoid S
open Equivalence eq
open Ring R

_∣_ : Rel A
a ∣ b = Sg A (λ c → (a * c) ∼ b)

divisibleWellDefined : {x y a b : A} → (x ∼ y) → (a ∼ b) → x ∣ a → y ∣ b
divisibleWellDefined x=y a=b (c , xc=a) = c , transitive (*WellDefined (symmetric x=y) reflexive) (transitive xc=a a=b)


module Issue790 where

open import Common.Level   renaming (lzero to zero; lsuc to suc)
open import Common.Prelude using (Bool; true; false; zero; suc) renaming (Nat to ℕ)

even? : ℕ -> Bool
even? 0             = true
even? (suc (suc n)) = even? n
even? _             = false

-- Name overlap between Level's suc and Nat's suc should not matter,
-- since only one is a constructor.


module Naturals where

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

-- suc (suc (suc (suc (suc (suc (suc zero))))))

{-# BUILTIN NATURAL ℕ #-}

import Relation.Binary.PropositionalEquality as Eq
open Eq using (_≡_; refl)
open Eq.≡-Reasoning using (begin_; _≡⟨⟩_; _∎)

_+_ : ℕ → ℕ → ℕ
zero + n  = n           -- 0 + n       ≡ n
suc m + n = suc (m + n) -- (1 + m) + n ≡ 1 + (m + n)

_ : 1 + 1 ≡ 2
_ = refl

_ : 3 + 4 ≡ 7
_ =
  begin
    3 + 4
  ≡⟨⟩
    suc 1 + 4
  ∎


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

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

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

open import Setoids.Subset S
open Group G

record Subgroup {c : _} (pred : A → Set c) : Set (a ⊔ b ⊔ c) where
  field
    isSubset : subset pred
    closedUnderPlus : {g h : A} → (pred g) → (pred h) → pred (g + h)
    containsIdentity : pred 0G
    closedUnderInverse : ({g : A} → (pred g) → (pred (inverse g)))

subgroupOp : {c : _} {pred : A → Set c} → (s : Subgroup pred) → Sg A pred → Sg A pred → Sg A pred
subgroupOp {pred = pred} record { closedUnderPlus = one } (a , prA) (b , prB) = (a + b) , one prA prB

subgroupIsGroup : {c : _} {pred : A → Set c} → (s : Subgroup pred) → Group (subsetSetoid (Subgroup.isSubset s)) (subgroupOp s)
Group.+WellDefined (subgroupIsGroup s) {m , prM} {n , prN} {x , prX} {y , prY} m=x n=y = +WellDefined m=x n=y
Group.0G (subgroupIsGroup record { containsIdentity = two }) = 0G , two
Group.inverse (subgroupIsGroup record { closedUnderInverse = three }) (a , prA) = (inverse a) , three prA
Group.+Associative (subgroupIsGroup s) {a , prA} {b , prB} {c , prC} = +Associative
Group.identRight (subgroupIsGroup s) {a , prA} = identRight
Group.identLeft (subgroupIsGroup s) {a , prA} = identLeft
Group.invLeft (subgroupIsGroup s) {a , prA} = invLeft
Group.invRight (subgroupIsGroup s) {a , prA} = invRight


module 030-semigroup where

-- We need equivalence.

open import 020-equivalence

-- Semigroups are basically a set with equality and some binary
-- operator which is associative and respects equality.

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

  field
    equiv : Equivalence _==_
    assoc : ∀ {r s t} -> ((r * s) * t) == (r * (s * t))
    cong : ∀ {r s u v} -> (r == s) -> (u == v) -> (r * u) == (s * v)

  -- The next line brings all fields and declarations of Equivalence
  -- into this record's namespace so we can refer to them in an
  -- unqualified way in proofs (for example, we can write "refl" for
  -- "Equivalence.symm equiv" and so on).

  open Equivalence equiv public

  -- No theorems here yet.


-- Proof of: ∀ (x : ND ℕ) → always (even (double (eo x))) ≡ tt

module even-double-eo where

open import bool
open import nat
open import eq
open import nat-thms
open import nondet
open import nondet-thms
open import functions

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

-- A definition of double with addition.
double : ℕ → ℕ
double x = x + x

-- even is a deterministic predicate:
even : ℕ → 𝔹
even zero = tt
even (suc 0) = ff
even (suc (suc x)) = even x

-- eo yields an even and odd number close to the input value:
eo : ℕ → ND ℕ
eo n = Val n ?? Val (suc n)

-- auxiliary property for x+x instead of double:
even-x+x : (x : ℕ) → even (x + x) ≡ tt
even-x+x zero = refl
even-x+x (suc x) rewrite +suc x x | even-x+x x = refl

-- (even (double x)) is always true:
even-double-is-true : ∀ (x : ℕ) → even (double x) ≡ tt
even-double-is-true x rewrite even-x+x x = refl

-- Proof of main result:
even-double-eo-true : (n : ℕ) → always ((even ∘ double) $* (eo n)) ≡ tt
even-double-eo-true n = always-$* (even ∘ double) (eo n) even-double-is-true

-- Alternative statement and proof:
double-eo-satisfy-even : ∀ (n : ℕ) → (double $* (eo n)) satisfy even ≡ tt
double-eo-satisfy-even n
  rewrite even-double-is-true n | +suc n n | even-double-is-true n = refl

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


module Lib where

-- Natural numbers

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

{-# BUILTIN NATURAL Nat #-}

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

-- Finite sets

data Fin : Nat -> Set where
  fzero : forall {n} ->          Fin (suc n)
  fsuc  : forall {n} -> Fin n -> Fin (suc n)

fin : forall {n} (k : Nat) -> Fin (suc (k + n))
fin zero    = fzero
fin (suc i) = fsuc (fin i)

-- Lists

infixl 0 _,_

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

-- List membership

data LMem {X : Set} (a : X) : List X -> Set where
  lzero : forall {l}               -> LMem a (l , a)
  lsuc  : forall {l b} -> LMem a l -> LMem a (l , b)

-- Vectors

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

proj : forall {X n} -> Vec X n -> Fin n -> X
proj []      ()
proj (_ , a) fzero    = a
proj (v , _) (fsuc i) = proj v i

-- Vector membership

data VMem {X : Set} (a : X) : forall {n} -> Fin n -> Vec X n -> Set where
  mzero : forall {n}     {v : Vec X n}               -> VMem a fzero    (v , a)
  msuc  : forall {n i b} {v : Vec X n} -> VMem a i v -> VMem a (fsuc i) (v , b)

fmem : forall {X n} -> (i : Fin n) -> {v : Vec X n} -> VMem (proj v i) i v
fmem {_} {zero}  ()
fmem {_} {suc n} fzero    {_ , a} = mzero
fmem {_} {suc n} (fsuc i) {v , _} = msuc (fmem i)

mem : forall {X n} -> (k : Nat) -> {v : Vec X (suc (k + n))} -> VMem (proj v (fin k)) (fin k) v
mem i = fmem (fin i)


-- Functions used in googology

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

module Math.Googology.Function where

-- agda-stdlib
open import Data.Nat
open import Data.Nat.GeneralisedArithmetic
open import Function

-- Ackermann function.
-- ack m n = Ack(m, n)
ack : ℕ → ℕ → ℕ
ack 0       n       = 1 + n
ack (suc m) zero    = ack m 1
ack (suc m) (suc n) = ack m (ack (suc m) n)

-- Hyperoperation.
-- H n a b ≡ Hₙ(a, b)
H : ℕ → ℕ → ℕ → ℕ
H 0                     a b       = 1 + b
H 1                     a 0       = a
H 1                     a (suc b) = H 0 a (H 1 a b)
H 2                     a 0       = 0
H 2                     a (suc b) = H 1 a (H 2 a b)
H (suc (suc (suc _)))   a 0       = 1
H (suc n@(suc (suc _))) a (suc b) = H n a (H (suc n) a b)

-- Knuth's up-arrow notation.
-- a ↑[ n ] b =`a ↑ⁿ b`
_↑[_]_ : ℕ → ℕ → ℕ → ℕ
a ↑[ n ] b = H (2 + n) a b

infixr 8 _↑_ _↑↑_ _↑↑↑_ _↑↑↑↑_

-- Exponentiation.
_↑_ : ℕ → ℕ → ℕ
_↑_ a b = a ↑[ 1 ] b

-- Tetration.
_↑↑_ : ℕ → ℕ → ℕ
_↑↑_ a b = a ↑[ 2 ] b

-- Pentation.
_↑↑↑_ : ℕ → ℕ → ℕ
_↑↑↑_ a b = a ↑[ 3 ] b

-- Hexation.
_↑↑↑↑_ : ℕ → ℕ → ℕ
_↑↑↑↑_ a b = a ↑[ 4 ] b

-- Heptation.
_↑↑↑↑↑_ : ℕ → ℕ → ℕ
_↑↑↑↑↑_ a b = a ↑[ 5 ] b

-- Graham's number.
graham's-number : ℕ
graham's-number = go 64 where
  go : ℕ → ℕ
  go 0       = 4
  go (suc n) = 3 ↑[ go n ] 3

-- Fast-growing hierarchy
FGHℕ[_][_] : ℕ → ℕ → ℕ
FGHℕ[ zero  ][ x ] = suc x
FGHℕ[ suc n ][ x ] = fold x FGHℕ[ n ][_] x

FGHω : ℕ → ℕ
FGHω n = FGHℕ[ n ][ n ]


------------------------------------------------------------------------------
-- Group theory properties
------------------------------------------------------------------------------

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

module GroupTheory.PropertiesI where

open import GroupTheory.Base

open import Common.FOL.Relation.Binary.EqReasoning

------------------------------------------------------------------------------
-- Congruence properties

-- The propositional equality is compatible with the binary operation.

·-leftCong : ∀ {a b c} → a ≡ b → a · c ≡ b · c
·-leftCong refl = refl

·-rightCong : ∀ {a b c} → b ≡ c → a · b ≡ a · c
·-rightCong refl = refl

-- The propositional equality is compatible with the inverse function.
⁻¹-cong : ∀ {a b} → a ≡ b → a ⁻¹ ≡ b ⁻¹
⁻¹-cong refl = refl

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

leftCancellation : ∀ {a b c} → a · b ≡ a · c → b ≡ c
leftCancellation {a} {b} {c} h =
  b              ≡⟨ sym (leftIdentity b) ⟩
  ε · b          ≡⟨ ·-leftCong (sym (leftInverse a)) ⟩
  a ⁻¹ · a · b   ≡⟨ assoc (a ⁻¹) a b ⟩
  a ⁻¹ · (a · b) ≡⟨ ·-rightCong h ⟩
  a ⁻¹ · (a · c) ≡⟨ sym (assoc (a ⁻¹) a c) ⟩
  a ⁻¹ · a · c   ≡⟨ ·-leftCong (leftInverse a) ⟩
  ε · c          ≡⟨ leftIdentity c ⟩
  c              ∎

-- A different proof without using congruence.
leftCancellation' : ∀ {a b c} → a · b ≡ a · c → b ≡ c
-- Paper proof (Mac Lane and Garret Birkhoff 1999. p. 48):
--
-- 1. a⁻¹(ab) = a⁻¹(ac)  (hypothesis ab = ac)
-- 2. a⁻¹a(b) = a⁻¹a(c)  (associative axiom)
-- 3. εb      = εc       (left-inverse axiom for a⁻¹)
-- 4. b       = c        (left-identity axiom)
leftCancellation' {a} {b} {c} h =
  b              ≡⟨ sym (leftIdentity b) ⟩
  ε · b          ≡⟨ subst (λ t → ε · b ≡ t · b) (sym (leftInverse a)) refl ⟩
  a ⁻¹ · a · b   ≡⟨ assoc (a ⁻¹) a b ⟩
  a ⁻¹ · (a · b) ≡⟨ subst (λ t → a ⁻¹ · (a · b) ≡ a ⁻¹ · t) h refl ⟩
  a ⁻¹ · (a · c) ≡⟨ sym (assoc (a ⁻¹) a c) ⟩
  a ⁻¹ · a · c   ≡⟨ subst (λ t → a ⁻¹ · a · c ≡ t · c) (leftInverse a) refl ⟩
  ε · c          ≡⟨ leftIdentity c ⟩
  c              ∎

-- Mac Lane and Garret Birkhoff (1999) p. 50, exercise 6.
rightIdentity : ∀ a → a · ε ≡ a
rightIdentity a = leftCancellation prf
  where
  prf : a ⁻¹ · (a · ε) ≡ a ⁻¹ · a
  prf = a ⁻¹ · (a · ε) ≡⟨ sym (assoc (a ⁻¹) a ε) ⟩
        a ⁻¹ · a · ε   ≡⟨ ·-leftCong (leftInverse a) ⟩
        ε · ε          ≡⟨ leftIdentity ε ⟩
        ε              ≡⟨ sym (leftInverse a) ⟩
        a ⁻¹ · a       ∎

-- Mac Lane and Garret Birkhoff (1999) p. 50, exercise 6.
rightInverse : ∀ a → a · a ⁻¹ ≡ ε
rightInverse a = leftCancellation prf
  where
  prf : a ⁻¹ · (a · a ⁻¹) ≡ a ⁻¹ · ε
  prf = a ⁻¹ · (a · a ⁻¹) ≡⟨ sym (assoc (a ⁻¹) a (a ⁻¹)) ⟩
        a ⁻¹ · a · a ⁻¹   ≡⟨ ·-leftCong (leftInverse a) ⟩
        ε · a ⁻¹          ≡⟨ leftIdentity (a ⁻¹)  ⟩
        a ⁻¹              ≡⟨ sym (rightIdentity (a ⁻¹)) ⟩
        a ⁻¹ · ε          ∎

rightCancellation : ∀ {a b c} → b · a ≡ c · a → b ≡ c
rightCancellation {a} {b} {c} h =
-- Paper proof:
--
-- 1. (ba)a⁻¹ = (ca)a⁻¹  (hypothesis ab = ac)
-- 2. (b)aa⁻¹ = (c)aa⁻¹  (associative axiom)
-- 3. bε      = cε       (right-inverse axiom for a⁻¹)
-- 4. b       = c        (right-identity axiom)
  b              ≡⟨ sym (rightIdentity b) ⟩
  b · ε          ≡⟨ ·-rightCong (sym (rightInverse a)) ⟩
  b · (a · a ⁻¹) ≡⟨ sym (assoc b a (a ⁻¹)) ⟩
  b · a · a ⁻¹   ≡⟨ ·-leftCong h ⟩
  c · a · a ⁻¹   ≡⟨ assoc c a (a ⁻¹) ⟩
  c · (a · a ⁻¹) ≡⟨ ·-rightCong (rightInverse a) ⟩
  c · ε          ≡⟨ rightIdentity c ⟩
  c              ∎

-- Adapted from the Agda standard library 0.8.1 (see
-- Algebra.Properties.Group.right-helper).
y≡x⁻¹[xy] : ∀ a b → b ≡ a ⁻¹ · (a · b)
y≡x⁻¹[xy] a b = b              ≡⟨ sym (leftIdentity b) ⟩
                ε · b          ≡⟨ ·-leftCong (sym (leftInverse a)) ⟩
                a ⁻¹ · a · b   ≡⟨ assoc (a ⁻¹) a b ⟩
                a ⁻¹ · (a · b) ∎

-- Adapted from the Agda standard library 0.8.1 (see
-- Algebra.Properties.Group.left-helper).
x≡[xy]y⁻¹ : ∀ a b → a ≡ (a · b) · b ⁻¹
x≡[xy]y⁻¹ a b = a              ≡⟨ sym (rightIdentity a) ⟩
                a · ε          ≡⟨ ·-rightCong (sym (rightInverse b)) ⟩
                a · (b · b ⁻¹) ≡⟨ sym (assoc a b (b ⁻¹)) ⟩
                a · b · b ⁻¹   ∎

rightIdentityUnique : ∀ r → (∀ a → a · r ≡ a) → r ≡ ε
-- Paper proof (Mac Lane and Garret 1999. p. 48):
--
-- 1. r  = εr (ε is an identity)
-- 2. εr = r  (hypothesis)
-- 3. r  = ε  (transitivity)
rightIdentityUnique r h = trans (sym (leftIdentity r)) (h ε)

-- A more appropiate version to be used in the proofs. Adapted from
-- the Agda standard library 0.8.1 (see
-- Algebra.Properties.Group.right-identity-unique).
rightIdentityUnique' : ∀ a r → a · r ≡ a → r ≡ ε
rightIdentityUnique' a r h = r              ≡⟨ y≡x⁻¹[xy] a r ⟩
                             a ⁻¹ · (a · r) ≡⟨ ·-rightCong h ⟩
                             a ⁻¹ · a       ≡⟨ leftInverse a ⟩
                             ε              ∎

leftIdentityUnique : ∀ l → (∀ a → l · a ≡ a) → l ≡ ε
-- Paper proof:
-- 1. l  = le (ε is an identity)
-- 2. le = e  (hypothesis)
-- 3. l  = e  (transitivity)
leftIdentityUnique l h = trans (sym (rightIdentity l)) (h ε)

-- A more appropiate version to be used in the proofs. Adapted from
-- the Agda standard library 0.8.1 (see
-- Algebra.Properties.Group.left-identity-unique).
leftIdentityUnique' : ∀ a l → l · a ≡ a → l ≡ ε
leftIdentityUnique' a l h = l            ≡⟨ x≡[xy]y⁻¹ l a ⟩
                            l · a · a ⁻¹ ≡⟨ ·-leftCong h ⟩
                            a · a ⁻¹     ≡⟨ rightInverse a ⟩
                            ε            ∎

rightInverseUnique : ∀ {a} → ∃[ r ] (a · r ≡ ε) ∧
                                    (∀ r' → a · r' ≡ ε → r ≡ r')
rightInverseUnique {a} =
-- Paper proof:
--
-- 1.   We know that (a⁻¹) is a right inverse for a.
-- 2.   Let's suppose there is other right inverse r for a, i.e. ar ≡ ε, then
-- 2.1. aa⁻¹ = ε  (right-inverse axiom)
-- 2.2. ar   = ε  (hypothesis)
-- 2.3. aa⁻¹ = ar (transitivity)
-- 2.4  a⁻¹  = a  (left-cancellation)
  _ , rightInverse a , prf
    where
    prf : ∀ r' → a · r' ≡ ε → a ⁻¹ ≡ r'
    prf r' ar'≡ε = leftCancellation aa⁻¹≡ar'
      where
      aa⁻¹≡ar' : a · a ⁻¹ ≡ a · r'
      aa⁻¹≡ar' = a · a ⁻¹ ≡⟨ rightInverse a ⟩
                 ε        ≡⟨ sym ar'≡ε ⟩
                 a · r'   ∎

-- A more appropiate version to be used in the proofs.
rightInverseUnique' : ∀ {a r} → a · r ≡ ε → a ⁻¹ ≡ r
rightInverseUnique' {a} {r} ar≡ε = leftCancellation aa⁻¹≡ar
  where
  aa⁻¹≡ar : a · a ⁻¹ ≡ a · r
  aa⁻¹≡ar = a · a ⁻¹ ≡⟨ rightInverse a ⟩
            ε        ≡⟨ sym ar≡ε ⟩
            a · r    ∎

leftInverseUnique : ∀ {a} → ∃[ l ] (l · a ≡ ε) ∧
                                   (∀ l' → l' · a ≡ ε → l ≡ l')
leftInverseUnique {a} =
-- Paper proof:
--
-- 1.   We know that (a⁻¹) is a left inverse for a.
-- 2.   Let's suppose there is other right inverse l for a, i.e. la ≡ ε, then
-- 2.1. a⁻¹a = ε  (left-inverse axiom)
-- 2.2. la   = ε  (hypothesis)
-- 2.3. a⁻¹a = la (transitivity)
-- 2.4  a⁻¹  = l  (right-cancellation)
  _ , leftInverse a , prf
    where
    prf : ∀ l' → l' · a ≡ ε → a ⁻¹ ≡ l'
    prf l' l'a≡ε = rightCancellation a⁻¹a≡l'a
      where
      a⁻¹a≡l'a : a ⁻¹ · a ≡ l' · a
      a⁻¹a≡l'a = a ⁻¹ · a ≡⟨ leftInverse a ⟩
                 ε        ≡⟨ sym l'a≡ε ⟩
                 l' · a   ∎

-- A more appropiate version to be used in the proofs.
leftInverseUnique' : ∀ {a l} → l · a ≡ ε → a ⁻¹ ≡ l
leftInverseUnique' {a} {l} la≡ε = rightCancellation a⁻¹a≡la
  where
  a⁻¹a≡la : a ⁻¹ · a ≡ l · a
  a⁻¹a≡la = a ⁻¹ · a ≡⟨ leftInverse a ⟩
            ε        ≡⟨ sym la≡ε ⟩
            l · a    ∎

⁻¹-involutive : ∀ a → a ⁻¹ ⁻¹ ≡ a
-- Paper proof:
--
-- 1. a⁻¹a = ε  (left-inverse axiom)
-- 2. The previous equation states that a is the unique right
-- inverse (a⁻¹)⁻¹ of a⁻¹.
⁻¹-involutive a = rightInverseUnique' (leftInverse a)

identityInverse : ε ⁻¹ ≡ ε
-- Paper proof:
--
-- 1. εε = ε  (left/right-identity axiom)
-- 2. The previous equation states that ε is the unique left/right
-- inverse ε⁻¹ of ε.
identityInverse = rightInverseUnique' (leftIdentity ε)

inverseDistribution : ∀ a b → (a · b) ⁻¹ ≡ b ⁻¹ · a ⁻¹
-- Paper proof:
--
-- (b⁻¹a⁻¹)(ab) = b⁻¹(a⁻¹(ab)) (associative axiom)
--              = b⁻¹(a⁻¹a)b   (associative axiom)
--              = b⁻¹(εb)      (left-inverse axiom)
--              = b⁻¹b         (left-identity axiom)
--              = ε            (left-inverse axiom)
-- Therefore, b⁻¹a⁻¹ is the unique left inverse of ab.
inverseDistribution a b = leftInverseUnique' b⁻¹a⁻¹[ab]≡ε
  where
  b⁻¹a⁻¹[ab]≡ε : b ⁻¹ · a ⁻¹ · (a · b) ≡ ε
  b⁻¹a⁻¹[ab]≡ε =
    b ⁻¹ · a ⁻¹ · (a · b)
      ≡⟨ assoc (b ⁻¹) (a ⁻¹) (a · b) ⟩
    b ⁻¹ · (a ⁻¹ · (a · b))
      ≡⟨ ·-rightCong (sym (assoc (a ⁻¹) a b)) ⟩
    b ⁻¹ · (a ⁻¹ · a · b)
      ≡⟨ ·-rightCong (·-leftCong (leftInverse a)) ⟩
    b ⁻¹ · (ε · b)
      ≡⟨ ·-rightCong (leftIdentity b) ⟩
    b ⁻¹ · b
      ≡⟨ leftInverse b ⟩
    ε ∎

-- If the square of every element is the identity, the system is
-- commutative. From: TPTP 6.4.0 problem GRP/GRP001-2.p.
x²≡ε→comm : (∀ a → a · a ≡ ε) → ∀ {b c d} → b · c ≡ d → c · b ≡ d
-- Paper proof:
--
-- 1. d(bc)  = dd  (hypothesis bc = d)
-- 2. d(bc)  = ε   (hypothesis dd = ε)
-- 3. d(bc)c = c   (by 2)
-- 4. db(cc) = c   (associativity axiom)
-- 5. db     = c   (hypothesis cc = ε)
-- 6. (db)b  = cb  (by 5)
-- 7. d(bb)  = cb  (associativity axiom)
-- 6. d      = cb  (hypothesis bb = ε)
x²≡ε→comm h {b} {c} {d} bc≡d = sym d≡cb
  where
  db≡c : d · b ≡ c
  db≡c =
    d · b
      ≡⟨ sym (rightIdentity (d · b)) ⟩
    d · b · ε
      ≡⟨ ·-rightCong (sym (h c)) ⟩
    d · b · (c · c)
      ≡⟨ assoc d b (c · c) ⟩
    d · (b · (c · c))
      ≡⟨ ·-rightCong (sym (assoc b c c)) ⟩
    d · ((b · c) · c)
      ≡⟨ ·-rightCong (·-leftCong bc≡d) ⟩
    d · (d · c)
      ≡⟨ sym (assoc d d c) ⟩
    d · d · c
      ≡⟨ ·-leftCong (h d) ⟩
    ε · c
      ≡⟨ leftIdentity c ⟩
    c ∎

  d≡cb : d ≡ c · b
  d≡cb = d           ≡⟨ sym (rightIdentity d) ⟩
         d · ε       ≡⟨ ·-rightCong (sym (h b)) ⟩
         d · (b · b) ≡⟨ sym (assoc d b b) ⟩
         d · b · b   ≡⟨ ·-leftCong db≡c ⟩
         c · b       ∎

------------------------------------------------------------------------------
-- References
--
-- Mac Lane, S. and Birkhof, G. (1999). Algebra. 3rd ed. AMS Chelsea
-- Publishing.


module Data.List.Relation.Permutation where

import      Data
open import Data.Boolean
open import Data.List
open import Data.List.Functions renaming (module LongOper to List)
open import Data.List.Relation
open import Functional using (id ; _∘_ ; const)
open import Logic.Propositional
open import Logic
import      Lvl
open import Numeral.Finite
open import Syntax.Function
open import Type

private variable ℓ : Lvl.Level
private variable T A B : Type{ℓ}
private variable l l₁ l₂ l₃ l₄ : List(T)
private variable x y z : T
private variable f : A → B
private variable P : T → Bool

-- The relation for two lists that are permutations of each other.
-- This means that they contain the same elements and the same number of them but possibly in a different order.
-- Or in other words, the first list is a reordered list of the second.
data _permutes_ {ℓ} : List{ℓ}(T) → List{ℓ}(T) → Stmt{Lvl.𝐒(ℓ)} where
  empty   : ∅ permutes (∅ {T = T})
  prepend : (l₁ permutes l₂) → ((x ⊰ l₁) permutes (x ⊰ l₂))
  swap    : (x ⊰ y ⊰ l) permutes (y ⊰ x ⊰ l)
  trans   : (l₁ permutes l₂) → (l₂ permutes l₃) → (l₁ permutes l₃)

trans-swap : (l₁ permutes l₂) → ((x ⊰ y ⊰ l₁) permutes (y ⊰ x ⊰ l₂))
trans-swap p = trans swap (prepend (prepend p))

-- TODO
-- _partition-of_ : List(List(T)) → List(T) → Stmt
-- p partition-of l = (foldᵣ (x ↦ ¬ Empty(x) ∧_) Data.Unit p) ∧ (concat(p) permutes l)

-- The permutation as a function between the permutated elements' indices.
-- Example:
--   p : [a,b,c,d,e,f] permutes [a,f,e,d,b,c]
--   map(permutation-mapping(p)) [0,1,2,3,4,5] = [0,4,5,3,2,1]
permutation-mapping : (l₁ permutes l₂) → (𝕟(length(l₁)) → 𝕟(length(l₂)))
permutation-mapping empty                = id
permutation-mapping (prepend p) 𝟎        = 𝟎
permutation-mapping (prepend p) (𝐒 n)    = 𝐒(permutation-mapping p n)
permutation-mapping swap        𝟎        = 𝐒(𝟎)
permutation-mapping swap        (𝐒 𝟎)    = 𝟎
permutation-mapping swap        (𝐒(𝐒 n)) = 𝐒 (𝐒 n)
permutation-mapping (trans p q)          = permutation-mapping q ∘ permutation-mapping p

-- TODO: It should be possible to make (_permutes_) the morphism of a category with some correct notion of equivalence (maybe trans swap swap ≡ refl for example?). Then permutation-mapping would be an instance of Functor(length) for the ((_→_) on₂ 𝕟) category?

module Proofs where
  open import Data.List.Proofs
  open import Data.List.Equiv.Id
  open import Lang.Inspect
  open import Logic.Predicate
  open import Numeral.Natural
  open import Numeral.Finite.Proofs
  open import Relator.Equals
  open import Relator.Equals.Proofs
  open import Structure.Function.Domain
  open import Structure.Function.Domain.Proofs
  import      Structure.Function.Names as Names
  open import Structure.Function.Proofs
  open import Structure.Function
  import      Structure.Operator.Names as Names
  open import Structure.Operator.Properties
  open import Structure.Operator
  import      Structure.Relator.Names as Names
  open import Structure.Relator.Equivalence
  open import Structure.Relator.Properties
  open import Structure.Setoid using (Equiv)
  open import Syntax.Function
  open import Syntax.Transitivity

  instance
    permutes-reflexivity : Reflexivity(_permutes_ {T = T})
    permutes-reflexivity = intro proof where
      proof : Names.Reflexivity(_permutes_)
      proof {∅}     = empty
      proof {_ ⊰ _} = prepend proof

  instance
    permutes-symmetry : Symmetry(_permutes_ {T = T})
    permutes-symmetry = intro proof where
      proof : Names.Symmetry(_permutes_)
      proof empty       = empty
      proof (prepend p) = prepend (proof p)
      proof swap        = swap
      proof (trans p q) = trans (proof q) (proof p)

  instance
    permutes-transitivity : Transitivity(_permutes_ {T = T})
    permutes-transitivity = intro trans

  instance
    permutes-equivalence : Equivalence(_permutes_ {T = T})
    permutes-equivalence = intro

  permutes-equiv : Equiv(List(T))
  Equiv._≡_         permutes-equiv = _permutes_
  Equiv.equivalence permutes-equiv = permutes-equivalence

  -- If permutation relation had empty, prepend and trans-swap
  module _ where
    swap-from-trans-swap : (x ⊰ y ⊰ l) permutes (y ⊰ x ⊰ l)
    swap-from-trans-swap = trans-swap(reflexivity(_permutes_))

  PermutationMappingCorrectness : (l₁ l₂ : List(T)) → (𝕟(length(l₁)) → 𝕟(length(l₂))) → Stmt
  PermutationMappingCorrectness l₁ l₂ mapping = ∀{i} → (index l₁(i) ≡ index l₂(mapping i))

  permutation-mapping-correctness : (p : (l₁ permutes l₂)) → PermutationMappingCorrectness l₁ l₂ (permutation-mapping p)
  permutation-mapping-correctness empty                 = reflexivity(_≡_)
  permutation-mapping-correctness (prepend p) {𝟎}       = reflexivity(_≡_)
  permutation-mapping-correctness (prepend p) {𝐒 i}     = permutation-mapping-correctness p {i}
  permutation-mapping-correctness swap        {𝟎}       = reflexivity(_≡_)
  permutation-mapping-correctness swap        {𝐒 𝟎}     = reflexivity(_≡_)
  permutation-mapping-correctness swap        {𝐒 (𝐒 i)} = reflexivity(_≡_)
  permutation-mapping-correctness (trans p q)           = permutation-mapping-correctness p 🝖 permutation-mapping-correctness q

  instance
    permutation-mapping-injective : ∀{p : (l₁ permutes l₂)} → Injective(permutation-mapping p)
    permutation-mapping-injective {p = p} = intro(proof p) where
      proof : (p : (l₁ permutes l₂)) → Names.Injective(permutation-mapping p)
      proof (prepend p) {𝟎}   {𝟎}   eq = [≡]-intro
      proof (prepend p) {𝐒 x} {𝐒 y} eq = congruence₁(𝐒) (proof p (injective(𝐒) ⦃ [𝐒]-injective ⦄ eq))
      proof swap {𝟎}       {𝟎}       eq = [≡]-intro
      proof swap {𝟎}       {𝐒 (𝐒 y)} ()
      proof swap {𝐒 (𝐒 x)} {𝟎}       ()
      proof swap {𝐒 𝟎}     {𝐒 𝟎}     eq = [≡]-intro
      proof swap {𝐒 (𝐒 x)} {𝐒 (𝐒 y)} eq = eq
      proof (trans p q) = proof p ∘ proof q

  instance
    permutation-mapping-surjective : ∀{p : (l₁ permutes l₂)} → Surjective(permutation-mapping p)
    permutation-mapping-surjective {p = p} = intro(proof p) where
      proof : (p : (l₁ permutes l₂)) → Names.Surjective(permutation-mapping p)
      ∃.witness (proof p {y}) = permutation-mapping(symmetry(_permutes_) p) y
      ∃.proof (proof (prepend p) {𝟎})   = [≡]-intro
      ∃.proof (proof (prepend p) {𝐒 y}) = congruence₁(𝐒) (∃.proof (proof p {y}))
      ∃.proof (proof swap {𝟎})       = [≡]-intro
      ∃.proof (proof swap {𝐒 𝟎})     = [≡]-intro
      ∃.proof (proof swap {𝐒 (𝐒 y)}) = [≡]-intro
      ∃.proof (proof (trans p q) {y}) =
        permutation-mapping (trans p q) (∃.witness (proof (trans p q))) 🝖[ _≡_ ]-[]
        (permutation-mapping (trans p q) ∘ permutation-mapping(symmetry(_permutes_) p) ∘ permutation-mapping (symmetry(_permutes_) q)) y 🝖[ _≡_ ]-[]
        (permutation-mapping q ∘ permutation-mapping p ∘ permutation-mapping(symmetry(_permutes_) p) ∘ permutation-mapping (symmetry(_permutes_) q)) y 🝖[ _≡_ ]-[ congruence₁(permutation-mapping q) (∃.proof (proof p {_})) ]
        (permutation-mapping q ∘ permutation-mapping (symmetry(_permutes_) q)) y 🝖[ _≡_ ]-[ ∃.proof (proof q {y}) ]
        y 🝖[ _≡_ ]-end

  permutation-mapping-bijective : ∀{p : (l₁ permutes l₂)} → Bijective(permutation-mapping p)
  permutation-mapping-bijective {p = p} = injective-surjective-to-bijective(permutation-mapping p) ⦃ permutation-mapping-injective {p = p} ⦄ ⦃ permutation-mapping-surjective {p = p} ⦄

  {-
  permutation-from-mapping : (p : 𝕟(length(l₁)) → 𝕟(length(l₂))) ⦃ bij : Bijective(p) ⦄ (correctness : PermutationMappingCorrectness l₁ l₂ p) → (l₁ permutes l₂)
  permutation-from-mapping {l₁ = ∅} {l₂ = ∅} p _ = empty
  permutation-from-mapping {l₁ = ∅} {l₂ = x₂ ⊰ l₂} p _ = {!!}
  permutation-from-mapping {l₁ = x₁ ⊰ l₁} {l₂ = ∅} p _ = {!!}
  permutation-from-mapping {l₁ = x₁ ⊰ l₁} {l₂ = x₂ ⊰ l₂} p correctness with p(𝟎) | correctness{𝟎}
  ... | 𝟎   | [≡]-intro = prepend (permutation-from-mapping (forgetFirstCutoffOfBij p) ⦃ forgetFirstCutoffOfBij-bijective ⦄ {!!}) where
    bijective-equinumerous : ∀{a b}{f : 𝕟(a) → 𝕟(b)} → Bijective(f) → (a ≡ b)
    forgetFirstCutoff : ∀{a} → (𝕟(𝐒(a)) → 𝕟(𝐒(a))) → (𝕟(a) → 𝕟(a))
    forgetFirstCutoff {𝐒(a)} f(x) with f(𝐒(x))
    ... | 𝟎    = 𝟎
    ... | 𝐒(y) = y

    forgetFirstCutoffOfBij : ∀{a b} → (f : 𝕟(𝐒(a)) → 𝕟(𝐒(b))) ⦃ bij : Bijective(f) ⦄ → (𝕟(a) → 𝕟(b))
    forgetFirstCutoffOfBij {𝐒 a} f ⦃ bij ⦄ with [≡]-intro ← bijective-equinumerous bij = forgetFirstCutoff f
    forgetFirstCutoffOfBij-bijective : ∀{a b}{f : 𝕟(𝐒(a)) → 𝕟(𝐒(b))} ⦃ bij : Bijective(f) ⦄ → Bijective(forgetFirstCutoffOfBij f)

    -- proof : ∀{l₁ l₂ : List(T)}{p : 𝕟(length(l₁)) → 𝕟(length(l₂))} → PermutationMappingCorrectness l₁ l₂ (forgetFirstCutoffOfBij p)
    proof : PermutationMappingCorrectness l₁ l₂ (forgetFirstCutoffOfBij p)
    proof {i} =
      index l₁ i                            🝖[ _≡_ ]-[ {!correctness!} ]
      index l₂ (forgetFirstCutoffOfBij p i) 🝖-end
  ... | 𝐒 w | _ = {!!}
  -}

  permutes-prepend-function : Function ⦃ permutes-equiv ⦄ ⦃ permutes-equiv ⦄ (List.prepend x)
  permutes-prepend-function = intro prepend

  permutes-postpend-function : Function ⦃ permutes-equiv ⦄ ⦃ permutes-equiv ⦄ (postpend x)
  permutes-postpend-function = intro proof where
    proof : (l₁ permutes l₂) → (postpend x l₁) permutes (postpend x l₂)
    proof empty       = prepend empty
    proof (prepend x) = prepend (proof x)
    proof swap        = swap
    proof (trans x y) = trans (proof x) (proof y)

  postpend-prepend-permutes : (postpend x l) permutes (List.prepend x l)
  postpend-prepend-permutes {l = ∅} = prepend empty
  postpend-prepend-permutes {l = x ⊰ l} = trans (prepend postpend-prepend-permutes) swap

  permutes-reverse : (reverse l) permutes l
  permutes-reverse {l = ∅} = empty
  permutes-reverse {l = x ⊰ l} = trans (Function.congruence ⦃ _ ⦄ ⦃ _ ⦄ permutes-postpend-function(permutes-reverse {l = l})) postpend-prepend-permutes

  permutes-length-function : Function ⦃ permutes-equiv {T = T} ⦄ (length)
  permutes-length-function = intro proof where
    proof : (l₁ permutes l₂) → (length l₁ ≡ length l₂)
    proof empty       = [≡]-intro
    proof (prepend p) = congruence₁(𝐒) (proof p)
    proof swap        = [≡]-intro
    proof (trans p q) = transitivity(_≡_) (proof p) (proof q)

  permutes-countᵣ-function : Function ⦃ permutes-equiv ⦄ (count P)
  permutes-countᵣ-function = intro proof where
    proof : (l₁ permutes l₂) → (count P l₁ ≡ count P l₂)
    proof empty = [≡]-intro
    proof {l₁ = x₁ ⊰ l₁} {P = P} (prepend {x = x} p) with P(x)
    ... | 𝑇 = [≡]-with 𝐒(proof {l₁ = l₁} {P = P} p)
    ... | 𝐹 = proof {l₁ = l₁} {P = P} p
    proof {P = P} (swap {x = x} {y = y}) with P(x) | P(y)
    ... | 𝑇 | 𝑇 = [≡]-intro
    ... | 𝑇 | 𝐹 = [≡]-intro
    ... | 𝐹 | 𝑇 = [≡]-intro
    ... | 𝐹 | 𝐹 = [≡]-intro
    proof (trans p q) = proof p 🝖 proof q

  permutes-satisfiesAny-functionᵣ : Function ⦃ permutes-equiv ⦄ (satisfiesAny f)
  permutes-satisfiesAny-functionᵣ = intro proof where
    proof : (l₁ permutes l₂) → (satisfiesAny f l₁ ≡ satisfiesAny f l₂)
    proof empty = [≡]-intro
    proof {f = f} (prepend{x = x} p) with f(x)
    ... | 𝑇 = [≡]-intro
    ... | 𝐹 = proof p
    proof {l₁ = x ⊰ y ⊰ l₁}{y ⊰ x ⊰ l₂}{f = f} (swap{x = x}{y = y}) with f(x) | f(y) | inspect f(x) | inspect f(y)
    ... | 𝑇 | 𝑇 | intro _ | intro _ = [≡]-intro
    ... | 𝑇 | 𝐹 | intro _ | intro _ with 𝑇 ← f(x) = [≡]-intro
    ... | 𝐹 | 𝑇 | intro _ | intro _ with 𝑇 ← f(y) = [≡]-intro
    ... | 𝐹 | 𝐹 | intro _ | intro _ with 𝐹 ← f(x) | 𝐹 ← f(y)= reflexivity(_≡_)
    proof (trans p q) = proof p 🝖 proof q

  {- TODO
  permutes-countₗ : (∀{P} → count P l₁ ≡ count P l₂) → (l₁ permutes l₂)
  permutes-countₗ {l₁ = ∅} {l₂ = ∅} p = empty
  permutes-countₗ {l₁ = ∅} {l₂ = x ⊰ l₂} p with () ← p{const 𝑇}
  permutes-countₗ {l₁ = x ⊰ l₁} {l₂ = ∅} p with () ← p{const 𝑇}
  permutes-countₗ {l₁ = x ⊰ l₁} {l₂ = x₁ ⊰ l₂} p = {!!} -- TODO: The rest of the cases from _permutes_. Maybe decidable equality on the items are required?
  -}

  permutes-[++]-function : BinaryOperator ⦃ permutes-equiv ⦄ ⦃ permutes-equiv ⦄ ⦃ permutes-equiv ⦄ (_++_ {T = T})
  permutes-[++]-function = binaryOperator-from-function ⦃ _ ⦄ ⦃ _ ⦄ ⦃ _ ⦄ ⦃ \{l} → intro(R{l = l}) ⦄ ⦃ intro L ⦄ where
    L : Names.Congruence₁ ⦃ permutes-equiv ⦄ ⦃ permutes-equiv ⦄ (_++ l)
    L {l = l} empty = reflexivity(_permutes_)
    L {l = l} (prepend l12) = prepend (L {l = l} l12)
    L {l = l} swap = swap
    L {l = l} (trans l13 l32) = transitivity(_permutes_) (L {l = l} l13) (L {l = l} l32)

    R : Names.Congruence₁ ⦃ permutes-equiv ⦄ ⦃ permutes-equiv ⦄ (l ++_)
    R {l = ∅}     l12 = l12
    R {l = x ⊰ l} l12 = prepend (R {l = l} l12)

  permutes-[++]-commutativity : Commutativity ⦃ permutes-equiv {T = T} ⦄ (_++_)
  permutes-[++]-commutativity = intro(\{l₁}{l₂} → proof{l₁}{l₂}) where
    proof : Names.Commutativity ⦃ permutes-equiv ⦄ (_++_)
    proof {∅}      {l₂} rewrite identityᵣ(_++_)(∅) {l₂} = reflexivity(_permutes_)
    proof {x ⊰ l₁} {l₂} =
      (x ⊰ l₁) ++ l₂        🝖[ _permutes_ ]-[]
      x ⊰ (l₁ ++ l₂)        🝖[ _permutes_ ]-[ prepend (proof {l₁} {l₂}) ]
      x ⊰ (l₂ ++ l₁)        🝖[ _permutes_ ]-[]
      (x ⊰ l₂) ++ l₁        🝖[ _permutes_ ]-[ BinaryOperator.congruence ⦃ _ ⦄ ⦃ _ ⦄ ⦃ _ ⦄ permutes-[++]-function (postpend-prepend-permutes {l = l₂}) (reflexivity(_permutes_)) ]-sym
      (postpend x l₂) ++ l₁ 🝖[ _permutes_ ]-[ sub₂(_≡_)(_permutes_) ([++]-middle-prepend-postpend {l₁ = l₂}{l₂ = l₁}) ]
      l₂ ++ (x ⊰ l₁)        🝖[ _permutes_ ]-end

  permutes-empty-not-empty : ¬(∅ permutes (x ⊰ l))
  permutes-empty-not-empty (trans {l₂ = ∅}     p q) = permutes-empty-not-empty q
  permutes-empty-not-empty (trans {l₂ = _ ⊰ _} p q) = permutes-empty-not-empty p

  permutes-map : ∀{f : A → B} → Function ⦃ permutes-equiv ⦄ ⦃ permutes-equiv ⦄ (map f)
  permutes-map {f = f} = intro proof where
    proof : Names.Congruence₁ ⦃ permutes-equiv ⦄ ⦃ permutes-equiv ⦄ (map f)
    proof empty       = empty
    proof (prepend p) = prepend (proof p)
    proof swap        = swap
    proof (trans p q) = trans(proof p) (proof q)

  permutes-on-empty : (l permutes ∅) → (l ≡ ∅)
  permutes-on-empty empty = [≡]-intro
  permutes-on-empty (trans p q)
    rewrite permutes-on-empty q
    rewrite permutes-on-empty p
    = [≡]-intro

  permutes-on-singleton : (l permutes (singleton x)) → (l ≡ singleton x)
  permutes-on-singleton (prepend empty) = [≡]-intro
  permutes-on-singleton (prepend (trans p q))
    rewrite permutes-on-empty q
    rewrite permutes-on-empty p
    = [≡]-intro
  permutes-on-singleton (trans p q)
    rewrite permutes-on-singleton q
    rewrite permutes-on-singleton p
    = [≡]-intro

  permutes-insertIn : ∀{n} → ((insertIn x l n) permutes (x ⊰ l))
  permutes-insertIn {n = 𝟎}               = reflexivity(_permutes_)
  permutes-insertIn {l = x ⊰ l} {n = 𝐒 n} = trans (prepend (permutes-insertIn {n = n})) swap

module InsertionPermutation where
  data _insertion-permutes_ {ℓ} : List{ℓ}(T) → List{ℓ}(T) → Stmt{Lvl.𝐒(ℓ)} where
    empty : ∅ insertion-permutes (∅ {T = T})
    ins : (n : 𝕟₌(length l₁)) → (l₁ insertion-permutes l₂) → ((insertIn x l₁ n) insertion-permutes (x ⊰ l₂))

  open import Data.List.Proofs.Length
  open import Relator.Equals.Proofs
  open import Structure.Relator

  insertion-permutation-mapping : (l₁ insertion-permutes l₂) → (𝕟(length(l₁)) → 𝕟(length(l₂)))
  insertion-permutation-mapping empty              ()
  insertion-permutation-mapping (ins 𝟎 p)          𝟎              = 𝟎
  insertion-permutation-mapping (ins 𝟎 p)          (𝐒 i)          = 𝐒(insertion-permutation-mapping p i)
  insertion-permutation-mapping (ins {l₁ = x ⊰ l₁} (𝐒 n) p) 𝟎     = 𝟎
  insertion-permutation-mapping (ins {l₁ = x ⊰ l₁} (𝐒 n) p) (𝐒 i) = 𝐒(insertion-permutation-mapping p (substitute₁(𝕟) (length-insertIn {l = l₁} {n = n}) i))

  open import Data using ()
  open import Numeral.Natural
  open import Relator.Equals
  open import Syntax.Number

  insertion-permutes-prepend : (l₁ insertion-permutes l₂) → ((x ⊰ l₁) insertion-permutes (x ⊰ l₂))
  insertion-permutes-prepend p = ins 𝟎 p

  insertion-permutes-refl : l insertion-permutes l
  insertion-permutes-refl {l = ∅} = empty
  insertion-permutes-refl {l = x ⊰ l} = insertion-permutes-prepend insertion-permutes-refl

  insertion-permutes-swap : (x ⊰ y ⊰ l) insertion-permutes (y ⊰ x ⊰ l)
  insertion-permutes-swap = ins 1 (insertion-permutes-prepend insertion-permutes-refl)

  insertion-permutes-to-permutes : (l₁ insertion-permutes l₂) → (l₁ permutes l₂)
  insertion-permutes-to-permutes empty     = empty
  insertion-permutes-to-permutes (ins n p) = trans Proofs.permutes-insertIn (prepend (insertion-permutes-to-permutes p))

  insertion-permutes-flipped-ins : ∀{n} → (l₁ insertion-permutes l₂) → ((x ⊰  l₁) insertion-permutes (insertIn x l₂ n))
  insertion-permutes-flipped-ins {n = 𝟎}   empty      = insertion-permutes-refl
  insertion-permutes-flipped-ins {n = 𝟎}   (ins k p)  = insertion-permutes-prepend (ins k p)
  insertion-permutes-flipped-ins {n = 𝐒 n} (ins k p) = ins (𝐒 k) (insertion-permutes-flipped-ins {n = n} p)

  insertion-permutes-sym : (l₁ insertion-permutes l₂) → (l₂ insertion-permutes l₁)
  insertion-permutes-sym empty = empty
  insertion-permutes-sym (ins n p) = insertion-permutes-flipped-ins(insertion-permutes-sym p)

  {-
  insertion-permutes-trans : (l₁ insertion-permutes l₂) → (l₃ insertion-permutes l₂) → (l₁ insertion-permutes l₃)
  ins2 : ∀{n₁ n₂} → (l₁ insertion-permutes l₂) → ((insertIn x l₁ n₁) insertion-permutes (insertIn x l₂ n₂))

  ins2 {l₁ = l₁} {l₂} {n₁ = n₁} {𝟎} p = ins n₁ p
  ins2 {l₁ = .(insertIn x _ n)} {x ⊰ l₂} {n₁ = 𝟎} {𝐒 n₂} (ins n p) = insertion-permutes-trans (insertion-permutes-prepend (ins n p)) (ins(𝐒 n₂) insertion-permutes-refl)
  ins2 {l₁ = .(insertIn x _ n)} {x ⊰ l₂} {n₁ = 𝐒 n₁} {𝐒 n₂} (ins n p) = {!!}

  insertion-permutes-trans empty     empty     = empty
  insertion-permutes-trans (ins m p) (ins n q) = {!!}
  -- ins2(insertion-permutes-trans p q)
  -}

  {-
  insertion-permutation-mapping-correctness : (p : (l₁ insertion-permutes l₂)) → Proofs.PermutationMappingCorrectness l₁ l₂ (insertion-permutation-mapping p)
  insertion-permutation-mapping-correctness (ins {l₁ = ∅} 𝟎 p) {𝟎} = [≡]-intro
  insertion-permutation-mapping-correctness (ins {l₁ = x ⊰ l₁} 𝟎 p) {𝟎} = [≡]-intro
  insertion-permutation-mapping-correctness (ins {l₁ = x ⊰ l₁} 𝟎 p) {𝐒 i} = insertion-permutation-mapping-correctness p
  insertion-permutation-mapping-correctness (ins {l₁ = x ⊰ l₁} (𝐒 n) p) {𝟎} = {!!}
  insertion-permutation-mapping-correctness (ins {l₁ = x ⊰ l₁} (𝐒 n) p) {𝐒 i} = {!!}
  -}

  -- test : (p : (l₁ insertion-permutes l₂)) → (∀{i} → (index l₁(insertion-permutation-mapping p i) ≡ index l₂(i)))
  -- test p = ?

  {-
  open import Data.Boolean.Stmt
  open import Numeral.Finite.Oper.Comparisons
  test : ∀{l : List(T)}{n₁ : 𝕟(𝐒(length l))}{n₂ : 𝕟(𝐒(length (insertIn y l n₁)))} → IsTrue(n₁ >? n₂) → (insertIn y (insertIn x l n₁) n₂ ≡ insertIn x (insertIn y l n₁) n₂)
  test p = {!!}
  -}

  {-
  ins2 : ∀{n₁ n₂} → (l₁ insertion-permutes l₂) → ((insertIn x l₁ n₁) insertion-permutes (insertIn x l₂ n₂))
  ins2 {n₁ = 𝟎} {𝟎} empty = insertion-permutes-refl
  ins2 {n₁ = n₁} {𝟎} (ins n p) = ins n₁ (ins n p)
  ins2 {x = x} {n₁ = n₁} {𝐒 n₂} (ins {x = y} n p) = {!(ins2 {x = x}{n₁ = n}{n₂ = n₂} p)!}

  insertion-permutes-trans : (l₁ insertion-permutes l₂) → (l₃ insertion-permutes l₂) → (l₁ insertion-permutes l₃)
  insertion-permutes-trans empty empty = empty
  insertion-permutes-trans (ins m p) (ins n q) = {!!}
  -}

  {-
  test : ∀{n} → (l₁ insertion-permutes (y ⊰ insertIn x l₂ n)) → (l₁ insertion-permutes (x ⊰ insertIn y l₂ n))
  test {l₂ = l₂} (ins {l₁ = l₁} n p) = {!!}

  ins2 : ∀{n₁ n₂} → (l₁ insertion-permutes l₂) → ((insertIn x l₁ n₁) insertion-permutes (insertIn x l₂ n₂))
  ins2 {n₁ = n₁} {𝟎} p = ins n₁ p
  ins2 {n₁ = n₁} {𝐒 n₂} (ins {x = x} n p) = test(ins n₁ (ins2{x = x}{n}{n₂} p))

  -- insertIn x₁ (insertIn x l₁ n) n₁
  -- x ⊰ insertIn x₁ l₂ n₂

  tr : (l₁ insertion-permutes l₂) → (l₃ insertion-permutes l₂) → (l₁ insertion-permutes l₃)
  tr {l₂ = ∅}       empty      empty      = empty
  tr {l₂ = x₂ ⊰ l₂} (ins n₁ p) (ins n₂ q) = ins2(tr p q)

  sym : (l₁ insertion-permutes l₂) → (l₂ insertion-permutes l₁)
  sym = tr insertion-permutes-refl
  -}


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

open import LogicalFormulae
open import Numbers.Naturals.Semiring
open import Numbers.Naturals.Naturals
open import Numbers.Naturals.Order
open import Numbers.Naturals.Order.Lemmas
open import Numbers.Naturals.Order.WellFounded
open import Orders.WellFounded.Induction
open import Orders.Total.Definition
open import Semirings.Definition

module Numbers.Naturals.Division where

open import Numbers.Naturals.EuclideanAlgorithm public using (_∣_ ; zeroDividesNothing ; divisionAlgResult ; divides ; biggerThanCantDivide ; aDivA ; aDivZero ; divEquality ; oneDivN ; dividesBothImpliesDividesSum ; dividesBothImpliesDividesDifference)

divOneImpliesOne : {a : ℕ} → a ∣ 1 → a ≡ 1
divOneImpliesOne {zero} a|1 = exFalso (zeroDividesNothing _ a|1)
divOneImpliesOne {succ zero} a|1 = refl
divOneImpliesOne {succ (succ a)} (divides record { quot = zero ; rem = .0 ; pr = pr ; remIsSmall = remIsSmall ; quotSmall = quotSmall } refl) rewrite Semiring.sumZeroRight ℕSemiring (a *N zero) | multiplicationNIsCommutative a 0 = exFalso (naughtE pr)
divOneImpliesOne {succ (succ a)} (divides record { quot = (succ quot) ; rem = .0 ; pr = pr ; remIsSmall = remIsSmall ; quotSmall = quotSmall } refl) rewrite Semiring.commutative ℕSemiring quot (succ (quot +N a *N succ quot)) = exFalso (naughtE (equalityCommutative (succInjective pr)))


open import Relation.Binary.Core

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

open import BBSTree _≤_
open import Bound.Total A
open import Bound.Total.Order _≤_
open import Data.List
open import Data.Sum

insert : {x : A}{b t : Bound} → LeB b (val x) → LeB (val x) t → BBSTree b t → BBSTree b t
insert b≤x x≤t (bslf _) = bsnd b≤x x≤t (bslf b≤x) (bslf x≤t)
insert {x = x} b≤x x≤t (bsnd {x = y} b≤y y≤t l r)
    with tot≤ x y
... | inj₁ x≤y = bsnd b≤y y≤t (insert b≤x (lexy x≤y) l) r
... | inj₂ y≤x = bsnd b≤y y≤t l (insert (lexy y≤x) x≤t r)

treeSort : List A → BBSTree bot top
treeSort [] = bslf lebx
treeSort (x ∷ xs) = insert {x = x} lebx lext (treeSort xs)


module +-mono-< where

open import Data.Nat using (ℕ; zero; suc; _+_)
open import Data.Nat.Properties using (+-comm)

open import Relations using (_<_; z<s; s<s)
open import <-trans using (<-trans)

+-monoʳ-< : ∀ (n p q : ℕ)
  → p < q
    -------------
  → n + p < n + q
+-monoʳ-< zero    p q p<q = p<q
+-monoʳ-< (suc n) p q p<q = s<s (+-monoʳ-< n p q p<q)

+-monoˡ-< : ∀ (m n p : ℕ)
  → m < n
    -------------
  → m + p < n + p
+-monoˡ-< m n p m<n rewrite +-comm m p | +-comm n p = +-monoʳ-< p m n m<n

+-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 n p m<n) (+-monoʳ-< n p q p<q)


{-

          Types Summer School 2007

                 Bertinoro
             Aug 19 - 31, 2007

                   Agda

                Ulf Norell

-}

module Parity where

open import Nat

-- Parity n tells us whether n is even or odd.

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

-- Every number is either even or odd.

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

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


module Auto.Prelude where

open import Agda.Primitive public
  using    (Level)

data ⊥ : Set where

¬ : Set → Set
¬ A = A → ⊥

⊥-e : (A : Set) → ⊥ → A
⊥-e A ()

record ⊤ : Set where

record _∧_ (A B : Set) : Set where
 constructor ∧-i
 field fst : A
       snd : B

data _∨_ (A B : Set) : Set where
 ∨-i₁ : A → A ∨ B
 ∨-i₂ : B → A ∨ B

∨-e : (A B C : Set) → A ∨ B → (A → C) → (B → C) → C
∨-e A B C (∨-i₁ x) h₁ h₂ = h₁ x
∨-e A B C (∨-i₂ x) h₁ h₂ = h₂ x

data Π (A : Set) (F : A → Set) : Set where
  fun : ((a : A) → F a) → Π A F

record Σ (X : Set) (P : X → Set) : Set where
 constructor Σ-i
 field wit : X
       prf : P wit

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

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

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

data List (X : Set) : Set where
  []  : List X
  _∷_ : X → List X → List X

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

data Vec (X : Set) : ℕ → Set where
  []  : Vec X zero
  _∷_ : ∀ {n} → X → Vec X n → Vec X (succ n)

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

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

subst : {i j : Level} {X : Set i} → (P : X → Set j) → (x y : X) → y ≡ x → P x → P y
subst P x .x refl h = h

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

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

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

data _IsRelatedTo_ {a : Level} {Carrier : Set a} (x y : Carrier) : Set a where
  relTo : (x∼y : x ≡ y) → x IsRelatedTo y

begin_ : {a : Level} {Carrier : Set a} → {x y : Carrier} → x IsRelatedTo y → x ≡ y
begin relTo x∼y = x∼y

_∎ : {a : Level} {Carrier : Set a} → (x : Carrier) → x IsRelatedTo x
_∎ _ = relTo refl

_≡⟨_⟩_ : {a : Level} {Carrier : Set a} → (x : Carrier) {y z : Carrier} → x ≡ y → y IsRelatedTo z → x IsRelatedTo z
_ ≡⟨ x∼y ⟩ relTo y∼z = relTo (trans x∼y y∼z)

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


{-# OPTIONS --exact-split #-}

-- The --exact-split flag causes Agda to raise an error whenever
-- a clause in a definition by pattern matching cannot be made to
-- hold definitionally (i.e. as a reduction rule). Specific clauses
-- can be excluded from this check by means of the {-# CATCHALL #-}
-- pragma.

module ExactSplit where

data Bool : Set where
  true false : Bool

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

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

eq : ℕ → ℕ → Bool
eq zero    zero    = true
eq (suc m) (suc n) = eq m n
{-# CATCHALL #-}
eq _       _       = false

-- See also fail/ExactSplitMin.agda
min : ℕ → ℕ → ℕ
min zero    y       = zero
{-# CATCHALL #-}
min x       zero    = zero
min (suc x) (suc y) = suc (min x y)

-- See also fail/ExactSplitBerry.agda
maj : Bool → Bool → Bool → Bool
maj true  true  true  = true
{-# CATCHALL #-}
maj x     true  false = x
{-# CATCHALL #-}
maj false y     true  = y
maj true  false z     = z
maj false false false = false

-- See also fail/ExactSplitParity.agda
parity : ℕ → ℕ → Bool
parity zero          zero          = true
parity zero          (suc zero)    = false
parity zero          (suc (suc n)) = parity zero n
parity (suc zero)    zero          = false
parity (suc (suc m)) zero          = parity m zero
{-# CATCHALL #-}
parity (suc m)       (suc n)       = parity m n


module foldr-++ where

import Relation.Binary.PropositionalEquality as Eq
open Eq using (_≡_; cong)
open Eq.≡-Reasoning
open import lists using (List; _∷_; []; _++_; foldr)

-- 結合したリストの重畳は、重畳した結果を初期値とした重畳と等しいことの証明
foldr-++ : ∀ {A B : Set} → (_⊗_ : A → B → B) → (e : B) → (xs ys : List A)
  → foldr _⊗_ e (xs ++ ys) ≡ foldr _⊗_ (foldr _⊗_ e ys) xs
foldr-++ _⊗_ e [] ys =
  begin
    foldr _⊗_ e ([] ++ ys)
  ≡⟨⟩
    foldr _⊗_ e ys
  ≡⟨⟩
    foldr _⊗_ (foldr _⊗_ e ys) []
  ∎
foldr-++ _⊗_ e (x ∷ xs) ys =
  begin
    foldr _⊗_ e ((x ∷ xs) ++ ys)
  ≡⟨⟩
    x ⊗ (foldr _⊗_ e (xs ++ ys))
  ≡⟨ cong (x ⊗_) (foldr-++ _⊗_ e xs ys) ⟩
    x ⊗ (foldr _⊗_ (foldr _⊗_ e ys) xs)
  ≡⟨⟩
    foldr _⊗_ (foldr _⊗_ e ys) (x ∷ xs)
  ∎


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

open import library.Basics hiding (Type ; Σ)
open import library.types.Sigma
open import library.types.Bool

open import Sec2preliminaries
open import Sec4hasConstToSplit

module Sec6hasConstToDecEq where

-- Lemma 6.1
hasConst-family-dec : {X : Type} → (x₁ x₂ : X) → ((x : X) → hasConst ((x₁ == x) + (x₂ == x))) → (x₁ == x₂) + ¬(x₁ == x₂)
hasConst-family-dec {X} x₁ x₂ hasConst-fam = solution where
  f₋ : (x : X) → (x₁ == x) + (x₂ == x) → (x₁ == x) + (x₂ == x)
  f₋ x = fst (hasConst-fam x)

  E₋ : X → Type
  E₋ x = fix (f₋ x)

  E : Type
  E = Σ X λ x → (E₋ x)

  E-fst-determines-eq : (e₁ e₂ : E) → (fst e₁ == fst e₂) → e₁ == e₂
  E-fst-determines-eq e₁ e₂ p = second-comp-triv (λ x → fixed-point (f₋ x) (snd (hasConst-fam x))) _ _ p

  r : Bool → E
  r true = x₁ , to-fix (f₋ x₁) (snd (hasConst-fam x₁)) (inl idp)
  r false = x₂ , to-fix (f₋ x₂) (snd (hasConst-fam x₂)) (inr idp)

  about-r : (r true == r false) ↔ (x₁ == x₂)
  about-r = (λ p → ap fst p) , (λ p → E-fst-determines-eq _ _ p)

  s : E → Bool
  s (_ , inl _ , _) = true
  s (_ , inr _ , _) = false

  s-section-of-r : (e : E) → r(s e) == e
  s-section-of-r (x , inl p , q) = E-fst-determines-eq _ _ p
  s-section-of-r (x , inr p , q) = E-fst-determines-eq _ _ p

  about-s : (e₁ e₂ : E) → (s e₁ == s e₂) ↔ (e₁ == e₂)
  about-s e₁ e₂ = one , two where
    one : (s e₁ == s e₂) → (e₁ == e₂)
    one p =
      e₁       =⟨ ! (s-section-of-r e₁) ⟩
      r(s(e₁)) =⟨ ap r p ⟩
      r(s(e₂)) =⟨ s-section-of-r e₂ ⟩
      e₂       ∎
    two : (e₁ == e₂) → (s e₁ == s e₂)
    two p = ap s p

  combine : (s (r true) == s (r false)) ↔ (x₁ == x₂)
  combine = (about-s _ _) ◎ about-r

  check-bool : (s (r true) == s (r false)) + ¬(s (r true) == s (r false))
  check-bool = Bool-has-dec-eq _ _

  solution : (x₁ == x₂) + ¬(x₁ == x₂)
  solution with check-bool
  solution | inl p = inl (fst combine p)
  solution | inr np = inr (λ p → np (snd combine p))

-- Theorem 6.2
all-hasConst→dec-eq : ((X : Type) → hasConst X) → (X : Type) → has-dec-eq X
all-hasConst→dec-eq all-hasConst X x₁ x₂ = hasConst-family-dec x₁ x₂ (λ x → all-hasConst _)


------------------------------------------------------------------------
-- The Agda standard library
--
-- Properties of functions, such as associativity and commutativity
------------------------------------------------------------------------

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

open import Level
open import Relation.Binary

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

module Algebra.FunctionProperties
         {a ℓ} {A : Set 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


module EqTest where

import Common.Level

data _≡_ {a : Set} (x : a) : a -> Set where
  refl : x ≡ x

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

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

_≟_ : (x y : ℕ) -> Maybe (x ≡ y)
suc m  ≟ suc n with m ≟ n
suc .n ≟ suc n |    just refl = just refl
suc m  ≟ suc n |    nothing   = nothing
zero   ≟ suc _ = nothing
suc m  ≟ zero  = nothing
zero   ≟ zero  = just refl


module nat where

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

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

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


{-# OPTIONS --allow-unsolved-metas #-}

open import Tutorials.Monday-Complete
module Tutorials.Tuesday where

-----------
-- Pi and Sigma types
-----------

module Product where
  -- The open keyword opens a given module in the current namespace
  -- By default all of the public names of the module are opened
  -- The using keyword limits the imported definitions to those explicitly listed
  open Fin
  open Vec using (Vec; []; _∷_)
  open Simple using (¬_)

  variable
    P Q : A → Set

  -- Pi types: dependent function types
  -- For every x of type A, the predicate P x holds
  Π : (A : Set) → (Pred A) → Set
  Π A P = (x : A) → P x

  infix 5 _,_
  -- Sigma types: dependent product types, existential types
  -- For this x of type A, the predicate P x holds
  record Σ (A : Set) (P : Pred A) : Set where
    -- In the type P fst, fst refers to a previously introduced field
    constructor _,_
    field
      fst : A
      snd : P fst

  open Σ public

  -- By depending on a boolean we can use pi types to represent product types
  Π-× : Set → Set → Set
  Π-× A B = Π Bool λ where
    true  → A
    false → B

  -- By depending on a boolean we can use sigma types to represent sum types
  Σ-⊎ : Set → Set → Set
  Σ-⊎ A B = Σ Bool λ where
    true  → A
    false → B

  -- Use pi types to recover function types
  Π-→ : Set → Set → Set
  Π-→ A B = Π A λ where
    _     → B

  -- Use sigma types to recover product types
  Σ-× : Set → Set → Set
  Σ-× A B = Σ A λ where
    _     → B

  infix 5 _×_
  _×_ : Set → Set → Set
  _×_ = Σ-×

  -- 1) If we can transform the witness and
  -- 2) transform the predicate as per the transformation on the witness
  -- ⇒) then we can transform a sigma type
  map : (f : A → B) → (∀ {x} → P x → Q (f x)) → (Σ A P → Σ B Q)
  map f g (x , y) = (f x , g y)

  -- The syntax keyword introduces notation that can include binders
  infix 4 Σ-syntax
  Σ-syntax : (A : Set) → (A → Set) → Set
  Σ-syntax = Σ
  syntax Σ-syntax A (λ x → B) = Σ[ x ∈ A ] B

  ¬∘ : Pred A → Pred A
  ¬∘ P = ¬_ ∘ P

  -- These can be proven regardless of A

  ¬∃⇒∀¬ : ¬ (Σ A P) → Π A (¬∘ P)
  ¬∃⇒∀¬ = {!!}

  ∃¬⇒¬∀ : Σ A (¬∘ P) → ¬ Π A P
  ∃¬⇒¬∀ = {!!}

  ∀¬⇒¬∃ : Π A (¬∘ P) → ¬ Σ A P
  ∀¬⇒¬∃ = {!!}

  -- Works in classical, not in constructive mathematics
  postulate ¬∀⇒∃¬ : ¬ Π A P → Σ A (¬∘ P)

  -- Show that ≤ is antisymmetric
  ≤-≡ : n ≤ m → m ≤ n → n ≡ m
  ≤-≡ x y = {!!}

  -- By using n ≤ m instead of Fin m we can mention n in the output
  take : Vec A m → n ≤ m → Vec A n
  take xs lte = {!!}

  Fin-to-≤ : (i : Fin m) → to-ℕ i < m
  Fin-to-≤ i = {!!}

  -- Proof combining sigma types and equality
  ≤-to-Fin : n < m → Fin m
  ≤-to-Fin lt = {!!}

  Fin-≤-inv : (i : Fin m) → ≤-to-Fin (Fin-to-≤ i) ≡ i
  Fin-≤-inv i = {!!}

  ≤-Fin-inv : (lt : Σ[ n ∈ ℕ ] n < m)
            → (to-ℕ (≤-to-Fin (snd lt)) , Fin-to-≤ (≤-to-Fin (snd lt))) ≡ lt
  ≤-Fin-inv lt = {!!}


module reverse-++-distrib where

import Relation.Binary.PropositionalEquality as Eq
open Eq using (_≡_; refl; sym; cong)
open Eq.≡-Reasoning
open import lists using (List; []; _∷_; [_]; _++_; ++-assoc; ++-identityʳ; reverse)

-- 結合したリストの逆順は、逆順にしたリストの逆順の結合と等しいことの証明
reverse-++-distrib : ∀ {A : Set} → (xs ys : List A)
  → reverse (xs ++ ys) ≡ reverse ys ++ reverse xs
reverse-++-distrib [] ys =
  begin
    reverse ([] ++ ys)
  ≡⟨⟩
    reverse ys
  ≡⟨ sym (++-identityʳ (reverse ys)) ⟩
    reverse ys ++ []
  ≡⟨⟩
    reverse ys ++ reverse []
  ∎
reverse-++-distrib (x ∷ xs) ys =
  begin
    reverse (x ∷ xs ++ ys)
  ≡⟨⟩
    reverse (xs ++ ys) ++ [ x ]
  ≡⟨ cong (_++ [ x ]) (reverse-++-distrib xs ys) ⟩
    (reverse ys ++ reverse xs) ++ [ x ]
  ≡⟨ ++-assoc (reverse ys) (reverse xs) [ x ] ⟩
    reverse ys ++ (reverse xs ++ [ x ])
  ≡⟨⟩
    reverse ys ++ reverse (x ∷ xs)
  ∎


{-# OPTIONS --safe #-}
module Cubical.Algebra.Monoid.Instances.NatVec where

open import Cubical.Foundations.Prelude

open import Cubical.Data.Nat using (ℕ ; isSetℕ)
open import Cubical.Data.Vec
open import Cubical.Data.Vec.OperationsNat

open import Cubical.Algebra.Monoid

NatVecMonoid : (n : ℕ) → Monoid ℓ-zero
fst (NatVecMonoid n) = Vec ℕ n
MonoidStr.ε (snd (NatVecMonoid n)) = replicate 0
MonoidStr._·_ (snd (NatVecMonoid n)) = _+n-vec_
MonoidStr.isMonoid (snd (NatVecMonoid n)) = makeIsMonoid (VecPath.isOfHLevelVec 0 n isSetℕ)
                                                       +n-vec-assoc +n-vec-rid +n-vec-lid


{-# OPTIONS --type-in-type #-}  -- yes, I will let you cheat in this exercise
{-# OPTIONS --allow-unsolved-metas #-}  -- allows import, unfinished

------------------------------------------------------------------------------
------------------------------------------------------------------------------
-- CS410 2017/18 Exercise 3  WINDOWS AND OTHER STORIES (worth 25%)
------------------------------------------------------------------------------
------------------------------------------------------------------------------

------------------------------------------------------------------------------
-- Dependencies
------------------------------------------------------------------------------

open import CS410-Prelude
open import CS410-Categories
open import Ex2

------------------------------------------------------------------------------
--  PART I:  Splittings
------------------------------------------------------------------------------

-- The type    ls <[ ms ]> rs
-- is similar to that found in Lec2.agda, but it works on lists, not numbers.
-- It provides the evidence that a list ms can be split into a left sublist ls
-- and a right sublist rs. In effect, it's a vector of bits that say which
-- elements of ms go left and which go right.

data _<[_]>_ {X : Set} : List X -> List X -> List X -> Set where
  sz : [] <[ [] ]> []
  sl : forall {l ls ms rs} -> ls <[ ms ]> rs -> (l ,- ls) <[ l ,- ms ]> rs
  sr : forall {r ls ms rs} -> ls <[ ms ]> rs -> ls <[ r ,- ms ]> (r ,- rs)

--??--3.1---------------------------------------------------------------------

-- Adapt _>[_]<_ from Lec2 to work for All. Given a P for each element of
-- ls and rs, riffle them together to get Ps for all the ms.

_>[_]<_ : {X : Set}{ls ms rs : List X} -> {P : X -> Set} ->
          All P ls -> ls <[ ms ]> rs -> All P rs ->
          All P ms
pl >[ s ]< pr = {!!}

-- Now, buikd the view that shows riffling can be inverted, using a splitting
-- as the instructions to discover how to split an All in two.

data IsRiffle {X : Set}{ls ms rs : List X}(s : ls <[ ms ]> rs){P : X -> Set}
  : All P ms -> Set where
  mkRiffle : (pl : All P ls)(pr : All P rs) -> IsRiffle s (pl >[ s ]< pr)

isRiffle : {X : Set}{ls ms rs : List X}(s : ls <[ ms ]> rs)
           {P : X -> Set}(pm : All P ms) -> IsRiffle s pm
isRiffle s pm = {!!}

--??--------------------------------------------------------------------------

--??--3.2---------------------------------------------------------------------

-- Construct the "all on the right" splitting.

srs : forall {X : Set}{xs : List X} -> [] <[ xs ]> xs
srs = {!!}

-- Construct a view to show that any "none on the left" splitting is
-- "all on the right". Come up with the type yourself.

-- Construct the splitting that corresponds to concatenation.

slrs : forall {X : Set}(xs ys : List X) -> xs <[ xs +L ys ]> ys
slrs xs ys = {!!}

--??--------------------------------------------------------------------------

--??--3.3---------------------------------------------------------------------

-- Invent other useful operations which transform splittings.
-- You will need some to do later parts of the exercise, so maybe
-- wait until you see what you need.

-- I expect you will need at least something that takes a pair of splittings
-- that make a tree, like
--
--                  ms
--               <[    ]>
--            ls          rs
--                     <[    ]>
--                 lrs          rrs
--
-- and compute a "rotated" pair of splittings like
--
--                  ms
--               <[    ]>
--            ??          rrs
--         <[    ]>
--      ls          lrs

-- HINT: Sg is your friend

-- You'll probably need some other stuff, too.

--??--------------------------------------------------------------------------

------------------------------------------------------------------------------
--  PART II:  Permutations
------------------------------------------------------------------------------

-- When is one list a permutation of another?

data _~_ {X : Set} : List X -> List X -> Set where

  -- [] is a permutation of []
  []   : [] ~ []

  -- if xs ~ ys, then (x ,- xs) is a permutation of any list made by
  -- shoving x somewhere into ys
  _,-_ : forall {x xs ys' ys} ->
           (x ,- []) <[ ys' ]> ys ->
           xs ~ ys ->
           (x ,- xs) ~ ys'

--??--3.4---------------------------------------------------------------------

-- Show that every list is a permutation of itself.

reflP : {X : Set}{xs : List X} -> xs ~ xs
reflP = {!!}

--??--------------------------------------------------------------------------

--??--3.5---------------------------------------------------------------------

-- Construct an "unbiased" insertion operator which lets you grow a
-- permutation by inserting a new element anywhere, left and right

insP : forall {X : Set}{z : X}{xs xs' ys ys'} ->
         (z ,- []) <[ xs' ]> xs ->
         (z ,- []) <[ ys' ]> ys ->
         xs ~ ys -> xs' ~ ys'
insP l r p = {!!}

-- Now show that, given a permutation, and any element on the left,
-- you can find out where it ended up on the right, and why the
-- remaining elements form a permutation.

findLonR : forall {X : Set}{z : X}{xs xs' ys'} ->
                  (z ,- []) <[ xs' ]> xs ->
                  xs' ~ ys' ->
                  {!!}
findLonR l p = {!!}

-- HINT: again, you may need Sg to give a sensible return type.

--??--------------------------------------------------------------------------

--??--3.6---------------------------------------------------------------------

-- Show that permutation is transitive.

transP : {X : Set}{xs ys zs : List X} -> xs ~ ys -> ys ~ zs -> xs ~ zs
transP p q = {!!}

-- HINT: you will need to define some useful operations on splittings to
-- get this to work.

-- HINT: this may help you figure out what you need for findLonR

-- For a small bonus, show that permutations are the morphisms of a
-- Category.

-- Show that permutation is symmetric.

symP : {X : Set}{xs ys : List X} -> xs ~ ys -> ys ~ xs
symP p = {!!}

-- A category where all morphisms are invertible is called a "groupoid".

--??--------------------------------------------------------------------------

--??--3.7---------------------------------------------------------------------

-- Make permutations act on All.

permute : {X : Set}{xs ys : List X} -> xs ~ ys ->
          {Q : X -> Set} -> All Q xs -> All Q ys

permute p qs = {!!}

--??--------------------------------------------------------------------------

-- MORE TO FOLLOW


module map-++-distribute where

import Relation.Binary.PropositionalEquality as Eq
open Eq using (_≡_; refl; cong)
open Eq.≡-Reasoning
open import lists using (List; []; _∷_; _++_; map)

-- リストの結合に関するmapの分配法則の証明
map-++-distribute : {A B : Set} → (f : A → B) → (xs ys : List A)
  → map f (xs ++ ys) ≡ map f xs ++ map f ys
map-++-distribute f [] ys =
  begin
    map f ([] ++ ys)
  ≡⟨⟩
    map f ys
  ≡⟨⟩
    map f [] ++ map f ys
  ∎
map-++-distribute f (x ∷ xs) ys =
  begin
    map f ((x ∷ xs) ++ ys)
  ≡⟨⟩
    f x ∷ map f (xs ++ ys)
  ≡⟨ cong (f x ∷_) (map-++-distribute f xs ys) ⟩
    f x ∷ map f xs ++ map f ys
  ≡⟨⟩
    map f (x ∷ xs) ++ map f ys
  ∎


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

open import BBHeap _≤_ hiding (#)
open import Bound.Lower A
open import Bound.Lower.Order _≤_
open import SNat

# : {b : Bound} → BBHeap b → SNat
# leaf = zero
# (left {l = l} {r = r} _ _) = succ (# l + # r)
# (right {l = l} {r = r} _ _) = succ (# l + # r)

height : {b : Bound} → BBHeap b → SNat
height leaf = zero
height (left {l = l} _ _) = succ (height l)
height (right {l = l} _ _) = succ (height l)

#' : {b : Bound} → BBHeap b → SNat
#' leaf = zero
#' (left {r = r}  _ _) = succ (#' r + #' r)
#' (right {r = r} _ _) = succ (#' r + #' r)

height' : {b : Bound} → BBHeap b → SNat
height' leaf = zero
height' (left {r = r} _ _) = succ (height' r)
height' (right {r = r} _ _) = succ (height' r)


module List.Order.Bounded.Properties {A : Set}
                   (_≤_ : A → A → Set)
                   (trans≤ : {x y z : A} → x ≤ y → y ≤ z → x ≤ z)  where

open import Bound.Total A
open import Bound.Total.Order _≤_
open import Bound.Total.Order.Properties _≤_ trans≤
open import Data.List
open import List.Order.Bounded _≤_
open import List.Sorted _≤_

lemma-sorted++ : {x : A}{xs ys : List A} → xs ≤* (val x) → (val x) *≤ ys → Sorted xs → Sorted ys → Sorted (xs ++ (x ∷ ys))
lemma-sorted++ {x = x} lenx genx _ _ = singls x
lemma-sorted++ lenx (gecx u≤y _) _ sys = conss (lemma-LeB≤ u≤y) sys
lemma-sorted++ (lecx x≤u xs≤*u) u*≤ys (singls x) sys = conss (lemma-LeB≤ x≤u) (lemma-sorted++ xs≤*u u*≤ys nils sys)
lemma-sorted++ (lecx x≤u xs≤*u) u*≤ys (conss x≤z sxs) sys = conss x≤z (lemma-sorted++ xs≤*u u*≤ys sxs sys)

lemma-++≤* : {t : Bound}{x : A}{xs ys : List A} → LeB (val x) t → xs ≤* (val x) → ys ≤* t → (xs ++ (x ∷ ys)) ≤* t
lemma-++≤* u≤t lenx ys≤*t = lecx u≤t ys≤*t
lemma-++≤* u≤t (lecx x≤u xs≤*u) ys≤*u = lecx (transLeB x≤u u≤t) (lemma-++≤* u≤t xs≤*u ys≤*u)

lemma-*≤ : {b : Bound}{x : A}{xs : List A} → LeB b (val x) → (val x) *≤ xs → b *≤ xs
lemma-*≤ _ genx = genx
lemma-*≤ b≤u (gecx u≤x u*≤xs) = gecx (transLeB b≤u u≤x) (lemma-*≤ b≤u u*≤xs)

lemma-++*≤ : {b : Bound}{x : A}{xs ys : List A} → LeB b (val x) → b *≤ xs → (val x) *≤ ys → b *≤ (xs ++ (x ∷ ys))
lemma-++*≤ b≤u genx u*≤ys = gecx b≤u (lemma-*≤ b≤u u*≤ys)
lemma-++*≤ b≤u (gecx b≤x b*≤xs) u*≤ys = gecx b≤x (lemma-++*≤ b≤u b*≤xs u*≤ys)


module trichotomy where

open import Relation.Binary.PropositionalEquality using (_≡_; refl)
open import Data.Nat using (ℕ; zero; suc)
open import Data.Sum using (_⊎_; inj₁; inj₂)
open import Data.Product using (_×_) renaming (_,_ to ⟨_,_⟩)

open import Negation using (¬_; _≢_)

infix 4 _<_
data _<_ : ℕ → ℕ → Set where
  z<s : ∀ {n : ℕ}
      ------------
    → zero < suc n

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

infix 4 _≮_
_≮_ : ∀ (m n : ℕ) → Set
m ≮ n = ¬ (m < n)

-- 1 + m ≡ 1 + n ならば m ≡ n
sm≡sn→m≡n : ∀ {m n : ℕ} → suc m ≡ suc n → m ≡ n
sm≡sn→m≡n refl = refl

-- m ≢ n ならば 1 + m ≢ 1 + n
m≢n→sm≢sn : ∀ {m n : ℕ} → m ≢ n → suc m ≢ suc n
m≢n→sm≢sn m≢n = λ{ sm≡sn → m≢n (sm≡sn→m≡n sm≡sn) }

-- m ≮ n ならば 1 + m ≮ 1 + n
m≮n→sm≮sn : ∀ {m n : ℕ} → m ≮ n → suc m ≮ suc n
m≮n→sm≮sn m≮n = λ{ (s<s m<n) → m≮n m<n }

-- 三分律の証明
trichotomy : ∀ (m n : ℕ)
  → (m < n × m ≢ n × n ≮ m)
  ⊎ (m ≮ n × m ≡ n × n ≮ m)
  ⊎ (m ≮ n × m ≢ n × n < m)
trichotomy zero    zero                                              = inj₂ (inj₁ ⟨ (λ()) , ⟨ refl , (λ()) ⟩ ⟩)
trichotomy zero    (suc n)                                           = inj₁ ⟨ z<s , ⟨ (λ()) , (λ()) ⟩ ⟩
trichotomy (suc m) zero                                              = inj₂ (inj₂ ⟨ (λ()) , ⟨ (λ()) , z<s ⟩ ⟩)
trichotomy (suc m) (suc n) with trichotomy m n
...                           | inj₁ ⟨ m<n , ⟨ m≢n , n≮m ⟩ ⟩         = inj₁ ⟨ s<s m<n , ⟨ m≢n→sm≢sn m≢n , m≮n→sm≮sn n≮m ⟩ ⟩
...                           | inj₂ (inj₁ ⟨ m≮n , ⟨ refl , n≮m ⟩ ⟩) = inj₂ (inj₁ ⟨ m≮n→sm≮sn m≮n , ⟨ refl , m≮n→sm≮sn n≮m ⟩ ⟩)
...                           | inj₂ (inj₂ ⟨ m≮n , ⟨ m≢n , n<m ⟩ ⟩)  = inj₂ (inj₂ ⟨ m≮n→sm≮sn m≮n , ⟨ m≢n→sm≢sn m≢n , s<s n<m ⟩ ⟩)


module Ag04 where

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

infix 4 _≡_

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

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

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

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

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

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

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

postulate
  +-identity : ∀ (m : ℕ) → m + zero ≡ m
  +-suc : ∀ (m n : ℕ) → m + suc n ≡ suc (m + n)
  +-comm : ∀ (m n : ℕ) → m + n ≡ n + m

_≐_ : ∀ {A : Set} (x y : A) → Set₁
_≐_ {A} x y = ∀ (P : A → Set) → P x → P y

refl-≐ : ∀ {A : Set} {x : A} → x ≐ x
refl-≐ P Px = Px

trans-≐ : ∀ {A : Set} {x y z : A} → x ≐ y → y ≐ z → x ≐ z
trans-≐ x≐y y≐z P Px = y≐z P (x≐y P Px)

sym-≐ : ∀ {A : Set} {x y : A} → x ≐ y → y ≐ x
sym-≐ {A} {x} {y} x≐y P = Qy
  where
    Q : A → Set
    Q z = P z → P x
    Qx : Q x
    Qx = refl-≐ P
    Qy : Q y
    Qy = x≐y Q Qx

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

≡-implies-≐ : ∀ {A : Set} {x y : A} → x ≡ y → x ≐ y
≡-implies-≐ x≡y P = subst P x≡y

≐-implies-≡ : ∀ {A : Set} {x y : A} → x ≐ y → x ≡ y
≐-implies-≡ {A} {x} {y} x≐y = Qy
  where
    Q : A → Set
    Q z = x ≡ z
    Qx : Q x
    Qx = refl
    Qy : Q y
    Qy = x≐y Q Qx

open import Level using (Level; _⊔_) renaming (zero to lzero; suc to lsuc)

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


module TerminationListInsertionNaive where

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

infixr 50 _::_

-- non-deterministic choice
postulate
  _⊕_ : {A : Set} -> A -> A -> A
infixl 10 _⊕_

-- a funny formulation of insert
-- insert (a :: l)  inserts a into l
--
-- this example cannot be handled with subpatterns
-- it is done with structured orders
-- could also be done with sized types

insert : {A : Set} -> List A -> List A
insert [] = []
insert (a :: []) = a :: []
insert (a :: b :: bs) = a :: b :: bs ⊕        -- case a <= b
                        b :: insert (a :: bs) -- case a > b

-- list flattening
-- termination using structured orders
flat : {A : Set} -> List (List A) -> List A
flat [] = []
flat ([] :: ll) = flat ll
flat ((x :: l) :: ll) = x :: flat (l :: ll)

{- generates two recursive calls with the following call matrices

      [] :: ll         (x :: l)   ll

  ll  <            l   <          .
                   ll  .          =

during composition, the second is collapsed to =, so the call graph is
already complete.  Both matrices are idempotent and contain a strictly
decreasing argument.

It could also be done with sized types; lexicographic in (i,j)
with type

  flat : {A : Set} -> (1 + Listʲ A × List^i (List^∞ A)) -> List^∞ A

-}


module Naturals where

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

infixl 60 _+_
infixl 80 _*_

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

_*_ : Nat -> Nat -> Nat
zero  * m = zero
suc n * m = m + n * m

{-# BUILTIN NATURAL  Nat  #-}
{-# BUILTIN ZERO     zero #-}
{-# BUILTIN SUC      suc  #-}
{-# BUILTIN NATPLUS  _+_  #-}
{-# BUILTIN NATTIMES _*_  #-}


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

module Data.Quiver where

-- A Quiver, also known as a multidigraph, is the "underlying graph" of
-- a category. Note how a Quiver has a *setoid* of edges.

open import Level
open import Relation.Binary using (Rel; IsEquivalence; Setoid)
import Relation.Binary.Reasoning.Setoid as EqR

-- a Quiver has vertices Obj and edges _⇒_, where edges form a setoid over _≈_.
record Quiver o ℓ e : Set (suc (o ⊔ ℓ ⊔ e)) where
  infix 4 _≈_ _⇒_

  field
    Obj   : Set o
    _⇒_   : Rel Obj ℓ
    _≈_   : ∀ {A B} → Rel (A ⇒ B) e
    equiv : ∀ {A B} → IsEquivalence (_≈_ {A} {B})

  setoid : {A B : Obj} → Setoid _ _
  setoid {A} {B} = record
    { Carrier       = A ⇒ B
    ; _≈_           = _≈_
    ; isEquivalence = equiv
    }

  module Equiv {A B : Obj} = IsEquivalence (equiv {A} {B})
  module EdgeReasoning {A B : Obj} = EqR (setoid {A} {B})


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

module SelectSort  {A : Set}
                  (_≤_ : A → A → Set)
                  (tot≤ : Total _≤_) where

open import Data.List
open import Data.Product
open import Data.Sum
open import Size
open import SList
open import SList.Order _≤_

select : {ι : Size} → A →  SList A {ι} → A × SList A {ι}
select x snil = (x , snil)
select x (y ∙ ys)
    with tot≤ x y
... | inj₁ x≤y
    with select x ys
select x (y ∙ ys) | inj₁ x≤y  | (z , zs) = (z , y ∙ zs)
select x (y ∙ ys) | inj₂ y≤x
    with select y ys
select x (y ∙ ys) | inj₂ y≤x | (z , zs) = (z , x ∙ zs)

selectSort : {ι : Size} → SList A {ι} → SList A {ι}
selectSort snil = snil
selectSort (x ∙ xs)
    with select x xs
... | (y , ys) = y ∙ (selectSort ys)


module Vec where

open import Star
open import Nat

data Step (A : Set) : Nat -> Nat -> Set where
  step : (x : A){n : Nat} -> Step A (suc n) n

Vec : (A : Set) -> Nat -> Set
Vec A n = Star (Step A) n zero

[] : {A : Set} -> Vec A zero
[] = ε

_::_ : {A : Set}{n : Nat} -> A -> Vec A n -> Vec A (suc n)
x :: xs = step x • xs

_+++_ : {A : Set}{n m : Nat} -> Vec A n -> Vec A m -> Vec A (n + m)
_+++_ {A}{m = m} xs ys = map +m step+m xs ++ ys
  where
    +m = \z -> z + m
    step+m : Step A =[ +m ]=> Step A
    step+m (step x) = step x

vec : {A : Set}{n : Nat} -> A -> Vec A n
vec {n = ε}     x = []
vec {n = _ • n} x = x :: vec x

_⊗_ : {A B : Set}{n : Nat} -> Vec (A -> B) n -> Vec A n -> Vec B n
ε             ⊗ ε             = []
(step f • fs) ⊗ (step x • xs) = f x :: (fs ⊗ xs)
ε             ⊗ (() • _)

{- Some proof about _-_ needed...

vreverse : {A : Set}{n : Nat} -> Vec A n -> Vec A n
vreverse {A}{n} xs = {! !} -- map i f (reverse xs)
  where
    i : Nat -> Nat
    i m = n - m

    f : Step A op =[ i ]=> Step A
    f (step x) = {! !} -- step x
-}


module Relation.Relation where

open import Level renaming (suc to lsuc)
open import Data.Product

-- Partial equivalence relations.
record ParRel {l l' : Level}{A : Set l}(R : A → A → Set l') : Set (l ⊔ l') where
  field
    symPf   : ∀{x y} → R x y → R y x
    transPf : ∀{x y z} → R x y → R y z → R x z

-- (Total) equivalence relation.
record EqRel {l l' : Level}{A : Set l}(R : A → A → Set l') : Set (l ⊔ l') where
  field
    parEqPf : ParRel R
    refPf   : ∀{x} → R x x

open ParRel public
open EqRel public

-- The product of two relations.
ProductRel : {l l' : Level}{A : Set l}{B : Set l'}
  → (R : A → A → Set l)
  → (R' : B → B → Set l')
  → (A × B → A × B → Set (l ⊔ l'))
ProductRel R R' a b = (R (proj₁ a) (proj₁ b)) × (R' (proj₂ a) (proj₂ b))

-- The product of two partial equivalence relations is also a partial
-- equivalence relation.
ProductRelIsParRel : {l l' : Level}{A : Set l}{B : Set l'}
  → (R : A → A → Set l)
  → (R' : B → B → Set l')
  → ParRel R
  → ParRel R'
  → ParRel (ProductRel R R')
ProductRelIsParRel R R' erPF₁ erPF₂ =
  record { symPf   = λ x₁ → symPf erPF₁ (proj₁ x₁) , symPf erPF₂ (proj₂ x₁);
           transPf = λ x₁ x₂ → (transPf erPF₁ (proj₁ x₁) (proj₁ x₂)) , (transPf erPF₂ (proj₂ x₁) (proj₂ x₂)) }

-- The product of two (total) equivalence relations is also a (total)
-- equivalence relation.
ProductRelIsEqRel : {l l' : Level}{A : Set l}{B : Set l'}
  → (R : A → A → Set l)
  → (R' : B → B → Set l')
  → EqRel R
  → EqRel R'
  → EqRel (ProductRel R R')
ProductRelIsEqRel R R' erPF₁ erPF₂ =
  record { parEqPf = ProductRelIsParRel R R' (parEqPf erPF₁) (parEqPf erPF₂);
           refPf   = λ {x} → (refPf erPF₁ {proj₁ x}) , (refPf erPF₂ {proj₂ x}) }

-- The restriction of a relation by a predicate.
_↓_ : {l l' : Level}
      {A : Set l}
    → (R : A → A → Set l)
    → (P : A → Set l')
    → Set (l ⊔ l')
_↓_ {A = A} R P = Σ[ f ∈ A ] (P f)

-- The restriction of a paritial equivalence is also a partial
-- equivalence.
↓ParRel : {l l' : Level}
          {A : Set l}
        → (R : A → A → Set l)
        → (P : A → Set l')
        → ParRel R
        → ParRel (λ (f g : R ↓ P) → R (proj₁ f) (proj₁ g))
↓ParRel R P prPF = record { symPf = λ x₁ → symPf prPF x₁; transPf = λ x₁ x₂ → transPf prPF x₁ x₂ }

-- The restriction of an equivalence relation is also an equivalence
-- relation.
↓EqRel : {l l' : Level}
         {A : Set l}
       → (R : A → A → Set l)
       → (P : A → Set l')
       → EqRel R
       → EqRel (λ (f g : R ↓ P) → R (proj₁ f) (proj₁ g))
↓EqRel R P eqrPF = record { parEqPf = ↓ParRel R P (parEqPf eqrPF); refPf = refPf eqrPF }


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

open import Categories.Category

module Categories.Diagram.Equalizer.Properties {o ℓ e} (C : Category o ℓ e) where

open import Categories.Diagram.Equalizer C
open import Categories.Morphism C
open import Categories.Morphism.Reasoning C

private
  module C = Category C
  open C

  variable
    X Y Z : Obj
    f g : X ⇒ Y

module _ (equalizer : Equalizer f g) where
  open Equalizer equalizer
  open HomReasoning

  equalizer-≈⇒≈ : ∀ {h} → arr ∘ h ≈ id → f ≈ g
  equalizer-≈⇒≈ {h} eq = begin
    f             ≈⟨ introʳ eq ⟩
    f ∘ arr ∘ h   ≈⟨ pullˡ equality ⟩
    (g ∘ arr) ∘ h ≈⟨ cancelʳ eq ⟩
    g             ∎

section-equalizer : ∀ {X Y} {f : Y ⇒ X} {g : X ⇒ Y} → f SectionOf g → IsEqualizer f (f ∘ g) id
section-equalizer {X = X} {Y = Y} {f = f} {g = g} g∘f≈id = record
  { equality = equality
  ; equalize = equalize
  ; universal = λ {_} {_} {eq} → universal {eq = eq}
  ; unique = unique
  }
  where
    open HomReasoning

    equality : (f ∘ g) ∘ f ≈ id ∘ f
    equality = begin
      (f ∘ g) ∘ f ≈⟨ pullʳ g∘f≈id ⟩
      f ∘ id      ≈⟨ id-comm ⟩
      id ∘ f      ∎

    equalize : ∀ {Z} {h : Z ⇒ X} → (f ∘ g) ∘ h ≈ id ∘ h → Z ⇒ Y
    equalize {h = h} _ = g ∘ h

    universal : ∀ {Z} {h : Z ⇒ X} {eq : (f ∘ g) ∘ h ≈ id ∘ h} → h ≈ f ∘ g ∘ h
    universal {h = h} {eq = eq} = begin
      h           ≈˘⟨ identityˡ ⟩
      id ∘ h      ≈˘⟨ eq ⟩
      (f ∘ g) ∘ h ≈⟨ assoc ⟩
      f ∘ g ∘ h   ∎

    unique : ∀ {Z} {h : Z ⇒ X} {i : Z ⇒ Y} → h ≈ f ∘ i → i ≈ g ∘ h
    unique {h = h} {i = i} h≈g∘i = begin
      i           ≈⟨ introˡ g∘f≈id ⟩
      (g ∘ f) ∘ i ≈⟨ pullʳ (⟺ h≈g∘i) ⟩
      g ∘ h       ∎


------------------------------------------------------------------------
-- The Agda standard library
--
-- Coinductive "natural" numbers
------------------------------------------------------------------------

module Data.Conat where

open import Coinduction
open import Data.Nat using (ℕ; zero; suc)
open import Relation.Binary

------------------------------------------------------------------------
-- The type

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

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

fromℕ : ℕ → Coℕ
fromℕ zero    = zero
fromℕ (suc n) = suc (♯ fromℕ n)

∞ℕ : Coℕ
∞ℕ = suc (♯ ∞ℕ)

infixl 6 _+_

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

------------------------------------------------------------------------
-- Equality

data _≈_ : Coℕ → Coℕ → Set where
  zero :                                 zero  ≈ zero
  suc  : ∀ {m n} (m≈n : ∞ (♭ m ≈ ♭ n)) → suc m ≈ suc n

setoid : Setoid _ _
setoid = record
  { Carrier       = Coℕ
  ; _≈_           = _≈_
  ; isEquivalence = record
    { refl  = refl
    ; sym   = sym
    ; trans = trans
    }
  }
  where
  refl : Reflexive _≈_
  refl {zero}  = zero
  refl {suc n} = suc (♯ refl)

  sym : Symmetric _≈_
  sym zero      = zero
  sym (suc m≈n) = suc (♯ sym (♭ m≈n))

  trans : Transitive _≈_
  trans zero      zero      = zero
  trans (suc m≈n) (suc n≈k) = suc (♯ trans (♭ m≈n) (♭ n≈k))


module 010-false-true where

-- In Agda, types are theorems, and instances of types are proofs. The
-- simplest theorem is the theorem which has no proof, and is useful
-- to represent any contradictory situation. We declare False as an
-- algebraic data type without constructors. If "False" has no
-- constructors, then it also has no instances, and thereby perfectly
-- serves our purpose.  Note that what we call here "False" is also
-- sometimes also called bottom and is denoted by ⊥.

data False : Set where

-- The next simplest theorem is the trivial theorem which is always
-- true. We declare it as an algebraic data type "True", with one
-- constructor named "trivial".

data True : Set where
  trivial : True


module Numeral.Natural.Oper.FlooredDivision where

import Lvl
open import Data
open import Data.Boolean.Stmt
open import Logic.Propositional.Theorems
open import Numeral.Natural
open import Numeral.Natural.Oper.Comparisons
open import Numeral.Natural.Oper.Comparisons.Proofs
open import Numeral.Natural.Relation.Order
open import Relator.Equals

infixl 10100 _⌊/⌋_

-- Inductive definition of an algorithm for division.
-- `[ d , b ] a' div b'` should be interpreted as following:
--   `d` is the result of the algorithm that is being incremented as it runs.
--   `b` is the predecessor of the original denominator. This is constant throughout the whole process.
--   `a'` is the numerator. This is decremented as it runs.
--   `b'` is the predecessor of the temporary denominator. This is decremented as it runs.
-- By decrementing both `a'` and `b'`, and incrementing `d` when 'b`' reaches 0, it counts how many times `b` "fits into" `a`.
-- Note: See Numeral.Natural.Oper.Modulo for a similiar algorithm used to determine the modulo.
[_,_]_div_ : ℕ → ℕ → ℕ → ℕ → ℕ
[ d , _ ] 𝟎     div _     = d
[ d , b ] 𝐒(a') div 𝟎     = [ 𝐒(d) , b ] a' div b
[ d , b ] 𝐒(a') div 𝐒(b') = [ d   , b ] a' div b'
{-# BUILTIN NATDIVSUCAUX [_,_]_div_ #-}

-- Floored division operation.
_⌊/⌋_ : ℕ → (m : ℕ) → .⦃ _ : IsTrue(positive?(m)) ⦄ → ℕ
a ⌊/⌋ 𝐒(m) = [ 𝟎 , m ] a div m

_⌊/⌋₀_ : ℕ → ℕ → ℕ
_ ⌊/⌋₀ 𝟎    = 𝟎
a ⌊/⌋₀ 𝐒(m) = a ⌊/⌋ 𝐒(m)
{-# INLINE _⌊/⌋₀_ #-}


open import Oscar.Prelude
open import Oscar.Class.Symmetry
open import Oscar.Class.Symmetrical
import Oscar.Data.Proposequality

module Oscar.Class.Symmetrical.Symmetry where

module _
    {𝔬} {𝔒 : Ø 𝔬}
    {ℓ} {_∼_ : 𝔒 → 𝔒 → Ø ℓ}
    ⦃ _ : Symmetry.class _∼_ ⦄
  where

  instance

    Symmetrical𝓢ymmetry : Symmetrical _∼_ (λ x∼y y∼x → x∼y → y∼x)
    Symmetrical𝓢ymmetry .𝓢ymmetrical.symmetrical _ _ = symmetry


Extensionality of a function of two arguments

\begin{code}
extensionality2 : ∀ {A B C : Set} → {f g : A → B → C} → (∀ (x : A) (y : B) → f x y ≡ g x y) → f ≡ g
extensionality2 fxy≡gxy = extensionality (λ x → extensionality (λ y → fxy≡gxy x y))
\end{code}

Isomorphism of all and exists.
\begin{code}
¬∃∀ : ∀ {A : Set} {B : A → Set} → (¬ ∃ (λ (x : A) → B x)) ≃ ∀ (x : A) → ¬ B x
¬∃∀ =
  record
    { to   =  λ { ¬∃bx x bx → ¬∃bx (x , bx) }
    ; fro  =  λ { ∀¬bx (x , bx) → ∀¬bx x bx }
    ; invˡ =  λ { ¬∃bx → extensionality (λ { (x , bx) → refl }) }
    ; invʳ =  λ { ∀¬bx → refl }
    }
\end{code}


------------------------------------------------------------------------------
-- Inductive PA arithmetic properties using Agsy
------------------------------------------------------------------------------

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

-- Tested with the development version of the Agda standard library on
-- 02 February 2012.

module Agsy.PA.Inductive.Properties where

open import Data.Nat renaming ( suc to succ )

open import Relation.Binary.PropositionalEquality
open ≡-Reasoning

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

+-rightIdentity : ∀ n → n + zero ≡ n  -- via Agsy {-c}
+-rightIdentity zero     = refl
+-rightIdentity (succ n) = cong succ (+-rightIdentity n)

+-assoc : ∀ m n o → m + n + o ≡ m + (n + o)  -- via Agsy {-c}
+-assoc zero     n o = refl
+-assoc (succ m) n o = cong succ (+-assoc m n o)

x+Sy≡S[x+y] : ∀ m n → m + succ n ≡ succ (m + n)  -- via Agsy {-c}
x+Sy≡S[x+y] zero     n = refl
x+Sy≡S[x+y] (succ m) n = cong succ (x+Sy≡S[x+y] m n)

+-comm : ∀ m n → m + n ≡ n + m  -- via Agsy {-c -m}
+-comm zero    n = sym (+-rightIdentity n)
+-comm (succ m) n =
  begin
    succ (m + n) ≡⟨ cong succ (+-comm m n) ⟩
    succ (n + m) ≡⟨ sym (x+Sy≡S[x+y] n m) ⟩
    n + succ m
  ∎


{-# OPTIONS --safe --without-K #-}
open import Relation.Binary

module Data.List.Membership.Setoid.Disjoint {a p} (S : Setoid a p) where
open Setoid S renaming (Carrier to A)
open import Data.List using (List ; [])
open import Data.List.Membership.Setoid (S)
open import Data.List.Membership.Setoid.Trans (S)
open import Data.Empty

open import Function

Disjoint : Rel (List A) _
Disjoint xs ys = ∀ {x} → x ∈ xs → x ∈ ys → ⊥

disjoint-sym : Symmetric Disjoint
disjoint-sym dis = flip dis

disjoint-[]ˡ : ∀ {xs} → Disjoint xs []
disjoint-[]ˡ _ ()

disjoint-[]ʳ :  ∀ {xs} → Disjoint [] xs
disjoint-[]ʳ ()

disjointness : ∀ {xs ys} → Disjoint xs ys → ∀ {x} → x ∈ xs → ∀ {y} → y ∈ ys → x ≈ y → ⊥
disjointness xs⋈ys x∈xs y∈ys x≈y = xs⋈ys x∈xs (≈-trans-∈ x≈y y∈ys)


module Nat where

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

infixl 60 _+_
infixl 70 _*_

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

_*_ : Nat -> Nat -> Nat
n * zero  = zero
n * suc m = n * m + n

{-# BUILTIN NATURAL Nat #-}
{-# BUILTIN ZERO zero #-}
{-# BUILTIN SUC suc #-}
{-# BUILTIN NATPLUS _+_ #-}
{-# BUILTIN NATTIMES _*_ #-}


open import Preliminaries
open import Preorder

module PreorderExamples where

-- there is a preorder on Unit

  unit-p : Preorder Unit
  unit-p = preorder (preorder-structure (λ x x₁ → Unit) (λ x → <>) (λ x y z _ _ → <>))

-- there is a preorder on Nat

  _≤n_ : Nat → Nat → Set
  _≤n_ Z Z = Unit
  _≤n_ Z (S n) = Unit
  _≤n_ (S m) Z = Void
  _≤n_ (S m) (S n) = m ≤n n

  nat-refl : ∀ (n : Nat) → n ≤n n
  nat-refl Z = <>
  nat-refl (S n) = nat-refl n

  nat-trans : ∀ (m n p : Nat) → m ≤n n → n ≤n p → m ≤n p
  nat-trans Z Z Z x x₁ = <>
  nat-trans Z Z (S p) x x₁ = <>
  nat-trans Z (S n) Z x x₁ = <>
  nat-trans Z (S n) (S p) x x₁ = <>
  nat-trans (S m) Z Z () x₁
  nat-trans (S m) Z (S p) () x₁
  nat-trans (S m) (S n) Z x ()
  nat-trans (S m) (S n) (S p) x x₁ = nat-trans m n p x x₁

  nat-p : Preorder Nat
  nat-p = preorder (preorder-structure (λ m n → m ≤n n) nat-refl nat-trans)


module Extensions.VecFirst where

open import Data.Vec
open import Data.Product
open import Level
open import Relation.Nullary
open import Function using (_∘_; _$_)

-- proof that an element is the first in a vector to satisfy the predicate B
data First {a b} {A : Set a} (B : A → Set b) : ∀ {n} (x : A) → Vec A n → Set (a ⊔ b) where

  here  : ∀ {n} {x : A} → (p : B x) → (v : Vec A n) → First B x (x ∷ v)
  there : ∀ {n x} {v : Vec A n} (x' : A) → ¬ (B x') → First B x v → First B x (x' ∷ v)

-- more likable syntax for the above structure
first_∈_⇔_ : ∀ {n} {A : Set} → A → Vec A n → (B : A → Set) → Set
first_∈_⇔_ x v p = First p x v

-- a decision procedure to find the first element in a vector that satisfies a predicate
find : ∀ {n} {A : Set} (P : A → Set) → ((a : A) → Dec (P a)) → (v : Vec A n) →
       Dec (∃ λ e → first e ∈ v ⇔ P)
find P dec [] = no (λ{ (e , ()) })
find P dec (x ∷ v) with dec x
find P dec (x ∷ v) | yes px = yes (x , here px v)
find P dec (x ∷ v) | no ¬px with find P dec v
find P dec (x ∷ v) | no ¬px | yes firstv = yes (, there x ¬px (proj₂ firstv))
find P dec (x ∷ v) | no ¬px | no ¬firstv = no $ helper ¬px ¬firstv
  where
    helper : ¬ (P x) → ¬ (∃ λ e → First P e v) → ¬ (∃ λ e → First P e (x ∷ v))
    helper ¬px ¬firstv (.x , here p .v) = ¬px p
    helper ¬px ¬firstv (u  , there ._ _ firstv) = ¬firstv (u , firstv)