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

module NfCBPVLaws where

open import Library hiding (_×̇_)

open import NfCBPV

-- NB: mon⁺ is a comonad coalgebra

module MonIsComonadCoalgebra where

  mon-id : ∀ (P : Ty⁺) {Γ} (a : ⟦ P ⟧⁺ Γ) → mon⁺ P a ⊆-refl ≡ a
  mon-id (base o)  x         = {!monVar-id!}
  mon-id (P₁ ×̇ P₂) (a₁ , a₂) = cong₂ _,_ (mon-id P₁ a₁) (mon-id P₂ a₂)
  mon-id (Σ̇ I Ps)  (i  ,  a) = cong (i ,_) (mon-id (Ps i) a)
  mon-id (□̇ N)     f         = funExtH (funExt (λ τ → cong f {!!})) -- ⊆-trans ⊆-refl τ ≡ τ

  -- Identity: extract ∘ mon⁺ ≡ id

  extract∘mon : ∀ (P : Ty⁺) {Γ} → extract ∘ mon⁺ P ≗ id {A = ⟦ P ⟧⁺ Γ}
  extract∘mon = mon-id

  -- Associativity: □-map (mon⁺ P) ∘ mon⁺ P ≡ duplicate ∘ mon⁺ P

  mon∘mon : ∀ (P : Ty⁺) {Γ} (a : ⟦ P ⟧⁺ Γ) {Δ} {τ : Γ ⊆ Δ} {Φ} {τ' : Δ ⊆ Φ} →
    mon⁺ P (mon⁺ P a τ) τ' ≡ mon⁺ P a (⊆-trans τ τ')
  mon∘mon (base o)  x         = {!!}  -- monVar∘monVar
  mon∘mon (P₁ ×̇ P₂) (a₁ , a₂) = cong₂ _,_ (mon∘mon P₁ a₁) (mon∘mon P₂ a₂)
  mon∘mon (Σ̇ I Ps)  (i  , a)  = cong (i ,_) (mon∘mon (Ps i) a)
  mon∘mon (□̇ N)     f         = {!!}  -- □-mon∘□-mon

  map-mon∘mon : ∀ (P : Ty⁺) {Γ} → □-map (mon⁺ P) ∘ mon⁺ P ≗ duplicate ∘ mon⁺ P {Γ}
  map-mon∘mon P a = funExtH $ funExt λ τ → funExtH $ funExt λ τ' → mon∘mon P a

module RunIsMonadAlgebra where

  -- Identity: run⁻ N ∘ return ≡ id

  -- Associativity: run⁻ N ∘ ◇-map (run⁻ N) ≡ run⁻ N ∘ join

monNe : ∀{N} → Mon (Ne N)
monNe = {!!}

monNf : ∀{N} → Mon (Nf N)
monNf = {!!}

-- ◇ preserves monotonicity
------------------------------------------------------------------------

-- This needs weakening of neutrals

◇-mon : Mon A → Mon (◇ A)
◇-mon mA (return a) τ = return (mA a τ)
◇-mon mA (bind u c) τ = bind (monNe u τ) (◇-mon mA c (refl ∷ τ)) -- need monotonicity of Ne
◇-mon mA (case x t) τ = case (monVar x τ) (λ i → ◇-mon mA (t i) (refl ∷ τ))
◇-mon mA (split x c) τ = split (monVar x τ) (◇-mon mA c (refl ∷ refl ∷ τ))

-- From ◇-mon we get □-run

□-run : Run B → Run (□ B)
□-run rB c = rB ∘ ◇-map extract ∘ ◇-mon □-mon c

-- Run for Nf?
-- Seems to need a category of renamings rather just OPE

bindNf : ∀ {N} {Γ} {P} →
         Ne (◇̇ P) Γ → Nf N (P ∷ Γ) → Nf N Γ
bindNf u (ret v) = ret (bind u v)
bindNf u (ne n)  = ne  (bind u n)
bindNf u (rec t) = rec λ i → bindNf u (t i)
bindNf u (abs t) = abs (bindNf (monNe u (_ ∷ʳ ⊆-refl)) (monNf t {!!}))
  -- The remaining goal Q ∷ P ∷ Γ ⊆ P ∷ Q ∷ Γ
  -- cannot be filled since OPEs do not support swap.

runNf : ∀{N} → ◇ (Nf N) →̇ Nf N
runNf (return j) = j
runNf (bind u c) = bindNf u (runNf c)  -- Problem!
runNf (case x t) = {!!}
runNf (split x c) = {!!}

-- Monoidal functoriality ★

module _ {A B : ISet} (mA : Mon A) (mB : Mon B) where

  zip : ⟨ ◇ A ⊙ ◇ B ⟩→̇ ◇ (A ×̂ B)
  zip cA cB = join (◇-map! (λ τ a → ◇-map! (λ τ' b → mA a τ' , b) (◇-mon mB cB τ)) cA)

-- Alternative definitions of freshᶜ

freshᶜ₀ : (Γ : Cxt) → ◇ ⟦ Γ ⟧ᶜ Γ
freshᶜ₀ [] = return []
freshᶜ₀ (P ∷ Γ) = ◇-ext $
  □-weak (◇-mon (monᶜ Γ) (freshᶜ₀ Γ)) -- BAD, use of ◇-mon
  ⋉ fresh◇
-- freshᶜ (P ∷ Γ) = ◇-ext $
--   (λ τ → ◇-mon (monᶜ Γ) (freshᶜ Γ) (⊆-trans (_ ∷ʳ ⊆-refl) τ))  -- BAD, use of ◇-mon
--   ⋉ fresh◇

freshG₀ : □ (◇ ⟦ Γ ⟧ᶜ) Γ
-- freshG₀ : (τ : Γ ⊆ Δ) → ◇ ⟦ Γ ⟧ᶜ Δ
freshG₀ [] = return []
freshG₀ (P   ∷ʳ τ) = ◇-mon (monᶜ _) (freshG₀ τ) (P ∷ʳ ⊆-refl)  -- BAD, use of ◇-mon
freshG₀ (refl ∷ τ) = ◇-ext $ (λ τ₁ → freshG₀ (⊆-trans τ (⊆-trans (_ ∷ʳ ⊆-refl) τ₁))) ⋉ fresh◇


{-# OPTIONS --universe-polymorphism #-}
module Issue204 where

open import Issue204.Dependency

postulate
  ℓ : Level
  r : R ℓ
  d : D ℓ

open R r

open M d


------------------------------------------------------------------------
-- The Agda standard library
--
-- Properties of the binary representation of natural numbers
------------------------------------------------------------------------

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

module Data.Bin.Properties where

open import Data.Bin
open import Data.Digit using (Bit; Expansion)
import Data.Fin as Fin
import Data.Fin.Properties as 𝔽ₚ
open import Data.List.Base using (List; []; _∷_)
open import Data.List.Properties using (∷-injective)
open import Data.Nat
  using (ℕ; zero; z≤n; s≤s)
  renaming (suc to 1+_; _+_ to _+ℕ_; _*_ to _*ℕ_; _≤_ to _≤ℕ_)
import Data.Nat.Properties as ℕₚ
open import Data.Product using (proj₁; proj₂)
open import Function using (_∘_)
open import Relation.Binary
open import Relation.Binary.Consequences
open import Relation.Binary.PropositionalEquality
  using (_≡_; _≢_; refl; sym; isEquivalence; resp₂; decSetoid)
open import Relation.Nullary using (yes; no)

------------------------------------------------------------------------
-- (Bin, _≡_) is a decidable setoid

1#-injective : ∀ {as bs} → as 1# ≡ bs 1# → as ≡ bs
1#-injective refl = refl

infix 4 _≟_ _≟ₑ_

_≟ₑ_ : ∀ {base} → Decidable (_≡_ {A = Expansion base})
_≟ₑ_ []       []       = yes refl
_≟ₑ_ []       (_ ∷ _)  = no λ()
_≟ₑ_ (_ ∷ _) []        = no λ()
_≟ₑ_ (x ∷ xs) (y ∷ ys) with x Fin.≟ y | xs ≟ₑ ys
... | _        | no xs≢ys = no (xs≢ys ∘ proj₂ ∘ ∷-injective)
... | no  x≢y  | _        = no (x≢y   ∘ proj₁ ∘ ∷-injective)
... | yes refl | yes refl = yes refl

_≟_ : Decidable {A = Bin} _≡_
0#    ≟ 0#    = yes refl
0#    ≟ bs 1# = no λ()
as 1# ≟ 0#    = no λ()
as 1# ≟ bs 1# with as ≟ₑ bs
... | yes refl  = yes refl
... | no  as≢bs = no (as≢bs ∘ 1#-injective)

≡-isDecEquivalence : IsDecEquivalence _≡_
≡-isDecEquivalence = record
  { isEquivalence = isEquivalence
  ; _≟_           = _≟_
  }

≡-decSetoid : DecSetoid _ _
≡-decSetoid = decSetoid _≟_

------------------------------------------------------------------------
-- (Bin _≡_ _<_) is a strict total order

<-trans : Transitive _<_
<-trans (less lt₁) (less lt₂) = less (ℕₚ.<-trans lt₁ lt₂)

<-asym : Asymmetric _<_
<-asym (less lt) (less gt) = ℕₚ.<-asym lt gt

<-irrefl : Irreflexive _≡_ _<_
<-irrefl refl (less lt) = ℕₚ.<-irrefl refl lt

∷ʳ-mono-< : ∀ {a b as bs} → as 1# < bs 1# → (a ∷ as) 1# < (b ∷ bs) 1#
∷ʳ-mono-< {a} {b} {as} {bs} (less lt) = less (begin
  1+ (m₁ +ℕ n₁ *ℕ 2) ≤⟨ s≤s (ℕₚ.+-monoˡ-≤ _ (𝔽ₚ.toℕ≤pred[n] a)) ⟩
  1+ (1 +ℕ n₁ *ℕ 2)  ≡⟨ refl ⟩
  1+ n₁ *ℕ 2         ≤⟨ ℕₚ.*-mono-≤ lt ℕₚ.≤-refl ⟩
  n₂ *ℕ 2            ≤⟨ ℕₚ.n≤m+n m₂ (n₂ *ℕ 2) ⟩
  m₂ +ℕ n₂ *ℕ 2      ∎)
  where
  open ℕₚ.≤-Reasoning
  m₁ = Fin.toℕ a;   m₂ = Fin.toℕ b
  n₁ = toℕ (as 1#); n₂ = toℕ (bs 1#)

∷ˡ-mono-< : ∀ {a b bs} → a Fin.< b → (a ∷ bs) 1# < (b ∷ bs) 1#
∷ˡ-mono-< {a} {b} {bs} lt = less (begin
  1 +ℕ (m₁  +ℕ n *ℕ 2)  ≡⟨ sym (ℕₚ.+-assoc 1 m₁ (n *ℕ 2)) ⟩
  (1 +ℕ m₁) +ℕ n *ℕ 2   ≤⟨ ℕₚ.+-monoˡ-≤ _ lt ⟩
  m₂  +ℕ n *ℕ 2   ∎)
  where
  open ℕₚ.≤-Reasoning
  m₁ = Fin.toℕ a; m₂ = Fin.toℕ b; n = toℕ (bs 1#)

1<[23] : ∀ {b} → [] 1# < (b ∷ []) 1#
1<[23] {b} = less (ℕₚ.n≤m+n (Fin.toℕ b) 2)

1<2+ : ∀ {b bs} → [] 1# < (b ∷ bs) 1#
1<2+ {_} {[]}     = 1<[23]
1<2+ {_} {b ∷ bs} = <-trans 1<[23] (∷ʳ-mono-< {a = b} 1<2+)

0<1+ : ∀ {bs} → 0# < bs 1#
0<1+ {[]}     = less (s≤s z≤n)
0<1+ {b ∷ bs} = <-trans (less (s≤s z≤n)) 1<2+

<⇒≢ : ∀ {a b} → a < b → a ≢ b
<⇒≢ lt eq = asym⟶irr (resp₂ _<_) sym <-asym eq lt

<-cmp : Trichotomous _≡_ _<_
<-cmp 0#            0#            = tri≈ (<-irrefl refl) refl (<-irrefl refl)
<-cmp 0#            (_ 1#)        = tri< 0<1+ (<⇒≢ 0<1+) (<-asym 0<1+)
<-cmp (_ 1#)        0#            = tri> (<-asym 0<1+) (<⇒≢ 0<1+ ∘ sym) 0<1+
<-cmp ([] 1#)       ([] 1#)       = tri≈ (<-irrefl refl) refl (<-irrefl refl)
<-cmp ([] 1#)       ((b ∷ bs) 1#) = tri< 1<2+ (<⇒≢ 1<2+) (<-asym 1<2+)
<-cmp ((a ∷ as) 1#) ([] 1#)       = tri> (<-asym 1<2+) (<⇒≢ 1<2+ ∘ sym) 1<2+
<-cmp ((a ∷ as) 1#) ((b ∷ bs) 1#) with <-cmp (as 1#) (bs 1#)
... | tri<  lt ¬eq ¬gt =
  tri< (∷ʳ-mono-< lt)  (<⇒≢ (∷ʳ-mono-< lt)) (<-asym (∷ʳ-mono-< lt))
... | tri> ¬lt ¬eq  gt =
  tri> (<-asym (∷ʳ-mono-< gt)) (<⇒≢ (∷ʳ-mono-< gt) ∘ sym) (∷ʳ-mono-< gt)
... | tri≈ ¬lt refl ¬gt with 𝔽ₚ.<-cmp a b
...   | tri≈ ¬lt′ refl ¬gt′ =
  tri≈ (<-irrefl refl) refl (<-irrefl refl)
...   | tri<  lt′ ¬eq  ¬gt′ =
  tri< (∷ˡ-mono-< lt′)  (<⇒≢ (∷ˡ-mono-< lt′)) (<-asym (∷ˡ-mono-< lt′))
...   | tri> ¬lt′ ¬eq  gt′  =
  tri> (<-asym (∷ˡ-mono-< gt′)) (<⇒≢ (∷ˡ-mono-< gt′) ∘ sym) (∷ˡ-mono-< gt′)

<-isStrictTotalOrder : IsStrictTotalOrder _≡_ _<_
<-isStrictTotalOrder = record
  { isEquivalence = isEquivalence
  ; trans         = <-trans
  ; compare       = <-cmp
  }

<-strictTotalOrder : StrictTotalOrder _ _ _
<-strictTotalOrder = record
  { Carrier            = Bin
  ; _≈_                = _≡_
  ; _<_                = _<_
  ; isStrictTotalOrder = <-isStrictTotalOrder
  }


open import Agda.Builtin.Equality

-- Case splitting should not remove implicit arguments
record ⊤ : Set where constructor tt

test₁ : {A : Set} → ⊤ → ⊤
test₁ {A} x = {!x!}

-- Case splitting on an implicit argument should make it visible
test₂ : {x : ⊤} → ⊤
test₂ = {!.x!}

-- Implicit variables in dot patterns should be replaced by _
postulate
  A B : Set
  f : A → B

test₃ : {x : A} (y : B) → f x ≡ y → B
test₃ y e = {!e!}

-- .. but not if they are bound inside the dot pattern
test₄ : (f : A → A) → f ≡ (λ x → x) → Set
test₄ f e = {!e!}


module rummy where

open import Data.Nat

-- The suit type
data Suit : Set where
  ♣ : Suit
  ♢ : Suit
  ♥ : Suit
  ♠ : Suit

-- A card consists of a value and a suite.
data Card : ℕ → Suit → Set where
  _of_ : (n : ℕ) (s : Suit) → Card n s

-- Common names for cards

A : ℕ; A = 1
K : ℕ; K = 13
Q : ℕ; Q = 12
J : ℕ; J = 11

--
-- The clubs suit
--

A♣  : Card A  ♣; A♣  = A  of ♣
2♣  : Card 2  ♣; 2♣  = 2  of ♣
3♣  : Card 3  ♣; 3♣  = 3  of ♣
4♣  : Card 4  ♣; 4♣  = 4  of ♣
5♣  : Card 5  ♣; 5♣  = 5  of ♣
6♣  : Card 6  ♣; 6♣  = 6  of ♣
7♣  : Card 7  ♣; 7♣  = 7  of ♣
8♣  : Card 8  ♣; 8♣  = 8  of ♣
9♣  : Card 9  ♣; 9♣  = 9  of ♣
10♣ : Card 10 ♣; 10♣ = 10 of ♣
J♣  : Card J  ♣; J♣  = J  of ♣
Q♣  : Card Q  ♣; Q♣  = Q  of ♣
K♣  : Card K  ♣; K♣  = K  of ♣

--
-- The diamond suit
--

A♢  : Card A  ♢; A♢  = A  of ♢
2♢  : Card 2  ♢; 2♢  = 2  of ♢
3♢  : Card 3  ♢; 3♢  = 3  of ♢
4♢  : Card 4  ♢; 4♢  = 4  of ♢
5♢  : Card 5  ♢; 5♢  = 5  of ♢
6♢  : Card 6  ♢; 6♢  = 6  of ♢
7♢  : Card 7  ♢; 7♢  = 7  of ♢
8♢  : Card 8  ♢; 8♢  = 8  of ♢
9♢  : Card 9  ♢; 9♢  = 9  of ♢
10♢ : Card 10 ♢; 10♢ = 10 of ♢
J♢  : Card J  ♢; J♢  = J  of ♢
Q♢  : Card Q  ♢; Q♢  = Q  of ♢
K♢  : Card K  ♢; K♢  = K  of ♢

--
-- The heart suit
--

A♥  : Card A  ♥; A♥  = A  of ♥
2♥  : Card 2  ♥; 2♥  = 2  of ♥
3♥  : Card 3  ♥; 3♥  = 3  of ♥
4♥  : Card 4  ♥; 4♥  = 4  of ♥
5♥  : Card 5  ♥; 5♥  = 5  of ♥
6♥  : Card 6  ♥; 6♥  = 6  of ♥
7♥  : Card 7  ♥; 7♥  = 7  of ♥
8♥  : Card 8  ♥; 8♥  = 8  of ♥
9♥  : Card 9  ♥; 9♥  = 9  of ♥
10♥ : Card 10 ♥; 10♥ = 10 of ♥
J♥  : Card J  ♥; J♥  = J  of ♥
Q♥  : Card Q  ♥; Q♥  = Q  of ♥
K♥  : Card K  ♥; K♥  = K  of ♥

--
-- The spade suit
--

A♠  : Card A  ♠; A♠  = A  of ♠
2♠  : Card 2  ♠; 2♠  = 2  of ♠
3♠  : Card 3  ♠; 3♠  = 3  of ♠
4♠  : Card 4  ♠; 4♠  = 4  of ♠
5♠  : Card 5  ♠; 5♠  = 5  of ♠
6♠  : Card 6  ♠; 6♠  = 6  of ♠
7♠  : Card 7  ♠; 7♠  = 7  of ♠
8♠  : Card 8  ♠; 8♠  = 8  of ♠
9♠  : Card 9  ♠; 9♠  = 9  of ♠
10♠ : Card 10 ♠; 10♠ = 10 of ♠
J♠  : Card J  ♠; J♠  = J  of ♠
Q♠  : Card Q  ♠; Q♠  = Q  of ♠
K♠  : Card K  ♠; K♠  = K  of ♠

-- A run of length ℓ.
data Run  (suit : Suit) : (start ℓ : ℕ) → Set where
  [] : {start : ℕ} → Run  suit  start 0

  _,_ : {n ℓ : ℕ}
       → Card n suit
       → Run    suit (1 + n)     ℓ
       → Run    suit    n     (1 + ℓ)

-- A group of length ℓ.
data Group : (value ℓ : ℕ) → Set where
  [] : {value : ℕ} → Group value 0

  _,_ : {suit : Suit} {value ℓ : ℕ}
       → Card   value  suit
       → Group  value    ℓ
       → Group  value    (1 + ℓ)

-- Some pretty functions for creating runs. You can create a run as
-- follows:
--
-- myrun = ⟨ A♣ , 2♣ , 3♣ ⟩
--

⟨_ : {suit : Suit} {n ℓ : ℕ} → Run suit n ℓ → Run suit n ℓ
⟨ r = r

_⟩ : {suit : Suit} {n : ℕ} → Card n suit → Run suit n 1
c ⟩ = c , []

-- Some pretty functions for creating groups. You can create a group
-- group as follows:
--
-- mygroup = ⟦ A♣ , A♥ , A♢ ⟧
--

⟦_ : {value ℓ : ℕ} → Group value ℓ → Group value ℓ
⟦ g = g

_⟧ : {suit : Suit} {n : ℕ} → Card n suit → Group n 1
c ⟧ = c , []

infixr 2 _⟩ _⟧ _,_
infixl 1 ⟨_ ⟦_

mygroup = ⟦ A♣ , A♣ , A♠ ⟧
myrun   = ⟨ A♣ , 2♣ , 3♣ ⟩


------------------------------------------------------------------------
-- Some definitions related to and properties of natural numbers
------------------------------------------------------------------------

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

open import Equality

module Nat
  {reflexive} (eq : ∀ {a p} → Equality-with-J a p reflexive) where

import Agda.Builtin.Bool
import Agda.Builtin.Nat

open import Logical-equivalence using (_⇔_)
open import Prelude

open Derived-definitions-and-properties eq

------------------------------------------------------------------------
-- A helper function

private

  -- Converts builtin booleans to Bool.

  Bool→Bool : Agda.Builtin.Bool.Bool → Bool
  Bool→Bool Agda.Builtin.Bool.true  = true
  Bool→Bool Agda.Builtin.Bool.false = false

------------------------------------------------------------------------
-- Equality of natural numbers is decidable

-- Inhabited only for zero.

Zero : ℕ → Type
Zero zero    = ⊤
Zero (suc n) = ⊥

-- Predecessor (except if the argument is zero).

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

abstract

  -- Zero is not equal to the successor of any number.

  0≢+ : {n : ℕ} → zero ≢ suc n
  0≢+ 0≡+ = subst Zero 0≡+ tt

-- The suc constructor is cancellative.

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

-- Equality of natural numbers is decidable.

infix 4 _≟_

_≟_ : Decidable-equality ℕ
zero  ≟ zero  = yes (refl _)
suc m ≟ suc n = ⊎-map (cong suc) (λ m≢n → m≢n ∘ cancel-suc) (m ≟ n)
zero  ≟ suc n = no 0≢+
suc m ≟ zero  = no (0≢+ ∘ sym)

-- An equality test that is likely to be more efficient.

infix 4 _==_

_==_ : ℕ → ℕ → Bool
m == n = Bool→Bool (m Agda.Builtin.Nat.== n)

------------------------------------------------------------------------
-- Inequality

-- Inequality.

Distinct : ℕ → ℕ → Type
Distinct zero    zero    = ⊥
Distinct zero    (suc _) = ⊤
Distinct (suc _) zero    = ⊤
Distinct (suc m) (suc n) = Distinct m n

-- Distinct is pointwise logically equivalent to _≢_.

Distinct⇔≢ : {m n : ℕ} → Distinct m n ⇔ m ≢ n
Distinct⇔≢ = record { to = to _ _; from = from _ _ }
  where
  to : ∀ m n → Distinct m n → m ≢ n
  to zero    zero    ()
  to zero    (suc n) _   = 0≢+
  to (suc m) zero    _   = 0≢+ ∘ sym
  to (suc m) (suc n) m≢n = to m n m≢n ∘ cancel-suc

  from : ∀ m n → m ≢ n → Distinct m n
  from zero    zero    0≢0     = 0≢0 (refl 0)
  from zero    (suc n) _       = _
  from (suc m) zero    _       = _
  from (suc m) (suc n) 1+m≢1+n = from m n (1+m≢1+n ∘ cong suc)

-- Two natural numbers are either equal or distinct.

≡⊎Distinct : ∀ m n → m ≡ n ⊎ Distinct m n
≡⊎Distinct m n = ⊎-map id (_⇔_.from Distinct⇔≢) (m ≟ n)

------------------------------------------------------------------------
-- Properties related to _+_

-- Addition is associative.

+-assoc : ∀ m {n o} → m + (n + o) ≡ (m + n) + o
+-assoc zero    = refl _
+-assoc (suc m) = cong suc (+-assoc m)

-- Zero is a right additive unit.

+-right-identity : ∀ {n} → n + 0 ≡ n
+-right-identity {zero}  = refl 0
+-right-identity {suc _} = cong suc +-right-identity

-- The successor constructor can be moved from one side of _+_ to the
-- other.

suc+≡+suc : ∀ m {n} → suc m + n ≡ m + suc n
suc+≡+suc zero    = refl _
suc+≡+suc (suc m) = cong suc (suc+≡+suc m)

-- Addition is commutative.

+-comm : ∀ m {n} → m + n ≡ n + m
+-comm zero        = sym +-right-identity
+-comm (suc m) {n} =
  suc (m + n)  ≡⟨ cong suc (+-comm m) ⟩
  suc (n + m)  ≡⟨ suc+≡+suc n ⟩∎
  n + suc m    ∎

-- A number is not equal to a strictly larger number.

≢1+ : ∀ m {n} → ¬ m ≡ suc (m + n)
≢1+ zero    p = 0≢+ p
≢1+ (suc m) p = ≢1+ m (cancel-suc p)

-- Addition is left cancellative.

+-cancellativeˡ : ∀ {m n₁ n₂} → m + n₁ ≡ m + n₂ → n₁ ≡ n₂
+-cancellativeˡ {zero}  = id
+-cancellativeˡ {suc m} = +-cancellativeˡ ∘ cancel-suc

-- Addition is right cancellative.

+-cancellativeʳ : ∀ {m₁ m₂ n} → m₁ + n ≡ m₂ + n → m₁ ≡ m₂
+-cancellativeʳ {m₁} {m₂} {n} hyp = +-cancellativeˡ (
  n + m₁  ≡⟨ +-comm n ⟩
  m₁ + n  ≡⟨ hyp ⟩
  m₂ + n  ≡⟨ +-comm m₂ ⟩∎
  n + m₂  ∎)

------------------------------------------------------------------------
-- Properties related to _*_

-- Zero is a right zero for multiplication.

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

-- Multiplication is commutative.

*-comm : ∀ m {n} → m * n ≡ n * m
*-comm zero    {n}     = sym (*-right-zero n)
*-comm (suc m) {zero}  = *-right-zero m
*-comm (suc m) {suc n} =
  suc (n + m * suc n)    ≡⟨ cong (suc ∘ (n +_)) (*-comm m) ⟩
  suc (n + suc n * m)    ≡⟨⟩
  suc (n + (m + n * m))  ≡⟨ cong suc (+-assoc n) ⟩
  suc (n + m + n * m)    ≡⟨ cong₂ (λ x y → suc (x + y)) (+-comm n) (sym (*-comm m)) ⟩
  suc (m + n + m * n)    ≡⟨ cong suc (sym (+-assoc m)) ⟩
  suc (m + (n + m * n))  ≡⟨⟩
  suc (m + suc m * n)    ≡⟨ cong (suc ∘ (m +_)) (*-comm (suc m) {n}) ⟩∎
  suc (m + n * suc m)    ∎

-- One is a left identity for multiplication.

*-left-identity : ∀ {n} → 1 * n ≡ n
*-left-identity {n} =
  1 * n     ≡⟨⟩
  n + zero  ≡⟨ +-right-identity ⟩∎
  n         ∎

-- One is a right identity for multiplication.

*-right-identity : ∀ n → n * 1 ≡ n
*-right-identity n =
  n * 1 ≡⟨ *-comm n ⟩
  1 * n ≡⟨ *-left-identity ⟩∎
  n     ∎

-- Multiplication distributes from the left over addition.

*-+-distribˡ : ∀ m {n o} → m * (n + o) ≡ m * n + m * o
*-+-distribˡ zero            = refl _
*-+-distribˡ (suc m) {n} {o} =
  n + o + m * (n + o)        ≡⟨ cong ((n + o) +_) (*-+-distribˡ m) ⟩
  n + o + (m * n + m * o)    ≡⟨ sym (+-assoc n) ⟩
  n + (o + (m * n + m * o))  ≡⟨ cong (n +_) (+-assoc o) ⟩
  n + (o + m * n + m * o)    ≡⟨ cong ((n +_) ∘ (_+ m * o)) (+-comm o) ⟩
  n + (m * n + o + m * o)    ≡⟨ cong (n +_) (sym (+-assoc (m * _))) ⟩
  n + (m * n + (o + m * o))  ≡⟨ +-assoc n ⟩∎
  n + m * n + (o + m * o)    ∎

-- Multiplication distributes from the right over addition.

*-+-distribʳ : ∀ m {n o} → (m + n) * o ≡ m * o + n * o
*-+-distribʳ m {n} {o} =
  (m + n) * o    ≡⟨ *-comm (m + _) ⟩
  o * (m + n)    ≡⟨ *-+-distribˡ o ⟩
  o * m + o * n  ≡⟨ cong₂ _+_ (*-comm o) (*-comm o) ⟩∎
  m * o + n * o  ∎

-- Multiplication is associative.

*-assoc : ∀ m {n k} → m * (n * k) ≡ (m * n) * k
*-assoc zero                    = refl _
*-assoc (suc m) {n = n} {k = k} =
  n * k + m * (n * k)  ≡⟨ cong (n * k +_) $ *-assoc m ⟩
  n * k + (m * n) * k  ≡⟨ sym $ *-+-distribʳ n ⟩∎
  (n + m * n) * k      ∎

-- Multiplication is right cancellative for positive numbers.

*-cancellativeʳ : ∀ {m₁ m₂ n} → m₁ * suc n ≡ m₂ * suc n → m₁ ≡ m₂
*-cancellativeʳ {zero}   {zero}   = λ _ → zero  ∎
*-cancellativeʳ {zero}   {suc _}  = ⊥-elim ∘ 0≢+
*-cancellativeʳ {suc _}  {zero}   = ⊥-elim ∘ 0≢+ ∘ sym
*-cancellativeʳ {suc m₁} {suc m₂} =
  cong suc ∘
  *-cancellativeʳ ∘
  +-cancellativeˡ

-- Multiplication is left cancellative for positive numbers.

*-cancellativeˡ : ∀ m {n₁ n₂} → suc m * n₁ ≡ suc m * n₂ → n₁ ≡ n₂
*-cancellativeˡ m {n₁} {n₂} hyp = *-cancellativeʳ (
  n₁ * suc m  ≡⟨ *-comm n₁ ⟩
  suc m * n₁  ≡⟨ hyp ⟩
  suc m * n₂  ≡⟨ *-comm (suc m) ⟩∎
  n₂ * suc m  ∎)

-- Even numbers are not equal to odd numbers.

even≢odd : ∀ m n → 2 * m ≢ 1 + 2 * n
even≢odd zero    n eq = 0≢+ eq
even≢odd (suc m) n eq =
  even≢odd n m (
    2 * n            ≡⟨ sym $ cancel-suc eq ⟩
    m + 1 * (1 + m)  ≡⟨ sym $ suc+≡+suc m ⟩∎
    1 + 2 * m        ∎)

------------------------------------------------------------------------
-- Properties related to _^_

-- One is a right identity for exponentiation.

^-right-identity : ∀ {n} → n ^ 1 ≡ n
^-right-identity {n} =
  n ^ 1  ≡⟨⟩
  n * 1  ≡⟨ *-right-identity _ ⟩∎
  n      ∎

-- One is a left zero for exponentiation.

^-left-zero : ∀ n → 1 ^ n ≡ 1
^-left-zero zero    = refl _
^-left-zero (suc n) =
  1 ^ suc n  ≡⟨⟩
  1 * 1 ^ n  ≡⟨ *-left-identity ⟩
  1 ^ n      ≡⟨ ^-left-zero n ⟩∎
  1          ∎

-- Some rearrangement lemmas for exponentiation.

^+≡^*^ : ∀ {m} n {k} → m ^ (n + k) ≡ m ^ n * m ^ k
^+≡^*^ {m} zero {k} =
  m ^ k          ≡⟨ sym *-left-identity ⟩
  1 * m ^ k      ≡⟨⟩
  m ^ 0 * m ^ k  ∎
^+≡^*^ {m} (suc n) {k} =
  m ^ (1 + n + k)      ≡⟨⟩
  m * m ^ (n + k)      ≡⟨ cong (m *_) $ ^+≡^*^ n ⟩
  m * (m ^ n * m ^ k)  ≡⟨ *-assoc m ⟩
  m * m ^ n * m ^ k    ≡⟨⟩
  m ^ (1 + n) * m ^ k  ∎

*^≡^*^ : ∀ {m n} k → (m * n) ^ k ≡ m ^ k * n ^ k
*^≡^*^ {m} {n} zero = refl _
*^≡^*^ {m} {n} (suc k) =
  (m * n) ^ suc k            ≡⟨⟩
  m * n * (m * n) ^ k        ≡⟨ cong (m * n *_) $ *^≡^*^ k ⟩
  m * n * (m ^ k * n ^ k)    ≡⟨ sym $ *-assoc m ⟩
  m * (n * (m ^ k * n ^ k))  ≡⟨ cong (m *_) $ *-assoc n ⟩
  m * (n * m ^ k * n ^ k)    ≡⟨ cong (λ x → m * (x * n ^ k)) $ *-comm n ⟩
  m * (m ^ k * n * n ^ k)    ≡⟨ cong (m *_) $ sym $ *-assoc (m ^ k) ⟩
  m * (m ^ k * (n * n ^ k))  ≡⟨ *-assoc m ⟩
  m * m ^ k * (n * n ^ k)    ≡⟨⟩
  m ^ suc k * n ^ suc k      ∎

^^≡^* : ∀ {m} n {k} → (m ^ n) ^ k ≡ m ^ (n * k)
^^≡^* {m} zero    {k} = ^-left-zero k
^^≡^* {m} (suc n) {k} =
  (m ^ (1 + n)) ^ k    ≡⟨⟩
  (m * m ^ n) ^ k      ≡⟨ *^≡^*^ k ⟩
  m ^ k * (m ^ n) ^ k  ≡⟨ cong (m ^ k *_) $ ^^≡^* n ⟩
  m ^ k * m ^ (n * k)  ≡⟨ sym $ ^+≡^*^ k ⟩
  m ^ (k + n * k)      ≡⟨⟩
  m ^ ((1 + n) * k)    ∎

------------------------------------------------------------------------
-- The usual ordering of the natural numbers, along with some
-- properties

-- The ordering.

infix 4 _≤_ _<_

data _≤_ (m n : ℕ) : Type where
  ≤-refl′ : m ≡ n → m ≤ n
  ≤-step′ : ∀ {k} → m ≤ k → suc k ≡ n → m ≤ n

-- Strict inequality.

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

-- Some abbreviations.

≤-refl : ∀ {n} → n ≤ n
≤-refl = ≤-refl′ (refl _)

≤-step : ∀ {m n} → m ≤ n → m ≤ suc n
≤-step m≤n = ≤-step′ m≤n (refl _)

-- _≤_ is transitive.

≤-trans : ∀ {m n o} → m ≤ n → n ≤ o → m ≤ o
≤-trans p (≤-refl′ eq)   = subst (_ ≤_) eq p
≤-trans p (≤-step′ q eq) = ≤-step′ (≤-trans p q) eq

-- If m is strictly less than n, then m is less than or equal to n.

<→≤ : ∀ {m n} → m < n → m ≤ n
<→≤ m<n = ≤-trans (≤-step ≤-refl) m<n

-- "Equational" reasoning combinators.

infix  -1 finally-≤ _∎≤
infixr -2 step-≤ step-≡≤ _≡⟨⟩≤_ step-< _<⟨⟩_

_∎≤ : ∀ n → n ≤ n
_ ∎≤ = ≤-refl

-- For an explanation of why step-≤, step-≡≤ and step-< are defined in
-- this way, see Equality.step-≡.

step-≤ : ∀ m {n o} → n ≤ o → m ≤ n → m ≤ o
step-≤ _ n≤o m≤n = ≤-trans m≤n n≤o

syntax step-≤ m n≤o m≤n = m ≤⟨ m≤n ⟩ n≤o

step-≡≤ : ∀ m {n o} → n ≤ o → m ≡ n → m ≤ o
step-≡≤ _ n≤o m≡n = subst (_≤ _) (sym m≡n) n≤o

syntax step-≡≤ m n≤o m≡n = m ≡⟨ m≡n ⟩≤ n≤o

_≡⟨⟩≤_ : ∀ m {n} → m ≤ n → m ≤ n
_ ≡⟨⟩≤ m≤n = m≤n

finally-≤ : ∀ m n → m ≤ n → m ≤ n
finally-≤ _ _ m≤n = m≤n

syntax finally-≤ m n m≤n = m ≤⟨ m≤n ⟩∎ n ∎≤

step-< : ∀ m {n o} → n ≤ o → m < n → m ≤ o
step-< m {n} {o} n≤o m<n =
  m  ≤⟨ <→≤ m<n ⟩
  n  ≤⟨ n≤o ⟩∎
  o  ∎≤

syntax step-< m n≤o m<n = m <⟨ m<n ⟩ n≤o

_<⟨⟩_ : ∀ m {n} → m < n → m ≤ n
_<⟨⟩_ _ = <→≤

-- Some simple lemmas.

zero≤ : ∀ n → zero ≤ n
zero≤ zero    = ≤-refl
zero≤ (suc n) = ≤-step (zero≤ n)

suc≤suc : ∀ {m n} → m ≤ n → suc m ≤ suc n
suc≤suc (≤-refl′ eq)     = ≤-refl′ (cong suc eq)
suc≤suc (≤-step′ m≤n eq) = ≤-step′ (suc≤suc m≤n) (cong suc eq)

suc≤suc⁻¹ : ∀ {m n} → suc m ≤ suc n → m ≤ n
suc≤suc⁻¹ (≤-refl′ eq)   = ≤-refl′ (cancel-suc eq)
suc≤suc⁻¹ (≤-step′ p eq) =
  ≤-trans (≤-step ≤-refl) (subst (_ ≤_) (cancel-suc eq) p)

m≤m+n : ∀ m n → m ≤ m + n
m≤m+n zero    n = zero≤ n
m≤m+n (suc m) n = suc≤suc (m≤m+n m n)

m≤n+m : ∀ m n → m ≤ n + m
m≤n+m m zero    = ≤-refl
m≤n+m m (suc n) = ≤-step (m≤n+m m n)

pred≤ : ∀ n → pred n ≤ n
pred≤ zero    = ≤-refl
pred≤ (suc _) = ≤-step ≤-refl

-- A decision procedure for _≤_.

infix 4 _≤?_

_≤?_ : Decidable _≤_
zero  ≤? n     = inj₁ (zero≤ n)
suc m ≤? zero  = inj₂ λ { (≤-refl′ eq)   → 0≢+ (sym eq)
                        ; (≤-step′ _ eq) → 0≢+ (sym eq)
                        }
suc m ≤? suc n = ⊎-map suc≤suc (λ m≰n → m≰n ∘ suc≤suc⁻¹) (m ≤? n)

-- A comparison operator that is likely to be more efficient than
-- _≤?_.

infix 4 _<=_

_<=_ : ℕ → ℕ → Bool
m <= n = Bool→Bool (m Agda.Builtin.Nat.< suc n)

-- If m is not less than or equal to n, then n is strictly less
-- than m.

≰→> : ∀ {m n} → ¬ m ≤ n → n < m
≰→> {zero}  {n}     p = ⊥-elim (p (zero≤ n))
≰→> {suc m} {zero}  p = suc≤suc (zero≤ m)
≰→> {suc m} {suc n} p = suc≤suc (≰→> (p ∘ suc≤suc))

-- If m is not less than or equal to n, then n is less than or
-- equal to m.

≰→≥ : ∀ {m n} → ¬ m ≤ n → n ≤ m
≰→≥ p = ≤-trans (≤-step ≤-refl) (≰→> p)

-- If m is less than or equal to n, but not equal to n, then m is
-- strictly less than n.

≤≢→< : ∀ {m n} → m ≤ n → m ≢ n → m < n
≤≢→< (≤-refl′ eq)     m≢m   = ⊥-elim (m≢m eq)
≤≢→< (≤-step′ m≤n eq) m≢1+n = subst (_ <_) eq (suc≤suc m≤n)

-- If m is less than or equal to n, then m is strictly less than n or
-- equal to n.

≤→<⊎≡ : ∀ {m n} → m ≤ n → m < n ⊎ m ≡ n
≤→<⊎≡         (≤-refl′ m≡n)               = inj₂ m≡n
≤→<⊎≡ {m} {n} (≤-step′ {k = k} m≤k 1+k≡n) = inj₁ (
  suc m  ≤⟨ suc≤suc m≤k ⟩
  suc k  ≡⟨ 1+k≡n ⟩≤
  n      ∎≤)

-- _≤_ is total.

total : ∀ m n → m ≤ n ⊎ n ≤ m
total m n = ⊎-map id ≰→≥ (m ≤? n)

-- A variant of total.

infix 4 _≤⊎>_

_≤⊎>_ : ∀ m n → m ≤ n ⊎ n < m
m ≤⊎> n = ⊎-map id ≰→> (m ≤? n)

-- Another variant of total.

infix 4 _<⊎≡⊎>_

_<⊎≡⊎>_ : ∀ m n → m < n ⊎ m ≡ n ⊎ n < m
m <⊎≡⊎> n = case m ≤⊎> n of λ where
  (inj₂ n<m) → inj₂ (inj₂ n<m)
  (inj₁ m≤n) → ⊎-map id inj₁ (≤→<⊎≡ m≤n)

-- A number is not strictly greater than a smaller (strictly or not)
-- number.

+≮ : ∀ m {n} → ¬ m + n < n
+≮ m {n}     (≤-refl′ q)           = ≢1+ n (n            ≡⟨ sym q ⟩
                                            suc (m + n)  ≡⟨ cong suc (+-comm m) ⟩∎
                                            suc (n + m)  ∎)
+≮ m {zero}  (≤-step′ {k = k} p q) = 0≢+ (0      ≡⟨ sym q ⟩∎
                                          suc k  ∎)
+≮ m {suc n} (≤-step′ {k = k} p q) = +≮ m {n} (suc m + n  ≡⟨ suc+≡+suc m ⟩≤
                                               m + suc n  <⟨ p ⟩
                                               k          ≡⟨ cancel-suc q ⟩≤
                                               n          ∎≤)

-- No number is strictly less than zero.

≮0 : ∀ n → ¬ n < zero
≮0 n = +≮ n ∘ subst (_< 0) (sym +-right-identity)

-- _<_ is irreflexive.

<-irreflexive : ∀ {n} → ¬ n < n
<-irreflexive = +≮ 0

-- If m is strictly less than n, then m is not equal to n.

<→≢ : ∀ {m n} → m < n → m ≢ n
<→≢ m<n m≡n = <-irreflexive (subst (_< _) m≡n m<n)

-- Antisymmetry.

≤-antisymmetric : ∀ {m n} → m ≤ n → n ≤ m → m ≡ n
≤-antisymmetric         (≤-refl′ q₁)             _                        = q₁
≤-antisymmetric         _                        (≤-refl′ q₂)             = sym q₂
≤-antisymmetric {m} {n} (≤-step′ {k = k₁} p₁ q₁) (≤-step′ {k = k₂} p₂ q₂) =
  ⊥-elim (<-irreflexive (
    suc k₁  ≡⟨ q₁ ⟩≤
    n       ≤⟨ p₂ ⟩
    k₂      <⟨⟩
    suc k₂  ≡⟨ q₂ ⟩≤
    m       ≤⟨ p₁ ⟩
    k₁      ∎≤))

-- If n is less than or equal to pred n, then n is equal to zero.

≤pred→≡zero : ∀ {n} → n ≤ pred n → n ≡ zero
≤pred→≡zero {zero}  _   = refl _
≤pred→≡zero {suc n} n<n = ⊥-elim (+≮ 0 n<n)

-- The pred function is monotone.

pred-mono : ∀ {m n} → m ≤ n → pred m ≤ pred n
pred-mono         (≤-refl′ m≡n)               = ≤-refl′ (cong pred m≡n)
pred-mono {m} {n} (≤-step′ {k = k} m≤k 1+k≡n) =
  pred m  ≤⟨ pred-mono m≤k ⟩
  pred k  ≤⟨ pred≤ _ ⟩
  k       ≡⟨ cong pred 1+k≡n ⟩≤
  pred n  ∎≤

-- _+_ is monotone.

infixl 6 _+-mono_

_+-mono_ : ∀ {m₁ m₂ n₁ n₂} → m₁ ≤ m₂ → n₁ ≤ n₂ → m₁ + n₁ ≤ m₂ + n₂
_+-mono_ {m₁} {m₂} {n₁} {n₂} (≤-refl′ eq) q =
  m₁ + n₁  ≡⟨ cong (_+ _) eq ⟩≤
  m₂ + n₁  ≤⟨ lemma m₂ q ⟩∎
  m₂ + n₂  ∎≤
  where
  lemma : ∀ m {n k} → n ≤ k → m + n ≤ m + k
  lemma zero    p = p
  lemma (suc m) p = suc≤suc (lemma m p)
_+-mono_ {m₁} {m₂} {n₁} {n₂} (≤-step′ {k = k} p eq) q =
  m₁ + n₁     ≤⟨ p +-mono q ⟩
  k + n₂      ≤⟨ ≤-step (_ ∎≤) ⟩
  suc k + n₂  ≡⟨ cong (_+ _) eq ⟩≤
  m₂ + n₂     ∎≤

-- _*_ is monotone.

infixl 7 _*-mono_

_*-mono_ : ∀ {m₁ m₂ n₁ n₂} → m₁ ≤ m₂ → n₁ ≤ n₂ → m₁ * n₁ ≤ m₂ * n₂
_*-mono_ {zero}          _ _ = zero≤ _
_*-mono_ {suc _} {zero}  p q = ⊥-elim (≮0 _ p)
_*-mono_ {suc _} {suc _} p q = q +-mono suc≤suc⁻¹ p *-mono q

-- 1 is less than or equal to positive natural numbers raised to any
-- power.

1≤+^ : ∀ {m} n → 1 ≤ suc m ^ n
1≤+^ {m} zero    = ≤-refl
1≤+^ {m} (suc n) =
  1                          ≡⟨⟩≤
  1 + 0                      ≤⟨ 1≤+^ n +-mono zero≤ _ ⟩
  suc m ^ n + m * suc m ^ n  ∎≤

private

  -- _^_ is not monotone.

  ¬-^-mono : ¬ (∀ {m₁ m₂ n₁ n₂} → m₁ ≤ m₂ → n₁ ≤ n₂ → m₁ ^ n₁ ≤ m₂ ^ n₂)
  ¬-^-mono mono = ≮0 _ (
    1      ≡⟨⟩≤
    0 ^ 0  ≤⟨ mono (≤-refl {n = 0}) (zero≤ 1) ⟩
    0 ^ 1  ≡⟨⟩≤
    0      ∎≤)

-- _^_ is monotone for positive bases.

infixr 8 _⁺^-mono_

_⁺^-mono_ : ∀ {m₁ m₂ n₁ n₂} →
            suc m₁ ≤ m₂ → n₁ ≤ n₂ → suc m₁ ^ n₁ ≤ m₂ ^ n₂
_⁺^-mono_ {m₁} {m₂ = suc m₂} {n₁ = zero} {n₂} _ _ =
  suc m₁ ^ 0   ≡⟨⟩≤
  1            ≤⟨ 1≤+^ n₂ ⟩
  suc m₂ ^ n₂  ∎≤
_⁺^-mono_ {m₁} {m₂} {suc n₁} {suc n₂} p q =
  suc m₁ * suc m₁ ^ n₁  ≤⟨ p *-mono p ⁺^-mono suc≤suc⁻¹ q ⟩
  m₂     * m₂     ^ n₂  ∎≤
_⁺^-mono_ {m₂ = zero}              p _ = ⊥-elim (≮0 _ p)
_⁺^-mono_ {n₁ = suc _} {n₂ = zero} _ q = ⊥-elim (≮0 _ q)

-- _^_ is monotone for positive exponents.

infixr 8 _^⁺-mono_

_^⁺-mono_ : ∀ {m₁ m₂ n₁ n₂} →
            m₁ ≤ m₂ → suc n₁ ≤ n₂ → m₁ ^ suc n₁ ≤ m₂ ^ n₂
_^⁺-mono_ {zero}  _ _ = zero≤ _
_^⁺-mono_ {suc _} p q = p ⁺^-mono q

-- A natural number raised to a positive power is greater than or
-- equal to the number.

≤^+ : ∀ {m} n → m ≤ m ^ suc n
≤^+ {m} n =
  m          ≡⟨ sym ^-right-identity ⟩≤
  m ^ 1      ≤⟨ ≤-refl {n = m} ^⁺-mono suc≤suc (zero≤ n) ⟩
  m ^ suc n  ∎≤

-- The result of _! is always positive.

1≤! : ∀ n → 1 ≤ n !
1≤! zero    = ≤-refl
1≤! (suc n) =
  1            ≡⟨⟩≤
  1     * 1    ≤⟨ suc≤suc (zero≤ n) *-mono 1≤! n ⟩
  suc n * n !  ≡⟨⟩≤
  suc n !      ∎≤

-- _! is monotone.

infix 9 _!-mono

_!-mono : ∀ {m n} → m ≤ n → m ! ≤ n !
_!-mono {zero}  {n}     _ = 1≤! n
_!-mono {suc m} {zero}  p = ⊥-elim (≮0 _ p)
_!-mono {suc m} {suc n} p =
  suc m * m !  ≤⟨ p *-mono suc≤suc⁻¹ p !-mono ⟩
  suc n * n !  ∎≤

-- An eliminator corresponding to well-founded induction.

well-founded-elim :
  ∀ {p}
  (P : ℕ → Type p) →
  (∀ m → (∀ {n} → n < m → P n) → P m) →
  ∀ m → P m
well-founded-elim P p m = helper (suc m) ≤-refl
  where
  helper : ∀ m {n} → n < m → P n
  helper zero    n<0                           = ⊥-elim (≮0 _ n<0)
  helper (suc m) (≤-step′ {k = k} n<k 1+k≡1+m) =
    helper m (subst (_ <_) (cancel-suc 1+k≡1+m) n<k)
  helper (suc m) (≤-refl′ 1+n≡1+m) =
    subst P (sym (cancel-suc 1+n≡1+m)) (p m (helper m))

-- The accessibility relation for _<_.

data Acc (n : ℕ) : Type where
  acc : (∀ {m} → m < n → Acc m) → Acc n

-- Every natural number is accessible.

accessible : ∀ n → Acc n
accessible = well-founded-elim _ λ _ → acc

------------------------------------------------------------------------
-- An alternative definition of the ordering

-- The following ordering can be used to define a function by
-- recursion up to some bound (see the example below).

infix 4 _≤↑_

data _≤↑_ (m n : ℕ) : Type where
  ≤↑-refl : m ≡ n → m ≤↑ n
  ≤↑-step : suc m ≤↑ n → m ≤↑ n

-- The successor function preserves _≤↑_.

suc≤↑suc : ∀ {m n} → m ≤↑ n → suc m ≤↑ suc n
suc≤↑suc (≤↑-refl m≡n)    = ≤↑-refl (cong suc m≡n)
suc≤↑suc (≤↑-step 1+m≤↑n) = ≤↑-step (suc≤↑suc 1+m≤↑n)

-- Functions that convert between _≤_ and _≤↑_.

≤→≤↑ : ∀ {m n} → m ≤ n → m ≤↑ n
≤→≤↑ (≤-refl′ m≡n)               = ≤↑-refl m≡n
≤→≤↑ (≤-step′ {k = k} m≤k 1+k≡n) =
  subst (_ ≤↑_) 1+k≡n (≤↑-step (suc≤↑suc (≤→≤↑ m≤k)))

≤↑→≤ : ∀ {m n} → m ≤↑ n → m ≤ n
≤↑→≤ (≤↑-refl m≡n)    = ≤-refl′ m≡n
≤↑→≤ (≤↑-step 1+m≤↑n) = <→≤ (≤↑→≤ 1+m≤↑n)

private

  -- An example: The list up-to n consists of all natural numbers from
  -- 0 to n, inclusive.

  up-to : ℕ → List ℕ
  up-to bound = helper 0 (≤→≤↑ (zero≤ bound))
    where
    helper : ∀ n → n ≤↑ bound → List ℕ
    helper n (≤↑-refl _) = n ∷ []
    helper n (≤↑-step p) = n ∷ helper _ p

-- An eliminator wrapping up the technique used in the example above.

up-to-elim :
  ∀ {p}
  (P : ℕ → Type p) →
  ∀ n →
  P n →
  (∀ m → m < n → P (suc m) → P m) →
  P 0
up-to-elim P n Pn P<n = helper 0 (≤→≤↑ (zero≤ n))
  where
  helper : ∀ m → m ≤↑ n → P m
  helper m (≤↑-refl m≡n) = subst P (sym m≡n) Pn
  helper m (≤↑-step m<n) = P<n m (≤↑→≤ m<n) (helper (suc m) m<n)

private

  -- The example, expressed using the eliminator.

  up-to′ : ℕ → List ℕ
  up-to′ bound =
    up-to-elim (const _) bound (bound ∷ []) (λ n _ → n ∷_)

------------------------------------------------------------------------
-- Another alternative definition of the ordering

-- This ordering relation is defined by recursion on the numbers.

infix 4 _≤→_

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

-- Functions that convert between _≤_ and _≤→_.

≤→≤→ : ∀ m n → m ≤ n → m ≤→ n
≤→≤→ zero    _       _ = _
≤→≤→ (suc m) zero    p = ≮0 _ p
≤→≤→ (suc m) (suc n) p = ≤→≤→ m n (suc≤suc⁻¹ p)

≤→→≤ : ∀ m n → m ≤→ n → m ≤ n
≤→→≤ zero    n       _  = zero≤ n
≤→→≤ (suc m) zero    ()
≤→→≤ (suc m) (suc n) p  = suc≤suc (≤→→≤ m n p)

------------------------------------------------------------------------
-- Properties related to _∸_

-- Zero is a left zero of truncated subtraction.

∸-left-zero : ∀ n → 0 ∸ n ≡ 0
∸-left-zero zero    = refl _
∸-left-zero (suc _) = refl _

-- A form of associativity for _∸_.

∸-∸-assoc : ∀ {m} n {k} → (m ∸ n) ∸ k ≡ m ∸ (n + k)
∸-∸-assoc         zero            = refl _
∸-∸-assoc {zero}  (suc _) {zero}  = refl _
∸-∸-assoc {zero}  (suc _) {suc _} = refl _
∸-∸-assoc {suc _} (suc n)         = ∸-∸-assoc n

-- A limited form of associativity for _+_ and _∸_.

+-∸-assoc : ∀ {m n k} → k ≤ n → (m + n) ∸ k ≡ m + (n ∸ k)
+-∸-assoc {m} {n} {zero} _ =
  m + n ∸ 0    ≡⟨⟩
  m + n        ≡⟨⟩
  m + (n ∸ 0)  ∎
+-∸-assoc {m} {zero}  {suc k} <0      = ⊥-elim (≮0 _ <0)
+-∸-assoc {m} {suc n} {suc k} 1+k≤1+n =
  m + suc n ∸ suc k    ≡⟨ cong (_∸ suc k) (sym (suc+≡+suc m)) ⟩
  suc m + n ∸ suc k    ≡⟨⟩
  m + n ∸ k            ≡⟨ +-∸-assoc (suc≤suc⁻¹ 1+k≤1+n) ⟩
  m + (n ∸ k)          ≡⟨⟩
  m + (suc n ∸ suc k)  ∎

-- A special case of +-∸-assoc.

∸≡suc∸suc : ∀ {m n} → n < m → m ∸ n ≡ suc (m ∸ suc n)
∸≡suc∸suc = +-∸-assoc

-- If you add a number and then subtract it again, then you get back
-- what you started with.

+∸≡ : ∀ {m} n → (m + n) ∸ n ≡ m
+∸≡ {m} zero =
  m + 0  ≡⟨ +-right-identity ⟩∎
  m      ∎
+∸≡ {zero}  (suc n) = +∸≡ n
+∸≡ {suc m} (suc n) =
  m + suc n ∸ n  ≡⟨ cong (_∸ n) (sym (suc+≡+suc m))  ⟩
  suc m + n ∸ n  ≡⟨ +∸≡ n ⟩∎
  suc m          ∎

-- If you subtract a number from itself, then the answer is zero.

∸≡0 : ∀ n → n ∸ n ≡ 0
∸≡0 = +∸≡

-- If you subtract a number and then add it again, then you get back
-- what you started with if the number is less than or equal to the
-- number that you started with.

∸+≡ : ∀ {m n} → n ≤ m → (m ∸ n) + n ≡ m
∸+≡ {m} {n} (≤-refl′ n≡m) =
  (m ∸ n) + n  ≡⟨ cong (λ n → m ∸ n + n) n≡m ⟩
  (m ∸ m) + m  ≡⟨ cong (_+ m) (∸≡0 m) ⟩
  0 + m        ≡⟨⟩
  m            ∎
∸+≡ {m} {n} (≤-step′ {k = k} n≤k 1+k≡m) =
  (m ∸ n) + n        ≡⟨ cong (λ m → m ∸ n + n) (sym 1+k≡m) ⟩
  (1 + k ∸ n) + n    ≡⟨ cong (_+ n) (∸≡suc∸suc (suc≤suc n≤k)) ⟩
  1 + ((k ∸ n) + n)  ≡⟨ cong (1 +_) (∸+≡ n≤k) ⟩
  1 + k              ≡⟨ 1+k≡m ⟩∎
  m                  ∎

-- If you subtract a number and then add it again, then you get
-- something that is greater than or equal to what you started with.

≤∸+ : ∀ m n → m ≤ (m ∸ n) + n
≤∸+ m zero =
  m      ≡⟨ sym +-right-identity ⟩≤
  m + 0  ∎≤
≤∸+ zero    (suc n) = zero≤ _
≤∸+ (suc m) (suc n) =
  suc m            ≤⟨ suc≤suc (≤∸+ m n) ⟩
  suc (m ∸ n + n)  ≡⟨ suc+≡+suc _ ⟩≤
  m ∸ n + suc n    ∎≤

-- If you subtract something from a number you get a number that is
-- less than or equal to the one you started with.

∸≤ : ∀ m n → m ∸ n ≤ m
∸≤ _       zero    = ≤-refl
∸≤ zero    (suc _) = ≤-refl
∸≤ (suc m) (suc n) = ≤-step (∸≤ m n)

-- A kind of commutativity for _+ n and _∸ k.

+-∸-comm : ∀ {m n k} → k ≤ m → (m + n) ∸ k ≡ (m ∸ k) + n
+-∸-comm {m} {n} {k = zero}  = const (m + n  ∎)
+-∸-comm {zero}  {k = suc k} = ⊥-elim ∘ ≮0 k
+-∸-comm {suc _} {k = suc _} = +-∸-comm ∘ suc≤suc⁻¹

-- _∸_ is monotone in its first argument and antitone in its second
-- argument.

infixl 6 _∸-mono_

_∸-mono_ : ∀ {m₁ m₂ n₁ n₂} → m₁ ≤ m₂ → n₂ ≤ n₁ → m₁ ∸ n₁ ≤ m₂ ∸ n₂
_∸-mono_              {n₁ = zero}   {zero}  p _ = p
_∸-mono_              {n₁ = zero}   {suc _} _ q = ⊥-elim (≮0 _ q)
_∸-mono_ {zero}       {n₁ = suc n₁}         _ _ = zero≤ _
_∸-mono_ {suc _}  {zero}   {suc _}          p _ = ⊥-elim (≮0 _ p)
_∸-mono_ {suc m₁} {suc m₂} {suc n₁} {zero}  p _ = m₁ ∸ n₁  ≤⟨ ∸≤ _ n₁ ⟩
                                                  m₁       ≤⟨ pred≤ _ ⟩
                                                  suc m₁   ≤⟨ p ⟩∎
                                                  suc m₂   ∎≤
_∸-mono_ {suc _}  {suc _}  {suc _}  {suc _} p q =
  suc≤suc⁻¹ p ∸-mono suc≤suc⁻¹ q

-- The predecessor function can be expressed using _∸_.

pred≡∸1 : ∀ n → pred n ≡ n ∸ 1
pred≡∸1 zero    = refl _
pred≡∸1 (suc _) = refl _

------------------------------------------------------------------------
-- Minimum and maximum

-- Minimum.

min : ℕ → ℕ → ℕ
min zero    n       = zero
min m       zero    = zero
min (suc m) (suc n) = suc (min m n)

-- Maximum.

max : ℕ → ℕ → ℕ
max zero    n       = n
max m       zero    = m
max (suc m) (suc n) = suc (max m n)

-- The min operation can be expressed using repeated truncated
-- subtraction.

min≡∸∸ : ∀ m n → min m n ≡ m ∸ (m ∸ n)
min≡∸∸ zero n =
  0            ≡⟨ sym (∸-left-zero (0 ∸ n)) ⟩∎
  0 ∸ (0 ∸ n)  ∎
min≡∸∸ (suc m) zero =
  0      ≡⟨ sym (∸≡0 m) ⟩∎
  m ∸ m  ∎
min≡∸∸ (suc m) (suc n) =
  suc (min m n)      ≡⟨ cong suc (min≡∸∸ m n) ⟩
  suc (m ∸ (m ∸ n))  ≡⟨ sym (+-∸-assoc (∸≤ _ n)) ⟩∎
  suc m ∸ (m ∸ n)    ∎

-- The max operation can be expressed using addition and truncated
-- subtraction.

max≡+∸ : ∀ m n → max m n ≡ m + (n ∸ m)
max≡+∸ zero    _       = refl _
max≡+∸ (suc m) zero    = suc m        ≡⟨ cong suc (sym +-right-identity) ⟩∎
                         suc (m + 0)  ∎
max≡+∸ (suc m) (suc n) = cong suc (max≡+∸ m n)

-- The _≤_ relation can be expressed in terms of the min function.

≤⇔min≡ : ∀ {m n} → m ≤ n ⇔ min m n ≡ m
≤⇔min≡ = record { to = to _ _ ∘ ≤→≤→ _ _; from = from _ _ }
  where
  to : ∀ m n → m ≤→ n → min m n ≡ m
  to zero    n       = const (refl zero)
  to (suc m) zero    = λ ()
  to (suc m) (suc n) = cong suc ∘ to m n

  from : ∀ m n → min m n ≡ m → m ≤ n
  from zero    n       = const (zero≤ n)
  from (suc m) zero    = ⊥-elim ∘ 0≢+
  from (suc m) (suc n) = suc≤suc ∘ from m n ∘ cancel-suc

-- The _≤_ relation can be expressed in terms of the max function.

≤⇔max≡ : ∀ {m n} → m ≤ n ⇔ max m n ≡ n
≤⇔max≡ {m} = record { to = to m _ ∘ ≤→≤→ _ _; from = from _ _ }
  where
  to : ∀ m n → m ≤→ n → max m n ≡ n
  to zero    n       = const (refl n)
  to (suc m) zero    = λ ()
  to (suc m) (suc n) = cong suc ∘ to m n

  from : ∀ m n → max m n ≡ n → m ≤ n
  from zero    n       = const (zero≤ n)
  from (suc m) zero    = ⊥-elim ∘ 0≢+ ∘ sym
  from (suc m) (suc n) = suc≤suc ∘ from m n ∘ cancel-suc

-- Given two numbers one is the minimum and the other is the maximum.

min-and-max :
  ∀ m n → min m n ≡ m × max m n ≡ n ⊎ min m n ≡ n × max m n ≡ m
min-and-max zero    _       = inj₁ (refl _ , refl _)
min-and-max (suc _) zero    = inj₂ (refl _ , refl _)
min-and-max (suc m) (suc n) =
  ⊎-map (Σ-map (cong suc) (cong suc))
        (Σ-map (cong suc) (cong suc))
        (min-and-max m n)

-- The min operation is idempotent.

min-idempotent : ∀ n → min n n ≡ n
min-idempotent n = case min-and-max n n of [ proj₁ , proj₁ ]

-- The max operation is idempotent.

max-idempotent : ∀ n → max n n ≡ n
max-idempotent n = case min-and-max n n of [ proj₂ , proj₂ ]

-- The min operation is commutative.

min-comm : ∀ m n → min m n ≡ min n m
min-comm zero    zero    = refl _
min-comm zero    (suc _) = refl _
min-comm (suc _) zero    = refl _
min-comm (suc m) (suc n) = cong suc (min-comm m n)

-- The max operation is commutative.

max-comm : ∀ m n → max m n ≡ max n m
max-comm zero    zero    = refl _
max-comm zero    (suc _) = refl _
max-comm (suc _) zero    = refl _
max-comm (suc m) (suc n) = cong suc (max-comm m n)

-- The min operation is associative.

min-assoc : ∀ m {n o} → min m (min n o) ≡ min (min m n) o
min-assoc zero                            = refl _
min-assoc (suc m) {n = zero}              = refl _
min-assoc (suc m) {n = suc n} {o = zero}  = refl _
min-assoc (suc m) {n = suc n} {o = suc o} = cong suc (min-assoc m)

-- The max operation is associative.

max-assoc : ∀ m {n o} → max m (max n o) ≡ max (max m n) o
max-assoc zero                            = refl _
max-assoc (suc m) {n = zero}              = refl _
max-assoc (suc m) {n = suc n} {o = zero}  = refl _
max-assoc (suc m) {n = suc n} {o = suc o} = cong suc (max-assoc m)

-- The minimum is less than or equal to both arguments.

min≤ˡ : ∀ m n → min m n ≤ m
min≤ˡ zero    _       = ≤-refl
min≤ˡ (suc _) zero    = zero≤ _
min≤ˡ (suc m) (suc n) = suc≤suc (min≤ˡ m n)

min≤ʳ : ∀ m n → min m n ≤ n
min≤ʳ m n =
  min m n  ≡⟨ min-comm _ _ ⟩≤
  min n m  ≤⟨ min≤ˡ _ _ ⟩∎
  n        ∎≤

-- The maximum is greater than or equal to both arguments.

ˡ≤max : ∀ m n → m ≤ max m n
ˡ≤max zero    _       = zero≤ _
ˡ≤max (suc _) zero    = ≤-refl
ˡ≤max (suc m) (suc n) = suc≤suc (ˡ≤max m n)

ʳ≤max : ∀ m n → n ≤ max m n
ʳ≤max m n =
  n        ≤⟨ ˡ≤max _ _ ⟩
  max n m  ≡⟨ max-comm n _ ⟩≤
  max m n  ∎≤

-- A kind of distributivity property for max and _∸_.

max-∸ : ∀ m n o → max (m ∸ o) (n ∸ o) ≡ max m n ∸ o
max-∸ m       n       zero    = refl _
max-∸ zero    n       (suc o) = refl _
max-∸ (suc m) (suc n) (suc o) = max-∸ m n o
max-∸ (suc m) zero    (suc o) =
  max (m ∸ o) 0  ≡⟨ max-comm _ 0 ⟩
  m ∸ o          ∎

------------------------------------------------------------------------
-- Division by two

-- Division by two, rounded upwards.

⌈_/2⌉ : ℕ → ℕ
⌈ zero        /2⌉ = zero
⌈ suc zero    /2⌉ = suc zero
⌈ suc (suc n) /2⌉ = suc ⌈ n /2⌉

-- Division by two, rounded downwards.

⌊_/2⌋ : ℕ → ℕ
⌊ zero        /2⌋ = zero
⌊ suc zero    /2⌋ = zero
⌊ suc (suc n) /2⌋ = suc ⌊ n /2⌋

-- Some simple lemmas related to division by two.

⌈/2⌉+⌊/2⌋ : ∀ n → ⌈ n /2⌉ + ⌊ n /2⌋ ≡ n
⌈/2⌉+⌊/2⌋ zero          = refl _
⌈/2⌉+⌊/2⌋ (suc zero)    = refl _
⌈/2⌉+⌊/2⌋ (suc (suc n)) =
  suc ⌈ n /2⌉ + suc ⌊ n /2⌋      ≡⟨ cong suc (sym (suc+≡+suc _)) ⟩
  suc (suc (⌈ n /2⌉ + ⌊ n /2⌋))  ≡⟨ cong (suc ∘ suc) (⌈/2⌉+⌊/2⌋ n) ⟩∎
  suc (suc n)                    ∎

⌊/2⌋≤⌈/2⌉ : ∀ n → ⌊ n /2⌋ ≤ ⌈ n /2⌉
⌊/2⌋≤⌈/2⌉ zero          = ≤-refl
⌊/2⌋≤⌈/2⌉ (suc zero)    = zero≤ 1
⌊/2⌋≤⌈/2⌉ (suc (suc n)) = suc≤suc (⌊/2⌋≤⌈/2⌉ n)

⌈/2⌉≤ : ∀ n → ⌈ n /2⌉ ≤ n
⌈/2⌉≤ zero          = ≤-refl
⌈/2⌉≤ (suc zero)    = ≤-refl
⌈/2⌉≤ (suc (suc n)) =
  suc ⌈ n /2⌉  ≤⟨ suc≤suc (⌈/2⌉≤ n) ⟩
  suc n        ≤⟨ m≤n+m _ 1 ⟩∎
  suc (suc n)  ∎≤

⌈/2⌉< : ∀ n → ⌈ 2 + n /2⌉ < 2 + n
⌈/2⌉< n =
  2 + ⌈ n /2⌉  ≤⟨ ≤-refl +-mono ⌈/2⌉≤ n ⟩∎
  2 + n        ∎≤

⌊/2⌋< : ∀ n → ⌊ 1 + n /2⌋ < 1 + n
⌊/2⌋< zero    = ≤-refl
⌊/2⌋< (suc n) =
  2 + ⌊ n /2⌋  ≤⟨ ≤-refl +-mono ⌊/2⌋≤⌈/2⌉ n ⟩
  2 + ⌈ n /2⌉  ≤⟨ ⌈/2⌉< n ⟩∎
  2 + n        ∎≤

⌈2*+/2⌉≡ : ∀ m {n} → ⌈ 2 * m + n /2⌉ ≡ m + ⌈ n /2⌉
⌈2*+/2⌉≡ zero            = refl _
⌈2*+/2⌉≡ (suc m) {n = n} =
  ⌈ 2 * (1 + m) + n /2⌉  ≡⟨ cong (λ m → ⌈ m + n /2⌉) (*-+-distribˡ 2 {n = 1}) ⟩
  ⌈ 2 + 2 * m + n /2⌉    ≡⟨⟩
  1 + ⌈ 2 * m + n /2⌉    ≡⟨ cong suc (⌈2*+/2⌉≡ m) ⟩∎
  1 + m + ⌈ n /2⌉        ∎

⌊2*+/2⌋≡ : ∀ m {n} → ⌊ 2 * m + n /2⌋ ≡ m + ⌊ n /2⌋
⌊2*+/2⌋≡ zero            = refl _
⌊2*+/2⌋≡ (suc m) {n = n} =
  ⌊ 2 * (1 + m) + n /2⌋  ≡⟨ cong (λ m → ⌊ m + n /2⌋) (*-+-distribˡ 2 {n = 1}) ⟩
  ⌊ 2 + 2 * m + n /2⌋    ≡⟨⟩
  1 + ⌊ 2 * m + n /2⌋    ≡⟨ cong suc (⌊2*+/2⌋≡ m) ⟩∎
  1 + m + ⌊ n /2⌋        ∎

⌈2*/2⌉≡ : ∀ n → ⌈ 2 * n /2⌉ ≡ n
⌈2*/2⌉≡ n =
  ⌈ 2 * n /2⌉      ≡⟨ cong ⌈_/2⌉ $ sym +-right-identity ⟩
  ⌈ 2 * n + 0 /2⌉  ≡⟨ ⌈2*+/2⌉≡ n ⟩
  n + ⌈ 0 /2⌉      ≡⟨⟩
  n + 0            ≡⟨ +-right-identity ⟩∎
  n                ∎

⌈1+2*/2⌉≡ : ∀ n → ⌈ 1 + 2 * n /2⌉ ≡ 1 + n
⌈1+2*/2⌉≡ n =
  ⌈ 1 + 2 * n /2⌉  ≡⟨ cong ⌈_/2⌉ $ +-comm 1 ⟩
  ⌈ 2 * n + 1 /2⌉  ≡⟨ ⌈2*+/2⌉≡ n ⟩
  n + ⌈ 1 /2⌉      ≡⟨⟩
  n + 1            ≡⟨ +-comm n ⟩∎
  1 + n            ∎

⌊2*/2⌋≡ : ∀ n → ⌊ 2 * n /2⌋ ≡ n
⌊2*/2⌋≡ n =
  ⌊ 2 * n /2⌋      ≡⟨ cong ⌊_/2⌋ $ sym +-right-identity ⟩
  ⌊ 2 * n + 0 /2⌋  ≡⟨ ⌊2*+/2⌋≡ n ⟩
  n + ⌊ 0 /2⌋      ≡⟨⟩
  n + 0            ≡⟨ +-right-identity ⟩∎
  n                ∎

⌊1+2*/2⌋≡ : ∀ n → ⌊ 1 + 2 * n /2⌋ ≡ n
⌊1+2*/2⌋≡ n =
  ⌊ 1 + 2 * n /2⌋  ≡⟨ cong ⌊_/2⌋ $ +-comm 1 ⟩
  ⌊ 2 * n + 1 /2⌋  ≡⟨ ⌊2*+/2⌋≡ n ⟩
  n + ⌊ 1 /2⌋      ≡⟨⟩
  n + 0            ≡⟨ +-right-identity ⟩∎
  n                ∎


{- Byzantine Fault Tolerant Consensus Verification in Agda, version 0.9.

   Copyright (c) 2021, Oracle and/or its affiliates.
   Licensed under the Universal Permissive License v 1.0 as shown at https://opensource.oracle.com/licenses/upl
-}

open import LibraBFT.Base.Types
import      LibraBFT.Impl.Consensus.ConsensusTypes.VoteData as VoteData
open import LibraBFT.ImplShared.Base.Types
open import LibraBFT.ImplShared.Consensus.Types
open import Optics.All
open import Util.Prelude

module LibraBFT.Impl.Consensus.ConsensusTypes.Properties.VoteData (self : VoteData) where

  record Contract : Set where
    field
      ep≡     : self ^∙ vdParent ∙ biEpoch ≡ self ^∙ vdProposed ∙ biEpoch
      parRnd< : self ^∙ vdParent ∙ biRound < self ^∙ vdProposed ∙ biRound
      parVer≤ : (self ^∙ vdParent ∙ biVersion) ≤-Version (self ^∙ vdProposed ∙ biVersion)
  open Contract

  contract
      : VoteData.verify self ≡ Right unit → Contract
  contract
     with self ^∙ vdParent ∙ biEpoch ≟ self ^∙ vdProposed ∙ biEpoch
  ...| no neq = (λ ())
  ...| yes refl
     with self ^∙ vdParent ∙ biRound <? self ^∙ vdProposed ∙ biRound
  ...| no ¬par<prop = (λ ())
  ...| yes par<prop
     with (self ^∙ vdParent ∙ biVersion) ≤?-Version (self ^∙ vdProposed ∙ biVersion)
  ...| no ¬parVer≤ = (λ ())
  ...| yes parVer≤ = (λ x → record { ep≡ = refl
                                   ; parRnd< = par<prop
                                   ; parVer≤ = parVer≤ })


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

module Fragment.Extensions.CSemigroup where

open import Fragment.Extensions.CSemigroup.Base using (CSemigroupFrex) public


-- Andreas, 2017-02-15, issue #2462
-- Overloaded postfix projection should resolve

postulate
  A : Set

record R : Set where
  constructor mkR
  field f : A
open R

record S : Set where
  field f : R
open S

test : S → A
test s = let mkR x = s .f in x

-- Error WAS:
-- Cannot resolve overloaded projection f because it is not applied to
-- a visible argument
-- when inferring the type of .f


-- Andreas, 2016-05-10, issue 1848, reported by Nisse

-- {-# OPTIONS -v tc.lhs.top:20 #-}

data D : Set where
  c : D → D

postulate
  P : D → Set

foo : (x : D) → P x
foo _ = {!!}

-- checked lhs:
--   ps    =  _
--   delta =  (x : D)
--   qs    =  [r(x = VarP (0,"x"))]

-- The unnamed variable is part of the context:

-- Goal: P .x
-- ————————————————————————————————————————————————————————————
-- .x : D

bar : (x : D) → P x
bar (c _) = {!!}

-- WAS:
-- checked lhs:
--   ps    =  _
--   delta =  (_ : D)
--   qs    =  [r(x = ConP Issue1848.D.c ... [r(_ = VarP (0,"_"))])]

-- The unnamed variable is not part of the context:

-- Goal: P (c _)
-- ————————————————————————————————————————————————————————————

-- This can, in more complicated situations, make the goal type harder
-- to understand.

-- NOW:
-- Unnamed variable should be displayed in the context, e.g., as ".x"


-- Andreas, 2018-05-28, issue #3095, cannot make hidden shadowing variable visible
-- Andreas, 2019-07-15, issue #3919, make hidden variable visible in par. module

open import Agda.Builtin.Equality

module _ (A : Set) where

data Nat : Set where
  suc : {n : Nat} → Nat

data IsSuc : Nat → Set where
  isSuc : ∀{n} → IsSuc (suc {n})

test₁ : ∀{n} → IsSuc n → Set
test₁ p = aux p
  where
  aux : ∀{n} → IsSuc n → Set
  aux isSuc = {!n!}  -- C-c C-c
  -- Expected: aux (isSuc {n}) = {!!}

-- Context:
-- p  : IsSuc n
-- n : Nat  (not in scope)
-- n₁ : Nat  (not in scope)

-- WAS: ERROR
-- Ambiguous variable n
-- when checking that the expression ? has type Set

test₂ : ∀{m} → IsSuc m → Set
test₂ p = aux p
  where
  aux : ∀{n} → IsSuc n → Set
  aux isSuc = {!m!} -- C-c C-c
  -- Expected: cannot make hidden module parameter m visible

test₃ : ∀ m → IsSuc m → Set
test₃ m p = aux p refl
  where
  aux : ∀{n} → IsSuc n → m ≡ n → Set
  aux isSuc refl = {!n!} -- C-c C-c
  -- Expected: aux (isSuc {n}) refl = ?

test₄ : Nat → Nat
test₄ x = bar x
  where
    bar : Nat → Nat
    bar y = {!x!} -- C-c C-c
    -- Expected: cannot split on module parameter x

test₅ : Nat → {n : Nat} → Nat → Nat
test₅ = λ x y → {!n!} -- C-c C-c
    -- Expected: cannot make hidden lambda-bound variable n visible

issue3919 : {n m : Nat} → n ≡ m
issue3919 = {!m!} -- C-c C-c
    -- Expected: issue3919 {m = m} = ?


{-# OPTIONS --rewriting #-}

postulate _↦_ : ∀ {a} {A : Set a} → A → A → Set
{-# BUILTIN REWRITE _↦_ #-}

open import Agda.Primitive

postulate
  mekker : Level → Level → Set
  moomoo : Level → Set → Set
  rew : (a b : Level) → moomoo (a ⊔ b) (mekker a b) ↦ (Level → Level)

{-# REWRITE rew #-}

works : {a b : Level} → moomoo (a ⊔ b) (mekker a b) → Level
works f = f lzero

fails : {a : Level} → moomoo a (mekker a a) → Level
fails f = f lzero


{-# OPTIONS --safe #-}

open import Generics.Prelude
open import Generics.Telescope
open import Generics.Desc
open import Generics.Mu
open import Generics.Mu.All

module Generics.Mu.Elim
  {P I n} {D : DataDesc P I n}
  {p c} (Pr : ∀ {i} → μ D (p , i) → Set c)
  (f : ∀ {i} (x : μ D (p , i)) → All D Pr x → Pr x) where

private
  variable
    V : ExTele P
    i : ⟦ I ⟧tel p
    v : ⟦ V ⟧tel p

private
  Pr′ : ∀{i} → μ D (p , i) → Setω
  Pr′ x = Liftω (Pr x)

all : (x : μ D (p , i)) → All D Pr x

allIndArg : (C : ConDesc P V I)
            (x : ⟦ C ⟧IndArgω (μ D) (p , v))
          → AllIndArgωω Pr′ C x
allIndArg (var _) x = liftω (f x (all x))
allIndArg (A ⊗ B) (xa , xb) = allIndArg A xa , allIndArg B xb
allIndArg (π _ _ C) x s = allIndArg C (x s)

allCon : (C : ConDesc P V I)
         (x : ⟦ C ⟧Conω (μ D) (p , v , i))
       → AllConωω Pr′ C x
allCon (var _) x = tt
allCon (A ⊗ B) (xa , xb) = allIndArg A xa , allCon B xb
allCon (π _ _ C) (_ , x) = allCon C x

all ⟨ k , x ⟩ = allCon (lookupCon D k) x

elim : (x : μ D (p , i)) → Pr x
elim x = f x (all x)


module Ual.Void where

data ⊥ : Set where

¬ : Set → Set
¬ p = p → ⊥


module SystemF.BigStep.Extrinsic.Semantics where

open import Prelude hiding (⊥; id)
open import Function as Fun using ()
open import Data.List hiding ([_]; monad)
open import Data.List.Properties as ListProp using ()
open import Data.Fin.Substitution
open import Extensions.List

open import SystemF.BigStep.Types
open import SystemF.BigStep.Extrinsic.Terms
open import SystemF.BigStep.Extrinsic.Welltyped

-- environments
mutual
  Env : Set
  Env = List Val

  data Val : Set where
    unit : Val
    clos : Env → (t : Term) → Val
    tclos : Env → (t : Term) → Val

open import Relation.Binary.List.Pointwise hiding (refl; map)
mutual

  -- welltypedness relations between typing contexts and environmets
  -- is just the pointwise extension of value-welltypedness
  _⊢_ : ∀ {n} → Ctx n → Env → Set
  Γ ⊢ E = Rel (λ{ a v → ⊢̬ v ∶ a}) Γ E

  data ⊢̬_∶_ {n} : Val → Type n → Set where

    unit : -------------------
          ⊢̬ unit ∶ Unit

    clos : ∀ {b t}{Γ : Ctx n}{E a} →
            (a ∷ Γ) ⊢ t ∶ b →
            Γ ⊢ E →
            -------------------
            ⊢̬ clos E t ∶ (a ⇒ b)

    tclos : ∀ {a t}{Γ : Ctx n}{E} →
            (Γ ctx/ wk) ⊢ t ∶ a →
            Γ ⊢ E →
            ---------------------
            ⊢̬ tclos E t ∶ ∀' a

module UglyBits where

  _wt/_ : ∀ {n m}{Γ : Ctx n}{t a} → Γ ⊢ t ∶ a → (ρ : Sub Type n m) → (Γ ctx/ ρ) ⊢ t ∶ (a / ρ)
  unit wt/ ρ = unit
  ƛ a t wt/ ρ = ƛ (a / ρ) (t wt/ ρ)
  var x wt/ ρ = var ([]=-map x)
  (f · e) wt/ ρ = (f wt/ ρ) · (e wt/ ρ)
  Λ t wt/ ρ = Λ (subst (λ Γ → Γ ⊢ _ ∶ _) (sym $ CtxLemmas.ctx/-wk-comm _ ρ) (t wt/ (ρ ↑)))
  (_[_] {a = a} t b) wt/ ρ =
    subst (λ a → _ ⊢ _ ∶ a) (sym $ Lemmas.sub-commutes a) ((t wt/ ρ) [ (b / ρ) ])

module StepIndexed where

  open UglyBits
  open import Level as Lev using ()
  open import Data.Maybe
  open import Category.Monad
  open RawMonad (monad {f = Lev.zero})

  -- quadratic return through the layered monad
  pattern just² x = just (just x)

  -- substitution-free semantics in double-layered maybe monad;
  -- distinguishing semantic errors from timeouts
  _⊢_⇓_ : ∀ (μ : Env) → Term → ℕ → Maybe (Maybe Val)
  μ ⊢ x ⇓ zero = nothing
  μ ⊢ unit ⇓ (suc n) = just² unit
  μ ⊢ ƛ t ⇓ (suc n) = just² (clos μ t)
  μ ⊢ Λ t ⇓ (suc n) = just² (tclos μ t )
  μ ⊢ f · e ⇓ (suc n) with (μ ⊢ f ⇓ n) | μ ⊢ e ⇓ n
  -- timeout
  ... | nothing | _ = nothing
  ... | _ | nothing = nothing
  -- success
  ... | just² (clos μ' t) | just² v = (v ∷ μ') ⊢ t ⇓ n
  -- semantic errors & semantic error propagation
  ... | _ | _ = just nothing
  μ ⊢ t [-] ⇓ (suc n) with (μ ⊢ t ⇓ n)
  -- timeout
  ... | nothing = nothing
  -- success
  ... | just² (tclos μ' t') = μ' ⊢ t' ⇓ n
  -- semantic error (propagation)
  ... | _ = just nothing
  μ ⊢ var x ⇓ (suc n) = just (maybe-lookup x μ)

  -- extrinsic safety
  _⊢_⇓_ok : ∀ {n}{Γ : Ctx n}{μ : Env}{t a} →
            Γ ⊢ μ → Γ ⊢ t ∶ a → ∀ n → All (Any (λ v → ⊢̬ v ∶ a)) (μ ⊢ t ⇓ n)

  μ ⊢ x ⇓ zero ok = nothing

  μ ⊢ unit ⇓ suc n ok = just² unit

  μ ⊢ ƛ a x ⇓ suc n ok = just² (clos x μ)

  μ ⊢ Λ x ⇓ suc n ok = just² (tclos x μ)

  _⊢_⇓_ok {μ = E} μ (_·_ {f = f}{e = e} wtf wte) (suc n) with
    E ⊢ f ⇓ n | E ⊢ e ⇓ n | μ ⊢ wtf ⇓ n ok | μ ⊢ wte ⇓ n ok
  -- timeout
  ... | nothing | _ | _ | _ = nothing
  ... | just _ | nothing | _ | _ = nothing

  -- success
  ... | just² (clos μ' t) | just² v | just² (clos wtt wtμ') | just² px = (px ∷ wtμ') ⊢ wtt ⇓ n ok

  -- semantic error propagation
  ... | just nothing | _ | (just ()) | _
  ... | _ | just nothing | _ | (just ())

  -- semantic errors
  ... | just² (tclos _ _) | _ | just² () | _
  ... | just² unit | _ | just² () | _

  _⊢_⇓_ok {μ = E} μ (_[_] {f = f} wtf b) (suc n) with E ⊢ f ⇓ n | μ ⊢ wtf ⇓ n ok
  -- timeout
  ... | nothing | _ = nothing
  -- semantic errors
  ... | just nothing | (just ())
  ... | just² unit | just² ()
  ... | just² (clos x t) | just² ()
  -- success
  ... | just² (tclos μ' t) | just² (tclos tok μ'ok) =
    μ'ok ⊢ subst (λ Γ → Γ ⊢ _ ∶ _) (CtxLemmas.ctx/-wk-sub≡id _ b) (tok wt/ (sub b)) ⇓ n ok

  μ ⊢ var x ⇓ suc n ok with pointwise-maybe-lookup μ x
  μ ⊢ var x ⇓ suc n ok | _ , is-just , p rewrite is-just = just² p

module DelayMonad where

  open import Coinduction
  open import Category.Monad.Partiality
  open import Data.Maybe

  module _ where
    open Workaround

    _⊢lookup_ : Env → ℕ → Maybe Val
    [] ⊢lookup n = nothing
    (x ∷ μ) ⊢lookup zero = just x
    (x ∷ μ) ⊢lookup suc n = μ ⊢lookup n

    ret : ∀ {a} {A : Set a} → A → (Maybe A) ⊥P
    ret x = now (just x)

    -- substitution free semantics for SystemF
    _⊢_⇓P : ∀ (μ : Env) → Term → (Maybe Val) ⊥P
    μ ⊢ unit ⇓P = ret unit
    μ ⊢ ƛ t ⇓P = ret (clos μ t)
    μ ⊢ Λ t ⇓P = ret (tclos μ t )
    μ ⊢ f · e ⇓P = μ ⊢ f ⇓P >>= λ{
        (just (clos μ' t)) → μ ⊢ e ⇓P >>= (λ{
          (just v) → later (♯ ((v ∷ μ') ⊢ t ⇓P))
          ; nothing → now nothing
        }) ;
        _ → now nothing
      }
    μ ⊢ t [-] ⇓P = μ ⊢ t ⇓P >>= λ{
        (just (tclos μ' t')) →  later (♯ (μ' ⊢ t' ⇓P)) ;
        _ → now nothing
      }
    μ ⊢ var x ⇓P = now (μ ⊢lookup x)

    _⊢_⇓ : ∀ (μ : Env) → Term → (Maybe Val) ⊥
    μ ⊢ t ⇓ = ⟦ μ ⊢ t ⇓P ⟧P

{-}
  open import Category.Monad.Partiality.All
  open Alternative

  {-}
  module Compositional where
    private
      module Eq = Equality (_≡_)

    open import Level as Level
    open import Category.Monad
    open Eq hiding (_⇓)
    open RawMonad (monad {f = Level.zero})

    _·⇓_ : ∀ (f e : Val ⊥) → Val ⊥
    f ·⇓ e = f >>= λ{ (clos x t) → {!!} ; _ → now error }

    ·-comp : ∀ {μ f e} → (μ ⊢ f · e ⇓) ≅ ((μ ⊢ f ⇓) ·⇓ (μ ⊢ e ⇓))
    ·-comp = {!!}
  -}

  module Safety where

    _⊢_⇓okP : ∀ {n}{Γ : Ctx n}{μ : Env}{t a} → Γ ⊢ μ → Γ ⊢ t ∶ a → AllP (λ v → ⊢̬ v ∶ a) (μ ⊢ t ⇓)
    μ ⊢ unit ⇓okP = now unit
    μ ⊢ ƛ a t₁ ⇓okP = now (clos t₁ μ)
    μ ⊢ var x ⇓okP = now {!!}
    μ ⊢ f · e ⇓okP = {!μ ⊢ f ⇓okP!}
    μ ⊢ Λ t₁ ⇓okP = {!!}
    μ ⊢ t [ b ] ⇓okP = {!!}
-}


module Data.List.Instance where

open import Category.FAM
open import Data.List
open import Data.List.Properties
open import Function using (_$_)
open import Relation.Binary.PropositionalEquality hiding ([_])

instance
    ListFunctor : ∀ {ℓ} → Functor {ℓ} List
    ListFunctor = record
        { _<$>_ = map
        ; isFunctor = record
            { identity = map-id
            ; homo = λ f g a → map-compose a
            }
        }
    ListApplicative : ∀ {ℓ} → Applicative {ℓ} List
    ListApplicative {ℓ} = record
        { pure = [_]
        ; _⊛_ = λ fs xs → concat (map (flip map xs) fs)
        ; isApplicative = record
            { identity = λ xs → begin
                    map id xs ++ []
                ≡⟨ ++-identityʳ (map id xs) ⟩
                    map id xs
                ≡⟨ map-id xs ⟩
                    xs
                ∎
            ; compose = compose
            ; homo = λ _ _ → refl
            ; interchange = interchange
            }
        }
        where
            open ≡-Reasoning
            open import Function

            concat-∷ : {A : Set ℓ} (xs : List A) (xss : List (List A))
                → concat (xs ∷ xss) ≡ xs ++ concat xss
            concat-∷ []       xss = refl
            concat-∷ (x ∷ xs) xss = refl

            concat-++ : {A : Set ℓ} (xs ys : List (List A))
                → concat (xs ++ ys) ≡ concat xs ++ concat ys
            concat-++ []         ys = refl
            concat-++ (xs ∷ xss) ys = begin
                    concat ((xs ∷ xss) ++ ys)
                ≡⟨ refl ⟩
                    concat (xs ∷ xss ++ ys)
                ≡⟨ concat-∷ xs (xss ++ ys) ⟩
                    xs ++ concat (xss ++ ys)
                ≡⟨ cong (λ x → xs ++ x) (concat-++ xss ys) ⟩
                    xs ++ concat xss ++ concat ys
                ≡⟨ sym (++-assoc xs (concat xss) (concat ys)) ⟩
                    (xs ++ concat xss) ++ concat ys
                ≡⟨ cong (λ x → x ++ concat ys) (sym (concat-∷ xs xss)) ⟩
                    concat (xs ∷ xss) ++ concat ys
                ∎

            lemma : {A B C : Set ℓ} (f : B → C) (gs : List (A → B)) (xs : List A)
                → map (flip map xs) (flip map gs (_∘′_ f)) ≡ map (map f) (map (flip map xs) gs)
            lemma f []       xs       = refl
            lemma f (g ∷ gs) xs       =
                let shit = map (flip map xs) (map (_∘′_ f) gs) in
                begin
                    flip map xs (f ∘′ g) ∷ shit
                ≡⟨ refl ⟩
                    map (f ∘′ g) xs ∷ shit
                ≡⟨ cong (λ x → x ∷ shit) (map-compose xs) ⟩
                    map f (map g xs) ∷ shit
                ≡⟨ refl ⟩
                    map f (flip map xs g) ∷ shit
                ≡⟨ cong (λ x → map f (flip map xs g) ∷ x) (lemma f gs xs) ⟩
                    map f (flip map xs g) ∷ map (map f) (map (flip map xs) gs)
                ∎

            compose : {A B C : Set ℓ} (fs : List (B → C)) (gs : List (A → B)) (xs : List A)
                → concat (map (flip map xs) (concat (map (flip map gs) (map _∘′_ fs ++ []))))
                    ≡ concat (map (flip map (concat (map (flip map xs) gs))) fs)
            compose []       gs xs = refl
            compose (f ∷ fs) gs xs =
                begin
                    concat (map (flip map xs) (concat (flip map gs (_∘′_ f) ∷ map (flip map gs) (map _∘′_ fs ++ []))))
                ≡⟨ cong (λ x → concat (map (flip map xs) x)) (concat-∷ (flip map gs (_∘′_ f)) (map (flip map gs) (map _∘′_ fs ++ []))) ⟩
                    concat (map (flip map xs) (flip map gs (_∘′_ f) ++ concat (map (flip map gs) (map _∘′_ fs ++ []))))
                ≡⟨ cong concat (map-++-commute (flip map xs) (flip map gs (_∘′_ f)) (concat (map (flip map gs) (map _∘′_ fs ++ [])))) ⟩
                    concat (map (flip map xs) (flip map gs (_∘′_ f)) ++ map (flip map xs) (concat (map (flip map gs) (map _∘′_ fs ++ []))))
                ≡⟨ concat-++ (map (flip map xs) (flip map gs (_∘′_ f))) (map (flip map xs) (concat (map (flip map gs) (map _∘′_ fs ++ [])))) ⟩
                    concat (map (flip map xs) (flip map gs (_∘′_ f))) ++ concat (map (flip map xs) (concat (map (flip map gs) (map _∘′_ fs ++ []))))
                ≡⟨ cong (λ x → concat x ++ concat (map (flip map xs) (concat (map (flip map gs) (map _∘′_ fs ++ []))))) (lemma f gs xs) ⟩
                    concat (map (map f) (map (flip map xs) gs)) ++ concat (map (flip map xs) (concat (map (flip map gs) (map _∘′_ fs ++ []))))
                ≡⟨ cong (λ x → x ++ concat (map (flip map xs) (concat (map (flip map gs) (map _∘′_ fs ++ []))))) (concat-map ((map (flip map xs) gs)))⟩
                    map f (concat (map (flip map xs) gs)) ++ concat (map (flip map xs) (concat (map (flip map gs) (map _∘′_ fs ++ []))))
                ≡⟨ refl ⟩
                    flip map (concat (map (flip map xs) gs)) f ++ concat (map (flip map xs) (concat (map (flip map gs) (map _∘′_ fs ++ []))))
                ≡⟨ cong (λ x → flip map (concat (map (flip map xs) gs)) f ++ x) (compose fs gs xs) ⟩
                    flip map (concat (map (flip map xs) gs)) f ++ concat (map (flip map (concat (map (flip map xs) gs))) fs)
                ≡⟨ sym (concat-∷ (flip map (concat (map (flip map xs) gs)) f) (map (flip map (concat (map (flip map xs) gs))) fs)) ⟩
                    concat (flip map (concat (map (flip map xs) gs)) f ∷ map (flip map (concat (map (flip map xs) gs))) fs)
                ≡⟨ refl ⟩
                    concat (map (flip map (concat (map (flip map xs) gs))) (f ∷ fs))
                ∎

            interchange : {A B : Set ℓ} (fs : List (A → B)) (x : A)
                → concat (map (flip map [ x ]) fs) ≡ concat (map (flip map fs) [ (λ g → g x) ])
            interchange [] x       = refl
            interchange (f ∷ fs) x =
                begin
                    concat (flip map [ x ] f ∷ map (flip map [ x ]) fs)
                ≡⟨ refl ⟩
                    concat (map f [ x ] ∷ map (flip map [ x ]) fs)
                ≡⟨ concat-∷ (map f [ x ]) (map (flip map [ x ]) fs) ⟩
                    map f [ x ] ++ concat (map (flip map [ x ]) fs)
                ≡⟨ cong (λ w → map f [ x ] ++ w) (interchange fs x) ⟩
                    map f [ x ] ++ map (λ z → z x) fs ++ []
                ≡⟨ refl ⟩
                    concat (flip map (f ∷ fs) (λ g → g x) ∷ [])
                ∎


------------------------------------------------------------------------
-- An example: A non-terminating program that runs in bounded stack
-- space
------------------------------------------------------------------------

module Lambda.Interpreter.Stack-sizes.Example where

open import Equality.Propositional as E using (refl)
open import Prelude
open import Prelude.Size

open import Colist E.equality-with-J as C
open import Conat E.equality-with-J as Conat hiding (pred)
open import Function-universe E.equality-with-J hiding (id; _∘_)
open import Monad E.equality-with-J
open import Nat E.equality-with-J
open import Vec.Data E.equality-with-J

open import Delay-monad
open import Delay-monad.Bisimilarity as D using (later; force)

open import Upper-bounds

import Lambda.Delay-crash-trace as DCT
import Lambda.Interpreter
import Lambda.Interpreter.Stack-sizes

open DCT.Delay-crash-trace

-- This module uses a name type with a single inhabitant, allowing
-- (and requiring) the definition and use of one named definition.

open import Lambda.Syntax ⊤

open Closure Tm

-- A definition that calls itself repeatedly using a tail call.

def : ⊤ → Tm 1
def tt = call tt (con true)

-- The two interpreters are instantiated with this definition.

open Lambda.Interpreter def
module I = Lambda.Interpreter.Stack-sizes def

-- A top-level term to get things going.

go : Tm 0
go = call tt (con true)

-- The semantics of go is the non-terminating computation never.

go-loops : ∀ {i} → D.[ i ] ⟦ go ⟧ [] ∼ never
go-loops = later λ { .force → go-loops }

-- Colists used to analyse the stack space usage of go.

loop-sizes : ∀ {i} → Colist ℕ i
loop-sizes = 1 ∷′ 2 ∷ λ { .force → loop-sizes }

go-sizes : Colist ℕ ∞
go-sizes = 0 ∷′ 1 ∷′ loop-sizes

-- When go is interpreted (starting with an empty stack) the stack
-- sizes that are encountered match the sizes in go-sizes.

stack-sizes-go∼go-sizes : ∀ {i} → C.[ i ] I.stack-sizes go ∼ go-sizes
stack-sizes-go∼go-sizes =
  I.numbers (I.⟦ go ⟧ [] false) 0                                     C.∼⟨ ∷∼∷′ ⟩
  0 ∷′ I.numbers (I.[ id , pred ] lam (def tt) [] ∙ con true) 1       C.∼⟨ (refl ∷ λ { .force → ∷∼∷′ }) ⟩
  0 ∷′ 1 ∷′ I.numbers (I.⟦ def tt ⟧ ρ true >>= tell pred ∘ return) 1  C.∼⟨ (refl ∷ λ { .force → refl ∷ λ { .force → numbers-loop∼loop-sizes _ }}) ⟩
  0 ∷′ 1 ∷′ loop-sizes                                                C.∼⟨⟩
  go-sizes                                                            C.∎
  where
  ρ = con true ∷ []

  numbers-loop∼loop-sizes :
    ∀ {i} k → C.[ i ] I.numbers (I.⟦ def tt ⟧ ρ true >>= k) 1 ∼ loop-sizes
  numbers-loop∼loop-sizes k =
    I.numbers (I.⟦ def tt ⟧ ρ true >>= k) 1                                 C.∼⟨ ∷∼∷′ ⟩
    1 ∷′ I.numbers (I.[ pred , id ] lam (def tt) [] ∙ con true >>= k) 2     C.∼⟨ (refl ∷ λ { .force → ∷∼∷′ }) ⟩
    1 ∷′ 2 ∷′ I.numbers (I.⟦ def tt ⟧ ρ true >>= tell id ∘ return >>= k) 1  C.∼⟨ (refl ∷ λ { .force → refl ∷ λ { .force → I.numbers-cong (
                                                                                DCT.symmetric (DCT.associativity (I.⟦ def tt ⟧ ρ true) _ _)) }}) ⟩
    1 ∷′ 2 ∷′ I.numbers (I.⟦ def tt ⟧ ρ true >>= tell id ∘ k) 1             C.∼⟨ (refl ∷ λ { .force → refl ∷ λ { .force →
                                                                                numbers-loop∼loop-sizes _ }}) ⟩
    1 ∷′ 2 ∷′ loop-sizes                                                    C.∼⟨ (refl ∷ λ { .force → C.symmetric-∼ ∷∼∷′ }) ⟩
    loop-sizes                                                              C.∎

-- The least upper bound of go-sizes is 2.

lub-go-sizes-2 : LUB go-sizes ⌜ 2 ⌝
lub-go-sizes-2 =
  lub-∷ʳ zero (lub-∷ʳ 1≤2 lub-loop-sizes-2)
  where
  1≤2 = suc λ { .force → zero }

  2∷[] = λ { .force → 2 ∷′ [] }

  cycle-1-2∷[]∼loop-sizes :
    ∀ {i} → C.[ i ] cycle 1 2∷[] ∼ loop-sizes
  cycle-1-2∷[]∼loop-sizes =
    refl ∷ λ { .force → refl ∷ λ { .force → cycle-1-2∷[]∼loop-sizes }}

  lub-loop-sizes-2 : LUB loop-sizes ⌜ 2 ⌝
  lub-loop-sizes-2 =          $⟨ lub-∷ʳ 1≤2 (lub-∷ˡ zero lub-[]) ⟩
    LUB (1 ∷ 2∷[]) ⌜ 2 ⌝      ↝⟨ lub-cycle ⟩
    LUB (cycle 1 2∷[]) ⌜ 2 ⌝  ↝⟨ LUB-∼ cycle-1-2∷[]∼loop-sizes (Conat.reflexive-∼ _) ⟩□
    LUB loop-sizes ⌜ 2 ⌝      □

-- The maximum stack size encountered when running go (starting with
-- an empty stack) is 2.

go-bounded-stack : LUB (I.stack-sizes go) ⌜ 2 ⌝
go-bounded-stack =
  LUB-∼ (C.symmetric-∼ stack-sizes-go∼go-sizes)
        (Conat.reflexive-∼ _)
        lub-go-sizes-2


------------------------------------------------------------------------
-- Coherently constant functions
------------------------------------------------------------------------

{-# OPTIONS --erased-cubical --safe #-}

import Equality.Path as P

module Coherently-constant
  {e⁺} (eq : ∀ {a p} → P.Equality-with-paths a p e⁺) where

open P.Derived-definitions-and-properties eq

open import Prelude hiding (_+_)

import Bijection equality-with-J as B
open import Eilenberg-MacLane-space eq as K using (K[_]1; base; loop)
open import Embedding equality-with-J as Emb using (Embedding)
open import Equality.Decidable-UIP equality-with-J using (Constant)
open import Equality.Path.Isomorphisms eq
open import Equivalence equality-with-J as Eq using (_≃_)
open import Function-universe equality-with-J hiding (id; _∘_)
open import Group equality-with-J
open import Group.Cyclic eq as C using (ℤ/[1+_]ℤ; _≡_mod_)
open import H-level equality-with-J
open import H-level.Closure equality-with-J
open import H-level.Truncation.Propositional eq as T using (∥_∥; ∣_∣)
open import Injection equality-with-J using (Injective)
open import Integer equality-with-J
open import Pointed-type.Homotopy-group eq
open import Preimage equality-with-J using (_⁻¹_)
import Quotient eq as Q
open import Univalence-axiom equality-with-J

private
  variable
    a b     : Level
    A B C D : Type a
    f       : A → B
    p       : A

-- Coherently constant functions.
--
-- Shulman uses the term "conditionally constant" in "Not every weakly
-- constant function is conditionally constant"
-- (https://homotopytypetheory.org/2015/06/11/not-every-weakly-constant-function-is-conditionally-constant/).
-- I do not know who first came up with this definition.

Coherently-constant :
  {A : Type a} {B : Type b} → (A → B) → Type (a ⊔ b)
Coherently-constant {A = A} {B = B} f =
  ∃ λ (g : ∥ A ∥ → B) → f ≡ g ∘ ∣_∣

-- Every coherently constant function is weakly constant.
--
-- This result is mentioned by Shulman.

Coherently-constant→Constant :
  Coherently-constant f → Constant f
Coherently-constant→Constant {f = f} (g , eq) x y =
  f x      ≡⟨ cong (_$ x) eq ⟩
  g ∣ x ∣  ≡⟨ cong g (T.truncation-is-proposition _ _) ⟩
  g ∣ y ∣  ≡⟨ sym $ cong (_$ y) eq ⟩∎
  f y      ∎

-- Every weakly constant function with a stable domain is coherently
-- constant.
--
-- This result was proved by Kraus, Escardó, Coquand and Altenkirch in
-- "Notions of Anonymous Existence in Martin-Löf Type Theory".

Stable-domain→Constant→Coherently-constant :
  {f : A → B} →
  (∥ A ∥ → A) → Constant f → Coherently-constant f
Stable-domain→Constant→Coherently-constant {f = f} s c =
    f ∘ s
  , ⟨ext⟩ λ x →
      f x          ≡⟨ c _ _ ⟩∎
      f (s ∣ x ∣)  ∎

private

  -- Definitions used in the proof of ¬-Constant→Coherently-constant.

  module ¬-Constant→Coherently-constant
    (ℓ : Level) (univ : Univalence lzero)
    where

    -- CCC B is the statement that every constant function from a
    -- merely inhabited type in Type ℓ to B is coherently constant.

    CCC : Type ℓ → Type (lsuc ℓ)
    CCC B =
      (A : Type ℓ) → ∥ A ∥ →
      (f : A → B) → Constant f → Coherently-constant f

    Has-retraction : {A B : Type a} → (B → A) → Type a
    Has-retraction f = ∃ λ g → g ∘ f ≡ id

    -- IR A is the statement that every injective, (-1)-connected
    -- function from A to a type in Type ℓ has a retraction.

    IR : Type ℓ → Type (lsuc ℓ)
    IR A =
      (B : Type ℓ) (f : A → B) → (∀ x → ∥ f ⁻¹ x ∥) →
      Injective f → Has-retraction f

    -- CCC C implies IR C.

    CCC→IR : CCC C → IR C
    CCC→IR {C = C} ccc A f conn inj =
        (λ a → proj₁ (cc a) (conn a))
      , ⟨ext⟩ λ c →
          proj₁ (cc (f c)) (conn (f c))    ≡⟨ cong (proj₁ (cc (f c))) $ T.truncation-is-proposition _ _ ⟩
          proj₁ (cc (f c)) ∣ c , refl _ ∣  ≡⟨ sym $ cong (_$ c , refl _) $ proj₂ (cc (f c)) ⟩∎
          c                                ∎
      where
      cc : (a : A) → Coherently-constant {A = f ⁻¹ a} proj₁
      cc a = ccc (f ⁻¹ a) (conn a) proj₁ λ (c₁ , p₁) (c₂ , p₂) →
        inj (f c₁  ≡⟨ p₁ ⟩
             a     ≡⟨ sym p₂ ⟩∎
             f c₂  ∎)

    -- If there is an embedding from C to D, then CCC D implies CCC C.

    CCC→CCC : Embedding C D → CCC D → CCC C
    CCC→CCC emb ccc B ∥B∥ g c = proj₁ ∘ h , refl _
      where
      e = Embedding.to emb

      cc : Coherently-constant (e ∘ g)
      cc = ccc B ∥B∥ (e ∘ g) λ x y →
        e (g x)  ≡⟨ cong e (c x y) ⟩∎
        e (g y)  ∎

      h : (b : ∥ B ∥) → ∃ λ c → e c ≡ proj₁ cc b
      h = T.elim _ (λ _ → Emb.embedding→⁻¹-propositional
                            (Embedding.is-embedding emb) _) λ b →
        g b , cong (_$ b) (proj₂ cc)

    -- If CCC (A ≃ A) holds for every type A, then CCC (↑ ℓ K[ G ]1)
    -- holds for every abelian group G of type Group lzero.

    CCC-≃→CCC-K :
      ((B : Type ℓ) → CCC (B ≃ B)) →
      (G : Group lzero) → Abelian G → CCC (↑ ℓ K[ G ]1)
    CCC-≃→CCC-K ccc G abelian =
                                       $⟨ ccc (↑ ℓ K[ G ]1) ⟩
      CCC (↑ ℓ K[ G ]1 ≃ ↑ ℓ K[ G ]1)  ↝⟨ CCC→CCC emb ⟩□
      CCC (↑ ℓ K[ G ]1)                □
      where
      Aut[K[G]] = (K[ G ]1 ≃ K[ G ]1) , Eq.id

      Aut[K[G]]-groupoid : H-level 3 (K[ G ]1 ≃ K[ G ]1)
      Aut[K[G]]-groupoid = Eq.left-closure ext 2 K.is-groupoid

      Ω[Aut[K[G]]] =
        Fundamental-group′ Aut[K[G]] Aut[K[G]]-groupoid

      emb : Embedding (↑ ℓ K[ G ]1) (↑ ℓ K[ G ]1 ≃ ↑ ℓ K[ G ]1)
      emb =
        ↑ ℓ K[ G ]1                ↔⟨ B.↑↔ ⟩
        K[ G ]1                    ↔⟨ inverse $ K.cong-≃ $ K.Fundamental-group′[K1≃K1]≃ᴳ univ abelian ⟩
        K[ Ω[Aut[K[G]]] ]1         ↝⟨ proj₁ $ K.K[Fundamental-group′]1↣ᴮ univ Aut[K[G]]-groupoid ⟩
        K[ G ]1 ≃ K[ G ]1          ↔⟨ inverse $ Eq.≃-preserves-bijections ext B.↑↔ B.↑↔ ⟩□
        ↑ ℓ K[ G ]1 ≃ ↑ ℓ K[ G ]1  □

    -- The group of integers.

    module ℤG = Group ℤ-group

    -- The groups ℤ/2ℤ and ℤ/4ℤ.

    ℤ/2ℤ = ℤ/[1+ 1 ]ℤ
    ℤ/4ℤ = ℤ/[1+ 3 ]ℤ

    module ℤ/2ℤ where
      open Group ℤ/2ℤ public
        renaming (_∘_ to infixl 6 _+_; _⁻¹ to infix 8 -_)

    module ℤ/4ℤ where
      open Group ℤ/4ℤ public
        renaming (_∘_ to infixl 6 _+_; _⁻¹ to infix 8 -_)

    -- Multiplication by two, as a function from ℤ/2ℤ to ℤ/4ℤ.

    mul2 : ℤ/2ℤ.Carrier → ℤ/4ℤ.Carrier
    mul2 = Q.rec λ where
      .Q.[]ʳ i                                 → Q.[ i *+ 2 ]
      .Q.is-setʳ                               → Q./-is-set
      .Q.[]-respects-relationʳ {x = i} {y = j} →
        i ≡ j mod 2                  ↝⟨ C.*+-cong {j = j} {n = 2} 2 ⟩
        i *+ 2 ≡ j *+ 2 mod 4        ↝⟨ Q.[]-respects-relation ⟩□
        Q.[ i *+ 2 ] ≡ Q.[ j *+ 2 ]  □

    -- The function mul2, expressed as a group homomorphism.

    mul2ʰ : ℤ/2ℤ →ᴳ ℤ/4ℤ
    mul2ʰ = λ where
      .related     → mul2
      .homomorphic → Q.elim-prop λ where
        .Q.is-propositionʳ _ → Π-closure ext 1 λ _ →
                               Group.Carrier-is-set ℤ/[1+ 3 ]ℤ
        .Q.[]ʳ i → Q.elim-prop λ where
          .Q.is-propositionʳ _ → Group.Carrier-is-set ℤ/[1+ 3 ]ℤ
          .Q.[]ʳ j → cong Q.[_]
            ((i + j) *+ 2     ≡⟨ *+-distrib-+ {i = i} 2 ⟩∎
             i *+ 2 + j *+ 2  ∎)

    -- Integer division by 2, as a function from ℤ/4ℤ to ℤ/2ℤ.

    div2 : ℤ/4ℤ.Carrier → ℤ/2ℤ.Carrier
    div2 = Q.rec λ where
      .Q.[]ʳ i                                 → Q.[ ⌊ i /2⌋ ]
      .Q.is-setʳ                               → Q./-is-set
      .Q.[]-respects-relationʳ {x = i} {y = j} →
        i ≡ j mod 4                    ↝⟨ C.⌊/2⌋-cong j 2 ⟩
        ⌊ i /2⌋ ≡ ⌊ j /2⌋ mod 2        ↝⟨ Q.[]-respects-relation ⟩□
        Q.[ ⌊ i /2⌋ ] ≡ Q.[ ⌊ j /2⌋ ]  □

    -- Some lemmas relating mul2 and div2.

    mul2-div2-lemma₁ :
      ∀ i j → div2 (j ℤ/4ℤ.+ ℤ/4ℤ.- mul2 i) ≡ div2 j ℤ/2ℤ.+ ℤ/2ℤ.- i
    mul2-div2-lemma₁ = Q.elim-prop λ where
      .Q.is-propositionʳ _ →
        Π-closure ext 1 λ _ →
        Q./-is-set
      .Q.[]ʳ i → Q.elim-prop λ where
        .Q.is-propositionʳ _ → Q./-is-set
        .Q.[]ʳ j             → cong Q.[_]
          (⌊ j - i *+ 2 /2⌋    ≡⟨ cong (⌊_/2⌋ ∘ _+_ j) $ ℤG.^+⁻¹ {p = i} 2 ⟩
           ⌊ j + - i *+ 2 /2⌋  ≡⟨ ⌊+*+2/2⌋≡ j ⟩∎
           ⌊ j /2⌋ + - i       ∎)

    mul2-div2-lemma₂ :
      ∀ i j → ℤ/2ℤ.- i ℤ/2ℤ.+ div2 (mul2 i ℤ/4ℤ.+ j) ≡ div2 j
    mul2-div2-lemma₂ = Q.elim-prop λ where
      .Q.is-propositionʳ _ →
        Π-closure ext 1 λ _ →
        Q./-is-set
      .Q.[]ʳ i → Q.elim-prop λ where
        .Q.is-propositionʳ _ → Q./-is-set
        .Q.[]ʳ j             → cong Q.[_]
          (- i + ⌊ i *+ 2 + j /2⌋  ≡⟨ cong (_+_ (- i) ∘ ⌊_/2⌋) $ +-comm (i *+ 2) ⟩
           - i + ⌊ j + i *+ 2 /2⌋  ≡⟨ cong (_+_ (- i)) $ ⌊+*+2/2⌋≡ j ⟩
           - i + (⌊ j /2⌋ + i)     ≡⟨ cong (_+_ (- i)) $ +-comm ⌊ j /2⌋ ⟩
           - i + (i + ⌊ j /2⌋)     ≡⟨ +-assoc (- i) ⟩
           - i + i + ⌊ j /2⌋       ≡⟨ cong (_+ ⌊ j /2⌋) $ +-left-inverse i ⟩
           + 0 + ⌊ j /2⌋           ≡⟨ +-left-identity ⟩∎
           ⌊ j /2⌋                 ∎)

    -- The type K[ ℤ/4ℤ ]1 is (-1)-connected.

    K[ℤ/4ℤ]-connected : (x : K[ ℤ/4ℤ ]1) → ∥ K.map mul2ʰ ⁻¹ x ∥
    K[ℤ/4ℤ]-connected = K.elim-set λ where
      .K.baseʳ     → ∣ base , refl _ ∣
      .K.loopʳ _   → T.truncation-is-proposition _ _
      .K.is-setʳ _ → mono₁ 1 T.truncation-is-proposition

    -- Two equivalences.

    Ω[K[ℤ/4ℤ]]≃ℤ/4ℤ : _≡_ {A = K[ ℤ/4ℤ ]1} base base ≃ ℤ/4ℤ.Carrier
    Ω[K[ℤ/4ℤ]]≃ℤ/4ℤ =
      K.Fundamental-group′[K1]≃ᴳ univ K.is-groupoid .related

    Ω[K[ℤ/2ℤ]]≃ℤ/2ℤ : _≡_ {A = K[ ℤ/2ℤ ]1} base base ≃ ℤ/2ℤ.Carrier
    Ω[K[ℤ/2ℤ]]≃ℤ/2ℤ =
      K.Fundamental-group′[K1]≃ᴳ univ K.is-groupoid .related

    -- The function K.map mul2ʰ is injective.

    map-mul2ʰ-injective : Injective (K.map mul2ʰ)
    map-mul2ʰ-injective {x = x} {y = y} = K.elim-set e x y
      where
      lemma = K.elim-set λ where
        .K.is-setʳ _ →
          Π-closure ext 2 λ _ →
          K.is-groupoid
        .K.baseʳ →
          base ≡ base   ↔⟨ Ω[K[ℤ/4ℤ]]≃ℤ/4ℤ ⟩
          ℤ/4ℤ.Carrier  ↝⟨ div2 ⟩
          ℤ/2ℤ.Carrier  ↔⟨ inverse Ω[K[ℤ/2ℤ]]≃ℤ/2ℤ ⟩□
          base ≡ base   □
        .K.loopʳ i → ⟨ext⟩ λ eq →
          let j = _≃_.to Ω[K[ℤ/4ℤ]]≃ℤ/4ℤ eq in

          subst (λ y → base ≡ K.map mul2ʰ y → base ≡ y)
            (loop i) (loop ∘ div2 ∘ _≃_.to Ω[K[ℤ/4ℤ]]≃ℤ/4ℤ) eq        ≡⟨ subst-→ ⟩

          subst (base ≡_) (loop i)
            (loop $ div2 $ _≃_.to Ω[K[ℤ/4ℤ]]≃ℤ/4ℤ $
             subst ((base ≡_) ∘ K.map mul2ʰ) (sym (loop i)) eq)       ≡⟨ trans (sym trans-subst) $
                                                                         cong (flip trans _) $
                                                                         cong (loop ∘ div2 ∘ _≃_.to Ω[K[ℤ/4ℤ]]≃ℤ/4ℤ) $
                                                                         trans (subst-∘ _ _ _) $
                                                                         trans (sym trans-subst) $
                                                                         cong (trans _) $
                                                                         trans (cong-sym _ _) $
                                                                         cong sym $ K.rec-loop ⟩
          trans
            (loop $ div2 $ _≃_.to Ω[K[ℤ/4ℤ]]≃ℤ/4ℤ $
             trans eq (sym (loop (mul2 i))))
            (loop i)                                                  ≡⟨ cong (flip trans _) $ cong (loop ∘ div2) $
                                                                         K.Fundamental-group′[K1]≃ᴳ univ K.is-groupoid .homomorphic
                                                                           eq (sym (loop (mul2 i))) ⟩
          trans
            (loop $ div2 $
             j ℤ/4ℤ.+ _≃_.to Ω[K[ℤ/4ℤ]]≃ℤ/4ℤ (sym (loop (mul2 i))))
            (loop i)                                                  ≡⟨ cong (flip trans _) $ cong (loop ∘ div2 ∘ (j ℤ/4ℤ.+_)) $
                                                                         →ᴳ-⁻¹ (K.Fundamental-group′[K1]≃ᴳ univ K.is-groupoid) _ ⟩
          trans
            (loop $ div2 $
             j ℤ/4ℤ.+ ℤ/4ℤ.- _≃_.to Ω[K[ℤ/4ℤ]]≃ℤ/4ℤ (loop (mul2 i)))
            (loop i)                                                  ≡⟨ cong (flip trans _ ∘ loop ∘ div2 ∘ (j ℤ/4ℤ.+_) ∘ ℤ/4ℤ.-_) $
                                                                         _≃_.right-inverse-of Ω[K[ℤ/4ℤ]]≃ℤ/4ℤ _ ⟩

          trans (loop (div2 (j ℤ/4ℤ.+ ℤ/4ℤ.- mul2 i))) (loop i)       ≡⟨ cong (flip trans _) $ cong loop $ mul2-div2-lemma₁ i j ⟩

          trans (loop (div2 j ℤ/2ℤ.+ ℤ/2ℤ.- i)) (loop i)              ≡⟨ cong (flip trans _) $
                                                                         ≃ᴳ-sym {G₂ = ℤ/2ℤ} (K.Fundamental-group′[K1]≃ᴳ univ K.is-groupoid)
                                                                           .homomorphic _ _ ⟩

          trans (trans (loop (div2 j)) (loop (ℤ/2ℤ.- i))) (loop i)    ≡⟨ cong (flip trans _) $ cong (trans _) $
                                                                         →ᴳ-⁻¹ (≃ᴳ-sym $ K.Fundamental-group′[K1]≃ᴳ univ K.is-groupoid) _ ⟩

          trans (trans (loop (div2 j)) (sym (loop i))) (loop i)       ≡⟨ trans (trans-assoc _ _ _) $
                                                                         trans (cong (trans _) $ trans-symˡ _) $
                                                                         trans-reflʳ _ ⟩∎
          loop (div2 j)                                               ∎

      e = λ where
        .K.is-setʳ _ →
          Π-closure ext 2 λ _ →
          Π-closure ext 2 λ _ →
          K.is-groupoid
        .K.baseʳ   → lemma
        .K.loopʳ i → ⟨ext⟩ $ K.elim-prop λ where
          .K.is-propositionʳ _ → Π-closure ext 2 λ _ →
                                 K.is-groupoid
          .K.baseʳ             → ⟨ext⟩ λ eq →
            let j = _≃_.to Ω[K[ℤ/4ℤ]]≃ℤ/4ℤ eq in

            subst (λ x → ∀ y → K.map mul2ʰ x ≡ K.map mul2ʰ y → x ≡ y)
              (loop i) lemma base eq                                   ≡⟨ trans (cong (_$ eq) $ sym $
                                                                                push-subst-application _ _)
                                                                          subst-→ ⟩
            subst (_≡ base) (loop i)
              (lemma base $
               subst (λ x → K.map mul2ʰ x ≡ K.map mul2ʰ base)
                 (sym (loop i)) eq)                                    ≡⟨ trans subst-trans-sym $
                                                                          cong (trans _) $ cong (lemma base) $
                                                                          trans (subst-∘ _ _ _) $
                                                                          subst-trans-sym ⟩
            trans (sym $ loop i)
              (lemma base $
               trans (sym (cong (K.map mul2ʰ) (sym (loop i)))) eq)     ≡⟨ cong (trans _) $ cong (lemma base) $ cong (flip trans _) $
                                                                          trans (sym $ cong-sym _ _) $
                                                                          cong (cong _) $ sym-sym _ ⟩
            trans (sym $ loop i)
              (lemma base (trans (cong (K.map mul2ʰ) (loop i)) eq))    ≡⟨ cong (trans _) $ cong (lemma base) $ cong (flip trans _)
                                                                          K.rec-loop ⟩
            trans (sym $ loop i)
              (lemma base (trans (loop (mul2 i)) eq))                  ≡⟨⟩

            trans (sym $ loop i)
              (loop $ div2 $ _≃_.to Ω[K[ℤ/4ℤ]]≃ℤ/4ℤ $
               trans (loop (mul2 i)) eq)                               ≡⟨ cong₂ (λ p q → trans p (loop (div2 q)))
                                                                            (sym $
                                                                             →ᴳ-⁻¹ (≃ᴳ-sym $ K.Fundamental-group′[K1]≃ᴳ univ K.is-groupoid) _)
                                                                            (K.Fundamental-group′[K1]≃ᴳ univ K.is-groupoid .homomorphic
                                                                               (loop (mul2 i)) eq) ⟩
            trans (loop (ℤ/2ℤ.- i))
              (loop $ div2 $
               _≃_.to Ω[K[ℤ/4ℤ]]≃ℤ/4ℤ (loop (mul2 i)) ℤ/4ℤ.+ j)        ≡⟨ cong (trans (loop (ℤ/2ℤ.- i)) ∘ loop ∘ div2 ∘ (ℤ/4ℤ._+ j)) $
                                                                          _≃_.right-inverse-of Ω[K[ℤ/4ℤ]]≃ℤ/4ℤ _ ⟩

            trans (loop (ℤ/2ℤ.- i)) (loop (div2 (mul2 i ℤ/4ℤ.+ j)))    ≡⟨ sym $
                                                                          ≃ᴳ-sym (K.Fundamental-group′[K1]≃ᴳ univ K.is-groupoid)
                                                                            .homomorphic _ _ ⟩

            loop (ℤ/2ℤ.- i ℤ/2ℤ.+ div2 (mul2 i ℤ/4ℤ.+ j))              ≡⟨ cong loop $ mul2-div2-lemma₂ i j ⟩

            loop (div2 j)                                              ≡⟨⟩

            lemma base eq                                              ∎

    -- It is not the case that IR holds for ↑ ℓ K[ ℤ/2ℤ ]1.

    ¬IR : ¬ IR (↑ ℓ K[ ℤ/2ℤ ]1)
    ¬IR ir = contradiction
      where

      -- The function K.map mul2ʰ has a retraction.

      map-mul2ʰ-has-retraction : Has-retraction (K.map mul2ʰ)
      map-mul2ʰ-has-retraction =
        let r , is-r = ir (↑ ℓ K[ ℤ/4ℤ ]1) mul2′ conn inj in
          lower ∘ r ∘ lift
        , (⟨ext⟩ λ x →
           lower (r (lift (K.map mul2ʰ x)))  ≡⟨ cong lower $ cong (_$ lift x) is-r ⟩∎
           x                                 ∎)
        where
        mul2′ : ↑ ℓ K[ ℤ/2ℤ ]1 → ↑ ℓ K[ ℤ/4ℤ ]1
        mul2′ = lift ∘ K.map mul2ʰ ∘ lower

        conn : (x : ↑ ℓ K[ ℤ/4ℤ ]1) → ∥ mul2′ ⁻¹ x ∥
        conn =
          T.∥∥-map (Σ-map lift (cong lift)) ∘
          K[ℤ/4ℤ]-connected ∘ lower

        inj : Injective mul2′
        inj = cong lift ∘ map-mul2ʰ-injective ∘ cong lower

      -- The retraction, and the proof showing that it is a
      -- retraction.

      r₁ : K[ ℤ/4ℤ ]1 → K[ ℤ/2ℤ ]1
      r₁ = proj₁ map-mul2ʰ-has-retraction

      r₁-retraction : r₁ ∘ K.map mul2ʰ ≡ id
      r₁-retraction = proj₂ map-mul2ʰ-has-retraction

      -- A lemma related to r₁.

      r₁-lemma :
        trans (sym $ cong (_$ base) r₁-retraction)
          (trans (cong r₁ (cong (K.map mul2ʰ) p))
             (cong (_$ base) r₁-retraction)) ≡
        p
      r₁-lemma {p = p} =
        trans (sym $ cong (_$ base) r₁-retraction)
          (trans (cong r₁ (cong (K.map mul2ʰ) p))
             (cong (_$ base) r₁-retraction))        ≡⟨ cong (trans _) $ cong (flip trans _) $
                                                       cong-∘ _ _ _ ⟩
        trans (sym $ cong (_$ base) r₁-retraction)
          (trans (cong (r₁ ∘ K.map mul2ʰ) p)
             (cong (_$ base) r₁-retraction))        ≡⟨ cong (trans _) $
                                                       naturality (λ x → cong (_$ x) r₁-retraction) ⟩
        trans (sym $ cong (_$ base) r₁-retraction)
          (trans (cong (_$ base) r₁-retraction)
             (cong id p))                           ≡⟨ trans-sym-[trans] _ _ ⟩

        cong id p                                   ≡⟨ sym $ cong-id _ ⟩∎

        p                                           ∎

      -- A variant of r₁ that is definitionally equal to base for
      -- base.

      r₂ : K[ ℤ/4ℤ ]1 → K[ ℤ/2ℤ ]1
      r₂ = K.rec λ where
        .K.baseʳ → base

        .K.loopʳ i →
          base     ≡⟨ sym $ cong (_$ base) r₁-retraction ⟩
          r₁ base  ≡⟨ cong r₁ (loop i) ⟩
          r₁ base  ≡⟨ cong (_$ base) r₁-retraction ⟩∎
          base     ∎

        .K.loop-idʳ →
          trans (sym $ cong (_$ base) r₁-retraction)
            (trans (cong r₁ (loop ℤ/4ℤ.id))
               (cong (_$ base) r₁-retraction))                    ≡⟨ cong (trans _) $ cong (flip trans _) $ cong (cong r₁) $ sym
                                                                     K.rec-loop ⟩
          trans (sym $ cong (_$ base) r₁-retraction)
            (trans (cong r₁ (cong (K.map mul2ʰ) (loop ℤ/2ℤ.id)))
               (cong (_$ base) r₁-retraction))                    ≡⟨ r₁-lemma ⟩

          loop ℤ/2ℤ.id                                            ≡⟨ K.loop-id ⟩∎

          refl _                                                  ∎

        .K.loop-∘ʳ {x = x} {y = y} →
          trans (sym $ cong (_$ base) r₁-retraction)
            (trans (cong r₁ (loop (x ℤ/4ℤ.+ y)))
               (cong (_$ base) r₁-retraction))           ≡⟨ cong (trans _) $ cong (flip trans _) $ cong (cong r₁) $
                                                            K.loop-∘ ⟩
          trans (sym $ cong (_$ base) r₁-retraction)
            (trans (cong r₁ (trans (loop x) (loop y)))
               (cong (_$ base) r₁-retraction))           ≡⟨ trans (cong (trans _) $
                                                                   trans (cong (flip trans _) $
                                                                          cong-trans _ _ _) $
                                                                   trans-assoc _ _ _) $
                                                            sym $ trans-assoc _ _ _ ⟩
          trans
            (trans (sym $ cong (_$ base) r₁-retraction)
               (cong r₁ (loop x)))
            (trans (cong r₁ (loop y))
               (cong (_$ base) r₁-retraction))           ≡⟨ trans (cong (trans _) $ sym $
                                                                   trans--[trans-sym] _ _) $
                                                            trans (sym $ trans-assoc _ _ _) $
                                                            cong (flip trans _) $
                                                            trans-assoc _ _ _ ⟩∎
          trans
            (trans (sym $ cong (_$ base) r₁-retraction)
               (trans (cong r₁ (loop x))
                  (cong (_$ base) r₁-retraction)))
            (trans (sym $ cong (_$ base) r₁-retraction)
               (trans (cong r₁ (loop y))
                  (cong (_$ base) r₁-retraction)))       ∎

        .K.is-groupoidʳ → K.is-groupoid

      -- The functions r₁ and r₂ are pointwise equal.

      r₁≡r₂ : ∀ x → r₁ x ≡ r₂ x
      r₁≡r₂ = K.elim-set λ where
        .K.is-setʳ _ → K.is-groupoid
        .K.baseʳ     →
          r₁ base  ≡⟨ cong (_$ base) r₁-retraction ⟩∎
          r₂ base  ∎
        .K.loopʳ i →
          subst (λ x → r₁ x ≡ r₂ x) (loop i)
            (cong (_$ base) r₁-retraction)                  ≡⟨ subst-in-terms-of-trans-and-cong ⟩

          trans (sym (cong r₁ (loop i)))
            (trans (cong (_$ base) r₁-retraction)
               (cong r₂ (loop i)))                          ≡⟨ cong (trans _) $ cong (trans _)
                                                               K.rec-loop ⟩
          trans (sym (cong r₁ (loop i)))
            (trans (cong (_$ base) r₁-retraction)
               (trans (sym $ cong (_$ base) r₁-retraction)
                  (trans (cong r₁ (loop i))
                     (cong (_$ base) r₁-retraction))))      ≡⟨ cong (trans _) $
                                                               trans--[trans-sym] _ _ ⟩
          trans (sym (cong r₁ (loop i)))
            (trans (cong r₁ (loop i))
               (cong (_$ base) r₁-retraction))              ≡⟨ trans-sym-[trans] _ _ ⟩∎

          cong (_$ base) r₁-retraction                      ∎

      -- Thus r₂ is also a retraction of K.map mul2ʰ.

      r₂-retraction : r₂ ∘ K.map mul2ʰ ≡ id
      r₂-retraction =
        r₂ ∘ K.map mul2ʰ  ≡⟨ cong (_∘ K.map mul2ʰ) $ sym $ ⟨ext⟩ r₁≡r₂ ⟩
        r₁ ∘ K.map mul2ʰ  ≡⟨ r₁-retraction ⟩∎
        id                ∎

      -- A group homomorphism from ℤ/4ℤ to ℤ/2ℤ.

      r₃ : ℤ/4ℤ →ᴳ ℤ/2ℤ
      r₃ .related =
        ℤ/4ℤ.Carrier  ↔⟨ inverse Ω[K[ℤ/4ℤ]]≃ℤ/4ℤ ⟩
        base ≡ base   ↝⟨ cong r₂ ⟩
        base ≡ base   ↔⟨ Ω[K[ℤ/2ℤ]]≃ℤ/2ℤ ⟩□
        ℤ/2ℤ.Carrier  □
      r₃ .homomorphic i j =
        _≃_.to Ω[K[ℤ/2ℤ]]≃ℤ/2ℤ (cong r₂ (loop (i ℤ/4ℤ.+ j)))        ≡⟨ cong (_≃_.to Ω[K[ℤ/2ℤ]]≃ℤ/2ℤ ∘ cong r₂) K.loop-∘ ⟩

        _≃_.to Ω[K[ℤ/2ℤ]]≃ℤ/2ℤ (cong r₂ (trans (loop i) (loop j)))  ≡⟨ cong (_≃_.to Ω[K[ℤ/2ℤ]]≃ℤ/2ℤ) $ cong-trans _ _ _ ⟩

        _≃_.to Ω[K[ℤ/2ℤ]]≃ℤ/2ℤ
          (trans (cong r₂ (loop i)) (cong r₂ (loop j)))             ≡⟨ K.Fundamental-group′[K1]≃ᴳ univ K.is-groupoid
                                                                         .homomorphic _ _ ⟩∎
        _≃_.to Ω[K[ℤ/2ℤ]]≃ℤ/2ℤ (cong r₂ (loop i)) ℤ/2ℤ.+
        _≃_.to Ω[K[ℤ/2ℤ]]≃ℤ/2ℤ (cong r₂ (loop j))                   ∎

      -- The homomorphism r₃ is a retraction of mul2.

      r₃-retraction : ∀ i → Homomorphic.to r₃ (mul2 i) ≡ i
      r₃-retraction i =
        _≃_.to Ω[K[ℤ/2ℤ]]≃ℤ/2ℤ (cong r₂ (loop (mul2 i)))  ≡⟨ cong (_≃_.to Ω[K[ℤ/2ℤ]]≃ℤ/2ℤ) lemma ⟩
        _≃_.to Ω[K[ℤ/2ℤ]]≃ℤ/2ℤ (loop i)                   ≡⟨ _≃_.right-inverse-of Ω[K[ℤ/2ℤ]]≃ℤ/2ℤ _ ⟩∎
        i                                                 ∎
        where
        lemma =
          cong r₂ (loop (mul2 i))                           ≡⟨ K.rec-loop ⟩

          trans (sym $ cong (_$ base) r₁-retraction)
            (trans (cong r₁ (loop (mul2 i)))
               (cong (_$ base) r₁-retraction))              ≡⟨ cong (trans _) $ cong (flip trans _) $ cong (cong r₁) $ sym
                                                               K.rec-loop ⟩
          trans (sym $ cong (_$ base) r₁-retraction)
            (trans (cong r₁ (cong (K.map mul2ʰ) (loop i)))
               (cong (_$ base) r₁-retraction))              ≡⟨ r₁-lemma ⟩∎

          loop i                                            ∎

      -- 0 and 1 are equal when viewed as elements of ℤ/2ℤ.

      0≡1 : _≡_ {A = ℤ/2ℤ.Carrier} Q.[ + 0 ] Q.[ + 1 ]
      0≡1 =
        Q.[ + 0 ]                           ≡⟨ sym $ C.ℤ/2ℤ-+≡0 (Homomorphic.to r₃ Q.[ + 1 ]) ⟩

        Homomorphic.to r₃ Q.[ + 1 ] ℤ/2ℤ.+
        Homomorphic.to r₃ Q.[ + 1 ]         ≡⟨ sym $ r₃ .homomorphic Q.[ + 1 ] Q.[ + 1 ] ⟩

        Homomorphic.to r₃ Q.[ + 2 ]         ≡⟨⟩

        Homomorphic.to r₃ (mul2 Q.[ + 1 ])  ≡⟨ r₃-retraction Q.[ + 1 ] ⟩∎

        Q.[ + 1 ]                           ∎

      -- However, this is contradictory.

      contradiction : ⊥
      contradiction = C.ℤ/ℤ-0≢1 0 0≡1

-- It is not the case that, for every type A : Type a and merely
-- inhabited type B : Type a, every weakly constant function from B to
-- A ≃ A is coherently constant (assuming univalence).
--
-- This result is due to Sattler (personal communication), building on
-- work by Shulman (see "Not every weakly constant function is
-- conditionally constant").

¬-Constant→Coherently-constant :
  Univalence lzero →
  ¬ ((A B : Type a) → ∥ A ∥ →
     (f : A → B ≃ B) → Constant f → Coherently-constant f)
¬-Constant→Coherently-constant {a = a} univ =
  ((A B : Type a) → ∥ A ∥ →
   (f : A → B ≃ B) → Constant f → Coherently-constant f)  ↝⟨ flip ⟩

  ((B : Type a) → CCC (B ≃ B))                            ↝⟨ CCC-≃→CCC-K ⟩

  ((G : Group lzero) → Abelian G → CCC (↑ a K[ G ]1))     ↝⟨ (λ hyp G abelian → CCC→IR (hyp G abelian)) ⟩

  ((G : Group lzero) → Abelian G → IR (↑ a K[ G ]1))      ↝⟨ (λ hyp → hyp ℤ/2ℤ C.ℤ/ℤ-abelian) ⟩

  IR (↑ a K[ ℤ/2ℤ ]1)                                     ↝⟨ ¬IR ⟩□

  ⊥                                                       □
  where
  open ¬-Constant→Coherently-constant a univ


data Nat : Set where
  nohana : Nat
  kibou  : Nat -> Nat

one = kibou nohana
two = kibou one


module ModusPonens where

modusPonens : ∀ {P Q : Set} → (P → Q) → P → Q
modusPonens x = x


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

open import HoTT
open import cw.CW

module cw.examples.Empty where

cw-empty-skel : Skeleton {lzero} 0
cw-empty-skel = Empty , Empty-is-set
CWEmpty = ⟦ cw-empty-skel ⟧

CWEmpty-equiv-Empty : CWEmpty ≃ Empty
CWEmpty-equiv-Empty = ide _