------------------------------------------------------------------------
-- The Agda standard library
--
-- Basic properties of ℕᵇ
------------------------------------------------------------------------

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

module Data.Nat.Binary.Properties where

open import Algebra.Bundles
open import Algebra.Morphism.Structures
import Algebra.Morphism.MonoidMonomorphism as MonoidMonomorphism
open import Algebra.Consequences.Propositional
open import Data.Nat.Binary.Base
open import Data.Nat as ℕ using (ℕ; z≤n; s≤s)
import Data.Nat.Properties as ℕₚ
open import Data.Nat.Solver
open import Data.Product using (_,_; proj₁; proj₂; ∃)
open import Data.Sum.Base using (_⊎_; inj₁; inj₂)
open import Function using (_∘_; _$_; id)
open import Function.Definitions using (Injective)
open import Function.Definitions.Core2 using (Surjective)
open import Level using (0ℓ)
open import Relation.Binary
open import Relation.Binary.Consequences
open import Relation.Binary.Morphism
import Relation.Binary.Morphism.OrderMonomorphism as OrderMonomorphism
open import Relation.Binary.PropositionalEquality
import Relation.Binary.Reasoning.Base.Triple as InequalityReasoning
open import Relation.Nullary using (¬_; yes; no)
import Relation.Nullary.Decidable as Dec
open import Relation.Nullary.Negation using (contradiction)

open import Algebra.Definitions {A = ℕᵇ} _≡_
open import Algebra.Structures {A = ℕᵇ} _≡_
import Algebra.Properties.CommutativeSemigroup ℕₚ.+-commutativeSemigroup
  as ℕ-+-semigroupProperties
import Relation.Binary.Construct.StrictToNonStrict _≡_ _<_
  as StrictToNonStrict
open +-*-Solver

------------------------------------------------------------------------
-- Properties of _≡_
------------------------------------------------------------------------

2[1+x]≢0 : ∀ {x} → 2[1+ x ] ≢ 0ᵇ
2[1+x]≢0 ()

1+[2x]≢0 : ∀ {x} → 1+[2 x ] ≢ 0ᵇ
1+[2x]≢0 ()

2[1+_]-injective : Injective _≡_ _≡_ 2[1+_]
2[1+_]-injective refl = refl

1+[2_]-injective : Injective _≡_ _≡_ 1+[2_]
1+[2_]-injective refl = refl

_≟_ : Decidable {A = ℕᵇ} _≡_
zero     ≟ zero     =  yes refl
zero     ≟ 2[1+ _ ] =  no λ()
zero     ≟ 1+[2 _ ] =  no λ()
2[1+ _ ] ≟ zero     =  no λ()
2[1+ x ] ≟ 2[1+ y ] =  Dec.map′ (cong 2[1+_]) 2[1+_]-injective (x ≟ y)
2[1+ _ ] ≟ 1+[2 _ ] =  no λ()
1+[2 _ ] ≟ zero     =  no λ()
1+[2 _ ] ≟ 2[1+ _ ] =  no λ()
1+[2 x ] ≟ 1+[2 y ] =  Dec.map′ (cong 1+[2_]) 1+[2_]-injective (x ≟ y)

≡-isDecEquivalence : IsDecEquivalence {A = ℕᵇ} _≡_
≡-isDecEquivalence = isDecEquivalence _≟_

≡-setoid : Setoid 0ℓ 0ℓ
≡-setoid = setoid ℕᵇ

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

------------------------------------------------------------------------
-- Properties of toℕ & fromℕ
------------------------------------------------------------------------

toℕ-double : ∀ x → toℕ (double x) ≡ 2 ℕ.* (toℕ x)
toℕ-double zero     =  refl
toℕ-double 1+[2 x ] =  cong ((2 ℕ.*_) ∘ ℕ.suc) (toℕ-double x)
toℕ-double 2[1+ x ] =  cong (2 ℕ.*_) (sym (ℕₚ.*-distribˡ-+ 2 1 (toℕ x)))

toℕ-suc : ∀ x → toℕ (suc x) ≡ ℕ.suc (toℕ x)
toℕ-suc zero     =  refl
toℕ-suc 2[1+ x ] =  cong (ℕ.suc ∘ (2 ℕ.*_)) (toℕ-suc x)
toℕ-suc 1+[2 x ] =  ℕₚ.*-distribˡ-+ 2 1 (toℕ x)

toℕ-pred : ∀ x → toℕ (pred x) ≡ ℕ.pred (toℕ x)
toℕ-pred zero     =  refl
toℕ-pred 2[1+ x ] =  cong ℕ.pred $ sym $ ℕₚ.*-distribˡ-+ 2 1 (toℕ x)
toℕ-pred 1+[2 x ] =  toℕ-double x

toℕ-fromℕ : toℕ ∘ fromℕ ≗ id
toℕ-fromℕ 0         = refl
toℕ-fromℕ (ℕ.suc n) = begin
  toℕ (fromℕ (ℕ.suc n))   ≡⟨⟩
  toℕ (suc (fromℕ n))     ≡⟨ toℕ-suc (fromℕ n) ⟩
  ℕ.suc (toℕ (fromℕ n))   ≡⟨ cong ℕ.suc (toℕ-fromℕ n) ⟩
  ℕ.suc n                 ∎
  where open ≡-Reasoning

toℕ-injective : Injective _≡_ _≡_ toℕ
toℕ-injective {zero}     {zero}     _               =  refl
toℕ-injective {2[1+ x ]} {2[1+ y ]} 2[1+xN]≡2[1+yN] =  cong 2[1+_] x≡y
  where
  1+xN≡1+yN = ℕₚ.*-cancelˡ-≡ {ℕ.suc _} {ℕ.suc _} 1 2[1+xN]≡2[1+yN]
  xN≡yN     = cong ℕ.pred 1+xN≡1+yN
  x≡y       = toℕ-injective xN≡yN

toℕ-injective {2[1+ x ]} {1+[2 y ]} 2[1+xN]≡1+2yN =
  contradiction 2[1+xN]≡1+2yN (ℕₚ.even≢odd (ℕ.suc (toℕ x)) (toℕ y))

toℕ-injective {1+[2 x ]} {2[1+ y ]} 1+2xN≡2[1+yN] =
  contradiction (sym 1+2xN≡2[1+yN]) (ℕₚ.even≢odd (ℕ.suc (toℕ y)) (toℕ x))

toℕ-injective {1+[2 x ]} {1+[2 y ]} 1+2xN≡1+2yN =  cong 1+[2_] x≡y
  where
  2xN≡2yN = cong ℕ.pred 1+2xN≡1+2yN
  xN≡yN   = ℕₚ.*-cancelˡ-≡ 1 2xN≡2yN
  x≡y     = toℕ-injective xN≡yN

toℕ-surjective : Surjective _≡_ toℕ
toℕ-surjective n = (fromℕ n , toℕ-fromℕ n)

toℕ-isRelHomomorphism : IsRelHomomorphism _≡_ _≡_ toℕ
toℕ-isRelHomomorphism = record
  { cong = cong toℕ
  }

fromℕ-injective : Injective _≡_ _≡_ fromℕ
fromℕ-injective {x} {y} f[x]≡f[y] = begin
  x             ≡⟨ sym (toℕ-fromℕ x) ⟩
  toℕ (fromℕ x) ≡⟨ cong toℕ f[x]≡f[y] ⟩
  toℕ (fromℕ y) ≡⟨ toℕ-fromℕ y ⟩
  y             ∎
  where open ≡-Reasoning

fromℕ-toℕ : fromℕ ∘ toℕ ≗ id
fromℕ-toℕ =  toℕ-injective ∘ toℕ-fromℕ ∘ toℕ

fromℕ-pred : ∀ n → fromℕ (ℕ.pred n) ≡ pred (fromℕ n)
fromℕ-pred n = begin
  fromℕ (ℕ.pred n)        ≡⟨ cong (fromℕ ∘ ℕ.pred) (sym (toℕ-fromℕ n)) ⟩
  fromℕ (ℕ.pred (toℕ x))  ≡⟨ cong fromℕ (sym (toℕ-pred x)) ⟩
  fromℕ (toℕ (pred x))    ≡⟨ fromℕ-toℕ (pred x) ⟩
  pred x                  ≡⟨ refl ⟩
  pred (fromℕ n)          ∎
  where open ≡-Reasoning;  x = fromℕ n

x≡0⇒toℕ[x]≡0 : ∀ {x} → x ≡ zero → toℕ x ≡ 0
x≡0⇒toℕ[x]≡0 {zero} _ = refl

toℕ[x]≡0⇒x≡0 : ∀ {x} → toℕ x ≡ 0 → x ≡ zero
toℕ[x]≡0⇒x≡0 {zero} _ = refl

------------------------------------------------------------------------
-- Properties of _<_
------------------------------------------------------------------------
-- Basic properties

x≮0 : ∀ {x} → x ≮ zero
x≮0 ()

x≢0⇒x>0 : ∀ {x} → x ≢ zero → x > zero
x≢0⇒x>0 {zero}     0≢0 =  contradiction refl 0≢0
x≢0⇒x>0 {2[1+ _ ]} _   =  0<even
x≢0⇒x>0 {1+[2 _ ]} _   =  0<odd

1+[2x]<2[1+x] : ∀ x → 1+[2 x ] < 2[1+ x ]
1+[2x]<2[1+x] x =  odd<even (inj₂ refl)

<⇒≢ : _<_ ⇒ _≢_
<⇒≢ (even<even x<x) refl = <⇒≢ x<x refl
<⇒≢ (odd<odd   x<x) refl = <⇒≢ x<x refl

>⇒≢ : _>_ ⇒ _≢_
>⇒≢ y<x =  ≢-sym (<⇒≢ y<x)

≡⇒≮ : _≡_ ⇒ _≮_
≡⇒≮ x≡y x<y =  <⇒≢ x<y x≡y

≡⇒≯ : _≡_ ⇒ _≯_
≡⇒≯ x≡y x>y =  >⇒≢ x>y x≡y

<⇒≯ : _<_ ⇒ _≯_
<⇒≯ (even<even x<y)        (even<even y<x)        = <⇒≯ x<y y<x
<⇒≯ (even<odd x<y)         (odd<even (inj₁ y<x))  = <⇒≯ x<y y<x
<⇒≯ (even<odd x<y)         (odd<even (inj₂ refl)) = <⇒≢ x<y refl
<⇒≯ (odd<even (inj₁ x<y))  (even<odd y<x)         = <⇒≯ x<y y<x
<⇒≯ (odd<even (inj₂ refl)) (even<odd y<x)         = <⇒≢ y<x refl
<⇒≯ (odd<odd x<y)          (odd<odd y<x)          = <⇒≯ x<y y<x

>⇒≮ : _>_ ⇒ _≮_
>⇒≮ y<x =  <⇒≯ y<x

<⇒≤ : _<_ ⇒ _≤_
<⇒≤ = inj₁

------------------------------------------------------------------------------
-- Properties of _<_ and toℕ & fromℕ.

toℕ-mono-< : toℕ Preserves _<_ ⟶ ℕ._<_
toℕ-mono-< {zero}     {2[1+ _ ]} _               =  ℕₚ.0<1+n
toℕ-mono-< {zero}     {1+[2 _ ]} _               =  ℕₚ.0<1+n
toℕ-mono-< {2[1+ x ]} {2[1+ y ]} (even<even x<y) =  begin
  ℕ.suc (2 ℕ.* (ℕ.suc xN))    ≤⟨ ℕₚ.+-monoʳ-≤ 1 (ℕₚ.*-monoʳ-≤ 2 xN<yN) ⟩
  ℕ.suc (2 ℕ.* yN)            ≤⟨ ℕₚ.≤-step ℕₚ.≤-refl ⟩
  2 ℕ.+ (2 ℕ.* yN)            ≡⟨ sym (ℕₚ.*-distribˡ-+ 2 1 yN) ⟩
  2 ℕ.* (ℕ.suc yN)            ∎
  where open ℕₚ.≤-Reasoning;  xN = toℕ x;  yN = toℕ y;  xN<yN = toℕ-mono-< x<y
toℕ-mono-< {2[1+ x ]} {1+[2 y ]} (even<odd x<y) =
  ℕₚ.+-monoʳ-≤ 1 (ℕₚ.*-monoʳ-≤ 2 (toℕ-mono-< x<y))
toℕ-mono-< {1+[2 x ]} {2[1+ y ]} (odd<even (inj₁ x<y)) =   begin
  ℕ.suc (ℕ.suc (2 ℕ.* xN))    ≡⟨⟩
  2 ℕ.+ (2 ℕ.* xN)            ≡⟨ sym (ℕₚ.*-distribˡ-+ 2 1 xN) ⟩
  2 ℕ.* (ℕ.suc xN)            ≤⟨ ℕₚ.*-monoʳ-≤ 2 xN<yN ⟩
  2 ℕ.* yN                    ≤⟨ ℕₚ.*-monoʳ-≤ 2 (ℕₚ.≤-step ℕₚ.≤-refl) ⟩
  2 ℕ.* (ℕ.suc yN)            ∎
  where open ℕₚ.≤-Reasoning;  xN = toℕ x;  yN = toℕ y;  xN<yN = toℕ-mono-< x<y
toℕ-mono-< {1+[2 x ]} {2[1+ .x ]} (odd<even (inj₂ refl)) =
  ℕₚ.≤-reflexive (sym (ℕₚ.*-distribˡ-+ 2 1 (toℕ x)))
toℕ-mono-< {1+[2 x ]} {1+[2 y ]} (odd<odd x<y) =  ℕₚ.+-monoʳ-< 1 (ℕₚ.*-monoʳ-< 1 xN<yN)
  where xN = toℕ x;  yN = toℕ y;  xN<yN = toℕ-mono-< x<y

toℕ-cancel-< : ∀ {x y} → toℕ x ℕ.< toℕ y → x < y
toℕ-cancel-< {zero}     {2[1+ y ]} x<y = 0<even
toℕ-cancel-< {zero}     {1+[2 y ]} x<y = 0<odd
toℕ-cancel-< {2[1+ x ]} {2[1+ y ]} x<y =
  even<even (toℕ-cancel-< (ℕ.≤-pred (ℕₚ.*-cancelˡ-< 2 x<y)))
toℕ-cancel-< {2[1+ x ]} {1+[2 y ]} x<y
  rewrite ℕₚ.*-distribˡ-+ 2 1 (toℕ x) =
  even<odd (toℕ-cancel-< (ℕₚ.*-cancelˡ-< 2 (ℕₚ.≤-trans (s≤s (ℕₚ.n≤1+n _)) (ℕₚ.≤-pred x<y))))
toℕ-cancel-< {1+[2 x ]} {2[1+ y ]} x<y with toℕ x ℕₚ.≟ toℕ y
... | yes x≡y = odd<even (inj₂ (toℕ-injective x≡y))
... | no  x≢y
  rewrite ℕₚ.+-suc (toℕ y) (toℕ y ℕ.+ 0) =
  odd<even (inj₁ (toℕ-cancel-< (ℕₚ.≤∧≢⇒< (ℕₚ.*-cancelˡ-≤ 1 (ℕₚ.+-cancelˡ-≤ 2 x<y)) x≢y)))
toℕ-cancel-< {1+[2 x ]} {1+[2 y ]} x<y =
  odd<odd (toℕ-cancel-< (ℕₚ.*-cancelˡ-< 2 (ℕ.≤-pred x<y)))

fromℕ-cancel-< : ∀ {x y} → fromℕ x < fromℕ y → x ℕ.< y
fromℕ-cancel-< = subst₂ ℕ._<_ (toℕ-fromℕ _) (toℕ-fromℕ _) ∘ toℕ-mono-<

fromℕ-mono-< : fromℕ Preserves ℕ._<_ ⟶ _<_
fromℕ-mono-< = toℕ-cancel-< ∘ subst₂ ℕ._<_ (sym (toℕ-fromℕ _)) (sym (toℕ-fromℕ _))

toℕ-isHomomorphism-< : IsOrderHomomorphism _≡_ _≡_ _<_ ℕ._<_ toℕ
toℕ-isHomomorphism-< = record
  { cong = cong toℕ
  ; mono = toℕ-mono-<
  }

toℕ-isMonomorphism-< : IsOrderMonomorphism _≡_ _≡_ _<_ ℕ._<_ toℕ
toℕ-isMonomorphism-< = record
  { isOrderHomomorphism = toℕ-isHomomorphism-<
  ; injective           = toℕ-injective
  ; cancel              = toℕ-cancel-<
  }

------------------------------------------------------------------------------
-- Relational properties of _<_

<-irrefl : Irreflexive _≡_ _<_
<-irrefl refl (even<even x<x) =  <-irrefl refl x<x
<-irrefl refl (odd<odd x<x)   =  <-irrefl refl x<x

<-trans : Transitive _<_
<-trans {zero} {_}      {2[1+ _ ]} _  _        =  0<even
<-trans {zero} {_}      {1+[2 _ ]} _  _        =  0<odd
<-trans (even<even x<y) (even<even y<z)        =  even<even (<-trans x<y y<z)
<-trans (even<even x<y) (even<odd y<z)         =  even<odd (<-trans x<y y<z)
<-trans (even<odd x<y)  (odd<even (inj₁ y<z))  =  even<even (<-trans x<y y<z)
<-trans (even<odd x<y)  (odd<even (inj₂ refl)) =  even<even x<y
<-trans (even<odd x<y)  (odd<odd y<z)          =  even<odd (<-trans x<y y<z)
<-trans (odd<even (inj₁ x<y))  (even<even y<z) =  odd<even (inj₁ (<-trans x<y y<z))
<-trans (odd<even (inj₂ refl)) (even<even x<z) =  odd<even (inj₁ x<z)
<-trans (odd<even (inj₁ x<y))  (even<odd y<z)  =  odd<odd (<-trans x<y y<z)
<-trans (odd<even (inj₂ refl)) (even<odd x<z)  =  odd<odd x<z
<-trans (odd<odd x<y) (odd<even (inj₁ y<z))    =  odd<even (inj₁ (<-trans x<y y<z))
<-trans (odd<odd x<y) (odd<even (inj₂ refl))   =  odd<even (inj₁ x<y)
<-trans (odd<odd x<y) (odd<odd y<z)            =  odd<odd (<-trans x<y y<z)

-- Should not be implemented via the morphism `toℕ` in order to
-- preserve O(log n) time requirement.
<-cmp : Trichotomous _≡_ _<_
<-cmp zero     zero      = tri≈ x≮0    refl  x≮0
<-cmp zero     2[1+ _ ]  = tri< 0<even (λ()) x≮0
<-cmp zero     1+[2 _ ]  = tri< 0<odd  (λ()) x≮0
<-cmp 2[1+ _ ] zero      = tri> (λ())  (λ()) 0<even
<-cmp 2[1+ x ] 2[1+ y ]  with <-cmp x y
... | tri< x<y _    _   =  tri< lt (<⇒≢ lt) (<⇒≯ lt)  where lt = even<even x<y
... | tri≈ _   refl _   =  tri≈ (<-irrefl refl) refl (<-irrefl refl)
... | tri> _   _    x>y =  tri> (>⇒≮ gt) (>⇒≢ gt) gt  where gt = even<even x>y
<-cmp 2[1+ x ] 1+[2 y ]  with <-cmp x y
... | tri< x<y _    _ =  tri< lt (<⇒≢ lt) (<⇒≯ lt)  where lt = even<odd x<y
... | tri≈ _   refl _ =  tri> (>⇒≮ gt) (>⇒≢ gt) gt
  where
  gt = subst (_< 2[1+ x ]) refl (1+[2x]<2[1+x] x)
... | tri> _ _ y<x =  tri> (>⇒≮ gt) (>⇒≢ gt) gt  where gt = odd<even (inj₁ y<x)
<-cmp 1+[2 _ ] zero =  tri> (>⇒≮ gt) (>⇒≢ gt) gt  where gt = 0<odd
<-cmp 1+[2 x ] 2[1+ y ]  with <-cmp x y
... | tri< x<y _ _ =  tri< lt (<⇒≢ lt) (<⇒≯ lt)  where lt = odd<even (inj₁ x<y)
... | tri≈ _ x≡y _ =  tri< lt (<⇒≢ lt) (<⇒≯ lt)  where lt = odd<even (inj₂ x≡y)
... | tri> _ _ x>y =  tri> (>⇒≮ gt) (>⇒≢ gt) gt  where gt = even<odd x>y
<-cmp 1+[2 x ] 1+[2 y ]  with <-cmp x y
... | tri< x<y _  _   =  tri< lt (<⇒≢ lt) (<⇒≯ lt)  where lt = odd<odd x<y
... | tri≈ _ refl _   =  tri≈ (≡⇒≮ refl) refl (≡⇒≯ refl)
... | tri> _ _    x>y =  tri> (>⇒≮ gt) (>⇒≢ gt) gt  where gt = odd<odd x>y

_<?_ : Decidable _<_
_<?_ = tri⟶dec< <-cmp

------------------------------------------------------------------------------
-- Structures for _<_

<-isStrictPartialOrder : IsStrictPartialOrder _≡_ _<_
<-isStrictPartialOrder = record
  { isEquivalence = isEquivalence
  ; irrefl        = <-irrefl
  ; trans         = <-trans
  ; <-resp-≈      = resp₂ _<_
  }

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

------------------------------------------------------------------------------
-- Bundles for _<_

<-strictPartialOrder : StrictPartialOrder _ _ _
<-strictPartialOrder = record
  { isStrictPartialOrder = <-isStrictPartialOrder
  }

<-strictTotalOrder : StrictTotalOrder _ _ _
<-strictTotalOrder = record
  { isStrictTotalOrder =  <-isStrictTotalOrder
  }

------------------------------------------------------------------------------
-- Other properties of _<_

x<2[1+x] : ∀ x → x < 2[1+ x ]
x<1+[2x] : ∀ x → x < 1+[2 x ]

x<2[1+x] zero     = 0<even
x<2[1+x] 2[1+ x ] = even<even (x<2[1+x] x)
x<2[1+x] 1+[2 x ] = odd<even (inj₁ (x<1+[2x] x))

x<1+[2x] zero     = 0<odd
x<1+[2x] 2[1+ x ] = even<odd (x<2[1+x] x)
x<1+[2x] 1+[2 x ] = odd<odd (x<1+[2x] x)

------------------------------------------------------------------------------
-- Properties of _≤_
------------------------------------------------------------------------------
-- Basic properties

<⇒≱ : _<_ ⇒ _≱_
<⇒≱ x<y (inj₁ y<x) =  contradiction y<x (<⇒≯ x<y)
<⇒≱ x<y (inj₂ y≡x) =  contradiction (sym y≡x) (<⇒≢ x<y)

≤⇒≯ : _≤_ ⇒ _≯_
≤⇒≯ x≤y x>y =  <⇒≱ x>y x≤y

≮⇒≥ : _≮_ ⇒ _≥_
≮⇒≥ {x} {y} x≮y  with <-cmp x y
... | tri< lt _  _   =  contradiction lt x≮y
... | tri≈ _  eq _   =  inj₂ (sym eq)
... | tri> _  _  y<x =  <⇒≤ y<x

≰⇒> : _≰_ ⇒ _>_
≰⇒> {x} {y} x≰y  with <-cmp x y
... | tri< lt _  _   =  contradiction (<⇒≤ lt) x≰y
... | tri≈ _  eq _   =  contradiction (inj₂ eq) x≰y
... | tri> _  _  x>y =  x>y

≤∧≢⇒< : ∀ {x y} → x ≤ y → x ≢ y → x < y
≤∧≢⇒< (inj₁ x<y) _   =  x<y
≤∧≢⇒< (inj₂ x≡y) x≢y =  contradiction x≡y x≢y

0≤x : ∀ x → zero ≤ x
0≤x zero     =  inj₂ refl
0≤x 2[1+ _ ] =  inj₁ 0<even
0≤x 1+[2 x ] =  inj₁ 0<odd

x≤0⇒x≡0 : ∀ {x} → x ≤ zero → x ≡ zero
x≤0⇒x≡0 (inj₂ x≡0) = x≡0

------------------------------------------------------------------------------
-- Properties of _<_ and toℕ & fromℕ.

fromℕ-mono-≤ : fromℕ Preserves ℕ._≤_ ⟶ _≤_
fromℕ-mono-≤ m≤n  with ℕₚ.m≤n⇒m<n∨m≡n m≤n
... | inj₁ m<n =  inj₁ (fromℕ-mono-< m<n)
... | inj₂ m≡n =  inj₂ (cong fromℕ m≡n)

toℕ-mono-≤ : toℕ Preserves _≤_ ⟶ ℕ._≤_
toℕ-mono-≤ (inj₁ x<y)  =  ℕₚ.<⇒≤ (toℕ-mono-< x<y)
toℕ-mono-≤ (inj₂ refl) =  ℕₚ.≤-reflexive refl

toℕ-cancel-≤ : ∀ {x y} → toℕ x ℕ.≤ toℕ y → x ≤ y
toℕ-cancel-≤ = subst₂ _≤_ (fromℕ-toℕ _) (fromℕ-toℕ _) ∘ fromℕ-mono-≤

fromℕ-cancel-≤ : ∀ {x y} → fromℕ x ≤ fromℕ y → x ℕ.≤ y
fromℕ-cancel-≤ = subst₂ ℕ._≤_ (toℕ-fromℕ _) (toℕ-fromℕ _) ∘ toℕ-mono-≤

toℕ-isHomomorphism-≤ : IsOrderHomomorphism _≡_ _≡_ _≤_ ℕ._≤_ toℕ
toℕ-isHomomorphism-≤ = record
  { cong = cong toℕ
  ; mono = toℕ-mono-≤
  }

toℕ-isMonomorphism-≤ : IsOrderMonomorphism _≡_ _≡_ _≤_ ℕ._≤_ toℕ
toℕ-isMonomorphism-≤ = record
  { isOrderHomomorphism = toℕ-isHomomorphism-≤
  ; injective           = toℕ-injective
  ; cancel              = toℕ-cancel-≤
  }

------------------------------------------------------------------------------
-- Relational properties of _≤_

≤-refl : Reflexive _≤_
≤-refl =  inj₂ refl

≤-reflexive : _≡_ ⇒ _≤_
≤-reflexive {x} {_} refl =  ≤-refl {x}

≤-trans : Transitive _≤_
≤-trans = StrictToNonStrict.trans isEquivalence (resp₂ _<_) <-trans

<-≤-trans : ∀ {x y z} → x < y → y ≤ z → x < z
<-≤-trans x<y (inj₁ y<z)  =  <-trans x<y y<z
<-≤-trans x<y (inj₂ refl) =  x<y

≤-<-trans : ∀ {x y z} → x ≤ y → y < z → x < z
≤-<-trans (inj₁ x<y)  y<z =  <-trans x<y y<z
≤-<-trans (inj₂ refl) y<z =  y<z

≤-antisym : Antisymmetric _≡_ _≤_
≤-antisym = StrictToNonStrict.antisym isEquivalence <-trans <-irrefl

≤-total : Total _≤_
≤-total x y with <-cmp x y
... | tri< x<y _  _   = inj₁ (<⇒≤ x<y)
... | tri≈ _  x≡y _   = inj₁ (≤-reflexive x≡y)
... | tri> _  _   y<x = inj₂ (<⇒≤ y<x)

-- Should not be implemented via the morphism `toℕ` in order to
-- preserve O(log n) time requirement.
_≤?_ : Decidable _≤_
x ≤? y with <-cmp x y
... | tri< x<y _   _   = yes (<⇒≤ x<y)
... | tri≈ _   x≡y _   = yes (≤-reflexive x≡y)
... | tri> _   _   y<x = no (<⇒≱ y<x)

------------------------------------------------------------------------------
-- Structures

≤-isPreorder : IsPreorder _≡_ _≤_
≤-isPreorder = record
  { isEquivalence = isEquivalence
  ; reflexive     = ≤-reflexive
  ; trans         = ≤-trans
  }

≤-isPartialOrder : IsPartialOrder _≡_ _≤_
≤-isPartialOrder = record
  { isPreorder = ≤-isPreorder
  ; antisym    = ≤-antisym
  }

≤-isTotalOrder : IsTotalOrder _≡_ _≤_
≤-isTotalOrder = record
  { isPartialOrder = ≤-isPartialOrder
  ; total          = ≤-total
  }

≤-isDecTotalOrder : IsDecTotalOrder _≡_ _≤_
≤-isDecTotalOrder = record
  { isTotalOrder = ≤-isTotalOrder
  ; _≟_          = _≟_
  ; _≤?_         = _≤?_
  }

------------------------------------------------------------------------------
-- Bundles

≤-preorder : Preorder 0ℓ 0ℓ 0ℓ
≤-preorder = record
  { isPreorder = ≤-isPreorder
  }

≤-partialOrder : Poset 0ℓ 0ℓ 0ℓ
≤-partialOrder = record
  { isPartialOrder = ≤-isPartialOrder
  }

≤-totalOrder : TotalOrder 0ℓ 0ℓ 0ℓ
≤-totalOrder = record
  { isTotalOrder = ≤-isTotalOrder
  }

≤-decTotalOrder : DecTotalOrder 0ℓ 0ℓ 0ℓ
≤-decTotalOrder = record
  { isDecTotalOrder = ≤-isDecTotalOrder
  }

------------------------------------------------------------------------------
-- Equational reasoning for _≤_ and _<_

module ≤-Reasoning = InequalityReasoning
  ≤-isPreorder
  <-trans
  (resp₂ _<_) <⇒≤
  <-≤-trans ≤-<-trans
  hiding (step-≈; step-≈˘)

------------------------------------------------------------------------------
-- Properties of _<ℕ_
------------------------------------------------------------------------------

<⇒<ℕ : ∀ {x y} → x < y → x <ℕ y
<⇒<ℕ x<y = toℕ-mono-< x<y

<ℕ⇒< : ∀ {x y} → x <ℕ y → x < y
<ℕ⇒< {x} {y} t[x]<t[y] = begin-strict
  x             ≡⟨ sym (fromℕ-toℕ x) ⟩
  fromℕ (toℕ x) <⟨ fromℕ-mono-< t[x]<t[y] ⟩
  fromℕ (toℕ y) ≡⟨ fromℕ-toℕ y ⟩
  y             ∎
  where open ≤-Reasoning

------------------------------------------------------------------------
-- Properties of _+_
------------------------------------------------------------------------

------------------------------------------------------------------------
-- Raw bundles for _+_

+-rawMagma : RawMagma 0ℓ 0ℓ
+-rawMagma = record
  { _≈_ = _≡_
  ; _∙_ = _+_
  }

+-0-rawMonoid : RawMonoid 0ℓ 0ℓ
+-0-rawMonoid = record
  { _≈_ = _≡_
  ; _∙_ = _+_
  ; ε   = 0ᵇ
  }

------------------------------------------------------------------------
-- toℕ/fromℕ are homomorphisms for _+_

toℕ-homo-+ : ∀ x y → toℕ (x + y) ≡ toℕ x ℕ.+ toℕ y
toℕ-homo-+ zero     _        = refl
toℕ-homo-+ 2[1+ x ] zero     = cong ℕ.suc (sym (ℕₚ.+-identityʳ _))
toℕ-homo-+ 1+[2 x ] zero     = cong ℕ.suc (sym (ℕₚ.+-identityʳ _))
toℕ-homo-+ 2[1+ x ] 2[1+ y ] = begin
  toℕ (2[1+ x ] + 2[1+ y ])          ≡⟨⟩
  toℕ 2[1+ (suc (x + y)) ]           ≡⟨⟩
  2 ℕ.* (1 ℕ.+ (toℕ (suc (x + y))))  ≡⟨ cong ((2 ℕ.*_) ∘ ℕ.suc) (toℕ-suc (x + y)) ⟩
  2 ℕ.* (2 ℕ.+ toℕ (x + y))          ≡⟨ cong ((2 ℕ.*_) ∘ (2 ℕ.+_)) (toℕ-homo-+ x y) ⟩
  2 ℕ.* (2 ℕ.+ (toℕ x ℕ.+ toℕ y))    ≡⟨ solve 2 (λ m n → con 2 :* (con 2 :+ (m :+ n))  :=
                                          con 2 :* (con 1 :+ m) :+ con 2 :* (con 1 :+ n))
                                          refl (toℕ x) (toℕ y) ⟩
  toℕ 2[1+ x ] ℕ.+ toℕ 2[1+ y ]      ∎
  where open ≡-Reasoning

toℕ-homo-+ 2[1+ x ] 1+[2 y ] = begin
  toℕ (2[1+ x ] + 1+[2 y ])             ≡⟨⟩
  toℕ (suc 2[1+ (x + y) ])              ≡⟨ toℕ-suc 2[1+ (x + y) ] ⟩
  ℕ.suc (toℕ 2[1+ (x + y) ])            ≡⟨⟩
  ℕ.suc (2 ℕ.* (ℕ.suc (toℕ (x + y))))   ≡⟨ cong (λ v → ℕ.suc (2 ℕ.* ℕ.suc v)) (toℕ-homo-+ x y) ⟩
  ℕ.suc (2 ℕ.* (ℕ.suc (m ℕ.+ n)))       ≡⟨ solve 2 (λ m n → con 1 :+ (con 2 :* (con 1 :+ (m :+ n))) :=
                                             con 2 :* (con 1 :+ m) :+ (con 1 :+ (con 2 :* n)))
                                             refl m n ⟩
  (2 ℕ.* ℕ.suc m) ℕ.+ (ℕ.suc (2 ℕ.* n)) ≡⟨⟩
  toℕ 2[1+ x ] ℕ.+ toℕ 1+[2 y ]         ∎
  where open ≡-Reasoning;  m = toℕ x; n = toℕ y

toℕ-homo-+ 1+[2 x ] 2[1+ y ] = begin
  toℕ (1+[2 x ] + 2[1+ y ])                 ≡⟨⟩
  toℕ (suc 2[1+ (x + y) ])                  ≡⟨ toℕ-suc 2[1+ (x + y) ] ⟩
  ℕ.suc (toℕ 2[1+ (x + y) ])                ≡⟨⟩
  ℕ.suc (2 ℕ.* (ℕ.suc (toℕ (x + y))))       ≡⟨ cong (ℕ.suc ∘ (2 ℕ.*_) ∘ ℕ.suc) (toℕ-homo-+ x y) ⟩
  ℕ.suc (2 ℕ.* (ℕ.suc (m ℕ.+ n)))           ≡⟨ solve 2 (λ m n → con 1 :+ (con 2 :* (con 1 :+ (m :+ n))) :=
                                                 (con 1 :+ (con 2 :* m)) :+ (con 2 :* (con 1 :+ n)))
                                                 refl m n ⟩
  (ℕ.suc (2 ℕ.* m)) ℕ.+ (2 ℕ.* (ℕ.suc n))   ≡⟨⟩
  toℕ 1+[2 x ] ℕ.+ toℕ 2[1+ y ]             ∎
  where open ≡-Reasoning;  m = toℕ x;  n = toℕ y

toℕ-homo-+ 1+[2 x ] 1+[2 y ] = begin
  toℕ (1+[2 x ] + 1+[2 y ])               ≡⟨⟩
  toℕ (suc 1+[2 (x + y) ])                ≡⟨ toℕ-suc 1+[2 (x + y) ] ⟩
  ℕ.suc (toℕ 1+[2 (x + y) ])              ≡⟨⟩
  ℕ.suc (ℕ.suc (2 ℕ.* (toℕ (x + y))))     ≡⟨ cong (ℕ.suc ∘ ℕ.suc ∘ (2 ℕ.*_)) (toℕ-homo-+ x y) ⟩
  ℕ.suc (ℕ.suc (2 ℕ.* (m ℕ.+ n)))         ≡⟨ solve 2 (λ m n → con 1 :+ (con 1 :+ (con 2 :* (m :+ n))) :=
                                               (con 1 :+ (con 2 :* m)) :+ (con 1 :+ (con 2 :* n)))
                                               refl m n ⟩
  (ℕ.suc (2 ℕ.* m)) ℕ.+ (ℕ.suc (2 ℕ.* n)) ≡⟨⟩
  toℕ 1+[2 x ] ℕ.+ toℕ 1+[2 y ]           ∎
  where open ≡-Reasoning;  m = toℕ x;  n = toℕ y

toℕ-isMagmaHomomorphism-+ : IsMagmaHomomorphism +-rawMagma ℕₚ.+-rawMagma toℕ
toℕ-isMagmaHomomorphism-+ = record
  { isRelHomomorphism = toℕ-isRelHomomorphism
  ; homo              = toℕ-homo-+
  }

toℕ-isMonoidHomomorphism-+ : IsMonoidHomomorphism +-0-rawMonoid ℕₚ.+-0-rawMonoid toℕ
toℕ-isMonoidHomomorphism-+ = record
  { isMagmaHomomorphism = toℕ-isMagmaHomomorphism-+
  ; ε-homo              = refl
  }

toℕ-isMonoidMonomorphism-+ : IsMonoidMonomorphism +-0-rawMonoid ℕₚ.+-0-rawMonoid toℕ
toℕ-isMonoidMonomorphism-+ = record
  { isMonoidHomomorphism = toℕ-isMonoidHomomorphism-+
  ; injective            = toℕ-injective
  }

suc≗1+ : suc ≗ 1ᵇ +_
suc≗1+ zero     = refl
suc≗1+ 2[1+ _ ] = refl
suc≗1+ 1+[2 _ ] = refl

suc-+ : ∀ x y → suc x + y ≡ suc (x + y)
suc-+ zero        y     =  sym (suc≗1+ y)
suc-+ 2[1+ x ] zero     =  refl
suc-+ 1+[2 x ] zero     =  refl
suc-+ 2[1+ x ] 2[1+ y ] =  cong (suc ∘ 2[1+_]) (suc-+ x y)
suc-+ 2[1+ x ] 1+[2 y ] =  cong (suc ∘ 1+[2_]) (suc-+ x y)
suc-+ 1+[2 x ] 2[1+ y ] =  refl
suc-+ 1+[2 x ] 1+[2 y ] =  refl

1+≗suc : (1ᵇ +_) ≗ suc
1+≗suc = suc-+ zero

fromℕ-homo-+ : ∀ m n → fromℕ (m ℕ.+ n) ≡ fromℕ m + fromℕ n
fromℕ-homo-+ 0         _ = refl
fromℕ-homo-+ (ℕ.suc m) n = begin
  fromℕ ((ℕ.suc m) ℕ.+ n)          ≡⟨⟩
  suc (fromℕ (m ℕ.+ n))            ≡⟨ cong suc (fromℕ-homo-+ m n) ⟩
  suc (a + b)                      ≡⟨ sym (suc-+ a b) ⟩
  (suc a) + b                      ≡⟨⟩
  (fromℕ (ℕ.suc m)) + (fromℕ n)    ∎
  where open ≡-Reasoning;  a = fromℕ m;  b = fromℕ n

------------------------------------------------------------------------
-- Algebraic properties of _+_

-- Mostly proved by using the isomorphism between `ℕ` and `ℕᵇ` provided
-- by `toℕ`/`fromℕ`.

private
  module +-Monomorphism = MonoidMonomorphism toℕ-isMonoidMonomorphism-+

+-assoc : Associative _+_
+-assoc = +-Monomorphism.assoc ℕₚ.+-isMagma ℕₚ.+-assoc

+-comm : Commutative _+_
+-comm = +-Monomorphism.comm ℕₚ.+-isMagma ℕₚ.+-comm

+-identityˡ : LeftIdentity zero _+_
+-identityˡ _ = refl

+-identityʳ : RightIdentity zero _+_
+-identityʳ = +-Monomorphism.identityʳ ℕₚ.+-isMagma ℕₚ.+-identityʳ

+-identity : Identity zero _+_
+-identity = +-identityˡ , +-identityʳ

+-cancelˡ-≡ : LeftCancellative _+_
+-cancelˡ-≡ = +-Monomorphism.cancelˡ ℕₚ.+-isMagma ℕₚ.+-cancelˡ-≡

+-cancelʳ-≡ : RightCancellative _+_
+-cancelʳ-≡ = +-Monomorphism.cancelʳ ℕₚ.+-isMagma ℕₚ.+-cancelʳ-≡

------------------------------------------------------------------------
-- Structures for _+_

+-isMagma : IsMagma _+_
+-isMagma = isMagma _+_

+-isSemigroup : IsSemigroup _+_
+-isSemigroup = +-Monomorphism.isSemigroup ℕₚ.+-isSemigroup

+-0-isMonoid : IsMonoid _+_ 0ᵇ
+-0-isMonoid = +-Monomorphism.isMonoid ℕₚ.+-0-isMonoid

+-0-isCommutativeMonoid : IsCommutativeMonoid _+_ 0ᵇ
+-0-isCommutativeMonoid = +-Monomorphism.isCommutativeMonoid ℕₚ.+-0-isCommutativeMonoid

------------------------------------------------------------------------
-- Bundles for _+_

+-magma : Magma 0ℓ 0ℓ
+-magma = magma _+_

+-semigroup : Semigroup 0ℓ 0ℓ
+-semigroup = record
  { isSemigroup = +-isSemigroup
  }

+-0-monoid : Monoid 0ℓ 0ℓ
+-0-monoid = record
  { ε        = zero
  ; isMonoid = +-0-isMonoid
  }

+-0-commutativeMonoid : CommutativeMonoid 0ℓ 0ℓ
+-0-commutativeMonoid = record
  { isCommutativeMonoid = +-0-isCommutativeMonoid
  }

------------------------------------------------------------------------------
-- Properties of _+_ and _≤_

+-mono-≤ : _+_ Preserves₂ _≤_ ⟶ _≤_ ⟶ _≤_
+-mono-≤ {x} {x'} {y} {y'} x≤x' y≤y' =  begin
  x + y                 ≡⟨ sym $ cong₂ _+_ (fromℕ-toℕ x) (fromℕ-toℕ y) ⟩
  fromℕ m + fromℕ n     ≡⟨ sym (fromℕ-homo-+ m n) ⟩
  fromℕ (m ℕ.+ n)       ≤⟨ fromℕ-mono-≤ (ℕₚ.+-mono-≤ m≤m' n≤n') ⟩
  fromℕ (m' ℕ.+ n')     ≡⟨ fromℕ-homo-+ m' n' ⟩
  fromℕ m' + fromℕ n'   ≡⟨ cong₂ _+_ (fromℕ-toℕ x') (fromℕ-toℕ y') ⟩
  x' + y'               ∎
  where
  open ≤-Reasoning
  m    = toℕ x;             m'   = toℕ x'
  n    = toℕ y;             n'   = toℕ y'
  m≤m' = toℕ-mono-≤ x≤x';   n≤n' = toℕ-mono-≤ y≤y'

+-monoˡ-≤ : ∀ x → (_+ x) Preserves _≤_ ⟶ _≤_
+-monoˡ-≤ x y≤z =  +-mono-≤ y≤z (≤-refl {x})

+-monoʳ-≤ : ∀ x → (x +_) Preserves _≤_ ⟶ _≤_
+-monoʳ-≤ x y≤z =  +-mono-≤ (≤-refl {x}) y≤z

+-mono-<-≤ : _+_ Preserves₂ _<_ ⟶ _≤_ ⟶ _<_
+-mono-<-≤ {x} {x'} {y} {y'} x<x' y≤y' =  begin-strict
  x + y                  ≡⟨ sym $ cong₂ _+_ (fromℕ-toℕ x) (fromℕ-toℕ y) ⟩
  fromℕ m + fromℕ n      ≡⟨ sym (fromℕ-homo-+ m n) ⟩
  fromℕ (m ℕ.+ n)        <⟨ fromℕ-mono-< (ℕₚ.+-mono-<-≤ m<m' n≤n') ⟩
  fromℕ (m' ℕ.+ n')      ≡⟨ fromℕ-homo-+ m' n' ⟩
  fromℕ m' + fromℕ n'    ≡⟨ cong₂ _+_ (fromℕ-toℕ x') (fromℕ-toℕ y') ⟩
  x' + y'                ∎
  where
  open ≤-Reasoning
  m    = toℕ x;             n    = toℕ y
  m'   = toℕ x';            n'   = toℕ y'
  m<m' = toℕ-mono-< x<x';   n≤n' = toℕ-mono-≤ y≤y'

+-mono-≤-< : _+_ Preserves₂ _≤_ ⟶ _<_ ⟶ _<_
+-mono-≤-< {x} {x'} {y} {y'} x≤x' y<y' =  subst₂ _<_ (+-comm y x) (+-comm y' x') y+x<y'+x'
  where
  y+x<y'+x' =  +-mono-<-≤ y<y' x≤x'

+-monoˡ-< : ∀ x → (_+ x) Preserves _<_ ⟶ _<_
+-monoˡ-< x y<z =  +-mono-<-≤ y<z (≤-refl {x})

+-monoʳ-< : ∀ x → (x +_) Preserves _<_ ⟶ _<_
+-monoʳ-< x y<z =  +-mono-≤-< (≤-refl {x}) y<z

x≤y+x : ∀ x y → x ≤ y + x
x≤y+x x y =  begin
  x        ≡⟨ sym (+-identityˡ x) ⟩
  0ᵇ + x   ≤⟨ +-monoˡ-≤ x (0≤x y) ⟩
  y + x    ∎
  where open ≤-Reasoning

x≤x+y : ∀ x y → x ≤ x + y
x≤x+y x y =  begin
  x        ≤⟨ x≤y+x x y ⟩
  y + x    ≡⟨ +-comm y x ⟩
  x + y    ∎
  where open ≤-Reasoning

x<x+y : ∀ x {y} → y > 0ᵇ → x < x + y
x<x+y x {y} y>0 = begin-strict
  x                             ≡⟨ sym (fromℕ-toℕ x) ⟩
  fromℕ (toℕ x)                 <⟨ fromℕ-mono-< (ℕₚ.m<m+n (toℕ x) (toℕ-mono-< y>0)) ⟩
  fromℕ (toℕ x ℕ.+ toℕ y)       ≡⟨ fromℕ-homo-+ (toℕ x) (toℕ y) ⟩
  fromℕ (toℕ x) + fromℕ (toℕ y) ≡⟨ cong₂ _+_ (fromℕ-toℕ x) (fromℕ-toℕ y) ⟩
  x + y                         ∎
  where open ≤-Reasoning

x<x+1 : ∀ x → x < x + 1ᵇ
x<x+1 x = x<x+y x 0<odd

x<1+x : ∀ x → x < 1ᵇ + x
x<1+x x rewrite +-comm 1ᵇ x = x<x+1 x

x<1⇒x≡0 : ∀ {x} → x < 1ᵇ → x ≡ zero
x<1⇒x≡0 0<odd = refl

------------------------------------------------------------------------
-- Other properties

x≢0⇒x+y≢0 : ∀ {x} (y : ℕᵇ) → x ≢ zero → x + y ≢ zero
x≢0⇒x+y≢0 {2[1+ _ ]} zero _   =  λ()
x≢0⇒x+y≢0 {zero}     _    0≢0 =  contradiction refl 0≢0

------------------------------------------------------------------------
-- Properties of _*_
------------------------------------------------------------------------

------------------------------------------------------------------------
-- Raw bundles for _*_

*-rawMagma : RawMagma 0ℓ 0ℓ
*-rawMagma = record
  { _≈_ = _≡_
  ; _∙_ = _*_
  }

*-1-rawMonoid : RawMonoid 0ℓ 0ℓ
*-1-rawMonoid = record
  { _≈_ = _≡_
  ; _∙_ = _*_
  ; ε   = 1ᵇ
  }

------------------------------------------------------------------------
-- toℕ/fromℕ are homomorphisms for _*_

private  2*ₙ2*ₙ =  (2 ℕ.*_) ∘ (2 ℕ.*_)

toℕ-homo-* : ∀ x y → toℕ (x * y) ≡ toℕ x ℕ.* toℕ y
toℕ-homo-* x y =  aux x y (size x ℕ.+ size y) ℕₚ.≤-refl
  where
  aux : (x y : ℕᵇ) → (cnt : ℕ) → (size x ℕ.+ size y ℕ.≤ cnt) →  toℕ (x * y) ≡ toℕ x ℕ.* toℕ y
  aux zero     _        _ _ = refl
  aux 2[1+ x ] zero     _ _ = sym (ℕₚ.*-zeroʳ (toℕ x ℕ.+ (ℕ.suc (toℕ x ℕ.+ 0))))
  aux 1+[2 x ] zero     _ _ = sym (ℕₚ.*-zeroʳ (toℕ x ℕ.+ (toℕ x ℕ.+ 0)))
  aux 2[1+ x ] 2[1+ y ] (ℕ.suc cnt) (s≤s |x|+1+|y|≤cnt) = begin
    toℕ (2[1+ x ] * 2[1+ y ])                ≡⟨⟩
    toℕ (double 2[1+ (x + (y + xy)) ])       ≡⟨ toℕ-double 2[1+ (x + (y + xy)) ] ⟩
    2 ℕ.* (toℕ 2[1+ (x + (y + xy)) ])        ≡⟨⟩
    2*ₙ2*ₙ (ℕ.suc (toℕ (x + (y + xy))))      ≡⟨ cong (2*ₙ2*ₙ ∘ ℕ.suc) (toℕ-homo-+ x (y + xy)) ⟩
    2*ₙ2*ₙ (ℕ.suc (m ℕ.+ (toℕ (y + xy))))    ≡⟨ cong (2*ₙ2*ₙ ∘ ℕ.suc ∘ (m ℕ.+_)) (toℕ-homo-+ y xy) ⟩
    2*ₙ2*ₙ (ℕ.suc (m ℕ.+ (n ℕ.+ toℕ xy)))    ≡⟨ cong (2*ₙ2*ₙ ∘ ℕ.suc ∘ (m ℕ.+_) ∘ (n ℕ.+_))
                                                  (aux x y cnt |x|+|y|≤cnt) ⟩
    2*ₙ2*ₙ (ℕ.suc (m ℕ.+ (n ℕ.+ (m ℕ.* n)))) ≡⟨ solve 2 (λ m n → con 2 :* (con 2 :* (con 1 :+ (m :+ (n :+ m :* n)))) :=
                                                  (con 2 :* (con 1 :+ m)) :* (con 2 :* (con 1 :+ n)))
                                                  refl m n ⟩
    (2 ℕ.* (1 ℕ.+ m)) ℕ.* (2 ℕ.* (1 ℕ.+ n))  ≡⟨⟩
    toℕ 2[1+ x ] ℕ.* toℕ 2[1+ y ]            ∎
    where
    open ≡-Reasoning;  m = toℕ x;  n = toℕ y;  xy = x * y

    |x|+|y|≤cnt = ℕₚ.≤-trans (ℕₚ.+-monoʳ-≤ (size x) (ℕₚ.n≤1+n (size y))) |x|+1+|y|≤cnt

  aux 2[1+ x ] 1+[2 y ] (ℕ.suc cnt) (s≤s |x|+1+|y|≤cnt) = begin
    toℕ (2[1+ x ] * 1+[2 y ])                  ≡⟨⟩
    toℕ (2[1+ (x + y * 2[1+ x ]) ])            ≡⟨⟩
    2 ℕ.* (ℕ.suc (toℕ (x + y * 2[1+ x ])))     ≡⟨ cong ((2 ℕ.*_) ∘ ℕ.suc) (toℕ-homo-+ x _) ⟩
    2 ℕ.* (ℕ.suc (m ℕ.+ (toℕ (y * 2[1+ x ])))) ≡⟨ cong ((2 ℕ.*_) ∘ ℕ.suc ∘ (m ℕ.+_))
                                                    (aux y 2[1+ x ] cnt |y|+1+|x|≤cnt) ⟩
    2 ℕ.* (1+m ℕ.+ (n ℕ.* (toℕ 2[1+ x ])))     ≡⟨⟩
    2 ℕ.* (1+m ℕ.+ (n ℕ.* 2[1+m]))             ≡⟨ solve 2 (λ m n →
                                                    con 2 :* ((con 1 :+ m) :+ (n :* (con 2 :* (con 1 :+ m)))) :=
                                                    (con 2 :* (con 1 :+ m)) :* (con 1 :+ con 2 :* n))
                                                    refl m n ⟩
    2[1+m] ℕ.* (ℕ.suc (2 ℕ.* n))               ≡⟨⟩
    toℕ 2[1+ x ] ℕ.* toℕ 1+[2 y ]              ∎
    where
    open ≡-Reasoning;   m = toℕ x;  n = toℕ y;  1+m = ℕ.suc m;  2[1+m] = 2 ℕ.* (ℕ.suc m)

    eq : size x ℕ.+ (ℕ.suc (size y)) ≡ size y ℕ.+ (ℕ.suc (size x))
    eq = ℕ-+-semigroupProperties.x∙yz≈z∙yx (size x) 1 _

    |y|+1+|x|≤cnt =  subst (ℕ._≤ cnt) eq |x|+1+|y|≤cnt

  aux 1+[2 x ] 2[1+ y ] (ℕ.suc cnt) (s≤s |x|+1+|y|≤cnt) = begin
    toℕ (1+[2 x ] * 2[1+ y ])                  ≡⟨⟩
    toℕ 2[1+ (y + x * 2[1+ y ]) ]              ≡⟨⟩
    2 ℕ.* (ℕ.suc (toℕ (y + x * 2[1+ y ])))     ≡⟨ cong ((2 ℕ.*_) ∘ ℕ.suc)
                                                    (toℕ-homo-+ y (x * 2[1+ y ])) ⟩
    2 ℕ.* (ℕ.suc (n ℕ.+ (toℕ (x * 2[1+ y ])))) ≡⟨ cong ((2 ℕ.*_) ∘ ℕ.suc ∘ (n ℕ.+_))
                                                    (aux x 2[1+ y ] cnt |x|+1+|y|≤cnt) ⟩
    2 ℕ.* (1+n ℕ.+ (m ℕ.* toℕ 2[1+ y ]))       ≡⟨⟩
    2 ℕ.* (1+n ℕ.+ (m ℕ.* 2[1+n]))             ≡⟨ solve 2 (λ m n →
                                                    con 2 :* ((con 1 :+ n) :+ (m :* (con 2 :* (con 1 :+ n)))) :=
                                                    (con 1 :+ (con 2 :* m)) :* (con 2 :* (con 1 :+ n)))
                                                    refl m n ⟩
    (ℕ.suc 2m) ℕ.* 2[1+n]                      ≡⟨⟩
    toℕ 1+[2 x ] ℕ.* toℕ 2[1+ y ]              ∎
    where
    open ≡-Reasoning
    m  = toℕ x;     n      = toℕ y;            1+n = ℕ.suc n
    2m = 2 ℕ.* m;   2[1+n] = 2 ℕ.* (ℕ.suc n)

  aux 1+[2 x ] 1+[2 y ] (ℕ.suc cnt) (s≤s |x|+1+|y|≤cnt) = begin
    toℕ (1+[2 x ] * 1+[2 y ])               ≡⟨⟩
    toℕ 1+[2 (x + y * 1+2x) ]               ≡⟨⟩
    ℕ.suc (2 ℕ.* (toℕ (x + y * 1+2x)))      ≡⟨ cong (ℕ.suc ∘ (2 ℕ.*_)) (toℕ-homo-+ x (y * 1+2x)) ⟩
    ℕ.suc (2 ℕ.* (m ℕ.+ (toℕ (y * 1+2x))))  ≡⟨ cong (ℕ.suc ∘ (2 ℕ.*_) ∘ (m ℕ.+_))
                                                 (aux y 1+2x cnt |y|+1+|x|≤cnt) ⟩
    ℕ.suc (2 ℕ.* (m ℕ.+ (n ℕ.* [1+2x]')))   ≡⟨ cong ℕ.suc $ ℕₚ.*-distribˡ-+ 2 m (n ℕ.* [1+2x]') ⟩
    ℕ.suc (2m ℕ.+ (2 ℕ.* (n ℕ.* [1+2x]')))  ≡⟨ cong (ℕ.suc ∘ (2m ℕ.+_)) (sym (ℕₚ.*-assoc 2 n _)) ⟩
    (ℕ.suc 2m) ℕ.+ 2n ℕ.* [1+2x]'           ≡⟨⟩
    [1+2x]' ℕ.+ 2n ℕ.* [1+2x]'              ≡⟨ cong (ℕ._+ (2n ℕ.* [1+2x]')) $
                                                    sym (ℕₚ.*-identityˡ [1+2x]') ⟩
    1 ℕ.* [1+2x]' ℕ.+ 2n ℕ.* [1+2x]'        ≡⟨ sym (ℕₚ.*-distribʳ-+ [1+2x]' 1 2n) ⟩
    (ℕ.suc 2n) ℕ.* [1+2x]'                  ≡⟨ ℕₚ.*-comm (ℕ.suc 2n) [1+2x]' ⟩
    toℕ 1+[2 x ] ℕ.* toℕ 1+[2 y ]           ∎
    where
    open ≡-Reasoning
    m    = toℕ x;      n       = toℕ y;     2m = 2 ℕ.* m;    2n = 2 ℕ.* n
    1+2x = 1+[2 x ];   [1+2x]' = toℕ 1+2x

    eq : size x ℕ.+ (ℕ.suc (size y)) ≡ size y ℕ.+ (ℕ.suc (size x))
    eq = ℕ-+-semigroupProperties.x∙yz≈z∙yx (size x) 1 _

    |y|+1+|x|≤cnt = subst (ℕ._≤ cnt) eq |x|+1+|y|≤cnt

toℕ-isMagmaHomomorphism-* : IsMagmaHomomorphism *-rawMagma ℕₚ.*-rawMagma toℕ
toℕ-isMagmaHomomorphism-* = record
  { isRelHomomorphism = toℕ-isRelHomomorphism
  ; homo              = toℕ-homo-*
  }

toℕ-isMonoidHomomorphism-* : IsMonoidHomomorphism *-1-rawMonoid ℕₚ.*-1-rawMonoid toℕ
toℕ-isMonoidHomomorphism-* = record
  { isMagmaHomomorphism = toℕ-isMagmaHomomorphism-*
  ; ε-homo              = refl
  }

toℕ-isMonoidMonomorphism-* : IsMonoidMonomorphism *-1-rawMonoid ℕₚ.*-1-rawMonoid toℕ
toℕ-isMonoidMonomorphism-* = record
  { isMonoidHomomorphism = toℕ-isMonoidHomomorphism-*
  ; injective            = toℕ-injective
  }

fromℕ-homo-* : ∀ m n → fromℕ (m ℕ.* n) ≡ fromℕ m * fromℕ n
fromℕ-homo-* m n = begin
  fromℕ (m ℕ.* n)           ≡⟨ cong fromℕ (cong₂ ℕ._*_ m≡aN n≡bN) ⟩
  fromℕ (toℕ a ℕ.* toℕ b)   ≡⟨ cong fromℕ (sym (toℕ-homo-* a b)) ⟩
  fromℕ (toℕ (a * b))       ≡⟨ fromℕ-toℕ (a * b) ⟩
  a * b                     ∎
  where
  open ≡-Reasoning
  a    = fromℕ m;             b    = fromℕ n
  m≡aN = sym (toℕ-fromℕ m);   n≡bN = sym (toℕ-fromℕ n)

private
  module *-Monomorphism = MonoidMonomorphism toℕ-isMonoidMonomorphism-*

------------------------------------------------------------------------
-- Algebraic properties of _*_

-- Mostly proved by using the isomorphism between `ℕ` and `ℕᵇ` provided
-- by `toℕ`/`fromℕ`.

*-assoc : Associative _*_
*-assoc = *-Monomorphism.assoc ℕₚ.*-isMagma ℕₚ.*-assoc

*-comm : Commutative _*_
*-comm = *-Monomorphism.comm ℕₚ.*-isMagma ℕₚ.*-comm

*-identityˡ : LeftIdentity 1ᵇ _*_
*-identityˡ = *-Monomorphism.identityˡ ℕₚ.*-isMagma ℕₚ.*-identityˡ

*-identityʳ : RightIdentity 1ᵇ _*_
*-identityʳ x =  trans (*-comm x 1ᵇ) (*-identityˡ x)

*-identity : Identity 1ᵇ _*_
*-identity = (*-identityˡ , *-identityʳ)

*-zeroˡ : LeftZero zero _*_
*-zeroˡ _ = refl

*-zeroʳ : RightZero zero _*_
*-zeroʳ zero     = refl
*-zeroʳ 2[1+ _ ] = refl
*-zeroʳ 1+[2 _ ] = refl

*-zero : Zero zero _*_
*-zero = *-zeroˡ , *-zeroʳ

*-distribˡ-+ : _*_ DistributesOverˡ _+_
*-distribˡ-+ a b c = begin
  a * (b + c)                          ≡⟨ sym (fromℕ-toℕ (a * (b + c))) ⟩
  fromℕ (toℕ (a * (b + c)))            ≡⟨ cong fromℕ (toℕ-homo-* a (b + c)) ⟩
  fromℕ (k ℕ.* (toℕ (b + c)))          ≡⟨ cong (fromℕ ∘ (k ℕ.*_)) (toℕ-homo-+ b c) ⟩
  fromℕ (k ℕ.* (m ℕ.+ n))              ≡⟨ cong fromℕ (ℕₚ.*-distribˡ-+ k m n) ⟩
  fromℕ (k ℕ.* m ℕ.+ k ℕ.* n)          ≡⟨ cong fromℕ $ sym $
                                            cong₂ ℕ._+_ (toℕ-homo-* a b) (toℕ-homo-* a c) ⟩
  fromℕ (toℕ (a * b) ℕ.+ toℕ (a * c))  ≡⟨ cong fromℕ (sym (toℕ-homo-+ (a * b) (a * c))) ⟩
  fromℕ (toℕ (a * b + a * c))          ≡⟨ fromℕ-toℕ (a * b + a * c) ⟩
  a * b + a * c                        ∎
  where open ≡-Reasoning;  k = toℕ a;  m = toℕ b;  n = toℕ c

*-distribʳ-+ : _*_ DistributesOverʳ _+_
*-distribʳ-+ = comm+distrˡ⇒distrʳ *-comm *-distribˡ-+

*-distrib-+ : _*_ DistributesOver _+_
*-distrib-+ = *-distribˡ-+ , *-distribʳ-+

------------------------------------------------------------------------
-- Structures

*-isMagma : IsMagma _*_
*-isMagma = isMagma _*_

*-isSemigroup : IsSemigroup _*_
*-isSemigroup = *-Monomorphism.isSemigroup ℕₚ.*-isSemigroup

*-1-isMonoid : IsMonoid _*_ 1ᵇ
*-1-isMonoid = *-Monomorphism.isMonoid ℕₚ.*-1-isMonoid

*-1-isCommutativeMonoid : IsCommutativeMonoid _*_ 1ᵇ
*-1-isCommutativeMonoid = *-Monomorphism.isCommutativeMonoid ℕₚ.*-1-isCommutativeMonoid

*-+-isSemiringWithoutAnnihilatingZero : IsSemiringWithoutAnnihilatingZero _+_ _*_ zero 1ᵇ
*-+-isSemiringWithoutAnnihilatingZero = record
  { +-isCommutativeMonoid = +-0-isCommutativeMonoid
  ; *-isMonoid            = *-1-isMonoid
  ; distrib               = *-distrib-+
  }

*-+-isSemiring : IsSemiring _+_ _*_ zero 1ᵇ
*-+-isSemiring = record
  { isSemiringWithoutAnnihilatingZero = *-+-isSemiringWithoutAnnihilatingZero
  ; zero                              = *-zero
  }

*-+-isCommutativeSemiring : IsCommutativeSemiring _+_ _*_ zero 1ᵇ
*-+-isCommutativeSemiring = record
  { isSemiring = *-+-isSemiring
  ; *-comm = *-comm
  }

------------------------------------------------------------------------
-- Bundles

*-magma : Magma 0ℓ 0ℓ
*-magma = record
  { isMagma = *-isMagma
  }

*-semigroup : Semigroup 0ℓ 0ℓ
*-semigroup = record
  { isSemigroup = *-isSemigroup
  }

*-1-monoid : Monoid 0ℓ 0ℓ
*-1-monoid = record
  { isMonoid = *-1-isMonoid
  }

*-1-commutativeMonoid : CommutativeMonoid 0ℓ 0ℓ
*-1-commutativeMonoid = record
  { isCommutativeMonoid = *-1-isCommutativeMonoid
  }

*-+-semiring : Semiring 0ℓ 0ℓ
*-+-semiring = record
  { isSemiring = *-+-isSemiring
  }

*-+-commutativeSemiring : CommutativeSemiring 0ℓ 0ℓ
*-+-commutativeSemiring = record
  { isCommutativeSemiring = *-+-isCommutativeSemiring
  }

------------------------------------------------------------------------
-- Properties of _*_ and _≤_ & _<_

*-mono-≤ : _*_ Preserves₂ _≤_ ⟶ _≤_ ⟶ _≤_
*-mono-≤ {x} {u} {y} {v} x≤u y≤v = toℕ-cancel-≤ (begin
  toℕ (x * y)     ≡⟨ toℕ-homo-* x y ⟩
  toℕ x ℕ.* toℕ y ≤⟨ ℕₚ.*-mono-≤ (toℕ-mono-≤ x≤u) (toℕ-mono-≤ y≤v) ⟩
  toℕ u ℕ.* toℕ v ≡⟨ sym (toℕ-homo-* u v) ⟩
  toℕ (u * v)     ∎)
  where open ℕₚ.≤-Reasoning

*-monoʳ-≤ : ∀ x → (x *_) Preserves _≤_ ⟶ _≤_
*-monoʳ-≤ x y≤y' = *-mono-≤ (≤-refl {x}) y≤y'

*-monoˡ-≤ : ∀ x → (_* x) Preserves _≤_ ⟶ _≤_
*-monoˡ-≤ x y≤y' = *-mono-≤ y≤y' (≤-refl {x})

*-mono-< : _*_ Preserves₂ _<_ ⟶ _<_ ⟶ _<_
*-mono-< {x} {u} {y} {v} x<u y<v = toℕ-cancel-< (begin-strict
  toℕ (x * y)     ≡⟨ toℕ-homo-* x y ⟩
  toℕ x ℕ.* toℕ y <⟨ ℕₚ.*-mono-< (toℕ-mono-< x<u) (toℕ-mono-< y<v) ⟩
  toℕ u ℕ.* toℕ v ≡⟨ sym (toℕ-homo-* u v) ⟩
  toℕ (u * v)     ∎)
  where open ℕₚ.≤-Reasoning

*-monoʳ-< : ∀ x → ((1ᵇ + x) *_) Preserves _<_ ⟶ _<_
*-monoʳ-< x {y} {z} y<z = begin-strict
  (1ᵇ + x) * y    ≡⟨ *-distribʳ-+ y 1ᵇ x ⟩
  1ᵇ * y + x * y  ≡⟨ cong (_+ x * y) (*-identityˡ y) ⟩
  y      + x * y  <⟨ +-mono-<-≤ y<z (*-monoʳ-≤ x (<⇒≤ y<z)) ⟩
  z      + x * z  ≡⟨ cong (_+ x * z) (sym (*-identityˡ z)) ⟩
  1ᵇ * z + x * z  ≡⟨ sym (*-distribʳ-+ z 1ᵇ x) ⟩
  (1ᵇ + x) * z    ∎
  where open ≤-Reasoning

*-monoˡ-< : ∀ x → (_* (1ᵇ + x)) Preserves _<_ ⟶ _<_
*-monoˡ-< x {y} {z} y<z = begin-strict
  y * (1ᵇ + x)   ≡⟨ *-comm y (1ᵇ + x) ⟩
  (1ᵇ + x) * y   <⟨ *-monoʳ-< x y<z ⟩
  (1ᵇ + x) * z   ≡⟨ *-comm (1ᵇ + x) z ⟩
  z * (1ᵇ + x)   ∎
  where open ≤-Reasoning

------------------------------------------------------------------------
-- Other properties of _*_

x*y≡0⇒x≡0∨y≡0 : ∀ x {y} → x * y ≡ zero → x ≡ zero ⊎ y ≡ zero
x*y≡0⇒x≡0∨y≡0 zero {_}    _ =  inj₁ refl
x*y≡0⇒x≡0∨y≡0 _    {zero} _ =  inj₂ refl

x≢0∧y≢0⇒x*y≢0 : ∀ {x y} → x ≢ zero → y ≢ zero → x * y ≢ zero
x≢0∧y≢0⇒x*y≢0 {x} {_} x≢0 y≢0 xy≡0  with x*y≡0⇒x≡0∨y≡0 x xy≡0
... | inj₁ x≡0 =  x≢0 x≡0
... | inj₂ y≡0 =  y≢0 y≡0

2*x≡x+x : ∀ x → 2ᵇ * x ≡ x + x
2*x≡x+x x = begin
  2ᵇ * x            ≡⟨⟩
  (1ᵇ + 1ᵇ) * x     ≡⟨ *-distribʳ-+ x 1ᵇ 1ᵇ ⟩
  1ᵇ * x + 1ᵇ * x   ≡⟨ cong₂ _+_ (*-identityˡ x) (*-identityˡ x) ⟩
  x + x             ∎
  where open ≡-Reasoning

1+-* : ∀ x y → (1ᵇ + x) * y ≡ y + x * y
1+-* x y = begin
  (1ᵇ + x) * y     ≡⟨ *-distribʳ-+ y 1ᵇ x ⟩
  1ᵇ * y + x * y   ≡⟨ cong (_+ x * y) (*-identityˡ y) ⟩
  y + x * y        ∎
  where open ≡-Reasoning

*-1+ : ∀ x y → y * (1ᵇ + x) ≡ y + y * x
*-1+ x y = begin
  y * (1ᵇ + x)     ≡⟨ *-distribˡ-+ y 1ᵇ x ⟩
  y * 1ᵇ + y * x   ≡⟨ cong (_+ y * x) (*-identityʳ y) ⟩
  y + y * x        ∎
  where open ≡-Reasoning

------------------------------------------------------------------------
-- Properties of double
------------------------------------------------------------------------

double[x]≡0⇒x≡0 : ∀ {x} → double x ≡ zero → x ≡ zero
double[x]≡0⇒x≡0 {zero} _ = refl

x≢0⇒double[x]≢0 : ∀ {x} → x ≢ zero → double x ≢ zero
x≢0⇒double[x]≢0 x≢0 = x≢0 ∘ double[x]≡0⇒x≡0

double≢1 : ∀ {x} → double x ≢ 1ᵇ
double≢1 {zero} ()

double≗2* : double ≗ 2ᵇ *_
double≗2* x =  toℕ-injective $ begin
  toℕ (double x)  ≡⟨ toℕ-double x ⟩
  2 ℕ.* (toℕ x)   ≡⟨ sym (toℕ-homo-* 2ᵇ x) ⟩
  toℕ (2ᵇ * x)    ∎
  where open ≡-Reasoning

double-*-assoc : ∀ x y → (double x) * y ≡ double (x * y)
double-*-assoc x y = begin
  (double x) * y     ≡⟨ cong (_* y) (double≗2* x) ⟩
  (2ᵇ * x) * y       ≡⟨ *-assoc 2ᵇ x y ⟩
  2ᵇ * (x * y)       ≡⟨ sym (double≗2* (x * y)) ⟩
  double (x * y)     ∎
  where open ≡-Reasoning

double[x]≡x+x : ∀ x → double x ≡ x + x
double[x]≡x+x x =  trans (double≗2* x) (2*x≡x+x x)

double-distrib-+ : ∀ x y → double (x + y) ≡ double x + double y
double-distrib-+ x y = begin
  double (x + y)         ≡⟨ double≗2* (x + y) ⟩
  2ᵇ * (x + y)           ≡⟨ *-distribˡ-+ 2ᵇ x y ⟩
  (2ᵇ * x) + (2ᵇ * y)    ≡⟨ sym (cong₂ _+_ (double≗2* x) (double≗2* y)) ⟩
  double x + double y    ∎
  where open ≡-Reasoning

double-mono-≤ : double Preserves _≤_ ⟶ _≤_
double-mono-≤ {x} {y} x≤y =  begin
  double x   ≡⟨ double≗2* x ⟩
  2ᵇ * x     ≤⟨ *-monoʳ-≤ 2ᵇ x≤y ⟩
  2ᵇ * y     ≡⟨ sym (double≗2* y) ⟩
  double y   ∎
  where open ≤-Reasoning

double-mono-< : double Preserves _<_ ⟶ _<_
double-mono-< {x} {y} x<y =  begin-strict
  double x   ≡⟨ double≗2* x ⟩
  2ᵇ * x     <⟨ *-monoʳ-< 1ᵇ x<y ⟩
  2ᵇ * y     ≡⟨ sym (double≗2* y) ⟩
  double y   ∎
  where open ≤-Reasoning

double-cancel-≤ : ∀ {x y} → double x ≤ double y → x ≤ y
double-cancel-≤ {x} {y} 2x≤2y  with <-cmp x y
... | tri< x<y _   _   =  <⇒≤ x<y
... | tri≈ _   x≡y _   =  ≤-reflexive x≡y
... | tri> _   _   x>y =  contradiction 2x≤2y (<⇒≱ (double-mono-< x>y))

double-cancel-< : ∀ {x y} → double x < double y → x < y
double-cancel-< {x} {y} 2x<2y  with <-cmp x y
... | tri< x<y _    _   =  x<y
... | tri≈ _   refl _   =  contradiction 2x<2y (<-irrefl refl)
... | tri> _   _    x>y =  contradiction (double-mono-< x>y) (<⇒≯ 2x<2y)

x<double[x] : ∀ x → x ≢ zero → x < double x
x<double[x] x x≢0 = begin-strict
  x                 <⟨ x<x+y x (x≢0⇒x>0 x≢0) ⟩
  x + x             ≡⟨ sym (double[x]≡x+x x) ⟩
  double x          ∎
  where open ≤-Reasoning

x≤double[x] : ∀ x → x ≤ double x
x≤double[x] x =  begin
  x         ≤⟨ x≤x+y x x ⟩
  x + x     ≡⟨ sym (double[x]≡x+x x) ⟩
  double x  ∎
  where open ≤-Reasoning

------------------------------------------------------------------------
-- Properties of suc
------------------------------------------------------------------------

2[1+_]-double-suc : 2[1+_] ≗ double ∘ suc
2[1+_]-double-suc zero     = refl
2[1+_]-double-suc 2[1+ x ] = cong 2[1+_] (2[1+_]-double-suc x)
2[1+_]-double-suc 1+[2 x ] = refl

1+[2_]-suc-double : 1+[2_] ≗ suc ∘ double
1+[2_]-suc-double zero     = refl
1+[2_]-suc-double 2[1+ x ] = refl
1+[2_]-suc-double 1+[2 x ] = begin
  1+[2 1+[2 x ] ]         ≡⟨ cong 1+[2_] (1+[2_]-suc-double x) ⟩
  1+[2 (suc 2x) ]         ≡⟨⟩
  suc 2[1+ 2x ]           ≡⟨ cong suc (2[1+_]-double-suc 2x) ⟩
  suc (double (suc 2x))   ≡⟨ cong (suc ∘ double) (sym (1+[2_]-suc-double x)) ⟩
  suc (double 1+[2 x ])   ∎
  where open ≡-Reasoning;  2x = double x

suc≢0 : ∀ {x} → suc x ≢ zero
suc≢0 {zero}     ()
suc≢0 {2[1+ _ ]} ()
suc≢0 {1+[2 _ ]} ()

0<suc : ∀ x → zero < suc x
0<suc x =  x≢0⇒x>0 (suc≢0 {x})

x<suc[x] : ∀ x → x < suc x
x<suc[x] x =  begin-strict
  x        <⟨ x<1+x x ⟩
  1ᵇ + x   ≡⟨ sym (suc≗1+ x) ⟩
  suc x    ∎
  where open ≤-Reasoning

x≤suc[x] : ∀ x → x ≤ suc x
x≤suc[x] x = <⇒≤ (x<suc[x] x)

x≢suc[x] : ∀ x → x ≢ suc x
x≢suc[x] x = <⇒≢ (x<suc[x] x)

suc-mono-≤ : suc Preserves _≤_ ⟶ _≤_
suc-mono-≤ {x} {y} x≤y =  begin
  suc x     ≡⟨ suc≗1+ x ⟩
  1ᵇ + x    ≤⟨ +-monoʳ-≤ 1ᵇ x≤y ⟩
  1ᵇ + y    ≡⟨ sym (suc≗1+ y) ⟩
  suc y     ∎
  where open ≤-Reasoning

suc[x]≤y⇒x<y : ∀ {x y} → suc x ≤ y → x < y
suc[x]≤y⇒x<y {x} (inj₁ sx<y) = <-trans (x<suc[x] x) sx<y
suc[x]≤y⇒x<y {x} (inj₂ refl) = x<suc[x] x

x<y⇒suc[x]≤y : ∀ {x y} → x < y → suc x ≤ y
x<y⇒suc[x]≤y {x} {y} x<y =  begin
  suc x                  ≡⟨ sym (fromℕ-toℕ (suc x)) ⟩
  fromℕ (toℕ (suc x))    ≡⟨ cong fromℕ (toℕ-suc x) ⟩
  fromℕ (ℕ.suc (toℕ x))  ≤⟨ fromℕ-mono-≤ (toℕ-mono-< x<y) ⟩
  fromℕ (toℕ y)          ≡⟨ fromℕ-toℕ y ⟩
  y                      ∎
  where open ≤-Reasoning

suc-* : ∀ x y → suc x * y ≡ y + x * y
suc-* x y = begin
  suc x * y     ≡⟨ cong (_* y) (suc≗1+ x) ⟩
  (1ᵇ + x) * y  ≡⟨ 1+-* x y ⟩
  y + x * y     ∎
  where open ≡-Reasoning

*-suc : ∀ x y → x * suc y ≡ x + x * y
*-suc x y = begin
  x * suc y    ≡⟨ cong (x *_) (suc≗1+ y) ⟩
  x * (1ᵇ + y) ≡⟨ *-1+ y x ⟩
  x + x * y    ∎
  where open ≡-Reasoning

x≤suc[y]*x : ∀ x y → x ≤ (suc y) * x
x≤suc[y]*x x y =  begin
  x             ≤⟨ x≤x+y x (y * x) ⟩
  x + y * x     ≡⟨ sym (suc-* y x) ⟩
  (suc y) * x   ∎
  where open ≤-Reasoning

suc[x]≤double[x] : ∀ x → x ≢ zero → suc x ≤ double x
suc[x]≤double[x] x =  x<y⇒suc[x]≤y {x} {double x} ∘ x<double[x] x

suc[x]<2[1+x] : ∀ x → suc x < 2[1+ x ]
suc[x]<2[1+x] x =  begin-strict
  suc x           <⟨ x<double[x] (suc x) suc≢0  ⟩
  double (suc x)  ≡⟨ sym (2[1+_]-double-suc x) ⟩
  2[1+ x ]        ∎
  where open ≤-Reasoning

double[x]<1+[2x] : ∀ x → double x < 1+[2 x ]
double[x]<1+[2x] x =  begin-strict
  double x         <⟨ x<suc[x] (double x) ⟩
  suc (double x)   ≡⟨ sym (1+[2_]-suc-double x) ⟩
  1+[2 x ]         ∎
  where open ≤-Reasoning

------------------------------------------------------------------------
-- Properties of pred
------------------------------------------------------------------------

pred-suc : pred ∘ suc ≗ id
pred-suc zero     =  refl
pred-suc 2[1+ x ] =  sym (2[1+_]-double-suc x)
pred-suc 1+[2 x ] =  refl

suc-pred : ∀ {x} → x ≢ zero → suc (pred x) ≡ x
suc-pred {zero}     0≢0 =  contradiction refl 0≢0
suc-pred {2[1+ _ ]} _   =  refl
suc-pred {1+[2 x ]} _   =  sym (1+[2_]-suc-double x)

pred-mono-≤ : pred Preserves _≤_ ⟶ _≤_
pred-mono-≤ {x} {y} x≤y =  begin
  pred x             ≡⟨ cong pred (sym (fromℕ-toℕ x)) ⟩
  pred (fromℕ m)     ≡⟨ sym (fromℕ-pred m) ⟩
  fromℕ (ℕ.pred m)   ≤⟨ fromℕ-mono-≤ (ℕₚ.pred-mono (toℕ-mono-≤ x≤y)) ⟩
  fromℕ (ℕ.pred n)   ≡⟨ fromℕ-pred n ⟩
  pred (fromℕ n)     ≡⟨ cong pred (fromℕ-toℕ y) ⟩
  pred y             ∎
  where
  open ≤-Reasoning;  m = toℕ x;  n = toℕ y

pred[x]<x : ∀ {x} → x ≢ zero → pred x < x
pred[x]<x {x} x≢0 =  begin-strict
  pred x       <⟨ x<suc[x] (pred x) ⟩
  suc (pred x) ≡⟨ suc-pred x≢0 ⟩
  x            ∎
  where open ≤-Reasoning

------------------------------------------------------------------------
-- Properties of size
------------------------------------------------------------------------

|x|≡0⇒x≡0 : ∀ {x} → size x ≡ 0 → x ≡ 0ᵇ
|x|≡0⇒x≡0 {zero} refl =  refl


postulate
  f : {A B : Set₁} (C : Set) → A → B → C

module _ (A B C : Set) where
  test : (X : Set) → Set → Set → X
  test = f { A₁ = Set } { B₁ = Set }


module Main where

import univ
import cwf
import help
import proofs


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

open import Base
open import Homotopy.Truncation
open import Integers

-- Formalization of 0-truncated groups
module Algebra.Groups where

-- A pregroup is a group whose carrier is not a required to be a set (but
-- without higher coherences)

record pregroup i : Set (suc i) where
  -- constructor pregroup
  field
    -- Stuff
    carrier : Set i  -- \|

    -- Structure
    _∙_ : carrier → carrier → carrier  -- \.
    e : carrier
    _′ : carrier → carrier  -- \'

    -- Properties
    assoc : ∀ x y z → (x ∙ y) ∙ z ≡ x ∙ (y ∙ z)
    right-unit : ∀ x → x ∙ e ≡ x
    left-unit : ∀ x → e ∙ x ≡ x
    right-inverse : ∀ x → x ∙ (x ′) ≡ e
    left-inverse : ∀ x → (x ′) ∙ x ≡ e

record group i : Set (suc i) where
  -- constructor group
  field
    pre : pregroup i
  open pregroup pre
  field
    set : is-set carrier
  open pregroup pre public

-- Group structure on [unit]
unit-group : ∀ {i} → group i
unit-group {i} = record
  { pre = record
    { carrier = unit
    ; _∙_ = λ _ _ → tt
    ; e = tt
    ; _′ = λ _ → tt
    ; assoc = λ _ _ _ → refl
    ; right-unit = λ _ → refl
    ; left-unit = λ _ → refl
    ; right-inverse = λ _ → refl
    ; left-inverse = λ _ → refl
    }
  ; set = unit-is-set
  }

postulate  -- Tedious because I have a terrible definition of groups
  unit-group-unique : ∀ {i} (G : group i) →
    let open group G in (c : is-contr carrier) → G ≡ unit-group

-- Every pregroup can be truncated to a group
π₀-pregroup : ∀ {i} → pregroup i → group i
π₀-pregroup pre = record
  { pre = record
    { carrier = carrier₀
    ; _∙_ = _•₀_
    ; e = e₀
    ; _′ = _′₀
    ; assoc = assoc₀
    ; right-unit = right-unit₀
    ; left-unit = left-unit₀
    ; right-inverse = right-inverse₀
    ; left-inverse = left-inverse₀
    }
  ; set = carrier₀-is-set
  } where

    open pregroup pre

    carrier₀ : Set _
    carrier₀ = π₀ carrier

    carrier₀-is-set : is-set carrier₀
    carrier₀-is-set = π₀-is-set carrier

    _•₀_ : carrier₀ → carrier₀ → carrier₀
    _•₀_ = π₀-extend-nondep ⦃ →-is-set $ carrier₀-is-set ⦄
              (λ x → π₀-extend-nondep ⦃ carrier₀-is-set ⦄
                (λ y → proj (x ∙ y)))

    e₀ : π₀ carrier
    e₀ = proj e

    _′₀ : carrier₀ → carrier₀
    _′₀ = π₀-extend-nondep ⦃ carrier₀-is-set ⦄ (λ x → proj (x ′))

    abstract
      assoc₀ : ∀ x y z → (x •₀ y) •₀ z ≡ x •₀ (y •₀ z)
      assoc₀ =
        (π₀-extend ⦃ λ _ → Π-is-set λ _ → Π-is-set λ _ → ≡-is-set carrier₀-is-set ⦄
          (λ x → π₀-extend ⦃ λ _ → Π-is-set λ _ → ≡-is-set carrier₀-is-set ⦄
            (λ y → π₀-extend ⦃ λ _ → ≡-is-set carrier₀-is-set ⦄
              (λ z → ap proj (assoc x y z)))))

    abstract
      right-unit₀ : ∀ x → x •₀ e₀ ≡ x
      right-unit₀ =
        (π₀-extend ⦃ λ _ → ≡-is-set carrier₀-is-set ⦄
          (ap proj ◯ right-unit))

    abstract
      left-unit₀ : ∀ x → e₀ •₀ x ≡ x
      left-unit₀ =
        (π₀-extend ⦃ λ _ → ≡-is-set carrier₀-is-set ⦄
          (ap proj ◯ left-unit))

    abstract
      right-inverse₀ : ∀ x → x •₀ (x ′₀) ≡ e₀
      right-inverse₀ =
        (π₀-extend ⦃ λ _ → ≡-is-set carrier₀-is-set ⦄
          (ap proj ◯ right-inverse))

    abstract
      left-inverse₀ : ∀ x → (x ′₀) •₀ x ≡ e₀
      left-inverse₀ =
        (π₀-extend ⦃ λ _ → ≡-is-set carrier₀-is-set ⦄
          (ap proj ◯ left-inverse))

-- Not used

-- is-group-morphism : ∀ {i j} (A : Group i) (B : Group j)
-- (f : ∣ g A ∣ → ∣ g B ∣)
--   → Set (max i j)
-- is-group-morphism A B f =
--   (x y : ∣ g A ∣) → f (_∙_ (g A) x y) ≡ _∙_ (g B) (f x) (f y)

-- _≈_ : ∀ {i j} (A : Group i) (B : Group j) → Set (max i j)
-- A ≈ B = Σ (∣ g A ∣ → ∣ g B ∣) (λ f → is-equiv f × is-group-morphism A B f)


{-# OPTIONS --universe-polymorphism #-}

module Issue248 where

open import Common.Level

data ⊥ : Set where

-- This type checks:

Foo : ⊥ → (l : Level) → Set
Foo x l with x
Foo x l | ()

-- This didn't (but now it does):

Bar : ⊥ → (l : Level) → Set l → Set
Bar x l A with x
Bar x l A | ()

-- Bug.agda:25,1-15
-- ⊥ !=< Level of type Set
-- when checking that the expression w has type Level


------------------------------------------------------------------------
-- The syntax of the untyped λ-calculus
------------------------------------------------------------------------

{-# OPTIONS --safe #-}

module Lambda.Simplified.Syntax where

open import Equality.Propositional
open import Prelude

open import Vec.Function equality-with-J

------------------------------------------------------------------------
-- Terms

-- Variables are represented using de Bruijn indices.

infixl 9 _·_

data Tm (n : ℕ) : Type where
  var : (x : Fin n) → Tm n
  ƛ   : Tm (suc n) → Tm n
  _·_ : Tm n → Tm n → Tm n

------------------------------------------------------------------------
-- Closure-based definition of values

-- Environments and values. Defined in a module parametrised by the
-- type of terms.

module Closure (Tm : ℕ → Type) where

  mutual

    -- Environments.

    Env : ℕ → Type
    Env n = Vec Value n

    -- Values. Lambdas are represented using closures, so values do
    -- not contain any free variables.

    data Value : Type where
      ƛ : ∀ {n} (t : Tm (suc n)) (ρ : Env n) → Value

------------------------------------------------------------------------
-- Examples

-- A non-terminating term.

ω : Tm 0
ω = ƛ (var fzero · var fzero)

Ω : Tm 0
Ω = ω · ω

-- A call-by-value fixpoint combinator.

Z : Tm 0
Z = ƛ (t · t)
  where
  t = ƛ (var (fsuc fzero) ·
         ƛ (var (fsuc fzero) · var (fsuc fzero) · var fzero))


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

module old.Sharp where

  open import Basics
  open import Flat

  open import lib.Equivalence2

  {- I want sthing like this
  record ♯ {@♭ l : ULevel} (A : Type l) : Type l where
    constructor _^♯
    field
      _/♯ :{♭} A
  open ♯ publ
-}

  -- Following Licata

  postulate
    -- Given a type A, ♯ A is a type
    ♯ : {i : ULevel} → Type i → Type i

    -- Given an element a : A, we have an element ♯i a : ♯ A
    ♯i : {i : ULevel} {A : Type i} → A → ♯ A

    -- To map out of ♯ A into some type ♯ (B a) depending on it, you may just map out of A.
    ♯-elim : {i j : ULevel} {A : Type i} (B : ♯ A → Type j)
            → ((a : A) → ♯ (B (♯i a)))
            → ((a : ♯ A) → ♯ (B a))

    -- The resulting map out of ♯ A ``computes'' to the original map out of A on ♯i
    ♯-elim-β : {i j : ULevel} {A : Type i} {B : ♯ A → Type j}
               (f : (a : A) → ♯ (B (♯i a))) (a : A)
               → (♯-elim B f (♯i a)) ↦ (f a)
    {-# REWRITE ♯-elim-β #-}

    -- The type of equalities in a codiscrete type are codiscrete
    ♯path : {i : ULevel} {A : Type i} {x y : ♯ A}
            → (♯i {A = x == y}) is-an-equiv

    -- Given a crisp map into ♯ B, we get a cohesive map into it
    -- This encodes the adjunction between ♭ and ♯ on the level of types.
    uncrisp : {@♭ i : ULevel} {j : ULevel} {@♭ A : Type i} (B : A → Type j)
              → ((@♭ a : A) → ♯ (B a))
              → (a : A) → ♯ (B a)

    -- If we uncrispen a function and then apply it to a crisp variable, we get the original result judgementally
    uncrisp-β : {@♭ i : ULevel} {j : ULevel} {@♭ A : Type i} (B : A → Type j)
                → (f : (@♭ a : A) → ♯ (B a))
                → (@♭ a : A) → (uncrisp B f a) ↦ (f a)
    {-# REWRITE uncrisp-β #-}

    -- We can pull crisp elements out of ♯ A
    ♭♯e : {@♭ i : ULevel} {@♭ A : Type i} → ♯ A ::→ A

    -- If we take a crisp element of A, put it into ♯ A, and pull it out again, we get where we were judgementally
    ♭♯β : {@♭ i : ULevel} {@♭ A : Type i} (@♭ a : A)
          → (♭♯e (♯i a)) ↦ a
    {-# REWRITE ♭♯β #-}

    -- If we pull out a crisp element of ♯ A and then put it back in, we get back where we were
    -- Not sure why this isn't judgemental.
    ♭♯η : {@♭ i : ULevel} {@♭ A : Type i} (@♭ a : ♯ A) → a == ♯i (♭♯e a)

    -- We also posulate the half-adjoint needed for this to be a coherent adjunction.
    ♭♯η-▵ : {@♭ i : ULevel} {@♭ A : Type i} (@♭ a : A) → ♭♯η (♯i a) == refl

  ♯path-eq : {i : ULevel} {A : Type i} {x y : ♯ A}
             → (x == y) ≃ (♯ (x == y))
  ♯path-eq = ♯i , ♯path

  ♯-rec : {i j : ULevel} {A : Type i} {B : Type j} →
          (A → ♯ B) → (♯ A → ♯ B)
  ♯-rec {B = B} = ♯-elim (λ _ → B)

{-
  Given a family B : (@♭ a : A) → Type j crisply varying over A,
  we can form the family B' ≡ (λ (@♭ a : A) → ♯ (B a)).

  According to Shulman, we should be able to then get a cohesive variation
  B'' : (a : A) → Type j
  with the property that if (@♭ a : A) , B'' a ≡ B' a

  Or, shorter, from B : (@♭ a : A) → Type j, we should get C : (a : A) → Type j
  with the property that for (@♭ a : A), C a ≡ ♯ (B a)

  The signature of the operation B ↦ C must be ((@♭ a : A) → Type j) → (a : A) → Type j.
  Unfortunately, this doesn't tell us anything about where its landing
-}
  postulate
    ♯' : {@♭ @♭ i : ULevel} {Γ : Type i} {j : ULevel}
         (A : Γ ::→ Type j)
         → Γ → Type j
    ♯'-law : {@♭ @♭ i : ULevel} {Γ : Type i} {j : ULevel}
             (A : Γ ::→ Type j) (@♭ x : Γ)
             → (♯' A) x ↦ ♯ (A x)
    {-# REWRITE ♯'-law #-}

  {-
    Here, we define let notations for ♯ to approximate the upper and lower ♯s
    that Shulman uses in his paper.

    We also define versions of the eliminator and uncrisper that take an implicit family argument, so
    we can use the let notation without explicitly noting the family.
  -}
  syntax ♯-elim B (λ u → t) a = let♯ a :=♯i u in♯ t in-family B
  syntax uncrisp B (λ u → t) a = let♯ a ↓♯:= u in♯ t in-family B

  ♯-elim' : {i j : ULevel} {A : Type i} {B : ♯ A → Type j}
            → ((a : A) → ♯ (B (♯i a)))
            → (a : ♯ A) → ♯ (B a)
  ♯-elim' {B = B} f = ♯-elim B f
  syntax ♯-elim' (λ u → t) a = let♯ a :=♯i u in♯ t

  uncrisp' : {@♭ i : ULevel} {j : ULevel} {@♭ A : Type i} {B : A → Type j}
         → (f : (@♭ a : A) → ♯ (B a))
         → (a : A) → ♯ (B a)
  uncrisp' {B = B} f = uncrisp B f
  syntax uncrisp' (λ u → t) a = let♯ u := a ↓♯in♯ t

  -- A type A is codiscrete if the counit ♯i : A → ♯ A is an equivalence.
  _is-codiscrete : {i : ULevel} (A : Type i) → Type i
  _is-codiscrete {i} A = (♯i {A = A}) is-an-equiv

  -- To prove a type is an equivalence, it suffices to give a retract of ♯i
  _is-codiscrete-because_is-retract-by_ : {i : ULevel} (A : Type i)
                                          (r : ♯ A → A) (p : (a : A) → r (♯i a)  == a)
                                          → A is-codiscrete
  A is-codiscrete-because r is-retract-by p =
    (♯i {A = A}) is-an-equivalence-because r is-inverse-by
        (λ a → -- Given an a : ♯ A,
             (let♯ a :=♯i b in♯ -- We suppose a is ♯i b
                   (♯i (ap ♯i (p b))) -- apply p to b to get r (♯i b) == b,
                                      -- then apply ♯i to get ♯i r ♯i b == ♯i b
                                      -- then hit it with ♯i to get ♯ (♯i r ♯i b == ♯i b)
              in-family (λ (b : ♯ A) → ♯i (r b) == b) -- which is ♯ (♯i r a == a) by our hypothesis,
             )
          |> (<– ♯path-eq) -- and we can strip the ♯ becacuse equality types are codiscrete.
        )
      and p

  -- (λ a → (<– ♯path-eq) ((♯-elim  (λ (b : ♯ A) → ♯i (r b) == b)
  --     (λ b → ♯i (ap ♯i (p b)))) a))

  ♯→ : {i j : ULevel} {A : Type i} {B : Type j}
       (f : A → B) → (♯ A) → (♯ B)
  ♯→ {A = A} {B = B} f = ♯-rec (♯i ∘ f)

  -- Of course, ♯ A is codiscrete for any type A
  ♯-is-codiscrete : {i : ULevel} (A : Type i) → (♯ A) is-codiscrete
  ♯-is-codiscrete A =
    (♯ A) is-codiscrete-because
      (λ (a : ♯ (♯ A)) → let♯ a :=♯i x in♯ x) is-retract-by
        (λ a → refl)

  -- This is the actual equivalence A ≃ ♯ A, given that A is codiscrete
  codisc-eq : {i : ULevel} {A : Type i} (p : A is-codiscrete)
              → A ≃ (♯ A)
  codisc-eq = ♯i ,_

  -- Theorem 3.7 of Shulman
  module _ {@♭ i : ULevel} {@♭ A : Type i} where
    code : (a b : ♯ A) → Type i
    code a = ♯' {Γ = ♯ A} {!!}
         {-
                 (let♯ u := a ↓♯in♯
                     (let♯ v := b ↓♯in♯
                       (♯i (♯ (u == v)))
                     )
                  )
-}

    ♯-identity-eq : (a b : A) → ((♯i a) == (♯i b)) ≃ ♯ (a == b)
    ♯-identity-eq a b = equiv {!!} fro {!!} {!!}
      where
        to : (♯i a) == (♯i b) → ♯ (a == b)
        to p = {!!}

        fro : ♯ (a == b) → ♯i a == ♯i b
        fro p = (let♯ p :=♯i q in♯
                      ♯i (ap ♯i q)
                )
                |> (<– ♯path-eq)

  -- Theorem 6.22 of Shulman
  -- ♭ and ♯ reflect into eachothers categories.
  ♭♯-eq : {@♭ i : ULevel} {@♭ A : Type i} → ♭ (♯ A) ≃ ♭ A
  ♭♯-eq {A = A} = equiv to fro to-fro fro-to
    where
      to : ♭ (♯ A) → ♭ A
      to (a ^♭) = (♭♯e a) ^♭

      fro : ♭ A → ♭ (♯ A)
      fro (a ^♭) = (♯i a) ^♭

      to-fro : (a : ♭ A) → to (fro a) == a
      to-fro (a ^♭) = refl

      fro-to : (a : ♭ (♯ A)) → fro (to a) == a
      fro-to (a ^♭) = ♭-ap _^♭ (! (♭♯η a))

  ♯♭-eq : {@♭ i : ULevel} {@♭ A : Type i} → ♯ (♭ A) ≃ ♯ A
  ♯♭-eq {A = A} = equiv to fro to-fro fro-to
    where
      to : ♯ (♭ A) → ♯ A
      to = ♯-rec (λ { (a ^♭) → (♯i a)})

      fro : ♯ A → ♯ (♭ A)
      fro = ♯-rec (uncrisp _ (λ (a : A) → ♯i (a ^♭)))

      to-fro : (a : ♯ A) → to (fro a) == a
      to-fro = (<– ♯path-eq) ∘
               (♯-elim (λ a → to (fro a) == a) (λ a → ♯i refl))

      fro-to : (a : ♯ (♭ A)) → fro (to a) == a
      fro-to = (<– ♯path-eq) ∘
               (♯-elim (λ a → fro (to a) == a) (λ { (a ^♭) → ♯i refl }))

  -- Theorem 6.27 of Shulman
  ♭♯-adjoint : {@♭ i j : ULevel} {@♭ A : Type i} {@♭ B : A → Type j}
               → ♭ ((a : ♭ A) → B (♭i a)) ≃ ♭ ((a : A) → ♯ (B a))
  ♭♯-adjoint {i} {j} {A} {B}  = equiv to fro to-fro fro-to
    where
      to : ♭ ((a : ♭ A) → B (♭i a)) → ♭ ((a : A) → ♯ (B a))
      to (f ^♭) = (uncrisp B (λ (@♭ a : A) → ♯i (f (a ^♭)))) ^♭

      fro : ♭ ((a : A) → ♯ (B a)) → ♭ ((a : ♭ A) → B (♭i a))
      fro (f ^♭) = (λ { (a ^♭) → ♭♯e (f a) }) ^♭

      to-fro : (f : ♭ ((a : A) → ♯ (B a))) → to (fro f) == f
      to-fro (f ^♭)= ♭-ap _^♭ {!!}

      fro-to : (f : ♭ ((a : ♭ A) → B (♭i a))) → fro (to f) == f
      fro-to (@♭ f ^♭) = ♭-ap _^♭ (λ= (λ a → {!(λ { (a₁ ^♭) → ♭♯e (uncrisp B (λ (a₂ : _) → ♯i (f (a₂ ^♭))) a₁) })!}))

  has-level-is-codiscrete : {i : ULevel} {A : Type i} {n : ℕ₋₂}
                            → (has-level n A) is-codiscrete
  has-level-is-codiscrete = {!!}

  ♯-preserves-level : {i : ULevel} {A : Type i}
                      {n : ℕ₋₂} (p : has-level n A)
                      → has-level n (♯ A)
  ♯-preserves-level {i} {A} {⟨-2⟩} p =
    has-level-in (♯i (contr-center p) ,
      (<– ♯path-eq) ∘ (♯-elim (λ a → ♯i (contr-center p) == a)
        (λ a → ♯i (ap ♯i (contr-path p a)))))
  ♯-preserves-level {i} {A} {S n} p =
    has-level-in (λ x y → (<– (codisc-eq has-level-is-codiscrete))
                           ((♯-elim (λ y → has-level n (x == y)) {!!}) y)
                           )

  {-

  to-crisp : {@♭ i : ULevel} {j : ULevel} {A : ♭ (Type i)} {B : Type j}
        → (♭i A → B) → (A ♭:→ B)
  to-crisp {A = (A ^♭)} f = (<– ♭-recursion-eq) (f ∘ ♭i)

  _is-codiscrete : {@♭ j : ULevel} (B : Type j) → Type (lsucc j)
  _is-codiscrete {j} B = (A : ♭ (Type j)) → to-crisp {A = A} {B = B} is-an-equiv

  codisc-eq : {@♭ j : ULevel} {B : Type j} (p : B is-codiscrete)
              {A : ♭ (Type j)} → (♭i A → B) ≃ (A ♭:→ B)
  codisc-eq {j} {B} p {A} = (to-crisp {A = A} {B = B}) , (p A)

  codisc-promote : {@♭ j : ULevel} {B : Type j} (p : B is-codiscrete)
                   {A : ♭ (Type j)} → (A ♭:→ B) → (♭i A → B)
  codisc-promote p = <– (codisc-eq p)

  _is-codiscrete-is-a-prop : {@♭ j : ULevel} (B : Type j) → (B is-codiscrete) is-a-prop
  _is-codiscrete-is-a-prop {j} B =
    mapping-into-prop-is-a-prop (λ { (A ^♭) → is-equiv-is-prop })

  _is-codiscrete₀ : {@♭ j : ULevel} (B : Type j) → Type₀
  _is-codiscrete₀ {j} B = (resize₀ ((B is-codiscrete) , (B is-codiscrete-is-a-prop))) holds

  ⊤-is-codiscrete : ⊤ is-codiscrete
  ⊤-is-codiscrete =
    λ { (A ^♭) → to-crisp is-an-equivalence-because
      (λ _ _ → unit) is-inverse-by
        (λ f → refl) and (λ f → refl) }

 {-
  Π-codisc : {@♭ i : ULevel} {A : Type i} {B : A → Type i}
             → ((a : A) → (B a) is-codiscrete)
             → ((a : A) → B a) is-codiscrete
  Π-codisc {i} {A} {B} f =
     λ { (T ^♭) → to-crisp is-an-equivalence-because
      (λ g → λ t a → {!codisc-promote (f a)!}) is-inverse-by
        {!!} and {!!}}
  -}

  {-
  question : {@♭ i : ULevel} (B : Type i)
             (r : (A : ♭ (Type i)) → (to-crisp {A = A} {B = B}) is-split-inj)
             → B is-codiscrete
  question {i = i} B r =
    λ { (A ^♭) → to-crisp is-an-equivalence-because
      fst (r (A ^♭)) is-inverse-by
        (λ f → {!!})
        and snd (r (A ^♭)) } -}

  {-  The idea from this proof is to map out of the suspension

  =-is-codiscrete : {@♭ i : ULevel} {B : Type i} (p : B is-codiscrete)
                    (x y : B) → (x == y) is-codiscrete
  =-is-codiscrete {i} {B} p x y =
    λ { (A ^♭) → to-crisp is-an-equivalence-because
      {!!} is-inverse-by {!!} and {!!} }

  -}

  -}


{-# OPTIONS --without-K #-}
module hott.equivalence where

open import hott.equivalence.alternative public
open import hott.equivalence.core public
open import hott.equivalence.properties public
open import hott.equivalence.inverse public
-- open import hott.equivalence.coind public


------------------------------------------------------------------------
-- A definitional interpreter
------------------------------------------------------------------------

open import Prelude

import Lambda.Syntax

module Lambda.Interpreter
  {Name : Type}
  (open Lambda.Syntax Name)
  (def : Name → Tm 1)
  where

import Equality.Propositional as E

open import Monad E.equality-with-J
open import Vec.Data E.equality-with-J

open import Delay-monad
open import Delay-monad.Bisimilarity

open import Lambda.Delay-crash

open Closure Tm

------------------------------------------------------------------------
-- The interpreter

infix 10 _∙_

mutual

  ⟦_⟧ : ∀ {i n} → Tm n → Env n → Delay-crash Value i
  ⟦ var x ⟧       ρ = return (index ρ x)
  ⟦ lam t ⟧       ρ = return (lam t ρ)
  ⟦ t₁ · t₂ ⟧     ρ = do v₁ ← ⟦ t₁ ⟧ ρ
                         v₂ ← ⟦ t₂ ⟧ ρ
                         v₁ ∙ v₂
  ⟦ call f t ⟧    ρ = do v ← ⟦ t ⟧ ρ
                         lam (def f) [] ∙ v
  ⟦ con b ⟧       ρ = return (con b)
  ⟦ if t₁ t₂ t₃ ⟧ ρ = do v₁ ← ⟦ t₁ ⟧ ρ
                         ⟦if⟧ v₁ t₂ t₃ ρ

  _∙_ : ∀ {i} → Value → Value → Delay-crash Value i
  lam t₁ ρ ∙ v₂ = later λ { .force → ⟦ t₁ ⟧ (v₂ ∷ ρ) }
  con _    ∙ _  = crash

  ⟦if⟧ : ∀ {i n} →
         Value → Tm n → Tm n → Env n → Delay-crash Value i
  ⟦if⟧ (lam _ _)   _  _  _ = crash
  ⟦if⟧ (con true)  t₂ t₃ ρ = ⟦ t₂ ⟧ ρ
  ⟦if⟧ (con false) t₂ t₃ ρ = ⟦ t₃ ⟧ ρ

------------------------------------------------------------------------
-- An example

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

Ω-loops : ∀ {i} → [ i ] ⟦ Ω ⟧ [] ∼ never
Ω-loops =
  ⟦ Ω ⟧ []                             ∼⟨⟩
  ⟦ ω · ω ⟧ []                         ∼⟨⟩
  lam ω-body [] ∙ lam ω-body []        ∼⟨ later (λ { .force →

      ⟦ ω-body ⟧ (lam ω-body [] ∷ [])       ∼⟨⟩
      lam ω-body [] ∙ lam ω-body []         ∼⟨⟩
      ⟦ Ω ⟧ []                              ∼⟨ Ω-loops ⟩∼
      never                                 ∎ }) ⟩∼

  never                                ∎

-- A more direct proof.

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


module Issue357a where

module M (X : Set) where

  data R : Set where
    r : X → R

postulate
  P Q : Set
  q   : Q

open M P
open M.R

works : M.R Q → Q
works (M.R.r q) = q

fails : M.R Q → Q
fails (r q) = q


-- {-# OPTIONS --cubical -vtc.lhs.split.partial:20 #-}
{-# OPTIONS --cubical #-}
module _ where
open import Agda.Primitive.Cubical
open import Agda.Builtin.Equality

postulate
  X : Set
  P : I → Set
  p : P i1

module Test (A : Set) (i : I) (B : Set) where

  j = i
  R = P j
  module Z (r s : A) where
    a0 : I → Partial j R
    a0 k with k
    ... | _ = \ { (j = i1) → p }

  a : Partial j R
  a (j = i1) = p

  refining : ∀ (x y : A) → x ≡ y → A → Partial j R
  refining x y refl = \ { _ (j = i1) → p }

  refining-dot : ∀ (x y : A) → x ≡ y → A → Partial j R
  refining-dot x .x refl = \ { _ (j = i1) → p }

  refining-dot2 : ∀ (x y : A) → x ≡ y → A → Partial j R
  refining-dot2 x .x refl z = \ { (i = i1) → p }

  refining-cxt : A ≡ X → Partial j R
  refining-cxt refl = \ { (j = i1) → p }

  refining-cxt2 : B ≡ X → Partial j R
  refining-cxt2 refl = \ { (j = i1) → p }


-- Andreas, 2012-09-11
{-# OPTIONS --show-implicit #-}
-- {-# OPTIONS -v tc.meta:50 #-}
module Const where

import Common.Level

const : {A B : Set} → A → B → A
const a b = a
-- If this is analyzed as {A B : Set} → A → .B → A
-- then, due to constraint solving insensitive to subtyping,
-- the following will trigger an 'UnequalRelevance' error.

postulate
  F : Set → Set
  _<$>_ : {A B : Set} → (A → B) → F A → F B
  _<*>_ : {A B : Set} → F (A → B) → F A → F B

test : {A B : Set} → F A → F B → F A
test {A} {B} x y = (const <$> x) <*> y


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

open import Base

module Homotopy.PushoutDef where

record pushout-diag (i : Level) : Set (suc i) where
  constructor diag_,_,_,_,_
  field
    A : Set i
    B : Set i
    C : Set i
    f : C → A
    g : C → B

pushout-diag-raw-eq : ∀ {i} {A A' : Set i} (p : A ≡ A')
  {B B' : Set i} (q : B ≡ B') {C C' : Set i} (r : C ≡ C')
  {f : C → A} {f' : C' → A'} (s : f' ◯ transport _ r ≡ transport _ p ◯ f)
  {g : C → B} {g' : C' → B'} (t : transport _ q ◯ g ≡ g' ◯ transport _ r)
  → (diag A , B , C , f , g) ≡ (diag A' , B' , C' , f' , g')
pushout-diag-raw-eq refl refl refl refl refl = refl

pushout-diag-eq : ∀ {i} {A A' : Set i} (p : A ≃ A')
  {B B' : Set i} (q : B ≃ B') {C C' : Set i} (r : C ≃ C')
  {f : C → A} {f' : C' → A'} (s : (a : C) →  f' (π₁ r a) ≡ (π₁ p) (f a))
  {g : C → B} {g' : C' → B'} (t : (b : C) → (π₁ q) (g b) ≡ g' (π₁ r b))
  → (diag A , B , C , f , g) ≡ (diag A' , B' , C' , f' , g')
pushout-diag-eq p q r {f} {f'} s {g} {g'} t = pushout-diag-raw-eq
  (eq-to-path p)
  (eq-to-path q)
  (eq-to-path r)
  (funext (λ a → ap f' (trans-id-eq-to-path r a)
                     ∘ (s a ∘ ! (trans-id-eq-to-path p (f a)))))
  (funext (λ b → trans-id-eq-to-path q (g b)
                     ∘ (t b ∘ ap g' (! (trans-id-eq-to-path r b)))))

module Pushout {i} {d : pushout-diag i} where

  open pushout-diag d

  private
    data #pushout : Set i where
      #left : A → #pushout
      #right : B → #pushout

  pushout : Set _
  pushout = #pushout

  left : A → pushout
  left = #left

  right : B → pushout
  right = #right

  postulate  -- HIT
    glue : (c : C) → left (f c) ≡ right (g c)

  pushout-rec : ∀ {l} (P : pushout → Set l) (left* : (a : A) → P (left a))
    (right* : (b : B) → P (right b))
    (glue* : (c : C) → transport P (glue c) (left* (f c)) ≡ right* (g c))
    → (x : pushout) → P x
  pushout-rec P left* right* glue* (#left y) = left* y
  pushout-rec P left* right* glue* (#right y) = right* y

  postulate  -- HIT
    pushout-β-glue : ∀ {l} (P : pushout → Set l) (left* : (a : A) → P (left a))
      (right* : (b : B) → P (right b))
      (glue* : (c : C) → transport P (glue c) (left* (f c)) ≡ right* (g c))
      (c : C)
        → apd (pushout-rec {l} P left* right* glue*) (glue c) ≡ glue* c

  pushout-rec-nondep : ∀ {l} (D : Set l) (left* : A → D) (right* : B → D)
    (glue* : (c : C) → left* (f c) ≡ right* (g c)) → (pushout → D)
  pushout-rec-nondep D left* right* glue* (#left y) = left* y
  pushout-rec-nondep D left* right* glue* (#right y) = right* y

  postulate  -- HIT
    pushout-β-glue-nondep : ∀ {l} (D : Set l) (left* : A → D) (right* : B → D)
      (glue* : (c : C) → left* (f c) ≡ right* (g c)) (c : C)
      → ap (pushout-rec-nondep D left* right* glue*) (glue c) ≡ glue* c

open Pushout public hiding (pushout)

pushout : ∀ {i} (d : pushout-diag i) → Set i
pushout d = Pushout.pushout {_} {d}


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

open import Agda.Builtin.Equality using (_≡_)
open import Agda.Builtin.Equality.Rewrite

postulate
  cast : (A B : Set) → A → B
  cast-rew : (A : Set) (x : A) → cast A A x ≡ x
{-# REWRITE cast-rew #-}

postulate
  A : Set
  x y : A

data D (B : A → Set) (b : B y) : Set where
  con : cast (B x) (B y) ? ≡ b → D B b

record R (B : A → Set) (b : B y) : Set where
  field
    eq : cast (B x) (B y) ? ≡ b


------------------------------------------------------------------------
-- An alternative definition of listed finite subsets
------------------------------------------------------------------------

-- The code in this module is based on Frumin, Geuvers, Gondelman and
-- van der Weide's "Finite Sets in Homotopy Type Theory". However, the
-- type of subsets is defined mutually with a membership predicate,
-- and two higher constructors have been replaced by a constructor
-- that states that extensionally equal subsets are equal.
--
-- The type in this module is perhaps harder to work with than the one
-- in Finite-subset.Listed: the "natural" eliminator only works for
-- motives that are propositional. However, the two types are shown to
-- be equivalent.

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

import Equality.Path as P

module Finite-subset.Listed.Alternative
  {c⁺} (eq : ∀ {a p} → P.Equality-with-paths a p c⁺) where

open P.Derived-definitions-and-properties eq hiding (elim)

import Equality.Path.Univalence as EPU
open import Logical-equivalence using (_⇔_)
open import Prelude hiding (_∷_; swap)

open import Bijection equality-with-J using (_↔_)
import Bijection P.equality-with-J as PB
open import Equality.Path.Isomorphisms eq
open import Equivalence equality-with-J as Eq using (_≃_)
import Equivalence P.equality-with-J as PEq
import Finite-subset.Listed eq as Listed
open import Function-universe equality-with-J as F hiding (id; _∘_)
import H-level P.equality-with-J as PH
open import H-level.Closure equality-with-J
import H-level.Closure P.equality-with-J as PHC
open import H-level.Truncation.Propositional eq as Trunc
  using (∥_∥; _∥⊎∥_)
open import Injection equality-with-J using (Injective)
import Univalence-axiom P.equality-with-J as PU

private
  variable
    a b p                 : Level
    A B                   : Type a
    P                     : A → Type p
    x x∼y y y₁ y₂ z z₁ z₂ : A

------------------------------------------------------------------------
-- Listed finite subsets

mutual

  -- Listed finite subsets of a given type, defined mutually with a
  -- membership predicate.

  infixr 5 _∷_

  data Finite-subset-of (A : Type a) : Type a where
    []              : Finite-subset-of A
    _∷_             : A → Finite-subset-of A → Finite-subset-of A
    extensionalityᴾ : x ∼ y → x P.≡ y
    is-setᴾ         : P.Is-set (Finite-subset-of A)

  private

    Membership :
      {A : Type a} → A → Finite-subset-of A → PH.Proposition a

  -- Membership.

  infix 4 _∈_

  _∈_ : {A : Type a} → A → Finite-subset-of A → Type a
  x ∈ y = proj₁ (Membership x y)

  -- Membership is propositional.

  ∈-propositionalᴾ : ∀ y → P.Is-proposition (x ∈ y)
  ∈-propositionalᴾ y = proj₂ (Membership _ y)

  -- Extensional equality.

  infix 4 _∼_

  _∼_ :
    {A : Type a} → Finite-subset-of A → Finite-subset-of A → Type a
  x ∼ y = ∀ z → z ∈ x ⇔ z ∈ y

  Membership x [] =
    ⊥ , PHC.⊥-propositional

  Membership x (y ∷ z) =
    (x ≡ y ∥⊎∥ x ∈ z) , Trunc.truncation-is-propositionᴾ

  Membership x (extensionalityᴾ {x = y} {y = z} y∼z i) =
    lemma i
    where
    lemma : Membership x y P.≡ Membership x z
    lemma = P.Σ-≡,≡→≡
      (x ∈ y  P.≡⟨ PEq._≃_.from
                     (PU.Propositional-extensionality-is-univalence-for-propositions P.ext)
                     (λ _ _ → EPU.univ)
                     (∈-propositionalᴾ y)
                     (∈-propositionalᴾ z)
                     (y∼z x) ⟩∎
       x ∈ z  ∎)
      (PHC.H-level-propositional P.ext 1 _ _)

  Membership x (is-setᴾ {x = y} {y = z} p q i j) =
    P.heterogeneous-UIP₀₀
      {x = λ _ → Membership x y}
      {y = λ _ → Membership x z}
      {p = λ i → Membership x (p i)}
      {q = λ i → Membership x (q i)}
      (PU.∃-H-level-H-level-1+ P.ext EPU.univ 1)
      i j

-- Variants of some of the constructors.

extensionality : x ∼ y → x ≡ y
extensionality = _↔_.from ≡↔≡ ∘ extensionalityᴾ

is-set : Is-set (Finite-subset-of A)
is-set =
  _↔_.from (H-level↔H-level 2) Finite-subset-of.is-setᴾ

-- Membership is propositional.

∈-propositional : ∀ y → Is-proposition (x ∈ y)
∈-propositional = _↔_.from (H-level↔H-level 1) ∘ ∈-propositionalᴾ

-- Unit tests documenting some of the computational behaviour of _∈_.

_ : (x ∈ []) ≡ ⊥
_ = refl _

_ : (x ∈ y ∷ z) ≡ (x ≡ y ∥⊎∥ x ∈ z)
_ = refl _

------------------------------------------------------------------------
-- Eliminators

private

  -- The following dependent eliminator is not exported, because the
  -- motive is necessarily pointwise propositional (see
  -- motive-propositional below).

  record Elimᴾ′ {A : Type a} (P : Finite-subset-of A → Type p) :
                Type (a ⊔ p) where
    no-eta-equality
    field
      []ʳ             : P []
      ∷ʳ              : ∀ x → P y → P (x ∷ y)
      is-setʳ         : ∀ x → P.Is-set (P x)
      extensionalityʳ :
        (p : P x) (q : P y) →
        P.[ (λ i → P (extensionalityᴾ {x = x} {y = y} x∼y i)) ] p ≡ q

  open Elimᴾ′

  elimᴾ′ : Elimᴾ′ P → (x : Finite-subset-of A) → P x
  elimᴾ′ {A = A} {P = P} e = helper
    where
    module E = Elimᴾ′ e

    helper : (x : Finite-subset-of A) → P x
    helper []      = E.[]ʳ
    helper (x ∷ y) = E.∷ʳ x (helper y)

    helper (extensionalityᴾ {x = x} {y = y} _ i) =
      E.extensionalityʳ (helper x) (helper y) i

    helper (is-setᴾ x y i j) =
      P.heterogeneous-UIP
        E.is-setʳ (is-setᴾ x y)
        (λ i → helper (x i)) (λ i → helper (y i)) i j

  -- The motive is necessarily pointwise propositional.

  motive-propositional :
    Elimᴾ′ P → ∀ x → P.Is-proposition (P x)
  motive-propositional {P = P} e x p q =
    p                                         P.≡⟨ P.sym $ P.subst-refl P _ ⟩
    P.subst P P.refl p                        P.≡⟨ P.cong (λ eq → P.subst P eq p) $ is-setᴾ _ _ ⟩
    P.subst P (extensionalityᴾ λ _ → F.id) p  P.≡⟨ PB._↔_.to (P.heterogeneous↔homogeneous _)
                                                     (e .extensionalityʳ {x∼y = λ _ → F.id} p q) ⟩∎
    q                                         ∎

-- A dependent eliminator, expressed using paths.

record Elimᴾ {A : Type a} (P : Finite-subset-of A → Type p) :
             Type (a ⊔ p) where
  no-eta-equality
  field
    []ʳ             : P []
    ∷ʳ              : ∀ x → P y → P (x ∷ y)
    is-propositionʳ : ∀ x → P.Is-proposition (P x)

open Elimᴾ public

elimᴾ : Elimᴾ P → (x : Finite-subset-of A) → P x
elimᴾ {A = A} {P = P} e = elimᴾ′ e′
  where
  module E = Elimᴾ e

  e′ : Elimᴾ′ _
  e′ .[]ʳ                 = e .[]ʳ
  e′ .∷ʳ                  = e .∷ʳ
  e′ .is-setʳ             = PH.mono₁ 1 ∘ e .is-propositionʳ
  e′ .extensionalityʳ _ _ =
    PB._↔_.from (P.heterogeneous↔homogeneous _)
      (e .is-propositionʳ _ _ _)

-- A non-dependent eliminator, expressed using paths.

record Recᴾ (A : Type a) (B : Type b) : Type (a ⊔ b) where
  no-eta-equality
  field
    []ʳ             : B
    ∷ʳ              : A → Finite-subset-of A → B → B
    is-propositionʳ : P.Is-proposition B

open Recᴾ public

recᴾ : Recᴾ A B → Finite-subset-of A → B
recᴾ {A = A} {B = B} r = elimᴾ e
  where
  module R = Recᴾ r

  e : Elimᴾ _
  e .[]ʳ               = R.[]ʳ
  e .∷ʳ {y = y} x      = R.∷ʳ x y
  e .is-propositionʳ _ = R.is-propositionʳ

-- A dependent eliminator, expressed using equality.

record Elim
         {A : Type a} (P : Finite-subset-of A → Type p) :
         Type (a ⊔ p) where
  field
    []ʳ             : P []
    ∷ʳ              : ∀ x → P y → P (x ∷ y)
    is-propositionʳ : ∀ x → Is-proposition (P x)

open Elim public

elim : Elim P → (x : Finite-subset-of A) → P x
elim e = elimᴾ e′
  where
  module E = Elim e

  e′ : Elimᴾ _
  e′ .[]ʳ             = E.[]ʳ
  e′ .∷ʳ              = E.∷ʳ
  e′ .is-propositionʳ = _↔_.to (H-level↔H-level 1) ∘ E.is-propositionʳ

-- A non-dependent eliminator, expressed using equality.

record Rec (A : Type a) (B : Type b) : Type (a ⊔ b) where
  field
    []ʳ             : B
    ∷ʳ              : A → Finite-subset-of A → B → B
    is-propositionʳ : Is-proposition B

open Rec public

rec : Rec A B → Finite-subset-of A → B
rec r = elim e
  where
  module R = Rec r

  e : Elim _
  e .[]ʳ               = R.[]ʳ
  e .∷ʳ {y = y} x      = R.∷ʳ x y
  e .is-propositionʳ _ = R.is-propositionʳ

------------------------------------------------------------------------
-- Some lemmas

-- If A is inhabited, then Finite-subset-of A is not a proposition.

¬-proposition : A → ¬ Is-proposition (Finite-subset-of A)
¬-proposition {A = A} x =
  Is-proposition (Finite-subset-of A)  ↝⟨ (λ hyp → hyp _ _) ⟩
  x ∷ [] ≡ []                          ↝⟨ (λ hyp → subst (x ∈_) hyp (Trunc.∣inj₁∣ (refl _))) ⟩
  x ∈ []                               ↔⟨ ⊥↔⊥ ⟩□
  ⊥                                    □

abstract

  -- Duplicated elements can be dropped.

  drop : x ∷ x ∷ y ≡ x ∷ y
  drop {x = x} {y = y} = extensionality λ z →
    z ≡ x ∥⊎∥ (z ≡ x ∥⊎∥ z ∈ y)  ↔⟨ Trunc.drop-left-∥⊎∥ Trunc.∥⊎∥-propositional Trunc.∣inj₁∣ ⟩□
    z ≡ x ∥⊎∥ z ∈ y              □

  -- The "first" two elements can be swapped.

  swap : x ∷ y ∷ z ≡ y ∷ x ∷ z
  swap {x = x} {y = y} {z = z} = extensionality λ u →
    u ≡ x ∥⊎∥ (u ≡ y ∥⊎∥ u ∈ z)  ↔⟨ Trunc.∥⊎∥-assoc ⟩
    (u ≡ x ∥⊎∥ u ≡ y) ∥⊎∥ u ∈ z  ↔⟨ Trunc.∥⊎∥-comm Trunc.∥⊎∥-cong F.id ⟩
    (u ≡ y ∥⊎∥ u ≡ x) ∥⊎∥ u ∈ z  ↔⟨ inverse Trunc.∥⊎∥-assoc ⟩□
    u ≡ y ∥⊎∥ (u ≡ x ∥⊎∥ u ∈ z)  □

-- If x is a member of y, then x ∷ y is equal to y.

∈→∷≡ : x ∈ y → x ∷ y ≡ y
∈→∷≡ {x = x} = elim e _
  where
  e : Elim (λ y → x ∈ y → x ∷ y ≡ y)
  e .∷ʳ {y = y} z hyp =
    Trunc.rec is-set
      [ (λ x≡z →
           x ∷ z ∷ y  ≡⟨ cong (λ x → x ∷ _) x≡z ⟩
           z ∷ z ∷ y  ≡⟨ drop ⟩∎
           z ∷ y      ∎)
      , (λ x∈y →
           x ∷ z ∷ y  ≡⟨ swap ⟩
           z ∷ x ∷ y  ≡⟨ cong (_ ∷_) (hyp x∈y) ⟩∎
           z ∷ y      ∎)
      ]

  e .is-propositionʳ _ =
    Π-closure ext 1 λ _ →
    is-set

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

-- Singleton subsets.

singleton : A → Finite-subset-of A
singleton x = x ∷ []

-- A lemma characterising singleton.

∈singleton≃ :
  (x ∈ singleton y) ≃ ∥ x ≡ y ∥
∈singleton≃ {x = x} {y = y} =
  x ∈ singleton y  ↔⟨⟩
  x ≡ y ∥⊎∥ ⊥      ↔⟨ Trunc.∥∥-cong $ drop-⊥-right ⊥↔⊥ ⟩□
  ∥ x ≡ y ∥        □

-- If truncated equality is decidable, then membership is also
-- decidable.

member? :
  ((x y : A) → Dec ∥ x ≡ y ∥) →
  (x : A) (y : Finite-subset-of A) → Dec (x ∈ y)
member? equal? x = elim e
  where
  e : Elim _
  e .[]ʳ          = no λ ()
  e .∷ʳ {y = z} y = case equal? x y of
    [ (λ  ∥x≡y∥ _ → yes (Trunc.∥∥-map inj₁ ∥x≡y∥))
    , (λ ¬∥x≡y∥ →
         [ (λ x∈z → yes (Trunc.∣inj₂∣ x∈z))
         , (λ x∉z → no (
              x ∈ y ∷ z        ↔⟨⟩
              x ≡ y ∥⊎∥ x ∈ z  ↝⟨ Trunc.∥∥-map [ ¬∥x≡y∥ ∘ Trunc.∣_∣ , x∉z ] ⟩
              ∥ ⊥ ∥            ↔⟨ Trunc.not-inhabited⇒∥∥↔⊥ id ⟩□
              ⊥                □))
         ])
    ]
  e .is-propositionʳ y =
    Dec-closure-propositional ext (∈-propositional y)

------------------------------------------------------------------------
-- The union operation

private

  -- A specification of what it means for a subset to be the union of
  -- two subsets.

  Is-union-of :
    {A : Type a} (_ _ _ : Finite-subset-of A) → Type a
  Is-union-of x y z = ∀ u → (u ∈ z) ≃ (u ∈ x ∥⊎∥ u ∈ y)

  -- Is-union-of x y is functional.

  Is-union-of-functional :
    (x y : Finite-subset-of A) →
    Is-union-of x y z₁ → Is-union-of x y z₂ →
    z₁ ≡ z₂
  Is-union-of-functional {z₁ = z₁} {z₂ = z₂} x y p₁ p₂ =
    extensionality λ u →
      u ∈ z₁           ↔⟨ p₁ u ⟩
      u ∈ x ∥⊎∥ u ∈ y  ↔⟨ inverse $ p₂ u ⟩□
      u ∈ z₂           □

  -- Is-union-of is propositional.

  Is-union-of-propositional :
    (x y z : Finite-subset-of A) →
    Is-proposition (Is-union-of x y z)
  Is-union-of-propositional x y z =
    Π-closure ext 1 λ _ →
    Eq.left-closure ext 0 (∈-propositional z)

  -- The union operation, along with a correctness proof.

  union : (x y : Finite-subset-of A) → ∃ (Is-union-of x y)
  union = elim e
    where
    e : Elim _
    e .[]ʳ y =
        y
      , λ u →
          u ∈ y        ↔⟨ inverse $ Trunc.∥⊎∥-left-identity (∈-propositional y) ⟩□
          ⊥ ∥⊎∥ u ∈ y  □

    e .∷ʳ {y = y} x hyp z =
        x ∷ proj₁ (hyp z)
      , λ u →
          u ∈ x ∷ proj₁ (hyp z)        ↔⟨⟩
          u ≡ x ∥⊎∥ u ∈ proj₁ (hyp z)  ↝⟨ F.id Trunc.∥⊎∥-cong proj₂ (hyp z) u ⟩
          u ≡ x ∥⊎∥ (u ∈ y ∥⊎∥ u ∈ z)  ↔⟨ Trunc.∥⊎∥-assoc ⟩
          (u ≡ x ∥⊎∥ u ∈ y) ∥⊎∥ u ∈ z  ↔⟨⟩
          u ∈ x ∷ y ∥⊎∥ u ∈ z          □

    e .is-propositionʳ x f g = ⟨ext⟩ λ y →
      Σ-≡,≡→≡
        (Is-union-of-functional x y (proj₂ (f y)) (proj₂ (g y)))
        (Is-union-of-propositional x y (proj₁ (g y)) _ _)

-- The union of two finite subsets.

infixr 5 _∪_

_∪_ :
  Finite-subset-of A → Finite-subset-of A →
  Finite-subset-of A
x ∪ y = proj₁ (union x y)

-- Unit tests documenting some of the computational behaviour of _∪_.

_ : [] ∪ x ≡ x
_ = refl _

_ : (x ∷ y) ∪ z ≡ x ∷ (y ∪ z)
_ = refl _

-- Membership of a union of two subsets can be expressed in terms of
-- membership of the subsets.

∈∪≃∈∥⊎∥∈ : ∀ y → (x ∈ y ∪ z) ≃ (x ∈ y ∥⊎∥ x ∈ z)
∈∪≃∈∥⊎∥∈ {z = z} y = proj₂ (union y z) _

-- If x is a member of y, then x is a member of y ∪ z.

∈→∈∪ˡ : ∀ y → x ∈ y → x ∈ y ∪ z
∈→∈∪ˡ y = _≃_.from (∈∪≃∈∥⊎∥∈ y) ∘ Trunc.∣inj₁∣

-- If x is a member of z, then x is a member of y ∪ z.

∈→∈∪ʳ : ∀ y → x ∈ z → x ∈ y ∪ z
∈→∈∪ʳ y = _≃_.from (∈∪≃∈∥⊎∥∈ y) ∘ Trunc.∣inj₂∣

-- [] is a right identity of _∪_.

∪[] :
  (x : Finite-subset-of A) →
  x ∪ [] ≡ x
∪[] = elim e
  where
  e : Elim _
  e .is-propositionʳ _ = is-set
  e .[]ʳ               = refl _
  e .∷ʳ {y = y} x hyp  =
    x ∷ y ∪ []  ≡⟨ cong (x ∷_) hyp ⟩∎
    x ∷ y        ∎

-- A lemma relating _∪_ and _∷_.

∪∷ :
  (x : Finite-subset-of A) →
  x ∪ (y ∷ z) ≡ y ∷ x ∪ z
∪∷ {y = y} {z = z} = elim e
  where
  e : Elim _
  e .is-propositionʳ _ = is-set

  e .[]ʳ = refl _

  e .∷ʳ {y = u} x hyp =
    (x ∷ u) ∪ (y ∷ z)  ≡⟨⟩
    x ∷ u ∪ (y ∷ z)    ≡⟨ cong (x ∷_) hyp ⟩
    x ∷ y ∷ u ∪ z      ≡⟨ swap ⟩
    y ∷ x ∷ u ∪ z      ≡⟨⟩
    y ∷ (x ∷ u) ∪ z    ∎

-- The union operator is associative.

∪-assoc :
  (x : Finite-subset-of A) →
  x ∪ (y ∪ z) ≡ (x ∪ y) ∪ z
∪-assoc {y = y} {z = z} = elim e
  where
  e : Elim _
  e .is-propositionʳ _ = is-set

  e .[]ʳ = refl _

  e .∷ʳ {y = u} x hyp =
    x ∷ u ∪ (y ∪ z)  ≡⟨ cong (x ∷_) hyp ⟩∎
    x ∷ (u ∪ y) ∪ z  ∎

-- The union operator is commutative.

∪-comm :
  (x : Finite-subset-of A) →
  x ∪ y ≡ y ∪ x
∪-comm {y = y} = elim e
  where
  e : Elim _
  e .is-propositionʳ _ = is-set

  e .[]ʳ =
    [] ∪ y  ≡⟨⟩
    y       ≡⟨ sym (∪[] y) ⟩∎
    y ∪ []  ∎

  e .∷ʳ {y = z} x hyp =
    x ∷ z ∪ y    ≡⟨ cong (x ∷_) hyp ⟩
    x ∷ y ∪ z    ≡⟨ sym (∪∷ y) ⟩∎
    y ∪ (x ∷ z)  ∎

-- The union operator is idempotent.

∪-idem : (x : Finite-subset-of A) → x ∪ x ≡ x
∪-idem = elim e
  where
  e : Elim _
  e .[]ʳ =
    [] ∪ []  ≡⟨⟩
    []       ∎

  e .∷ʳ {y = y} x hyp =
    (x ∷ y) ∪ (x ∷ y)  ≡⟨⟩
    x ∷ y ∪ x ∷ y      ≡⟨ cong (_ ∷_) (∪∷ y) ⟩
    x ∷ x ∷ y ∪ y      ≡⟨ drop ⟩
    x ∷ y ∪ y          ≡⟨ cong (_ ∷_) hyp ⟩∎
    x ∷ y              ∎

  e .is-propositionʳ = λ _ → is-set

-- The union operator distributes from the left and right over itself.

∪-distrib-left : ∀ x → x ∪ (y ∪ z) ≡ (x ∪ y) ∪ (x ∪ z)
∪-distrib-left {y = y} {z = z} x =
  x ∪ (y ∪ z)        ≡⟨ cong (_∪ _) $ sym (∪-idem x) ⟩
  (x ∪ x) ∪ (y ∪ z)  ≡⟨ sym $ ∪-assoc x ⟩
  x ∪ (x ∪ (y ∪ z))  ≡⟨ cong (x ∪_) $ ∪-assoc x ⟩
  x ∪ ((x ∪ y) ∪ z)  ≡⟨ cong ((x ∪_) ∘ (_∪ _)) $ ∪-comm x ⟩
  x ∪ ((y ∪ x) ∪ z)  ≡⟨ cong (x ∪_) $ sym $ ∪-assoc y ⟩
  x ∪ (y ∪ (x ∪ z))  ≡⟨ ∪-assoc x ⟩∎
  (x ∪ y) ∪ (x ∪ z)  ∎

∪-distrib-right : ∀ x → (x ∪ y) ∪ z ≡ (x ∪ z) ∪ (y ∪ z)
∪-distrib-right {y = y} {z = z} x =
  (x ∪ y) ∪ z        ≡⟨ ∪-comm (x ∪ _) ⟩
  z ∪ (x ∪ y)        ≡⟨ ∪-distrib-left z ⟩
  (z ∪ x) ∪ (z ∪ y)  ≡⟨ cong₂ _∪_ (∪-comm z) (∪-comm z) ⟩∎
  (x ∪ z) ∪ (y ∪ z)  ∎

------------------------------------------------------------------------
-- Subsets of subsets

-- Subsets.

infix 4 _⊆_

_⊆_ : {A : Type a} → Finite-subset-of A → Finite-subset-of A → Type a
x ⊆ y = ∀ z → z ∈ x → z ∈ y

-- _⊆_ is pointwise propositional.

⊆-propositional :
  (x y : Finite-subset-of A) → Is-proposition (x ⊆ y)
⊆-propositional x y =
  Π-closure ext 1 λ _ →
  Π-closure ext 1 λ _ →
  ∈-propositional y

-- The function x ∷_ is monotone with respect to _⊆_.

∷-cong-⊆ : ∀ y z → y ⊆ z → x ∷ y ⊆ x ∷ z
∷-cong-⊆ {x = x} y z y⊆z = λ u →
  u ∈ x ∷ y        ↔⟨⟩
  u ≡ x ∥⊎∥ u ∈ y  ↝⟨ id Trunc.∥⊎∥-cong y⊆z _ ⟩
  u ≡ x ∥⊎∥ u ∈ z  ↔⟨⟩
  u ∈ x ∷ z        □

-- The union operator is monotone with respect to _⊆_.

∪-mono-⊆ : ∀ x₁ x₂ → x₁ ⊆ x₂ → y₁ ⊆ y₂ → x₁ ∪ y₁ ⊆ x₂ ∪ y₂
∪-mono-⊆ {y₁ = y₁} {y₂ = y₂} x₁ x₂ x₁⊆x₂ y₁⊆y₂ = λ u →
  u ∈ x₁ ∪ y₁        ↔⟨ ∈∪≃∈∥⊎∥∈ x₁ ⟩
  u ∈ x₁ ∥⊎∥ u ∈ y₁  ↝⟨ x₁⊆x₂ u Trunc.∥⊎∥-cong y₁⊆y₂ u ⟩
  u ∈ x₂ ∥⊎∥ u ∈ y₂  ↔⟨ inverse $ ∈∪≃∈∥⊎∥∈ x₂ ⟩□
  u ∈ x₂ ∪ y₂        □

-- The subset property can be expressed using _∪_ and _≡_.

⊆≃∪≡ : ∀ x → (x ⊆ y) ≃ (x ∪ y ≡ y)
⊆≃∪≡ {y = y} x = Eq.⇔→≃
  (⊆-propositional x y)
  is-set
  (elim e x)
  (λ p z →
     z ∈ x      ↝⟨ ∈→∈∪ˡ x ⟩
     z ∈ x ∪ y  ↝⟨ ≡⇒↝ _ (cong (z ∈_) p) ⟩□
     z ∈ y      □)
  where
  e : Elim (λ x → x ⊆ y → x ∪ y ≡ y)
  e .[]ʳ _ =
    [] ∪ y  ≡⟨⟩
    y       ∎

  e .∷ʳ {y = z} x hyp x∷z⊆y =
    x ∷ z ∪ y  ≡⟨ cong (x ∷_) (hyp (λ _ → x∷z⊆y _ ∘ Trunc.∣inj₂∣)) ⟩
    x ∷ y      ≡⟨ ∈→∷≡ (x∷z⊆y x (Trunc.∣inj₁∣ (refl _))) ⟩∎
    y          ∎

  e .is-propositionʳ _ =
    Π-closure ext 1 λ _ →
    is-set

-- _⊆_ is a partial order.

⊆-refl : x ⊆ x
⊆-refl _ = id

⊆-trans : x ⊆ y → y ⊆ z → x ⊆ z
⊆-trans x⊆y y⊆z _ = y⊆z _ ∘ x⊆y _

⊆-antisymmetric : x ⊆ y → y ⊆ x → x ≡ y
⊆-antisymmetric x⊆y y⊆x =
  extensionality λ z →
    record { to = x⊆y z; from = y⊆x z }

------------------------------------------------------------------------
-- Another lemma

-- Equality can be expressed using _⊆_.

≡≃⊆×⊇ : (x ≡ y) ≃ (x ⊆ y × y ⊆ x)
≡≃⊆×⊇ {x = x} {y = y} =
  x ≡ y                  ↝⟨ Eq.⇔→≃
                              is-set
                              (×-closure 1 is-set is-set)
                              (λ x≡y →
                                   (x ∪ y  ≡⟨ cong (_∪ _) x≡y ⟩
                                    y ∪ y  ≡⟨ ∪-idem y ⟩∎
                                    y      ∎)
                                 , (y ∪ x  ≡⟨ cong (_∪ _) $ sym x≡y ⟩
                                    x ∪ x  ≡⟨ ∪-idem x ⟩∎
                                    x      ∎))
                              (λ (p , q) →
                                 x      ≡⟨ sym q ⟩
                                 y ∪ x  ≡⟨ ∪-comm y ⟩
                                 x ∪ y  ≡⟨ p ⟩∎
                                 y      ∎) ⟩
  x ∪ y ≡ y × y ∪ x ≡ x  ↝⟨ inverse $ ⊆≃∪≡ x ×-cong ⊆≃∪≡ y ⟩□
  x ⊆ y × y ⊆ x          □

-- Extensional equality is equivalent to equality.

∼≃≡ : (x ∼ y) ≃ (x ≡ y)
∼≃≡ {x = x} {y = y} =
  x ∼ y                                      ↔⟨⟩
  (∀ z → z ∈ x ⇔ z ∈ y)                      ↔⟨ (∀-cong ext λ _ → ⇔↔→×→) ⟩
  (∀ z → (z ∈ x → z ∈ y) × (z ∈ y → z ∈ x))  ↔⟨ ΠΣ-comm ⟩
  x ⊆ y × y ⊆ x                              ↝⟨ inverse ≡≃⊆×⊇ ⟩□
  x ≡ y                                      □

------------------------------------------------------------------------
-- Definitions related to the listed finite subsets defined in Listed

-- Some lemmas used below.

private

  module Listed≃Listed where

    -- Converts one kind of finite subset to another.

    from : Listed.Finite-subset-of A → Finite-subset-of A
    from = Listed.rec r
      where
      r : Listed.Rec _ _
      r .Listed.Rec.[]ʳ           = []
      r .Listed.Rec.∷ʳ x _ y      = x ∷ y
      r .Listed.Rec.dropʳ _ _ _   = drop
      r .Listed.Rec.swapʳ _ _ _ _ = swap
      r .Listed.Rec.is-setʳ       = is-set

    -- A lemma relating from, _∈_ and Listed._∈_.

    ∈from≃ : ∀ x → (z ∈ from x) ≃ (z Listed.∈ x)
    ∈from≃ {z = z} = Listed.elim-prop e
      where
      e : Listed.Elim-prop _
      e .Listed.Elim-prop.[]ʳ =
        z ∈ from Listed.[]    ↔⟨⟩
        ⊥                     ↔⟨ ⊥↔⊥ ⟩
        ⊥₀                    ↝⟨ inverse $ Listed.∈[]≃ ⟩
        z Listed.∈ Listed.[]  □

      e .Listed.Elim-prop.∷ʳ {y = y} x hyp =
        z ∈ from (x Listed.∷ y)  ↔⟨⟩
        z ≡ x ∥⊎∥ z ∈ from y     ↝⟨ F.id Trunc.∥⊎∥-cong hyp ⟩
        z ≡ x ∥⊎∥ z Listed.∈ y   ↝⟨ inverse Listed.∈∷≃ ⟩□
        z Listed.∈ x Listed.∷ y  □

      e .Listed.Elim-prop.is-propositionʳ _ =
        Eq.right-closure ext 0 Listed.∈-propositional

    -- A lemma relating from, _⊆_ and Listed._⊆_.

    from⊆from→ :
      (x y : Listed.Finite-subset-of A) →
      from x ⊆ from y → x Listed.⊆ y
    from⊆from→ = Listed.elim-prop e
      where
      e : Listed.Elim-prop _
      e .Listed.Elim-prop.[]ʳ = Listed.elim-prop e′
        where
        e′ : Listed.Elim-prop _
        e′ .Listed.Elim-prop.[]ʳ _ = Listed.⊆-refl

        e′ .Listed.Elim-prop.∷ʳ {y = y} x _ _ z =
          z Listed.∈ Listed.[]     ↔⟨ Listed.∈[]≃ ⟩
          ⊥₀                       ↝⟨ ⊥-elim ⟩□
          z Listed.∈ x Listed.∷ y  □

        e′ .Listed.Elim-prop.is-propositionʳ _ =
          Π-closure ext 1 λ _ →
          Listed.⊆-propositional

      e .Listed.Elim-prop.∷ʳ {y = y₁} x hyp₁ y₂ =
        from (x Listed.∷ y₁) ⊆ from y₂                   ↔⟨⟩
        (∀ z → z ≡ x ∥⊎∥ z ∈ from y₁ → z ∈ from y₂)      ↝⟨ (λ hyp₂ z → Trunc.rec Listed.∈-propositional
                                                                          [ (
            z ≡ x                                                            ↝⟨ Trunc.∣inj₁∣ ⟩
            z ≡ x ∥⊎∥ z ∈ from y₁                                            ↝⟨ hyp₂ z ⟩
            z ∈ from y₂                                                      ↔⟨ ∈from≃ _ ⟩□
            z Listed.∈ y₂                                                    □)
                                                                          , ($⟨ (λ z → hyp₂ z ∘ Trunc.∣inj₂∣) ⟩
            from y₁ ⊆ from y₂                                                ↝⟨ hyp₁ y₂ ⟩
            y₁ Listed.⊆ y₂                                                   ↝⟨ _$ z ⟩□
            (z Listed.∈ y₁ → z Listed.∈ y₂)                                  □)
                                                                          ]) ⟩
        (∀ z → z ≡ x ∥⊎∥ z Listed.∈ y₁ → z Listed.∈ y₂)  ↔⟨ (∀-cong ext λ _ → →-cong ext (inverse Listed.∈∷≃) F.id) ⟩□
        x Listed.∷ y₁ Listed.⊆ y₂                        □

      e .Listed.Elim-prop.is-propositionʳ _ =
        Π-closure ext 1 λ _ →
        Π-closure ext 1 λ _ →
        Listed.⊆-propositional

    -- The function from is injective.

    from-injective : Injective (from {A = A})
    from-injective {x = x} {y = y} =
      from x ≡ from y                    ↔⟨ ≡≃⊆×⊇ ⟩
      from x ⊆ from y × from y ⊆ from x  ↝⟨ Σ-map (from⊆from→ _ _) (from⊆from→ _ _) ⟩
      x Listed.⊆ y × y Listed.⊆ x        ↝⟨ uncurry Listed.⊆-antisymmetric ⟩□
      x ≡ y                              □

    -- Converts one kind of finite subset to another, and returns a
    -- partial correctness result.

    to :
      (x : Finite-subset-of A) →
      ∃ λ (y : Listed.Finite-subset-of A) → from y ≡ x
    to = elim e
      where
      e : Elim _
      e .Elim.[]ʳ = Listed.[] , refl _

      e .Elim.∷ʳ x (y , eq) = x Listed.∷ y , cong (x ∷_) eq

      e .Elim.is-propositionʳ x (y₁ , eq₁) (y₂ , eq₂) =
        Σ-≡,≡→≡
          (from-injective
             (from y₁  ≡⟨ eq₁ ⟩
              x        ≡⟨ sym eq₂ ⟩∎
              from y₂  ∎))
          (is-set _ _)

    -- Another correctness result.

    to-from :
      (x : Listed.Finite-subset-of A) →
      proj₁ (to (from x)) ≡ x
    to-from = Listed.elim-prop e
      where
      e : Listed.Elim-prop _
      e .Listed.Elim-prop.[]ʳ               = refl _
      e .Listed.Elim-prop.∷ʳ x              = cong (x Listed.∷_)
      e .Listed.Elim-prop.is-propositionʳ _ = Listed.is-set

-- The type of listed finite subsets defined above is pointwise
-- equivalent to the type of listed finite subsets defined in Listed.

Listed≃Listed : Finite-subset-of A ≃ Listed.Finite-subset-of A
Listed≃Listed = Eq.↔→≃ (proj₁ ∘ to) from to-from (proj₂ ∘ to)
  where
  open Listed≃Listed

-- The equivalence preserves membership.

∈≃∈ : ∀ y → (x ∈ y) ≃ (x Listed.∈ _≃_.to Listed≃Listed y)
∈≃∈ {x = x} y =
  x ∈ y                                                ↝⟨ ≡⇒↝ _ $ cong (_ ∈_) $ sym $ _≃_.left-inverse-of Listed≃Listed y ⟩
  x ∈ _≃_.from Listed≃Listed (_≃_.to Listed≃Listed y)  ↝⟨ ∈from≃ _ ⟩□
  x Listed.∈ _≃_.to Listed≃Listed y                    □
  where
  open Listed≃Listed

-- Another dependent eliminator (expressed using equality).
--
-- Note that the motive is not required to be propositional.

record Elim′ {A : Type a} (P : Finite-subset-of A → Type p) :
             Type (a ⊔ p) where
  no-eta-equality
  field
    []ʳ     : P []
    ∷ʳ      : ∀ x → P y → P (x ∷ y)
    dropʳ   : ∀ x (p : P y) →
              subst P (drop {x = x} {y = y}) (∷ʳ x (∷ʳ x p)) ≡ ∷ʳ x p
    swapʳ   : ∀ x y (p : P z) →
              subst P (swap {x = x} {y = y} {z = z}) (∷ʳ x (∷ʳ y p)) ≡
              ∷ʳ y (∷ʳ x p)
    is-setʳ : ∀ x → Is-set (P x)

open Elim′ public

elim′ : Elim′ P → (x : Finite-subset-of A) → P x
elim′ {P = P} e x =
  subst P (_≃_.left-inverse-of Listed≃Listed x)
    (Listed.elim e′ (_≃_.to Listed≃Listed x))
  where
  module E = Elim′ e

  e′ : Listed.Elim (P ∘ _≃_.from Listed≃Listed)
  e′ .Listed.[]ʳ = E.[]ʳ

  e′ .Listed.∷ʳ = E.∷ʳ

  e′ .Listed.dropʳ x p =
    subst (P ∘ _≃_.from Listed≃Listed)
      Listed.drop
      (e .∷ʳ x (e .∷ʳ x p))                        ≡⟨ subst-∘ _ _ _ ⟩

    subst P
      (cong (_≃_.from Listed≃Listed) Listed.drop)
      (e .∷ʳ x (e .∷ʳ x p))                        ≡⟨ cong (flip (subst P) _) $ is-set _ _ ⟩

    subst P drop (e .∷ʳ x (e .∷ʳ x p))             ≡⟨ e .dropʳ x p ⟩∎

    e .∷ʳ x p                                      ∎

  e′ .Listed.swapʳ x y p =
    subst (P ∘ _≃_.from Listed≃Listed)
      Listed.swap
      (e .∷ʳ x (e .∷ʳ y p))                        ≡⟨ subst-∘ _ _ _ ⟩

    subst P
      (cong (_≃_.from Listed≃Listed) Listed.swap)
      (e .∷ʳ x (e .∷ʳ y p))                        ≡⟨ cong (flip (subst P) _) $ is-set _ _ ⟩

    subst P swap (e .∷ʳ x (e .∷ʳ y p))             ≡⟨ e .swapʳ x y p ⟩∎

    e .∷ʳ y (e .∷ʳ x p)                            ∎

  e′ .Listed.is-setʳ _ = E.is-setʳ _


module Data.Interval where

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

lowerBound : {A : Set} -> Interval A -> A
lowerBound [ l ▻ u ] = l

upperBound : {A : Set} -> Interval A -> A
upperBound [ l ▻ u ] = u