module Pi-2 where

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

open import Groupoid

infixr 10 _◎_
infixr 30 _⟷_

------------------------------------------------------------------------------
-- Level -2
-- Types are -2 groupoids or equivalently all types are contractible or
-- equivalently all types have exactly one point

-- There is no interesting path structure but we have the trivial paths
-- explicitly below.

-- Types and values are defined mutually without reference to programs Types
-- always include PATHs in addition to the usual types.

mutual

  data U : Set where
    ONE   : U
    TIMES : U → U → U
    PATH  : {t : U} → ⟦ t ⟧ → ⟦ t ⟧ → U

  ⟦_⟧ : U → Set
  ⟦ ONE ⟧         = ⊤
  ⟦ TIMES t₁ t₂ ⟧ = ⟦ t₁ ⟧ × ⟦ t₂ ⟧
  ⟦ PATH v₁ v₂ ⟧  = (v₁ ≡ v₂)

-- Proof that all types are contractible. Def. 3.11.1 in the HoTT book

isContr : (t : U) → Σ[ v ∈ ⟦ t ⟧ ] ((v' : ⟦ t ⟧) → (v ≡ v'))
isContr ONE = (tt , λ v → refl)
isContr (TIMES t₁ t₂) with isContr t₁ | isContr t₂
... | (v₁ , f₁) | (v₂ , f₂) = ((v₁ , v₂) , f)
  where f : (vv : ⟦ t₁ ⟧ × ⟦ t₂ ⟧) → (v₁ , v₂) ≡ vv
        f (v₁' , v₂') = cong₂ _,′_ (f₁ v₁') (f₂ v₂')
isContr (PATH {t} v₁ v₂) with isContr t
isContr (PATH {t} v₁ v₂) | (v' , f') = (p , λ q → proof-irrelevance p q)
  where p = trans (sym (f' v₁))  (f' v₂)

-- Proof that every type is a groupoid; this does not depend on the
-- definition of programs

isGroupoid : U → 1Groupoid
isGroupoid ONE              = discrete ⊤
isGroupoid (TIMES t₁ t₂)    = isGroupoid t₁ ×G isGroupoid t₂
isGroupoid (PATH {t} v₁ v₂) = discrete (v₁ ≡ v₂)

-- Programs
-- We use pointed types; programs map a pointed type to another
-- In other words, each program takes one particular value to another; if we
-- want to work on another value, we generally use another program

record U• : Set where
  constructor •[_,_]
  field
    ∣_∣ : U
    • : ⟦ ∣_∣ ⟧

open U•

Space : (t• : U•) → Set
Space •[ t , v ] = ⟦ t ⟧

point : (t• : U•) → Space t•
point •[ t , v ] = v

data _⟷_ : U• → U• → Set where
  id⟷    : {t : U•} → t ⟷ t
  sym⟷   : {t₁ t₂ : U•} → (t₁ ⟷ t₂) → (t₂ ⟷ t₁)
  _◎_     : {t₁ t₂ t₃ : U•} → (t₁ ⟷ t₂) → (t₂ ⟷ t₃) → (t₁ ⟷ t₃)
  unite⋆  : {t : U•} → •[ TIMES ONE ∣ t ∣ , (tt , • t) ] ⟷ t
  uniti⋆  : {t : U•} → t ⟷ •[ TIMES ONE ∣ t ∣ , (tt , • t) ]
  swap⋆   : {t₁ t₂ : U•} → •[ TIMES ∣ t₁ ∣ ∣ t₂ ∣ , (• t₁ , • t₂) ] ⟷
                           •[ TIMES ∣ t₂ ∣ ∣ t₁ ∣ , (• t₂ , • t₁) ]
  assocl⋆ : {t₁ t₂ t₃ : U•} →
           •[ TIMES ∣ t₁ ∣ (TIMES ∣ t₂ ∣ ∣ t₃ ∣) , (• t₁ , (• t₂ , • t₃)) ] ⟷
           •[ TIMES (TIMES ∣ t₁ ∣ ∣ t₂ ∣) ∣ t₃ ∣ , ((• t₁ , • t₂) , • t₃) ]
  assocr⋆ : {t₁ t₂ t₃ : U•} →
           •[ TIMES (TIMES ∣ t₁ ∣ ∣ t₂ ∣) ∣ t₃ ∣ , ((• t₁ , • t₂) , • t₃) ] ⟷
           •[ TIMES ∣ t₁ ∣ (TIMES ∣ t₂ ∣ ∣ t₃ ∣) , (• t₁ , (• t₂ , • t₃)) ]
  _⊗_     : {t₁ t₂ t₃ t₄ : U•} → (t₁ ⟷ t₃) → (t₂ ⟷ t₄) →
            (•[ TIMES ∣ t₁ ∣ ∣ t₂ ∣ , (• t₁ , • t₂ ) ] ⟷
             •[ TIMES ∣ t₃ ∣ ∣ t₄ ∣ , (• t₃ , • t₄ ) ])

-- Proof that the universe is itself a groupoid; this DOES depend on the
-- definition of programs; the morphisms between types ARE the programs; all
-- programs between the same types are forced to be the same using a
-- degenerate observational equivalence relation.

_obs≅_ : {t₁ t₂ : U•} → (c₁ c₂ : t₁ ⟷ t₂) → Set
c₁ obs≅ c₂ = ⊤

UG : 1Groupoid
UG = record
       { set = U•
       ; _↝_ = _⟷_
       ; _≈_ = _obs≅_
       ; id = id⟷
       ; _∘_ = λ y⟷z x⟷y → x⟷y ◎ y⟷z
       ; _⁻¹ = sym⟷
       ; lneutr = λ _ →  tt
       ; rneutr = λ _ → tt
       ; assoc = λ _ _ _ → tt
       ; equiv = record { refl = tt
                        ; sym = λ _ → tt
                        ; trans = λ _ _ → tt
                        }
       ; linv = λ _ → tt
       ; rinv = λ _ → tt
       ; ∘-resp-≈ = λ _ _ → tt
       }

-- Examples

ONE• ONE×ONE• : U•
ONE•     = •[ ONE , tt ]
ONE×ONE• = •[ TIMES ONE ONE , (tt , tt) ]

PathSpace : {t : U•} → ⟦ ∣ t ∣ ⟧ → U•
PathSpace v = •[ PATH v v , refl ]

c₁ c₂ c₃ : ONE• ⟷ ONE•
c₁ = id⟷
c₂ = uniti⋆ ◎ swap⋆ ◎ unite⋆
c₃ = uniti⋆ ◎ uniti⋆ ◎ assocl⋆ ◎ (swap⋆ ⊗ (sym⟷ id⟷)) ◎
     assocr⋆ ◎ unite⋆ ◎ unite⋆

-- The evaluation of a program like c₁, c₂, c₃ above is not done in order to
-- figure out the output value. Both the input and output values are encoded
-- in the type of the program; what the evaluation does is follow the path to
-- constructively reach the ouput value from the input value. Even though the
-- programs are observationally equivalent, they follow different paths. The
-- next level will allow us to reason about which of these paths are
-- connected by 2paths etc. In general, one write programs at level i, and
-- reasons about their (observational) equivalence at levels i+1 and
-- higher. It is always possible to stop this game and use extensional
-- equality at some level, i.e., to equate all programs that connect the same
-- input and output values.

c₄ : ONE×ONE• ⟷ ONE•
c₄ = unite⋆

c₅ : PathSpace tt ⟷ PathSpace tt
c₅ = id⟷

c₁≅c₂ : c₁ obs≅ c₂
c₁≅c₂ = tt

-- the following does not typecheck
-- c₁≅c₄ : c₁ obs≅ c₄
-- it is not possible to equate programs that go between different types/values.

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


module Prelude.Data.Natural where

open import Prelude.Core
open import Prelude.Classes
open import Prelude.Orders

----------------
-- Conversion --
----------------

record ToNatural {ℓ} (A : Set ℓ) : Set ℓ where
  constructor mk[ToNatural]
  field
    𝕟 : A → ℕ
open ToNatural {{…}}

-----------
-- Order --
-----------

data _≤ⁿ_ : ℕ → ℕ → Set where
  Zero : ∀ {n} → Zero ≤ⁿ n
  Succ : ∀ {n₁ n₂} → n₁ ≤ⁿ n₂ → Succ n₁ ≤ⁿ Succ n₂

xRx⸢≤ⁿ⸣ : reflexive _≤ⁿ_
xRx⸢≤ⁿ⸣ {Zero} = Zero
xRx⸢≤ⁿ⸣ {Succ n} = Succ xRx⸢≤ⁿ⸣

⋈⸢≤ⁿ⸣ : antisymmetric _≤ⁿ_
⋈⸢≤ⁿ⸣ Zero Zero = ↯
⋈⸢≤ⁿ⸣ (Succ n₁≤n₂) (Succ n₂≤n₁) = res[•x] $ ⋈⸢≤ⁿ⸣ n₁≤n₂ n₂≤n₁

_⊚⸢≤ⁿ⸣_ : transitive _≤ⁿ_
n₁≤n₂ ⊚⸢≤ⁿ⸣ Zero = Zero
Succ n₂≤n₃ ⊚⸢≤ⁿ⸣ Succ n₁≤n₂ = Succ (n₂≤n₃ ⊚⸢≤ⁿ⸣ n₁≤n₂)

data _<ⁿ_ : ℕ → ℕ → Set where
  Zero : ∀ {n} → Zero <ⁿ Succ n
  Succ : ∀ {n₁ n₂} → n₁ <ⁿ n₂ → Succ n₁ <ⁿ Succ n₂

weaken[<]ⁿ : ∀ {n₁ n₂} → n₁ <ⁿ n₂ → n₁ ≤ⁿ n₂
weaken[<]ⁿ Zero = Zero
weaken[<]ⁿ (Succ <₁) = Succ (weaken[<]ⁿ <₁)

strict[<]ⁿ : ∀ {n₁ n₂} → n₁ <ⁿ n₂ → ¬ (n₂ ≤ⁿ n₁)
strict[<]ⁿ Zero ()
strict[<]ⁿ (Succ <₁) (Succ ≤₁) = strict[<]ⁿ <₁ ≤₁

complete[<]ⁿ : ∀ {n₁ n₂} → n₁ ≤ⁿ n₂ → ¬ (n₂ ≤ⁿ n₁) → n₁ <ⁿ n₂
complete[<]ⁿ {n₂ = Zero} Zero ¬≤ = exfalso (¬≤ Zero)
complete[<]ⁿ {n₂ = Succ n₂} Zero ¬≤ = Zero
complete[<]ⁿ (Succ ≤₁) ¬≤ = Succ (complete[<]ⁿ ≤₁ (λ ≤₂ → ¬≤ (Succ ≤₂)))

_⋚ⁿ_ : ℕ → ℕ → ⪥!
Zero ⋚ⁿ Zero = [≡]
Zero ⋚ⁿ Succ n₂ = [<]
Succ n₁ ⋚ⁿ Zero = [>]
Succ n₁ ⋚ⁿ Succ n₂ = n₁ ⋚ⁿ n₂

_⋚ⁿᴾ_ : ∀ n₁ n₂ → n₁ ⪥!ᴾ[ _<ⁿ_ ] n₂
Zero ⋚ⁿᴾ Zero = [≡] ↯
Zero ⋚ⁿᴾ Succ n₂ = [<] Zero
Succ n₁ ⋚ⁿᴾ Zero = [>] Zero
Succ n₁ ⋚ⁿᴾ Succ n₂ with n₁ ⋚ⁿᴾ n₂
… | [<] <₀ = [<] (Succ <₀)
… | [≡] ≡₀ rewrite ≡₀ = [≡] ↯
… | [>] >₀ = [>] (Succ >₀)

_⋚ⁿᴸ_ : ∀ n₁ n₂ → n₁ ⪥!ᴸ[ _<ⁿ_ ] n₂ ‖[ n₁ ⋚ⁿ n₂ , n₁ ⋚ⁿᴾ n₂ ]
Zero ⋚ⁿᴸ Zero = [≡]
Zero ⋚ⁿᴸ Succ n₂ = [<]
Succ n₁ ⋚ⁿᴸ Zero = [>]
Succ n₁ ⋚ⁿᴸ Succ n₂ with n₁ ⋚ⁿ n₂ | n₁ ⋚ⁿᴾ n₂ | n₁ ⋚ⁿᴸ n₂
… | [<] | [<] <₀ | [<] = [<]
… | [≡] | [≡] ≡₀ | [≡] rewrite ≡₀ = [≡]
… | [>] | [>] >₀ | [>] = [>]

instance
  Reflexive[≤]ⁿ : Reflexive _≤ⁿ_
  Reflexive[≤]ⁿ = record { xRx = xRx⸢≤ⁿ⸣ }
  Antisymmetric[≤]ⁿ : Antisymmetric _≤ⁿ_
  Antisymmetric[≤]ⁿ = record { ⋈ = ⋈⸢≤ⁿ⸣ }
  Transitive[≤]ⁿ : Transitive _≤ⁿ_
  Transitive[≤]ⁿ = record { _⊚_ = _⊚⸢≤ⁿ⸣_ }
  Strict[<]ⁿ : Strict _≤ⁿ_ _<ⁿ_
  Strict[<]ⁿ = record
    { weaken[≺] = weaken[<]ⁿ
    ; strict[≺] = strict[<]ⁿ
    ; complete[≺] = complete[<]ⁿ
    }
  Irreflexive[<]ⁿ : Irreflexive _<ⁿ_
  Irreflexive[<]ⁿ = Irreflexive[<]/≤ _≤ⁿ_ _<ⁿ_
  Asymmetric[<]ⁿ : Asymmetric _<ⁿ_
  Asymmetric[<]ⁿ = Asymmetric[<]/≤ _≤ⁿ_ _<ⁿ_
  Transitive[<]ⁿ : Transitive _<ⁿ_
  Transitive[<]ⁿ = Transitive[<]/≤ _≤ⁿ_ _<ⁿ_
  Totally[<]ⁿ : Totally _<ⁿ_
  Totally[<]ⁿ = record
    { _⪥_ = _⋚ⁿ_
    ; _⪥ᴾ_ = _⋚ⁿᴾ_
    ; _⪥ᴸ_ = _⋚ⁿᴸ_
    }
  Order[ℕ] : Order 0ᴸ ℕ
  Order[ℕ] = mk[Order] _≤ⁿ_ _<ⁿ_

weaken[≤]ⁿ : ∀ {n₁ n₂} → n₁ ≤ⁿ n₂ → n₁ ≤ⁿ Succ n₂
weaken[≤]ⁿ Zero = Zero
weaken[≤]ⁿ (Succ n₁≤n₂) = Succ (weaken[≤]ⁿ n₁≤n₂)

pred[≤]ⁿ : ∀ {n₁ n₂} → Succ n₁ ≤ⁿ n₂ → n₁ ≤ⁿ n₂
pred[≤]ⁿ (Succ x) = weaken[≤]ⁿ x

n≤succ : ∀ {n : ℕ} → n ≤ⁿ Succ n
n≤succ = weaken[≤]ⁿ xRx

rel[</≤]ⁿ : ∀ {n₁ n₂} → n₁ <ⁿ n₂ ↔ Succ n₁ ≤ⁿ n₂
rel[</≤]ⁿ = ⟨ LHS , RHS ⟩
  where
    LHS : ∀ {n₁ n₂} → n₁ <ⁿ n₂ → Succ n₁ ≤ⁿ n₂
    LHS Zero = Succ Zero
    LHS (Succ <₁) = Succ (LHS <₁)
    RHS : ∀ {n₁ n₂} → Succ n₁ ≤ⁿ n₂ → n₁ <ⁿ n₂
    RHS {Zero} (Succ ≤₁) = Zero
    RHS {Succ n₃} (Succ ≤₁) = Succ (RHS ≤₁)

------------------
-- ≤ⁿ Decidable --
------------------

instance
  DecRel[≡]ⁿ : DecRel (_≡_ {A = ℕ})
  DecRel[≡]ⁿ = record
    { _⁇_ = ⁇[≡]/⪥[] _≤_ _<_
    ; _⁇ᴾ_ = ⁇ᴾ[≡]/⪥[] _≤_ _<_
    ; _⁇ᴸ_ = ⁇ᴸ[≡]/⪥[] _≤_ _<_
    }
  DecRel[≤]ⁿ : DecRel _≤ⁿ_
  DecRel[≤]ⁿ = record
    { _⁇_ = ⁇[≤]/⪥[] _≤_ _<_
    ; _⁇ᴾ_ = ⁇ᴾ[≤]/⪥[] _≤_ _<_
    ; _⁇ᴸ_ = ⁇ᴸ[≤]/⪥[] _≤_ _<_
    }
  DecRel[<]ⁿ : DecRel _<ⁿ_
  DecRel[<]ⁿ = record
    { _⁇_ = ⁇[<]/⪥[] _≤_ _<_
    ; _⁇ᴾ_ = ⁇ᴾ[<]/⪥[] _≤_ _<_
    ; _⁇ᴸ_ = ⁇ᴸ[<]/⪥[] _≤_ _<_
    }

--------------
-- Addition --
--------------

_+ⁿ_ : ℕ → ℕ → ℕ
Zero +ⁿ n₂ = n₂
Succ n₁ +ⁿ n₂ = Succ (n₁ +ⁿ n₂)

left-unit[+]ⁿ : ∀ (n : ℕ) → 0 +ⁿ n ≡ n
left-unit[+]ⁿ n = ↯

right-unit[+]ⁿ : ∀ (n : ℕ) → n +ⁿ 0 ≡ n
right-unit[+]ⁿ Zero = ↯
right-unit[+]ⁿ (Succ n) rewrite right-unit[+]ⁿ n = ↯

associative[+]ⁿ : ∀ (n₁ n₂ n₃ : ℕ) → (n₁ +ⁿ n₂) +ⁿ n₃ ≡ n₁ +ⁿ (n₂ +ⁿ n₃)
associative[+]ⁿ Zero n₂ n₃ = ↯
associative[+]ⁿ (Succ n₁) n₂ n₃ rewrite associative[+]ⁿ n₁ n₂ n₃ = ↯

m+suc[n]=suc[m+n] : ∀ (n₁ n₂ : ℕ) → n₁ +ⁿ Succ n₂ ≡ Succ (n₁ +ⁿ n₂)
m+suc[n]=suc[m+n] Zero n₂ = ↯
m+suc[n]=suc[m+n] (Succ n₁) n₂ rewrite m+suc[n]=suc[m+n] n₁ n₂ = ↯

suc[m+n]=m+suc[n] : ∀ (n₁ n₂ : ℕ) → Succ (n₁ +ⁿ n₂) ≡ n₁ +ⁿ Succ n₂
suc[m+n]=m+suc[n] n₁ n₂ = ◇ $ m+suc[n]=suc[m+n] n₁ n₂

commutative[+]ⁿ : ∀ (n₁ n₂ : ℕ) → n₁ +ⁿ n₂ ≡ n₂ +ⁿ n₁
commutative[+]ⁿ Zero n₂ rewrite right-unit[+]ⁿ n₂ = ↯
commutative[+]ⁿ (Succ n₁) n₂ rewrite commutative[+]ⁿ n₁ n₂ | suc[m+n]=m+suc[n] n₂ n₁ = ↯

instance
  Additive[ℕ] : Additive ℕ
  Additive[ℕ] = record
    { zero = Zero
    ; _+_ = _+ⁿ_
    ; left-unit[+] = left-unit[+]ⁿ
    ; right-unit[+] = right-unit[+]ⁿ
    ; associative[+] = associative[+]ⁿ
    ; commutative[+] = commutative[+]ⁿ
    }

--------------------
-- Multiplication --
--------------------

oneⁿ : ℕ
oneⁿ = Succ Zero

_×ⁿ_ : ℕ → ℕ → ℕ
Zero ×ⁿ n₂ = Zero
Succ n₁ ×ⁿ n₂ = n₂ +ⁿ (n₁ ×ⁿ n₂)

left-zero[×]ⁿ : ∀ n → zero ×ⁿ n ≡ zero
left-zero[×]ⁿ n = ↯

right-zero[×]ⁿ : ∀ n → n ×ⁿ zero ≡ zero
right-zero[×]ⁿ Zero = ↯
right-zero[×]ⁿ (Succ n) rewrite right-zero[×]ⁿ n = ↯

left-unit[×]ⁿ : ∀ n → oneⁿ ×ⁿ n ≡ n
left-unit[×]ⁿ n = right-unit[+]ⁿ n

right-unit[×]ⁿ : ∀ n → n ×ⁿ oneⁿ ≡ n
right-unit[×]ⁿ Zero = ↯
right-unit[×]ⁿ (Succ n) rewrite right-unit[×]ⁿ n = ↯

distributive[×]ⁿ : ∀ n₁ n₂ n₃ → (n₁ +ⁿ n₂) ×ⁿ n₃ ≡ (n₁ ×ⁿ n₃) +ⁿ (n₂ ×ⁿ n₃)
distributive[×]ⁿ Zero n₂ n₃ = ↯
distributive[×]ⁿ (Succ n₁) n₂ n₃ rewrite distributive[×]ⁿ n₁ n₂ n₃ | associative[+]ⁿ n₃ (n₁ ×ⁿ n₃) (n₂ ×ⁿ n₃) = ↯

associative[×]ⁿ : ∀ n₁ n₂ n₃ → (n₁ ×ⁿ n₂) ×ⁿ n₃ ≡ n₁ ×ⁿ (n₂ ×ⁿ n₃)
associative[×]ⁿ Zero n₂ n₃ = ↯
associative[×]ⁿ (Succ n₁) n₂ n₃ rewrite distributive[×]ⁿ n₂ (n₁ ×ⁿ n₂) n₃ | associative[×]ⁿ n₁ n₂ n₃ = ↯

commutative[×]ⁿ : ∀ n₁ n₂ → n₁ ×ⁿ n₂ ≡ n₂ ×ⁿ n₁
commutative[×]ⁿ Zero n₂ rewrite right-zero[×]ⁿ n₂ = ↯
commutative[×]ⁿ n₁ Zero rewrite right-zero[×]ⁿ n₁ = ↯
commutative[×]ⁿ (Succ n₁) (Succ n₂)
  rewrite commutative[×]ⁿ n₁ (Succ n₂)
        | commutative[×]ⁿ n₂ (Succ n₁)
        | commutative[×]ⁿ n₁ n₂
        | ◇ $ associative[+]ⁿ n₁ n₂ (n₂ ×ⁿ n₁)
        | commutative[+]ⁿ n₁ n₂
        | associative[+]ⁿ n₂ n₁ (n₂ ×ⁿ n₁)
        = ↯

instance
  Multiplicative[ℕ] : Multiplicative ℕ
  Multiplicative[ℕ] = record
    { one = oneⁿ
    ; _×_ = _×ⁿ_
    ; left-zero[×] = left-zero[×]ⁿ
    ; right-zero[×] = right-zero[×]ⁿ
    ; left-unit[×] = left-unit[×]ⁿ
    ; right-unit[×] = right-unit[×]ⁿ
    ; associative[×] = associative[×]ⁿ
    ; commutative[×] = commutative[×]ⁿ
    ; distributive[×] = distributive[×]ⁿ
    }

-----------------
-- Subtraction --
-----------------

_-ⁿ_‖_ : ∀ (n₁ n₂ : ℕ) → n₂ ≤ n₁ → ℕ
n₁ -ⁿ Zero ‖ Zero = n₁
Succ n₁ -ⁿ Succ n₂ ‖ Succ n₁≤n₂ = n₁ -ⁿ n₂ ‖ n₁≤n₂

correct[-ⁿ‖] : ∀ n₁ n₂ (n₂≤n₁ : n₂ ≤ n₁) → n₂ + (n₁ -ⁿ n₂ ‖ n₂≤n₁) ≡ n₁
correct[-ⁿ‖] n₁ Zero Zero = ↯
correct[-ⁿ‖] (Succ n₁) (Succ n₂) (Succ n₂≤n₁) rewrite correct[-ⁿ‖] n₁ n₂ n₂≤n₁ = ↯

n-n=0 : ∀ n → n -ⁿ n ‖ xRx ≡ Zero
n-n=0 Zero = ↯
n-n=0 (Succ n) rewrite n-n=0 n = ↯

n-0=n : ∀ n → n -ⁿ 0 ‖ Zero ≡ n
n-0=n n = ↯

suc[m-n]=suc[m]-n : ∀ n₁ n₂ (n₂≤n₁ : n₂ ≤ n₁) → Succ (n₁ -ⁿ n₂ ‖ n₂≤n₁) ≡ Succ n₁ -ⁿ n₂ ‖ weaken[≤]ⁿ n₂≤n₁
suc[m-n]=suc[m]-n n₁ Zero Zero = ↯
suc[m-n]=suc[m]-n (Succ n₁) (Succ n₂) (Succ n₂≤n₁) rewrite suc[m-n]=suc[m]-n n₁ n₂ n₂≤n₁ = ↯

instance
  Subtractive/OK[ℕ] : Subtractive/OK ℕ
  Subtractive/OK[ℕ] = record { ok[_-_] = _≥_ }
  Subtractive[ℕ] : Subtractive/P ℕ
  Subtractive[ℕ] = record
    { _-_‖_ = _-ⁿ_‖_
    ; correct[-‖] = correct[-ⁿ‖]
    }

_-%ⁿ_ : ∀ (n₁ n₂ : ℕ) → ℕ ∨ ℕ
Zero -%ⁿ n₂ = Inr n₂
n₁ -%ⁿ Zero = Inl n₁
Succ n₁ -%ⁿ Succ n₂ = n₁ -%ⁿ n₂

correct[-%ⁿ]/spec : ℕ → ℕ → Set
correct[-%ⁿ]/spec n₁ n₂ with n₁ -%ⁿ n₂
… | Inl n = n₂ + n ≡ n₁
… | Inr n = n₁ + n ≡ n₂

correct[-%ⁿ] : ∀ n₁ n₂ → correct[-%ⁿ]/spec n₁ n₂
correct[-%ⁿ] Zero Zero = ↯
correct[-%ⁿ] Zero (Succ n₂) = ↯
correct[-%ⁿ] (Succ n₁) Zero = ↯
correct[-%ⁿ] (Succ n₁) (Succ n₂) with n₁ -%ⁿ n₂ | correct[-%ⁿ] n₁ n₂
… | Inl x | IH rewrite IH = ↯
… | Inr x | IH rewrite IH = ↯

--------------------------
-- Division and Modulus --
--------------------------

divmod-loop : ∀ (n₁ n₂ quo n₂-rem : ℕ) → n₂-rem ≤ n₂ → ∃ quo,n₂-rem ⦂ ℕ ∧ ℕ 𝑠𝑡 let ⟨ quo' , n₂-rem' ⟩ = quo,n₂-rem in n₂-rem' ≤ n₂
divmod-loop Zero n₂ quo n₂-rem n₂-rem≤n₂ = ⟨∃ ⟨ quo , n₂-rem ⟩ , n₂-rem≤n₂ ⟩
divmod-loop (Succ n₁) n₂ quo Zero n₂-rem≤n₂ = divmod-loop n₁ n₂ (Succ quo) n₂ xRx
divmod-loop (Succ n₁) n₂ quo (Succ n₂-rem) n₂-rem≤n₂ = divmod-loop n₁ n₂ quo n₂-rem (pred[≤]ⁿ n₂-rem≤n₂)

correct[divmod-loop] :
  ∀ (n₁ n₂ quo n₂-rem : ℕ) (n₂-rem≤n₂ : n₂-rem ≤ n₂)
  → let ⟨∃ ⟨ quo' , n₂-rem' ⟩ , n₂-rem'≤n₂ ⟩ = divmod-loop n₁ n₂ quo n₂-rem n₂-rem≤n₂ in
    quo' × Succ n₂ + (n₂ - n₂-rem' ‖ n₂-rem'≤n₂) ≡ n₁ + (quo × Succ n₂) + (n₂ - n₂-rem ‖ n₂-rem≤n₂)
correct[divmod-loop] Zero n₂ quo n₂-rem n₂-rem≤n₂ = ↯
correct[divmod-loop] (Succ n₁) n₂ quo Zero Zero
  with divmod-loop n₁ n₂ (Succ quo) n₂ xRx
     | correct[divmod-loop] n₁ n₂ (Succ quo) n₂ xRx
… | ⟨∃ ⟨ quo' , n₂-rem' ⟩ , n₂-rem'≤n₂ ⟩ | IH
  rewrite suc[m+n]=m+suc[n] n₁ (quo × Succ n₂ + n₂ - Zero ‖ Zero)
        | n-n=0 n₂
        | commutative[+] (quo × Succ n₂) n₂
        | right-unit[+] (n₂ + quo × Succ n₂)
        = IH
correct[divmod-loop] (Succ n₁) (Succ n₂) quo (Succ n₂-rem) (Succ n₂-rem≤n₂)
  with divmod-loop n₁ (Succ n₂) quo n₂-rem (weaken[≤]ⁿ n₂-rem≤n₂)
     | correct[divmod-loop] n₁ (Succ n₂) quo n₂-rem (weaken[≤]ⁿ n₂-rem≤n₂)
… | ⟨∃ ⟨ quo' , n₂-rem' ⟩ , n₂-rem'≤n₂ ⟩ | IH
  rewrite suc[m+n]=m+suc[n] n₁ (quo × Succ (Succ n₂) + n₂ - n₂-rem ‖ n₂-rem≤n₂)
        | suc[m+n]=m+suc[n] (quo × Succ (Succ n₂)) (n₂ - n₂-rem ‖ n₂-rem≤n₂)
        | suc[m-n]=suc[m]-n n₂ n₂-rem n₂-rem≤n₂
        = IH

_/%ⁿ_‖_ : ∀ (n₁ n₂ : ℕ) (0<n₂ : 0 < n₂) → ℕ ∧ ℕ
n₁ /%ⁿ Succ n₂ ‖ Zero with divmod-loop n₁ n₂ 0 n₂ xRx⸢≤ⁿ⸣
… | ⟨∃ ⟨ quo , n₂-rem ⟩ , n₂-rem≤n₂ ⟩ = ⟨ quo , n₂ - n₂-rem ‖ n₂-rem≤n₂ ⟩

correct[/%‖]ⁿ : ∀ n₁ n₂ (0<n₂ : 0 < n₂) → let ⟨ quo , rem ⟩ = n₁ /%ⁿ n₂ ‖ 0<n₂ in n₂ × quo + rem ≡ n₁
correct[/%‖]ⁿ n₁ (Succ n₂) Zero with divmod-loop n₁ n₂ 0 n₂ xRx | correct[divmod-loop] n₁ n₂ 0 n₂ xRx
… | ⟨∃ ⟨ quo , n₂-rem ⟩ , n₂-rem≤n₂ ⟩ | H rewrite n-n=0 n₂ | right-unit[+] n₁ | commutative[×] quo (Succ n₂) = H

instance
  DivMod/OK[ℕ] : DivMod/OK ℕ
  DivMod/OK[ℕ] = record
    { ok[_/%_] = (λ n₁ n₂ → 0 < n₂) }
  DivMod[ℕ] : DivMod/P ℕ
  DivMod[ℕ] = record
    { _/%_‖_ = _/%ⁿ_‖_
    ; correct[/%‖] = correct[/%‖]ⁿ
    }

-------------
-- Bounded --
-------------

record ℕ≤[_] (nᵇ : ℕ) : Set where
  constructor mk[ℕ≤]
  field
    n : ℕ
    n≤nᵇ : n ≤ nᵇ

-- mk↯[ℕ≤] : ∀ {nᵇ} n → {{_ : ✓‼ (n ⁇[ _≤_ ] nᵇ)}} → ℕ≤[ nᵇ ]
-- mk↯[ℕ≤] {nᵇ} n {{_}} with n ⁇[ _≤_ ] nᵇ |
-- mk↯[ℕ≤] {nᵇ} n {{↯Rel}} | Rel n≤nᵇ = mk[ℕ≤] n n≤nᵇ

weaken[ℕ≤] : ∀ {nᵇ₁ nᵇ₂} → nᵇ₁ ≤ nᵇ₂ → ℕ≤[ nᵇ₁ ] → ℕ≤[ nᵇ₂ ]
weaken[ℕ≤] nᵇ₁≤nᵇ₂ (mk[ℕ≤] n n≤nᵇ₁) = mk[ℕ≤] n (nᵇ₁≤nᵇ₂ ⊚ n≤nᵇ₁)

instance
  ToNatural[ℕ≤] : ∀ {nᵇ} → ToNatural ℕ≤[ nᵇ ]
  ToNatural[ℕ≤] = mk[ToNatural] ℕ≤[_].n

record ℕ<[_] (nᵇ : ℕ) : Set where
  constructor mk[ℕ<]
  field
    n : ℕ
    n<nᵇ : n < nᵇ

-- mk↯[ℕ<] : ∀ {nᵇ} n → {{_ : rel (dec-rel[ _<_ ] n nᵇ)}} → ℕ<[ nᵇ ]
-- mk↯[ℕ<] {nᵇ} n {{_}} with dec-rel[ _<_ ] n nᵇ
-- mk↯[ℕ<] {nᵇ} n {{↯Rel}} | Rel n<nᵇ = mk[ℕ<] n n<nᵇ

weaken[ℕ<] : ∀ {nᵇ₁ nᵇ₂} → nᵇ₁ ≤ nᵇ₂ → ℕ<[ nᵇ₁ ] → ℕ<[ nᵇ₂ ]
weaken[ℕ<] nᵇ₁≤nᵇ₂ (mk[ℕ<] n n<nᵇ₁) = mk[ℕ<] n $ π₂ rel[</≤]ⁿ $ nᵇ₁≤nᵇ₂ ⊚ π₁ rel[</≤]ⁿ n<nᵇ₁

instance
  ToNatural[ℕ<] : ∀ {nᵇ} → ToNatural ℕ<[ nᵇ ]
  ToNatural[ℕ<] = mk[ToNatural] ℕ<[_].n

data fin : ℕ → Set where
  Zero : ∀ {n} → fin (Succ n)
  Succ : ∀ {n} → fin n → fin (Succ n)

mk[fin/<] : ∀ {nᵇ} n → n < nᵇ → fin nᵇ
mk[fin/<] Zero Zero = Zero
mk[fin/<] (Succ n) (Succ <₁) = Succ (mk[fin/<] n <₁)

mk[fin/ℕ<] : ∀ {nᵇ} → ℕ<[ nᵇ ] → fin nᵇ
mk[fin/ℕ<] (mk[ℕ<] n n<nᵇ) = mk[fin/<] n n<nᵇ

record ℕ⁺ : Set where
  constructor mk[ℕ⁺]
  field
    n : ℕ
    0<n : 0 < n

-- mk↯[ℕ⁺] : ∀ n {{_ : rel (dec-rel[ _<_ ] 0 n)}} → ℕ⁺
-- mk↯[ℕ⁺] n {{_}} with dec-rel[ _<_ ] 0 n
-- mk↯[ℕ⁺] n {{↯Rel}} | Rel 0<n = mk[ℕ⁺] n 0<n

instance
  ToNatural[ℕ⁺] : ToNatural ℕ⁺
  ToNatural[ℕ⁺] = mk[ToNatural] ℕ⁺.n


------------------------------------------------------------------------
-- Alpha-equivalence
------------------------------------------------------------------------

open import Atom

module Alpha-equivalence (atoms : χ-atoms) where

open import Equality.Propositional
open import Prelude hiding (const)

open import Bag-equivalence equality-with-J using (_∈_)
import Nat equality-with-J as Nat

open import Chi            atoms
open import Free-variables atoms

open χ-atoms atoms

private
  variable
    A                          : Type
    b₁ b₂                      : Br
    bs₁ bs₂                    : List Br
    c c₁ c₂                    : Const
    e e₁ e₂ e₃ e₁₁ e₁₂ e₂₁ e₂₂ : Exp
    es₁ es₂                    : List Exp
    R R₁ R₂                    : A → A → Type
    x x₁ x₁′ x₂ x₂′ y          : A
    xs xs₁ xs₂                 : List A

------------------------------------------------------------------------
-- The definition of α-equivalence

-- R [ x ∼ y ] relates x to y, and for pairs of variables x′, y′ such
-- that x is distinct from x′ and y is distinct from y′ it behaves
-- like R.

infix 5 _[_∼_]

_[_∼_] : (Var → Var → Type) → Var → Var → (Var → Var → Type)
(R [ x ∼ y ]) x′ y′ =
  x ≡ x′ × y ≡ y′
    ⊎
  x ≢ x′ × y ≢ y′ × R x′ y′

-- Alpha-⋆ lifts a binary relation to lists.

infixr 5 _∷_

data Alpha-⋆ (R : A → A → Type) : List A → List A → Type where
  []  : Alpha-⋆ R [] []
  _∷_ : R x₁ x₂ →
        Alpha-⋆ R xs₁ xs₂ →
        Alpha-⋆ R (x₁ ∷ xs₁) (x₂ ∷ xs₂)

-- Alpha R is α-equivalence up to R: free variables are related if
-- they are related by R.

mutual

  data Alpha (R : Var → Var → Type) : Exp → Exp → Type where
    apply :
      Alpha R e₁₁ e₁₂ → Alpha R e₂₁ e₂₂ →
      Alpha R (apply e₁₁ e₂₁) (apply e₁₂ e₂₂)

    lambda :
      Alpha (R [ x₁ ∼ x₂ ]) e₁ e₂ →
      Alpha R (lambda x₁ e₁) (lambda x₂ e₂)

    case :
      Alpha R e₁ e₂ →
      Alpha-⋆ (Alpha-Br R) bs₁ bs₂ →
      Alpha R (case e₁ bs₁) (case e₂ bs₂)

    rec :
      Alpha (R [ x₁ ∼ x₂ ]) e₁ e₂ →
      Alpha R (rec x₁ e₁) (rec x₂ e₂)

    var : R x₁ x₂ → Alpha R (var x₁) (var x₂)

    const :
      Alpha-⋆ (Alpha R) es₁ es₂ →
      Alpha R (const c es₁) (const c es₂)

  data Alpha-Br (R : Var → Var → Type) : Br → Br → Type where
    nil :
      Alpha R e₁ e₂ →
      Alpha-Br R (branch c [] e₁) (branch c [] e₂)
    cons :
      Alpha-Br (R [ x₁ ∼ x₂ ]) (branch c xs₁ e₁) (branch c xs₂ e₂) →
      Alpha-Br R (branch c (x₁ ∷ xs₁) e₁) (branch c (x₂ ∷ xs₂) e₂)

-- The α-equivalence relation.

infix 4 _≈α_

_≈α_ : Exp → Exp → Type
_≈α_ = Alpha _≡_

------------------------------------------------------------------------
-- Some properties related to reflexivity

-- If R y y holds assuming that y is distinct from x, then
-- (R [ x ∼ x ]) y y holds.

[≢→[∼]]→[∼] :
  ∀ R →
  (y ≢ x → R y y) →
  (R [ x ∼ x ]) y y
[≢→[∼]]→[∼] {y = y} {x = x} _ r = case x V.≟ y of λ where
  (yes x≡y) → inj₁ (x≡y , x≡y)
  (no  x≢y) → inj₂ ( x≢y , x≢y
                   , r (x≢y ∘ sym)
                   )

-- Alpha R is reflexive for expressions for which R x x holds for
-- every free variable x.

mutual

  refl-Alpha :
    ∀ e → (∀ x → x ∈FV e → R x x) → Alpha R e e

  refl-Alpha (apply e₁ e₂) r =
    apply (refl-Alpha e₁ λ x x∈e₁ → r x (apply-left  x∈e₁))
          (refl-Alpha e₂ λ x x∈e₂ → r x (apply-right x∈e₂))

  refl-Alpha {R = R} (lambda x e) r =
    lambda (refl-Alpha e λ y y∈e → [≢→[∼]]→[∼] R λ y≢x →
              r y (lambda y≢x y∈e))

  refl-Alpha (case e bs) r =
    case
      (refl-Alpha e λ x x∈e →
         r x (case-head x∈e))
      (refl-Alpha-B⋆ bs λ x ∈bs x∉xs x∈ →
         r x (case-body x∈ ∈bs x∉xs))

  refl-Alpha {R = R} (rec x e) r =
    rec (refl-Alpha e λ y y∈e → [≢→[∼]]→[∼] R λ y≢x →
           r y (rec y≢x y∈e))

  refl-Alpha (var x) r =
    var (r x (var refl))

  refl-Alpha (const c es) r =
    const (refl-Alpha-⋆ es λ x e e∈es x∈e →
             r x (const x∈e e∈es))

  refl-Alpha-B :
    ∀ c xs e →
    (∀ x → ¬ x ∈ xs → x ∈FV e → R x x) →
    Alpha-Br R (branch c xs e) (branch c xs e)
  refl-Alpha-B c [] e r =
    nil (refl-Alpha e λ x x∈e →
           r x (λ ()) x∈e)
  refl-Alpha-B {R = R} c (x ∷ xs) e r =
    cons (refl-Alpha-B c xs e λ y y∉xs y∈e → [≢→[∼]]→[∼] R λ y≢x →
            r y [ y≢x , y∉xs ] y∈e)

  refl-Alpha-⋆ :
    ∀ es → (∀ x e → e ∈ es → x ∈FV e → R x x) →
    Alpha-⋆ (Alpha R) es es
  refl-Alpha-⋆ []       _ = []
  refl-Alpha-⋆ (e ∷ es) r =
    refl-Alpha e (λ x x∈e → r x e (inj₁ refl) x∈e) ∷
    refl-Alpha-⋆ es (λ x e e∈es x∈e → r x e (inj₂ e∈es) x∈e)

  refl-Alpha-B⋆ :
    ∀ bs →
    (∀ x {c xs e} → branch c xs e ∈ bs → ¬ x ∈ xs → x ∈FV e → R x x) →
    Alpha-⋆ (Alpha-Br R) bs bs
  refl-Alpha-B⋆ []                   r = []
  refl-Alpha-B⋆ (branch c xs e ∷ bs) r =
    refl-Alpha-B c xs e (λ x x∉xs x∈e → r x (inj₁ refl) x∉xs x∈e) ∷
    refl-Alpha-B⋆ bs (λ x ∈bs x∉xs x∈ → r x (inj₂ ∈bs) x∉xs x∈)

-- The α-equivalence relation is reflexive.

refl-α : e ≈α e
refl-α = refl-Alpha _ (λ _ _ → refl)

-- Equational reasoning combinators.

infix  -1 finally-α _∎α
infixr -2 step-≡-≈α step-≈α-≡ _≡⟨⟩α_

_∎α : ∀ e → e ≈α e
_ ∎α = refl-α

step-≡-≈α : ∀ e₁ → e₂ ≈α e₃ → e₁ ≡ e₂ → e₁ ≈α e₃
step-≡-≈α _ e₂≈e₃ e₁≡e₂ = subst (_≈α _) (sym e₁≡e₂) e₂≈e₃

syntax step-≡-≈α e₁ e₂≈e₃ e₁≡e₂ = e₁ ≡⟨ e₁≡e₂ ⟩α e₂≈e₃

step-≈α-≡ : ∀ e₁ → e₂ ≡ e₃ → e₁ ≈α e₂ → e₁ ≈α e₃
step-≈α-≡ _ e₂≡e₃ e₁≈e₂ = subst (_ ≈α_) e₂≡e₃ e₁≈e₂

syntax step-≈α-≡ e₁ e₂≡e₃ e₁≈e₂ = e₁ ≈⟨ e₁≈e₂ ⟩α e₂≡e₃

_≡⟨⟩α_ : ∀ e₁ → e₁ ≈α e₂ → e₁ ≈α e₂
_ ≡⟨⟩α e₁≈e₂ = e₁≈e₂

finally-α : ∀ e₁ e₂ → e₁ ≈α e₂ → e₁ ≈α e₂
finally-α _ _ e₁≈e₂ = e₁≈e₂

syntax finally-α e₁ e₂ e₁≈e₂ = e₁ ≈⟨ e₁≈e₂ ⟩α∎ e₂ ∎

------------------------------------------------------------------------
-- A map function

-- A kind of map function for _[_∼_].

map-[∼] :
  ∀ R₁ → (∀ {x₁ x₂} → R₁ x₁ x₂ → R₂ x₁ x₂) →
  (R₁ [ x₁ ∼ x₂ ]) x₁′ x₂′ →
  (R₂ [ x₁ ∼ x₂ ]) x₁′ x₂′
map-[∼] _ r = ⊎-map id (Σ-map id (Σ-map id r))

-- A kind of map function for Alpha.

mutual

  map-Alpha :
    (∀ {x₁ x₂} → R₁ x₁ x₂ → R₂ x₁ x₂) →
    Alpha R₁ e₁ e₂ → Alpha R₂ e₁ e₂

  map-Alpha r (var Rx₁x₂) = var (r Rx₁x₂)

  map-Alpha {R₁ = R₁} r (lambda e₁≈e₂) =
    lambda (map-Alpha (map-[∼] R₁ r) e₁≈e₂)

  map-Alpha {R₁ = R₁} r (rec e₁≈e₂) =
    rec (map-Alpha (map-[∼] R₁ r) e₁≈e₂)

  map-Alpha r (apply e₁₁≈e₁₂ e₂₁≈e₂₂) =
    apply (map-Alpha r e₁₁≈e₁₂) (map-Alpha r e₂₁≈e₂₂)

  map-Alpha r (const es₁≈es₂) =
    const (map-Alpha-⋆ r es₁≈es₂)

  map-Alpha r (case e₁≈e₂ bs₁≈bs₂) =
    case (map-Alpha r e₁≈e₂)
         (map-Alpha-Br-⋆ r bs₁≈bs₂)

  map-Alpha-Br :
    (∀ {x₁ x₂} → R₁ x₁ x₂ → R₂ x₁ x₂) →
    Alpha-Br R₁ b₁ b₂ → Alpha-Br R₂ b₁ b₂
  map-Alpha-Br r (nil e₁≈e₂) =
    nil (map-Alpha r e₁≈e₂)
  map-Alpha-Br {R₁ = R₁} r (cons b₁≈b₂) =
    cons (map-Alpha-Br (map-[∼] R₁ r) b₁≈b₂)

  map-Alpha-⋆ :
    (∀ {x₁ x₂} → R₁ x₁ x₂ → R₂ x₁ x₂) →
    Alpha-⋆ (Alpha R₁) es₁ es₂ → Alpha-⋆ (Alpha R₂) es₁ es₂
  map-Alpha-⋆ _ []                = []
  map-Alpha-⋆ r (e₁≈e₂ ∷ es₁≈es₂) =
    map-Alpha r e₁≈e₂ ∷ map-Alpha-⋆ r es₁≈es₂

  map-Alpha-Br-⋆ :
    (∀ {x₁ x₂} → R₁ x₁ x₂ → R₂ x₁ x₂) →
    Alpha-⋆ (Alpha-Br R₁) bs₁ bs₂ → Alpha-⋆ (Alpha-Br R₂) bs₁ bs₂
  map-Alpha-Br-⋆ _ []                = []
  map-Alpha-Br-⋆ r (b₁≈b₂ ∷ bs₁≈bs₂) =
    map-Alpha-Br r b₁≈b₂ ∷ map-Alpha-Br-⋆ r bs₁≈bs₂

------------------------------------------------------------------------
-- Symmetry

-- A kind of symmetry holds for _[_∼_].

sym-[∼] :
  ∀ R →
  (R [ x₁ ∼ x₂ ]) x₁′ x₂′ →
  (flip R [ x₂ ∼ x₁ ]) x₂′ x₁′
sym-[∼] _ =
  ⊎-map Prelude.swap
        (λ (x₁≢x₁′ , x₂≢x₂′ , R₁x₁′x₂′) →
           x₂≢x₂′ , x₁≢x₁′ , R₁x₁′x₂′)

-- A kind of symmetry holds for Alpha.

mutual

  sym-Alpha : Alpha R e₁ e₂ → Alpha (flip R) e₂ e₁

  sym-Alpha (var Rx₁x₂) = var Rx₁x₂

  sym-Alpha {R = R} (lambda e₁≈e₂) =
    lambda (map-Alpha (sym-[∼] R) (sym-Alpha e₁≈e₂))

  sym-Alpha {R = R} (rec e₁≈e₂) =
    rec (map-Alpha (sym-[∼] R) (sym-Alpha e₁≈e₂))

  sym-Alpha (apply e₁₁≈e₁₂ e₂₁≈e₂₂) =
    apply (sym-Alpha e₁₁≈e₁₂) (sym-Alpha e₂₁≈e₂₂)

  sym-Alpha (const es₁≈es₂) =
    const (sym-Alpha-⋆ es₁≈es₂)

  sym-Alpha (case e₁≈e₂ bs₁≈bs₂) =
    case (sym-Alpha e₁≈e₂)
         (sym-Alpha-Br-⋆ bs₁≈bs₂)

  sym-Alpha-Br :
    Alpha-Br R b₁ b₂ → Alpha-Br (flip R) b₂ b₁
  sym-Alpha-Br (nil e₁≈e₂) =
    nil (sym-Alpha e₁≈e₂)
  sym-Alpha-Br {R = R} (cons b₁≈b₂) =
    cons (map-Alpha-Br (sym-[∼] R) (sym-Alpha-Br b₁≈b₂))

  sym-Alpha-⋆ :
    Alpha-⋆ (Alpha R) es₁ es₂ → Alpha-⋆ (Alpha (flip R)) es₂ es₁
  sym-Alpha-⋆ []                = []
  sym-Alpha-⋆ (e₁≈e₂ ∷ es₁≈es₂) =
    sym-Alpha e₁≈e₂ ∷ sym-Alpha-⋆ es₁≈es₂

  sym-Alpha-Br-⋆ :
    Alpha-⋆ (Alpha-Br R) bs₁ bs₂ → Alpha-⋆ (Alpha-Br (flip R)) bs₂ bs₁
  sym-Alpha-Br-⋆ []                = []
  sym-Alpha-Br-⋆ (b₁≈b₂ ∷ bs₁≈bs₂) =
    sym-Alpha-Br b₁≈b₂ ∷ sym-Alpha-Br-⋆ bs₁≈bs₂

-- The α-equivalence relation is symmetric.

sym-α : e₁ ≈α e₂ → e₂ ≈α e₁
sym-α = map-Alpha sym ∘ sym-Alpha

------------------------------------------------------------------------
-- Several things respect α-equivalence

-- The free variable relation respects α-equivalence.

mutual

  Alpha-∈ :
    Alpha R e₁ e₂ → x₁ ∈FV e₁ → ∃ λ x₂ → R x₁ x₂ × x₂ ∈FV e₂
  Alpha-∈ {R = R} (var Ry₁y₂) (var x₁≡y₁) =
    _ , subst (flip R _) (sym x₁≡y₁) Ry₁y₂ , var refl

  Alpha-∈ (lambda e₁≈e₂) (lambda x₁≢y₁ x₁∈)
    with Alpha-∈ e₁≈e₂ x₁∈
  … | x₂ , inj₂ (_ , y₂≢x₂ , Rx₁x₂) , x₂∈ =
    x₂ , Rx₁x₂ , lambda (y₂≢x₂ ∘ sym) x₂∈
  … | _ , inj₁ (y₁≡x₁ , _) , _ =
    ⊥-elim $ x₁≢y₁ (sym y₁≡x₁)

  Alpha-∈ (rec e₁≈e₂) (rec x₁≢y₁ x₁∈)
    with Alpha-∈ e₁≈e₂ x₁∈
  … | x₂ , inj₂ (_ , y₂≢x₂ , Rx₁x₂) , x₂∈ =
    x₂ , Rx₁x₂ , rec (y₂≢x₂ ∘ sym) x₂∈
  … | _ , inj₁ (y₁≡x₁ , _) , _ =
    ⊥-elim $ x₁≢y₁ (sym y₁≡x₁)

  Alpha-∈ (apply e₁₁≈e₁₂ e₂₁≈e₂₂) (apply-left x₁∈) =
    Σ-map id (Σ-map id apply-left) $ Alpha-∈ e₁₁≈e₁₂ x₁∈
  Alpha-∈ (apply e₁₁≈e₁₂ e₂₁≈e₂₂) (apply-right x₁∈) =
    Σ-map id (Σ-map id apply-right) $ Alpha-∈ e₂₁≈e₂₂ x₁∈

  Alpha-∈ (const es₁≈es₂) (const x₁∈ ∈es₁) =
    Σ-map id (Σ-map id $ uncurry λ _ → uncurry const) $
    Alpha-⋆-∈ es₁≈es₂ x₁∈ ∈es₁

  Alpha-∈ (case e₁≈e₂ bs₁≈bs₂) (case-head x₁∈) =
    Σ-map id (Σ-map id case-head) $
    Alpha-∈ e₁≈e₂ x₁∈

  Alpha-∈ (case e₁≈e₂ bs₁≈bs₂) (case-body x₁∈ ∈bs₁ ∉xs₁) =
    Σ-map id (Σ-map id λ (_ , _ , _ , x₂∈ , ∈bs₂ , ∉xs₂) →
                case-body x₂∈ ∈bs₂ ∉xs₂) $
    Alpha-Br-⋆-∈ bs₁≈bs₂ x₁∈ ∈bs₁ ∉xs₁

  Alpha-Br-∈ :
    Alpha-Br R (branch c₁ xs₁ e₁) (branch c₂ xs₂ e₂) →
    x₁ ∈FV e₁ → ¬ x₁ ∈ xs₁ →
    ∃ λ x₂ → R x₁ x₂ × x₂ ∈FV e₂ × ¬ x₂ ∈ xs₂
  Alpha-Br-∈ (nil e₁≈e₂) x₁∈ _ =
    Σ-map id (Σ-map id (_, λ ())) $
    Alpha-∈ e₁≈e₂ x₁∈
  Alpha-Br-∈ (cons {x₁ = y₁} {x₂ = y₂} bs₁≈bs₂) x₁∈ x₁∉
    with Alpha-Br-∈ bs₁≈bs₂ x₁∈ (x₁∉ ∘ inj₂)
  … | x₂ , inj₂ (_ , y₂≢x₂ , Rx₁x₂) , x₂∈ , x₂∉ =
    x₂ , Rx₁x₂ , x₂∈ , [ y₂≢x₂ ∘ sym , x₂∉ ]
  … | _ , inj₁ (y₁≡x₁ , _) , _ =
    ⊥-elim $ x₁∉ (inj₁ (sym y₁≡x₁))

  Alpha-⋆-∈ :
    Alpha-⋆ (Alpha R) es₁ es₂ →
    x₁ ∈FV e₁ → e₁ ∈ es₁ →
    ∃ λ x₂ → R x₁ x₂ × ∃ λ e₂ → x₂ ∈FV e₂ × e₂ ∈ es₂
  Alpha-⋆-∈ (e₁≈e₂ ∷ es₁≈es₂) x₁∈ (inj₁ ≡e₁) =
    Σ-map id (Σ-map id λ x₂∈ → _ , x₂∈ , inj₁ refl) $
    Alpha-∈ e₁≈e₂ (subst (_ ∈FV_) ≡e₁ x₁∈)
  Alpha-⋆-∈ (e₁≈e₂ ∷ es₁≈es₂) x₁∈ (inj₂ ∈es₁) =
    Σ-map id (Σ-map id (Σ-map id (Σ-map id inj₂))) $
    Alpha-⋆-∈ es₁≈es₂ x₁∈ ∈es₁

  Alpha-Br-⋆-∈ :
    Alpha-⋆ (Alpha-Br R) bs₁ bs₂ →
    x₁ ∈FV e₁ → branch c₁ xs₁ e₁ ∈ bs₁ → ¬ x₁ ∈ xs₁ →
    ∃ λ x₂ → R x₁ x₂ × ∃ λ c₂ → ∃ λ xs₂ → ∃ λ e₂ →
      x₂ ∈FV e₂ × branch c₂ xs₂ e₂ ∈ bs₂ × ¬ x₂ ∈ xs₂
  Alpha-Br-⋆-∈
    (_∷_ {x₁ = branch _ _ _} {x₂ = branch _ _ _} b₁≈b₂ bs₁≈bs₂)
    x₁∈ (inj₁ ≡b₁) x₁∉
    with
      Alpha-Br-∈
        b₁≈b₂
        (subst (_ ∈FV_) (cong (λ { (branch _ _ e) → e }) ≡b₁) x₁∈)
        (x₁∉ ∘
         subst (_ ∈_) (cong (λ { (branch _ xs _) → xs }) (sym ≡b₁)))
  … | x₂ , Rx₁x₂ , x₂∈ , x₂∉ =
    x₂ , Rx₁x₂ , _ , _ , _ , x₂∈ , inj₁ refl , x₂∉
  Alpha-Br-⋆-∈ (b₁≈b₂ ∷ bs₁≈bs₂) x₁∈ (inj₂ ∈bs₁) x₁∉ =
    (Σ-map id $ Σ-map id $ Σ-map id $ Σ-map id $ Σ-map id $ Σ-map id $
     Σ-map inj₂ id) $
    Alpha-Br-⋆-∈ bs₁≈bs₂ x₁∈ ∈bs₁ x₁∉

α-∈ : e₁ ≈α e₂ → x ∈FV e₁ → x ∈FV e₂
α-∈ e₁≈e₂ x∈ with Alpha-∈ e₁≈e₂ x∈
… | x′ , x≡x′ , x′∈ = subst (_∈FV _) (sym x≡x′) x′∈

-- The predicate Closed′ respects α-equivalence.

α-closed′ : e₁ ≈α e₂ → Closed′ xs e₁ → Closed′ xs e₂
α-closed′ e₁≈e₂ cl x x∉ x∈ =
  cl x x∉ (α-∈ (sym-α e₁≈e₂) x∈)

-- The predicate Closed respects α-equivalence.

α-closed : e₁ ≈α e₂ → Closed e₁ → Closed e₂
α-closed = α-closed′

-- Substitution does not necessarily respect α-equivalence.

¬-subst-α :
  ¬ (∀ {x₁ x₂ e₁ e₂ e₁′ e₂′} →
     Alpha (_≡_ [ x₁ ∼ x₂ ]) e₁ e₂ →
     e₁′ ≈α e₂′ →
     e₁ [ x₁ ← e₁′ ] ≈α e₂ [ x₂ ← e₂′ ])
¬-subst-α subst-α =
  not-equal (subst-α e¹≈e² e′≈e′)
  where
  x¹ = V.name 0
  x² = V.name 1
  z  = V.name 2

  e¹ = lambda x¹ (var z)
  e² = lambda x² (var z)

  e′ = var x¹

  e¹≈e² : Alpha (_≡_ [ z ∼ z ]) e¹ e²
  e¹≈e² =
    lambda (var (inj₂ ( V.distinct-codes→distinct-names (λ ())
                      , V.distinct-codes→distinct-names (λ ())
                      , inj₁ (refl , refl)
                      )))

  e′≈e′ : e′ ≈α e′
  e′≈e′ = refl-α

  not-equal : ¬ e¹ [ z ← e′ ] ≈α e² [ z ← e′ ]
  not-equal _ with z V.≟ x¹ | z V.≟ x² | z V.≟ z
  not-equal (lambda (var (inj₁ (_ , x²≡x¹)))) | no _ | no _ | yes _ =
    from-⊎ (1 Nat.≟ 0) (V.name-injective x²≡x¹)
  not-equal (lambda (var (inj₂ (x¹≢x¹ , _)))) | no _ | no _ | yes _ =
    x¹≢x¹ refl
  not-equal _ | yes z≡x¹ | _ | _ =
    from-⊎ (2 Nat.≟ 0) (V.name-injective z≡x¹)
  not-equal _ | _ | yes z≡x² | _ =
    from-⊎ (2 Nat.≟ 1) (V.name-injective z≡x²)
  not-equal _ | _ | _ | no z≢z = z≢z refl

-- TODO: Does substitution of closed terms respect α-equivalence? Does
-- the semantics respect α-equivalence for closed terms?


------------------------------------------------------------------------
-- The Agda standard library
--
-- Natural numbers represented in binary.
------------------------------------------------------------------------

-- This module aims to create an alternative formulation of ℕ that is
-- still reasonably computationally efficient without having to call out
-- to Haskell.

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

module Data.Nat.Binary.Base where

open import Algebra.Core using (Op₂)
open import Data.Nat.Base as ℕ using (ℕ)
open import Data.Sum.Base using (_⊎_)
open import Function using (_on_)
open import Level using (0ℓ)
open import Relation.Binary using (Rel)
open import Relation.Binary.PropositionalEquality using (_≡_)
open import Relation.Nullary using (¬_)

------------------------------------------------------------------------
-- Definition

data ℕᵇ : Set where
  zero   : ℕᵇ
  2[1+_] : ℕᵇ → ℕᵇ    -- n → 2*(1+n) = nonzero even numbers
  1+[2_] : ℕᵇ → ℕᵇ    -- n → 1 + 2*n = odd numbers

------------------------------------------------------------------------
-- Ordering relations

infix 4 _<_ _>_ _≤_ _≮_ _≯_ _≰_ _≱_

data _<_ : Rel ℕᵇ 0ℓ  where
  0<even    : ∀ {x} → zero < 2[1+ x ]
  0<odd     : ∀ {x} → zero < 1+[2 x ]
  even<even : ∀ {x y} → x < y → 2[1+ x ] < 2[1+ y ]
  even<odd  : ∀ {x y} → x < y → 2[1+ x ] < 1+[2 y ]
  odd<even  : ∀ {x y} → x < y ⊎ x ≡ y → 1+[2 x ] < 2[1+ y ]
  odd<odd   : ∀ {x y} → x < y → 1+[2 x ] < 1+[2 y ]
  -- In these constructors "even" stands for nonzero even.

_>_ : Rel ℕᵇ 0ℓ
x > y = y < x

_≤_ : Rel ℕᵇ 0ℓ
x ≤ y = x < y ⊎ x ≡ y

_≥_ : Rel ℕᵇ 0ℓ
x ≥ y = y ≤ x

_≮_ : Rel ℕᵇ 0ℓ
x ≮ y = ¬ (x < y)

_≯_ : Rel ℕᵇ 0ℓ
x ≯ y = ¬ (x > y)

_≰_ : Rel ℕᵇ 0ℓ
x ≰ y = ¬ (x ≤ y)

_≱_ : Rel ℕᵇ 0ℓ
x ≱ y = ¬ (x ≥ y)

------------------------------------------------------------------------
-- Basic operations

double : ℕᵇ → ℕᵇ
double zero     = zero
double 2[1+ x ] = 2[1+ 1+[2 x ] ]
double 1+[2 x ] = 2[1+ (double x) ]

suc : ℕᵇ → ℕᵇ
suc zero     =  1+[2 zero ]
suc 2[1+ x ] =  1+[2 (suc x) ]
suc 1+[2 x ] =  2[1+ x ]

pred : ℕᵇ → ℕᵇ
pred zero     = zero
pred 2[1+ x ] = 1+[2 x ]
pred 1+[2 x ] = double x

------------------------------------------------------------------------
-- Addition, multiplication and certain related functions

infixl 6 _+_
infixl 7 _*_

_+_ : Op₂ ℕᵇ
zero     + y        =  y
x        + zero     =  x
2[1+ x ] + 2[1+ y ] =  2[1+ suc (x + y) ]
2[1+ x ] + 1+[2 y ] =  suc 2[1+ (x + y) ]
1+[2 x ] + 2[1+ y ] =  suc 2[1+ (x + y) ]
1+[2 x ] + 1+[2 y ] =  suc 1+[2 (x + y) ]

_*_ : Op₂ ℕᵇ
zero     * _        =  zero
_        * zero     =  zero
2[1+ x ] * 2[1+ y ] =  double 2[1+ x + (y + x * y) ]
2[1+ x ] * 1+[2 y ] =  2[1+ x + y * 2[1+ x ] ]
1+[2 x ] * 2[1+ y ] =  2[1+ y + x * 2[1+ y ] ]
1+[2 x ] * 1+[2 y ] =  1+[2 x + y * 1+[2 x ] ]

------------------------------------------------------------------------
-- Conversion between ℕᵇ and ℕ

toℕ : ℕᵇ → ℕ
toℕ zero     =  0
toℕ 2[1+ x ] =  2 ℕ.* (ℕ.suc (toℕ x))
toℕ 1+[2 x ] =  ℕ.suc (2 ℕ.* (toℕ x))

-- Costs O(n), could be improved using `_/_` and `_%_`
fromℕ : ℕ → ℕᵇ
fromℕ 0         = zero
fromℕ (ℕ.suc n) = suc (fromℕ n)

-- An alternative ordering lifted from ℕ

infix 4 _<ℕ_

_<ℕ_ :  Rel ℕᵇ 0ℓ
_<ℕ_ =  ℕ._<_ on toℕ

------------------------------------------------------------------------
-- Other functions

-- Useful in some termination proofs.
size : ℕᵇ → ℕ
size zero     = 0
size 2[1+ x ] = ℕ.suc (size x)
size 1+[2 x ] = ℕ.suc (size x)

------------------------------------------------------------------------
-- Constants

0ᵇ = zero
1ᵇ = suc 0ᵇ
2ᵇ = suc 1ᵇ
3ᵇ = suc 2ᵇ
4ᵇ = suc 3ᵇ
5ᵇ = suc 4ᵇ
6ᵇ = suc 5ᵇ
7ᵇ = suc 6ᵇ
8ᵇ = suc 7ᵇ
9ᵇ = suc 8ᵇ


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

module Algebra.Construct.Free.Semilattice.Relation.Unary.Any.Def where

open import Prelude hiding (⊥; ⊤)
open import Algebra.Construct.Free.Semilattice.Eliminators
open import Algebra.Construct.Free.Semilattice.Definition
open import Cubical.Foundations.HLevels
open import Data.Empty.UniversePolymorphic
open import HITs.PropositionalTruncation.Sugar
open import HITs.PropositionalTruncation.Properties
open import HITs.PropositionalTruncation
open import Data.Unit.UniversePolymorphic

private
  variable p : Level

dup-◇ : (P : A → Type p) → (x : A) (xs : Type p) → ∥ P x ⊎ ∥ P x ⊎ xs ∥ ∥ ⇔ ∥ P x ⊎ xs ∥
dup-◇ P x xs .inv p = ∣ inr p ∣
dup-◇ P x xs .fun ps = ps >>= either (∣_∣ ∘ inl) id
dup-◇ P x xs .leftInv p = squash _ p
dup-◇ P x xs .rightInv p = squash p _

swap-◇ : {x y xs : Type p} → ∥ x ⊎ ∥ y ⊎ xs ∥ ∥ → ∥ y ⊎ ∥ x ⊎ xs ∥ ∥
swap-◇ p = p >>= either′ (∣_∣ ∘ inr ∘ ∣_∣ ∘ inl) (mapʳ (∣_∣ ∘ inr) ∥$∥_)

com-◇ : (P : A → Type p) → (x y : A) (xs : Type p) → ∥ P x ⊎ ∥ P y ⊎ xs ∥ ∥ ⇔ ∥ P y ⊎ ∥ P x ⊎ xs ∥ ∥
com-◇ P y z xs .fun = swap-◇
com-◇ P y z xs .inv = swap-◇
com-◇ P y z xs .leftInv  p = squash _ p
com-◇ P y z xs .rightInv p = squash _ p

◇′ : (P : A → Type p) → 𝒦 A → hProp p
◇′ P =
  𝒦-rec
    isSetHProp
    (λ { x (xs , _) → ∥ P x ⊎ xs ∥ , squash })
    (⊥ , λ ())
    (λ x xs → ΣProp≡ (λ _ → isPropIsProp) (isoToPath (dup-◇ P x (xs .fst))))
    (λ x y xs → ΣProp≡ (λ _ → isPropIsProp) (isoToPath (com-◇ P x y (xs .fst))))
{-# INLINE ◇′ #-}

◇ : (P : A → Type p) → 𝒦 A → Type p
◇ P xs = ◇′ P xs .fst

isProp-◇ : ∀ {P : A → Type p} {xs} → isProp (◇ P xs)
isProp-◇ {P = P} {xs = xs} = ◇′ P xs .snd


------------------------------------------------------------------------
-- Integers
------------------------------------------------------------------------

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

open import Equality

module Integer {e⁺} (eq : ∀ {a p} → Equality-with-J a p e⁺) where

open Derived-definitions-and-properties eq

open import Prelude as P hiding (suc) renaming (_+_ to _⊕_; _*_ to _⊛_)

open import Bijection eq using (_↔_)
open import Equivalence eq as Eq using (_≃_)
open import Function-universe eq hiding (_∘_)
open import Group eq using (Group; Abelian)
open import H-level eq
open import H-level.Closure eq
import Nat eq as Nat

open import Integer.Basics eq public

private
  variable
    i j : ℤ

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

-- The sum of i and - i is zero.

+-right-inverse : ∀ i → i + - i ≡ + 0
+-right-inverse = λ where
    (+ zero)    → refl _
    (+ P.suc n) → lemma n
    -[1+ n ]    → lemma n
  where
  lemma : ∀ n → + P.suc n +-[1+ n ] ≡ + 0
  lemma n
    with P.suc n Nat.<= n | T[<=]↔≤ {m = P.suc n} {n = n}
  … | false | _  = cong (+_) $ Nat.∸≡0 n
  … | true  | eq = ⊥-elim $ Nat.<-irreflexive (_↔_.to eq _)

-- The sum of - i and i is zero.

+-left-inverse : ∀ i → - i + i ≡ + 0
+-left-inverse i =
  - i + i  ≡⟨ +-comm (- i) ⟩
  i + - i  ≡⟨ +-right-inverse i ⟩∎
  + 0      ∎

-- + 0 is a left identity for addition.

+-left-identity : + 0 + i ≡ i
+-left-identity {i = + _}      = refl _
+-left-identity {i = -[1+ _ ]} = refl _

-- + 0 is a right identity for addition.

+-right-identity : i + + 0 ≡ i
+-right-identity {i = + _}      = cong (+_) Nat.+-right-identity
+-right-identity {i = -[1+ _ ]} = refl _

-- Addition is associative.

+-assoc : ∀ i {j k} → i + (j + k) ≡ (i + j) + k
+-assoc = λ where
    (+ m) {j = + _} {k = + _} →
      cong (+_) $ Nat.+-assoc m
    -[1+ m ] {j = -[1+ n ]} {k = -[1+ o ]} →
      cong (-[1+_] ∘ P.suc)
        (m ⊕ P.suc (n ⊕ o)  ≡⟨ sym $ Nat.suc+≡+suc m ⟩
         P.suc m ⊕ (n ⊕ o)  ≡⟨ Nat.+-assoc (P.suc m) ⟩∎
         (P.suc m ⊕ n) ⊕ o  ∎)
    -[1+ m ] {j = + n} {k = + o} →
      sym $ ++-[1+]++ _ n _
    (+ m) {j = -[1+ n ]} {k = -[1+ o ]} →
      sym $ ++-[1+]+-[1+] m _ _
    (+ m) {j = + n} {k = -[1+ o ]} →
      lemma₁ m _ _
    (+ m) {j = -[1+ n ]} {k = + o} →
      lemma₂ m _ _
    -[1+ m ] {j = -[1+ n ]} {k = + o} →
      lemma₃ _ o _
    -[1+ m ] {j = + n} {k = -[1+ o ]} →
      lemma₄ _ n _
  where
  ++-[1+]++ : ∀ m n o → + n +-[1+ m ] + + o ≡ (+ (n ⊕ o) +-[1+ m ])
  ++-[1+]++ m         zero      o = refl _
  ++-[1+]++ zero      (P.suc n) o = refl _
  ++-[1+]++ (P.suc m) (P.suc n) o = ++-[1+]++ m n o

  ++-[1+]+-[1+] :
    ∀ m n o → + m +-[1+ n ] + -[1+ o ] ≡ (+ m +-[1+ 1 ⊕ n ⊕ o ])
  ++-[1+]+-[1+] zero      n         o = refl _
  ++-[1+]+-[1+] (P.suc m) zero      o = refl _
  ++-[1+]+-[1+] (P.suc m) (P.suc n) o = ++-[1+]+-[1+] m n o

  lemma₁ : ∀ m n o → + m + (+ n +-[1+ o ]) ≡ (+ m ⊕ n +-[1+ o ])
  lemma₁ m n o =
    + m + (+ n +-[1+ o ])  ≡⟨ +-comm (+ m) {j = + n +-[1+ o ]} ⟩
    (+ n +-[1+ o ]) + + m  ≡⟨ ++-[1+]++ _ n _ ⟩
    (+ n ⊕ m +-[1+ o ])    ≡⟨ cong +_+-[1+ o ] $ Nat.+-comm n ⟩∎
    (+ m ⊕ n +-[1+ o ])    ∎

  lemma₂ : ∀ m n o → + m + (+ n +-[1+ o ]) ≡ (+ m +-[1+ o ]) + + n
  lemma₂ m n o =
    + m + (+ n +-[1+ o ])  ≡⟨ lemma₁ m n o ⟩
    (+ m ⊕ n +-[1+ o ])    ≡⟨ sym $ ++-[1+]++ _ m _ ⟩∎
    (+ m +-[1+ o ]) + + n  ∎

  lemma₃ :
    ∀ m n o → -[1+ m ] + (+ n +-[1+ o ]) ≡ (+ n +-[1+ 1 ⊕ m ⊕ o ])
  lemma₃ m n o =
    -[1+ m ] + (+ n +-[1+ o ])  ≡⟨ +-comm -[1+ m ] {j = + n +-[1+ o ]} ⟩
    (+ n +-[1+ o ]) + -[1+ m ]  ≡⟨ ++-[1+]+-[1+] n o m ⟩
    (+ n +-[1+ 1 ⊕ o ⊕ m ])     ≡⟨ cong + n +-[1+_] $ cong (1 ⊕_) $ Nat.+-comm o ⟩∎
    (+ n +-[1+ 1 ⊕ m ⊕ o ])     ∎

  lemma₄ :
    ∀ m n o → -[1+ m ] + (+ n +-[1+ o ]) ≡ (+ n +-[1+ m ]) + -[1+ o ]
  lemma₄ m n o =
    -[1+ m ] + (+ n +-[1+ o ])  ≡⟨ lemma₃ m n o ⟩
    (+ n +-[1+ 1 ⊕ m ⊕ o ])     ≡⟨ sym $ ++-[1+]+-[1+] n _ _ ⟩∎
    (+ n +-[1+ m ]) + -[1+ o ]  ∎

------------------------------------------------------------------------
-- Successor and predecessor

-- The successor function.

suc : ℤ → ℤ
suc (+ n)          = + P.suc n
suc -[1+ zero ]    = + zero
suc -[1+ P.suc n ] = -[1+ n ]

-- The successor function adds one to its input.

suc≡1+ : ∀ i → suc i ≡ + 1 + i
suc≡1+ (+ _)          = refl _
suc≡1+ -[1+ zero ]    = refl _
suc≡1+ -[1+ P.suc _ ] = refl _

-- The predecessor function.

pred : ℤ → ℤ
pred (+ zero)    = -[1+ zero ]
pred (+ P.suc n) = + n
pred -[1+ n ]    = -[1+ P.suc n ]

-- The predecessor function adds minus one to its input.

pred≡-1+ : ∀ i → pred i ≡ -[ 1 ] + i
pred≡-1+ (+ zero)    = refl _
pred≡-1+ (+ P.suc _) = refl _
pred≡-1+ -[1+ _ ]    = refl _

-- An equivalence between ℤ and ℤ corresponding to the successor
-- function.

successor : ℤ ≃ ℤ
successor = Eq.↔→≃ suc pred suc-pred pred-suc
  where
  suc-pred : ∀ i → suc (pred i) ≡ i
  suc-pred (+ zero)    = refl _
  suc-pred (+ P.suc _) = refl _
  suc-pred -[1+ _ ]    = refl _

  pred-suc : ∀ i → pred (suc i) ≡ i
  pred-suc (+ _)          = refl _
  pred-suc -[1+ zero ]    = refl _
  pred-suc -[1+ P.suc _ ] = refl _

------------------------------------------------------------------------
-- Positive, negative

-- The property of being positive.

Positive : ℤ → Type
Positive (+ zero)    = ⊥
Positive (+ P.suc _) = ⊤
Positive -[1+ _ ]    = ⊥

-- Positive is propositional.

Positive-propositional : Is-proposition (Positive i)
Positive-propositional {i = + zero}    = ⊥-propositional
Positive-propositional {i = + P.suc _} = mono₁ 0 ⊤-contractible
Positive-propositional {i = -[1+ _ ]}  = ⊥-propositional

-- The property of being negative.

Negative : ℤ → Type
Negative (+ _)    = ⊥
Negative -[1+ _ ] = ⊤

-- Negative is propositional.

Negative-propositional : Is-proposition (Negative i)
Negative-propositional {i = + _}      = ⊥-propositional
Negative-propositional {i = -[1+ _ ]} = mono₁ 0 ⊤-contractible

-- No integer is both positive and negative.

¬+- : Positive i → Negative i → ⊥₀
¬+- {i = + _}      _   neg = neg
¬+- {i = -[1+ _ ]} pos _   = pos

-- No integer is both positive and equal to zero.

¬+0 : Positive i → i ≡ + 0 → ⊥₀
¬+0 {i = + zero}    pos _  = pos
¬+0 {i = + P.suc _} _   ≡0 = Nat.0≢+ $ sym $ +-cancellative ≡0
¬+0 {i = -[1+ _ ]}  pos _  = pos

-- No integer is both negative and equal to zero.

¬-0 : Negative i → i ≡ + 0 → ⊥₀
¬-0 {i = + _}      neg _  = neg
¬-0 {i = -[1+ _ ]} _   ≡0 = +≢-[1+] $ sym ≡0

-- One can decide if an integer is negative, zero or positive.

-⊎0⊎+ : ∀ i → Negative i ⊎ i ≡ + 0 ⊎ Positive i
-⊎0⊎+ (+ zero)    = inj₂ (inj₁ (refl _))
-⊎0⊎+ (+ P.suc _) = inj₂ (inj₂ _)
-⊎0⊎+ -[1+ _ ]    = inj₁ _

-- If i and j are positive, then i + j is positive.

>0→>0→+>0 : ∀ i j → Positive i → Positive j → Positive (i + j)
>0→>0→+>0 (+ P.suc _) (+ P.suc _) _ _ = _

-- If i and j are negative, then i + j is negative.

<0→<0→+<0 : ∀ i j → Negative i → Negative j → Negative (i + j)
<0→<0→+<0 -[1+ _ ] -[1+ _ ] _ _ = _

------------------------------------------------------------------------
-- The group of integers

-- The group of integers.

ℤ-group : Group lzero
ℤ-group .Group.Carrier          = ℤ
ℤ-group .Group.Carrier-is-set   = ℤ-set
ℤ-group .Group._∘_              = _+_
ℤ-group .Group.id               = + 0
ℤ-group .Group._⁻¹              = -_
ℤ-group .Group.left-identity _  = +-left-identity
ℤ-group .Group.right-identity _ = +-right-identity
ℤ-group .Group.assoc i _ _      = +-assoc i
ℤ-group .Group.right-inverse    = +-right-inverse
ℤ-group .Group.left-inverse     = +-left-inverse

-- The group of integers is abelian.

ℤ-abelian : Abelian ℤ-group
ℤ-abelian i _ = +-comm i

private
  module ℤG = Group ℤ-group
open ℤG public
  using ()
  renaming (_^+_ to infixl 7 _*+_;
            _^_  to infixl 7 _*_)

-- + 1 is a left identity for multiplication.

*-left-identity : ∀ i → + 1 * i ≡ i
*-left-identity = lemma
  where
  +lemma : ∀ n → + 1 *+ n ≡ + n
  +lemma zero      = refl _
  +lemma (P.suc n) =
    + 1 + (+ 1) *+ n  ≡⟨ cong (λ i → + 1 + i) $ +lemma n ⟩
    + 1 + + n         ≡⟨⟩
    + P.suc n         ∎

  -lemma : ∀ n → -[ 1 ] *+ n ≡ -[ n ]
  -lemma zero              = refl _
  -lemma (P.suc zero)      = refl _
  -lemma (P.suc (P.suc n)) =
    -[ 1 ] + -[ 1 ] *+ P.suc n  ≡⟨ cong (λ i → -[ 1 ] + i) $ -lemma (P.suc n) ⟩
    -[ 1 ] + -[ P.suc n ]       ≡⟨⟩
    -[ P.suc (P.suc n) ]        ∎

  lemma : ∀ i → + 1 * i ≡ i
  lemma (+ n)    = +lemma n
  lemma -[1+ n ] = -lemma (P.suc n)

-- _*+ n distributes over addition.

*+-distrib-+ : ∀ n → (i + j) *+ n ≡ i *+ n + j *+ n
*+-distrib-+ {i = i} n = ℤG.∘^+≡^+∘^+ (+-comm i) n

-- If a positive number is multiplied by a positive number, then
-- the result is positive.

>0→*+suc> : ∀ i m → Positive i → Positive (i *+ P.suc m)
>0→*+suc> i zero =
  Positive i          ↝⟨ subst Positive (sym $ ℤG.right-identity i) ⟩
  Positive (i + + 0)  ↔⟨⟩
  Positive (i *+ 1)   □
>0→*+suc> i (P.suc m) =
  Positive i                            ↝⟨ (λ p → p , >0→*+suc> i m p) ⟩
  Positive i × Positive (i *+ P.suc m)  ↝⟨ uncurry (>0→>0→+>0 i (i *+ P.suc m)) ⟩
  Positive (i + i *+ P.suc m)           ↔⟨⟩
  Positive (i *+ P.suc (P.suc m))       □

-- If a negative number is multiplied by a positive number, then
-- the result is negative.

<0→*+suc<0 : ∀ i m → Negative i → Negative (i *+ P.suc m)
<0→*+suc<0 i zero =
  Negative i          ↝⟨ subst Negative (sym $ ℤG.right-identity i) ⟩
  Negative (i + + 0)  ↔⟨⟩
  Negative (i *+ 1)   □
<0→*+suc<0 i (P.suc m) =
  Negative i                            ↝⟨ (λ p → p , <0→*+suc<0 i m p) ⟩
  Negative i × Negative (i *+ P.suc m)  ↝⟨ uncurry (<0→<0→+<0 i (i *+ P.suc m)) ⟩
  Negative (i + i *+ P.suc m)           ↔⟨⟩
  Negative (i *+ P.suc (P.suc m))       □

------------------------------------------------------------------------
-- Integer division by two

-- Division by two, rounded downwards.

⌊_/2⌋ : ℤ → ℤ
⌊ + n      /2⌋ = + Nat.⌊ n /2⌋
⌊ -[1+ n ] /2⌋ = -[ Nat.⌈ P.suc n /2⌉ ]

-- A kind of distributivity property for ⌊_/2⌋ and _+_.

⌊+*+2/2⌋≡ : ∀ i {j} → ⌊ i + j *+ 2 /2⌋ ≡ ⌊ i /2⌋ + j
⌊+*+2/2⌋≡ = λ where
    (+ m) {j = + n} → cong +_
      (Nat.⌊ m ⊕ 2 ⊛ n /2⌋  ≡⟨ cong Nat.⌊_/2⌋ $ Nat.+-comm m ⟩
       Nat.⌊ 2 ⊛ n ⊕ m /2⌋  ≡⟨ Nat.⌊2*+/2⌋≡ n ⟩
       n ⊕ Nat.⌊ m /2⌋      ≡⟨ Nat.+-comm n ⟩∎
       Nat.⌊ m /2⌋ ⊕ n      ∎)

    -[1+ zero ] {j = -[1+ n ]} → cong -[1+_]
      (Nat.⌈ P.suc (n ⊕ n) /2⌉            ≡⟨ cong (Nat.⌈_/2⌉ ∘ P.suc) $ ⊕-lemma n ⟩
       Nat.⌈ 1 ⊕ 2 ⊛ n /2⌉                ≡⟨ cong Nat.⌈_/2⌉ $ Nat.+-comm 1 ⟩
       Nat.⌈ 2 ⊛ n ⊕ 1 /2⌉                ≡⟨ Nat.⌈2*+/2⌉≡ n ⟩
       n ⊕ Nat.⌈ 1 /2⌉                    ≡⟨ Nat.+-comm n ⟩∎
       P.suc n                            ∎)

    -[1+ P.suc m ] {j = -[1+ n ]} → cong -[1+_]
      (Nat.⌈ P.suc m ⊕ P.suc (n ⊕ n) /2⌉  ≡⟨ cong (Nat.⌈_/2⌉ ∘ P.suc) $ sym $ Nat.suc+≡+suc m ⟩
       P.suc Nat.⌈ m ⊕ (n ⊕ n) /2⌉        ≡⟨ cong (P.suc ∘ Nat.⌈_/2⌉ ∘ (m ⊕_)) $ ⊕-lemma n ⟩
       P.suc Nat.⌈ m ⊕ 2 ⊛ n /2⌉          ≡⟨ cong (P.suc ∘ Nat.⌈_/2⌉) $ Nat.+-comm m ⟩
       P.suc Nat.⌈ 2 ⊛ n ⊕ m /2⌉          ≡⟨ cong P.suc $ Nat.⌈2*+/2⌉≡ n ⟩
       P.suc (n ⊕ Nat.⌈ m /2⌉)            ≡⟨ cong P.suc $ Nat.+-comm n ⟩∎
       P.suc (Nat.⌈ m /2⌉ ⊕ n)            ∎)

    (+ m) {j = -[1+ n ]} →
      ⌊ + m +-[1+ P.suc (n ⊕ n) ] /2⌋  ≡⟨ cong (λ n → ⌊ + m +-[1+ P.suc n ] /2⌋) $ ⊕-lemma n ⟩
      ⌊ + m +-[1+ P.suc (2 ⊛ n) ] /2⌋  ≡⟨ lemma₁ m n ⟩∎
      + Nat.⌊ m /2⌋ +-[1+ n ]          ∎

    -[1+ 0 ] {j = + 0} →
      -[ 1 ]  ≡⟨⟩
      -[ 1 ]  ∎

    -[1+ 0 ] {j = + P.suc n} → cong +_
      (Nat.⌊ n ⊕ P.suc (n ⊕ 0) /2⌋  ≡⟨ cong Nat.⌊_/2⌋ $ sym $ Nat.suc+≡+suc n ⟩
       Nat.⌊ 1 ⊕ 2 ⊛ n /2⌋          ≡⟨ Nat.⌊1+2*/2⌋≡ n ⟩∎
       n                            ∎)

    -[1+ P.suc m ] {j = + n} →
      ⌊ + 2 ⊛ n +-[1+ P.suc m ] /2⌋  ≡⟨ lemma₂ m n ⟩∎
      + n +-[1+ Nat.⌈ m /2⌉ ]        ∎
  where
  ⊕-lemma : ∀ n → n ⊕ n ≡ 2 ⊛ n
  ⊕-lemma n = cong (n ⊕_) $ sym Nat.+-right-identity

  lemma₁ :
    ∀ m n →
    ⌊ + m +-[1+ P.suc (2 ⊛ n) ] /2⌋ ≡
    + Nat.⌊ m /2⌋ +-[1+ n ]
  lemma₁ zero n = cong -[1+_]
    (Nat.⌈ 2 ⊛ n /2⌉  ≡⟨ Nat.⌈2*/2⌉≡ n ⟩∎
     n                ∎)
  lemma₁ (P.suc zero) n =
    -[ Nat.⌈ 1 ⊕ 2 ⊛ n /2⌉ ]  ≡⟨ cong -[_] $ Nat.⌈1+2*/2⌉≡ n ⟩∎
    -[1+ n ]                  ∎
  lemma₁ (P.suc (P.suc m)) zero =
    ⌊ + m /2⌋      ≡⟨⟩
    + Nat.⌊ m /2⌋  ∎
  lemma₁ (P.suc (P.suc m)) (P.suc n) =
    ⌊ + m +-[1+ n ⊕ P.suc (n ⊕ 0) ] /2⌋  ≡⟨ cong (⌊_/2⌋ ∘ + m +-[1+_]) $ sym $ Nat.suc+≡+suc n ⟩
    ⌊ + m +-[1+ P.suc (2 ⊛ n) ] /2⌋      ≡⟨ lemma₁ m n ⟩∎
    + Nat.⌊ m /2⌋ +-[1+ n ]              ∎

  mutual

    lemma₂ :
      ∀ m n →
      ⌊ + 2 ⊛ n +-[1+ P.suc m ] /2⌋ ≡
      + n +-[1+ Nat.⌈ m /2⌉ ]
    lemma₂ m zero =
      ⌊ -[1+ P.suc m ] /2⌋  ≡⟨⟩
      -[1+ Nat.⌈ m /2⌉ ]    ∎
    lemma₂ m (P.suc n) =
      ⌊ + n ⊕ P.suc (n ⊕ 0) +-[1+ m ] /2⌋  ≡⟨ cong (⌊_/2⌋ ∘ +_+-[1+ m ]) $ sym $ Nat.suc+≡+suc n ⟩
      ⌊ + P.suc (2 ⊛ n) +-[1+ m ] /2⌋      ≡⟨ lemma₃ m n ⟩∎
      + P.suc n +-[1+ Nat.⌈ m /2⌉ ]        ∎

    lemma₃ :
      ∀ m n →
      ⌊ + P.suc (2 ⊛ n) +-[1+ m ] /2⌋ ≡
      + P.suc n +-[1+ Nat.⌈ m /2⌉ ]
    lemma₃ zero n = cong +_
      (Nat.⌊ 2 ⊛ n /2⌋  ≡⟨ Nat.⌊2*/2⌋≡ n ⟩∎
       n                ∎)
    lemma₃ (P.suc zero) zero =
      -[ 1 ]  ≡⟨⟩
      -[ 1 ]  ∎
    lemma₃ (P.suc zero) (P.suc n) = cong +_
      (Nat.⌊ n ⊕ P.suc (n ⊕ zero) /2⌋  ≡⟨ cong Nat.⌊_/2⌋ $ sym $ Nat.suc+≡+suc n ⟩
       Nat.⌊ 1 ⊕ 2 ⊛ n /2⌋             ≡⟨ Nat.⌊1+2*/2⌋≡ n ⟩∎
       n                               ∎)
    lemma₃ (P.suc (P.suc m)) n =
      ⌊ + 2 ⊛ n +-[1+ P.suc m ] /2⌋  ≡⟨ lemma₂ m n ⟩∎
      + n +-[1+ Nat.⌈ m /2⌉ ]        ∎

-- If you double and then halve an integer, then you get back what you
-- started with.

⌊*+2/2⌋≡ : ∀ i → ⌊ i *+ 2 /2⌋ ≡ i
⌊*+2/2⌋≡ i =
  ⌊ i *+ 2 /2⌋        ≡⟨ cong ⌊_/2⌋ $ sym $ +-left-identity {i = i *+ 2} ⟩
  ⌊ + 0 + i *+ 2 /2⌋  ≡⟨ ⌊+*+2/2⌋≡ (+ 0) {j = i} ⟩
  ⌊ + 0 /2⌋ + i       ≡⟨⟩
  + 0 + i             ≡⟨ +-left-identity ⟩∎
  i                   ∎


-- Andreas, 2018-10-16, runtime erasure
--
-- Should not be able to extract erased constructor field.

open import Agda.Builtin.Nat

data Vec (A : Set) : Nat → Set where
  [] : Vec A zero
  _∷_ : {@0 n : Nat} (x : A) (xs : Vec A n) → Vec A (suc n)

length : ∀{A} {@0 n} (x : Vec A n) → Nat
length [] = zero
length (_∷_ {n} _ _) = suc n

-- Expected error:
--
-- Variable n is declared erased, so it cannot be used here
-- when checking that the expression n has type Nat


{-# OPTIONS --without-K --exact-split --allow-unsolved-metas #-}

module SAT-solver where

import 14-univalence
open 14-univalence public

{- The literates are atomic propositions or negations thereof. We simply use
   the natural numbers to encode the atomic propositions, and we use the
   booleans to tell whether it should be negated or not. -}

Literate = ℕ × bool

neg-Literate : Literate → Literate
neg-Literate (pair n b) = pair n (neg-𝟚 b)

zero-true-Literate : Literate
zero-true-Literate = pair zero-ℕ true

truth-value-Literate : (ℕ → bool) → Literate → bool
truth-value-Literate f (pair n true) = f n
truth-value-Literate f (pair n false) = neg-𝟚 (f n)

bool-Eq-ℕ : ℕ → ℕ → bool
bool-Eq-ℕ zero-ℕ zero-ℕ = true
bool-Eq-ℕ zero-ℕ (succ-ℕ n) = false
bool-Eq-ℕ (succ-ℕ m) zero-ℕ = false
bool-Eq-ℕ (succ-ℕ m) (succ-ℕ n) = bool-Eq-ℕ m n

bool-Eq-𝟚 : bool → bool → bool
bool-Eq-𝟚 true true = true
bool-Eq-𝟚 true false = false
bool-Eq-𝟚 false true = false
bool-Eq-𝟚 false false = true

bool-Eq-Literate : Literate → Literate → bool
bool-Eq-Literate (pair m x) (pair n y) =
  conjunction-𝟚 (bool-Eq-ℕ m n) (bool-Eq-𝟚 x y)

{- Clauses are finite disjunctions of literates. We simply encode them using
   lists of literates. -}

Clause = list Literate

clause-Literate : Literate → Clause
clause-Literate l = cons l nil

is-literate-Clause : Clause → UU lzero
is-literate-Clause c = Σ Literate (λ l → Id (clause-Literate l) c)

zero-true-Clause = clause-Literate zero-true-Literate

truth-value-Clause : (ℕ → bool) → Clause → bool
truth-value-Clause f nil = false
truth-value-Clause f (cons l c) =
  disjunction-𝟚 (truth-value-Literate f l) (truth-value-Clause f c)

contains-Clause : Literate → Clause → bool
contains-Clause l nil = false
contains-Clause l (cons l' c) =
  disjunction-𝟚 (bool-Eq-Literate l l') (contains-Clause l c)

if-then-else : {l : Level} {A : UU l} → bool → A → A → A
if-then-else true x y = x
if-then-else false x y = y

if-then-else-dep :
  {l1 l2 : Level} {A : UU l1} (B : A → UU l2)
  (b : bool) {x y : A} (u : Id b true → B x) (v : Id b false → B y) →
  B (if-then-else b x y)
if-then-else-dep B true u v = u refl
if-then-else-dep B false u v = v refl

{- We write a function that simplifies a clause in the following way:
    * simplified clauses do not contain any literate more than once.
    * if a simplified clause contains a literate and its negation, then it is
      of the form l ∨ ¬l. -}

simplify-Clause : Clause → Clause
simplify-Clause nil = nil
simplify-Clause (cons l c) =
  if-then-else
    ( contains-Clause (neg-Literate l) c)
    ( cons l (cons (neg-Literate l) nil))
    ( if-then-else
      ( contains-Clause l c)
      ( simplify-Clause c)
      ( cons l (simplify-Clause c)))

is-satisfiable-Clause : Clause → UU lzero
is-satisfiable-Clause c = Σ (ℕ → bool) (λ f → Id (truth-value-Clause f c) true)

{- We show that any non-empty disjunctive clause is satisfiable. -}

right-true-law-disjunction-𝟚 : (b : bool) → Id (disjunction-𝟚 b true) true
right-true-law-disjunction-𝟚 true = refl
right-true-law-disjunction-𝟚 false = refl

left-true-law-disjunction-𝟚 : (b : bool) → Id (disjunction-𝟚 true b) true
left-true-law-disjunction-𝟚 true = refl
left-true-law-disjunction-𝟚 false = refl

is-satisfiable-cons-Clause :
  ( l : Literate) (c : Clause) → is-satisfiable-Clause (cons l c)
is-satisfiable-cons-Clause (pair n true) c =
  pair
    ( const ℕ bool true)
    ( left-true-law-disjunction-𝟚 (truth-value-Clause (const ℕ bool true) c))
is-satisfiable-cons-Clause (pair n false) c =
  pair
    ( const ℕ bool false)
    ( left-true-law-disjunction-𝟚 (truth-value-Clause (const ℕ bool false) c))

{- Formulas in conjunctive normal form are finite conjunctions of clauses, as
   defined above. Therefore we encode them as lists of clauses. -}

CNF = list Clause

truth-value-CNF : (ℕ → bool) → CNF → bool
truth-value-CNF f nil = true
truth-value-CNF f (cons c φ) =
  conjunction-𝟚 (truth-value-Clause f c) (truth-value-CNF f φ)

{- A formula φ is in conjunctive normal form is said to be satisfiable if there
   is a map ℕ → bool which evaluates φ to true. -}

is-satisfiable-CNF : CNF → UU lzero
is-satisfiable-CNF φ = Σ (ℕ → bool) (λ f → Id (truth-value-CNF f φ) true)

contains-CNF : (l : Literate) (φ : CNF) → bool
contains-CNF l nil = false
contains-CNF l (cons c φ) =
  disjunction-𝟚 (contains-Clause l c) (contains-CNF l φ)

contains

simplify-CNF : CNF → CNF
simplify-CNF nil = nil
simplify-CNF (cons c φ) = cons (simplify-Clause c) (simplify-CNF φ)


-- Andreas, 2015-07-16, issue reported by Nisse

postulate
  A   : Set₁
  P   : A → Set₁
  T   : Set₁ → Set₁
  Σ   : (A : Set₁) → (A → Set₁) → Set₁
  T-Σ : {A : Set₁} {B : A → Set₁} → (∀ x → T (B x)) → T (Σ A B)

t : T (Σ Set λ _ → Σ (A → A) λ f → Σ (∀ x₁ → P (f x₁)) λ _ → Set)
t = T-Σ λ _ → T-Σ λ _ → T-Σ {!!}

-- WAS:
-- Goal type and context:
--
--   Goal: (x : (x₁ : A) → P (x₁ x₁)) → T Set
--   ————————————————————————————————————————————————————————————
--   x₁ : A → A
--   x  : Set
--
-- Note the application "x₁ x₁".

-- EXPECTED:
-- Goal: (x : (x₁ : A) → P (.x₁ x₁)) → T Set
-- ————————————————————————————————————————————————————————————
-- .x₁ : A → A
-- .x  : Set

id : (x : A) → A
-- id _ = {!!}      -- Context displays .x
id = λ _ → {!!}  -- Context should display .x


import      Lvl
open import Type

module Structure.Logic.Constructive.Propositional {ℓₗ} {Formula : Type{ℓₗ}} {ℓₘₗ} (Proof : Formula → Type{ℓₘₗ}) where

open import Logic.Predicate

private variable X Y Z : Formula

-- Rules of bottom (falsity).
record Bottom(⊥ : Formula) : Type{ℓₘₗ Lvl.⊔ ℓₗ} where
  field
    elim : Proof(⊥) → Proof(X)
⊥ = \ ⦃([∃]-intro ▫) : ∃(Bottom)⦄ → ▫
module ⊥ {▫} ⦃ p ⦄ = Bottom {▫} p

-- Rules of top (truth).
record Top(⊤ : Formula) : Type{ℓₘₗ Lvl.⊔ ℓₗ} where
  field
    intro : Proof(⊤)
⊤ = \ ⦃([∃]-intro ▫) : ∃(Top)⦄ → ▫
module ⊤ {▫} ⦃ p ⦄ = Top {▫} p

-- Rules of conjunction (and).
record Conjunction(_∧_ : Formula → Formula → Formula) : Type{ℓₘₗ Lvl.⊔ ℓₗ} where
  field
    intro : Proof(X) → Proof(Y) → Proof(X ∧ Y)
    elimₗ : Proof(X ∧ Y) → Proof(X)
    elimᵣ : Proof(X ∧ Y) → Proof(Y)
_∧_ = \ ⦃([∃]-intro ▫) : ∃(Conjunction)⦄ → ▫
module ∧ {▫} ⦃ p ⦄ = Conjunction {▫} p

-- Rules of implication.
record Implication(_⟶_ : Formula → Formula → Formula) : Type{ℓₘₗ Lvl.⊔ ℓₗ} where
  field
    intro : (Proof(X) → Proof(Y)) → Proof(X ⟶ Y)
    elim  : Proof(X ⟶ Y) → Proof(X) → Proof(Y)
_⟶_ = \ ⦃([∃]-intro ▫) : ∃(Implication)⦄ → ▫
module ⟶ {▫} ⦃ p ⦄ = Implication {▫} p

-- Rules of reversed implication.
record Consequence(_⟵_ : Formula → Formula → Formula) : Type{ℓₘₗ Lvl.⊔ ℓₗ} where
  field
    intro : (Proof(X) → Proof(Y)) → Proof(Y ⟵ X)
    elim  : Proof(Y ⟵ X) → Proof(X) → Proof(Y)
_⟵_ = \ ⦃([∃]-intro ▫) : ∃(Consequence)⦄ → ▫
module ⟵ {▫} ⦃ p ⦄ = Consequence {▫} p

-- Rules of equivalence.
record Equivalence(_⟷_ : Formula → Formula → Formula) : Type{ℓₘₗ Lvl.⊔ ℓₗ} where
  field
    intro  : let _ = X in (Proof(Y) → Proof(X)) → (Proof(X) → Proof(Y)) → Proof(X ⟷ Y)
    elimₗ  : Proof(X ⟷ Y) → Proof(Y) → Proof(X)
    elimᵣ  : Proof(X ⟷ Y) → Proof(X) → Proof(Y)
_⟷_ = \ ⦃([∃]-intro ▫) : ∃(Equivalence)⦄ → ▫
module ⟷ {▫} ⦃ p ⦄ = Equivalence {▫} p

-- Rules of disjunction (or).
record Disjunction(_∨_  : Formula → Formula → Formula) : Type{ℓₘₗ Lvl.⊔ ℓₗ} where
  field
    introₗ : Proof(X) → Proof(X ∨ Y)
    introᵣ : Proof(Y) → Proof(X ∨ Y)
    elim   : (Proof(X) → Proof(Z)) → (Proof(Y) → Proof(Z)) → Proof(X ∨ Y) → Proof(Z)
_∨_ = \ ⦃([∃]-intro ▫) : ∃(Disjunction)⦄ → ▫
module ∨ {▫} ⦃ p ⦄ = Disjunction {▫} p

-- Rules of negation (not).
record Negation(¬_ : Formula → Formula) : Type{ℓₘₗ Lvl.⊔ ℓₗ} where
  field
    intro : (Proof(X) → Proof(Y)) → (Proof(X) → Proof(¬ Y)) → Proof(¬ X)
    elim  : Proof(X) → Proof(¬ X) → Proof(Y)
¬_ = \ ⦃([∃]-intro ▫) : ∃(Negation)⦄ → ▫
module ¬ {▫} ⦃ p ⦄ = Negation {▫} p

record Logic : Type{ℓₘₗ Lvl.⊔ ℓₗ} where
  field
    ⦃ bottom ⦄      : ∃(Bottom)
    ⦃ top ⦄         : ∃(Top)
    ⦃ conjunction ⦄ : ∃(Conjunction)
    ⦃ implication ⦄ : ∃(Implication)
    ⦃ consequence ⦄ : ∃(Consequence)
    ⦃ equivalence ⦄ : ∃(Equivalence)
    ⦃ disjunction ⦄ : ∃(Disjunction)
    ⦃ negation ⦄    : ∃(Negation)


------------------------------------------------------------------------
-- Finite sets (currently only some type signatures)
------------------------------------------------------------------------

module Data.Sets where

open import Relation.Nullary
open import Relation.Binary
open import Relation.Binary.OrderMorphism
open import Data.Function
open import Data.List as L using (List)
open import Data.Product using (∃; _×_)

module Sets₁ (dto : DecTotalOrder) where

  open DecTotalOrder dto public using (_≈_)
  open DecTotalOrder dto hiding (_≈_)

  infixr 6 _∪_
  infix  5 _∈?_
  infix  4 _∈_ _|≈|_

  abstract postulate decSetoid : DecSetoid

  <Set> : Set
  <Set> = DecSetoid.carrier decSetoid

  _|≈|_ : Rel <Set>
  _|≈|_ = DecSetoid._≈_ decSetoid

  abstract
   postulate
    empty  : <Set>
    insert : carrier → <Set> → <Set>
    _∪_    : <Set> → <Set> → <Set>
    _∈_    : carrier → <Set> → Set
    _∈?_   : (x : carrier) → (s : <Set>) → Dec (x ∈ s)
    toList : <Set> → List carrier

   postulate
    prop-∈-insert₁ : ∀ {x y s} → x ≈ y → x ∈ insert y s
    prop-∈-insert₂ : ∀ {x y s} → x ∈ s → x ∈ insert y s
    prop-∈-insert₃ : ∀ {x y s} → ¬ x ≈ y → x ∈ insert y s → x ∈ s

    prop-∈-empty : ∀ {x} → ¬ x ∈ empty

    prop-∈-∪ : ∀ {x s₁ s₂} → x ∈ s₁ → x ∈ s₁ ∪ s₂

    prop-∪₁ : ∀ {s₁ s₂}    → s₁ ∪ s₂        |≈| s₂ ∪ s₁
    prop-∪₂ : ∀ {s₁ s₂ s₃} → s₁ ∪ (s₂ ∪ s₃) |≈| (s₁ ∪ s₂) ∪ s₃

    prop-∈-|≈| : ∀ {x} → (λ s → x ∈ s) Respects _|≈|_
    prop-∈-≈   : ∀ {s} → (λ x → x ∈ s) Respects  _≈_

    -- TODO: Postulates for toList.

  singleton : carrier → <Set>
  singleton x = insert x empty

  ⋃_ : List <Set> → <Set>
  ⋃_ = L.foldr _∪_ empty

  fromList : List carrier → <Set>
  fromList = L.foldr insert empty

  _⊆_ : <Set> → <Set> → Set
  s₁ ⊆ s₂ = ∀ x → x ∈ s₁ → x ∈ s₂

open Sets₁ public
open DecTotalOrder hiding (_≈_)
open _⇒-Poset_

abstract
 postulate
  map : ∀ {do₁ do₂} → do₁ ⇒-DTO do₂ → <Set> do₁ → <Set> do₂
  mapToSet : ∀ {do₁ do₂} →
             (carrier do₁ → <Set> do₂) →
             <Set> do₁ → <Set> do₂

  prop-map-∈₁ : ∀ {do₁ do₂ f x s} →
                      x ⟨ _∈_ do₁ ⟩₁       s →
                fun f x ⟨ _∈_ do₂ ⟩₁ map f s
  prop-map-∈₂ : ∀ {do₁ do₂ f y s} →
                y ⟨ _∈_ do₂ ⟩₁ map f s →
                ∃ λ x → (fun f x ⟨ _≈_ do₂ ⟩₁ y) ×
                        (      x ⟨ _∈_ do₁ ⟩₁ s)

  prop-mapToSet₁ : ∀ {do₁ do₂ f x s} →
                     x ⟨ _∈_ do₁ ⟩₁            s →
                   f x ⟨ _⊆_ do₂ ⟩₁ mapToSet f s
  prop-mapToSet₂ : ∀ {do₁ do₂ f y s} →
                   y ⟨ _∈_ do₂ ⟩₁ mapToSet f s →
                   ∃ λ x → (y ⟨ _∈_ do₂ ⟩₁ f x) ×
                           (x ⟨ _∈_ do₁ ⟩₁ s)


module Control.Monad.Writer where

open import Prelude
open import Control.Monad.Zero
open import Control.Monad.Identity
open import Control.Monad.Transformer

record WriterT {a} (W : Set a) (M : Set a → Set a) (A : Set a) : Set a where
  no-eta-equality
  constructor writerT
  field runWriterT : M (A × W)

open WriterT public

module _ {a} {W : Set a} {M : Set a → Set a} where

  instance
    FunctorWriterT : {{_ : Functor M}} → Functor {a = a} (WriterT W M)
    runWriterT (fmap {{ FunctorWriterT }} f m) = first f <$> runWriterT m

    FunctorZeroWriterT : {{_ : FunctorZero M}} → FunctorZero {a = a} (WriterT W M)
    runWriterT (empty {{FunctorZeroWriterT}}) = empty

    AlternativeWriterT : {{_ : Alternative M}} → Alternative {a = a} (WriterT W M)
    runWriterT (_<|>_ {{AlternativeWriterT}} x y) = runWriterT x <|> runWriterT y

  module _ {{_ : Monoid W}} {{_ : Monad M}} where

    private
      bindWriterT : ∀ {A B} → WriterT W M A → (A → WriterT W M B) → WriterT W M B
      runWriterT (bindWriterT m f) = do
        (x , w₁) ← runWriterT m
        (y , w₂) ← (runWriterT (f x))
        return (y , w₁ <> w₂)

    instance
      ApplicativeWriterT : Applicative {a = a} (WriterT W M)
      runWriterT (pure {{ApplicativeWriterT}} x) = return (x , mempty)
      _<*>_ {{ApplicativeWriterT}} = monadAp bindWriterT

      MonadWriterT : Monad {a = a} (WriterT W M)
      _>>=_  {{MonadWriterT}} = bindWriterT

    liftWriterT : {A : Set a} → M A → WriterT W M A
    runWriterT (liftWriterT m) = (_, mempty) <$> m

    writer : {A : Set a} → A × W → WriterT W M A
    runWriterT (writer (x , w)) = return (x , w)

    tell : W → WriterT W M ⊤′
    runWriterT (tell w) = return (tt , w)

    listens : {A B : Set a} → (W → B) → WriterT W M A → WriterT W M (A × B)
    runWriterT (listens f m) = do
      (x , w) ← runWriterT m
      return ((x , f w) , w)

    listen : {A : Set a} → WriterT W M A → WriterT W M (A × W)
    listen = listens id

    pass : {A : Set a} → WriterT W M (A × (W → W)) → WriterT W M A
    runWriterT (pass m) = do
      ((x , f) , w) ← runWriterT m
      return (x , f w)

    censor : {A : Set a} → (W → W) → WriterT W M A → WriterT W M A
    censor f m = pass ((_, f) <$> m)

instance
  TransformerWriterT : ∀ {a} {W : Set a} {{_ : Monoid W}} → Transformer (WriterT W)
  lift {{TransformerWriterT}} = liftWriterT

Writer : ∀ {a} (W : Set a) (A : Set a) → Set a
Writer W = WriterT W Identity

runWriter : ∀ {a} {W : Set a} {A : Set a} → Writer W A → A × W
runWriter m = runIdentity (runWriterT m)

execWriter : ∀ {a} {W : Set a} {A : Set a} → Writer W A → W
execWriter = snd ∘ runWriter


module Cats.Category.Fun.Facts where

open import Cats.Category
open import Cats.Category.Cat using (_≈_)
open import Cats.Category.Fun using (Trans ; Fun ; ≈-intro ; ≈-elim)
open import Cats.Functor using (Functor)
open import Cats.Trans.Iso using (NatIso ; iso ; forth-natural ; back-natural)

open import Level using (_⊔_)

open Functor
open Trans
open Category._≅_

module _ {lo la l≈ lo′ la′ l≈′}
  {C : Category lo la l≈}
  {D : Category lo′ la′ l≈′}
  {F G : Functor C D}
  where

  private
    module C = Category C
    module D = Category D
    open D.≈-Reasoning
    open Category (Fun C D) using (_≅_)

  NatIso→≅ : NatIso F G → F ≅ G
  NatIso→≅ i = record
      { forth = Forth i
      ; back = Back i
      ; back-forth = ≈-intro (back-forth (iso i))
      ; forth-back = ≈-intro (forth-back (iso i))
      }
    where
      open NatIso

  ≅→NatIso : F ≅ G → NatIso F G
  ≅→NatIso i = record
      { iso = λ {c} → record
          { forth = component (forth i) c
          ; back = component (back i) c
          ; back-forth = ≈-elim (back-forth i)
          ; forth-back = ≈-elim (forth-back i)
          }
      ; forth-natural = natural (forth i)
      }

  ≈→≅ : F ≈ G → F ≅ G
  ≈→≅ eq = NatIso→≅ eq

  ≅→≈ : F ≅ G → F ≈ G
  ≅→≈ i = ≅→NatIso i


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

module Categories.Category.Instance.Properties.Setoids.Extensive where

open import Level
open import Data.Product using (∃; Σ; proj₁; proj₂; _,_; _×_)
open import Data.Sum.Base as Sum using (_⊎_; inj₁; inj₂)
open import Data.Sum.Relation.Binary.Pointwise using (inj₁; inj₂; _⊎ₛ_; drop-inj₁; drop-inj₂)
open import Data.Unit.Polymorphic using (tt)
open import Function.Equality using (Π; _⟶_; _⇨_; _∘_)
open import Relation.Binary using (Setoid)
import  Relation.Binary.Reasoning.Setoid as SetoidR

open import Categories.Category using (Category; _[_,_])
open import Categories.Category.Instance.Setoids using (Setoids)
open import Categories.Category.Extensive using (Extensive)
open import Categories.Category.Cocartesian using (Cocartesian)
open import Categories.Diagram.Pullback using (Pullback)
open import Categories.Category.Instance.Properties.Setoids.Limits.Canonical using (pullback; FiberProduct)
open import Categories.Category.Monoidal.Instance.Setoids using (Setoids-Cocartesian)

open Π
open Pullback

-- Note the Setoids is extensive if the two levels coincide.  Whether it happens more generally
-- is unknown at this point.

Setoids-Extensive : (ℓ : Level) → Extensive (Setoids ℓ ℓ)
Setoids-Extensive ℓ = record
   { cocartesian = record { initial = initial ; coproducts = coproducts }
   ; pullback₁ = λ f → pullback ℓ ℓ f i₁
   ; pullback₂ = λ f → pullback ℓ ℓ f i₂
   ; pullback-of-cp-is-cp = λ f → record
        { [_,_] = λ g h → copair f g h
        ; inject₁ = λ {X g h z} eq →
             trans (isEquivalence X) (copair-inject₁ f g h z) (cong g eq)
        ; inject₂ = λ {X g h z} eq →
             trans (isEquivalence X) (copair-inject₂ f g h z) (cong h eq)
        ; unique = λ {X u g h} feq₁ feq₂ {z} eq →
             trans (isEquivalence X) (copair-unique f g h u z (λ {z} → feq₁ {z}) (λ {z} → feq₂ {z})) (cong u eq)
        }
   ; pullback₁-is-mono = λ _ _ eq x≈y → drop-inj₁ (eq x≈y)
   ; pullback₂-is-mono = λ _ _ eq x≈y → drop-inj₂ (eq x≈y)
   ; disjoint = λ {A B} → record
        { commute = λ { {()} _}
        ; universal = λ {C f g} eq → record
           { _⟨$⟩_ = λ z → conflict A B (eq {x = z} (refl (isEquivalence C)))
           ; cong = λ z → tt
           }
        ; unique = λ _ _ _ → tt
        ; p₁∘universal≈h₁ = λ {_ _ _ eq} x≈y → conflict A B (eq x≈y)
        ; p₂∘universal≈h₂ = λ {_ _ _ eq} x≈y → conflict A B (eq x≈y)
        }
   }
     where
       open Cocartesian (Setoids-Cocartesian {ℓ} {ℓ})
       open Relation.Binary.IsEquivalence
       open Setoid renaming (_≈_ to [_][_≈_]; Carrier to ∣_∣) using (isEquivalence)

       -- must be in the standard library. Maybe it is?
       conflict : ∀ {ℓ ℓ' ℓ''} (X Y : Setoid ℓ ℓ') {Z : Set ℓ''}
         {x : ∣ X ∣} {y : ∣ Y ∣} → [ X ⊎ₛ Y ][ inj₁ x ≈ inj₂ y ] → Z
       conflict X Y ()

       module Diagram {A B C X : Setoid ℓ ℓ} (f : C ⟶ A ⊎ₛ B)
         (g : P (pullback ℓ ℓ f i₁) ⟶ X) (h : P (pullback ℓ ℓ f i₂) ⟶ X) where

         private
           module A = Setoid A
           module B = Setoid B
           module C = Setoid C
           module X = Setoid X
           A⊎B = A ⊎ₛ B
           module A⊎B = Setoid (A ⊎ₛ B)

           A′ = P (pullback ℓ ℓ f i₁)
           B′ = P (pullback ℓ ℓ f i₂)
           A⊎B′ = A′ ⊎ₛ B′
           module A⊎B′ = Setoid A⊎B′
           open SetoidR A⊎B′

         _⊎⟶_ : {o₁ o₂ o₃ ℓ₁ ℓ₂ ℓ₃ : Level} {X : Setoid o₁ ℓ₁} {Y : Setoid o₂ ℓ₂} {Z : Setoid o₃ ℓ₃} →
           (X ⟶ Z) → (Y ⟶ Z) → (X ⊎ₛ Y) ⟶ Z
         f₁ ⊎⟶ f₂ = record
           { _⟨$⟩_ = Sum.[ f₁ ⟨$⟩_ , f₂ ⟨$⟩_ ]
           ; cong = λ { (inj₁ x) → cong f₁ x ; (inj₂ x) → cong f₂ x}
           }

         to-⊎ₛ : (z : ∣ C ∣) → (w : ∣ A ⊎ₛ B ∣) → (eq : [ A⊎B ][ f ⟨$⟩ z ≈ w ]) → ∣ A′ ⊎ₛ B′ ∣
         to-⊎ₛ z (inj₁ x) eq = inj₁ (record { elem₁ = z ; elem₂ = x ; commute = eq })
         to-⊎ₛ z (inj₂ y) eq = inj₂ (record { elem₁ = z ; elem₂ = y ; commute = eq })

         to-⊎ₛ-cong : {z : ∣ C ∣} {w w′ : ∣ A ⊎ₛ B ∣ } → [ A⊎B ][ w ≈ w′ ] →
           {eq : [ A⊎B ][ f ⟨$⟩ z ≈ w ]} → {eq′ : [ A⊎B ][ f ⟨$⟩ z ≈ w′ ]} → [ A⊎B′ ][ to-⊎ₛ z w eq ≈ to-⊎ₛ z w′ eq′ ]
         to-⊎ₛ-cong (inj₁ x) = inj₁ (C.refl , x)
         to-⊎ₛ-cong (inj₂ x) = inj₂ (C.refl , x)

         f⟨$⟩→ : (z : ∣ C ∣) → ∣ A′ ⊎ₛ B′ ∣
         f⟨$⟩→ z = to-⊎ₛ z (f ⟨$⟩ z) A⊎B.refl

         f⟨$⟩-cong′ : {z z′ : ∣ C ∣} → (z≈z′ : [ C ][ z ≈ z′ ]) → (w w′ : ∣ A ⊎ₛ B ∣) →
           [ A⊎B ][ f ⟨$⟩ z ≈ w ] → [ A⊎B ][ f ⟨$⟩ z′ ≈ w′ ] → [ A′ ⊎ₛ B′ ][ f⟨$⟩→ z ≈ f⟨$⟩→ z′ ]
         f⟨$⟩-cong′ {z} {z′} z≈z′ (inj₁ x) (inj₁ x₁) fz≈w fz′≈w′ = begin
           f⟨$⟩→ z                       ≈⟨ A⊎B′.refl ⟩
           to-⊎ₛ z (f ⟨$⟩ z) A⊎B.refl   ≈⟨ to-⊎ₛ-cong fz≈w ⟩
           to-⊎ₛ z (inj₁ x) fz≈w       ≈⟨ inj₁ (z≈z′ , (drop-inj₁ (A⊎B.trans (A⊎B.sym fz≈w) (A⊎B.trans (cong f z≈z′) fz′≈w′)))) ⟩
           to-⊎ₛ z′ (inj₁ x₁) fz′≈w′   ≈⟨ to-⊎ₛ-cong (A⊎B.sym fz′≈w′) ⟩
           to-⊎ₛ z′ (f ⟨$⟩ z′) A⊎B.refl ≈⟨ A⊎B′.refl ⟩
           f⟨$⟩→ z′ ∎
         f⟨$⟩-cong′ z≈z′ (inj₁ x) (inj₂ y) fz≈w fz′≈w′ = conflict A B (A⊎B.trans (A⊎B.sym fz≈w) (A⊎B.trans (cong f z≈z′) fz′≈w′))
         f⟨$⟩-cong′ z≈z′ (inj₂ y) (inj₁ x) fz≈w fz′≈w′ = conflict A B (A⊎B.trans (A⊎B.sym fz′≈w′) (A⊎B.trans (cong f (C.sym z≈z′)) fz≈w))
         f⟨$⟩-cong′ {z} {z′} z≈z′ (inj₂ y) (inj₂ y₁) fz≈w fz′≈w′ = begin
           to-⊎ₛ z (f ⟨$⟩ z) A⊎B.refl   ≈⟨ to-⊎ₛ-cong fz≈w ⟩
           to-⊎ₛ z (inj₂ y) fz≈w       ≈⟨ inj₂ (z≈z′ , (drop-inj₂ (A⊎B.trans (A⊎B.sym fz≈w) (A⊎B.trans (cong f z≈z′) fz′≈w′)))) ⟩
           to-⊎ₛ z′ (inj₂ y₁) fz′≈w′   ≈⟨ to-⊎ₛ-cong (A⊎B.sym fz′≈w′) ⟩
           to-⊎ₛ z′ (f ⟨$⟩ z′) A⊎B.refl ∎

         f⟨$⟩-cong : {i j : ∣ C ∣} → i C.≈ j → [ A′ ⊎ₛ B′ ][ f⟨$⟩→ i ≈ f⟨$⟩→ j ]
         f⟨$⟩-cong {i} {j} i≈j = f⟨$⟩-cong′ i≈j (f ⟨$⟩ i) (f ⟨$⟩ j) A⊎B.refl A⊎B.refl

         f⟨$⟩ : C ⟶ A′ ⊎ₛ B′
         f⟨$⟩ = record { _⟨$⟩_ = f⟨$⟩→ ; cong = f⟨$⟩-cong }

         -- copairing of g : A′ → X and h : B′ → X, resulting in C → X
         copair : C ⟶ X
         copair = (g ⊎⟶ h) ∘ f⟨$⟩

         copair-inject₁ : (z : FiberProduct f i₁) → [ X ][ copair ⟨$⟩ (FiberProduct.elem₁ z) ≈ g ⟨$⟩ z ]
         copair-inject₁ record { elem₁ = z ; elem₂ = x ; commute = eq } = cong (g ⊎⟶ h) (to-⊎ₛ-cong eq)

         copair-inject₂ : (z : FiberProduct f i₂) → [ X ][ copair ⟨$⟩ (FiberProduct.elem₁ z) ≈ h ⟨$⟩ z ]
         copair-inject₂ record { elem₁ = z ; elem₂ = y ; commute = eq } = cong (g ⊎⟶ h) (to-⊎ₛ-cong eq)

         copair-unique′ : (u : C ⟶ X) (z : ∣ C ∣) →
           [ A′ ⇨ X ][ u ∘ p₁ (pullback ℓ ℓ f i₁) ≈ g ] →
           [ B′ ⇨ X ][ u ∘ p₁ (pullback ℓ ℓ f i₂) ≈ h ] →
           (w : ∣ A⊎B ∣) → [ A⊎B ][ f ⟨$⟩ z ≈ w ] →
           [ X ][ copair ⟨$⟩ z ≈ u ⟨$⟩ z ]
         copair-unique′ u z feq₁ feq₂ (inj₁ x) fz≈w = XR.begin
           copair ⟨$⟩ z                                XR.≈⟨ X.refl ⟩
           g ⊎⟶ h ⟨$⟩ (to-⊎ₛ z (f ⟨$⟩ z) A⊎B.refl)     XR.≈⟨ cong (g ⊎⟶ h) (to-⊎ₛ-cong fz≈w) ⟩
           g ⊎⟶ h ⟨$⟩ (to-⊎ₛ z (inj₁ x) fz≈w)         XR.≈⟨ X.refl ⟩
           g ⟨$⟩ fb                                    XR.≈⟨ X.sym (feq₁ {x = fb} (C.refl , A.refl)) ⟩
           u ⟨$⟩ z                                     XR.∎

           where
             module XR = SetoidR X
             fb = record {elem₁ = z ; elem₂ = x; commute = fz≈w }
         copair-unique′ u z feq₁ feq₂ (inj₂ y) fz≈w = XR.begin
           copair ⟨$⟩ z                                XR.≈⟨ X.refl ⟩
           g ⊎⟶ h ⟨$⟩ (to-⊎ₛ z (f ⟨$⟩ z) A⊎B.refl)     XR.≈⟨ cong (g ⊎⟶ h) (to-⊎ₛ-cong fz≈w) ⟩
           g ⊎⟶ h ⟨$⟩ (to-⊎ₛ z (inj₂ y) fz≈w)         XR.≈⟨ X.refl ⟩
           h ⟨$⟩ fb                                    XR.≈⟨ X.sym (feq₂ {x = fb} {y = fb} (C.refl , B.refl)) ⟩
           u ⟨$⟩ z                                     XR.∎
           where
             module XR = SetoidR X
             fb = record {elem₁ = z ; elem₂ = y; commute = fz≈w }

         copair-unique : (u : C ⟶ X) (z : ∣ C ∣) →
           [ A′ ⇨ X ][ u ∘ p₁ (pullback ℓ ℓ f i₁) ≈ g ] →
           [ B′ ⇨ X ][ u ∘ p₁ (pullback ℓ ℓ f i₂) ≈ h ] →
           [ X ][ copair ⟨$⟩ z ≈ u ⟨$⟩ z ]
         copair-unique u z feq₁ feq₂ = copair-unique′ u z (λ {x} {y} → feq₁ {x} {y}) (λ {x} {y} → feq₂ {x} {y}) (f ⟨$⟩ z) A⊎B.refl

       open Diagram


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

module Data.Binary.Addition where

open import Data.Binary.Definition
open import Data.Binary.Increment

add₁ : 𝔹 → 𝔹 → 𝔹
add₂ : 𝔹 → 𝔹 → 𝔹

add₁ 0ᵇ      ys      = inc ys
add₁ (1ᵇ xs) 0ᵇ      = 2ᵇ xs
add₁ (2ᵇ xs) 0ᵇ      = 1ᵇ inc xs
add₁ (1ᵇ xs) (1ᵇ ys) = 1ᵇ add₁ xs ys
add₁ (1ᵇ xs) (2ᵇ ys) = 2ᵇ add₁ xs ys
add₁ (2ᵇ xs) (1ᵇ ys) = 2ᵇ add₁ xs ys
add₁ (2ᵇ xs) (2ᵇ ys) = 1ᵇ add₂ xs ys

add₂ 0ᵇ      0ᵇ      = 2ᵇ 0ᵇ
add₂ 0ᵇ      (1ᵇ ys) = 1ᵇ inc ys
add₂ 0ᵇ      (2ᵇ ys) = 2ᵇ inc ys
add₂ (1ᵇ xs) 0ᵇ      = 1ᵇ inc xs
add₂ (2ᵇ xs) 0ᵇ      = 2ᵇ inc xs
add₂ (1ᵇ xs) (1ᵇ ys) = 2ᵇ add₁ xs ys
add₂ (1ᵇ xs) (2ᵇ ys) = 1ᵇ add₂ xs ys
add₂ (2ᵇ xs) (1ᵇ ys) = 1ᵇ add₂ xs ys
add₂ (2ᵇ xs) (2ᵇ ys) = 2ᵇ add₂ xs ys

infixl 6 _+_
_+_ : 𝔹 → 𝔹 → 𝔹
0ᵇ    + ys    = ys
1ᵇ xs + 0ᵇ    = 1ᵇ xs
2ᵇ xs + 0ᵇ    = 2ᵇ xs
1ᵇ xs + 1ᵇ ys = 2ᵇ (xs + ys)
1ᵇ xs + 2ᵇ ys = 1ᵇ add₁ xs ys
2ᵇ xs + 1ᵇ ys = 1ᵇ add₁ xs ys
2ᵇ xs + 2ᵇ ys = 2ᵇ add₁ xs ys


open import Data.Product using ( _,_ )
open import Data.Empty using ( ⊥ )
open import FRP.LTL.ISet.Core using ( ISet ; [_] ; _,_ )

module FRP.LTL.ISet.Empty where

F : ISet
F = [ (λ i → ⊥) , (λ i j i~j → λ ()) , (λ i j i⊑j → λ ()) ]


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

open import Algebra

module Control.Monad.Weighted {ℓ} (rng : Semiring ℓ) where

open import Control.Monad.Weighted.Definition rng public
open import Control.Monad.Weighted.Union      rng using (_∪_) public
open import Control.Monad.Weighted.Cond       rng using (_⋊_) public
open import Control.Monad.Weighted.Monad      rng using (_>>=_; pure; _>>_; _<*>_) public

import Control.Monad.Weighted.Expect using (∫)

module Expect = Control.Monad.Weighted.Expect rng


------------------------------------------------------------------------
-- The Agda standard library
--
-- Indexed monads
------------------------------------------------------------------------

-- Note that currently the monad laws are not included here.

module Category.Monad.Indexed where

open import Category.Applicative.Indexed
open import Function
open import Level

record RawIMonad {i f} {I : Set i} (M : IFun I f) :
                 Set (i ⊔ suc f) where
  infixl 1 _>>=_ _>>_ _>=>_
  infixr 1 _=<<_ _<=<_

  field
    return : ∀ {i A} → A → M i i A
    _>>=_  : ∀ {i j k A B} → M i j A → (A → M j k B) → M i k B

  _>>_ : ∀ {i j k A B} → M i j A → M j k B → M i k B
  m₁ >> m₂ = m₁ >>= λ _ → m₂

  _=<<_ : ∀ {i j k A B} → (A → M j k B) → M i j A → M i k B
  f =<< c = c >>= f

  _>=>_ : ∀ {i j k a} {A : Set a} {B C} →
          (A → M i j B) → (B → M j k C) → (A → M i k C)
  f >=> g = _=<<_ g ∘ f

  _<=<_ : ∀ {i j k B C a} {A : Set a} →
          (B → M j k C) → (A → M i j B) → (A → M i k C)
  g <=< f = f >=> g

  join : ∀ {i j k A} → M i j (M j k A) → M i k A
  join m = m >>= id

  rawIApplicative : RawIApplicative M
  rawIApplicative = record
    { pure = return
    ; _⊛_  = λ f x → f >>= λ f' → x >>= λ x' → return (f' x')
    }

  open RawIApplicative rawIApplicative public

record RawIMonadZero {i f} {I : Set i} (M : IFun I f) :
                     Set (i ⊔ suc f) where
  field
    monad : RawIMonad M
    ∅     : ∀ {i j A} → M i j A

  open RawIMonad monad public

record RawIMonadPlus {i f} {I : Set i} (M : IFun I f) :
                     Set (i ⊔ suc f) where
  infixr 3 _∣_
  field
    monadZero : RawIMonadZero M
    _∣_       : ∀ {i j A} → M i j A → M i j A → M i j A

  open RawIMonadZero monadZero public


{-
This second-order equational theory was created from the following second-order syntax description:

syntax Empty | E

type
  𝟘 : 0-ary

term
  abort : 𝟘  ->  α

theory
  (𝟘η) e : 𝟘  c : α |> abort(e) = c
-}

module Empty.Equality where

open import SOAS.Common
open import SOAS.Context
open import SOAS.Variable
open import SOAS.Families.Core
open import SOAS.Families.Build
open import SOAS.ContextMaps.Inductive

open import Empty.Signature
open import Empty.Syntax

open import SOAS.Metatheory.SecondOrder.Metasubstitution E:Syn
open import SOAS.Metatheory.SecondOrder.Equality E:Syn

private
  variable
    α β γ τ : ET
    Γ Δ Π : Ctx

infix 1 _▹_⊢_≋ₐ_

-- Axioms of equality
data _▹_⊢_≋ₐ_ : ∀ 𝔐 Γ {α} → (𝔐 ▷ E) α Γ → (𝔐 ▷ E) α Γ → Set where
  𝟘η : ⁅ 𝟘 ⁆ ⁅ α ⁆̣ ▹ ∅ ⊢ abort 𝔞 ≋ₐ 𝔟

open EqLogic _▹_⊢_≋ₐ_
open ≋-Reasoning


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

open import lib.Base
open import lib.PathGroupoid
open import lib.Relation
open import lib.NType
open import lib.types.Empty

module lib.types.Nat where

infixl 80 _+_
_+_ : ℕ → ℕ → ℕ
0 + n = n
(S m) + n = S (m + n)

{-# BUILTIN NATPLUS _+_ #-}

+-unit-r : (m : ℕ) → m + 0 == m
+-unit-r 0     = idp
+-unit-r (S m) = ap S (+-unit-r m)

+-βr : (m n : ℕ) → m + (S n) == S (m + n)
+-βr 0     n = idp
+-βr (S m) n = ap S (+-βr m n)

+-comm : (m n : ℕ) → m + n == n + m
+-comm m 0     = +-unit-r m
+-comm m (S n) = +-βr m n ∙ ap S (+-comm m n)

+-assoc : (k m n : ℕ) → (k + m) + n == k + (m + n)
+-assoc 0     m n = idp
+-assoc (S k) m n = ap S (+-assoc k m n)

infix 120 _*2
_*2 : ℕ → ℕ
O *2 = O
(S n) *2 = S (S (n *2))

ℕ-pred : ℕ → ℕ
ℕ-pred 0 = 0
ℕ-pred (S n) = n

ℕ-S-inj : (n m : ℕ) (p : S n == S m) → n == m
ℕ-S-inj n m p = ap ℕ-pred p

ℕ-S-≠ : ∀ {n m : ℕ} (p : n ≠ m) → S n ≠ S m
ℕ-S-≠ p = p ∘ ℕ-S-inj _ _

private
  ℕ-S≠O-type : ℕ → Type₀
  ℕ-S≠O-type O = Empty
  ℕ-S≠O-type (S n) = Unit

abstract
  ℕ-S≠O : (n : ℕ) → S n ≠ O
  ℕ-S≠O n p = transport ℕ-S≠O-type p unit

  ℕ-O≠S : (n : ℕ) → (O ≠ S n)
  ℕ-O≠S n p = ℕ-S≠O n (! p)

  ℕ-has-dec-eq : has-dec-eq ℕ
  ℕ-has-dec-eq O O = inl idp
  ℕ-has-dec-eq O (S n) = inr (ℕ-O≠S n)
  ℕ-has-dec-eq (S n) O = inr (ℕ-S≠O n)
  ℕ-has-dec-eq (S n) (S m) with ℕ-has-dec-eq n m
  ℕ-has-dec-eq (S n) (S m) | inl p = inl (ap S p)
  ℕ-has-dec-eq (S n) (S m) | inr p⊥ = inr (λ p → p⊥ (ℕ-S-inj n m p))

  ℕ-is-set : is-set ℕ
  ℕ-is-set = dec-eq-is-set ℕ-has-dec-eq

ℕ-level = ℕ-is-set

{- Inequalities -}
infix 40 _<_ _≤_

data _<_ : ℕ → ℕ → Type₀ where
  ltS : {m : ℕ} → m < (S m)
  ltSR : {m n : ℕ} → m < n → m < (S n)

_≤_ : ℕ → ℕ → Type₀
m ≤ n = Coprod (m == n) (m < n)

-- properties of [<]

instance
  O<S : (m : ℕ) → O < S m
  O<S O = ltS
  O<S (S m) = ltSR (O<S m)

O≤ : (m : ℕ) → O ≤ m
O≤ O = inl idp
O≤ (S m) = inr (O<S m)

≮O : ∀ n → ¬ (n < O)
≮O _ ()

<-trans : {m n k : ℕ} → m < n → n < k → m < k
<-trans lt₁ ltS = ltSR lt₁
<-trans lt₁ (ltSR lt₂) = ltSR (<-trans lt₁ lt₂)

≤-refl : {m : ℕ} → m ≤ m
≤-refl = inl idp

≤-trans : {m n k : ℕ} → m ≤ n → n ≤ k → m ≤ k
≤-trans {k = k} (inl p₁) lte₂ = transport (λ t → t ≤ k) (! p₁) lte₂
≤-trans {m = m} lte₁ (inl p₂) = transport (λ t → m ≤ t) p₂ lte₁
≤-trans (inr lt₁) (inr lt₂) = inr (<-trans lt₁ lt₂)

<-ap-S : {m n : ℕ} → m < n → S m < S n
<-ap-S ltS = ltS
<-ap-S (ltSR lt) = ltSR (<-ap-S lt)

≤-ap-S : {m n : ℕ} → m ≤ n → S m ≤ S n
≤-ap-S (inl p) = inl (ap S p)
≤-ap-S (inr lt) = inr (<-ap-S lt)

<-cancel-S : {m n : ℕ} → S m < S n → m < n
<-cancel-S ltS = ltS
<-cancel-S (ltSR lt) = <-trans ltS lt

≤-cancel-S : {m n : ℕ} → S m ≤ S n → m ≤ n
≤-cancel-S (inl p) = inl (ap ℕ-pred p)
≤-cancel-S (inr lt) = inr (<-cancel-S lt)

<-dec : Decidable _<_
<-dec _     O     = inr (≮O _)
<-dec O     (S m) = inl (O<S m)
<-dec (S n) (S m) with <-dec n m
<-dec (S n) (S m) | inl p  = inl (<-ap-S p)
<-dec (S n) (S m) | inr p⊥ = inr (p⊥ ∘ <-cancel-S)

≯-to-≤ : {m n : ℕ} → ¬ (n < m) → m ≤ n
≯-to-≤ {O} {O} _ = inl idp
≯-to-≤ {O} {S n} _ = inr (O<S n)
≯-to-≤ {S m} {O} neggt = ⊥-elim $ neggt (O<S m)
≯-to-≤ {S m} {S n} neggt = ≤-ap-S (≯-to-≤ (neggt ∘ <-ap-S))

<-+-l : {m n : ℕ} (k : ℕ) → m < n → (k + m) < (k + n)
<-+-l O lt = lt
<-+-l (S k) lt = <-ap-S (<-+-l k lt)

≤-+-l : {m n : ℕ} (k : ℕ) → m ≤ n → (k + m) ≤ (k + n)
≤-+-l k (inl p) = inl (ap (λ t → k + t) p)
≤-+-l k (inr lt) = inr (<-+-l k lt)

<-+-r : {m n : ℕ} (k : ℕ) → m < n → (m + k) < (n + k)
<-+-r k ltS = ltS
<-+-r k (ltSR lt) = ltSR (<-+-r k lt)

≤-+-r : {m n : ℕ} (k : ℕ) → m ≤ n → (m + k) ≤ (n + k)
≤-+-r k (inl p) = inl (ap (λ t → t + k) p)
≤-+-r k (inr lt) = inr (<-+-r k lt)

<-witness : {m n : ℕ} → (m < n) → Σ ℕ (λ k → S k + m == n)
<-witness ltS = (O , idp)
<-witness (ltSR lt) = let w' = <-witness lt in (S (fst w') , ap S (snd w'))

≤-witness : {m n : ℕ} → (m ≤ n) → Σ ℕ (λ k → k + m == n)
≤-witness (inl p) = (O , p)
≤-witness (inr lt) = let w' = <-witness lt in (S (fst w') , snd w')

*2-increasing : (m : ℕ) → (m ≤ m *2)
*2-increasing O = inl idp
*2-increasing (S m) = ≤-trans (≤-ap-S (*2-increasing m)) (inr ltS)

*2-monotone-< : {m n : ℕ} → m < n → m *2 < n *2
*2-monotone-< ltS = ltSR ltS
*2-monotone-< (ltSR lt) = ltSR (ltSR (*2-monotone-< lt))

*2-monotone-≤ : {m n : ℕ} → m ≤ n → m *2 ≤ n *2
*2-monotone-≤ (inl p) = inl (ap _*2 p)
*2-monotone-≤ (inr lt) = inr (*2-monotone-< lt)


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

module Data.Vec where

open import Prelude

private
  variable
    n m : ℕ

infixr 5 _∷_
data Vec (A : Type a) : ℕ → Type a where
  [] : Vec A zero
  _∷_ : A → Vec A n → Vec A (suc n)

head : Vec A (suc n) → A
head (x ∷ _) = x

foldr : (A → B → B) → B → Vec A n → B
foldr f b [] = b
foldr f b (x ∷ xs) = f x (foldr f b xs)


open import Common.Size

postulate
  A : Set
  f : Size → A

-- k < j ==> ∃ l < j
works : ∀ i (j : Size< (↑ i)) (k : Size< j) → (((l : Size< j) → A) → A) → A
works i j k ret = ret λ l → f l

-- k < j <= i ==> ∃ l < i
test1 : ∀ i (j : Size< (↑ i)) (k : Size< j) → (((l : Size< i) → A) → A) → A
test1 i j k ret = ret λ l → f l

-- k' < k < j <= i + 1 ==> ∃ l < i
test : ∀ i (j : Size< (↑ ↑ i)) (k : Size< j) (k' : Size< k) → (((l : Size< i) → A) → A) → A
test i j k k' ret = ret λ l → f l


module prelude.int where
open import Data.Nat as Nat renaming (suc to s; zero to z)
open import Agda.Builtin.Int public

⁺1 : Int → Int
⁺1 (pos n) = pos (s n)
⁺1 (negsuc z) = pos z
⁺1 (negsuc (s n)) = negsuc n

⁻1 : Int → Int
⁻1 (pos Nat.zero) = negsuc Nat.zero
⁻1 (pos (Nat.suc n)) = pos n
⁻1 (negsuc n) = negsuc (Nat.suc n)


module Issue2749-2 where

-- testing unicode lambda and arrow
id : {A : Set} -> A -> A
id = {!!}

-- testing unicode double braces
it : {A : Set} {{a : A}} → A → A
it = {!!}

data B : Set where
  mkB : B → B → B

-- testing unicode suffixes
left : B → B
left b₁ = {!!}

open import Agda.Builtin.Equality

-- testing ascii only forall
allq : (∀ m n → m ≡ n) ≡ {!!}
allq = refl


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

open import Fragment.Algebra.Signature

module Fragment.Algebra.Homomorphism.Properties (Σ : Signature) where

open import Fragment.Algebra.Algebra Σ
open import Fragment.Algebra.Homomorphism.Base Σ
open import Fragment.Algebra.Homomorphism.Setoid Σ

open import Level using (Level)
open import Relation.Binary using (Setoid)

private
  variable
    a b c d ℓ₁ ℓ₂ ℓ₃ ℓ₄ : Level
    A : Algebra {a} {ℓ₁}
    B : Algebra {b} {ℓ₂}
    C : Algebra {c} {ℓ₃}
    D : Algebra {d} {ℓ₄}

id-unitˡ : ∀ {f : A ⟿ B} → id ⊙ f ≗ f
id-unitˡ {B = B} = Setoid.refl ∥ B ∥/≈

id-unitʳ : ∀ {f : A ⟿ B} → f ⊙ id ≗ f
id-unitʳ {B = B} = Setoid.refl ∥ B ∥/≈

⊙-assoc : ∀ (h : C ⟿ D) (g : B ⟿ C) (f : A ⟿ B)
          → (h ⊙ g) ⊙ f ≗ h ⊙ (g ⊙ f)
⊙-assoc {D = D} _ _ _ = Setoid.refl ∥ D ∥/≈

⊙-congˡ : ∀ (h : B ⟿ C) (f g : A ⟿ B)
          → f ≗ g
          → h ⊙ f ≗ h ⊙ g
⊙-congˡ h _ _ f≗g = ∣ h ∣-cong f≗g

⊙-congʳ : ∀ (h : A ⟿ B) (f g : B ⟿ C)
          → f ≗ g
          → f ⊙ h ≗ g ⊙ h
⊙-congʳ _ _ _ f≗g = f≗g


{-# OPTIONS --without-K #-}
module Chapter3.Formalization where

-- Sets and n-types
-- ----------------

open import Data.Unit
open import Data.Empty
open import Data.Nat
open import Data.Sum
open import Relation.Nullary using (¬_)
open import Data.Bool
open import Data.Product

open import Basics
open import Relation.Equivalence.Univalence
open import Relation.Equality
open import Relation.Equality.Extensionality
open import Relation.Path.Operation

isSet : ∀ {a} → Set a → Set a
isSet A = (x y : A) (p q : x ≡ y) → p ≡ q

-- The only possible inhabitants of ⊤ is tt which means everything
-- is reflexivity.
is-1-set : isSet ⊤
is-1-set tt tt refl refl = refl

-- Ex falso quodlibet strikes again
is-0-set : isSet ⊥
is-0-set ()

hasDecEq : ∀ {i} → Set i → Set i
hasDecEq A = (x y : A) → (x ≡ y) ⊎ ¬ (x ≡ y)

decEqIsSet : ∀ {i}{A : Set i} → hasDecEq A → isSet A
decEqIsSet {A} d x y = {!   !} -- TBD: Hedberg's Theorem

-- Natural numbers are also a set because every equality type is decidable.
-- Boy, it's a pain in the ass proving that, though.
is-ℕ-set : isSet ℕ
is-ℕ-set = decEqIsSet hasDecEq-ℕ where
  hasDecEq-ℕ : hasDecEq ℕ
  hasDecEq-ℕ zero zero = inj₁ refl
  hasDecEq-ℕ zero (suc y) = inj₂ (λ ())
  hasDecEq-ℕ (suc x) zero = inj₂ (λ ())
  hasDecEq-ℕ (suc x) (suc y) with hasDecEq-ℕ x y
  hasDecEq-ℕ (suc x) (suc y) | inj₁ x₁ = inj₁ (ap {f = suc} x₁)
  hasDecEq-ℕ (suc x) (suc y) | inj₂ pnot = inj₂ (λ p → pnot (ap {f = remark} p)) where
    remark : ℕ → ℕ
    remark zero = 42
    remark (suc n) = n

is-×-set : ∀ {a b}{A : Set a}{B : Set b} → isSet A → isSet B → isSet (A × B)
is-×-set SA SB x y p q = {!   !}

is-1-type : ∀ {a} → Set a → Set a
is-1-type A = (x y : A) → (p q : x ≡ y) → (r s : p ≡ q) → r ≡ s

3-1-8 : ∀ {a}{A : Set a} → isSet A → is-1-type A
3-1-8 f x y p q r s = {! apd r  !}
  where
    g : (q : x ≡ y) → (p ≡ q)
    g q = f x y p q

3-1-9 : ¬ (isSet Set)
3-1-9 x = {!   !} where
  f : Bool → Bool
  f false = true
  f true = false

  contra : ¬ (false ≡ true)
  contra ()

  lem : IsEquiv f
  lem = record
    { from = f
    ; iso₁ = λ x → mlem {x}
    ; iso₂ = λ x → mlem {x}
    } where
    mlem : ∀ {x : Bool} → f (f x) ≡ x
    mlem {false} = refl
    mlem {true} = refl

not-double-neg : ∀ {A : Set} → (¬ (¬ A) → A) → ⊥
not-double-neg f = {!  !} where
  e : Bool ≃ Bool
  e = e-equiv , record { from = e-equiv ; iso₁ = λ x → helper {x} ; iso₂ = λ x → helper {x} } where
    e-equiv : Bool → Bool
    e-equiv true = false
    e-equiv false = true

    helper : ∀ {x : Bool} → e-equiv (e-equiv x) ≡ x
    helper {true} = refl
    helper {false} = refl

  -- 3-2-4 : (x : Bool) → ¬ (e x ≡ x)
  -- 3-2-4 = ?

  p : Bool ≡ Bool
  p = {! ua e  !}

not-lem : ∀ {A : Set} → ¬ (A ⊎ (¬ A))
not-lem {A} (inj₁ x) = not-double-neg (λ _ → x)
not-lem {A} (inj₂ w) = not-double-neg (λ x → ⊥-elim (x w))

-- This defines "mere propositions"
-- If all elements of P are connected by a path, then p contains no
-- higher homotopy.
--
-- "The adjective “mere” emphasizes that although any type may be regarded as a
-- proposition (which we prove by giving an inhabitant of it), a type that is a
-- mere proposition cannot usefully be regarded as any more than a proposition:
-- there is no additional information contained in a witness of its truth."
isProp : ∀ {a} → Set a → Set a
isProp P = (x y : P) → (x ≡ y)

top-is-prop : isProp ⊤
top-is-prop tt tt = refl

3-3-3 : ∀ {a b}{P : Set a}{Q : Set b} → (p : isProp P)(q : isProp Q) → (f : P → Q) → (g : Q → P) → P ≃ Q
3-3-3 p q f g = f , record
                      { from = g
                      ; iso₁ = λ x → p (g (f x)) x
                      ; iso₂ = λ y → q (f (g y)) y
                      }

3-3-2 : ∀ {a}{P : Set a} → (p : isProp P) → (x₀ : P) → P ≃ ⊤
3-3-2 {_}{P} p x₀ = 3-3-3 p (top-is-prop) f g where
  f : P → ⊤
  f x = tt

  g : ⊤ → P
  g u = x₀

isProp-isSet : ∀ {a}{A : Set a} → isProp A → isSet A
isProp-isSet {_}{A} f x y p q = lem p ∙ lem q ⁻¹ where
  g : (y : A) → x ≡ y
  g y = f x y

  -- Read bottom-to-top
  lem : (p : x ≡ y) → p ≡ (g x ⁻¹ ∙ g y)
  lem p = (ap {f = (λ z → z ∙ p)} (back-and-there-again {p = (g x)}) ⁻¹) -- we have p = g(x)−1   g(y) = q.
        ∙ (assoc (g x ⁻¹) (g x) p ⁻¹) -- and after a little convincing
        ∙ ap {f = (λ z → (g x ⁻¹) ∙ z)} -- which is to say that p = g(y)⁻¹ ∙ g(z)
          ( (2-11-2 x p (g x) ⁻¹) -- Hence by Lemma 2.11.2, we have g(y) ∙ p = g(z)
          ∙ (apd {f = g} p) -- we have apd(p) : p(g(y)) = g(z).
          ) -- Then for any y,z : A and p : y = z

isProp-is-prop : ∀ {a}{A : Set a} → isProp (isProp A)
isProp-is-prop f g = funext λ x →
                     funext λ y → isProp-isSet f _ _ (f x y) (g x y)

isSet-is-prop : ∀ {a}{A : Set a} → isProp (isSet A)
isSet-is-prop f g = funext λ x →
                    funext λ y →
                    funext λ p →
                    funext λ q → isProp-isSet (f x y) _ _ (f x y p q) (g x y p q)

3-5-1 : ∀ {a}{A : Set a} → (P : A → Set) → ({x : A} → isProp (P x)) → (u v : Σ[ x ∈ A ] P x) → (proj₁ u ≡ proj₁ v) → u ≡ v
3-5-1 P x u v p = {!   !}

3-6-1 : ∀ {a b}{A : Set a}{B : Set b} → (isProp A) → (isProp B) → isProp (A × B)
3-6-1 PA PB px py = {!   !}

3-6-2 : ∀ {a b}{A : Set a}{B : A → Set b}{x : A} → (isProp (B x)) → isProp ((x : A) → B x)
3-6-2 PPI f g = funext λ x → {! f x ≡ g x  !}


module examplesPaperJFP.loadAllOOAgdaPart2 where

-- This is a continuation of the file loadAllOOAgdaPart1
-- giving the code from the ooAgda paper
-- This file was split into two because of a builtin IO which
-- makes loading files from part1 and part2 incompatible.

-- Note that some files which are directly in the libary can be found
-- in loadAllOOAgdaFilesAsInLibrary

-- Sect 1 - 7 are in loadAllOOAgdaPart1.agda

-- 8. State-Dependent Objects and IO
-- 8.1 State-Dependent Interfaces

import examplesPaperJFP.StatefulObject

-- 8.2 State-Dependent Objects
-- 8.2.1. Example of Use of Safe Stack

import examplesPaperJFP.safeFibStackMachineObjectOriented

-- 8.3 Reasoning About Stateful Objects

import examplesPaperJFP.StackBisim

-- 8.3.1. Bisimilarity
-- 8.3.2. Verifying stack laws}
-- 8.3.3. Bisimilarity of different stack implementations

-- 8.4. State-Dependent IO

import examplesPaperJFP.StateDependentIO

-- 9. A Drawing Program in Agda

-- code as in paper adapted to new Agda
open import examplesPaperJFP.IOGraphicsLib
-- code as in library see loadAllOOAgdaFilesAsInLibrary.agda
-- open import SizedIO.IOGraphicsLib
open import examplesPaperJFP.ExampleDrawingProgram

-- 10. A Graphical User Interface using an Object
-- 10.1. wxHaskell
-- 10.2. A Library for Object-Based GUIs in Agda

open import examplesPaperJFP.VariableList
open import examplesPaperJFP.WxGraphicsLib
open import examplesPaperJFP.VariableListForDispatchOnly

-- 10.3 Example: A GUI controlling a Space Ship in Agda

open import examplesPaperJFP.SpaceShipSimpleVar
open import examplesPaperJFP.SpaceShipCell
open import examplesPaperJFP.SpaceShipAdvanced

-- 11. Related Work

open import examplesPaperJFP.agdaCodeBrady

-- 12. Conclusion
-- Bibliography


{-# OPTIONS --safe #-}

open import Cubical.Foundations.Prelude
open import Cubical.Categories.Category.Base
open import Cubical.Categories.Monoidal.Base
open import Cubical.Categories.Instances.Functors
open import Cubical.Categories.Functor.Base renaming (𝟙⟨_⟩ to idfunctor)
open import Cubical.Categories.NaturalTransformation.Base
open import Cubical.Categories.NaturalTransformation.Properties

module Cubical.Categories.Instances.Functors.Endo {ℓC ℓC'} (C : Category ℓC ℓC') where

  open Category
  open NatTrans
  open Functor
  open StrictMonStr
  open TensorStr

  EndofunctorCategory : Category (ℓ-max ℓC ℓC') (ℓ-max ℓC ℓC')
  EndofunctorCategory = FUNCTOR C C


------------------------------------------------------------------------
-- Properties of non-empty lists
------------------------------------------------------------------------

module Data.List.NonEmpty.Properties where

open import Algebra
open import Category.Monad
open import Data.Function
open import Data.Product
open import Data.List as List using (List; []; _∷_; _++_)
open RawMonad List.monad using () renaming (_>>=_ to _⋆>>=_)
private module LM {A} = Monoid (List.monoid A)
open import Data.List.NonEmpty as List⁺
open RawMonad List⁺.monad
open import Relation.Binary.PropositionalEquality
open ≡-Reasoning

η : ∀ {A} (xs : List⁺ A) → head xs ∷ tail xs ≡ List⁺.toList xs
η [ x ]    = refl
η (x ∷ xs) = refl

toList-fromList : ∀ {A} x (xs : List A) →
                  x ∷ xs ≡ List⁺.toList (List⁺.fromList x xs)
toList-fromList x []       = refl
toList-fromList x (y ∷ xs) = cong (_∷_ x) (toList-fromList y xs)

toList-⁺++ : ∀ {A} (xs : List⁺ A) ys →
             List⁺.toList xs ++ ys ≡
             List⁺.toList (xs ⁺++ ys)
toList-⁺++ [ x ]    ys = toList-fromList x ys
toList-⁺++ (x ∷ xs) ys = cong (_∷_ x) (toList-⁺++ xs ys)

toList-⁺++⁺ : ∀ {A} (xs ys : List⁺ A) →
              List⁺.toList xs ++ List⁺.toList ys ≡
              List⁺.toList (xs ⁺++⁺ ys)
toList-⁺++⁺ [ x ]    ys = refl
toList-⁺++⁺ (x ∷ xs) ys = cong (_∷_ x) (toList-⁺++⁺ xs ys)

toList->>= : ∀ {A B} (f : A → List⁺ B) (xs : List⁺ A) →
             (List⁺.toList xs ⋆>>= List⁺.toList ∘ f) ≡
             (List⁺.toList (xs >>= f))
toList->>= f [ x ]    = proj₂ LM.identity _
toList->>= f (x ∷ xs) = begin
  List⁺.toList (f x) ++ (List⁺.toList xs ⋆>>= List⁺.toList ∘ f) ≡⟨ cong (_++_ (List⁺.toList (f x))) (toList->>= f xs) ⟩
  List⁺.toList (f x) ++ List⁺.toList (xs >>= f)                 ≡⟨ toList-⁺++⁺ (f x) (xs >>= f) ⟩
  List⁺.toList (f x ⁺++⁺ (xs >>= f))                            ∎


module Control.WellFounded where

open import Prelude
open import Prelude.Nat.Properties using (suc-inj)

data Acc {a} {A : Set a} (_<_ : A → A → Set a) (x : A) : Set a where
  acc : (∀ y → y < x → Acc _<_ y) → Acc _<_ x

-- LessNat is well-founded --

private
  wfNatSlow : (n : Nat) → Acc _<_ n

  wfNatSlow′ : (n j y : Nat) → n ≡ suc (j + y) → Acc _<_ y
  wfNatSlow′ (suc n)  zero  .n refl = wfNatSlow n
  wfNatSlow′ (suc n) (suc j) y eq   = wfNatSlow′ n j y (suc-inj eq)
  wfNatSlow′ zero     zero   y ()
  wfNatSlow′ zero    (suc j) y ()

  wfNatSlow n = acc λ { y (diff j eq) → wfNatSlow′ n j y eq }

  -- Need to match on n to avoid unfolding on neutral argument!
  wfNatFast : {k : Nat} → (n : Nat) → Acc _<_ n
  wfNatFast {zero}     n    = wfNatSlow n
  wfNatFast {suc k}  zero   = wfNatSlow zero
  wfNatFast {suc k} (suc n) = acc λ m _ → wfNatFast {k} m

wfNat : (n : Nat) → Acc _<_ n
wfNat n = wfNatFast {1000000000} n


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

open import Categories.Category
open import Categories.Category.Monoidal.Core using (Monoidal)
open import Categories.Category.Monoidal.Symmetric
open import Data.Sum

module Categories.Category.Monoidal.CompactClosed {o ℓ e} {C : Category o ℓ e} (M : Monoidal C) where

open import Level

open import Categories.Functor.Bifunctor
open import Categories.NaturalTransformation.NaturalIsomorphism
open import Categories.Category.Monoidal.Rigid

open Category C
open Commutation C

record CompactClosed : Set (levelOfTerm M) where
  field
    symmetric : Symmetric M
    rigid     : LeftRigid M ⊎ RightRigid M


-- WARNING: This file was generated automatically by Vehicle
-- and should not be modified manually!
-- Metadata
--  - Agda version: 2.6.2
--  - AISEC version: 0.1.0.1
--  - Time generated: ???

{-# OPTIONS --allow-exec #-}

open import Vehicle
open import Data.Product
open import Data.Integer as ℤ using (ℤ)
open import Data.Rational as ℝ using () renaming (ℚ to ℝ)

module andGate-output where

private
  VEHICLE_PROJECT_FILE = "TODO_projectFile"

andGate : ℝ → (ℝ → ℝ)
andGate = evaluate record
  { projectFile = VEHICLE_PROJECT_FILE
  ; networkUUID = "TODO_networkUUID"
  }

Truthy : ℝ → Set
Truthy x = x ℝ.≥ ℤ.+ 1 ℝ./ 2

Falsey : ℝ → Set
Falsey x = x ℝ.≤ ℤ.+ 1 ℝ./ 2

ValidInput : ℝ → Set
ValidInput x = ℤ.+ 0 ℝ./ 1 ℝ.≤ x × x ℝ.≤ ℤ.+ 1 ℝ./ 1

CorrectOutput : ℝ → (ℝ → Set)
CorrectOutput x1 x2 = let y = andGate x1 x2 in (Truthy x1 × Truthy x2 → Truthy y) × ((Truthy x1 × Falsey x2 → Falsey y) × ((Falsey x1 × Truthy x2 → Falsey y) × (Falsey x1 × Falsey x2 → Falsey y)))

abstract
  andGateCorrect : ∀ (x1 : ℝ) → ∀ (x2 : ℝ) → ValidInput x1 × ValidInput x2 → CorrectOutput x1 x2
  andGateCorrect = checkProperty record
    { projectFile  = VEHICLE_PROJECT_FILE
    ; propertyUUID = "TODO_propertyUUID"
    }