{-# OPTIONS --safe #-}
{-
This file models "ZF - powerset" in cubical agda, via a cumulative hierarchy, in the sense given
in the HoTT book §10.5 "The cumulative hierarchy".

A great amount of inspiration is taken from the Coq implementations found in
Jérémy Ledent, Modeling set theory in homotopy type theory, code of which can be found online at
https://github.com/jledent/vset
-}

module Cubical.HITs.CumulativeHierarchy.Base where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Path
open import Cubical.Foundations.Function
open import Cubical.Foundations.HLevels
open import Cubical.Foundations.Equiv using (fiber)
open import Cubical.Functions.Logic
open import Cubical.Data.Sigma
open import Cubical.HITs.PropositionalTruncation as P hiding (elim; elim2)

import Cubical.HITs.PropositionalTruncation.Monad as PropMonad

private
  variable
    ℓ ℓ' : Level

infix 5 _∈_

-- set up the basic hierarchy definition and _∈_ as recursive, higher inductive types
data V (ℓ : Level) : Type (ℓ-suc ℓ)
_∈_ : (S T : V ℓ) → hProp (ℓ-suc ℓ)

eqImage : {X Y : Type ℓ} (ix : X → V ℓ) (iy : Y → V ℓ) → Type (ℓ-suc ℓ)
eqImage {X = X} {Y = Y} ix iy = (∀ (a : X) → ∥ fiber iy (ix a) ∥₁) ⊓′
                                (∀ (b : Y) → ∥ fiber ix (iy b) ∥₁)

data V ℓ where
  sett : (X : Type ℓ) → (X → V ℓ) → V ℓ
  seteq : (X Y : Type ℓ) (ix : X → V ℓ) (iy : Y → V ℓ) (eq : eqImage ix iy) → sett X ix ≡ sett Y iy
  setIsSet : isSet (V ℓ)

A ∈ sett X ix = ∥ Σ[ i ∈ X ] (ix i ≡ A) ∥ₚ
A ∈ seteq X Y ix iy (f , g) i =
  ⇔toPath {P = A ∈ sett X ix} {Q = A ∈ sett Y iy}
    (λ ax → do (x , xa) ← ax ; (y , ya) ← f x ; ∣ y , ya ∙ xa ∣₁)
    (λ ay → do (y , ya) ← ay ; (x , xa) ← g y ; ∣ x , xa ∙ ya ∣₁) i
  where open PropMonad
A ∈ setIsSet a b p q i j = isSetHProp (A ∈ a) (A ∈ b) (λ j → A ∈ p j) (λ j → A ∈ q j) i j

-- setup a general eliminator into h-sets
record ElimSet {Z : (s : V ℓ) → Type ℓ'}
               (isSetZ : ∀ s → isSet (Z s)) : Type (ℓ-max ℓ' (ℓ-suc ℓ)) where
  field
    ElimSett :
      ∀ (X : Type ℓ) (ix : X → V ℓ)
      -- ^ the structural parts of the set
      → (rec : ∀ x → Z (ix x))
      -- ^ a recursor into the elements
      → Z (sett X ix)
    ElimEq :
      ∀ (X₁ X₂ : Type ℓ) (ix₁ : X₁ → V ℓ) (ix₂ : X₂ → V ℓ) (eq : eqImage ix₁ ix₂)
      -- ^ the structural parts of the seteq path
      → (rc₁ : ∀ x₁ → Z (ix₁ x₁)) (rc₂ : ∀ x₂ → Z (ix₂ x₂))
      -- ^ recursors into the elements
      → ((x₁ : X₁) → ∃[ (x₂ , p) ∈ fiber ix₂ (ix₁ x₁) ] PathP (λ i → Z (p i)) (rc₂ x₂) (rc₁ x₁))
      → ((x₂ : X₂) → ∃[ (x₁ , p) ∈ fiber ix₁ (ix₂ x₂) ] PathP (λ i → Z (p i)) (rc₁ x₁) (rc₂ x₂))
      -- ^ proofs that the recursors have equal images
      → PathP (λ i → Z (seteq X₁ X₂ ix₁ ix₂ eq i)) (ElimSett X₁ ix₁ rc₁) (ElimSett X₂ ix₂ rc₂)

module _ {Z : (s : V ℓ) → Type ℓ'} {isSetZ : ∀ s → isSet (Z s)} (E : ElimSet isSetZ) where
  open ElimSet E
  elim : (s : V ℓ) → Z s
  elim (sett X ix) = ElimSett X ix (elim ∘ ix)
  elim (seteq X₁ X₂ ix₁ ix₂ eq i) =
    ElimEq X₁ X₂ ix₁ ix₂ eq (elim ∘ ix₁) (elim ∘ ix₂) rec₁→₂ rec₂→₁ i
    where
    rec₁→₂ :
      ∀ (x₁ : X₁)
      → ∃[ (x₂ , p) ∈ fiber ix₂ (ix₁ x₁) ] PathP (λ i → Z (p i)) (elim (ix₂ x₂)) (elim (ix₁ x₁))
    rec₂→₁ :
      ∀ (x₂ : X₂)
      → ∃[ (x₁ , p) ∈ fiber ix₁ (ix₂ x₂) ] PathP (λ i → Z (p i)) (elim (ix₁ x₁)) (elim (ix₂ x₂))
    -- using a local definition of Prop.rec satisfies the termination checker
    rec₁→₂ x₁ = localRec₁ (eq .fst x₁) where
      localRec₁ :
          ∥ fiber ix₂ (ix₁ x₁) ∥₁
        → ∃[ (x₂ , p) ∈ fiber ix₂ (ix₁ x₁) ] PathP (λ i → Z (p i)) (elim (ix₂ x₂)) (elim (ix₁ x₁))
      localRec₁ ∣ x₂ , xx ∣₁ = ∣ (x₂ , xx) , (λ i → elim (xx i)) ∣₁
      localRec₁ (squash₁ x y i) = squash₁ (localRec₁ x) (localRec₁ y) i
    rec₂→₁ x₂ = localRec₂ (eq .snd x₂) where
      localRec₂ :
          ∥ fiber ix₁ (ix₂ x₂) ∥₁
        → ∃[ (x₁ , p) ∈ fiber ix₁ (ix₂ x₂) ] PathP (λ i → Z (p i)) (elim (ix₁ x₁)) (elim (ix₂ x₂))
      localRec₂ ∣ x₁ , xx ∣₁ = ∣ (x₁ , xx) , (λ i → elim (xx i)) ∣₁
      localRec₂ (squash₁ x y i) = squash₁ (localRec₂ x) (localRec₂ y) i
  elim (setIsSet S T x y i j) = isProp→PathP propPathP (cong elim x) (cong elim y) i j where
    propPathP : (i : I) → isProp (PathP (λ j → Z (setIsSet S T x y i j)) (elim S) (elim T))
    propPathP _ = subst isProp (sym (PathP≡Path _ _ _)) (isSetZ _ _ _)

-- eliminator into propositions
elimProp : {Z : (s : V ℓ) → Type ℓ'} (isPropZ : ∀ s → isProp (Z s))
         → ((X : Type ℓ) → (ix : X → V ℓ) → (∀ x → Z (ix x)) → Z (sett X ix))
         → (s : V ℓ) → Z s
elimProp isPropZ algz (sett X ix) = algz X ix (λ x → elimProp isPropZ algz (ix x))
elimProp isPropZ algz (seteq X Y ix iy eq i) =
  isProp→PathP (λ i → isPropZ (seteq X Y ix iy eq i))
               (algz X ix (elimProp isPropZ algz ∘ ix))
               (algz Y iy (elimProp isPropZ algz ∘ iy)) i
elimProp isPropZ algz (setIsSet S T x y i j) =
  isProp→SquareP (λ i j → isPropZ (setIsSet S T x y i j))
                 (λ _ → elimProp isPropZ algz S)
                 (λ _ → elimProp isPropZ algz T)
                 (cong (elimProp isPropZ algz) x)
                 (cong (elimProp isPropZ algz) y) i j

-- eliminator for two sets at once
record Elim2Set {Z : (s t : V ℓ) → Type ℓ'}
                (isSetZ : ∀ s t → isSet (Z s t)) : Type (ℓ-max ℓ' (ℓ-suc ℓ)) where
  field
    ElimSett2 :
      ∀ (X : Type ℓ) (ix : X → V ℓ) (Y : Type ℓ) (iy : Y → V ℓ)
      -- ^ the structural parts of the set
      → (rec : ∀ x y → Z (ix x) (iy y))
      -- ^ a recursor into the elements
      → Z (sett X ix) (sett Y iy)
    -- path when the the first argument deforms along seteq and the second argument is held constant
    ElimEqFst :
      ∀ (X₁ X₂ : Type ℓ) (ix₁ : X₁ → V ℓ) (ix₂ : X₂ → V ℓ) (eq : eqImage ix₁ ix₂)
      -- ^ the structural parts of the seteq path
      → (Y : Type ℓ) (iy : Y → V ℓ)
      -- ^ the second argument held constant
      → (rec₁ : ∀ x₁ y → Z (ix₁ x₁) (iy y)) (rec₂ : ∀ x₂ y → Z (ix₂ x₂) (iy y))
      -- ^ recursors into the elements
      → (rec₁→₂ : (x₁ : X₁)
                → ∃[ (x₂ , p) ∈ fiber ix₂ (ix₁ x₁) ]
                     PathP (λ i → ∀ y → Z (p i) (iy y)) (λ y → rec₂ x₂ y) (λ y → rec₁ x₁ y))
      → (rec₂→₁ : (x₂ : X₂)
                → ∃[ (x₁ , p) ∈ fiber ix₁ (ix₂ x₂) ]
                     PathP (λ i → ∀ y → Z (p i) (iy y)) (λ y → rec₁ x₁ y) (λ y → rec₂ x₂ y))
      -- ^ proofs that the recursors have equal images
      → PathP (λ i → Z (seteq X₁ X₂ ix₁ ix₂ eq i) (sett Y iy))
              (ElimSett2 X₁ ix₁ Y iy rec₁)
              (ElimSett2 X₂ ix₂ Y iy rec₂)
    -- path when the the second argument deforms along seteq and the first argument is held constant
    ElimEqSnd :
      ∀ (X : Type ℓ) (ix : X → V ℓ)
      -- ^ the first argument held constant
      → (Y₁ Y₂ : Type ℓ) (iy₁ : Y₁ → V ℓ) (iy₂ : Y₂ → V ℓ) → (eq : eqImage iy₁ iy₂)
      -- ^ the structural parts of the seteq path
      → (rec₁ : ∀ x y₁ → Z (ix x) (iy₁ y₁)) (rec₂ : ∀ x y₂ → Z (ix x) (iy₂ y₂))
      -- ^ recursors into the elements
      → (rec₁→₂ : (y₁ : Y₁)
                → ∃[ (y₂ , p) ∈ fiber iy₂ (iy₁ y₁) ]
                     PathP (λ i → ∀ x → Z (ix x) (p i)) (λ x → rec₂ x y₂) (λ x → rec₁ x y₁))
      → (rec₂→₁ : (y₂ : Y₂)
                → ∃[ (y₁ , p) ∈ fiber iy₁ (iy₂ y₂) ]
                     PathP (λ i → ∀ x → Z (ix x) (p i)) (λ x → rec₁ x y₁) (λ x → rec₂ x y₂))
      -- ^ proofs that the recursors have equal images
      → PathP (λ i → Z (sett X ix) (seteq Y₁ Y₂ iy₁ iy₂ eq i))
              (ElimSett2 X ix Y₁ iy₁ rec₁)
              (ElimSett2 X ix Y₂ iy₂ rec₂)

module _ {Z : (s t : V ℓ) → Type ℓ'} {isSetZ : ∀ s t → isSet (Z s t)} (E : Elim2Set isSetZ) where
  open Elim2Set E
  open ElimSet

  elim2 : (s t : V ℓ) → Z s t
  elim2 = elim pElim where
    open PropMonad

    isSetPElim : ∀ s → isSet (∀ t → Z s t)
    isSetPElim s = isSetΠ (isSetZ s)

    eliminatorImplX : (X : Type ℓ) (ix : X → V ℓ)
                    → (rec : ∀ x y → Z (ix x) y)
                    → ElimSet (λ t → isSetZ (sett X ix) t)
    ElimSett (eliminatorImplX X ix rec) Y iy _ =
      ElimSett2 X ix Y iy (λ x → rec x ∘ iy)
    ElimEq (eliminatorImplX X ix rec) Y₁ Y₂ iy₁ iy₂ eq _ _ _ _ =
      ElimEqSnd X ix Y₁ Y₂ iy₁ iy₂ eq (λ x → rec x ∘ iy₁) (λ x → rec x ∘ iy₂) rec₁→₂ rec₂→₁
      where
      rec₁→₂ :
        ∀ (y₁ : Y₁)
        → ∃[ (y₂ , p) ∈ fiber iy₂ (iy₁ y₁) ]
             PathP (λ i → ∀ x → Z (ix x) (p i)) (λ x → rec x (iy₂ y₂)) (λ x → rec x (iy₁ y₁))
      rec₂→₁ :
        ∀ (y₂ : Y₂)
        → ∃[ (y₁ , p) ∈ fiber iy₁ (iy₂ y₂) ]
             PathP (λ i → ∀ x → Z (ix x) (p i)) (λ x → rec x (iy₁ y₁)) (λ x → rec x (iy₂ y₂))
      rec₁→₂ y₁ = do (y₂ , yy) ← fst eq y₁ ; ∣ (y₂ , yy) , (λ i x → rec x (yy i)) ∣₁
      rec₂→₁ y₂ = do (y₁ , yy) ← snd eq y₂ ; ∣ (y₁ , yy) , (λ i x → rec x (yy i)) ∣₁

    elimImplS :
      ∀ (X : Type ℓ) (ix : X → V ℓ)
      → (∀ x t₂ → Z (ix x) t₂)
      → (t : V ℓ) → Z (sett X ix) t
    elimImplS X ix rec = elim (eliminatorImplX X ix rec)

    elimImplSExt :
      ∀ (X₁ X₂ : Type ℓ) (ix₁ : X₁ → V ℓ) (ix₂ : X₂ → V ℓ) → (eq : eqImage ix₁ ix₂)
      → (rec₁ : ∀ x₁ t₂ → Z (ix₁ x₁) t₂) (rec₂ : ∀ x₂ t₂ → Z (ix₂ x₂) t₂)
      → ((x₁ : X₁) → ∃[ (x₂ , p) ∈ fiber ix₂ (ix₁ x₁) ]
                        PathP (λ i → ∀ t → Z (p i) t) (rec₂ x₂) (rec₁ x₁))
      → ((x₂ : X₂) → ∃[ (x₁ , p) ∈ fiber ix₁ (ix₂ x₂) ]
                        PathP (λ i → ∀ t → Z (p i) t) (rec₁ x₁) (rec₂ x₂))
      → (t : V ℓ)
      → PathP (λ i → Z (seteq X₁ X₂ ix₁ ix₂ eq i) t)
              (elimImplS X₁ ix₁ rec₁ t)
              (elimImplS X₂ ix₂ rec₂ t)
    elimImplSExt X₁ X₂ ix₁ ix₂ eq rec₁ rec₂ rec₁→₂ rec₂→₁ =
      elimProp propPathP (λ Y iy _ → elimImplSExtT Y iy)
      where
      propPathP : (t : V ℓ)
                → isProp (PathP (λ i → Z (seteq X₁ X₂ ix₁ ix₂ eq i) t)
                                (elimImplS X₁ ix₁ rec₁ t)
                                (elimImplS X₂ ix₂ rec₂ t))
      propPathP _ = subst isProp (sym (PathP≡Path _ _ _)) (isSetZ _ _ _ _)

      elimImplSExtT : (Y : Type ℓ) (iy : Y → V ℓ) → _ {- the appropriate path type -}
      elimImplSExtT Y iy =
        ElimEqFst X₁ X₂ ix₁ ix₂ eq Y iy (λ x₁ y → rec₁ x₁ (iy y))
                                        (λ x₂ y → rec₂ x₂ (iy y)) rec₁→₂Impl rec₂→₁Impl
        where
        rec₁→₂Impl :
          ∀ (x₁ : X₁)
          → ∃[ (x₂ , p) ∈ fiber ix₂ (ix₁ x₁) ]
               PathP (λ i → ∀ y → Z (p i) (iy y)) (λ y → rec₂ x₂ (iy y)) (λ y → rec₁ x₁ (iy y))
        rec₂→₁Impl :
          ∀ (x₂ : X₂)
          → ∃[ (x₁ , p) ∈ fiber ix₁ (ix₂ x₂) ]
               PathP (λ i → ∀ y → Z (p i) (iy y)) (λ y → rec₁ x₁ (iy y)) (λ y → rec₂ x₂ (iy y))
        rec₁→₂Impl x₁ = do ((x₂ , xx) , rx) ← rec₁→₂ x₁ ; ∣ (x₂ , xx) , (λ i y → rx i (iy y)) ∣₁
        rec₂→₁Impl x₂ = do ((x₁ , xx) , rx) ← rec₂→₁ x₂ ; ∣ (x₁ , xx) , (λ i y → rx i (iy y)) ∣₁

    pElim : ElimSet isSetPElim
    ElimSett pElim = elimImplS
    ElimEq pElim X₁ X₂ ix₁ ix₂ eq rec₁ rec₂ rec₁→₂ rec₂→₁ i t =
      elimImplSExt X₁ X₂ ix₁ ix₂ eq rec₁ rec₂ rec₁→₂ rec₂→₁ t i


module Substitution where

open import Library
open import Terms

-- VarTm n specifies whether the substitution produces variables or terms.
-- The index is used to impose an order on the constructors
-- and so pass termination checking in lift/subst.

data VarTm : ℕ → Set where
  `Var : VarTm 0
  `Tm  : VarTm 1

max01 : ℕ → ℕ → ℕ
max01 0 m = m
max01 n m = n

_∙VT_ : ∀ {m n} → VarTm m → VarTm n → VarTm (max01 m n)
`Var ∙VT vt = vt
`Tm  ∙VT vt = `Tm

VT : ∀ {m} → VarTm m → Cxt → Ty → Set
VT `Var Γ a = Var Γ a
VT `Tm  Γ a = Tm Γ a

vt2tm : ∀ {Γ a m} vt → VT {m} vt Γ a → Tm Γ a
vt2tm `Var x = var x
vt2tm `Tm  t = t

RenSub : ∀ {m} → VarTm m → Cxt → Cxt → Set
RenSub vt Γ Δ = ∀ {a} → Var Γ a → VT vt Δ a

mutual

  -- Lifiting a substitution

  lifts : ∀ {m vt Γ Δ a} → RenSub {m} vt Γ Δ → RenSub vt (a ∷ Γ) (a ∷ Δ)
  lifts {vt = `Var} σ (zero)    = zero
  lifts {vt = `Var} σ (suc x) = suc (σ x)
  lifts {vt = `Tm}  σ (zero)    = var (zero)
  lifts {vt = `Tm}  σ (suc x) = subst {vt = `Var} suc (σ x)

  -- Performing a substitution

  subst : ∀ {m vt Γ Δ τ} → RenSub {m} vt Γ Δ → Tm Γ τ → Tm Δ τ

  subst σ (abs t)     = abs (subst (lifts σ) t)
  subst σ (app t u)   = app (subst σ t) (subst σ u)
  subst σ (var x)     = vt2tm _ (σ x)

-- Performing substitution, inductive specification

data IndSubst {m vt Γ Δ} (σ : RenSub {m} vt Γ Δ) : ∀ {τ} → Tm Γ τ → Tm Δ τ → Set where

  var  : ∀{a t} (x : Var Γ a)
       → vt2tm _ (σ x) ≡ t
       → IndSubst σ (var x) t

  abs  : ∀{a b} {t : Tm (a ∷ Γ) b} {t'}
       → IndSubst (lifts σ) t t'
       → IndSubst σ (abs t) (abs t')

  app  : ∀{a b} {t : Tm Γ (a →̂ b)} {u t' u'}
       → IndSubst σ t t'
       → IndSubst σ u u'
       → IndSubst σ (app t u) (app t' u')

-- Performing renaming, inductive specification

data IndRen {Γ Δ} (σ : RenSub `Var Γ Δ) : ∀ {τ} → Tm Γ τ → Tm Δ τ → Set where

  var  : ∀{a y} (x : Var Γ a)
       → (σ x) ≡ y
       → IndRen σ (var x) (var y)

  abs  : ∀{a b} {t : Tm (a ∷ Γ) b} {t'}
       → IndRen (lifts σ) t t'
       → IndRen σ (abs t) (abs t')

  app  : ∀{a b} {t : Tm Γ (a →̂ b)} {u t' u'}
       → IndRen σ t t'
       → IndRen σ u u'
       → IndRen σ (app t u) (app t' u')

-- Logical equivalence between inductive and algorithmic substitution

IndS→prop : ∀ {m vt Γ Δ} (σ : RenSub {m} vt Γ Δ) {τ} {t : Tm Γ τ} {t' : Tm Δ τ} → IndSubst σ t t' → subst σ t ≡ t'
IndS→prop σ (var x ≡.refl) = ≡.refl
IndS→prop σ (abs t)     = ≡.cong abs (IndS→prop (lifts σ) t)
IndS→prop σ (app t t₁)  = ≡.cong₂ app (IndS→prop σ t) (IndS→prop σ t₁)

prop→IndS' : ∀ {m vt Γ Δ} (σ : RenSub {m} vt Γ Δ) {τ} (t : Tm Γ τ) → IndSubst σ t (subst σ t)
prop→IndS' σ (var x) = var x ≡.refl
prop→IndS' σ (abs t)     = abs (prop→IndS' (lifts σ) t)
prop→IndS' σ (app t u)   = app (prop→IndS' σ t) (prop→IndS' σ u)

prop→IndS : ∀ {m vt Γ Δ} (σ : RenSub {m} vt Γ Δ) {τ} {t : Tm Γ τ} {t' : Tm Δ τ} → subst σ t ≡ t' → IndSubst σ t t'
prop→IndS _ ≡.refl = prop→IndS' _ _

-- Logical equivalence between inductive and algorithmic renaming

Ind→prop : ∀ {Γ Δ} (σ : RenSub `Var Γ Δ) {τ} {t : Tm Γ τ} {t' : Tm Δ τ} → IndRen σ t t' → subst σ t ≡ t'
Ind→prop σ (var x ≡.refl) = ≡.refl
Ind→prop σ (abs t)     = ≡.cong abs (Ind→prop (lifts σ) t)
Ind→prop σ (app t t₁)  = ≡.cong₂ app (Ind→prop σ t) (Ind→prop σ t₁)

prop→Ind' : ∀ {Γ Δ} (σ : RenSub `Var Γ Δ) {τ} (t : Tm Γ τ) → IndRen σ t (subst σ t)
prop→Ind' σ (var x) = var x ≡.refl
prop→Ind' σ (abs t)     = abs (prop→Ind' (lifts σ) t)
prop→Ind' σ (app t u)   = app (prop→Ind' σ t) (prop→Ind' σ u)

prop→Ind : ∀ {Γ Δ} (σ : RenSub `Var Γ Δ) {τ} {t : Tm Γ τ} {t' : Tm Δ τ} → subst σ t ≡ t' → IndRen σ t t'
prop→Ind _ ≡.refl = prop→Ind' _ _

-- Identity substitution

ids : ∀ {i vt Γ} → RenSub {i} vt Γ Γ
ids {vt = `Var} x = x
ids {vt = `Tm } x = var x

-- substitution composition

_•s_ : ∀ {Γ₀ Γ₁ Γ₂}
         {n}{vt2 : VarTm n}(τ : RenSub vt2 Γ₁ Γ₂)
         {m}{vt1 : VarTm m}(σ : RenSub vt1 Γ₀ Γ₁) → RenSub (vt1 ∙VT vt2) Γ₀ Γ₂
_•s_ τ {vt1 = `Var} σ x = τ (σ x)
_•s_ τ {vt1 = `Tm } σ x = subst τ (σ x)

-- Term substitution

Subst : Cxt → Cxt → Set
Subst Γ Δ = ∀ {a : Ty} → Var Γ a → Tm Δ a

-- Extending a substitution

_∷s_ : ∀ {Γ Δ a} → Tm Γ a → Subst Δ Γ → Subst (a ∷ Δ) Γ
(t ∷s σ) (zero) = t
(t ∷s σ) (suc x) = σ x

-- Substitution for 0th variable

sgs : ∀ {Γ a} → Tm Γ a → Subst (a ∷ Γ) Γ
sgs t = t ∷s ids

-- Substituting for the 0th variable [u/0]t

subst0 : ∀ {Γ a b} → Tm Γ a → Tm (a ∷ Γ) b → Tm Γ b
subst0 u = subst (sgs u)

-- Renamings

Ren : (Γ Δ : Cxt) → Set
Ren = RenSub `Var

_≤_  : (Γ Δ : Cxt) → Set
_≤_ Γ Δ = RenSub `Var Δ Γ

rename : ∀ {Γ Δ : Cxt} {a : Ty} (η : Γ ≤ Δ) (x : Tm Δ a) → Tm Γ a
rename = subst

-- Weakening renaming

weak : ∀{Γ a} → (a ∷ Γ) ≤ Γ
weak = suc

-- Weakening substitution

weaks : ∀{n}{vt : VarTm n}{a Γ Δ} (σ : RenSub vt Γ Δ) → RenSub vt (Γ) (a ∷ Δ)
weaks {vt = `Var} σ x = suc (σ x)
weaks {vt = `Tm} σ x = rename suc (σ x)

-- Properties

_≡s_ : ∀ {Γ Δ} {m n vt1 vt2} → (f : RenSub {m} vt1 Γ Δ)(g : RenSub {n} vt2 Γ Δ) → Set
f ≡s g = (∀ {a} x → vt2tm _ (f {a} x) ≡ vt2tm _ (g x))

mutual
  subst-ext : ∀ {Γ Δ} {m n vt1 vt2} {f : RenSub {m} vt1 Γ Δ}{g : RenSub {n} vt2 Γ Δ} → f ≡s g → ∀ {a} (t : Tm Γ a) → subst f t ≡ subst g t
  subst-ext f≐g (var v) = (f≐g v)
  subst-ext {f = f} {g = g} f≐g (abs t)     = ≡.cong abs (subst-ext (lifts-ext {f = f} {g = g} f≐g) t)
  subst-ext f≐g (app t t₁)  = ≡.cong₂ app (subst-ext f≐g t) (subst-ext f≐g t₁)

  lifts-ext : ∀ {Γ Δ b} {m n vt1 vt2} {f : RenSub {m} vt1 Γ Δ}{g : RenSub {n} vt2 Γ Δ} → f ≡s g → lifts {a = b} f ≡s lifts g
  lifts-ext {vt1 = `Var} {`Var} f≐g (zero) = ≡.refl
  lifts-ext {vt1 = `Var} {`Var} {f} {g} f≐g (suc x) with f x | g x | f≐g x
  lifts-ext {Γ} {Δ} {b} {._} {._} {`Var} {`Var} f≐g (suc x) | z | .z | ≡.refl = ≡.refl
  lifts-ext {vt1 = `Var} {`Tm} f≐g (zero) = ≡.refl
  lifts-ext {vt1 = `Var} {`Tm} f≐g (suc x) rewrite ≡.sym (f≐g x) = ≡.refl
  lifts-ext {vt1 = `Tm} {`Var} f≐g (zero) = ≡.refl
  lifts-ext {vt1 = `Tm} {`Var} f≐g (suc x) rewrite (f≐g x) = ≡.refl
  lifts-ext {vt1 = `Tm} {`Tm} f≐g (zero) = ≡.refl
  lifts-ext {vt1 = `Tm} {`Tm} f≐g (suc x) = ≡.cong (subst suc) (f≐g x)

mutual
  subst-∙ : ∀ {Γ₀ Γ₁ Γ₂}
           {n}{vt2 : VarTm n}(τ : RenSub vt2 Γ₁ Γ₂)
           {m}{vt1 : VarTm m}(σ : RenSub vt1 Γ₀ Γ₁) → ∀ {a} (t : Tm Γ₀ a) → subst (τ •s σ) t ≡ subst τ (subst σ t)
  subst-∙ τ {vt1 = `Var} σ (var x) = ≡.refl
  subst-∙ τ {vt1 = `Tm} σ (var x) = ≡.refl
  subst-∙ τ σ (abs t)     = ≡.cong abs (≡.trans (subst-ext (lifts-∙ τ σ) t) (subst-∙ (lifts τ) (lifts σ) t))
  subst-∙ τ σ (app t t₁)  = ≡.cong₂ app (subst-∙ τ σ t) (subst-∙ τ σ t₁)

  lifts-∙ : ∀ {Γ₀ Γ₁ Γ₂}
         {n}{vt2 : VarTm n}(τ : RenSub vt2 Γ₁ Γ₂)
         {m}{vt1 : VarTm m}(σ : RenSub vt1 Γ₀ Γ₁) → ∀ {a} → lifts {a = a} (τ •s σ) ≡s (lifts τ •s lifts σ)
  lifts-∙ {vt2 = `Var} τ {vt1 = `Var} σ (zero)    = ≡.refl
  lifts-∙ {vt2 = `Tm}  τ {vt1 = `Var} σ (zero)    = ≡.refl
  lifts-∙ {vt2 = `Var} τ {vt1 = `Var} σ (suc x) = ≡.refl
  lifts-∙ {vt2 = `Tm}  τ {vt1 = `Var} σ (suc x) = ≡.refl
  lifts-∙ {vt2 = `Var} τ {vt1 = `Tm}  σ (zero)    = ≡.refl
  lifts-∙ {vt2 = `Tm}  τ {vt1 = `Tm}  σ (zero)    = ≡.refl
  lifts-∙ {vt2 = `Var} τ {vt1 = `Tm}  σ (suc x) = ≡.trans (≡.sym (subst-∙ suc τ (σ x))) (subst-∙ (lifts τ) suc (σ x))
  lifts-∙ {vt2 = `Tm}  τ {vt1 = `Tm}  σ (suc x) = ≡.trans (≡.sym (subst-∙ suc τ (σ x))) (subst-∙ (lifts τ) suc (σ x))

mutual
  subst-id : ∀ {m vt Γ a} → (t : Tm Γ a) → subst (ids {m} {vt}) t ≡ t
  subst-id {vt = `Var} (var v) = ≡.refl
  subst-id {vt = `Tm}  (var v) = ≡.refl
  subst-id {m} {vt} {Γ} (abs t)     = ≡.cong abs (≡.trans (subst-ext {n = m} {vt2 = vt} (lifts-id {m} {vt}) t) (subst-id t))
  subst-id (app t t₁)  = ≡.cong₂ app (subst-id t) (subst-id t₁)

  lifts-id : ∀ {m vt Γ b} → lifts {a = b} (ids {m} {vt} {Γ = Γ}) ≡s ids {m} {vt} {Γ = b ∷ Γ}
  lifts-id {vt = `Var} (zero)    = ≡.refl
  lifts-id {vt = `Var} (suc x) = ≡.refl
  lifts-id {vt = `Tm}  (zero)    = ≡.refl
  lifts-id {vt = `Tm}  (suc x) = ≡.refl

sgs-lifts : ∀ {m vt Γ Δ a} {σ : RenSub {m} vt Γ Δ} {u : Tm Γ a} → (sgs (subst σ u) •s lifts σ) ≡s (σ •s sgs u)
sgs-lifts {vt = `Var} = (λ { (zero) → ≡.refl ; (suc x) → ≡.refl })
sgs-lifts {vt = `Tm} {σ = σ} {u} = (λ { (zero) → ≡.refl ; (suc x) → ≡.sym (≡.trans (≡.sym (subst-id (σ x)))
                                                                               (subst-∙ (sgs (subst σ u)) {vt1 = `Var} suc (σ x))) })
sgs-lifts-term : ∀ {m vt Γ Δ a b} {σ : RenSub {m} vt Γ Δ} {u : Tm Γ a}{t : Tm (a ∷ Γ) b}
                 → subst (sgs (subst σ u)) (subst (lifts σ) t) ≡ subst σ (subst (sgs u) t)
sgs-lifts-term {σ = σ} {u} {t} = (≡.trans (≡.sym (subst-∙ (sgs (subst σ u)) (lifts σ) t))
                                 (≡.trans (subst-ext sgs-lifts t)
                                          (subst-∙ σ (sgs u) t)))

renId : ∀ {Γ a}{t : Tm Γ a} → rename id t ≡ t
renId = subst-id _

contract : ∀ {a Γ} → RenSub `Var (a ∷ a ∷ Γ) (a ∷ Γ)
contract (zero)    = zero
contract (suc x) = x

contract-sgs : ∀ {a Γ} → contract {a} {Γ} ≡s sgs (var zero)
contract-sgs (zero)  = ≡.refl
contract-sgs (suc x) = ≡.refl

sgs-weak₀ : ∀ {Γ a} {u : Tm Γ a} {b} (x : Var Γ b) → sgs u (suc x) ≡ var x
sgs-weak₀ x = ≡.refl

sgs-weak₁ : ∀ {Γ a} {u : Tm Γ a} → (sgs u ∘ suc) ≡s (ids {vt = `Tm})
sgs-weak₁ x = ≡.refl

sgs-weak : ∀ {Γ a} {u : Tm Γ a} → (sgs u •s weak) ≡s (ids {vt = `Tm})
sgs-weak x = ≡.refl

cons-to-sgs :  ∀ {Γ Δ a} (u : Tm Δ a) (σ : Subst Γ Δ)
               → (u ∷s σ) ≡s (sgs u •s lifts σ)
cons-to-sgs u σ (zero) = ≡.refl
cons-to-sgs u σ (suc x) = begin
    σ x                               ≡⟨ ≡.sym (subst-id (σ x)) ⟩
    subst (ids {vt = `Tm}) (σ x)      ≡⟨ subst-ext (λ _ → ≡.refl) (σ x) ⟩
    subst (sgs u •s weak) (σ x)       ≡⟨ subst-∙ (sgs u) weak (σ x) ⟩
    subst (sgs u) (subst suc (σ x))
  ∎
  where open ≡-Reasoning
-- -}


------------------------------------------------------------------------------
-- The FOTC lists type
------------------------------------------------------------------------------

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

-- N.B. This module is re-exported by FOTC.Data.List.

module FOTC.Data.List.Type where

open import FOTC.Base
open import FOTC.Base.List

------------------------------------------------------------------------------
-- The FOTC lists type (inductive predicate for total lists).
data List : D → Set where
  lnil  : List []
  lcons : ∀ x {xs} → List xs → List (x ∷ xs)
{-# ATP axioms lnil lcons #-}

-- Induction principle.
List-ind : (A : D → Set) →
           A [] →
           (∀ x {xs} → A xs → A (x ∷ xs)) →
           ∀ {xs} → List xs → A xs
List-ind A A[] h lnil          = A[]
List-ind A A[] h (lcons x Lxs) = h x (List-ind A A[] h Lxs)


{-# OPTIONS --cubical --no-import-sorts --safe #-}
module Cubical.Structures.Group.MorphismProperties where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Isomorphism
open import Cubical.Foundations.Equiv
open import Cubical.Foundations.Equiv.HalfAdjoint
open import Cubical.Foundations.HLevels
open import Cubical.Foundations.Univalence
open import Cubical.Foundations.SIP
open import Cubical.Foundations.Function using (_∘_)
open import Cubical.Foundations.GroupoidLaws
open import Cubical.Functions.Embedding
open import Cubical.Data.Sigma

open import Cubical.Structures.Axioms
open import Cubical.Structures.NAryOp
open import Cubical.Structures.Pointed
open import Cubical.Structures.Semigroup hiding (⟨_⟩)
open import Cubical.Structures.Monoid hiding (⟨_⟩)

open import Cubical.Structures.Group.Base
open import Cubical.Structures.Group.Properties
open import Cubical.Structures.Group.Morphism

open Iso

private
  variable
    ℓ ℓ' ℓ'' : Level

isPropIsGroupHom : (G : Group {ℓ}) (H : Group {ℓ'}) {f : ⟨ G ⟩ → ⟨ H ⟩} → isProp (isGroupHom G H f)
isPropIsGroupHom G H {f} = isPropΠ2 λ a b → Group.is-set H _ _

isSetGroupHom : {G : Group {ℓ}} {H : Group {ℓ'}} → isSet (GroupHom G H)
isSetGroupHom {G = G} {H = H} = isOfHLevelRespectEquiv 2 equiv (isSetΣ (isSetΠ λ _ → is-set H) λ _ → isProp→isSet (isPropIsGroupHom G H)) where
  open Group
  equiv : (Σ[ g ∈ (Carrier G → Carrier H) ] (isGroupHom G H g)) ≃ GroupHom G H
  equiv = isoToEquiv (iso (λ (g , m) → grouphom g m) (λ (grouphom g m) → g , m) (λ _ → refl) λ _ → refl)

-- Morphism composition
isGroupHomComp : {F : Group {ℓ}} {G : Group {ℓ'}} {H : Group {ℓ''}} →
  (f : GroupHom F G) → (g : GroupHom G H) → isGroupHom F H (GroupHom.fun g ∘ GroupHom.fun f)
isGroupHomComp (grouphom f morph-f) (grouphom g morph-g) x y =
  cong g (morph-f _ _) ∙ morph-g _ _

compGroupHom : {F : Group {ℓ}} {G : Group {ℓ'}} {H : Group {ℓ''}} → GroupHom F G → GroupHom G H → GroupHom F H
compGroupHom {F = F} {G = G} {H = H} f g = grouphom _ (isGroupHomComp f g)

compGroupEquiv : {F : Group {ℓ}} {G : Group {ℓ'}} {H : Group {ℓ''}} → GroupEquiv F G → GroupEquiv G H → GroupEquiv F H
compGroupEquiv {F = F} {G = G} {H = H} f g =
  groupequiv (compEquiv f.eq g.eq) (isGroupHomComp f.hom g.hom) where
  module f = GroupEquiv f
  module g = GroupEquiv g

idGroupEquiv : (G : Group {ℓ}) → GroupEquiv G G
idGroupEquiv G = groupequiv (idEquiv (Group.Carrier G)) (λ _ _ → refl)

-- Isomorphism inversion
isGroupHomInv : {G : Group {ℓ}} {H : Group {ℓ'}} (f : GroupEquiv G H) → isGroupHom H G (invEq (GroupEquiv.eq f))
isGroupHomInv {G = G} {H = H}  (groupequiv (f , eq) morph) h h' = isInj-f _ _ (
  f (g (h ⋆² h') )
    ≡⟨ retEq (f , eq) _ ⟩
  h ⋆² h'
    ≡⟨ sym (λ i → retEq (f , eq) h i ⋆² retEq (f , eq) h' i) ⟩
  f (g h) ⋆² f (g h')
    ≡⟨ sym (morph _ _) ⟩
  f (g h ⋆¹ g h') ∎)
  where
  _⋆¹_ = Group._+_ G
  _⋆²_ = Group._+_ H
  g = invEq (f , eq)
  isEmbedding-f : isEmbedding f
  isEmbedding-f = isEquiv→isEmbedding eq
  isInj-f : (x y : ⟨ G ⟩) → f x ≡ f y → x ≡ y
  isInj-f x y = invEq (_ , isEquiv→isEmbedding eq x y)

invGroupEquiv : {G : Group {ℓ}} {H : Group {ℓ'}} → GroupEquiv G H → GroupEquiv H G
invGroupEquiv {G = G} {H = H} f = groupequiv (invEquiv (eq f)) (isGroupHomInv f) where open GroupEquiv

groupHomEq : {G : Group {ℓ}} {H : Group {ℓ'}} {f g : GroupHom G H} → (GroupHom.fun f ≡ GroupHom.fun g) → f ≡ g
groupHomEq {G = G} {H = H} {grouphom f fm} {grouphom g gm} p i = grouphom (p i) (p-hom i) where
  p-hom : PathP (λ i → isGroupHom G H (p i)) fm gm
  p-hom = toPathP (isPropIsGroupHom G H _ _)

groupEquivEq : {G : Group {ℓ}} {H : Group {ℓ'}} {f g : GroupEquiv G H} → (GroupEquiv.eq f ≡ GroupEquiv.eq g) → f ≡ g
groupEquivEq {G = G} {H = H} {groupequiv f fm} {groupequiv g gm} p i = groupequiv (p i) (p-hom i) where
  p-hom : PathP (λ i → isGroupHom G H (p i .fst)) fm gm
  p-hom = toPathP (isPropIsGroupHom G H _ _)

module GroupΣTheory {ℓ} where

  RawGroupStructure : Type ℓ → Type ℓ
  RawGroupStructure = SemigroupΣTheory.RawSemigroupStructure

  rawGroupUnivalentStr : UnivalentStr RawGroupStructure _
  rawGroupUnivalentStr = SemigroupΣTheory.rawSemigroupUnivalentStr

  -- The neutral element and the inverse function will be derived from the
  -- axioms, instead of being defined in the RawGroupStructure in order
  -- to have that group equivalences are equivalences that preserves
  -- multiplication (so we don't have to show that they also preserve inversion
  -- and neutral element, although they will preserve them).
  GroupAxioms : (G : Type ℓ) → RawGroupStructure G → Type ℓ
  GroupAxioms G _·_ =
      IsSemigroup _·_
    × (Σ[ e ∈ G ] ((x : G) → (x · e ≡ x) × (e · x ≡ x))
                × ((x : G) → Σ[ x' ∈ G ] (x · x' ≡ e) × (x' · x ≡ e)))

  GroupStructure : Type ℓ → Type ℓ
  GroupStructure = AxiomsStructure RawGroupStructure GroupAxioms

  GroupΣ : Type (ℓ-suc ℓ)
  GroupΣ = TypeWithStr ℓ GroupStructure

  -- Structured equivalences for groups are those for monoids (but different axioms)
  GroupEquivStr : StrEquiv GroupStructure ℓ
  GroupEquivStr = AxiomsEquivStr (BinaryFunEquivStr PointedEquivStr) GroupAxioms

  open MonoidTheory

  isPropGroupAxioms : (G : Type ℓ)
                      → (s : RawGroupStructure G)
                      → isProp (GroupAxioms G s)
  isPropGroupAxioms G _+_ = isPropΣ (isPropIsSemigroup _) γ
    where
    γ : (h : IsSemigroup _+_) →
        isProp (Σ[ e ∈ G ] ((x : G) → (x + e ≡ x) × (e + x ≡ x))
                         × ((x : G) → Σ[ x' ∈ G ] (x + x' ≡ e) × (x' + x ≡ e)))
    γ h (e , P , _) (e' , Q , _) =
      Σ≡Prop (λ x → isPropΣ (isPropΠ λ _ → isProp× (isSetG _ _) (isSetG _ _)) (β x))
             (sym (fst (Q e)) ∙ snd (P e'))
      where
      isSetG : isSet G
      isSetG = IsSemigroup.is-set h

      β : (e : G) → ((x : G) → (x + e ≡ x) × (e + x ≡ x))
        → isProp ((x : G) → Σ[ x' ∈ G ] (x + x' ≡ e) × (x' + x ≡ e))
      β e He =
        isPropΠ λ { x (x' , _ , P) (x'' , Q , _) →
                Σ≡Prop (λ _ → isProp× (isSetG _ _) (isSetG _ _))
                       (inv-lemma ℳ x x' x'' P Q) }
        where
        ℳ : Monoid
        ℳ = makeMonoid e _+_ isSetG (IsSemigroup.assoc h) (λ x → He x .fst) (λ x → He x .snd)

  Group→GroupΣ : Group → GroupΣ
  Group→GroupΣ (group _ _ _ -_ isGroup) =
   _ , _ , IsMonoid.isSemigroup (IsGroup.isMonoid isGroup) ,
   _ , IsMonoid.identity (IsGroup.isMonoid isGroup) ,
   λ x → (- x) , IsGroup.inverse isGroup x

  GroupΣ→Group : GroupΣ → Group
  GroupΣ→Group (_ , _ , SG , _ , H0g , w ) =
     group _ _ _ (λ x → w x .fst) (isgroup (ismonoid SG H0g) λ x → w x .snd)

  GroupIsoGroupΣ : Iso Group GroupΣ
  GroupIsoGroupΣ = iso Group→GroupΣ GroupΣ→Group (λ _ → refl) (λ _ → refl)

  groupUnivalentStr : UnivalentStr GroupStructure GroupEquivStr
  groupUnivalentStr = axiomsUnivalentStr _ isPropGroupAxioms rawGroupUnivalentStr

  GroupΣPath : (G H : GroupΣ) → (G ≃[ GroupEquivStr ] H) ≃ (G ≡ H)
  GroupΣPath = SIP groupUnivalentStr

  GroupEquivΣ : (G H : Group) → Type ℓ
  GroupEquivΣ G H = Group→GroupΣ G ≃[ GroupEquivStr ] Group→GroupΣ H

  GroupIsoΣPath : {G H : Group} → Iso (GroupEquiv G H) (GroupEquivΣ G H)
  fun GroupIsoΣPath (groupequiv e h) = (e , h)
  inv GroupIsoΣPath (e , h)        = groupequiv e h
  rightInv GroupIsoΣPath _         = refl
  leftInv GroupIsoΣPath _          = refl

  GroupPath : (G H : Group) → (GroupEquiv G H) ≃ (G ≡ H)
  GroupPath G H =
    GroupEquiv G H                    ≃⟨ isoToEquiv GroupIsoΣPath ⟩
    GroupEquivΣ G H                   ≃⟨ GroupΣPath _ _ ⟩
    Group→GroupΣ G ≡ Group→GroupΣ H ≃⟨ isoToEquiv (invIso (congIso GroupIsoGroupΣ)) ⟩
    G ≡ H ■

-- Extract the characterization of equality of groups
GroupPath : (G H : Group {ℓ}) → (GroupEquiv G H) ≃ (G ≡ H)
GroupPath = GroupΣTheory.GroupPath

uaGroup : {G H : Group {ℓ}} → GroupEquiv G H → G ≡ H
uaGroup {G = G} {H = H} = equivFun (GroupPath G H)

carac-uaGroup : {G H : Group {ℓ}} (f : GroupEquiv G H) → cong Group.Carrier (uaGroup f) ≡ ua (GroupEquiv.eq f)
carac-uaGroup (groupequiv f m) =
  (refl ∙∙ ua f ∙∙ refl)
    ≡⟨ sym (rUnit (ua f)) ⟩
  ua f ∎

-- Group-ua functoriality
open Group

Group≡ : (G H : Group {ℓ}) → (
  Σ[ p ∈ Carrier G ≡ Carrier H ]
  Σ[ q ∈ PathP (λ i → p i) (0g G) (0g H) ]
  Σ[ r ∈ PathP (λ i → p i → p i → p i) (_+_ G) (_+_ H) ]
  Σ[ s ∈ PathP (λ i → p i → p i) (-_ G) (-_ H) ]
  PathP (λ i → IsGroup (q i) (r i) (s i)) (isGroup G) (isGroup H))
  ≃ (G ≡ H)
Group≡ G H = isoToEquiv (iso
  (λ (p , q , r , s , t) i → group (p i) (q i) (r i) (s i) (t i))
  (λ p → cong Carrier p , cong 0g p , cong _+_ p , cong -_ p , cong isGroup p)
  (λ _ → refl) (λ _ → refl))

caracGroup≡ : {G H : Group {ℓ}} (p q : G ≡ H) → cong Group.Carrier p ≡ cong Group.Carrier q → p ≡ q
caracGroup≡ {G = G} {H = H} p q t = cong (fst (Group≡ G H)) (Σ≡Prop (λ t →
  isPropΣ
    (isOfHLevelPathP' 1 (is-set H) _ _) λ t₁ → isPropΣ
    (isOfHLevelPathP' 1 (isSetΠ2 λ _ _ → is-set H) _ _) λ t₂ → isPropΣ
    (isOfHLevelPathP' 1 (isSetΠ λ _ → is-set H) _ _) λ t₃ →
    isOfHLevelPathP 1 (isPropIsGroup _ _ _) _ _)
  t)

uaGroupId : (G : Group {ℓ}) → uaGroup (idGroupEquiv G) ≡ refl
uaGroupId G = caracGroup≡ _ _ (carac-uaGroup (idGroupEquiv G) ∙ uaIdEquiv)

uaCompGroupEquiv : {F G H : Group {ℓ}} (f : GroupEquiv F G) (g : GroupEquiv G H) → uaGroup (compGroupEquiv f g) ≡ uaGroup f ∙ uaGroup g
uaCompGroupEquiv f g = caracGroup≡ _ _ (
  cong Carrier (uaGroup (compGroupEquiv f g))
    ≡⟨ carac-uaGroup (compGroupEquiv f g) ⟩
  ua (eq (compGroupEquiv f g))
    ≡⟨ uaCompEquiv _ _ ⟩
  ua (eq f) ∙ ua (eq g)
    ≡⟨ cong (_∙ ua (eq g)) (sym (carac-uaGroup f)) ⟩
  cong Carrier (uaGroup f) ∙ ua (eq g)
    ≡⟨ cong (cong Carrier (uaGroup f) ∙_) (sym (carac-uaGroup g)) ⟩
  cong Carrier (uaGroup f) ∙ cong Carrier (uaGroup g)
    ≡⟨ sym (cong-∙ Carrier (uaGroup f) (uaGroup g)) ⟩
  cong Carrier (uaGroup f ∙ uaGroup g) ∎) where
  open GroupEquiv


module hott.topology where

open import hott.topology.loopspace public


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

-- First and second species counterpoint
module Counterpoint where

open import Data.Bool using (Bool; true; false; if_then_else_; _∨_; _∧_; not)
open import Data.Fin using (Fin; #_)
open import Data.Integer using (+_)
open import Data.List using (List; []; _∷_; mapMaybe; map; zip; _++_; concatMap)
open import Data.Maybe using (Maybe; just; nothing)
open import Data.Nat using (suc; _+_; _<ᵇ_; compare; _∸_; ℕ; zero) renaming (_≡ᵇ_ to _==_)
open import Data.Product using (_×_; _,_; proj₁; proj₂; uncurry)
open import Data.Vec using ([]; _∷_; Vec; lookup; drop; reverse)

open import Function using (_∘_)

open import Relation.Binary.PropositionalEquality using (_≡_; refl)

open import Music
open import Note
open import Pitch
open import Interval
open import Util using (pairs)

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

-- First species

-- Beginning must be the 1st, 5th, or 8th
data BeginningError : Set where
  not158   : PitchInterval → BeginningError

checkBeginning : PitchInterval → Maybe BeginningError
checkBeginning pi@(_ , i) =
  if ((i == per1) ∨ (i == per5) ∨ (i == per8))
  then nothing
  else just (not158 pi)

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

-- Intervals in middle bars must be consonant and non-unison
data IntervalError : Set where
  dissonant : Upi   → IntervalError
  unison    : Pitch → IntervalError

intervalCheck : PitchInterval → Maybe IntervalError
intervalCheck (p , i) with isConsonant i | isUnison i
intervalCheck (p , i) | false | _    = just (dissonant i)
intervalCheck (p , i) | _     | true = just (unison p)
intervalCheck (p , i) | _     | _    = nothing

checkIntervals : List PitchInterval → List IntervalError
checkIntervals = mapMaybe intervalCheck

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

-- Perfect intervals must not approached by parallel or similar motion
data Motion : Set where
  contrary : Motion
  parallel : Motion
  similar  : Motion
  oblique  : Motion

motion : PitchInterval → PitchInterval → Motion
motion (p , i) (q , j) =
  let p' = p + i; q' = q + j
  in if i == j then parallel
     else (if (p == q) ∨ (p' == q') then oblique
           else (if p <ᵇ q then (if p' <ᵇ q' then similar  else contrary)
                 else           (if p' <ᵇ q' then contrary else similar)))

data MotionError : Set where
  parallel : PitchInterval → PitchInterval → MotionError
  similar  : PitchInterval → PitchInterval → MotionError

motionCheck : PitchInterval → PitchInterval → Maybe MotionError
motionCheck i1 i2 with motion i1 i2 | isPerfect (proj₂ i2)
motionCheck i1 i2 | contrary | _     = nothing
motionCheck i1 i2 | oblique  | _     = nothing
motionCheck i1 i2 | parallel | false = nothing
motionCheck i1 i2 | parallel | true  = just (parallel i1 i2)
motionCheck i1 i2 | similar  | false = nothing
motionCheck i1 i2 | similar  | true  = just (similar i1 i2)

checkMotion : List PitchInterval → List MotionError
checkMotion = mapMaybe (uncurry motionCheck) ∘ pairs

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

-- Ending must be the 1st or 8th approached by a cadence
data EndingError : Set where
  not18    : PitchInterval → EndingError
  not27    : PitchInterval → EndingError
  tooShort : List PitchInterval → EndingError

endingCheck : PitchInterval → PitchInterval → Maybe EndingError
endingCheck pi1@(p , i) (q , 0)  =
  if ((p + 1 == q) ∧ (i == min3)) then nothing else just (not27 pi1)
endingCheck pi1@(p , i) (q , 12) =
  if ((q + 2 == p) ∧ (i == maj6) ∨ (p + 1 == q) ∧ (i == min10))
  then nothing
  else just (not27 pi1)
endingCheck pi1               pi2                     =
  just (not18 pi2)

checkEnding : List PitchInterval → PitchInterval → Maybe EndingError
checkEnding []       _ = just (tooShort [])
checkEnding (p ∷ []) q = endingCheck p q
checkEnding (p ∷ ps) q = checkEnding ps q

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

-- Correct first species counterpoint
record FirstSpecies : Set where
  constructor firstSpecies
  field
    firstBar    : PitchInterval
    middleBars  : List PitchInterval
    lastBar     : PitchInterval
    beginningOk : checkBeginning firstBar ≡ nothing
    intervalsOk : checkIntervals middleBars ≡ []
    motionOk    : checkMotion (firstBar ∷ middleBars) ≡ []
                  -- no need to include the last bar,
                  -- since endingOK guarantees contrary motion in the ending
    endingOk    : checkEnding middleBars lastBar ≡ nothing

------------------------------------------------
-- Second Species

PitchInterval2 : Set
PitchInterval2 = Pitch × Upi × Upi

strongBeat : PitchInterval2 → PitchInterval
strongBeat (p , i , _) = p , i

weakBeat : PitchInterval2 → PitchInterval
weakBeat (p , _ , i) = p , i

expandPitchInterval2 : PitchInterval2 → List PitchInterval
expandPitchInterval2 (p , i , j) = (p , i) ∷ (p , j) ∷ []

expandPitchIntervals2 : List PitchInterval2 → List PitchInterval
expandPitchIntervals2 = concatMap expandPitchInterval2

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

-- Beginning must be the 5th or 8th
data BeginningError2 : Set where
  not58    : PitchInterval → BeginningError2

checkBeginning2 : PitchInterval → Maybe BeginningError2
checkBeginning2 pi@(_ , i) =
  if ((i == per5) ∨ (i == per8))
  then nothing
  else just (not58 pi)

checkEnding2 : List PitchInterval2 → PitchInterval → Maybe EndingError
checkEnding2 []           _   = just (tooShort [])
checkEnding2 (p ∷ [])     q   = endingCheck (weakBeat p) q
checkEnding2 (_ ∷ p ∷ ps) q   = checkEnding2 (p ∷ ps) q

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

-- Strong beats must be consonant and non-unison
checkStrongBeats : List PitchInterval2 → List IntervalError
checkStrongBeats = checkIntervals ∘ map strongBeat

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

-- Weak beats may be dissonant or unison
checkWeakBeat : PitchInterval2 → Pitch → Maybe IntervalError
checkWeakBeat (p , i , j) q with isConsonant j | isUnison j
checkWeakBeat (p , i , j) q | false | _ =
  if isPassingTone (secondPitch (p , i)) (secondPitch (p , j)) q
  then nothing
  else just (dissonant j)
checkWeakBeat (p , i , j) q | _ | true =
  if isOppositeStep (secondPitch (p , i)) (secondPitch (p , j)) q
  then nothing
  else just (unison p)
checkWeakBeat (p , i , j) q | _ | _    =
  nothing

checkWeakBeats : List PitchInterval2 → Pitch → List IntervalError
checkWeakBeats []            p = []
checkWeakBeats pis@(_ ∷ qis) p =
  mapMaybe (uncurry checkWeakBeat)
           (zip pis
                (map (λ {(q , i , j) → proj₂ (pitchIntervalToPitchPair (q , i))}) qis ++ (p ∷ [])))

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

-- Perfect intervals on strong beats must not be approached by parallel or similar motion
checkMotion2 : List PitchInterval → List MotionError
checkMotion2 []           = []
checkMotion2 (_ ∷ [])     = []
checkMotion2 (p ∷ q ∷ ps) = checkMotion (p ∷ q ∷ []) ++ checkMotion2 ps

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

-- Correct second species counterpoint
record SecondSpecies : Set where
  constructor secondSpecies
  field
    firstBar      : PitchInterval -- require counterpont to start with a rest, which is preferred
    middleBars    : List PitchInterval2
    lastBar       : PitchInterval -- require counterpoint to end with only a single whole note, which is preferred
    beginningOk   : checkBeginning2 firstBar ≡ nothing
    strongBeatsOk : checkStrongBeats middleBars ≡ []
    weakBeatsOk   : checkWeakBeats middleBars (secondPitch lastBar) ≡ []
    motionOk      : checkMotion2 (firstBar ∷ (expandPitchIntervals2 middleBars)) ≡ []
    endingOk      : checkEnding2 middleBars lastBar ≡ nothing


{- Basic theory about transport:

- transport is invertible
- transport is an equivalence ([pathToEquiv])

-}
{-# OPTIONS --safe #-}
module Cubical.Foundations.Transport where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Equiv
open import Cubical.Foundations.Isomorphism
open import Cubical.Foundations.Univalence
open import Cubical.Foundations.GroupoidLaws
open import Cubical.Foundations.Function using (_∘_)

-- Direct definition of transport filler, note that we have to
-- explicitly tell Agda that the type is constant (like in CHM)
transpFill : ∀ {ℓ} {A : Type ℓ}
             (φ : I)
             (A : (i : I) → Type ℓ [ φ ↦ (λ _ → A) ])
             (u0 : outS (A i0))
           → --------------------------------------
             PathP (λ i → outS (A i)) u0 (transp (λ i → outS (A i)) φ u0)
transpFill φ A u0 i = transp (λ j → outS (A (i ∧ j))) (~ i ∨ φ) u0

transport⁻ : ∀ {ℓ} {A B : Type ℓ} → A ≡ B → B → A
transport⁻ p = transport (λ i → p (~ i))

subst⁻ : ∀ {ℓ ℓ'} {A : Type ℓ} {x y : A} (B : A → Type ℓ') (p : x ≡ y) → B y → B x
subst⁻ B p pa = transport⁻ (λ i → B (p i)) pa

transport-fillerExt : ∀ {ℓ} {A B : Type ℓ} (p : A ≡ B)
                    → PathP (λ i → A → p i) (λ x → x) (transport p)
transport-fillerExt p i x = transport-filler p x i

transport⁻-fillerExt : ∀ {ℓ} {A B : Type ℓ} (p : A ≡ B)
                     → PathP (λ i → p i → A) (λ x → x) (transport⁻ p)
transport⁻-fillerExt p i x = transp (λ j → p (i ∧ ~ j)) (~ i) x

transport-fillerExt⁻ : ∀ {ℓ} {A B : Type ℓ} (p : A ≡ B)
                    → PathP (λ i → p i → B) (transport p) (λ x → x)
transport-fillerExt⁻ p = symP (transport⁻-fillerExt (sym p))

transport⁻-fillerExt⁻ : ∀ {ℓ} {A B : Type ℓ} (p : A ≡ B)
                     → PathP (λ i → B → p i) (transport⁻ p) (λ x → x)
transport⁻-fillerExt⁻ p = symP (transport-fillerExt (sym p))

transport⁻-filler : ∀ {ℓ} {A B : Type ℓ} (p : A ≡ B) (x : B)
                   → PathP (λ i → p (~ i)) x (transport⁻ p x)
transport⁻-filler p x = transport-filler (λ i → p (~ i)) x

transport⁻Transport : ∀ {ℓ} {A B : Type ℓ} → (p : A ≡ B) → (a : A) →
                          transport⁻ p (transport p a) ≡ a
transport⁻Transport p a j = transport⁻-fillerExt p (~ j) (transport-fillerExt p (~ j) a)

transportTransport⁻ : ∀ {ℓ} {A B : Type ℓ} → (p : A ≡ B) → (b : B) →
                        transport p (transport⁻ p b) ≡ b
transportTransport⁻ p b j = transport-fillerExt⁻ p j (transport⁻-fillerExt⁻ p j b)

substEquiv : ∀ {ℓ ℓ'} {A : Type ℓ} {a a' : A} (P : A → Type ℓ') (p : a ≡ a') → P a ≃ P a'
substEquiv P p = (subst P p , isEquivTransport (λ i → P (p i)))

liftEquiv : ∀ {ℓ ℓ'} {A B : Type ℓ} (P : Type ℓ → Type ℓ') (e : A ≃ B) → P A ≃ P B
liftEquiv P e = substEquiv P (ua e)

transpEquiv : ∀ {ℓ} {A B : Type ℓ} (p : A ≡ B) → ∀ i → p i ≃ B
transpEquiv P i .fst = transp (λ j → P (i ∨ j)) i
transpEquiv P i .snd
  = transp (λ k → isEquiv (transp (λ j → P (i ∨ (j ∧ k))) (i ∨ ~ k)))
      i (idIsEquiv (P i))

uaTransportη : ∀ {ℓ} {A B : Type ℓ} (P : A ≡ B) → ua (pathToEquiv P) ≡ P
uaTransportη P i j
  = Glue (P i1) λ where
      (j = i0) → P i0 , pathToEquiv P
      (i = i1) → P j , transpEquiv P j
      (j = i1) → P i1 , idEquiv (P i1)

pathToIso : ∀ {ℓ} {A B : Type ℓ} → A ≡ B → Iso A B
Iso.fun (pathToIso x) = transport x
Iso.inv (pathToIso x) = transport⁻ x
Iso.rightInv (pathToIso x) = transportTransport⁻ x
Iso.leftInv (pathToIso x) = transport⁻Transport x

isInjectiveTransport : ∀ {ℓ : Level} {A B : Type ℓ} {p q : A ≡ B}
  → transport p ≡ transport q → p ≡ q
isInjectiveTransport {p = p} {q} α i =
  hcomp
    (λ j → λ
      { (i = i0) → retEq univalence p j
      ; (i = i1) → retEq univalence q j
      })
    (invEq univalence ((λ a → α i a) , t i))
  where
  t : PathP (λ i → isEquiv (λ a → α i a)) (pathToEquiv p .snd) (pathToEquiv q .snd)
  t = isProp→PathP (λ i → isPropIsEquiv (λ a → α i a)) _ _

transportUaInv : ∀ {ℓ} {A B : Type ℓ} (e : A ≃ B) → transport (ua (invEquiv e)) ≡ transport (sym (ua e))
transportUaInv e = cong transport (uaInvEquiv e)
-- notice that transport (ua e) would reduce, thus an alternative definition using EquivJ can give
-- refl for the case of idEquiv:
-- transportUaInv e = EquivJ (λ _ e → transport (ua (invEquiv e)) ≡ transport (sym (ua e))) refl e

isSet-subst : ∀ {ℓ ℓ'} {A : Type ℓ} {B : A → Type ℓ'}
                → (isSet-A : isSet A)
                → ∀ {a : A}
                → (p : a ≡ a) → (x : B a) → subst B p x ≡ x
isSet-subst {B = B} isSet-A p x = subst (λ p′ → subst B p′ x ≡ x) (isSet-A _ _ refl p) (substRefl {B = B} x)

-- substituting along a composite path is equivalent to substituting twice
substComposite : ∀ {ℓ ℓ'} {A : Type ℓ} → (B : A → Type ℓ')
                 → {x y z : A} (p : x ≡ y) (q : y ≡ z) (u : B x)
                 → subst B (p ∙ q) u ≡ subst B q (subst B p u)
substComposite B p q Bx i =
  transport (cong B (compPath-filler' p q (~ i))) (transport-fillerExt (cong B p) i Bx)

-- transporting along a composite path is equivalent to transporting twice
transportComposite : ∀ {ℓ} {A B C : Type ℓ} (p : A ≡ B) (q : B ≡ C) (x : A)
                 → transport (p ∙ q) x ≡ transport q (transport p x)
transportComposite = substComposite (λ D → D)

-- substitution commutes with morphisms in slices
substCommSlice : ∀ {ℓ ℓ′} {A : Type ℓ}
                   → (B C : A → Type ℓ′)
                   → (F : ∀ a → B a → C a)
                   → {x y : A} (p : x ≡ y) (u : B x)
                   → subst C p (F x u) ≡ F y (subst B p u)
substCommSlice B C F p Bx a =
  transport-fillerExt⁻ (cong C p) a (F _ (transport-fillerExt (cong B p) a Bx))

constSubstCommSlice : ∀ {ℓ ℓ'} {A : Type ℓ}
                   → (B : A → Type ℓ')
                   → (C : Type ℓ')
                   → (F : ∀ a → B a → C)
                   → {x y : A} (p : x ≡ y) (u : B x)
                   →  (F x u) ≡ F y (subst B p u)
constSubstCommSlice B C F p Bx = (sym (transportRefl (F _ Bx)) ∙ substCommSlice B (λ _ → C) F p Bx)

-- transporting over (λ i → B (p i) → C (p i)) divides the transport into
-- transports over (λ i → C (p i)) and (λ i → B (p (~ i)))
funTypeTransp : ∀ {ℓ ℓ'} {A : Type ℓ} (B C : A → Type ℓ') {x y : A} (p : x ≡ y) (f : B x → C x)
         → PathP (λ i → B (p i) → C (p i)) f (subst C p ∘ f ∘ subst B (sym p))
funTypeTransp B C {x = x} p f i b =
  transp (λ j → C (p (j ∧ i))) (~ i) (f (transp (λ j → B (p (i ∧ ~ j))) (~ i) b))

-- transports between loop spaces preserve path composition
overPathFunct : ∀ {ℓ} {A : Type ℓ} {x y : A} (p q : x ≡ x) (P : x ≡ y)
           → transport (λ i → P i ≡ P i) (p ∙ q)
            ≡ transport (λ i → P i ≡ P i) p ∙ transport (λ i → P i ≡ P i) q
overPathFunct p q =
  J (λ y P → transport (λ i → P i ≡ P i) (p ∙ q) ≡ transport (λ i → P i ≡ P i) p ∙ transport (λ i → P i ≡ P i) q)
    (transportRefl (p ∙ q) ∙ cong₂ _∙_ (sym (transportRefl p)) (sym (transportRefl q)))

-- substition over families of paths
-- theorem 2.11.3 in The Book
substInPaths : ∀ {ℓ} {A B : Type ℓ} {a a' : A}
                 → (f g : A → B) → (p : a ≡ a') (q : f a ≡ g a)
                 → subst (λ x → f x ≡ g x) p q ≡ sym (cong f p) ∙ q ∙ cong g p
substInPaths {a = a} f g p q =
  J (λ x p' → (subst (λ y → f y ≡ g y) p' q) ≡ (sym (cong f p') ∙ q ∙ cong g p'))
    p=refl p
    where
    p=refl : subst (λ y → f y ≡ g y) refl q
           ≡ refl ∙ q ∙ refl
    p=refl = subst (λ y → f y ≡ g y) refl q
           ≡⟨ substRefl {B = (λ y → f y ≡ g y)} q ⟩ q
           ≡⟨ (rUnit q) ∙ lUnit (q ∙ refl) ⟩ refl ∙ q ∙ refl ∎

-- special cases of substInPaths from lemma 2.11.2 in The Book
module _ {ℓ : Level} {A : Type ℓ} {a x1 x2 : A} (p : x1 ≡ x2) where
  substInPathsL : (q : a ≡ x1) → subst (λ x → a ≡ x) p q ≡ q ∙ p
  substInPathsL q = subst (λ x → a ≡ x) p q
    ≡⟨ substInPaths (λ _ → a) (λ x → x) p q ⟩
      sym (cong (λ _ → a) p) ∙ q ∙ cong (λ x → x) p
    ≡⟨ assoc (λ _ → a) q p ⟩
      (refl ∙ q) ∙ p
    ≡⟨ cong (_∙ p) (sym (lUnit q)) ⟩ q ∙ p ∎

  substInPathsR : (q : x1 ≡ a) → subst (λ x → x ≡ a) p q ≡ sym p ∙ q
  substInPathsR q = subst (λ x → x ≡ a) p q
    ≡⟨ substInPaths (λ x → x) (λ _ → a) p q ⟩
      sym (cong (λ x → x) p) ∙ q ∙ cong (λ _ → a) p
    ≡⟨ assoc (sym p) q refl ⟩
      (sym p ∙ q) ∙ refl
    ≡⟨ sym (rUnit (sym p ∙ q))⟩ sym p ∙ q ∎


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

module overloading where

-- An overloading system based on instance arguments. See `overloading.core` for
-- more details and documentation.

open import overloading.bundle public
open import overloading.core public
open import overloading.level public


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

module AgdaFeatureNeedHiddenVariableTypeConstructorWrapper where

Unwrapped : {A : Set} → (A → Set) → Set₁
Unwrapped B = ∀ {x} → B x → Set

record Unindexed : Set₁ where
  field
    {A} : Set
    {B} : A → Set
    unwrap : Unwrapped B

record Indexed {A : Set} (B : A → Set) : Set₁ where
  field
    unwrap : Unwrapped B

record Generic (A : Set₁) : Set₁ where
  field
    unwrap : A

record Foo (F : Set₁) : Set₁ where
  field
    foo : F → Set

open Foo {{...}}

postulate
  A : Set
  B : A → Set
  unwrapped : Unwrapped B
  indexed : Indexed B
  unindexed : Unindexed
  generic : Generic (Unwrapped B)

postulate

  instance FooUnwrapped : Foo (Unwrapped B)
  instance FooIndexed : Foo (Indexed B)
  instance FooUnindexed : Foo Unindexed
  instance FooGeneric : Foo (Generic (Unwrapped B))

test-unwrapped-lambda-unhide-works : Set
test-unwrapped-lambda-unhide-works = foo (λ {_} → unwrapped)

test-unwrapped-help-instance-works : Set
test-unwrapped-help-instance-works = foo {F = ∀ {_} → _} unwrapped

test-unindexed-works : Set
test-unindexed-works = foo unindexed

test-indexed-works : Set
test-indexed-works = foo indexed

test-generic-works : Set
test-generic-works = foo generic

test-unwrapped-fails : Set
test-unwrapped-fails = {!foo unwrapped!}
{-
No instance of type Foo (B _x_48 → Set) was found in scope.
when checking that unwrapped is a valid argument to a function of
type {F : Set₁} {{r : Foo F}} → F → Set
-}

-- tests for unwrapping

unwrap-test-generic : Unwrapped B
unwrap-test-generic = let instance _ = generic in let open Generic ⦃ … ⦄ in unwrap {A = Unwrapped _}

unwrap-test-index : Unwrapped B
unwrap-test-index = let instance _ = indexed in let open Indexed ⦃ … ⦄ in unwrap


{-# OPTIONS --copatterns #-}
module EmptyInductiveRecord where

mutual

  data E : Set where
    e : F -> E

  record F : Set where
    inductive
    constructor c
    field f : E
open F

data ⊥ : Set where

elim : E → ⊥
elim (e (c x)) = elim x

elim' : E → ⊥
elim' (e y) = elim' (f y)


module instances where
open import lib public renaming (return to returnᵢₒ; _>>_ to _>>ᵢₒ_; _>>=_ to _>>=ᵢₒ_)
open import functions public

record functor {ℓ ℓ'} (F : Set ℓ → Set ℓ') : Set (lsuc (ℓ ⊔ ℓ')) where
  infixl 2 _<$>_ _<$_
  field
    fmap : ∀ {A B : Set ℓ} → (A → B) → F A → F B

  {-functor-identity-law :
      ∀ {A} (fa : F A) →
        fmap id fa ≡ fa
    functor-composition-law :
      ∀ {A B C} (f : B → C) (g : A → B) (fa : F A) →
        fmap (f ∘ g) fa ≡ fmap f (fmap g fa)-}

  _<$>_ = fmap

  _<$_ : ∀ {A B : Set ℓ} → A → F B → F A
  a <$ fb = (λ _ → a) <$> fb

open functor ⦃...⦄ public

record applicative {ℓ ℓ'} (F : Set ℓ → Set ℓ') : Set (lsuc (ℓ ⊔ ℓ')) where
  infixl 2 _<*>_ _<*_ _*>_
  field
    pure : ∀ {A : Set ℓ} → A → F A
    _<*>_ : ∀ {A B : Set ℓ} → F (A → B) → F A → F B
    ⦃ functorF ⦄ : functor F

  {-applicative-identity-law :
      ∀ {A} (v : F A) →
        pure id <*> v ≡ v
    applicative-composition-law :
      ∀ {A B C} (u : F (B → C)) (v : F (A → B)) (w : F A) →
        pure _∘_ <*> u <*> v <*> w ≡ u <*> (v <*> w)
    applicative-homomorphism-law :
      ∀ {A B} (f : A → B) (x : A) →
        pure f <*> pure x ≡ pure (f x)
    applicative-interchange-law :
      ∀ {A B} (u : F (A → B)) (y : A) →
        u <*> pure y ≡ pure (_$ y) <*> u-}

  _<*_ : ∀ {A B : Set ℓ} → F A → F B → F A
  fa <* fb = (λ a b → a) <$> fa <*> fb

  _*>_ : ∀ {A B : Set ℓ} → F A → F B → F B
  fa *> fb = (λ a b → b) <$> fa <*> fb

  liftA : ∀ {A B : Set ℓ} → (A → B) → F A → F B
  liftA g fa = pure g <*> fa

  liftA2 : ∀ {A B C : Set ℓ} → (A → B → C) → F A → F B → F C
  liftA2 g fa fb = pure g <*> fa <*> fb

  sequenceA : ∀ {A : Set ℓ} → 𝕃 (F A) → F (𝕃 A)
  sequenceA = foldr (liftA2 _::_) (pure [])

open applicative ⦃...⦄ public

record monad {ℓ ℓ'} (F : Set ℓ → Set ℓ') : Set (lsuc (ℓ ⊔ ℓ')) where
  infixr 2 _>>_ _>>=_ _=<<_ _>=>_ _>>=c_ _>>c_ _>>=?_ _>>=m_ _>>=s_ _>>=e_ _>>≠_ _>≯_ _>>=r_ _>>r_

  field
    return : ∀{A : Set ℓ} → A → F A
    _>>=_ : ∀{A B : Set ℓ} → F A → (A → F B) → F B

  {-monad-left-identity-law :
      ∀ {A B} (a : A) (k : A → F B) →
        return a >>= k ≡ k a
    monad-right-identity-law :
      ∀ {A} (m : F A) →
        m >>= return ≡ m
    monad-associativity-law :
      ∀ {A B C} (m : F A) (k : A → F B) (h : B → F C) →
        m >>= (λ x → k x >>= h) ≡ (m >>= k) >>= h-}

  _>>_ : ∀ {A B : Set ℓ} → F A → F B → F B
  fa >> fb = fa >>= λ _ → fb

  _=<<_ : ∀ {A B : Set ℓ} → (A → F B) → F A → F B
  fab =<< fa = fa >>= fab

  _>=>_ : ∀ {A B C : Set ℓ} → (A → F B) → (B → F C) → (A → F C)
  fab >=> fbc = λ a → fab a >>= fbc

  _>>=c_ : ∀ {A B C : Set ℓ} → F (A × B) → (A → B → F C) → F C
  p >>=c f = p >>= λ {(a , b) → f a b}

  _>>c_ : ∀ {A B : Set ℓ} → F A → F B → F (A × B)
  fa >>c fb = fa >>= λ a → fb >>= λ b → return (a , b)

  _>>=?_ : ∀ {A B : Set ℓ} → maybe (F A) → (maybe A → F B) → F B
  nothing >>=? f = f nothing
  (just a) >>=? f = a >>= (f ∘ just)

  _>>=s_ : ∀ {A B E : Set ℓ} → F (E ⊎ A) → (A → F (E ⊎ B)) → F (E ⊎ B)
  s >>=s f = s >>= λ {(inj₁ e) → return (inj₁ e); (inj₂ a) → f a}

  _>>=e_ : ∀ {A B : Set ℓ} → F (error-t A) → (A → F (error-t B)) → F (error-t B)
  fe? >>=e f = fe? >>= λ {(no-error a) → f a; (yes-error e) → return (yes-error e)}

  _>>=m_ : ∀{A B : Set ℓ} → F (maybe A) → (A → F (maybe B)) → F (maybe B)
  m >>=m f = m >>= λ {(just a) → f a; nothing → return nothing}

  _>>≠_  : ∀{A B : Set ℓ} → F A → (A → F B) → F A
  (f₁ >>≠ f₂) = f₁ >>= λ result → f₂ result >> return result

  _>≯_ : ∀{A B : Set ℓ} → F A → F B → F A
  (f₁ >≯ f₂) = f₁ >>= λ result → f₂ >> return result

  _>>=r_ : ∀{A B : Set ℓ} → F A → (A → B) → F B
  a >>=r f = a >>= (return ∘ f)

  _>>r_ : ∀{A B : Set ℓ} → F A → B → F B
  a >>r b = a >> return b

  _on-fail_>>=m_ : ∀ {A B : Set ℓ} → F (maybe A) → F B → (A → F B) → F B
  fa? on-fail fb >>=m fab = fa? >>= λ {(just a) → fab a; nothing → fb}

  _on-fail_>>=s_ : ∀ {A B E : Set ℓ} → F (E ⊎ A) → (E → F B) → (A → F B) → F B
  fa+e on-fail feb >>=s fab = fa+e >>= λ {(inj₁ e) → feb e; (inj₂ a) → fab a}

  return2 : ∀ {A B : Set ℓ} → A → B → F (A × B)
  return2 a b = return (a , b)

  foldrM : ∀ {A B} → (A → F B → F B) → F B → 𝕃 (F A) → F B
  foldrM c n [] = n
  foldrM c n (fa :: fas) = fa >>= λ a → c a (foldrM c n fas)

  foldlM : ∀ {A B} → (A → F B → F B) → F B → 𝕃 (F A) → F B
  foldlM c n [] = n
  foldlM c n (fa :: fas) = fa >>= λ a → foldlM c (c a n) fas

  forM_init_use_ : ∀ {A B} → 𝕃 (F A) → F B → (A → F B → F B) → F B
  forM as init b use f = foldrM f b as

open monad ⦃...⦄ public

join : ∀ {ℓ}{F : Set ℓ → Set ℓ}{A : Set ℓ} ⦃ _ : monad F ⦄ → F (F A) → F A
join ffa = ffa >>= id

infixr 2 _>>∘_
_>>∘_ : ∀{ℓ}{F : Set ℓ → Set ℓ}{A B : Set ℓ} ⦃ _ : monad F ⦄ → F A → F (A → F B) → F B
a >>∘ f = a >>= λ a → f >>= λ f → f a

--========== Id ==========--
-- Using "id" itself causes Agda to hang when resolving instances, I suspect due
-- to something like endlessly embedding (id (id (id (...)))). So instead we must
-- use a "newtype" for id.

record Id (A : Set) : Set where
  constructor id-in
  field id-out : A
open Id public

instance
  id-functor : functor Id
  id-applicative : applicative Id
  id-monad : monad Id

  fmap ⦃ id-functor ⦄ f = id-in ∘ (f ∘ id-out)

  pure ⦃ id-applicative ⦄ = id-in
  _<*>_ ⦃ id-applicative ⦄ fab fa = id-in (id-out fab (id-out fa))

  return ⦃ id-monad ⦄ = id-in
  _>>=_ ⦃ id-monad ⦄ a f = f (id-out a)

--========== IO ==========--

instance
  IO-functor : functor IO
  IO-applicative : applicative IO
  IO-monad : monad IO

{-
postulate
  IO-functor-identity-law :
    ∀ {A} →
      fmap ⦃ IO-functor ⦄ {A} id ≡ id
  IO-functor-composition-law :
    ∀ {A B C} (f : B → C) (g : A → B) →
      fmap (f ∘ g) ≡ fmap f ∘ fmap g

  IO-applicative-identity-law :
    ∀ {A} (v : IO A) →
      pure ⦃ IO-applicative ⦄ id <*> v ≡ v
  IO-applicative-composition-law :
    ∀ {A B C} (u : IO (B → C)) (v : IO (A → B)) (w : IO A) →
      pure ⦃ IO-applicative ⦄ _∘_ <*> u <*> v <*> w ≡ u <*> (v <*> w)
  IO-applicative-homomorphism-law :
    ∀ {A B} (f : A → B) (x : A) →
      pure ⦃ IO-applicative ⦄ f <*> pure x ≡ pure (f x)
  IO-applicative-interchange-law :
    ∀ {A B} (u : IO (A → B)) (y : A) →
      u <*> pure y ≡ pure ⦃ IO-applicative ⦄ (_$ y) <*> u

  IO-monad-left-identity-law :
    ∀ {A B} (a : A) (k : A → IO B) →
      (return a >>= k) ≡ k a
  IO-monad-right-identity-law :
    ∀ {A} (m : IO A) →
      (m >>= return) ≡ m
  IO-monad-associativity-law :
    ∀ {A B C} (m : IO A) (k : A → IO B) (h : B → IO C) →
      (m >>= (λ x → k x >>= h)) ≡ ((m >>= k) >>= h)
-}

  fmap ⦃ IO-functor ⦄ g fa = fa >>=ᵢₒ λ a → returnᵢₒ (g a)

  pure ⦃ IO-applicative ⦄ = returnᵢₒ
  _<*>_ ⦃ IO-applicative ⦄ fab fa = fab >>=ᵢₒ λ ab → fa >>=ᵢₒ λ a → returnᵢₒ (ab a)

  return ⦃ IO-monad ⦄ = returnᵢₒ
  _>>=_ ⦃ IO-monad ⦄ = _>>=ᵢₒ_

--========== ⊎ ==========--

instance
  sum-functor : ∀ {ℓ ℓ'} {E : Set ℓ} → functor {ℓ'} {ℓ ⊔ ℓ'} (E ⊎_)
  sum-applicative : ∀ {ℓ ℓ'} {E : Set ℓ} → applicative {ℓ'} {ℓ ⊔ ℓ'} (E ⊎_)
  sum-monad : ∀ {ℓ ℓ'} {E : Set ℓ} → monad {ℓ'} {ℓ ⊔ ℓ'} (E ⊎_)

  fmap ⦃ sum-functor ⦄ f (inj₁ e) = inj₁ e
  fmap ⦃ sum-functor ⦄ f (inj₂ a) = inj₂ (f a)

  pure ⦃ sum-applicative ⦄ = inj₂
  _<*>_ ⦃ sum-applicative ⦄ sf sa =
    sf >>= λ f →
    sa >>= λ a →
    return (f a)

  return ⦃ sum-monad ⦄ = inj₂
  _>>=_ ⦃ sum-monad ⦄ (inj₁ e) f = inj₁ e
  _>>=_ ⦃ sum-monad ⦄ (inj₂ a) f = f a

--========== maybe ==========--

instance
  maybe-functor : ∀ {ℓ} → functor {ℓ} maybe
  maybe-applicative : ∀ {ℓ} → applicative {ℓ} maybe
  maybe-monad : ∀ {ℓ} → monad {ℓ} maybe

  fmap ⦃ maybe-functor ⦄ = maybe-map

  pure ⦃ maybe-applicative ⦄ = just
  _<*>_ ⦃ maybe-applicative ⦄ f? a? =
    f? ≫=maybe λ f → a? ≫=maybe (just ∘ f)

  return ⦃ maybe-monad ⦄ = just
  _>>=_ ⦃ maybe-monad ⦄ = _≫=maybe_

--========== 𝕃 ==========--

instance
  list-functor : ∀ {ℓ} → functor {ℓ} 𝕃
  list-applicative : ∀ {ℓ} → applicative {ℓ} 𝕃
  list-monad : ∀ {ℓ} → monad {ℓ} 𝕃

  fmap ⦃ list-functor ⦄ = map

  pure ⦃ list-applicative ⦄ = [_]
  _<*>_ ⦃ list-applicative ⦄ fs as = map (λ {(f , a) → f a}) (zip fs as)

  return ⦃ list-monad ⦄ = [_]
  _>>=_ ⦃ list-monad ⦄ as f = concat (map f as)


import      Lvl
open import Structure.Category

module Structure.Category.Functor.Equiv
  {ℓₗₒ ℓᵣₒ ℓₗₘ ℓᵣₘ ℓₗₑ ℓᵣₑ : Lvl.Level}
  {catₗ : CategoryObject{ℓₗₒ}{ℓₗₘ}{ℓₗₑ}}
  {catᵣ : CategoryObject{ℓᵣₒ}{ℓᵣₘ}{ℓᵣₑ}}
  where

open import Functional.Dependent as Fn using (_$_)
import      Function.Equals
open        Function.Equals.Dependent
open import Logic
open import Logic.Propositional
open import Logic.Predicate
open import Relator.Equals using ([≡]-intro) renaming (_≡_ to _≡ₑ_)
open import Relator.Equals.Proofs
open import Relator.Equals.Proofs.Equiv
open import Structure.Category.Functor
open import Structure.Category.Functor.Functors as Functors
open import Structure.Category.Morphism.IdTransport
import      Structure.Categorical.Names as Names
open import Structure.Category.NaturalTransformation
open import Structure.Category.Proofs
open import Structure.Categorical.Properties
open import Structure.Function
open import Structure.Operator
open import Structure.Relator.Equivalence
open import Structure.Relator.Properties
open import Structure.Setoid
open import Syntax.Transitivity
open import Type

open Structure.Category

open Category ⦃ … ⦄
open CategoryObject
open Functor ⦃ … ⦄
private instance _ = category catₗ
private instance _ = category catᵣ
private open module MorphismEquivₗ {x}{y} = Equiv(morphism-equiv(catₗ){x}{y}) using () renaming (_≡_ to _≡ₗₘ_)
private open module MorphismEquivᵣ {x}{y} = Equiv(morphism-equiv(catᵣ){x}{y}) using () renaming (_≡_ to _≡ᵣₘ_)

module _
  (f₁@([∃]-intro F₁) f₂@([∃]-intro F₂) : (catₗ →ᶠᵘⁿᶜᵗᵒʳ catᵣ))
  where

  record _≡ᶠᵘⁿᶜᵗᵒʳ_ : Type{Lvl.of(Type.of(catₗ)) Lvl.⊔ Lvl.of(Type.of(catᵣ))} where
    constructor intro
    field
      functor-proof : (F₁ ⊜ F₂)
      map-proof : NaturalTransformation(f₁)(f₂) (\x → transport(catᵣ) (_⊜_.proof functor-proof {x}))

instance
  [≡ᶠᵘⁿᶜᵗᵒʳ]-reflexivity : Reflexivity(_≡ᶠᵘⁿᶜᵗᵒʳ_)
  _≡ᶠᵘⁿᶜᵗᵒʳ_.functor-proof (Reflexivity.proof [≡ᶠᵘⁿᶜᵗᵒʳ]-reflexivity) = intro [≡]-intro
  NaturalTransformation.natural (_≡ᶠᵘⁿᶜᵗᵒʳ_.map-proof (Reflexivity.proof [≡ᶠᵘⁿᶜᵗᵒʳ]-reflexivity {functor})) {f = f} =
    trans-refl ∘ map(f) 🝖[ _≡ᵣₘ_ ]-[]
    id ∘ map(f)         🝖[ _≡ᵣₘ_ ]-[ Morphism.identityₗ(_∘_)(id) ]
    map(f)              🝖[ _≡ᵣₘ_ ]-[ Morphism.identityᵣ(_∘_)(id) ]-sym
    map(f) ∘ id         🝖[ _≡ᵣₘ_ ]-[]
    map(f) ∘ trans-refl 🝖-end
    where
      trans-refl = \{x} → transport(catᵣ) ([≡]-intro {x = x})

instance
  [≡ᶠᵘⁿᶜᵗᵒʳ]-symmetry : Symmetry(_≡ᶠᵘⁿᶜᵗᵒʳ_)
  _≡ᶠᵘⁿᶜᵗᵒʳ_.functor-proof (Symmetry.proof [≡ᶠᵘⁿᶜᵗᵒʳ]-symmetry xy) = symmetry(_⊜_) (_≡ᶠᵘⁿᶜᵗᵒʳ_.functor-proof xy)
  NaturalTransformation.natural (_≡ᶠᵘⁿᶜᵗᵒʳ_.map-proof (Symmetry.proof [≡ᶠᵘⁿᶜᵗᵒʳ]-symmetry {[∃]-intro F₁} {[∃]-intro F₂} (intro (intro fe) (intro me)))) {x}{y} {f = f} =
    trans-sym(y) ∘ map(f)                               🝖[ _≡ᵣₘ_ ]-[ Morphism.identityᵣ(_∘_)(id) ]-sym
    (trans-sym(y) ∘ map(f)) ∘ id                        🝖[ _≡ᵣₘ_ ]-[ congruence₂ᵣ(_∘_)(_) ([∘]-on-transport-inverseᵣ catᵣ {ab = fe}) ]-sym
    (trans-sym(y) ∘ map(f)) ∘ (trans(x) ∘ trans-sym(x)) 🝖[ _≡ᵣₘ_ ]-[ associate4-213-121 (category catᵣ) ]-sym
    (trans-sym(y) ∘ (map(f) ∘ trans(x))) ∘ trans-sym(x) 🝖[ _≡ᵣₘ_ ]-[ congruence₂ₗ(_∘_)(_) (congruence₂ᵣ(_∘_)(_) me) ]-sym
    (trans-sym(y) ∘ (trans(y) ∘ map(f))) ∘ trans-sym(x) 🝖[ _≡ᵣₘ_ ]-[ associate4-213-121 (category catᵣ) ]
    (trans-sym(y) ∘ trans(y)) ∘ (map(f) ∘ trans-sym(x)) 🝖[ _≡ᵣₘ_ ]-[ congruence₂ₗ(_∘_)(_) ([∘]-on-transport-inverseₗ catᵣ {ab = fe}) ]
    id ∘ (map(f) ∘ trans-sym(x))                        🝖[ _≡ᵣₘ_ ]-[ Morphism.identityₗ(_∘_)(id) ]
    map(f) ∘ trans-sym(x)                               🝖-end
    where
      trans     = \(x : Object(catₗ)) → transport catᵣ (fe{x})
      trans-sym = \(x : Object(catₗ)) → transport catᵣ (symmetry(_≡ₑ_) (fe{x}))

instance
  [≡ᶠᵘⁿᶜᵗᵒʳ]-transitivity : Transitivity(_≡ᶠᵘⁿᶜᵗᵒʳ_)
  _≡ᶠᵘⁿᶜᵗᵒʳ_.functor-proof (Transitivity.proof [≡ᶠᵘⁿᶜᵗᵒʳ]-transitivity (intro fe₁ _) (intro fe₂ _)) = transitivity(_⊜_) fe₁ fe₂
  NaturalTransformation.natural (_≡ᶠᵘⁿᶜᵗᵒʳ_.map-proof (Transitivity.proof [≡ᶠᵘⁿᶜᵗᵒʳ]-transitivity {[∃]-intro F₁} {[∃]-intro F₂} {[∃]-intro F₃} (intro (intro fe₁) (intro me₁)) (intro (intro fe₂) (intro me₂)))) {x}{y} {f = f} =
    transport catᵣ (transitivity(_≡ₑ_) (fe₁{y}) (fe₂{y})) ∘ map(f) 🝖[ _≡ᵣₘ_ ]-[ congruence₂ₗ(_∘_)(_) (transport-of-transitivity catᵣ {ab = fe₁}{bc = fe₂}) ]
    (transport catᵣ (fe₂{y}) ∘ transport catᵣ (fe₁{y})) ∘ map(f)         🝖[ _≡ᵣₘ_ ]-[ Morphism.associativity(_∘_) ]
    transport catᵣ (fe₂{y}) ∘ (transport catᵣ (fe₁{y}) ∘ map(f))         🝖[ _≡ᵣₘ_ ]-[ congruence₂ᵣ(_∘_)(_) me₁ ]
    transport catᵣ (fe₂{y}) ∘ (map(f) ∘ transport catᵣ (fe₁{x}))         🝖[ _≡ᵣₘ_ ]-[ Morphism.associativity(_∘_) ]-sym
    (transport catᵣ (fe₂{y}) ∘ map(f)) ∘ transport catᵣ (fe₁{x})         🝖[ _≡ᵣₘ_ ]-[ congruence₂ₗ(_∘_)(_) me₂ ]
    (map(f) ∘ transport catᵣ (fe₂{x})) ∘ transport catᵣ (fe₁{x})         🝖[ _≡ᵣₘ_ ]-[ Morphism.associativity(_∘_) ]
    map(f) ∘ (transport catᵣ (fe₂{x}) ∘ transport catᵣ (fe₁{x}))         🝖[ _≡ᵣₘ_ ]-[ congruence₂ᵣ(_∘_)(_) (transport-of-transitivity catᵣ {ab = fe₁}{bc = fe₂}) ]-sym
    map(f) ∘ transport catᵣ (transitivity(_≡ₑ_) (fe₁{x}) (fe₂{x})) 🝖-end

instance
  [≡ᶠᵘⁿᶜᵗᵒʳ]-equivalence : Equivalence(_≡ᶠᵘⁿᶜᵗᵒʳ_)
  [≡ᶠᵘⁿᶜᵗᵒʳ]-equivalence = intro

instance
  [≡ᶠᵘⁿᶜᵗᵒʳ]-equiv : Equiv(catₗ →ᶠᵘⁿᶜᵗᵒʳ catᵣ)
  [≡ᶠᵘⁿᶜᵗᵒʳ]-equiv = intro(_≡ᶠᵘⁿᶜᵗᵒʳ_) ⦃ [≡ᶠᵘⁿᶜᵗᵒʳ]-equivalence ⦄


------------------------------------------------------------------------
-- The Agda standard library
--
-- Properties satisfied by Heyting Algebra
------------------------------------------------------------------------

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

open import Relation.Binary.Lattice

module Relation.Binary.Properties.HeytingAlgebra
  {c ℓ₁ ℓ₂} (L : HeytingAlgebra c ℓ₁ ℓ₂) where

open HeytingAlgebra L

open import Algebra.FunctionProperties _≈_
open import Data.Product using (_,_)
open import Function using (_$_; flip; _∘_)
open import Level using (_⊔_)
open import Relation.Binary
import Relation.Binary.Reasoning.PartialOrder as POR
open import Relation.Binary.Properties.MeetSemilattice meetSemilattice
open import Relation.Binary.Properties.JoinSemilattice joinSemilattice
import Relation.Binary.Properties.BoundedMeetSemilattice boundedMeetSemilattice as BM
open import Relation.Binary.Properties.Lattice lattice
open import Relation.Binary.Properties.BoundedLattice boundedLattice
import Relation.Binary.Reasoning.Setoid as EqReasoning

------------------------------------------------------------------------
-- Useful lemmas

⇨-eval : ∀ {x y} → (x ⇨ y) ∧ x ≤ y
⇨-eval {x} {y} = transpose-∧ refl

swap-transpose-⇨ : ∀ {x y w} → x ∧ w ≤ y → w ≤ x ⇨ y
swap-transpose-⇨ x∧w≤y = transpose-⇨ $ trans (reflexive $ ∧-comm _ _) x∧w≤y

------------------------------------------------------------------------
-- Properties of exponential

⇨-unit : ∀ {x} → x ⇨ x ≈ ⊤
⇨-unit = antisym (maximum _) (transpose-⇨ $ reflexive $ BM.identityˡ _)

y≤x⇨y : ∀ {x y} → y ≤ x ⇨ y
y≤x⇨y = transpose-⇨ (x∧y≤x _ _)

⇨-drop : ∀ {x y} → (x ⇨ y) ∧ y ≈ y
⇨-drop = antisym (x∧y≤y _ _) (∧-greatest y≤x⇨y refl)

⇨-app : ∀ {x y} → (x ⇨ y) ∧ x ≈ y ∧ x
⇨-app = antisym (∧-greatest ⇨-eval (x∧y≤y _ _)) (∧-monotonic y≤x⇨y refl)

⇨ʳ-covariant : ∀ {x} → (x ⇨_) Preserves _≤_ ⟶ _≤_
⇨ʳ-covariant y≤z = transpose-⇨ (trans ⇨-eval y≤z)

⇨ˡ-contravariant : ∀ {x} → (_⇨ x) Preserves (flip _≤_) ⟶ _≤_
⇨ˡ-contravariant z≤y = transpose-⇨ (trans (∧-monotonic refl z≤y) ⇨-eval)

⇨-relax : _⇨_ Preserves₂ (flip _≤_) ⟶ _≤_ ⟶ _≤_
⇨-relax {x} {y} {u} {v} y≤x u≤v = begin
  x ⇨ u ≤⟨ ⇨ʳ-covariant u≤v ⟩
  x ⇨ v ≤⟨ ⇨ˡ-contravariant y≤x ⟩
  y ⇨ v ∎
  where open POR poset

⇨-cong : _⇨_ Preserves₂ _≈_ ⟶ _≈_ ⟶ _≈_
⇨-cong x≈y u≈v = antisym (⇨-relax (reflexive $ Eq.sym x≈y) (reflexive u≈v))
                         (⇨-relax (reflexive x≈y) (reflexive $ Eq.sym u≈v))

⇨-applyˡ : ∀ {w x y} → w ≤ x → (x ⇨ y) ∧ w ≤ y
⇨-applyˡ = transpose-∧ ∘ ⇨ˡ-contravariant

⇨-applyʳ : ∀ {w x y} → w ≤ x → w ∧ (x ⇨ y) ≤ y
⇨-applyʳ w≤x = trans (reflexive (∧-comm _ _)) (⇨-applyˡ w≤x)

⇨-curry : ∀ {x y z} → x ∧ y ⇨ z ≈ x ⇨ y ⇨ z
⇨-curry = antisym (transpose-⇨ $ transpose-⇨ $ trans (reflexive $ ∧-assoc _ _ _) ⇨-eval)
                  (transpose-⇨ $ trans (reflexive $ Eq.sym $ ∧-assoc _ _ _)
                                       (transpose-∧ $ ⇨-applyˡ refl))

------------------------------------------------------------------------
-- Various proofs of distributivity

∧-distribˡ-∨-≤ : ∀ x y z → x ∧ (y ∨ z) ≤ x ∧ y ∨ x ∧ z
∧-distribˡ-∨-≤ x y z = trans (reflexive $ ∧-comm _ _)
  (transpose-∧ $ ∨-least (swap-transpose-⇨ (x≤x∨y _ _)) $ swap-transpose-⇨ (y≤x∨y _ _))

∧-distribˡ-∨-≥ : ∀ x y z → x ∧ y ∨ x ∧ z ≤ x ∧ (y ∨ z)
∧-distribˡ-∨-≥ x y z = let
    x∧y≤x , x∧y≤y , _ = infimum x y
    x∧z≤x , x∧z≤z , _ = infimum x z
    y≤y∨z , z≤y∨z , _ = supremum y z
  in ∧-greatest (∨-least x∧y≤x x∧z≤x)
                (∨-least (trans x∧y≤y y≤y∨z) (trans x∧z≤z z≤y∨z))

∧-distribˡ-∨ : _∧_ DistributesOverˡ _∨_
∧-distribˡ-∨ x y z = antisym (∧-distribˡ-∨-≤ x y z) (∧-distribˡ-∨-≥ x y z)

⇨-distribˡ-∧-≤ : ∀ x y z → x ⇨ y ∧ z ≤ (x ⇨ y) ∧ (x ⇨ z)
⇨-distribˡ-∧-≤ x y z = let
     y∧z≤y , y∧z≤z , _ = infimum y z
   in ∧-greatest (transpose-⇨ $ trans ⇨-eval y∧z≤y)
                 (transpose-⇨ $ trans ⇨-eval y∧z≤z)

⇨-distribˡ-∧-≥ : ∀ x y z → (x ⇨ y) ∧ (x ⇨ z) ≤ x ⇨ y ∧ z
⇨-distribˡ-∧-≥ x y z = transpose-⇨ (begin
  (((x ⇨ y) ∧ (x ⇨ z)) ∧ x)      ≈⟨ ∧-cong Eq.refl $ Eq.sym $ ∧-idempotent _ ⟩
  (((x ⇨ y) ∧ (x ⇨ z)) ∧ x  ∧ x) ≈⟨ Eq.sym $ ∧-assoc _ _ _ ⟩
  (((x ⇨ y) ∧ (x ⇨ z)) ∧ x) ∧ x  ≈⟨ ∧-cong (∧-assoc _ _ _) Eq.refl ⟩
  (((x ⇨ y) ∧ (x ⇨ z)  ∧ x) ∧ x) ≈⟨ ∧-cong (∧-cong Eq.refl $ ∧-comm _ _) Eq.refl ⟩
  (((x ⇨ y) ∧ x  ∧ (x ⇨ z)) ∧ x) ≈⟨ ∧-cong (Eq.sym $ ∧-assoc _ _ _) Eq.refl ⟩
  (((x ⇨ y) ∧ x) ∧ (x ⇨ z)) ∧ x  ≈⟨ ∧-assoc _ _ _ ⟩
  (((x ⇨ y) ∧ x) ∧ (x ⇨ z)  ∧ x) ≤⟨ ∧-monotonic ⇨-eval ⇨-eval ⟩
  y ∧ z                          ∎)
  where open POR poset

⇨-distribˡ-∧ : _⇨_ DistributesOverˡ _∧_
⇨-distribˡ-∧ x y z = antisym (⇨-distribˡ-∧-≤ x y z) (⇨-distribˡ-∧-≥ x y z)

⇨-distribˡ-∨-∧-≤ : ∀ x y z → x ∨ y ⇨ z ≤ (x ⇨ z) ∧ (y ⇨ z)
⇨-distribˡ-∨-∧-≤ x y z = let x≤x∨y , y≤x∨y , _ = supremum x y
   in ∧-greatest (transpose-⇨ $ trans (∧-monotonic refl x≤x∨y) ⇨-eval)
                 (transpose-⇨ $ trans (∧-monotonic refl y≤x∨y) ⇨-eval)

⇨-distribˡ-∨-∧-≥ : ∀ x y z → (x ⇨ z) ∧ (y ⇨ z) ≤ x ∨ y ⇨ z
⇨-distribˡ-∨-∧-≥ x y z = transpose-⇨ (trans (reflexive $ ∧-distribˡ-∨ _ _ _)
  (∨-least (trans (transpose-∧ (x∧y≤x _ _)) refl)
           (trans (transpose-∧ (x∧y≤y _ _)) refl)))

⇨-distribˡ-∨-∧ : ∀ x y z → x ∨ y ⇨ z ≈ (x ⇨ z) ∧ (y ⇨ z)
⇨-distribˡ-∨-∧ x y z = antisym (⇨-distribˡ-∨-∧-≤ x y z) (⇨-distribˡ-∨-∧-≥ x y z)

------------------------------------------------------------------------
-- Heyting algebras are distributive lattices

isDistributiveLattice : IsDistributiveLattice _≈_ _≤_ _∨_ _∧_
isDistributiveLattice = record
  { isLattice    = isLattice
  ; ∧-distribˡ-∨ = ∧-distribˡ-∨
  }

distributiveLattice : DistributiveLattice _ _ _
distributiveLattice = record
  { isDistributiveLattice = isDistributiveLattice
  }

------------------------------------------------------------------------
-- Heyting algebras can define pseudo-complement

infix 8 ¬_

¬_ : Op₁ Carrier
¬ x = x ⇨ ⊥

x≤¬¬x : ∀ x → x ≤ ¬ ¬ x
x≤¬¬x x = transpose-⇨ (trans (reflexive (∧-comm _ _)) ⇨-eval)

------------------------------------------------------------------------
-- De-Morgan laws

de-morgan₁ : ∀ x y → ¬ (x ∨ y) ≈ ¬ x ∧ ¬ y
de-morgan₁ x y = ⇨-distribˡ-∨-∧ _ _ _

de-morgan₂-≤ : ∀ x y → ¬ (x ∧ y) ≤ ¬ ¬ (¬ x ∨ ¬ y)
de-morgan₂-≤ x y = transpose-⇨ $ begin
  ¬ (x ∧ y) ∧ ¬ (¬ x ∨ ¬ y)     ≈⟨ ∧-cong ⇨-curry (de-morgan₁ _ _) ⟩
  (x ⇨ ¬ y) ∧ ¬ ¬ x ∧ ¬ ¬ y     ≈⟨ ∧-cong Eq.refl (∧-comm _ _) ⟩
  (x ⇨ ¬ y) ∧ ¬ ¬ y ∧ ¬ ¬ x     ≈⟨ Eq.sym $ ∧-assoc _ _ _ ⟩
  ((x ⇨ ¬ y) ∧ ¬ ¬ y) ∧ ¬ ¬ x   ≤⟨ ⇨-applyʳ $ transpose-⇨ $
    begin
      ((x ⇨ ¬ y) ∧ ¬ ¬ y) ∧ x   ≈⟨ ∧-cong (∧-comm _ _) Eq.refl ⟩
      ((¬ ¬ y) ∧ (x ⇨ ¬ y)) ∧ x ≈⟨ ∧-assoc _ _ _ ⟩
      (¬ ¬ y) ∧ (x ⇨ ¬ y) ∧ x   ≤⟨ ∧-monotonic refl ⇨-eval ⟩
      ¬ ¬ y ∧ ¬ y               ≤⟨ ⇨-eval ⟩
      ⊥                         ∎ ⟩
  ⊥                             ∎
  where open POR poset

de-morgan₂-≥ : ∀ x y → ¬ ¬ (¬ x ∨ ¬ y) ≤ ¬ (x ∧ y)
de-morgan₂-≥ x y = transpose-⇨ $ ⇨-applyˡ $ transpose-⇨ $ begin
  (x ∧ y) ∧ (¬ x ∨ ¬ y)         ≈⟨ ∧-distribˡ-∨ _ _ _ ⟩
  (x ∧ y) ∧ ¬ x ∨ (x ∧ y) ∧ ¬ y ≤⟨ ∨-monotonic (⇨-applyʳ (x∧y≤x _ _))
                                               (⇨-applyʳ (x∧y≤y _ _)) ⟩
  ⊥ ∨ ⊥                         ≈⟨ ∨-idempotent _ ⟩
  ⊥                             ∎
  where open POR poset

de-morgan₂ : ∀ x y → ¬ (x ∧ y) ≈ ¬ ¬ (¬ x ∨ ¬ y)
de-morgan₂ x y = antisym (de-morgan₂-≤ x y) (de-morgan₂-≥ x y)

weak-lem : ∀ {x} → ¬ ¬ (¬ x ∨ x) ≈ ⊤
weak-lem {x} = begin
  ¬ ¬ (¬ x ∨ x)   ≈⟨ ⇨-cong (de-morgan₁ _ _) Eq.refl ⟩
  ¬ (¬ ¬ x ∧ ¬ x) ≈⟨ ⇨-cong ⇨-app Eq.refl ⟩
  ⊥ ∧ (x ⇨ ⊥) ⇨ ⊥ ≈⟨ ⇨-cong (∧-zeroˡ _) Eq.refl ⟩
  ⊥ ⇨ ⊥           ≈⟨ ⇨-unit ⟩
  ⊤               ∎
  where open EqReasoning setoid


{-# OPTIONS --copatterns #-}

-- One-place functors (decorations) on Set

module Control.Auto-Bug-in-Goal-2 where

open import Function using (id)
open import Relation.Binary.PropositionalEquality
open ≡-Reasoning

open import Control.Functor

record IsDecoration (D : Set → Set) : Set₁ where
  field
    traverse : ∀ {F} {{ functor : IsFunctor F }} {A B} → (A → F B) → D A → F (D B)
    traverse-id : ∀ {A} → traverse {F = λ A → A} {A = A} id ≡ id

  isFunctor : IsFunctor D
  isFunctor = record
    { ops  = record { map = traverse }
    ; laws = record { map-id = traverse-id ; map-∘ = {!!} } }

open IsDecoration

idIsDecoration : IsDecoration (λ A → A)
traverse idIsDecoration f = f
traverse-id idIsDecoration = {!!}

compIsDecoration : ∀ {D E} → IsDecoration D → IsDecoration E → IsDecoration (λ A → D (E A))
traverse (compIsDecoration d e) f = traverse d (traverse e f)
traverse-id (compIsDecoration d e) = {!!}


{-# OPTIONS --safe --no-qualified-instances #-}
module JVM.Syntax.Instructions where

open import Level
open import Data.Unit
open import Data.Product hiding (swap)
open import Data.String using (String)
open import Data.List
open import Data.List.Membership.Propositional using () renaming (_∈_ to Reg)

open import JVM.Types
open import JVM.Syntax.Values
open import JVM.Model StackTy

open import Relation.Unary hiding (_∈_)
open import Relation.Ternary.Core
open import Relation.Ternary.Structures
open import Relation.Ternary.Structures.Syntax
open import Relation.Ternary.Monad.Weakening

data NativeBinOp : Ty → Ty → Ty → Set where
  add sub mul div xor : NativeBinOp int int int

data Comparator : List Ty → Set where
  eq ne lt ge gt le : {{IsIntegral a}} → Comparator [ a ]
  icmpge icmpgt icmpeq icmpne icmplt icmple : Comparator (int ∷ [ int ])

{- Instructions -}
module _ (𝑭 : FrameTy) where

  open import Data.List.Membership.Propositional

  𝑹[_] : Ty → Set
  𝑹[ a ] = a ∈ 𝑭

  -- True to bytecode, the collection of registers is fixed.
  -- The stack typing varies.
  data ⟨_↝_⟩ : StackTy → StackTy → Pred Labels 0ℓ where

    noop : ε[ ⟨ ψ ↝ ψ ⟩ ]

    -- stack manipulation
    pop  :           ε[ ⟨ a ∷ ψ      ↝  ψ     ⟩ ]
    push : Const a → ε[ ⟨ ψ          ↝  a ∷ ψ ⟩ ]
    dup  : ε[ ⟨ a ∷ ψ      ↝  a ∷ a ∷ ψ ⟩ ]
    swap : ε[ ⟨ a ∷ b ∷ ψ  ↝  b ∷ a ∷ ψ ⟩ ]

    -- binary operations on primitive types
    bop   : NativeBinOp a b c → ε[ ⟨ b ∷ a ∷ ψ  ↝  c ∷ ψ ⟩ ]

    -- register manipulation
    load  : 𝑹[ a ] → ε[ ⟨ ψ ↝ a ∷ ψ ⟩ ]
    store : 𝑹[ a ] → ε[ ⟨ a ∷ ψ ↝ ψ ⟩ ]

    -- jumps
    goto  : ∀[ One ψ₁ ⇒ ⟨ ψ₁ ↝ ψ₂ ⟩ ]
    if    : ∀ {as} → Comparator as → ∀[ One ψ ⇒ ⟨ as ++ ψ ↝ ψ ⟩ ]

  ⟨_∣_↝_⟩ = ⟨_↝_⟩
  Instr = ⟨_↝_⟩

  open import JVM.Syntax.Bytecode StackTy ⟨_↝_⟩ as BC
  open BC using (Code) public

  ⟪_∣_↜_⟫   = ⟪_↜_⟫
  ⟪_∣_↝_⟫   = ⟪_↝_⟫
  ⟪_∣_↝_⟫+  = ⟪_↝_⟫+

module _ {𝑭} where
  open import JVM.Syntax.Bytecode StackTy ⟨ 𝑭 ∣_↝_⟩
    hiding (⟪_↜_⟫; ⟪_↝_⟫; ⟪_↝_⟫+; Code) public


module Thesis.LangChanges where

open import Thesis.Changes
open import Thesis.IntChanges
open import Thesis.Types
open import Thesis.Contexts
open import Thesis.Environments
open import Relation.Binary.PropositionalEquality

Chτ : (τ : Type) → Set
Chτ τ = ⟦ Δt τ ⟧Type

ΔΓ : Context → Context
ΔΓ ∅ = ∅
ΔΓ (τ • Γ) = Δt τ • τ • ΔΓ Γ

ChΓ : ∀ (Γ : Context) → Set
ChΓ Γ = ⟦ ΔΓ Γ ⟧Context

[_]τ_from_to_ : ∀ (τ : Type) → (dv : Chτ τ) → (v1 v2 : ⟦ τ ⟧Type) → Set

isCompChangeStructureτ : ∀ τ → IsCompChangeStructure ⟦ τ ⟧Type ⟦ Δt τ ⟧Type [ τ ]τ_from_to_

changeStructureτ : ∀ τ → ChangeStructure ⟦ τ ⟧Type
changeStructureτ τ = record { isCompChangeStructure = isCompChangeStructureτ τ }

instance
  ichangeStructureτ : ∀ {τ} → ChangeStructure ⟦ τ ⟧Type
  ichangeStructureτ {τ} = changeStructureτ τ

[ σ ⇒ τ ]τ df from f1 to f2 =
  ∀ (da : Chτ σ) (a1 a2 : ⟦ σ ⟧Type) →
  [ σ ]τ da from a1 to a2 → [ τ ]τ df a1 da from f1 a1 to f2 a2
[ unit ]τ tt from tt to tt = ⊤
[ int ]τ dv from v1 to v2 = v1 + dv ≡ v2
[ pair σ τ ]τ (da , db) from (a1 , b1) to (a2 , b2) = [ σ ]τ da from a1 to a2 × [ τ ]τ db from b1 to b2
[ sum σ τ ]τ dv from v1 to v2 = sch_from_to_ dv v1 v2

isCompChangeStructureτ (σ ⇒ τ) = ChangeStructure.isCompChangeStructure (funCS {{changeStructureτ σ}} {{changeStructureτ τ}})
isCompChangeStructureτ unit = ChangeStructure.isCompChangeStructure unitCS
isCompChangeStructureτ int = ChangeStructure.isCompChangeStructure intCS
isCompChangeStructureτ (pair σ τ) = ChangeStructure.isCompChangeStructure (pairCS {{changeStructureτ σ}} {{changeStructureτ τ}})
isCompChangeStructureτ (sum σ τ) = ChangeStructure.isCompChangeStructure (sumCS {{changeStructureτ σ}} {{changeStructureτ τ}})

open import Data.Unit
-- We can define an alternative semantics for contexts, that defines environments as nested products:
⟦_⟧Context-prod : Context → Set
⟦ ∅ ⟧Context-prod = ⊤
⟦ τ • Γ ⟧Context-prod = ⟦ τ ⟧Type × ⟦ Γ ⟧Context-prod

-- And define a change structure for such environments, reusing the change
-- structure constructor for pairs. However, this change structure does not
-- duplicate base values in the environment. We probably *could* define a
-- different change structure for pairs that gives the right result.
changeStructureΓ-old : ∀ Γ → ChangeStructure ⟦ Γ ⟧Context-prod
changeStructureΓ-old ∅ = unitCS
changeStructureΓ-old (τ • Γ) = pairCS {{changeStructureτ τ}}  {{changeStructureΓ-old Γ}}

data [_]Γ_from_to_ : ∀ Γ → ChΓ Γ → (ρ1 ρ2 : ⟦ Γ ⟧Context) → Set where
  v∅ : [ ∅ ]Γ ∅ from ∅ to ∅
  _v•_ : ∀ {τ Γ dv v1 v2 dρ ρ1 ρ2} →
    (dvv : [ τ ]τ dv from v1 to v2) →
    (dρρ : [ Γ ]Γ dρ from ρ1 to ρ2) →
    [ τ • Γ ]Γ (dv • v1 • dρ) from (v1 • ρ1) to (v2 • ρ2)

module _ where
  _e⊕_ : ∀ {Γ} → ⟦ Γ ⟧Context → ChΓ Γ → ⟦ Γ ⟧Context
  _e⊕_ ∅ ∅ = ∅
  _e⊕_ (v • ρ) (dv • _ • dρ) = v ⊕ dv • ρ e⊕ dρ
  _e⊝_ : ∀ {Γ} → ⟦ Γ ⟧Context → ⟦ Γ ⟧Context → ChΓ Γ
  _e⊝_ ∅ ∅ = ∅
  _e⊝_ (v₂ • ρ₂) (v₁ • ρ₁) = v₂ ⊝ v₁ • v₁ • ρ₂ e⊝ ρ₁

  isEnvCompCS : ∀ Γ → IsCompChangeStructure ⟦ Γ ⟧Context (ChΓ Γ) [ Γ ]Γ_from_to_

  efromto→⊕ : ∀ {Γ} (dρ : ChΓ Γ) (ρ1 ρ2 : ⟦ Γ ⟧Context) →
      [ Γ ]Γ dρ from ρ1 to ρ2 → (ρ1 e⊕ dρ) ≡ ρ2
  efromto→⊕ .∅ .∅ .∅ v∅ = refl
  efromto→⊕ .(_ • _ • _) .(_ • _) .(_ • _) (dvv v• dρρ) =
    cong₂ _•_ (fromto→⊕ _ _ _ dvv) (efromto→⊕ _ _ _ dρρ)

  e⊝-fromto : ∀ {Γ} → (ρ1 ρ2 : ⟦ Γ ⟧Context) → [ Γ ]Γ ρ2 e⊝ ρ1 from ρ1 to ρ2
  e⊝-fromto ∅ ∅ = v∅
  e⊝-fromto (v1 • ρ1) (v2 • ρ2) = ⊝-fromto v1 v2 v• e⊝-fromto ρ1 ρ2

  _e⊚_ : ∀ {Γ} → ChΓ Γ → ChΓ Γ → ChΓ Γ
  _e⊚_ {∅} ∅ ∅ = ∅
  _e⊚_ {τ • Γ} (dv1 • v1 • dρ1) (dv2 • _ • dρ2) = dv1 ⊚[ ⟦ τ ⟧Type ] dv2 • v1 • dρ1 e⊚ dρ2

  e⊚-fromto : ∀ Γ → (ρ1 ρ2 ρ3 : ⟦ Γ ⟧Context) (dρ1 dρ2 : ChΓ Γ) →
    [ Γ ]Γ dρ1 from ρ1 to ρ2 →
    [ Γ ]Γ dρ2 from ρ2 to ρ3 → [ Γ ]Γ (dρ1 e⊚ dρ2) from ρ1 to ρ3
  e⊚-fromto ∅ ∅ ∅ ∅ ∅ ∅ v∅ v∅ = v∅
  e⊚-fromto (τ • Γ) (v1 • ρ1) (v2 • ρ2) (v3 • ρ3)
    (dv1 • (.v1 • dρ1)) (dv2 • (.v2 • dρ2))
    (dvv1 v• dρρ1) (dvv2 v• dρρ2) =
        ⊚-fromto v1 v2 v3 dv1 dv2 dvv1 dvv2
      v•
        e⊚-fromto Γ ρ1 ρ2 ρ3 dρ1 dρ2 dρρ1 dρρ2

  isEnvCompCS Γ = record
    { isChangeStructure = record
      { _⊕_ = _e⊕_
      ; fromto→⊕ = efromto→⊕
      ; _⊝_ = _e⊝_
      ; ⊝-fromto = e⊝-fromto
      }
    ; _⊚_ = _e⊚_
    ; ⊚-fromto = e⊚-fromto Γ
    }

changeStructureΓ : ∀ Γ → ChangeStructure ⟦ Γ ⟧Context
changeStructureΓ Γ = record { isCompChangeStructure = isEnvCompCS Γ }

instance
  ichangeStructureΓ : ∀ {Γ} → ChangeStructure ⟦ Γ ⟧Context
  ichangeStructureΓ {Γ} = changeStructureΓ Γ

changeStructureΓτ : ∀ Γ τ → ChangeStructure (⟦ Γ ⟧Context → ⟦ τ ⟧Type)
changeStructureΓτ Γ τ = funCS

instance
  ichangeStructureΓτ : ∀ {Γ τ} → ChangeStructure (⟦ Γ ⟧Context → ⟦ τ ⟧Type)
  ichangeStructureΓτ {Γ} {τ} = changeStructureΓτ Γ τ


{-# OPTIONS --cubical --no-import-sorts --allow-unsolved-metas #-}

module Number.Instances.QuoQ.Definitions where

open import Agda.Primitive renaming (_⊔_ to ℓ-max; lsuc to ℓ-suc; lzero to ℓ-zero)
open import Cubical.Foundations.Everything renaming (_⁻¹ to _⁻¹ᵖ; assoc to ∙-assoc)
open import Cubical.Foundations.Logic renaming (inl to inlᵖ; inr to inrᵖ)

open import Cubical.Relation.Nullary.Base renaming (¬_ to ¬ᵗ_)
open import Cubical.Relation.Binary.Base
open import Cubical.Data.Sum.Base renaming (_⊎_ to infixr 4 _⊎_)
open import Cubical.Data.Sigma.Base renaming (_×_ to infixr 4 _×_)
open import Cubical.Data.Sigma
open import Cubical.Data.Bool as Bool using (Bool; not; true; false)
open import Cubical.Data.Empty renaming (elim to ⊥-elim; ⊥ to ⊥⊥) -- `⊥` and `elim`
open import Cubical.Foundations.Logic renaming (¬_ to ¬ᵖ_; inl to inlᵖ; inr to inrᵖ)
open import Function.Base using (it; _∋_; _$_)
open import Cubical.Foundations.Isomorphism

open import Cubical.HITs.PropositionalTruncation --.Properties

open import Utils using (!_; !!_)
open import MoreLogic.Reasoning
open import MoreLogic.Definitions
open import MoreLogic.Properties
open import MorePropAlgebra.Definitions hiding (_≤''_)
open import MorePropAlgebra.Structures
open import MorePropAlgebra.Bundles
open import MorePropAlgebra.Consequences
open import Number.Structures2
open import Number.Bundles2

open import Cubical.Data.NatPlusOne using (HasFromNat; 1+_; ℕ₊₁; ℕ₊₁→ℕ)
open import Cubical.HITs.SetQuotients as SetQuotient using () renaming (_/_ to _//_)

open import Cubical.Data.Nat.Literals
open import Cubical.Data.Bool
open import Number.Prelude.Nat
open import Number.Prelude.QuoInt
open import Cubical.HITs.Ints.QuoInt using (HasFromNat)
open import Cubical.HITs.Rationals.QuoQ using
  ( ℚ
  ; onCommonDenom
  ; onCommonDenomSym
  ; eq/
  ; _//_
  ; _∼_
  )
  renaming
  ( [_] to [_]ᶠ
  ; ℕ₊₁→ℤ to [1+_ⁿ]ᶻ
  )

abstract
  private
    lemma1 : ∀ a b₁ b₂ c → (a ·ᶻ b₁) ·ᶻ (b₂ ·ᶻ c) ≡ (a ·ᶻ c) ·ᶻ (b₂ ·ᶻ b₁)
    lemma1 a b₁ b₂ c =
      (a ·ᶻ b₁) ·ᶻ (b₂ ·ᶻ c) ≡⟨ sym $ ·ᶻ-assoc a b₁ (b₂ ·ᶻ c) ⟩
      a ·ᶻ (b₁ ·ᶻ (b₂ ·ᶻ c)) ≡⟨ (λ i → a ·ᶻ ·ᶻ-assoc b₁ b₂ c i) ⟩
      a ·ᶻ ((b₁ ·ᶻ b₂) ·ᶻ c) ≡⟨ (λ i → a ·ᶻ ·ᶻ-comm (b₁ ·ᶻ b₂) c i) ⟩
      a ·ᶻ (c ·ᶻ (b₁ ·ᶻ b₂)) ≡⟨ ·ᶻ-assoc a c (b₁ ·ᶻ b₂) ⟩
      (a ·ᶻ c) ·ᶻ (b₁ ·ᶻ b₂) ≡⟨ (λ i → (a ·ᶻ c) ·ᶻ ·ᶻ-comm b₁ b₂ i) ⟩
      (a ·ᶻ c) ·ᶻ (b₂ ·ᶻ b₁) ∎

    ·ᶻ-commʳ : ∀ a b c → (a ·ᶻ b) ·ᶻ c ≡ (a ·ᶻ c) ·ᶻ b
    ·ᶻ-commʳ a b c = (a ·ᶻ  b) ·ᶻ c  ≡⟨ sym $ ·ᶻ-assoc a b c ⟩
                      a ·ᶻ (b  ·ᶻ c) ≡⟨ (λ i → a ·ᶻ ·ᶻ-comm b c i) ⟩
                      a ·ᶻ (c  ·ᶻ b) ≡⟨ ·ᶻ-assoc a c b ⟩
                     (a ·ᶻ  c) ·ᶻ b  ∎

∼-preserves-<ᶻ : ∀ aᶻ aⁿ bᶻ bⁿ → (aᶻ , aⁿ) ∼ (bᶻ , bⁿ) → [ ((aᶻ <ᶻ 0) ⇒ (bᶻ <ᶻ 0)) ⊓ ((0 <ᶻ aᶻ) ⇒ (0 <ᶻ bᶻ)) ]
∼-preserves-<ᶻ aᶻ aⁿ bᶻ bⁿ r = γ where
  aⁿᶻ = [1+ aⁿ ⁿ]ᶻ
  bⁿᶻ = [1+ bⁿ ⁿ]ᶻ
  0<aⁿᶻ : [ 0 <ᶻ aⁿᶻ ]
  0<aⁿᶻ = ℕ₊₁.n aⁿ , +ⁿ-comm (ℕ₊₁.n aⁿ) 1
  0<bⁿᶻ : [ 0 <ᶻ bⁿᶻ ]
  0<bⁿᶻ = ℕ₊₁.n bⁿ , +ⁿ-comm (ℕ₊₁.n bⁿ) 1
  γ : [ ((aᶻ <ᶻ 0) ⇒ (bᶻ <ᶻ 0)) ⊓ ((0 <ᶻ aᶻ) ⇒ (0 <ᶻ bᶻ)) ]
  γ .fst aᶻ<0 = (
    aᶻ <ᶻ 0               ⇒ᵖ⟨ ·ᶻ-preserves-<ᶻ aᶻ 0 bⁿᶻ 0<bⁿᶻ ⟩
    aᶻ ·ᶻ bⁿᶻ <ᶻ 0 ·ᶻ bⁿᶻ ⇒ᵖ⟨ (subst (λ p → [ aᶻ ·ᶻ bⁿᶻ <ᶻ p ]) $ ·ᶻ-nullifiesˡ bⁿᶻ) ⟩
    aᶻ ·ᶻ bⁿᶻ <ᶻ 0        ⇒ᵖ⟨ subst (λ p → [ p <ᶻ 0 ]) r ⟩
    bᶻ ·ᶻ aⁿᶻ <ᶻ 0        ⇒ᵖ⟨ subst (λ p → [ bᶻ ·ᶻ aⁿᶻ <ᶻ p ]) (sym (·ᶻ-nullifiesˡ aⁿᶻ)) ⟩
    bᶻ ·ᶻ aⁿᶻ <ᶻ 0 ·ᶻ aⁿᶻ ⇒ᵖ⟨ ·ᶻ-reflects-<ᶻ bᶻ 0 aⁿᶻ 0<aⁿᶻ ⟩
    bᶻ        <ᶻ 0        ◼ᵖ) .snd aᶻ<0
  γ .snd 0<aᶻ = (
    0        <ᶻ aᶻ        ⇒ᵖ⟨ ·ᶻ-preserves-<ᶻ 0 aᶻ bⁿᶻ 0<bⁿᶻ ⟩
    0 ·ᶻ bⁿᶻ <ᶻ aᶻ ·ᶻ bⁿᶻ ⇒ᵖ⟨ (subst (λ p → [ p <ᶻ aᶻ ·ᶻ bⁿᶻ ]) $ ·ᶻ-nullifiesˡ bⁿᶻ) ⟩
    0        <ᶻ aᶻ ·ᶻ bⁿᶻ ⇒ᵖ⟨ subst (λ p → [ 0 <ᶻ p ]) r ⟩
    0        <ᶻ bᶻ ·ᶻ aⁿᶻ ⇒ᵖ⟨ subst (λ p → [ p <ᶻ bᶻ ·ᶻ aⁿᶻ ]) (sym (·ᶻ-nullifiesˡ aⁿᶻ)) ⟩
    0 ·ᶻ aⁿᶻ <ᶻ bᶻ ·ᶻ aⁿᶻ ⇒ᵖ⟨ ·ᶻ-reflects-<ᶻ 0 bᶻ aⁿᶻ 0<aⁿᶻ ⟩
    0        <ᶻ bᶻ        ◼ᵖ) .snd 0<aᶻ

-- < on ℤ × ℕ₊₁ in terms of < on ℤ
_<'_ : ℤ × ℕ₊₁ → ℤ × ℕ₊₁ → hProp ℓ-zero
(aᶻ , aⁿ) <' (bᶻ , bⁿ) =
  let aⁿᶻ = [1+ aⁿ ⁿ]ᶻ
      bⁿᶻ = [1+ bⁿ ⁿ]ᶻ
  in (aᶻ ·ᶻ bⁿᶻ) <ᶻ (bᶻ ·ᶻ aⁿᶻ)

private
  lem1 : ∀ x y z → [ 0 <ᶻ y ] → [ 0 <ᶻ z ] → (0 <ᶻ (x ·ᶻ y)) ≡ (0 <ᶻ (x ·ᶻ z))
  lem1 x y z p q =
     0       <ᶻ (x ·ᶻ y) ≡⟨ (λ i → ·ᶻ-nullifiesˡ y (~ i) <ᶻ x ·ᶻ y) ⟩
    (0 ·ᶻ y) <ᶻ (x ·ᶻ y) ≡⟨ sym $ ·ᶻ-creates-<ᶻ-≡ 0 x y p ⟩
     0       <ᶻ  x       ≡⟨ ·ᶻ-creates-<ᶻ-≡ 0 x z q ⟩
    (0 ·ᶻ z) <ᶻ (x ·ᶻ z) ≡⟨ (λ i → ·ᶻ-nullifiesˡ z i <ᶻ x ·ᶻ z) ⟩
     0       <ᶻ (x ·ᶻ z) ∎

<'-respects-∼ˡ : ∀ a b x → a ∼ b → a <' x ≡ b <' x
<'-respects-∼ˡ a@(aᶻ , aⁿ) b@(bᶻ , bⁿ) x@(xᶻ , xⁿ) a~b = γ where
  aⁿᶻ = [1+ aⁿ ⁿ]ᶻ; 0<aⁿᶻ : [ 0 <ᶻ aⁿᶻ ]; 0<aⁿᶻ = 0<ᶻpos[suc] _
  bⁿᶻ = [1+ bⁿ ⁿ]ᶻ; 0<bⁿᶻ : [ 0 <ᶻ bⁿᶻ ]; 0<bⁿᶻ = 0<ᶻpos[suc] _
  xⁿᶻ = [1+ xⁿ ⁿ]ᶻ
  p : aᶻ ·ᶻ bⁿᶻ ≡ bᶻ ·ᶻ aⁿᶻ
  p = a~b
  γ : ((aᶻ ·ᶻ xⁿᶻ) <ᶻ (xᶻ ·ᶻ aⁿᶻ)) ≡ ((bᶻ ·ᶻ xⁿᶻ) <ᶻ (xᶻ ·ᶻ bⁿᶻ))
  γ = aᶻ ·ᶻ xⁿᶻ        <ᶻ xᶻ ·ᶻ aⁿᶻ        ≡⟨ ·ᶻ-creates-<ᶻ-≡ (aᶻ ·ᶻ xⁿᶻ) (xᶻ ·ᶻ aⁿᶻ) bⁿᶻ 0<bⁿᶻ ⟩
      aᶻ ·ᶻ xⁿᶻ ·ᶻ bⁿᶻ <ᶻ xᶻ ·ᶻ aⁿᶻ ·ᶻ bⁿᶻ ≡⟨ (λ i → ·ᶻ-commʳ aᶻ xⁿᶻ bⁿᶻ i <ᶻ xᶻ ·ᶻ aⁿᶻ ·ᶻ bⁿᶻ) ⟩
      aᶻ ·ᶻ bⁿᶻ ·ᶻ xⁿᶻ <ᶻ xᶻ ·ᶻ aⁿᶻ ·ᶻ bⁿᶻ ≡⟨ (λ i → p i ·ᶻ xⁿᶻ <ᶻ xᶻ ·ᶻ aⁿᶻ ·ᶻ bⁿᶻ) ⟩
      bᶻ ·ᶻ aⁿᶻ ·ᶻ xⁿᶻ <ᶻ xᶻ ·ᶻ aⁿᶻ ·ᶻ bⁿᶻ ≡⟨ (λ i → ·ᶻ-commʳ bᶻ aⁿᶻ xⁿᶻ i <ᶻ ·ᶻ-commʳ xᶻ aⁿᶻ bⁿᶻ i) ⟩
      bᶻ ·ᶻ xⁿᶻ ·ᶻ aⁿᶻ <ᶻ xᶻ ·ᶻ bⁿᶻ ·ᶻ aⁿᶻ ≡⟨ sym $ ·ᶻ-creates-<ᶻ-≡ (bᶻ ·ᶻ xⁿᶻ) (xᶻ ·ᶻ bⁿᶻ) aⁿᶻ 0<aⁿᶻ ⟩
      bᶻ ·ᶻ xⁿᶻ        <ᶻ xᶻ ·ᶻ bⁿᶻ        ∎

<'-respects-∼ʳ : ∀ x a b → a ∼ b → x <' a ≡ x <' b
<'-respects-∼ʳ x@(xᶻ , xⁿ) a@(aᶻ , aⁿ) b@(bᶻ , bⁿ) a~b =
  let aⁿᶻ = [1+ aⁿ ⁿ]ᶻ; 0<aⁿᶻ : [ 0 <ᶻ aⁿᶻ ]; 0<aⁿᶻ = 0<ᶻpos[suc] _
      bⁿᶻ = [1+ bⁿ ⁿ]ᶻ; 0<bⁿᶻ : [ 0 <ᶻ bⁿᶻ ]; 0<bⁿᶻ = 0<ᶻpos[suc] _
      xⁿᶻ = [1+ xⁿ ⁿ]ᶻ
      p : aᶻ ·ᶻ bⁿᶻ ≡ bᶻ ·ᶻ aⁿᶻ
      p = a~b
  in xᶻ ·ᶻ aⁿᶻ        <ᶻ aᶻ  ·ᶻ  xⁿᶻ        ≡⟨ (λ i → xᶻ ·ᶻ aⁿᶻ <ᶻ ·ᶻ-comm aᶻ xⁿᶻ i) ⟩
     xᶻ ·ᶻ aⁿᶻ        <ᶻ xⁿᶻ ·ᶻ  aᶻ         ≡⟨ ·ᶻ-creates-<ᶻ-≡ (xᶻ ·ᶻ aⁿᶻ) (xⁿᶻ ·ᶻ  aᶻ) bⁿᶻ 0<bⁿᶻ ⟩
     xᶻ ·ᶻ aⁿᶻ ·ᶻ bⁿᶻ <ᶻ xⁿᶻ ·ᶻ  aᶻ ·ᶻ bⁿᶻ  ≡⟨ (λ i → xᶻ ·ᶻ aⁿᶻ ·ᶻ bⁿᶻ <ᶻ ·ᶻ-assoc xⁿᶻ aᶻ bⁿᶻ (~ i)) ⟩
     xᶻ ·ᶻ aⁿᶻ ·ᶻ bⁿᶻ <ᶻ xⁿᶻ ·ᶻ (aᶻ ·ᶻ bⁿᶻ) ≡⟨ (λ i → xᶻ ·ᶻ aⁿᶻ ·ᶻ bⁿᶻ <ᶻ xⁿᶻ ·ᶻ (p i)) ⟩
     xᶻ ·ᶻ aⁿᶻ ·ᶻ bⁿᶻ <ᶻ xⁿᶻ ·ᶻ (bᶻ ·ᶻ aⁿᶻ) ≡⟨ (λ i → ·ᶻ-commʳ xᶻ aⁿᶻ bⁿᶻ i <ᶻ ·ᶻ-assoc xⁿᶻ bᶻ aⁿᶻ i) ⟩
     xᶻ ·ᶻ bⁿᶻ ·ᶻ aⁿᶻ <ᶻ xⁿᶻ ·ᶻ  bᶻ ·ᶻ aⁿᶻ  ≡⟨ sym $ ·ᶻ-creates-<ᶻ-≡ (xᶻ ·ᶻ bⁿᶻ) (xⁿᶻ ·ᶻ bᶻ) aⁿᶻ 0<aⁿᶻ ⟩
     xᶻ ·ᶻ bⁿᶻ        <ᶻ xⁿᶻ ·ᶻ  bᶻ         ≡⟨ (λ i → xᶻ ·ᶻ bⁿᶻ <ᶻ ·ᶻ-comm xⁿᶻ bᶻ i) ⟩
     xᶻ ·ᶻ bⁿᶻ        <ᶻ bᶻ  ·ᶻ  xⁿᶻ        ∎

infixl 4 _<_
_<_ : hPropRel ℚ ℚ ℓ-zero
a < b = SetQuotient.rec2 {R = _∼_} {B = hProp ℓ-zero} isSetHProp _<'_ <'-respects-∼ˡ <'-respects-∼ʳ a b

_≤_ : hPropRel ℚ ℚ ℓ-zero
x ≤ y = ¬ᵖ (y < x)

min' : ℤ × ℕ₊₁ → ℤ × ℕ₊₁ → ℤ
min' (aᶻ , aⁿ) (bᶻ , bⁿ) =
  let aⁿᶻ = [1+ aⁿ ⁿ]ᶻ
      bⁿᶻ = [1+ bⁿ ⁿ]ᶻ
  in minᶻ (aᶻ ·ᶻ bⁿᶻ) (bᶻ ·ᶻ aⁿᶻ)

max' : ℤ × ℕ₊₁ → ℤ × ℕ₊₁ → ℤ
max' (aᶻ , aⁿ) (bᶻ , bⁿ) =
  let aⁿᶻ = [1+ aⁿ ⁿ]ᶻ
      bⁿᶻ = [1+ bⁿ ⁿ]ᶻ
  in maxᶻ (aᶻ ·ᶻ bⁿᶻ) (bᶻ ·ᶻ aⁿᶻ)

min'-sym : ∀ x y → min' x y ≡ min' y x
min'-sym (aᶻ , aⁿ) (bᶻ , bⁿ) = minᶻ-comm (aᶻ ·ᶻ [1+ bⁿ ⁿ]ᶻ) (bᶻ ·ᶻ [1+ aⁿ ⁿ]ᶻ)

max'-sym : ∀ x y → max' x y ≡ max' y x
max'-sym (aᶻ , aⁿ) (bᶻ , bⁿ) = maxᶻ-comm (aᶻ ·ᶻ [1+ bⁿ ⁿ]ᶻ) (bᶻ ·ᶻ [1+ aⁿ ⁿ]ᶻ)

min'-respects-∼ : (a@(aᶻ , aⁿ) b@(bᶻ , bⁿ) x@(xᶻ , xⁿ) : ℤ × ℕ₊₁)
                → a ∼ b
                → [1+ bⁿ ⁿ]ᶻ ·ᶻ min' a x ≡ [1+ aⁿ ⁿ]ᶻ ·ᶻ min' b x
min'-respects-∼ a@(aᶻ , aⁿ) b@(bᶻ , bⁿ) x@(xᶻ , xⁿ) a~b =
  bⁿᶻ ·ᶻ minᶻ (aᶻ ·ᶻ xⁿᶻ) (xᶻ ·ᶻ aⁿᶻ)            ≡⟨ ·ᶻ-minᶻ-distribˡ (aᶻ ·ᶻ xⁿᶻ) (xᶻ ·ᶻ aⁿᶻ) bⁿᶻ 0≤bⁿᶻ ⟩
  minᶻ (bⁿᶻ ·ᶻ (aᶻ ·ᶻ xⁿᶻ)) (bⁿᶻ ·ᶻ (xᶻ ·ᶻ aⁿᶻ)) ≡⟨ (λ i → minᶻ (·ᶻ-assoc bⁿᶻ aᶻ xⁿᶻ i) (bⁿᶻ ·ᶻ (xᶻ ·ᶻ aⁿᶻ))) ⟩
  minᶻ ((bⁿᶻ ·ᶻ aᶻ) ·ᶻ xⁿᶻ) (bⁿᶻ ·ᶻ (xᶻ ·ᶻ aⁿᶻ)) ≡⟨ (λ i → minᶻ ((·ᶻ-comm bⁿᶻ aᶻ i) ·ᶻ xⁿᶻ) (bⁿᶻ ·ᶻ (xᶻ ·ᶻ aⁿᶻ))) ⟩
  minᶻ ((aᶻ ·ᶻ bⁿᶻ) ·ᶻ xⁿᶻ) (bⁿᶻ ·ᶻ (xᶻ ·ᶻ aⁿᶻ)) ≡⟨ (λ i → minᶻ (p i ·ᶻ xⁿᶻ) (bⁿᶻ ·ᶻ (xᶻ ·ᶻ aⁿᶻ))) ⟩
  minᶻ ((bᶻ ·ᶻ aⁿᶻ) ·ᶻ xⁿᶻ) (bⁿᶻ ·ᶻ (xᶻ ·ᶻ aⁿᶻ)) ≡⟨ (λ i → minᶻ (·ᶻ-comm bᶻ aⁿᶻ i ·ᶻ xⁿᶻ) (·ᶻ-assoc bⁿᶻ xᶻ aⁿᶻ i)) ⟩
  minᶻ ((aⁿᶻ ·ᶻ bᶻ) ·ᶻ xⁿᶻ) ((bⁿᶻ ·ᶻ xᶻ) ·ᶻ aⁿᶻ) ≡⟨ (λ i → minᶻ (·ᶻ-assoc aⁿᶻ bᶻ xⁿᶻ (~ i)) (·ᶻ-comm (bⁿᶻ ·ᶻ xᶻ) aⁿᶻ i)) ⟩
  minᶻ (aⁿᶻ ·ᶻ (bᶻ ·ᶻ xⁿᶻ)) (aⁿᶻ ·ᶻ (bⁿᶻ ·ᶻ xᶻ)) ≡⟨ sym $ ·ᶻ-minᶻ-distribˡ (bᶻ ·ᶻ xⁿᶻ) (bⁿᶻ ·ᶻ xᶻ) aⁿᶻ 0≤aⁿᶻ ⟩
  aⁿᶻ ·ᶻ minᶻ (bᶻ ·ᶻ xⁿᶻ) (bⁿᶻ ·ᶻ xᶻ)            ≡⟨ (λ i → aⁿᶻ ·ᶻ minᶻ (bᶻ ·ᶻ xⁿᶻ) (·ᶻ-comm bⁿᶻ xᶻ i)) ⟩
  aⁿᶻ ·ᶻ minᶻ (bᶻ ·ᶻ xⁿᶻ) (xᶻ ·ᶻ bⁿᶻ)            ∎
  where
    aⁿᶻ = [1+ aⁿ ⁿ]ᶻ
    bⁿᶻ = [1+ bⁿ ⁿ]ᶻ
    xⁿᶻ = [1+ xⁿ ⁿ]ᶻ
    p : aᶻ ·ᶻ bⁿᶻ ≡ bᶻ ·ᶻ aⁿᶻ
    p = a~b
    0≤aⁿᶻ : [ 0 ≤ᶻ aⁿᶻ ]
    0≤aⁿᶻ (k , p) = snotzⁿ $ sym (+ⁿ-suc k _) ∙ p
    0≤bⁿᶻ : [ 0 ≤ᶻ bⁿᶻ ]
    0≤bⁿᶻ (k , p) = snotzⁿ $ sym (+ⁿ-suc k _) ∙ p

-- same proof as for min
max'-respects-∼ : (a@(aᶻ , aⁿ) b@(bᶻ , bⁿ) x@(xᶻ , xⁿ) : ℤ × ℕ₊₁)
  → a ∼ b
  → [1+ bⁿ ⁿ]ᶻ ·ᶻ max' a x ≡ [1+ aⁿ ⁿ]ᶻ ·ᶻ max' b x
max'-respects-∼ a@(aᶻ , aⁿ) b@(bᶻ , bⁿ) x@(xᶻ , xⁿ) a~b =
  bⁿᶻ ·ᶻ maxᶻ (aᶻ ·ᶻ xⁿᶻ) (xᶻ ·ᶻ aⁿᶻ)            ≡⟨ ·ᶻ-maxᶻ-distribˡ (aᶻ ·ᶻ xⁿᶻ) (xᶻ ·ᶻ aⁿᶻ) bⁿᶻ 0≤bⁿᶻ ⟩
  maxᶻ (bⁿᶻ ·ᶻ (aᶻ ·ᶻ xⁿᶻ)) (bⁿᶻ ·ᶻ (xᶻ ·ᶻ aⁿᶻ)) ≡⟨ (λ i → maxᶻ (·ᶻ-assoc bⁿᶻ aᶻ xⁿᶻ i) (bⁿᶻ ·ᶻ (xᶻ ·ᶻ aⁿᶻ))) ⟩
  maxᶻ ((bⁿᶻ ·ᶻ aᶻ) ·ᶻ xⁿᶻ) (bⁿᶻ ·ᶻ (xᶻ ·ᶻ aⁿᶻ)) ≡⟨ (λ i → maxᶻ ((·ᶻ-comm bⁿᶻ aᶻ i) ·ᶻ xⁿᶻ) (bⁿᶻ ·ᶻ (xᶻ ·ᶻ aⁿᶻ))) ⟩
  maxᶻ ((aᶻ ·ᶻ bⁿᶻ) ·ᶻ xⁿᶻ) (bⁿᶻ ·ᶻ (xᶻ ·ᶻ aⁿᶻ)) ≡⟨ (λ i → maxᶻ (p i ·ᶻ xⁿᶻ) (bⁿᶻ ·ᶻ (xᶻ ·ᶻ aⁿᶻ))) ⟩
  maxᶻ ((bᶻ ·ᶻ aⁿᶻ) ·ᶻ xⁿᶻ) (bⁿᶻ ·ᶻ (xᶻ ·ᶻ aⁿᶻ)) ≡⟨ (λ i → maxᶻ (·ᶻ-comm bᶻ aⁿᶻ i ·ᶻ xⁿᶻ) (·ᶻ-assoc bⁿᶻ xᶻ aⁿᶻ i)) ⟩
  maxᶻ ((aⁿᶻ ·ᶻ bᶻ) ·ᶻ xⁿᶻ) ((bⁿᶻ ·ᶻ xᶻ) ·ᶻ aⁿᶻ) ≡⟨ (λ i → maxᶻ (·ᶻ-assoc aⁿᶻ bᶻ xⁿᶻ (~ i)) (·ᶻ-comm (bⁿᶻ ·ᶻ xᶻ) aⁿᶻ i)) ⟩
  maxᶻ (aⁿᶻ ·ᶻ (bᶻ ·ᶻ xⁿᶻ)) (aⁿᶻ ·ᶻ (bⁿᶻ ·ᶻ xᶻ)) ≡⟨ sym $ ·ᶻ-maxᶻ-distribˡ (bᶻ ·ᶻ xⁿᶻ) (bⁿᶻ ·ᶻ xᶻ) aⁿᶻ 0≤aⁿᶻ ⟩
  aⁿᶻ ·ᶻ maxᶻ (bᶻ ·ᶻ xⁿᶻ) (bⁿᶻ ·ᶻ xᶻ)            ≡⟨ (λ i → aⁿᶻ ·ᶻ maxᶻ (bᶻ ·ᶻ xⁿᶻ) (·ᶻ-comm bⁿᶻ xᶻ i)) ⟩
  aⁿᶻ ·ᶻ maxᶻ (bᶻ ·ᶻ xⁿᶻ) (xᶻ ·ᶻ bⁿᶻ)            ∎
  where
    aⁿᶻ = [1+ aⁿ ⁿ]ᶻ
    bⁿᶻ = [1+ bⁿ ⁿ]ᶻ
    xⁿᶻ = [1+ xⁿ ⁿ]ᶻ
    p : aᶻ ·ᶻ bⁿᶻ ≡ bᶻ ·ᶻ aⁿᶻ
    p = a~b
    0≤aⁿᶻ : [ 0 ≤ᶻ aⁿᶻ ]
    0≤aⁿᶻ (k , p) = snotzⁿ $ sym (+ⁿ-suc k _) ∙ p
    0≤bⁿᶻ : [ 0 ≤ᶻ bⁿᶻ ]
    0≤bⁿᶻ (k , p) = snotzⁿ $ sym (+ⁿ-suc k _) ∙ p

min : ℚ → ℚ → ℚ
min a b = onCommonDenomSym min' min'-sym min'-respects-∼ a b

max : ℚ → ℚ → ℚ
max a b = onCommonDenomSym max' max'-sym max'-respects-∼ a b

-- injᶻⁿ⁺¹ : ∀ x → [ 0 <ᶻ x ] → Σ[ y ∈ ℕ₊₁ ] x ≡ [1+ y ⁿ]ᶻ
-- injᶻⁿ⁺¹ (signed spos zero) p = ⊥-elim {A = λ _ → Σ[ y ∈ ℕ₊₁ ] ℤ.posneg i0 ≡ [1+ y ⁿ]ᶻ}  (¬-<ⁿ-zero p)
-- injᶻⁿ⁺¹ (signed sneg  zero) p = ⊥-elim {A = λ _ → Σ[ y ∈ ℕ₊₁ ] ℤ.posneg i1 ≡ [1+ y ⁿ]ᶻ}  (¬-<ⁿ-zero p)
-- injᶻⁿ⁺¹ (ℤ.posneg i)        p = ⊥-elim {A = λ _ → Σ[ y ∈ ℕ₊₁ ] ℤ.posneg i  ≡ [1+ y ⁿ]ᶻ}  (¬-<ⁿ-zero p)
-- injᶻⁿ⁺¹ (signed spos (suc n)) p =  1+ n , refl

absᶻ⁺¹ : ℤ → ℕ₊₁
absᶻ⁺¹ (pos zero)    = 1+ 0
absᶻ⁺¹ (neg zero)    = 1+ 0
absᶻ⁺¹ (posneg i)    = 1+ 0
absᶻ⁺¹ (pos (suc n)) = 1+ n
absᶻ⁺¹ (neg (suc n)) = 1+ n

-- absᶻ⁺¹-identity⁺ : ∀ x → [ 0 <ⁿ x ] → [1+ absᶻ⁺¹ (pos x) ⁿ]ᶻ ≡ pos x
-- absᶻ⁺¹-identity⁺ zero    p = ⊥-elim {A = λ _ → [1+ absᶻ⁺¹ (pos zero) ⁿ]ᶻ ≡ pos zero} (<ⁿ-irrefl 0 p)
-- absᶻ⁺¹-identity⁺ (suc x) p = refl
--
-- absᶻ⁺¹-identity⁻ : ∀ x → [ 0 <ⁿ x ] → [1+ absᶻ⁺¹ (neg x) ⁿ]ᶻ ≡ pos x
-- absᶻ⁺¹-identity⁻ zero p = ⊥-elim {A = λ _ → [1+ absᶻ⁺¹ (neg zero) ⁿ]ᶻ ≡ pos zero} (<ⁿ-irrefl 0 p)
-- absᶻ⁺¹-identity⁻ (suc x) p = refl

absᶻ⁺¹-identity : ∀ x → [ x #ᶻ 0 ] → [1+ absᶻ⁺¹ x ⁿ]ᶻ ≡ pos (absᶻ x)
absᶻ⁺¹-identity (pos zero)    p = ⊥-elim {A = λ _ → pos 1 ≡ pos 0} $ #ᶻ⇒≢ (posneg i0) p refl
absᶻ⁺¹-identity (neg zero)    p = ⊥-elim {A = λ _ → pos 1 ≡ pos 0} $ #ᶻ⇒≢ (posneg i1) p posneg
absᶻ⁺¹-identity (posneg i)    p = ⊥-elim {A = λ _ → pos 1 ≡ pos 0} $ #ᶻ⇒≢ (posneg i ) p (λ j → posneg (i ∧ j))
absᶻ⁺¹-identity (pos (suc n)) p = refl
absᶻ⁺¹-identity (neg (suc n)) p = refl

absᶻ⁺¹-identityⁿ : ∀ x → [ x #ᶻ 0 ] → suc (ℕ₊₁.n (absᶻ⁺¹ x)) ≡ absᶻ x
absᶻ⁺¹-identityⁿ x p i = absᶻ (absᶻ⁺¹-identity x p i)

sign' : ℤ × ℕ₊₁ → Sign
sign' (z , n) = signᶻ z

sign'-preserves-∼ : (a b : ℤ × ℕ₊₁) → a ∼ b → sign' a ≡ sign' b
sign'-preserves-∼ a@(aᶻ , aⁿ) b@(bᶻ , bⁿ) p =  sym (lem aᶻ bⁿ) ∙ ψ ∙ lem bᶻ aⁿ where
  a' = absᶻ aᶻ ·ⁿ suc (ℕ₊₁.n bⁿ)
  b' = absᶻ bᶻ ·ⁿ suc (ℕ₊₁.n aⁿ)
  γ : signed (signᶻ aᶻ ⊕ spos) a' ≡ signed (signᶻ bᶻ ⊕ spos) b'
  γ = p
  ψ : signᶻ (signed (signᶻ aᶻ ⊕ spos) a') ≡ signᶻ (signed (signᶻ bᶻ ⊕ spos) b')
  ψ i = signᶻ (γ i)
  lem : ∀ x y → signᶻ (signed (signᶻ x ⊕ spos) (absᶻ x ·ⁿ suc (ℕ₊₁.n y))) ≡ signᶻ x
  lem (pos zero)    y = refl
  lem (neg zero)    y = refl
  lem (posneg i)    y = refl
  lem (pos (suc n)) y = refl
  lem (neg (suc n)) y = refl

sign : ℚ → Sign
sign = SetQuotient.rec {R = _∼_} {B = Sign} Bool.isSetBool sign' sign'-preserves-∼

sign-signᶻ-identity : ∀ z n → sign [ z , n ]ᶠ ≡ signᶻ z
sign-signᶻ-identity z n = refl


open import Oscar.Prelude

module Oscar.Data.List where

open import Agda.Builtin.List public
  using ()
  renaming ([] to ∅)
  renaming (_∷_ to _,_)
⟨_⟩¶ = Agda.Builtin.List.List

List⟨_⟩ = ⟨_⟩¶