module x04equality where

------------------------------------------------------------------------------
-- EQUALITY

-- for any      type A
-- for any x of type A
-- refl constructor provides evidence that x ≡ x
-- i.e., every value is equal to itself
data _≡_ {A : Set} (x : A) : A → Set where
  refl : x ≡ x

infix 4 _≡_

-- tell Agda which type corresponds to equality
{-# BUILTIN EQUALITY _≡_ #-}

{-
Note:
- 1st arg to _≡_ is PARAMETER (x : A)
  - BEST PRACTICE: use parameters when possible
  - can be a parameter because it does not vary
- 2nd arg is an INDEX in A → Set
  - must be an index, so it can be required to be equal to the first

------------------------------------------------------------------------------
-- EQUALITY is an EQUIVALENCE RELATION (reflexive, symmetric, transitive)

reflexivity in the def of equality, via refl constructor
-}

-- symmetry
sym : ∀ {A : Set} {x y : A}
  → x ≡ y  -- arg has type x ≡ y
    -----
  → y ≡ x
sym refl -- LHS :instantiates arg to refl CONSTRUCTOR (only one possible)
         -- refl requires x y to be the same
  = refl -- RHS : need a term of type x ≡ x, so refl

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

------------------------------------------------------------------------------
-- EQUALITY SATISFIES CONGRUENCE

-- if two terms are equal, they remain so after same function is applied to both
cong : ∀ {A B : Set} (f : A → B) {x y : A}
  →   x ≡   y
    ---------
  → f x ≡ f y
cong f refl = refl

-- where f takes two args
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

-- if two functions are equal, then applying them to same term yields equal terms
cong-app : ∀ {A B : Set} {f g : A → B}
  →             f   ≡ g
    ---------------------
  → ∀ (x : A) → f x ≡ g x
cong-app refl x = refl

------------------------------------------------------------------------------
-- EQUALITY SATISFIES SUBSTITUTION

-- if two values are equal and a predicate holds of first then it also holds of second
subst : ∀ {A : Set} {x y : A} (P : A → Set)
  →   x ≡  y
    ---------
  → P x
  →     P y
subst P refl px = px

------------------------------------------------------------------------------
--  CHAINS OF EQUATIONS (aka EQUATIONAL REASONING)

module ≡-Reasoning {A : Set} where

  infix  1 begin_
  infixr 2 _≡⟨⟩_ _≡⟨_⟩_
  infix  3 _∎

  -- identity : this is just used to make proof look nice
  begin_ : ∀ {x y : A}
    → x ≡ y
      -----
    → x ≡ y
  begin x≡y = x≡y

  -- think of _≡⟨⟩_ as equivalent to _≡⟨ refl ⟩_
  _≡⟨⟩_ : ∀ (x : A) {y : A}
    → x ≡ y
      -----
    → x ≡ y
  x ≡⟨⟩ x≡y = x≡y

  _≡⟨_⟩_ : ∀ (x : A) {y z : A}
    → x ≡ y
    → y ≡ z
      -----
    → x ≡ z
  x ≡⟨ x≡y ⟩ y≡z = trans x≡y y≡z

  _∎ : ∀ (x : A)
      -----
    → x ≡ x
  x ∎ = refl

open ≡-Reasoning

trans′ : ∀ {A : Set} {x y z : A}
  → x ≡ y
  →     y ≡ z
    -----
  → x ≡     z
trans′ {A} {x} {y} {z} x≡y y≡z =
  begin          -- Goal: x ≡ z   ; y≡z : y ≡ z; x≡y : x ≡ y
    x ≡⟨ x≡y ⟩   -- Goal: y ≡ z
    y ≡⟨ y≡z ⟩   -- Goal: z ≡ z
    z
  ∎

{-
EXERCISE trans and ≡-Reasoning (practice) TODO
Cannot use definition of trans’ using ≡-Reasoning as the definition for trans.
Why?
Hint: look at the definition of _≡⟨_⟩_

-- Your code goes here

------------------------------------------------------------------------------
Chains of equations, another example : addition is commutative
-}

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

{-# BUILTIN NATURAL ℕ #-}

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

infixl 6  _+_

-- to save space, postulate (rather than prove) two lemmas:
-- POSTULATE : specifies a signature but no def. Use with care. DON'T postulate something false!
postulate
  +-identity : ∀ (m   : ℕ) → m + zero  ≡ m
  +-suc      : ∀ (m n : ℕ) → m + suc n ≡ suc (m + n)

+-comm : ∀ (m n : ℕ) → m + n ≡ n + m
+-comm m zero =
  begin
    m + zero    ≡⟨ +-identity m ⟩
    m           ≡⟨⟩
    zero + m
  ∎
+-comm m (suc n) =
  begin
         m + suc n  ≡⟨ +-suc m n ⟩
    suc (m +     n) ≡⟨ cong suc (+-comm m n) ⟩
    suc (n +     m) ≡⟨⟩ -- terms are equivalent to simplified term
    suc  n +     m
  ∎

{-
------------------------------------------------------------------------------
Exercise ≤-Reasoning (stretch)

redo proof of +-monoʳ-≤ (from Chapter Relations) using an analogue of ≡-Reasoning

define ≤-Reasoning

use it to write out proof that addition is monotonic with regard to inequality
by redoing all of +-monoˡ-≤, +-monoʳ-≤, and +-mono-≤
-}

module ≤-Reasoning {A : Set} where

  data _≤_ : ℕ → ℕ → Set where
    z≤n : ∀ {n : ℕ}
        --------
      → zero ≤ n

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

  infix 4 _≤_

  ≤-trans : ∀ {m n p : ℕ} → m ≤ n → n ≤ p → m ≤ p
  ≤-trans      z≤n         _  = z≤n
  ≤-trans (s≤s m≤n) (s≤s n≤p) = s≤s (≤-trans m≤n n≤p)

  infix  1 begin≤_
  infixr 2 _≤⟨⟩_ _≤⟨_⟩_
  infix  3 _∎≤

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

  begin≤_ : ∀ {x y : ℕ}
    → x ≤ y
      -----
    → x ≤ y
  begin≤ x≤y = x≤y

  -- can think of _≤⟨⟩_ as equivalent to _≤⟨ refl ⟩_
  _≤⟨⟩_ : ∀ (x : ℕ) {y : ℕ}
    → x ≤ y
      -----
    → x ≤ y
  x ≤⟨⟩ x≤y = x≤y

  _≤⟨_⟩_ : ∀ (x : ℕ) {y z : ℕ}
    → x ≤ y
    → y ≤ z
      -----
    → x ≤ z
  x ≤⟨ x≤y ⟩ y≤z = ≤-trans x≤y y≤z

  _∎≤ : ∀ (x : ℕ)
      -----
    → x ≤ x
  zero  ∎≤ = z≤n
  suc x ∎≤ = s≤s (x ∎≤)

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

  +-monoʳ-≤ : ∀ (n p q : ℕ)
    →      p  ≤      q
      -------------
    → (n + p) ≤ (n + q)

  +-monoʳ-≤ zero    p q p≤q  =
    begin≤
      zero + p ≤⟨⟩
             p ≤⟨ p≤q ⟩
             q ≤⟨⟩
      zero + q
    ∎≤

  +-monoʳ-≤ (suc n) p q p≤q =
    begin≤
      suc n + p ≤⟨ s≤s (+-monoʳ-≤ n p q p≤q) ⟩
      suc n + q
    ∎≤

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

  postulate
    +-comm-≤ : ∀ (m n : ℕ) → m + n ≤ n + m

  +-monoˡ-≤ : ∀ (m n p : ℕ)
    → m     ≤ n
      -------------
    → m + p ≤ n + p

  +-monoˡ-≤ m n p m≤n =
    begin≤
      m + p ≤⟨ +-comm-≤ m p ⟩
      p + m ≤⟨ +-monoʳ-≤ p m n m≤n ⟩
      p + n ≤⟨ +-comm-≤ p n ⟩
      n + p
    ∎≤

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

  +-mono-≤ : ∀ (m n p q : ℕ)
    → m     ≤ n
    →     p ≤     q
      -------------
    → m + p ≤ n + q
  +-mono-≤ m n p q m≤n p≤q =
    begin≤
      m + p ≤⟨ +-monoˡ-≤ m n p m≤n ⟩
      n + p ≤⟨ +-monoʳ-≤ n p q p≤q ⟩
      n + q
    ∎≤

{-
------------------------------------------------------------------------------
-- Rewriting
-}

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

data even where

  even-zero : even zero

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

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

{-
given even (m + n) holds
prove even (n + m) holds

REWRITE: notation to support this kind of reasoning
-}

-- then use rewrite
even-comm : ∀ (m n : ℕ)
  → even (m + n)
    ------------
  → even (n + m)
even-comm m n ev      -- even (n + m)
  rewrite +-comm n m  -- Goal: even (m + n); ev : even (m + n)
  = ev

{-
keyword REWRITE : followed by evidence of an equality
That equality is used to rewrite the type of the goal and of any variable in scope.
-}

even-comm' : ∀ (m n : ℕ)
  → even (m + n)
    ------------
  → even (n + m)
even-comm' m n ev        -- Goal: even (n + m)  ; ev : even (m + n)
  rewrite
    +-comm m n           -- Goal: even (n + m)  ; ev : even (n + m) <-- rewrites evidence
  = ev --   ^
--          note: arg order diff than 'even-comm' above

------------------------------------------------------------------------------
-- Multiple rewrites : each separated by a vertical bar

+-comm′ : ∀ (m n : ℕ) → m + n ≡ n + m
+-comm′ zero    n        --    zero + n ≡ n + zero
                         --           n ≡ n + zero
  rewrite
    +-identity n         --           n ≡ n
  = refl
+-comm′ (suc m) n        -- suc  m + n  ≡ n + suc m
                         -- suc (m + n) ≡ n + suc m
  rewrite
    +-suc   n m          -- suc (m + n) ≡ suc (n + m) <-- rewrites LHS
  | +-comm′ m n          -- suc (n + m) ≡ suc (n + m) <-- rewrites RHS
  = refl

{-
Previous +-comm proof required cong suc (+-comm m n) (invoking inductive hypothesis).
Rewriting automatically takes congruence into account.
Proofs with rewriting are shorter.
Proofs as chains of equalities are easier to follow.
-}

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

{-
------------------------------------------------------------------------------
--rewrite is shorthand for 'WITH'
-}

even-comm′ : ∀ (m n : ℕ)
  → even (m + n)
    ------------
  → even (n + m)
even-comm′ m n ev with   m + n  | +-comm m n
...                  | .(n + m) | refl       = ev

{-
WITH : can be followed by one or more expressions, separated by bars
- where each equation has the same number of patterns

1st COLUMN asserts m + n and n + m are identical
2nd COLUMN justifies assertion with evidence of the appropriate equality

DOT PATTERN : .(n + m)
- dot followed by an expression
- used when other info forces value matched to be equal to value of expression in dot pattern

Here: m + n ≡ n + m justified by matching +-comm m n with refl

------------------------------------------------------------------------------
-- using SUBSTITUTION instead of REWRITE
-}

even-comm″ : ∀ (m n : ℕ)
  → even (m + n)
    ------------
  → even (n + m)
even-comm″ m n
  --      m + n ≡ n + m
  --            v
--= subst even {!!}
--= subst {!!}  (+-comm m n)
--         ^
-- Constraints
-- ?0 (n + m) =< even (n + m)
-- even (m + n) =< ?0 (m + n)
  = subst even (+-comm m n)

{-
------------------------------------------------------------------------------
-- Leibniz equality : TWO OBJECTS EQUAL IFF THEY SATISFY THE SAME PROPERTIES.

The form of asserting equality so far is due to Martin Löf (1975).

Another form is due to Leibniz (1686).

Define Leibniz equality and show that two terms satisfy Leibniz equality
IFF they satisfy Martin Löf equality.

x ≐ y
holds if
every property P that holds of x also holds of y
also ensures converse
every property P that holds of y also holds of x

Let x and y be objects of type A.
x ≐ y holds if for every predicate P over type A we have that P x implies P y:
-}

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

{-
write _≐_ {A} x y (instead of infix) to provide access to the implicit parameter A

FIRST USE OF LEVELS

Cannot assign Set the type Set
- would lead to contradictions such as Russell’s Paradox and Girard’s Paradox

hierarchy of types, where Set : Set₁, Set₁ : Set₂, ...

'Set' is an abbreviation for 'Set₀'

Since the equation defining _≐_ mentions Set on the right-hand side,
the corresponding signature must use Set₁.

------------------------------------------------------------------------------
Leibniz equality is reflexive, transitive, symmetric
-}

-- reflexiviity follows by a variant of the identity function
refl-≐ : ∀ {A : Set} {x : A}
  → x ≐ x
refl-≐ P Px = Px

-- transitivity follows by a variant of function composition
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)

-- show that if P x implies P y for all predicates P
-- then         P y implies P x
sym-≐ : ∀ {A : Set} {x y : A}
  → x ≐ y           -- given x ≐ y
    -----
  → y ≐ x
sym-≐ {A} {x} {y} x≐y P = Qy -- TODO : where is 'P' in the signature?
  where
    Q : A → Set     -- instantiate the equality with a predicate Q such that Q z holds
    Q z = P z → P x -- if P z implies P x

    Qx : Q x        -- The property Q x is by reflexivity, and hence Q y follows from x ≐ y.
    Qx = refl-≐ P

    Qy : Q y        --  Q y is the required proof : P y implies P x
    Qy = x≐y Q Qx

{-
------------------------------------------------------------------------------
Martin Löf equality implies Leibniz equality

given x ≡ y
need for any P to take evidence of P x to evidence of P y

the equality of x and y implies that any proof of P x is also a proof of P y
follows from substitution
-}

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

{-
------------------------------------------------------------------------------
Leibniz equality implies Martin Löf equality

given for any P we can take a proof of P x to a proof of P y
show x ≡ y

proof is similar to that for symmetry of Leibniz equality
-}

≐-implies-≡ : ∀ {A : Set} {x y : A}
  → x ≐ y
    -----
  → x ≡ y
≐-implies-≡ {A} {x} {y} x≐y = Qy
  where
    Q : A → Set   -- Q is predicate that holds of z if x ≡ z
    Q z = x ≡ z

    Qx : Q x      -- Q x by reflexivity of Martin Löf equality
    Qx = refl

    Qy : Q y      -- Q y follows from x ≐ y
    Qy = x≐y Q Qx -- Q y is required proof : x ≡ y

{-
This section adapted from
≐≃≡: Leibniz Equality is Isomorphic to Martin-Löf Identity, Parametrically
draft/2017
by Andreas Abel, Jesper Cockx, Dominique Devries, Andreas Nuyts, and Philip Wadler

------------------------------------------------------------------------------
UNIVERSE POLYMORPHISM (aka LEVELs)

every type belongs somewhere in the hierarchy Set₀, Set₁, Set₂, ...

Set abbreviates Set₀

Set₀ : Set₁
Set₁ : Set₂
...

to compare values of a type that belongs to Set ℓ for some arbitrary level ℓ?

via UNIVERSE POLYMORPHISM

definition is made with respect to an arbitrary level ℓ

to use levels:
-}

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

{-
rename constructors zero and suc to avoid confusion between levels and naturals

Levels are isomorphic to natural numbers, and have similar constructors:

lzero : Level
lsuc  : Level → Level

Set₀, Set₁, Set₂, ... abbreviations for

Set lzero
Set (lsuc lzero)
Set (lsuc (lsuc lzero))

_⊔_ : Level → Level → Level

that given two levels returns the larger of the two.
-}

-- equality, generalised to an arbitrary level:
data _≡′_ {ℓ : Level} {A : Set ℓ} (x : A) : A → Set ℓ where
  refl′ : x ≡′ x

-- generalised definition of symmetry:
sym′ : ∀ {ℓ : Level} {A : Set ℓ} {x y : A}
  → x ≡′ y
    ------
  → y ≡′ x
sym′ refl′ = refl′

{-
For simplicity, this book avoids universe polymorphism.
Most definitions in the standard library are generalised to arbitrary levels as above.
-}

-- generalised definition of Leibniz equality:
_≐′_ : ∀ {ℓ : Level} {A : Set ℓ} (x y : A) → Set (lsuc ℓ)
_≐′_ {ℓ} {A} x y = ∀ (P : A → Set ℓ) → P x → P y

{-
Before the signature used Set₁ as the type of a term that includes Set,
whereas here the signature uses Set (lsuc ℓ) as the type of a term that includes Set ℓ.

Most other functions in the standard library are also generalised to arbitrary levels.
-}

-- definition of composition.
_∘_ : ∀ {ℓ₁ ℓ₂ ℓ₃ : Level} {A : Set ℓ₁} {B : Set ℓ₂} {C : Set ℓ₃}
  → (B → C) → (A → B) → A → C
(g ∘ f) x = g (f x)

{-
------------------------------------------------------------------------------
Standard library

standard library defines _≡⟨_⟩_ as step-≡,
which reverses the order of the arguments

standard library defines a macro,imported when import step-≡
which recovers the original argument order:

import Relation.Binary.PropositionalEquality as Eq
open Eq using (_≡_; refl; trans; sym; cong; cong-app; subst)
open Eq.≡-Reasoning using (begin_; _≡⟨⟩_; step-≡; _∎)

------------------------------------------------------------------------------
Unicode

≡  U+2261  IDENTICAL TO                     (\==, \equiv)
⟨  U+27E8  MATHEMATICAL LEFT ANGLE BRACKET  (\<)
⟩  U+27E9  MATHEMATICAL RIGHT ANGLE BRACKET (\>)
∎  U+220E  END OF PROOF                     (\qed)
≐  U+2250  APPROACHES THE LIMIT             (\.=)
ℓ  U+2113  SCRIPT SMALL L                   (\ell)
⊔  U+2294  SQUARE CUP                       (\lub)
₀  U+2080  SUBSCRIPT ZERO                   (\_0)
₁  U+2081  SUBSCRIPT ONE                    (\_1)
₂  U+2082  SUBSCRIPT TWO                    (\_2)
-}


{-# OPTIONS --safe #-}

module Invert where

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

open import Data.Nat.Properties

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

pred₂ : ℕ → ℕ
pred₂ = pred ∘ pred

lemma : (a b : ℕ) → pred₂ (suc a + suc a) ≡ pred₂ (suc b + suc b)
        → a + a ≡ b + b
lemma a b p =
  begin
  a + a ≡⟨⟩
  pred₂ (suc (suc (a + a))) ≡⟨⟩
  pred₂ (suc (suc a + a)) ≡⟨ cong (pred₂ ∘ suc) (+-comm (suc a) a)  ⟩
  pred₂ (suc (a + suc a)) ≡⟨⟩
  pred₂ (suc a + suc a) ≡⟨ p ⟩
  pred₂ (suc b + suc b) ≡⟨⟩
  pred₂ (suc (b + suc b)) ≡⟨ cong (pred₂ ∘ suc) (+-comm b (suc b)) ⟩
  pred₂ (suc (suc b + b)) ≡⟨⟩
  b + b
  ∎ where open ≡-Reasoning

invert : (a b : ℕ) → a + a ≡ b + b → a ≡ b
invert zero zero p = refl
invert (suc m) (suc n) p = cong suc (invert m n (lemma m n (cong pred₂ p)))


module Bin-laws where

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

open import Induction′ using (+-suc; +-identityʳ; +-comm; +-assoc)

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

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

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

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

2*n≡n+n : ∀ (n : ℕ) → 2 * n ≡ n + n
2*n≡n+n n =
  begin
    2 * n
  ≡⟨⟩
    n + (1 * n)
  ≡⟨⟩
    n + (n + (0 * n))
  ≡⟨⟩
    n + (n + 0)
  ≡⟨ cong (n +_) (+-identityʳ n) ⟩
    n + n
  ∎

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

-- 変換の前後どちらでインクリメントしても結果は等しい
from∘inc≡suc∘from : ∀ (b : Bin) → from (inc b) ≡ suc (from b)
from∘inc≡suc∘from ⟨⟩ =
  begin
    from (inc ⟨⟩)
  ≡⟨⟩
    from (⟨⟩ I)
  ≡⟨⟩
    suc zero
  ≡⟨⟩
    suc (from ⟨⟩)
  ∎
from∘inc≡suc∘from (b O) =
  begin
    from (inc (b O))
  ≡⟨⟩
    from (b I)
  ≡⟨⟩
    2 * (from b) + 1
  ≡⟨⟩
    from (b O) + 1
  ≡⟨ +-suc (from (b O)) zero ⟩
    suc (from (b O) + zero)
  ≡⟨ cong suc (+-identityʳ (from (b O))) ⟩
    suc (from (b O))
  ∎
from∘inc≡suc∘from (b I) =
  begin
    from (inc (b I))
  ≡⟨⟩
    from ((inc b) O)
  ≡⟨⟩
    2 * (from (inc b))
  ≡⟨ cong (2 *_) (from∘inc≡suc∘from b) ⟩
    2 * (suc (from b))
  ≡⟨ 2*n≡n+n (suc (from b)) ⟩
    (suc (from b)) + (suc (from b))
  ≡⟨ +-suc-suc (from b) (from b) ⟩
    suc (suc ((from b) + (from b)))
  ≡⟨ cong (λ 2*fromb → suc (suc 2*fromb)) (sym (2*n≡n+n (from b))) ⟩
    suc (suc (2 * (from b)))
  ≡⟨ cong suc (+-comm 1 (2 * (from b))) ⟩
    suc (2 * (from b) + 1)
  ≡⟨⟩
    suc (from (b I))
  ∎

-- to∘from : ∀ (b : Bin) → to (from b) ≡ b
-- to∘from ⟨⟩ = {!!} -- (to zero) が (⟨⟩ O) にエンコードされるため成り立たない
-- to∘from (b O) = {!!}
-- to∘from (b I) = {!!}

from∘to : ∀ (n : ℕ) → from (to n) ≡ n
from∘to zero =
  begin
    from (to zero)
  ≡⟨⟩
    from (⟨⟩ O)
  ≡⟨⟩
    2 * (from ⟨⟩)
  ≡⟨⟩
    2 * zero
  ≡⟨⟩
    zero
  ∎
from∘to (suc n) =
  begin
    from (to (suc n))
  ≡⟨⟩
    from (inc (to n))
  ≡⟨ from∘inc≡suc∘from (to n) ⟩
    suc (from (to n))
  ≡⟨ cong suc (from∘to n) ⟩
    suc n
  ∎


module Data.Permutation where

open import Prelude
open import Data.Fin as Fin hiding (_==_; _<_)
open import Data.Nat
open import Data.Vec
open import Logic.Identity
open import Logic.Base
import Logic.ChainReasoning

-- What is a permutation?
-- Answer 1: A bijection between Fin n and itself

data Permutation (n : Nat) : Set where
  permutation :
    (π π⁻¹ : Fin n -> Fin n) ->
    (forall {i} -> π (π⁻¹ i) ≡ i) ->
    Permutation n

module Permutation {n : Nat}(P : Permutation n) where

  private
    π' : Permutation n -> Fin n -> Fin n
    π' (permutation x _ _) = x

    π⁻¹' : Permutation n -> Fin n -> Fin n
    π⁻¹' (permutation _ x _) = x

    proof : (P : Permutation n) -> forall {i} -> π' P (π⁻¹' P i) ≡ i
    proof (permutation _ _ x) = x

  π : Fin n -> Fin n
  π	  = π' P

  π⁻¹ : Fin n -> Fin n
  π⁻¹	  = π⁻¹' P

  module Proofs where

    ππ⁻¹-id : {i : Fin n} -> π (π⁻¹ i) ≡ i
    ππ⁻¹-id = proof P

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

    π⁻¹-inj : (i j : Fin n) -> π⁻¹ i ≡ π⁻¹ j -> i ≡ j
    π⁻¹-inj i j h =
      chain> i
	 === π (π⁻¹ i)	by sym ππ⁻¹-id
	 === π (π⁻¹ j)	by cong π h
	 === j		by ππ⁻¹-id

    -- Generalise
    lem : {n : Nat}(f g : Fin n -> Fin n)
	  -> (forall i -> f (g i) ≡ i)
	  -> (forall i -> g (f i) ≡ i)
    lem {zero}  f g inv ()
    lem {suc n} f g inv i  = ?
      where
	gz≠gs : {i : Fin n} -> g fzero ≢ g (fsuc i)
	gz≠gs {i} gz=gs = fzero≠fsuc $
	  chain> fzero
	     === f (g fzero)	 by sym (inv fzero)
	     === f (g (fsuc i))  by cong f gz=gs
	     === fsuc i		 by inv (fsuc i)

	z≠f-thin-gz : {i : Fin n} -> fzero ≢ f (thin (g fzero) i)
	z≠f-thin-gz {i} z=f-thin-gz = ?
-- 	  f (g fzero)
-- 	  = fzero
-- 	  = f (thin (g fzero) i)

	g' : Fin n -> Fin n
	g' j = thick (g fzero) (g (fsuc j)) gz≠gs

	f' : Fin n -> Fin n
	f' j = thick fzero (f (thin (g fzero) j)) ?

	g'f' : forall j -> g' (f' j) ≡ j
	g'f' = lem {n} f' g' ?

    π⁻¹π-id : forall {i} -> π⁻¹ (π i) ≡ i
    π⁻¹π-id = ?

-- Answer 2: A Vec (Fin n) n with no duplicates

{-
infixr 40 _◅_ _↦_,_
infixr 20 _○_

data Permutation : Nat -> Set where
  ε   : Permutation zero
  _◅_ : {n : Nat} -> Fin (suc n) -> Permutation n -> Permutation (suc n)

_↦_,_ : {n : Nat}(i j : Fin (suc n)) -> Permutation n -> Permutation (suc n)
fzero  ↦ j , π	    = j ◅ π
fsuc i ↦ j , j' ◅ π = thin j j' ◅ i ↦ ? , π

indices : {n : Nat} -> Permutation n -> Vec (Fin n) n
indices  ε	= []
indices (i ◅ π) = i :: map (thin i) (indices π)

-- permute (i ◅ π) xs with xs [!] i where
--   permute₁ (i ◅ π) .(insert i x xs) (ixV x xs) = x :: permute π xs

permute : {n : Nat}{A : Set} -> Permutation n -> Vec A n -> Vec A n
permute (i ◅ π) xs = permute' π i xs (xs [!] i)
  where
    permute' : {n : Nat}{A : Set} -> Permutation n -> (i : Fin (suc n))(xs : Vec A (suc n)) ->
	       IndexView i xs -> Vec A (suc n)
    permute' π i .(insert i x xs') (ixV x xs') = x :: permute π xs'

delete : {n : Nat} -> Fin (suc n) -> Permutation (suc n) -> Permutation n
delete		fzero    (j ◅ π) = π
delete {zero}  (fsuc ())  _
delete {suc _} (fsuc i)  (j ◅ π) = ? ◅ delete i π

identity : {n : Nat} -> Permutation n
identity {zero } = ε
identity {suc n} = fzero ◅ identity

_⁻¹ : {n : Nat} -> Permutation n -> Permutation n
ε	⁻¹ = ε
(i ◅ π) ⁻¹ = ?

_○_ : {n : Nat} -> Permutation n -> Permutation n -> Permutation n
ε      ○ π₂ = ε
i ◅ π₁ ○ π₂ = (indices π₂ ! i) ◅ (π₁ ○ delete i π₂)
-}


module List.Permutation.Pair.Properties (A : Set) where

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

lemma≈∼ : {xs ys zs : List A} → xs ≈ (ys , zs) → xs ∼ (ys ++ zs)
lemma≈∼ (≈[]l zs) = refl∼
lemma≈∼ (≈[]r ys) rewrite ((proj₂ (IsMonoid.identity (Monoid.isMonoid (monoid A)))) ys) = refl∼
lemma≈∼ (≈xr {ys = ys} xs∼ys,zs') = ∼x /head (lemma++/l {xs = ys} /head) (lemma≈∼ xs∼ys,zs')
lemma≈∼ (≈xl xs∼ys',zs) = ∼x /head /head (lemma≈∼ xs∼ys',zs)

lemma≈ : {xs ys zs ws ys' zs' : List A} → xs ≈ (ys , zs) → ys ∼ ys' → zs ∼ zs' → ws ≈ (ys' , zs') → xs ∼ ws
lemma≈ {xs} {ys} {zs} {ws} {ys'} {zs'} xs∼ys,zs ys∼ys' zs∼zs' ws∼ys',zs'
  =  begin
        xs
        ∼⟨ lemma≈∼ xs∼ys,zs  ⟩
        ys ++ zs
        ∼⟨ lemma++∼ ys∼ys' zs∼zs'  ⟩
        ys' ++ zs'
        ∼⟨ sym∼ (lemma≈∼ ws∼ys',zs')  ⟩
        ws
      ∎


module _^_ where

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

open import Naturals using (ℕ; zero; suc; _*_)

_^_ : ℕ → ℕ → ℕ
_ ^ zero    = 1
m ^ (suc n) = m * (m ^ n)

_ : 3 ^ 4 ≡ 81
_ =
  begin
    3 ^ 4
  ≡⟨⟩
    3 * (3 ^ 3)
  ≡⟨⟩
    3 * (3 * (3 ^ 2))
  ≡⟨⟩
    3 * (3 * (3 * (3 ^ 1)))
  ≡⟨⟩
    3 * (3 * (3 * (3 * (3 ^ 0))))
  ≡⟨⟩
    3 * (3 * (3 * (3 * 1)))
  ≡⟨⟩
    81
  ∎


module Data.List.Combinatorics where

import      Lvl
open import Data
open import Data.List
open import Data.List.Functions
open        Data.List.Functions.LongOper
open import Data.Tuple as Tuple using (_⨯_ ; _,_)
open import Data.Tuple.Raiseᵣ as Tuple₊ using (_^_)
import      Data.Tuple.Raiseᵣ.Functions as Tuple₊
open import Functional
open import Numeral.Natural
open import Type

private variable ℓ : Lvl.Level
private variable T : Type{ℓ}

-- A list of all non-empty sublists of the specified list.
-- The corresponding counting function is `(2 ^ n) − 1` where `n` is the length of the list.
-- Note:
--   In the inductive case, all of these are permutations of each other:
--   • `foldᵣ (prev ↦ rest ↦ (prev ⊰ (x ⊰ prev) ⊰ rest)) ∅ (sublists₊ l)` (This is used because of its "natural" order)
--   • `foldᵣ (prev ↦ rest ↦ ((x ⊰ prev) ⊰ prev ⊰ rest)) ∅ (sublists₊ l)`
--   • `(map (x ⊰_) (sublists₊ l)) ++ (sublists₊ l)`
--   • `(sublists₊ l) ++ (map (x ⊰_) (sublists₊ l))`
-- Examples:
--   sublists₊ []        = []
--   sublists₊ [1]       = [[1]]
--   sublists₊ [1,2]     = [[1],[2],[1,2]]
--   sublists₊ [1,2,3]   = [[1],[2],[1,2],[3],[1,3],[2,3],[1,2,3]]
--   sublists₊ [1,2,3,4] = [[1],[2],[1,2],[3],[1,3],[2,3],[1,2,3],[4],[1,4],[2,4],[1,2,4],[3,4],[1,3,4],[2,3,4],[1,2,3,4]]
sublists₊ : List(T) → List(List(T))
sublists₊ ∅       = ∅
sublists₊ (x ⊰ l) = singleton(x) ⊰ concatMap(y ↦ (y ⊰ (x ⊰ y) ⊰ ∅)) (sublists₊ l)

-- A list of all sublists of the specified list.
-- This is also the list of all subsets when the given list is a set (distinct elements).
-- The corresponding counting function is `2 ^ n` where `n` is the length of the list.
-- Examples:
--   sublists []        = [[]]
--   sublists [1]       = [[],[1]]
--   sublists [1,2]     = [[],[1],[2],[1,2]]
--   sublists [1,2,3]   = [[],[1],[2],[1,2],[3],[1,3],[2,3],[1,2,3]]
--   sublists [1,2,3,4] = [[],[1],[2],[1,2],[3],[1,3],[2,3],[1,2,3],[4],[1,4],[2,4],[1,2,4],[3,4],[1,3,4],[2,3,4],[1,2,3,4]]
sublists : List(T) → List(List(T))
sublists(l) = ∅ ⊰ sublists₊(l)

-- A list of all combinations of the specified size of the specified list.
-- The corresponding counting function is `𝑐𝐶(n,k)` where `n` is the length of the specified "multiset".
-- All subsets of size `n` from the set `l`.
-- Every unique subset of size n up to set equality.
-- This is also a list of all sublists of the specified size of the specified list.
-- Alternative definition that does not pass the termination checker:
--   combinations : ℕ → List(T) → List(List(T))
--   combinations 0         _ = ∅
--   combinations _         ∅ = ∅
--   combinations 1         l = map singleton l
--   combinations (𝐒(𝐒(n))) l = concat(map f(tails l)) where
--     f : List(T) → List(List(T))
--     f ∅      = ∅
--     f(x ⊰ l) = map (x ⊰_) (combinations (𝐒(n)) l)
-- Examples:
--   combinations _ []          = []
--   combinations 0 [a,b,c,...] = [[]]              when the list is non-empty
--   combinations 1 [a,b,c,...] = [[a],[b],[c],...] when the list is non-empty
--   combinations n l           = []  when (n ≥ length(l))
--   combinations n l           = [l] when (n = length(l))
--   combinations 2 [a,b,c]     = [[a,b],[a,c],[b,c]]
--   combinations 2 [a,b,c,d]   = [[a,b],[a,c],[a,d],[b,c],[b,d],[c,d]]
--   combinations 2 [a,b,c,d,e] = [[a,b],[a,c],[a,d],[a,e],[b,c],[b,d],[b,e],[c,d],[c,e],[d,e]]
--   combinations 3 [a,b,c,d]   = [[a,b,c],[a,b,d],[a,c,d],[b,c,d]]
--   combinations 3 [a,b,c,d,e] = [[a,b,c],[a,b,d],[a,b,e],[a,c,d],[a,c,e],[a,d,e],[b,c,d],[b,c,e],[b,d,e],[c,d,e]]
--   combinations 4 [a,b,c,d,e] = [[a,b,c,d],[a,b,c,e],[a,b,d,e],[a,c,d,e],[b,c,d,e]]
combinations : (k : ℕ) → List(T) → List(T ^ k)
combinations 0         _         = singleton(<>)
combinations (𝐒(_))    ∅         = ∅
combinations 1         l@(_ ⊰ _) = l
combinations (𝐒(𝐒(k))) (x ⊰ l)   = (map(x ,_) (combinations (𝐒(k)) l)) ++ (combinations(𝐒(𝐒(k))) l)

-- The corresponding counting function is `𝑐𝐶(n + k − 1 , k)` where `n` is the length of the specified "multiset".
-- Examples:
--   repeatableCombinations _ []          = []
--   repeatableCombinations 0 [a,b,c,...] = [[]]              when the list is non-empty
--   repeatableCombinations 1 [a,b,c,...] = [[a],[b],[c],...] when the list is non-empty
--   repeatableCombinations n [a]         = [repeat n a]
--   repeatableCombinations 2 [a,b]       = [[a,a],[a,b],[b,b]]
--   repeatableCombinations 2 [a,b,c]     = [[a,a],[a,b],[a,c],[b,b],[b,c],[c,c]]
--   repeatableCombinations 3 [a,b]       = [[a,a,a],[a,a,b],[a,b,b],[b,b,b]]
--   repeatableCombinations 3 [a,b,c]     = [[a,a,a],[a,a,b],[a,a,c],[a,b,b],[a,b,c],[a,c,c],[b,b,b],[b,b,c],[b,c,c],[c,c,c]]
--   repeatableCombinations 4 [a,b]       = [[a,a,a,a],[a,a,a,b],[a,a,b,b],[a,b,b,b],[b,b,b,b]]
--   repeatableCombinations 4 [a,b,c]     = [[a,a,a,a],[a,a,a,b],[a,a,a,c],[a,a,b,b],[a,a,b,c],[a,a,c,c],[a,b,b,b],[a,b,b,c],[a,b,c,c],[a,c,c,c],[b,b,b,b],[b,b,b,c],[b,b,c,c],[b,c,c,c],[c,c,c,c]]
repeatableCombinations : (k : ℕ) → List(T) → List(T ^ k)
repeatableCombinations 0         _         = singleton(<>)
repeatableCombinations (𝐒(_))    ∅         = ∅
repeatableCombinations 1         l@(_ ⊰ _) = l
repeatableCombinations (𝐒(𝐒(k))) (x ⊰ l)   = (map (x ,_) (repeatableCombinations (𝐒(k)) (x ⊰ l))) ++ (repeatableCombinations (𝐒(𝐒(k))) l)

-- A list of all tuples of length `n` from the "multiset" `l`.
-- Every tuple combination of length `n`.
-- The corresponding counting function is `k ^ n` where `k` is the length of the list.
-- Examples:
--   tuples 0 [a]     = [()]
--   tuples 1 [a]     = [a]
--   tuples 2 [a]     = [(a,a)]
--   tuples 0 [a,b]   = [()]
--   tuples 1 [a,b]   = [a,b]
--   tuples 2 [a,b]   = [(a,a) , (a,b) , (b,a) , (b,b)]
--   tuples 0 [a,b,c] = [()]
--   tuples 1 [a,b,c] = [a,b,c]
--   tuples 2 [a,b,c] = [(a,a) , (a,b) , (a,c) , (b,a) , (b,b) , (b,c) , (c,a) , (c,b), (c,c)]
tuples : (n : ℕ) → List(T) → List(T ^ n)
tuples 0           = const(singleton(<>))
tuples 1           = id
tuples (𝐒(𝐒(n))) l = concatMap(x ↦ map (Tuple₊.prepend x) (tuples (𝐒(n)) l)) l

-- A list of all rotations of a list.
-- Examples:
--   rotations []        = []
--   rotations [a]       = [[a]]
--   rotations [a,b]     = [[a,b] , [b,a]]
--   rotations [a,b,c]   = [[a,b,c] , [b,c,a] , [c,a,b]]
--   rotations [a,b,c,d] = [[a,b,c,d] , [b,c,d,a] , [c,d,a,b] , [d,a,b,c]]
rotations : List(T) → List(List(T))
rotations l = accumulateIterate₀(length l) (rotateₗ(1)) l

-- Accumulated `insertAt` for every position of the given list.
-- Examples:
--   insertedEverywhere i []        = [[i]]
--   insertedEverywhere i [a]       = [[i,a],[a,i]]
--   insertedEverywhere i [a,b]     = [[i,a,b],[a,i,b],[a,b,i]]
--   insertedEverywhere i [a,b,c]   = [[i,a,b,c],[a,i,b,c],[a,b,i,c],[a,b,c,i]]
--   insertedEverywhere i [a,b,c,d] = [[i,a,b,c,d],[a,i,b,c,d],[a,b,i,c,d],[a,b,c,i,d],[a,b,c,d,i]
insertedEverywhere : T → List(T) → List(List(T))
insertedEverywhere i ∅       = singleton(singleton i)
insertedEverywhere i (x ⊰ l) = (i ⊰ x ⊰ l) ⊰ (map (prepend x) (insertedEverywhere i l))

-- Every reordering of the list's elements.
-- Examples:
--   permutations []        = [[]]
--   permutations [a]       = [[a]]
--   permutations [a,b]     = [[a,b],[b,a]]
--   permutations [a,b,c]   = [[a,b,c],[b,a,c],[b,c,a],[a,c,b],[c,a,b],[c,b,a]]
--   permutations [a,b,c,d] = [[a,b,c,d],[b,a,c,d],[b,c,a,d],[b,c,d,a],[a,c,b,d],[c,a,b,d],[c,b,a,d],[c,b,d,a],[a,c,d,b],[c,a,d,b],[c,d,a,b],[c,d,b,a],[a,b,d,c],[b,a,d,c],[b,d,a,c],[b,d,c,a],[a,d,b,c],[d,a,b,c],[d,b,a,c],[d,b,c,a],[a,d,c,b],[d,a,c,b],[d,c,a,b],[d,c,b,a]]
permutations : List(T) → List(List(T))
permutations ∅               = singleton(∅)
permutations (x ⊰ ∅)         = singleton(singleton x)
permutations (x ⊰ l@(_ ⊰ _)) = concatMap (insertedEverywhere x) (permutations l)


module Nat1 where

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

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

open import Equality
one   = succ zero
two   = succ one
three = succ two

0-is-id : ∀ (n : ℕ) → (n + zero) ≡ n
0-is-id zero     =
  begin
    (zero + zero) ≈ zero by definition
  ∎
0-is-id (succ y) =
  begin
    (succ y + zero) ≈ succ (y + zero) by definition
                    ≈ succ y          by cong succ (0-is-id y)
  ∎

+-assoc : ∀ (a b c : ℕ) → (a + b) + c ≡ a + (b + c)
+-assoc zero     b c = definition
+-assoc (succ a) b c =
  begin ((succ a + b) + c)
               ≈ succ (a + b) + c by definition
               ≈ succ ((a + b) + c) by definition
               ≈ succ (a + (b + c)) by cong succ (+-assoc a b c)
               ≈ succ a + (b + c) by definition
  ∎
{-
+-assoc zero     b c     = definition
+-assoc (succ a) b c     =
  begin ((succ a + b) + c)
               ≈ succ (a + b)  + c   by definition
               ≈ succ ((a + b) + c)  by definition
               ≈ succ (a  + (b + c)) by cong succ (+-assoc a b c)
               ≈ succ a   + (b + c)  by definition
  ∎
-}


open import Data.Nat using (_+_; _*_; zero; suc; ℕ)
open import Relation.Binary.PropositionalEquality as PropEq
  using (_≡_; _≢_; refl; cong)
import Data.Nat.Properties
open Data.Nat.Properties.SemiringSolver
  using (solve; _:=_; con; var; _:+_; _:*_; :-_; _:-_)
open PropEq.≡-Reasoning

lem1 : (4 + 6 ≡ 10)
lem1 = refl

lem3 : (x : ℕ) → (2 * (x + 4) ≡ 8 + 2 * x)
lem3 = solve 1 (λ x' → con 2 :* (x' :+ con 4) := con 8 :+ con 2 :* x') refl

sum : ℕ → ℕ
sum zero    = 0
sum (suc n) = 1 + 2 * n + sum n

theorem : (n : ℕ) → (sum n ≡ n * n)
theorem 0       = refl
theorem (suc p) =
  begin
    sum (suc p)
  ≡⟨ refl ⟩
    1 + 2 * p + sum p
  ≡⟨ cong (λ x → 1 + 2 * p + x)  (theorem p)⟩
    1 + 2 * p + p * p
  ≡⟨ solve 1 (λ p → con 1 :+ con 2 :* p :+ p :* p := (con 1 :+ p) :* (con 1 :+ p)) refl p ⟩
    (1 + p) * (1 + p)
  ≡⟨ refl ⟩
    (suc p) * (suc p)
  ∎


module Type.Properties.MereProposition {ℓ ℓₑ} where

import      Lvl
open import Lang.Instance
open import Structure.Setoid
open import Type

-- A type is a mere proposition type when there is at most one inhabitant (there is at most one object with this type).
-- In other words: If there is an inhabitant of type T, it is unique (essentially only allowing empty or singleton types, but this is not provable (excluded middöe)).
-- Also called:
-- • "Irrelevance" / "Irrelevancy" / "Proof irrelevance" (in the context of proofs).
--   A proof of the proposition T is unique (using equality to determine uniqueness).
-- • "isProp" / "h-proposition" / "is of h-level 1" / "a mere proposition" (in homotopy type theory).
--   Classically, when MereProposition(T), T is either empty or a singleton (which in the context of proofs corresponds to types isomorphic to ⊥ or ⊤).
-- • "subsingleton" (in set theory)
--   When a type and its inhabitants is interpreted as a set and its elements.
-- • "subterminal object" (in category theory).
module _ (T : Type{ℓ}) ⦃ _ : Equiv{ℓₑ}(T) ⦄ where
  record MereProposition : Type{ℓ Lvl.⊔ ℓₑ} where
    constructor intro
    field uniqueness : ∀{x y : T} → (x ≡ y)
  uniqueness = inst-fn MereProposition.uniqueness

-- TODO: Consider using unicode ◐○●⧭⦵⦳


module x00-playpen where

-- prove properties of inductive naturals and operations on them via induction

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

*-assoc : ∀ (m n p : ℕ)
        → (m *  n) * p
        ≡  m * (n  * p)
*-assoc m n p = {!!}

+-xx : ∀ (n  : ℕ)
       → (n ^ 3) ∸ ((n * n) * n)
       ≡ zero
+-xx zero = refl
+-xx (suc n) = {!!}
{-
  begin
              (n * (n ^ 2))   ∸ ((n * n) * n)
  ≡⟨⟩
         (n * (n * (n ^ 1)))  ∸ ((n * n) * n)
  ≡⟨⟩
    (n * (n * (n * (n ^ 0)))) ∸ ((n * n) * n)
  ≡⟨⟩
    (n * (n * (n *  1     ))) ∸ ((n * n) * n)
  ≡⟨⟩
    (n * (n *  n          ))  ∸ ((n * n) * n)
  ≡⟨ cong ( ((n * (n *  n))) ∸_) (*-assoc n n n) ⟩
    (n * (n *  n          ))  ∸ ( n * (n * n))
  ∎
-}


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

module hott.core.univalence  where

open import hott.core.universe
open import hott.functions
open import hott.core.equality
open import hott.core.sigma

-- The core idea of univalence is to "identify" isomorphic types as
-- equal. Of course the normal definition of isomorphism is that there
-- should be a map from A to B that is witnesses the equivalence of the
-- two type. This is captured by the following record.
record _≃_  {a b : Level}(A : Type a)(B : Type b) : Type (a ⊔ b) where

  constructor IdentifyTypesVia
  field
    equiv     : (A → B)  -- The equivalence
    left-inv  : (B → A)  -- its left inverse
    right-inv : (B → A)  -- and its right inverse

    -- The proofs of the fact that the left and right inverses are actually
    -- left and right inverses.
    left-inv∘equiv~idA  : left-inv ∘ equiv ~ id
    iso∘right-equiv~idB : equiv    ∘ right-inv ~ id

-- Of course a type should be equivalent to itself via identity.
A≃A : {ℓ : Level}{A : Type ℓ} → A ≃ A
A≃A {ℓ} {A} = IdentifyTypesVia id id id (λ _ →  refl) (λ _ → refl)

-- Equal types are equivalent.
≡→≃ : {ℓ : Level}{A B : Type ℓ} → A ≡ B → A ≃ B
≡→≃ refl = A≃A

-- For the converse we need the univalence. However Univalence says
-- something. Not only can we infer A ≡ B from A ≃ B via the postulate
-- ua, this map together with ≡→≃ gives an equivalence of types.
module Univalence {ℓ : Level}{A B : Type ℓ} where

  -- The main axiom is to identify A ≃ B with A ≡ B
  postulate ua : A ≃ B → A ≡ B

  -- Now we are ready for the univalence axiom.
  UnivalenceAxiom : (A ≃ B) ≃ (A ≡ B)
  UnivalenceAxiom = IdentifyTypesVia ua ≡→≃ ≡→≃ linv-prf rinv-prf
    where postulate rinv-prf :  ua ∘ ≡→≃ ~ id
          postulate linv-prf :  ≡→≃ ∘ ua ~ id

  -- The next function helps in clean use of the univalence
  -- axioms in equational reasoning.
  --
  --
  -- begin ...
  --       ≡    B by univalence
  --       ...
  --
  -- provided an appropriate instance of A ≃ B is available in the
  -- vicinity.
  --
  univalence : ⦃ a≃b : A ≃ B ⦄ → A ≡ B
  univalence ⦃ a≃b ⦄ = ua a≃b

open Univalence public


-- Solutions to ExerciseSession2
{-# OPTIONS --cubical #-}
module SolutionsSession2 where

open import Part1
open import Part2
open import ExerciseSession1

-- Exercise 1
JEq : {x : A} (P : (z : A) → x ≡ z → Type ℓ'')
      (d : P x refl) → J P d refl ≡ d
JEq P p d = transportRefl p d

-- Exercise 2
isContr→isProp : isContr A → isProp A
isContr→isProp (x , p) a b = sym (p a) ∙ p b

-- Exercise 3
isProp→isProp' : isProp A → isProp' A
isProp→isProp' p x y = p x y , isProp→isSet p _ _ (p x y)

-- Exercise 4
isContr→isContr≡ : isContr A → (x y : A) → isContr (x ≡ y)
isContr→isContr≡ h = isProp→isProp' (isContr→isProp h)

-- Exercise 5
fromPathP : {A : I → Type ℓ} {x : A i0} {y : A i1}
          → PathP A x y
          → transport (λ i → A i) x ≡ y
fromPathP {A = A} p i = transp (λ j → A (i ∨ j)) i (p i)

-- The converse is harder to prove so we give it:
toPathP : {A : I → Type ℓ} {x : A i0} {y : A i1}
        → transport (λ i → A i) x ≡ y
        → PathP A x y
toPathP {A = A} {x = x} p i =
  hcomp (λ j → λ { (i = i0) → x
                 ; (i = i1) → p j })
        (transp (λ j → A (i ∧ j)) (~ i) x)

-- Exercise 6
Σ≡Prop : {B : A → Type ℓ'} {u v : Σ A B} (h : (x : A) → isProp (B x))
       → (p : fst u ≡ fst v) → u ≡ v
Σ≡Prop {B = B} {u = u} {v = v} h p =
  ΣPathP (p , toPathP (h _ (transport (λ i → B (p i)) (snd u)) (snd v)))

-- Exercice 7 (thanks Loïc for the slick proof!)
isPropIsContr : isProp (isContr A)
isPropIsContr (c0 , h0) (c1 , h1) j =
  h0 c1 j , λ y i → hcomp (λ k → λ { (i = i0) → h0 (h0 c1 j) k;
                                     (i = i1) → h0 y k;
                                     (j = i0) → h0 (h0 y i) k;
                                     (j = i1) → h0 (h1 y i) k}) c0

-- Exercises about Part 3:

-- Exercise 8 (a bit longer, but very good):

open import Cubical.Data.Nat
open import Cubical.Data.Int hiding (addEq ; subEq)

-- Compose sucPathInt with itself n times. Transporting along this
-- will be addition, transporting with it backwards will be subtraction.

-- a) Define a path "addEq n" by composing sucPathInt with itself n
-- times.
addEq : ℕ → Int ≡ Int
addEq zero = refl
addEq (suc n) = (addEq n) ∙ sucPathInt

-- b) Define another path "subEq n" by composing "sym sucPathInt" with
-- itself n times.
subEq : ℕ → Int ≡ Int
subEq zero = refl
subEq (suc n) = (subEq n) ∙ sym sucPathInt

-- c) Define addition on integers by pattern-matching and transporting
-- along addEq/subEq appropriately.
_+Int_ : Int → Int → Int
m +Int pos n    = transport (addEq n) m
m +Int negsuc n = transport (subEq (suc n)) m

-- d) Do some concrete computations using _+Int_ (this would not work
-- in HoTT as the transport would be stuck!)

-- Exercise 9: prove that hSet is not an hSet

open import Cubical.Data.Bool renaming (notEq to notPath)
open import Cubical.Data.Empty

-- Just define hSets of level 0 for simplicity
hSet : Type₁
hSet = Σ[ A ∈ Type₀ ] isSet A

-- Bool is an hSet
BoolSet : hSet
BoolSet = Bool , isSetBool

notPath≢refl : (notPath ≡ refl) → ⊥
notPath≢refl e = true≢false (transport (λ i → transport (e i) true ≡ false) refl)

¬isSet-hSet : isSet hSet → ⊥
¬isSet-hSet h = notPath≢refl (cong (cong fst) (h BoolSet BoolSet p refl))
 where
 p : BoolSet ≡ BoolSet
 p = Σ≡Prop (λ A → isPropIsSet {A = A}) notPath

-- Exercise 10: squivalence between FinData and Fin

-- Thanks to Elies for the PR with the code. On the development
-- version of the library there is now:
--
-- open import Cubical.Data.Fin using (FinData≡Fin)


module plfa-exercises.Practice where

--------------------------------------- Naturals ---------------------------------------

-- Inductive definition of Numbers (new datatype)
data ℕ : Set where
-- Judgements (two in total for this case)
  zero : ℕ       -- No hypothesis and one conclusion
  suc  : ℕ → ℕ   -- One hypothesis and one conclusion

seven : ℕ
seven = suc (suc (suc (suc (suc (suc (suc zero))))))
--seven′ = --7

pred : ℕ → ℕ
pred zero = zero
pred (suc n) = n

---

-- Gives us the power of writing 3 to signify suc (suc (suc zero)) :)
{-# BUILTIN NATURAL ℕ #-}

import Relation.Binary.PropositionalEquality as Eq
open Eq using (_≡_; _≢_; refl; cong; sym; trans)
open Eq.≡-Reasoning using (begin_; _≡⟨⟩_; _≡⟨_⟩_; _∎)
open import Function.Base using (flip)
open import Relation.Nullary using (¬_)
open import Data.Empty using (⊥; ⊥-elim)
open import Data.Product using (_×_; ∃-syntax) renaming (_,_ to ⟨_,_⟩)
open import Data.Sum using (_⊎_; inj₁; inj₂)

_+_ : ℕ → ℕ → ℕ
zero + n = n                -- +-def₀
(suc m) + n = suc (m + n)   -- +-def₁

--_ : (suc (suc zero)) + (suc (suc (suc zero))) ≡ (suc (suc (suc (suc (suc zero)))))
--_ =
--  begin
--    (suc (suc zero)) + (suc (suc (suc zero)))
--  ≡⟨⟩    -- inductive case
--    suc ((suc zero) + (suc (suc (suc zero))))
--  ≡⟨⟩    -- inductive case
--    suc (suc (zero + (suc (suc (suc zero)))))
--  ≡⟨⟩    -- base case
--    suc (suc (suc (suc (suc zero))))
--  ∎
--
--_ : 2 + 3 ≡ 5
--_ =
--  begin
--    2 + 3
--    (suc 1) + 3
--  ≡⟨⟩
--    suc (1 + 3)
--  ≡⟨⟩
--    suc (suc 0 + 3)
--  ≡⟨⟩
--    suc (suc (0 + 3))
--  ≡⟨⟩
--    suc (suc 3)
--  ≡⟨⟩
--    suc 4
--  ≡⟨⟩
--    5
--  ∎
--
--
--_ : (suc (suc zero)) + (suc (suc (suc zero))) ≡ (suc (suc (suc (suc (suc zero)))))
--_ = refl

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

_^_ : ℕ → ℕ → ℕ
n ^ zero  =  suc zero
n ^ (suc m)  =  n * (n ^ m)

-- Monus
_∸_ : ℕ → ℕ → ℕ
m     ∸ zero   =  m
zero  ∸ suc n  =  zero
suc m ∸ suc n  =  m ∸ n

infixl 6  _+_  _∸_
infixl 7  _*_
infixr 8  _^_

-- Superfun binary numbers :D
data Bin : Set where
  ⟨⟩ : Bin
  _O : Bin → Bin
  _I : Bin → Bin

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

_ : inc (⟨⟩ I O I I) ≡ ⟨⟩ I I O O
_ = refl

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

fromᵇ : Bin → ℕ
fromᵇ ⟨⟩ = zero
fromᵇ (b O) = let n = fromᵇ b in n + n
fromᵇ (b I) = let n = fromᵇ b in suc (n + n)

_ : toᵇ 11 ≡ (⟨⟩ I O I I)
_ = refl

_ : fromᵇ (inc (⟨⟩ I O I I)) ≡ 12
_ = refl
--_ = begin
--      (fromᵇ (⟨⟩ I I O O))
--    ≡⟨ 12 ≡⟨⟩ 12 ∎ ⟩
--      12
--    ∎

--_ : Set₉₁₁₁₁₁₁₁₁₁₁₁₁₁₁₁₁₁₁₁₁
--_ : Set₀
_ : Set
_ = suc 11 ≡ 12

_+ᵇ_ : Bin → Bin → Bin
⟨⟩    +ᵇ b     = b
b     +ᵇ ⟨⟩    = b
--(b O) +ᵇ ⟨⟩    = b O
(b O) +ᵇ (d O) = (b +ᵇ d) O
(b O) +ᵇ (d I) = (b +ᵇ d) I
--(b I) +ᵇ ⟨⟩    = b I
(b I) +ᵇ (d O) = (b +ᵇ d) I
(b I) +ᵇ (d I) = (inc (b +ᵇ d)) O

-- Proving the following is trivial
mod-left : ∀ {b : Bin} → ⟨⟩ +ᵇ b ≡ b
mod-left = refl
-- But not its complement. This is due to "case trees" (or how Agda implements
-- functions under the hood)
-- https://agda.readthedocs.io/en/v2.6.0.1/language/function-definitions.html#case-trees
mod-right : ∀ {b : Bin} → b +ᵇ ⟨⟩ ≡ b
mod-right {⟨⟩}  = refl
mod-right {b O} = refl
mod-right {b I} = refl
-- Also, I'm confused on the implications of improper "case trees". If the
-- second rule wasn't reachable, the following code would run even
-- if the rule was nonesense (eg, changing `b +ᵇ ⟨⟩ = b O O`) but it doesn't
-- work! The rule must make sense. So, Agda is applying the rule after all and
-- not ignoring it even thought it can't be reached directly in proofs
_ : (⟨⟩ I O I I I) +ᵇ (⟨⟩ O O I) ≡ ⟨⟩ I I O O O
_ = refl

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

-- Taken it from book
assoc-+ : ∀ (m n p : ℕ) → (m + n) + p ≡ m + (n + p)
assoc-+ zero n p = refl
assoc-+ (suc m) n p rewrite assoc-+ m n p = refl

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

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

comm-+ : ∀ (n m : ℕ) → n + m ≡ m + n
comm-+ zero n = sym (comm-+₀ n)
comm-+ (suc n) m rewrite comm-+ n m | succ_right m n = refl
--comm-+ (suc n) m = trans (cong suc (comm-+ n m)) (succ_right m n)
--comm-+ (suc n) m =
--  begin
--    suc n + m
--  ≡⟨⟩ -- +-def₁
--    suc (n + m)
--  ≡⟨ cong suc (comm-+ n m) ⟩
--    suc (m + n)
--  ≡⟨ succ_right m n ⟩
--    m + suc n
--  ∎

-- Try evaluating and type-checking the following expressions:
-- comm-+ zero
-- (flip comm-+) zero
-- λ n m → cong suc (comm-+ n m)
-- λ m n → succ_right m n
-- λ m n → sym (succ_right m n)
-- λ n m → trans (cong suc (comm-+ n m)) (succ_right m n)

monus : ∀ (n : ℕ) → zero ∸ n ≡ zero
monus zero = refl
monus (suc n) = refl
--monus : ∀ {n : ℕ} → zero ∸ n ≡ zero
--monus {zero} = refl
--monus {suc n} = refl

inc≡suc : ∀ (b : Bin) → fromᵇ (inc b) ≡ suc (fromᵇ b)
inc≡suc ⟨⟩ = refl
inc≡suc (b O) rewrite sym (comm-+₀ (fromᵇ b)) = refl
inc≡suc (b I)
  rewrite
    comm-+₀ (fromᵇ (inc b))
  | inc≡suc b
  | succ_right (fromᵇ b) (fromᵇ b)
  | comm-+₀ (fromᵇ b)
  | succ_right (fromᵇ b) (fromᵇ b) = refl

-- `toᵇ (fromᵇ b) ≡ b` doesn't hold for all values, just for some.
-- So the following is false
--tofromb≢b : ∀ (b : Bin) → ¬ (toᵇ (fromᵇ b) ≡ b)
--tofromb≢b ⟨⟩ = λ()
--tofromb≢b = ? -- impossible to prove

_ : ¬ (toᵇ (fromᵇ ⟨⟩) ≡ ⟨⟩)
_ = λ()

--from∘toᵇ₀ : ∀ (n : ℕ) → fromᵇ ((toᵇ n) O) ≡ fromᵇ (toᵇ n) + fromᵇ (toᵇ n)
--from∘toᵇ₀ zero = refl
--from∘toᵇ₀ (suc n) = refl
--
--from∘toᵇ₁ : ∀ (n : ℕ) → fromᵇ ((toᵇ n) I) ≡ suc (fromᵇ (toᵇ n) + fromᵇ (toᵇ n))
--from∘toᵇ₁ zero = refl
--from∘toᵇ₁ (suc n) = refl

monobin₀ : ∀ (b : Bin) → inc (inc (b +ᵇ b)) ≡ (inc b +ᵇ inc b)
monobin₀ ⟨⟩ = refl
monobin₀ (b O) = refl
monobin₀ (b I) rewrite monobin₀ b = refl

monobin : ∀ (n : ℕ) → toᵇ (n + n) ≡ (toᵇ n) +ᵇ (toᵇ n)
monobin zero = refl
monobin (suc n) rewrite
    sym (succ_right n n)
  | monobin n
  | monobin₀ (toᵇ n) = refl

--mononat₀ : ∀ (a : Bin) → a +ᵇ ⟨⟩ ≡ a
--mononat₀ ⟨⟩ = refl
--mononat₀ (b O) = refl
--mononat₀ (b I) = refl
--
--mononat₁ : ∀ (a b : Bin) → fromᵇ (inc (a +ᵇ b)) ≡ suc (fromᵇ a + fromᵇ b)
--mononat₁ ⟨⟩ b rewrite inc≡suc b = refl
--mononat₁ a ⟨⟩ rewrite mononat₀ a | comm-+₀ (fromᵇ a) | inc≡suc a = refl
--mononat₁ = ?
---- λ a → fromᵇ (inc (a +ᵇ ⟨⟩)) ≡ suc (fromᵇ a + fromᵇ ⟨⟩)
---- fromᵇ (inc b) ≡ suc (fromᵇ b)
--
--mononat : ∀ (a b : Bin) → fromᵇ (a +ᵇ b) ≡ fromᵇ a + fromᵇ b
--mononat ⟨⟩ _ = refl
--mononat a ⟨⟩ rewrite mononat₀ a | comm-+₀ (fromᵇ a) = refl
----mononat a ⟨⟩ =
----  begin
----    fromᵇ (a +ᵇ ⟨⟩)
----    ≡⟨ cong fromᵇ (mononat₀ a) ⟩
----    fromᵇ (a)
----    ≡⟨ sym (comm-+₀ (fromᵇ a)) ⟩
----    fromᵇ a + zero
----    ≡⟨⟩
----    fromᵇ a + fromᵇ ⟨⟩
----  ∎
--mononat (a O) (b O) rewrite
--    mononat a b
--  | assoc-+ (fromᵇ a) (fromᵇ b) (fromᵇ a + fromᵇ b)
--  | comm-+ (fromᵇ b) (fromᵇ a + fromᵇ b)
--  | assoc-+ (fromᵇ a) (fromᵇ a) (fromᵇ b + fromᵇ b)
--  | assoc-+ (fromᵇ a) (fromᵇ b) (fromᵇ b)
--  = refl
--mononat (a I) (b O) rewrite
--    mononat a b
--  | assoc-+ (fromᵇ a) (fromᵇ b) (fromᵇ a + fromᵇ b)
--  | comm-+ (fromᵇ b) (fromᵇ a + fromᵇ b)
--  | assoc-+ (fromᵇ a) (fromᵇ a) (fromᵇ b + fromᵇ b)
--  | assoc-+ (fromᵇ a) (fromᵇ b) (fromᵇ b)
--  = refl
--mononat (a O) (b I) rewrite
--    mononat a b
--  | sym (succ_right (fromᵇ a + fromᵇ a) (fromᵇ b + fromᵇ b))
--  | assoc-+ (fromᵇ a) (fromᵇ b) (fromᵇ a + fromᵇ b)
--  | comm-+ (fromᵇ b) (fromᵇ a + fromᵇ b)
--  | assoc-+ (fromᵇ a) (fromᵇ a) (fromᵇ b + fromᵇ b)
--  | assoc-+ (fromᵇ a) (fromᵇ b) (fromᵇ b)
--  = refl
--mononat (a I) (b I) rewrite
--    mononat₁ a b
--  | sym (succ_right (fromᵇ a + fromᵇ a) (fromᵇ b + fromᵇ b))
--  | sym (succ_right (fromᵇ a + fromᵇ b) (fromᵇ a + fromᵇ b))
--  | assoc-+ (fromᵇ a) (fromᵇ b) (fromᵇ a + fromᵇ b)
--  | comm-+ (fromᵇ b) (fromᵇ a + fromᵇ b)
--  | assoc-+ (fromᵇ a) (fromᵇ a) (fromᵇ b + fromᵇ b)
--  | assoc-+ (fromᵇ a) (fromᵇ b) (fromᵇ b)
--  = refl

-- Really hard!! Keep working on it!
-- IT WASN'T HARD!!! I JUST COULDN'T SEE THE RIGHT REWRITE!!
from∘toᵇ : ∀ (n : ℕ) → fromᵇ (toᵇ n) ≡ n
from∘toᵇ zero = refl
from∘toᵇ (suc n) rewrite inc≡suc (toᵇ n) | from∘toᵇ n = refl
--from∘toᵇ (suc n) =
--  begin
--    fromᵇ (toᵇ (suc n))
--  ≡⟨⟩
--    fromᵇ (inc (toᵇ n))
--  ≡⟨ inc≡suc (toᵇ n) ⟩
--    suc (fromᵇ (toᵇ n))
--  ≡⟨ cong suc (from∘toᵇ n) ⟩
--    suc n
--  ∎

swap-m-n-+ : ∀ (m n p) → m + (n + p) ≡ n + (m + p)
swap-m-n-+ m n p rewrite
    sym (assoc-+ m n p)
  | sym (assoc-+ n m p)
  | comm-+ m n
  = refl

right-zero-* : ∀ (n : ℕ) → n * 0 ≡ 0
right-zero-* zero    = refl
right-zero-* (suc n) rewrite right-zero-* n = refl

suc-right-* : ∀ (m n) → m * suc n ≡ m + m * n
suc-right-* zero n = refl
suc-right-* (suc m) n
  rewrite
    suc-right-* m n
  | sym (assoc-+ n m (m * n))
  | comm-+ n m
  | assoc-+ m n (m * n)
  = refl

comm-* : ∀ (m n : ℕ) → m * n ≡ n * m
comm-* zero n rewrite right-zero-* n = refl
comm-* (suc m) n
  rewrite
    comm-* m n
  | suc-right-* n m
  = refl

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

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

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

swap-m-n-* : ∀ (m n p) → m * (n * p) ≡ n * (m * p)
swap-m-n-* m n p rewrite
    sym (assoc-* m n p)
  | sym (assoc-* n m p)
  | comm-* m n
  = refl

distr-^-* : ∀ (m n p) → (m * n) ^ p ≡ (m ^ p) * (n ^ p)
--distr-^-* m n zero    =
--  begin
--    (m * n) ^ zero
--  ≡⟨⟩
--    (m * n) ^ 0
--  ≡⟨⟩
--    suc 0
--  ≡⟨⟩
--    1
--  ≡⟨⟩
--    1 + 0
--  ≡⟨⟩
--    1 + 0 * 1
--  ≡⟨⟩
--    (suc 0) * 1
--  ≡⟨⟩
--    (suc 0) * 1
--  ≡⟨⟩
--    1 * 1
--  ≡⟨⟩
--    1 * (n ^ 0)
--  ≡⟨⟩
--    (m ^ zero) * (n ^ zero)
--  ≡⟨⟩
--    (m ^ 0) * (n ^ 0)
--  ∎
distr-^-* _       _       zero    = refl
distr-^-* zero    zero    (suc p) = refl
distr-^-* zero    (suc n) (suc p) = refl
distr-^-* (suc m) zero    (suc p)
  rewrite
    right-zero-* (suc m ^ suc p)
  | right-zero-* m
  = refl
distr-^-* (suc m) (suc n) (suc p)
  rewrite
--  (suc m * suc n) ^ suc p ≡ suc m ^ suc p * suc n ^ suc p
--
--    suc (n + m * suc n) ^ p + (n + m * suc n) * suc (n + m * suc n) ^ p
--  ≡ (suc m ^ p + m * suc m ^ p) * (suc n ^ p + n * suc n ^ p)
    distr-*-+ (suc m ^ p) (m * suc m ^ p) (suc n ^ p + n * suc n ^ p)
--    suc (n + m * suc n) ^ p + (n + m * suc n) * suc (n + m * suc n) ^ p
--  ≡
--    suc m ^ p * (suc n ^ p + n * suc n ^ p)
--    + m * suc m ^ p * (suc n ^ p + n * suc n ^ p)
  | assoc-* m (suc m ^ p) (suc n ^ p + n * suc n ^ p)
--    suc (n + m * suc n) ^ p + (n + m * suc n) * suc (n + m * suc n) ^ p
--  ≡
--    suc m ^ p * (suc n ^ p + n * suc n ^ p)
--    + m * (suc m ^ p * (suc n ^ p + n * suc n ^ p))
  | distl-*-+ (suc m ^ p) (suc n ^ p) (n * suc n ^ p)
--    suc (n + m * suc n) ^ p + (n + m * suc n) * suc (n + m * suc n) ^ p
--  ≡
--    suc m ^ p * suc n ^ p + suc m ^ p * (n * suc n ^ p)
--    + m * (suc m ^ p * suc n ^ p + suc m ^ p * (n * suc n ^ p))
  | comm-* m (suc n)
--    suc (n + (m + n * m)) ^ p
--    + (n + (m + n * m)) * suc (n + (m + n * m)) ^ p
--  ≡
--    suc m ^ p * suc n ^ p + suc m ^ p * (n * suc n ^ p)
--    + m * (suc m ^ p * suc n ^ p + suc m ^ p * (n * suc n ^ p))
  | comm-* n m
--    suc (n + (m + m * n)) ^ p
--    + (n + (m + m * n)) * suc (n + (m + m * n)) ^ p
--  ≡
--    suc m ^ p * suc n ^ p + suc m ^ p * (n * suc n ^ p)
--    + m * (suc m ^ p * suc n ^ p + suc m ^ p * (n * suc n ^ p))
  | sym (suc-right-* m n)
--    suc (n + m * suc n) ^ p
--    + (n + m * suc n) * suc (n + m * suc n) ^ p
--  ≡
--    suc m ^ p * suc n ^ p + suc m ^ p * (n * suc n ^ p)
--    + m * (suc m ^ p * suc n ^ p + suc m ^ p * (n * suc n ^ p))
  | distr-^-* (suc m) (suc n) p
--    suc m ^ p * suc n ^ p + (n + m * suc n) * (suc m ^ p * suc n ^ p)
--  ≡
--    suc m ^ p * suc n ^ p + suc m ^ p * (n * suc n ^ p)
--    + m * (suc m ^ p * suc n ^ p + suc m ^ p * (n * suc n ^ p))
  | distr-*-+ n (m * suc n) (suc m ^ p * suc n ^ p)
--    suc m ^ p * suc n ^ p + (n * (suc m ^ p * suc n ^ p)
--    + m * suc n * (suc m ^ p * suc n ^ p))
--    ≡
--    suc m ^ p * suc n ^ p + suc m ^ p * (n * suc n ^ p)
--    + m * (suc m ^ p * suc n ^ p + suc m ^ p * (n * suc n ^ p))
  | distl-*-+ m (suc m ^ p * suc n ^ p) (suc m ^ p * (n * suc n ^ p))
--    suc m ^ p * suc n ^ p + (n * (suc m ^ p * suc n ^ p)
--    + m * suc n * (suc m ^ p * suc n ^ p))
--  ≡
--    suc m ^ p * suc n ^ p + suc m ^ p * (n * suc n ^ p)
--    + (m * (suc m ^ p * suc n ^ p) + m * (suc m ^ p * (n * suc n ^ p)))
  | comm-* m (suc n)
--    suc m ^ p * suc n ^ p + (n * (suc m ^ p * suc n ^ p)
--    + (m + n * m) * (suc m ^ p * suc n ^ p))
--  ≡
--    suc m ^ p * suc n ^ p + suc m ^ p * (n * suc n ^ p)
--    + (m * (suc m ^ p * suc n ^ p) + m * (suc m ^ p * (n * suc n ^ p)))
  | distr-*-+ m (n * m) (suc m ^ p * suc n ^ p)
--    suc m ^ p * suc n ^ p +
--    (n * (suc m ^ p * suc n ^ p) +
--     (m * (suc m ^ p * suc n ^ p) + n * m * (suc m ^ p * suc n ^ p)))
--  ≡
--    suc m ^ p * suc n ^ p + suc m ^ p * (n * suc n ^ p) +
--    (m * (suc m ^ p * suc n ^ p) + m * (suc m ^ p * (n * suc n ^ p)))
  | swap-m-n-* n (suc m ^ p) (suc n ^ p)
--    suc m ^ p * suc n ^ p +
--    (suc m ^ p * (n * suc n ^ p) +
--     (m * (suc m ^ p * suc n ^ p) + n * m * (suc m ^ p * suc n ^ p)))
--  ≡
--    suc m ^ p * suc n ^ p + suc m ^ p * (n * suc n ^ p) +
--    (m * (suc m ^ p * suc n ^ p) + m * (suc m ^ p * (n * suc n ^ p)))
  | swap-m-n-* (suc m ^ p) n (suc n ^ p)
--    suc m ^ p * suc n ^ p +
--    (n * (suc m ^ p * suc n ^ p) +
--     (m * (suc m ^ p * suc n ^ p) + n * m * (suc m ^ p * suc n ^ p)))
--  ≡
--    suc m ^ p * suc n ^ p + n * (suc m ^ p * suc n ^ p) +
--    (m * (suc m ^ p * suc n ^ p) + m * (n * (suc m ^ p * suc n ^ p)))
  | sym (assoc-* m n (suc m ^ p * suc n ^ p))
--    suc m ^ p * suc n ^ p +
--    (n * (suc m ^ p * suc n ^ p) +
--     (m * (suc m ^ p * suc n ^ p) + n * m * (suc m ^ p * suc n ^ p)))
--  ≡
--    suc m ^ p * suc n ^ p + n * (suc m ^ p * suc n ^ p) +
--    (m * (suc m ^ p * suc n ^ p) + m * n * (suc m ^ p * suc n ^ p))
  | comm-* m n
--    suc m ^ p * suc n ^ p +
--    (n * (suc m ^ p * suc n ^ p) +
--     (m * (suc m ^ p * suc n ^ p) + n * m * (suc m ^ p * suc n ^ p)))
--    ≡
--    suc m ^ p * suc n ^ p + n * (suc m ^ p * suc n ^ p) +
--    (m * (suc m ^ p * suc n ^ p) + n * m * (suc m ^ p * suc n ^ p))
  | assoc-+ (suc m ^ p * suc n ^ p) (n * (suc m ^ p * suc n ^ p))
    (m * (suc m ^ p * suc n ^ p) + n * m * (suc m ^ p * suc n ^ p))
--    suc m ^ p * suc n ^ p +
--    (n * (suc m ^ p * suc n ^ p) +
--     (m * (suc m ^ p * suc n ^ p) + n * m * (suc m ^ p * suc n ^ p)))
--    ≡
--    suc m ^ p * suc n ^ p +
--    (n * (suc m ^ p * suc n ^ p) +
--     (m * (suc m ^ p * suc n ^ p) + n * m * (suc m ^ p * suc n ^ p)))
-- QED
  = refl

--distr-^-* (suc m) (suc n) (suc p)
--  rewrite
--    distr-*-+ (suc m ^ p) (m * suc m ^ p) (suc n ^ p + n * suc n ^ p)
--  | assoc-* m (suc m ^ p) (suc n ^ p + n * suc n ^ p)
--  | distl-*-+ (suc m ^ p) (suc n ^ p) (n * suc n ^ p)
--  | comm-* m (suc n)
--  | comm-* n m
--  | sym (suc-right-* m n)
--  | distr-^-* (suc m) (suc n) p
--  | distr-*-+ n (m * suc n) (suc m ^ p * suc n ^ p)
--  | distl-*-+ m (suc m ^ p * suc n ^ p) (suc m ^ p * (n * suc n ^ p))
--  | comm-* m (suc n)
--  | distr-*-+ m (n * m) (suc m ^ p * suc n ^ p)
--  | swap-m-n-* n (suc m ^ p) (suc n ^ p)
--  | swap-m-n-* (suc m ^ p) n (suc n ^ p)
--  | sym (assoc-* m n (suc m ^ p * suc n ^ p))
--  | comm-* m n
--  | assoc-+ (suc m ^ p * suc n ^ p) (n * (suc m ^ p * suc n ^ p))
--    (m * (suc m ^ p * suc n ^ p) + n * m * (suc m ^ p * suc n ^ p))
--  = refl

--------------------------------------- Relations ---------------------------------------

data _≤_ : ℕ → ℕ → Set where
  z≤n : ∀ {n : ℕ} → zero ≤ n
  s≤s : ∀ {m n : ℕ} → m ≤ n → suc m ≤ suc n

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

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

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

refl-≤ : ∀ {n : ℕ} → n ≤ n
refl-≤ {zero}  = z≤n
refl-≤ {suc o} = s≤s refl-≤

trans-≤ : ∀ {m n p : ℕ} → m ≤ n → n ≤ p → m ≤ p
trans-≤ z≤n       _         = z≤n
trans-≤ (s≤s m≤n) (s≤s n≤p) = s≤s (trans-≤ m≤n n≤p)

antisym-≤ : ∀ {m n : ℕ} → m ≤ n → n ≤ m → m ≡ n
antisym-≤ z≤n       n≤m       = sym (inv-z≤n n≤m)
antisym-≤ (s≤s m≤n) (s≤s n≤m) = cong suc (antisym-≤ m≤n n≤m)

open import Data.Sum using (_⊎_; inj₁; inj₂) renaming ([_,_] to case-⊎)

--data Total (m n : ℕ) : Set where
--  forward : m ≤ n → Total m n
--  flipped : n ≤ m → Total m n
--
--total-≤ : ∀ (m n : ℕ) → Total m n
--total-≤ zero    _    = forward z≤n
--total-≤ (suc m) zero = flipped z≤n
--total-≤ (suc m) (suc n) with total-≤ m n
--...                     | forward m≤n = forward (s≤s m≤n)
--...                     | flipped n≤m = flipped (s≤s n≤m)

total-≤` : ∀ (m n : ℕ) → m ≤ n ⊎ n ≤ m
total-≤` zero    _       = inj₁ z≤n
total-≤` _       zero    = inj₂ z≤n
total-≤` (suc m) (suc n) with total-≤` m n
...                      | inj₁ m≤n = inj₁ (s≤s m≤n)
...                      | inj₂ n≤m = inj₂ (s≤s n≤m)

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

+-monoʳ-≤ : ∀ {n p q : ℕ} → p ≤ q → (n + p) ≤ (n + q)
+-monoʳ-≤ {zero}  p≤q = p≤q
+-monoʳ-≤ {suc n} p≤q = s≤s (+-monoʳ-≤ {n} 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ʳ-≤ m≤n

-- From book
≤-trans : ∀ {m n p : ℕ} → m ≤ n → n ≤ p → m ≤ p
≤-trans z≤n       _          =  z≤n
≤-trans (s≤s m≤n) (s≤s n≤p)  =  s≤s (≤-trans m≤n n≤p)

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

-- Exercises
*-monoʳ-≤ : ∀ {n p q : ℕ} → p ≤ q → (n * p) ≤ (n * q)
*-monoʳ-≤ {zero}  p≤q = z≤n
*-monoʳ-≤ {suc n} p≤q = +-mono-≤ p≤q (*-monoʳ-≤ {n} 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-≤ {_} {n} m≤n p≤q = ≤-trans (*-monoˡ-≤ m≤n) (*-monoʳ-≤ {n} p≤q)

infix 4 _<_

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

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

trichotomy : ∀ (m n) → (m ≡ n) ⊎ (m < n) ⊎ (n < m)
trichotomy zero    zero    = inj₁ refl
trichotomy zero    (suc n) = inj₂ (inj₁ z<s)
trichotomy (suc m) zero    = inj₂ (inj₂ z<s)
trichotomy (suc m) (suc n) with trichotomy m n
...                       | inj₁ m≡n        = inj₁ (cong suc m≡n)
...                       | inj₂ (inj₁ m<n) = inj₂ (inj₁ (s<s m<n))
...                       | inj₂ (inj₂ n<m) = inj₂ (inj₂ (s<s n<m))

+-monoʳ-< : ∀ {n p q} → p < q → (n + p) < (n + q)
+-monoʳ-< {zero}  p<q = p<q
+-monoʳ-< {suc n} p<q = s<s (+-monoʳ-< 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ʳ-< m<n

+-mono-< : ∀ {m n p q} → m < n → p < q → (m + p) < (n + q)
+-mono-< m<n p<q = <-trans (+-monoˡ-< m<n) (+-monoʳ-< p<q)

-- From Software Verification Class (nice exercises but the two first are
-- unnecessary in Agda because the proofs are basically the relation
-- definition)
≡0 : ∀ {n : ℕ} → ¬( 0 < n ) → n ≡ 0
≡0 {zero}  _    = refl
≡0 {suc n} ¬0<n = ⊥-elim (¬0<n z<s)

--0< : ∀ {n : ℕ} → n ≢ 0 → 0 < n
0< : ∀ {n : ℕ} → ¬( n ≡ 0 ) → 0 < n
0< {zero} 0≢0 = ⊥-elim (0≢0 refl)
0< {suc n} s≢0 = z<s

¬n<z : ∀ {n : ℕ} → ¬( n < 0 )
¬n<z ()

m<sn→m<n⊎m≡n : {m n : ℕ} → (m < suc n) → (m < n) ⊎ (m ≡ n)
m<sn→m<n⊎m≡n {zero}  {zero}  _ = inj₂ refl
m<sn→m<n⊎m≡n {zero}  {suc n} _ = inj₁ z<s
m<sn→m<n⊎m≡n {suc m} {zero}  (s<s ())
m<sn→m<n⊎m≡n {suc m} {suc n} (s<s m<sn) with m<sn→m<n⊎m≡n {m} {n} m<sn
...                 | inj₁ m<n = inj₁ (s<s m<n)
...                 | inj₂ m≡n = inj₂ (cong suc m≡n)

suc-step : {m n : ℕ} → (m < suc n) × (m ≢ n) → m < n
suc-step {zero}  {zero}  ⟨ 0<1      , 0≢0   ⟩ = 0< 0≢0
suc-step {zero}  {suc n} ⟨ 0<ssn    , 0≢sn  ⟩ = z<s
suc-step {suc m} {zero}  ⟨ s<s m<0  , sm≢0  ⟩ = ⊥-elim (¬n<z m<0)
suc-step {suc m} {suc n} ⟨ s<s m<sn , sm≢sn ⟩ with m<sn→m<n⊎m≡n m<sn
...                 | inj₁ m<n = s<s m<n
...                 | inj₂ m≡n = ⊥-elim (sm≢sn (cong suc m≡n))

-- This idea of using returning ∃ in Athena might be fundamental but it is
-- clumsy or cumbersome in Agda
discrete : ∀ {n : ℕ} → ¬ (∃[ m ] (n < m × m < suc n))
discrete {zero}  ⟨ _     , ⟨ z<s , s<s () ⟩ ⟩
discrete {suc n} ⟨ zero  , ⟨ ()  , _      ⟩ ⟩
discrete {suc n} ⟨ suc m , ⟨ s<s n<m , s<s m<sn ⟩ ⟩ = discrete ⟨ m , ⟨ n<m , m<sn ⟩ ⟩

-- This is unnecessary because it is the same as pred n
-- proj₁ (S4 {_} {n} _) ≡ pred n
--S4 : ∀ {m n : ℕ} → suc m < n → ∃[ n' ] ( n ≡ suc n' )
S4 : ∀ {m n : ℕ} → m < n → ∃[ n' ] ( n ≡ suc n' )
S4 {_} {zero} ()
S4 {_} {suc n} _ = ⟨ n , refl ⟩

-- more interesting is:
S4' : ∀ {m n : ℕ} → suc m ≤ n → ∃[ n' ] ( n ≡ suc n' )
S4' {_} {zero} ()
S4' {_} {suc n} _ = ⟨ n , refl ⟩
-- It is more interesting because, this is not true:
-- S4' : ∀ {m n : ℕ} → m ≤ n → ∃[ n' ] ( n ≡ suc n' )
-- as opposed to S4.
-- But still, it's something that isn't necessary in Agda

irreflexive : ∀ {m : ℕ} → ¬(m < m)
irreflexive {zero} ()
irreflexive {suc m} (s<s m<m) = irreflexive m<m

trichotomy₂ : ∀ (m n) → (m ≡ n × ¬(m < n) × ¬(n < m))
                      ⊎ (m < n ×   m ≢ n  × ¬(n < m))
                      ⊎ (n < m ×   m ≢ n  × ¬(m < n))
trichotomy₂ zero    zero    = inj₁ ⟨ refl , ⟨ irreflexive , irreflexive ⟩ ⟩
trichotomy₂ zero    (suc n) = inj₂ (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₁ ⟨ cong suc m≡n , ⟨ (λ{(s<s m<n) → ¬m<n m<n}) , (λ{(s<s n<m) → ¬n<m n<m}) ⟩ ⟩
...                       | inj₂ (inj₁ ⟨ m<n , ⟨ m≢n , ¬n<m ⟩ ⟩) =
      inj₂ (inj₁ ⟨ s<s m<n , ⟨ (λ{sm≡sn → m≢n (cong pred sm≡sn)}) , (λ{(s<s n<m) → ¬n<m n<m}) ⟩ ⟩)
...                       | inj₂ (inj₂ ⟨ n<m , ⟨ m≢n , ¬m<n ⟩ ⟩) =
      inj₂ (inj₂ ⟨ s<s n<m , ⟨ (λ{sm≡sn → m≢n (cong pred sm≡sn)}) , (λ{(s<s m<n) → ¬m<n m<n}) ⟩ ⟩)

--open import Function.Equivalence using (_⇔_)
record _⇔_ (A B : Set) : Set where
  field
    to   : A → B
    from : B → A

open _⇔_

<-if-≤ : ∀ {m n} → suc m ≤ n → m < n
<-if-≤ {zero}  {suc n} z≤s        = z<s
<-if-≤ {suc m} {suc n} (s≤s sm≤n) = s<s (<-if-≤ sm≤n)

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

≤-iff-< : ∀ {m n} → (suc m ≤ n) ⇔ (m < n)
≤-iff-< = record
  { to   = <-if-≤
  ; from = ≤-if-<
  }

pred-smaller : ∀ {m n} → suc m ≤ n → m ≤ n
pred-smaller {zero}          _          = z≤n
pred-smaller {suc m} {suc n} (s≤s sm≤n) = s≤s (pred-smaller sm≤n)

<-trans-revisited : ∀ {m n p} → m < n → n < p → m < p
<-trans-revisited {m} {n} {p} m<n n<p
  = <-if-≤ (≤-trans (≤-if-< m<n) (pred-smaller (≤-if-< n<p)))

---

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

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

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

---

data Can : Bin → Set
data One : Bin → Set

data Can where
  zero-C : Can (⟨⟩ O)
  one-C : ∀ {b : Bin} → One b → Can b

data One where
  oneO : One (⟨⟩ I)
  oneO-O : ∀ {b : Bin} → One b → One (b O)
  oneO-I : ∀ {b : Bin} → One b → One (b I)

_ : Can (⟨⟩ I)
_ = one-C oneO

inc-Bin : ∀ {b : Bin} → One b → One (inc b)
inc-Bin oneO        = oneO-O oneO
inc-Bin (oneO-O ob) = oneO-I ob
inc-Bin (oneO-I ob) = oneO-O (inc-Bin ob)

inc-Can : ∀ {b : Bin} → Can b → Can (inc b)
inc-Can zero-C     = one-C oneO
inc-Can (one-C ob) = one-C (inc-Bin ob)

to-Can : ∀ (n : ℕ) → Can (toᵇ n)
to-Can zero = zero-C
to-Can (suc n) = inc-Can (to-Can n)

twicebinisO : ∀ {b : Bin} → One b → b +ᵇ b ≡ b O
twicebinisO {⟨⟩ I} _ = refl
twicebinisO {b O} (oneO-O ob) rewrite twicebinisO ob = refl
twicebinisO {b I} (oneO-I ob) rewrite twicebinisO ob = refl

to∘from-Can : ∀ {b : Bin} → Can b → toᵇ (fromᵇ b) ≡ b
to∘from-Can zero-C = refl
to∘from-Can (one-C oneO) = refl
to∘from-Can {b O} (one-C (oneO-O ob))
  rewrite monobin (fromᵇ b)
        | to∘from-Can (one-C ob)
        | twicebinisO ob = refl
to∘from-Can {b I} (one-C (oneO-I ob))
  rewrite monobin (fromᵇ b)
        | to∘from-Can (one-C ob)
        | twicebinisO ob = refl

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

module ≤-Reasoning where
  infix  1 begin≤_
  infixr 2 _≤⟨⟩_ _≤⟨_⟩_
  infix  3 _∎≤

  begin≤_ : ∀ {x y : ℕ} → x ≤ y → x ≤ y
  begin≤ x≤y = x≤y

  _≤⟨⟩_ : ∀ (x : ℕ) {y : ℕ} → x ≤ y → x ≤ y
  x ≤⟨⟩ x≤y = x≤y

  _≤⟨_⟩_ : ∀ (x : ℕ) {y z : ℕ} → x ≤ y → y ≤ z → x ≤ z
  x ≤⟨ x≤y ⟩ y≤z = trans-≤ x≤y y≤z

  _∎≤ : ∀ (x : ℕ) → x ≤ x
  x ∎≤ = refl-≤

open ≤-Reasoning

+-monoʳ-≤` : ∀ {n p q : ℕ} → p ≤ q → (n + p) ≤ (n + q)
+-monoʳ-≤` {zero} p≤q = p≤q
+-monoʳ-≤` {suc n} {p} {q} p≤q =
  begin≤
    suc n + p
  ≤⟨⟩
    suc (n + p)
  ≤⟨ s≤s (+-monoʳ-≤` p≤q) ⟩
    suc (n + q)
  ≤⟨⟩
    suc n + q
  ∎≤

pred≡ : ∀ {m n : ℕ} → suc m ≡ suc n → m ≡ n
pred≡ = cong pred

≡to≤ : ∀ {m n : ℕ} → m ≡ n → m ≤ n
≡to≤ {zero}  {zero}  _     = refl-≤
≡to≤ {suc m} {suc n} sm≡sn = s≤s (≡to≤ (cong pred sm≡sn))

+-monoˡ-≤` : ∀ {m n p : ℕ} → m ≤ n → (m + p) ≤ (n + p)
+-monoˡ-≤` {m} {n} {p} m≤n =
  begin≤
    m + p
  ≤⟨ ≡to≤ (comm-+ m p) ⟩
    p + m
  ≤⟨ +-monoʳ-≤` {p} {m} {n} m≤n ⟩
    p + n
  ≤⟨ ≡to≤ (comm-+ p n) ⟩
    n + p
  ∎≤

+-mono-≤` : ∀ {m n p q : ℕ} → m ≤ n → p ≤ q → (m + p) ≤ (n + q)
+-mono-≤` {m} {n} {p} {q} m≤n p≤q =
  begin≤
    m + p
  ≤⟨ +-monoˡ-≤` m≤n ⟩
    n + p
  ≤⟨ +-monoʳ-≤` p≤q ⟩
    n + q
  ∎≤

--even-comm′ : ∀ (m n : ℕ)
--  → even (m + n)
--    ------------
--  → even (n + m)
--even-comm′ m n ev with   m + n  | comm-+ m n
--...                  | .(n + m) | refl       = ev

--------------------------------------- Isomorphism ---------------------------------------

postulate
  extensionality : ∀ {A B : Set} {f g : A → B}
    → (∀ (x : A) → f x ≡ g x)
      -----------------------
    → f ≡ g

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

same-app : ∀ (m n : ℕ) → m +′ n ≡ m + n
same-app m n rewrite comm-+ m n = helper m n
  where
    helper : ∀ (m n : ℕ) → m +′ n ≡ n + m
    helper _ zero    = refl
    helper m (suc n) = cong suc (helper m n)

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

--open import Level using (Level; _⊔_) renaming (zero to lzero; suc to lsuc)
--
--private
--  variable
--    ℓ ℓ₁ : Level

--infix 0 _≃_
--record _≃_ (A : Set ℓ) (B : Set ℓ₁) : Set (ℓ ⊔ ℓ₁) where
record _≃_ (A B : Set) : Set where
  field
    to   : A → B
    from : B → A
    from∘to : ∀ (x : A) → from (to x) ≡ x
    to∘from : ∀ (y : B) → to (from y) ≡ y
open _≃_

≃-refl : ∀ {A : Set} → A ≃ A
≃-refl =
  record
    { to      = λ x → x
    ; from    = λ y → y
    ; from∘to = λ x → refl
    ; to∘from = λ y → refl
    }

≃-sym : ∀ {A B : Set} → A ≃ B → B ≃ A
≃-sym A≃B =
  record
    { to      = from A≃B
    ; from    = to A≃B
    ; from∘to = to∘from A≃B
    ; to∘from = from∘to A≃B
    }

open import Function.Base using (_∘_)

≃-trans : ∀ {A B C : Set} → A ≃ B → B ≃ C → A ≃ C
≃-trans A≃B B≃C =
  record
    { to      = to B≃C ∘ to A≃B
    ; from    = from A≃B ∘ from B≃C
    ; from∘to = λ{x →
        begin
          from A≃B (from B≃C (to B≃C (to A≃B x)))
        ≡⟨ cong (from A≃B) (from∘to B≃C (to A≃B x)) ⟩
          from A≃B (to A≃B x)
        ≡⟨ from∘to A≃B x ⟩
          x
        ∎
      }
    ; to∘from = λ{y →
        begin
          to B≃C (to A≃B (from A≃B (from B≃C y)))
        ≡⟨ cong (to B≃C) (to∘from A≃B (from B≃C y)) ⟩
          to B≃C (from B≃C y)
        ≡⟨ to∘from B≃C y ⟩
          y
        ∎
      }
    }

infix 0 _≲_
record _≲_ (A B : Set) : Set where
  field
    to      : A → B
    from    : B → A
    from∘to : ∀ (x : A) → from (to x) ≡ x
open _≲_

≃-implies-≲ : ∀ {A B : Set} → A ≃ B → A ≲ B
≃-implies-≲ A≃B =
  record
  { to   = to A≃B
  ; from = from A≃B
  ; from∘to = from∘to A≃B
  }

-- Idea: Prove that (ℕ) is isomorph to (Can)
-- Idea: Prove that (+, ℕ) is isomorph to (+ᵇ, Can)
--record _⇔_ (A B : Set) : Set where
--  field
--    to   : A → B
--    from : B → A

-- Exercise: implement reflexive, symetric and transitive properties on _⇔_

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

data Dec-Can : Set where
  num : ∀ (b : Bin) → Can b → Dec-Can

toᵈᶜ : ℕ → Dec-Can
toᵈᶜ n = num (toᵇ n) (to-Can n)
--toᵈᶜ n = num (to-Can n)

fromᵈᶜ : Dec-Can → ℕ
fromᵈᶜ (num b _) = fromᵇ b

--from∘toᵈᶜ (suc n) = ?
-- λ n → fromᵈᶜ (toᵈᶜ (suc n)) ≡ suc n
-- λ cb → toᵈᶜ (fromᵈᶜ (num cb)) ≡ num cb
-- λ b ob → toᵈᶜ (fromᵈᶜ (num (b O) (one-C (oneO-O ob))))

--to∘fromᵈᶜ : ∀ (y : Dec-Can) → toᵈᶜ (fromᵈᶜ y) ≡ y
--to∘fromᵈᶜ (num (⟨⟩ O) zero-C)       = refl
--to∘fromᵈᶜ (num (⟨⟩ I) (one-C oneO)) = refl
--to∘fromᵈᶜ (num (b O) (one-C (oneO-O {b} ob))) rewrite monobin (fromᵇ b) = ?
---- λ b ob → toᵈᶜ (fromᵈᶜ (num (b O) (one-C (oneO-O ob))))
---- λ b ob → λ b ob → num (toᵇ (fromᵇ b + fromᵇ b)) (to-Can (fromᵇ b + fromᵇ b))
--to∘fromᵈᶜ = ?
----to∘fromᵈᶜ (num b cb) =
----  begin
----    toᵈᶜ (fromᵈᶜ (num b cb))
----  ≡⟨⟩
----    toᵈᶜ (fromᵇ b)
----  ≡⟨⟩
----    num (toᵇ (fromᵇ b)) (to-Can (fromᵇ b))
----  ≡⟨ ? ⟩
----    num b cb
----  ∎

--ℕ≃Can : ℕ ≃ Dec-Can
--ℕ≃Can =
--  record
--  { to      = toᵈᶜ
--  ; from    = fromᵈᶜ
--  ; from∘to = from∘toᵇ
--  ; to∘from = ? -- to∘fromᵈᶜ -- to∘from-Can
--  }

--num (zero-C)

--------------------------------------- Decidable ---------------------------------------
-- Use `Dec` to create elements for `Can`. Look if this is enough to prove `ℕ ≃ Can`
-- Ans: NO. Decidables don't do what you thought they do

--------------------------------------- Last ---------------------------------------
-- Prove that `sqrt 2` is irrational

-- Stuff to take into account and add to agda neovim:
-- IOTCM "plfa/part1/Naturals.agda" None Direct (Cmd_load "plfa/part1/Naturals.agda" [])
-- IOTCM "plfa/part1/Naturals.agda" None Direct (Cmd_compute_toplevel DefaultCompute "2 + suc 3") # Already done by plugin
-- IOTCM "plfa/part1/Naturals.agda" None Direct (Cmd_infer_toplevel AsIs "2 + suc 3")  # THIS SHOULD BE PART OF THE STUFF IN MAGDA
--
-- Other stuff:
-- IOTCM "plfa/part1/Naturals.agda" None Direct (Cmd_show_module_contents_toplevel AsIs "Eq")
-- IOTCM "plfa/part1/Naturals.agda" None Direct (Cmd_why_in_scope_toplevel "Eq")
-- IOTCM "plfa/part1/Naturals.agda" None Direct (Cmd_why_in_scope (InteractionId 1) (Range (Just "plfa/part1/Naturals.agda") (Interval (Pn () 1 76 1) (Pn () 1 76 19))) "Eq")
---- IOTCM "plfa/part1/Naturals.agda" None Direct (Cmd_autoOne (InteractionId 1) noRange "")
---- IOTCM "plfa/part1/Naturals.agda" NonInteractive Indirect (Cmd_infer Simplified 103992 (intervalsToRange (Just (mkAbsolute "plfa/part1/Naturals.agda")) [Interval (Pn () 50 75 1) (Pn () 52 79 1)]) "3 + suc 2")


module PartialOrder where

open import Prelude

record PartialOrder (A : Set) : Set1 where
  field
    _==_    : A -> A -> Set
    _≤_     : A -> A -> Set
    ==-def  : forall {x y} -> (x == y) ⇐⇒ (x ≤ y) ∧ (y ≤ x)
    ≤-refl  : forall {x} -> x ≤ x
    ≤-trans : forall {x y z} -> x ≤ y -> y ≤ z -> x ≤ z

module POrder {A : Set}(ord : PartialOrder A) where

  private module POrd = PartialOrder ord
  open POrd public

  infix 60 _≤_ _==_

  Monotone : (A -> A) -> Set
  Monotone f = forall {x y} -> x ≤ y -> f x ≤ f y

  Antitone : (A -> A) -> Set
  Antitone f = forall {x y} -> x ≤ y -> f y ≤ f x

  ≤-antisym : forall {x y} -> x ≤ y -> y ≤ x -> x == y
  ≤-antisym p q = snd ==-def (p , q)

  ==≤-L : forall {x y} -> x == y -> x ≤ y
  ==≤-L x=y = fst (fst ==-def x=y)

  ==≤-R : forall {x y} -> x == y -> y ≤ x
  ==≤-R x=y = snd (fst ==-def x=y)

  ==-refl : forall {x} -> x == x
  ==-refl = ≤-antisym ≤-refl ≤-refl

  ==-sym : forall {x y} -> x == y -> y == x
  ==-sym xy = snd ==-def (swap (fst ==-def xy))

  ==-trans : forall {x y z} -> x == y -> y == z -> x == z
  ==-trans xy yz = ≤-antisym
                           (≤-trans x≤y y≤z)
                           (≤-trans z≤y y≤x)
    where
      x≤y = ==≤-L xy
      y≤z = ==≤-L yz
      y≤x = ==≤-R xy
      z≤y = ==≤-R yz

  Dual : PartialOrder A
  Dual = record
    { _==_    = _==_
    ; _≤_     = \x y -> y ≤ x
    ; ==-def  = (swap ∘ fst ==-def , snd ==-def ∘ swap)
    ; ≤-refl  = ≤-refl
    ; ≤-trans = \yx zy -> ≤-trans zy yx
    }


module Lib.Vec where

open import Lib.Prelude
open import Lib.Nat
open import Lib.Fin

infixr 40 _::_ _++_

data Vec (A : Set) : Nat -> Set where
  []   : Vec A 0
  _::_ : forall {n} -> A -> Vec A n -> Vec A (suc n)

_++_ : {A : Set}{n m : Nat} -> Vec A n -> Vec A m -> Vec A (n + m)
[]        ++ ys = ys
(x :: xs) ++ ys = x :: xs ++ ys

_!_ : forall {A n} -> Vec A n -> Fin n -> A
[]      ! ()
x :: xs ! zero  = x
x :: xs ! suc i = xs ! i

tabulate : forall {A n} -> (Fin n -> A) -> Vec A n
tabulate {n = zero}  f = []
tabulate {n = suc n} f = f zero :: tabulate (f ∘ suc)

vec : forall {A n} -> A -> Vec A n
vec x = tabulate (\_ -> x)

infixl 30 _<*>_

_<*>_ : forall {A B n} -> Vec (A -> B) n -> Vec A n -> Vec B n
[]      <*> []      = []
f :: fs <*> x :: xs = f x :: (fs <*> xs)

map : forall {A B n} -> (A -> B) -> Vec A n -> Vec B n
map f xs = vec f <*> xs

zip : forall {A B C n} -> (A -> B -> C) -> Vec A n -> Vec B n -> Vec C n
zip f xs ys = vec f <*> xs <*> ys


module Issue246 where

module James where

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

  data Zero : Set where

  data One : Set where
    void : One

  propLEQ : Nat -> Nat -> Set
  propLEQ zero    _       = One
  propLEQ (suc n) (suc m) = propLEQ n m
  propLEQ (suc n) zero    = Zero

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

  toFin : {n : Nat} -> (i : Nat) -> (propLEQ (suc i) n) -> Fin n
  toFin {zero}  zero      ()
  toFin {zero}  (suc _)   ()
  toFin {suc n} zero    k  = fzero
  toFin {suc n} (suc i) k  = fsuc (toFin i k)

  one : Nat
  one = suc zero

  two : Nat
  two = suc one

  three : Nat
  three = suc two

  null : Fin three
  null = toFin zero void

module Conor where

  data Nat : Set where
   ze : Nat
   su : Nat -> Nat

  data Bool : Set where
   tt ff : Bool

  record One : Set where
  data Zero : Set where

  So : Bool -> Set
  So tt = One
  So ff = Zero

  _<_ : Nat -> Nat -> Bool
  _ < ze = ff
  ze < su n = tt
  su m < su n = m < n

  data Lt (m n : Nat) : Set where
   lt : So (m < n) -> Lt m n

  boo : {m n : Nat} -> So (m < n) -> Lt (su m) (su n)
  boo p = lt p

module Alan where

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

  {-# BUILTIN NATURAL ℕ #-}
  {-# BUILTIN ZERO zero #-}
  {-# BUILTIN SUC suc #-}

  data Bool : Set where
    true false : Bool

  infixr 5 _∷_

  _lt_ : ℕ → ℕ → Bool
  _     lt zero  = false
  zero  lt suc _ = true
  suc x lt suc y = x lt y

  data List<? (X : ℕ → Set) (n : ℕ) : Bool → Set where
    [] : List<? X n true
    _∷_ : {m : ℕ} → (x : X m) → (List<? X m true) → (List<? X n (m lt n))

  List< : (ℕ → Set) → ℕ → Set
  List< X n = List<? X n true

  data A : ℕ → Set where
    a1 : A 1
    a2 : A 2

  as : List< A 3
  as = a2 ∷ a1 ∷ ([] {A})

  as' : List< A 3
  as' = a2 ∷ a1 ∷ []


module test where

data Bool : Set where
    True  : Bool
    False : Bool

!_ : Bool → Bool
! True  = False
! False = True

if_then_else_ : {A : Set} → Bool → A → A → A
if True then x else y = x
if False then x else y = y

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

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

low = suc zero
high = low + (low + low)

data List (A : Set) : Set where
    Nil  : List A
    Cons : A → List A → List A

length : {A : Set} → List A → ℕ
length Nil = zero
length (Cons x x₁) = suc (length x₁)

map : {A B : Set} → (A → B) → List A → List B
map f Nil = Nil
map f (Cons x l) = Cons (f x) (map f l)

concat : {A : Set} → List A → List A → List A
concat Nil m = m
concat (Cons x l) m = Cons x (concat l m)


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

open import LogicalFormulae
open import Numbers.Naturals.Definition
open import Numbers.Naturals.Addition
open import Numbers.Naturals.Multiplication
open import Numbers.Naturals.Order

module Numbers.Naturals.Exponentiation where

_^N_ : ℕ → ℕ → ℕ
a ^N zero = 1
a ^N succ b = a *N (a ^N b)

exponentiationIncreases : (a b : ℕ) → (a ≡ 0) || (a ≤N a ^N (succ b))
exponentiationIncreases zero b = inl refl
exponentiationIncreases (succ a) zero = inr (inr (applyEquality succ (transitivity (additionNIsCommutative 0 a) (multiplicationNIsCommutative 1 a))))
exponentiationIncreases (succ a) (succ b) with exponentiationIncreases (succ a) b
exponentiationIncreases (succ a) (succ b) | inr (inl x) = inr (inl (canAddToOneSideOfInequality _ x))
exponentiationIncreases (succ a) (succ b) | inr (inr x) with productOne x
exponentiationIncreases (succ 0) (succ b) | inr (inr x) | inr pr rewrite pr = inr (inr refl)
exponentiationIncreases (succ (succ a)) (succ b) | inr (inr x) | inr pr rewrite pr | productWithOneRight a = inr (inl (le (succ (a +N a *N succ (succ a))) (additionNIsCommutative _ (succ (succ a)))))