module Algebra.LabelledGraph.Theorems where

open import Algebra.LabelledGraph
open import Algebra.LabelledGraph.Reasoning
open import Algebra.Dioid
open import Algebra.Graph using (Graph)
import Algebra.Graph as Graph
import Algebra.Graph.Reasoning as Graph
import Algebra.Graph.Theorems as Graph
import Algebra.Dioid.Bool as Bool
import Algebra.Dioid.Bool.Theorems as Bool

-- | Laws of labelled graphs

associativity : ∀ {A D eq} {d : Dioid D eq} {a b c : LabelledGraph d A} {r : D} -> (a [ r ]> b) [ r ]> c ≡ a [ r ]> (b [ r ]> c)
associativity {_} {_} {_} {_} {a} {b} {c} {r} = right-decomposition >> symmetry left-decomposition

absorption : ∀ {A D eq} {d : Dioid D eq} {a b : LabelledGraph d A} {r : D} -> a [ r ]> b ≡ a [ r ]> b + a + b
absorption {_} {_} {_} {d} {a} {b} {r} =
  begin
    (a [ r ]> b) ≡⟨ symmetry right-identity ⟩
    (a [ r ]> b) [ Dioid.zero d ]> ε ≡⟨ right-decomposition ⟩
    (a [ r ]> b) + (a + ε) + (b + ε) ≡⟨ L (R right-identity ) ⟩
    (a [ r ]> b) + a + (b + ε) ≡⟨ R right-identity ⟩
    (a [ r ]> b) + a + b
  ∎

idempotence : ∀ {A D eq} {d : Dioid D eq} {a : LabelledGraph d A} -> a ≡ a + a
idempotence {_} {_} {_} {_} {a} =
  begin
    a ≡⟨ symmetry right-identity ⟩
    a + ε ≡⟨ symmetry right-identity ⟩
    a + ε + ε ≡⟨ right-decomposition ⟩
    (a + ε) + (a + ε) + (ε + ε) ≡⟨ right-congruence left-identity ⟩
    (a + ε) + (a + ε) + ε ≡⟨ right-identity ⟩
    (a + ε) + (a + ε) ≡⟨ right-congruence right-identity ⟩
    (a + ε) + a ≡⟨ left-congruence right-identity ⟩
    a + a
  ∎

left-absorption : ∀ {A D eq} {d : Dioid D eq} {a b : LabelledGraph d A} {r : D} -> a [ r ]> b ≡ a [ r ]> b + a
left-absorption {_} {_} {_} {_} {a} {b} {r} =
  begin
    (a [ r ]> b)                 ≡⟨ absorption ⟩
    (a [ r ]> b) + a + b         ≡⟨ L (R idempotence) ⟩
    (a [ r ]> b) + (a + a) + b   ≡⟨ associativity ⟩
    (a [ r ]> b) + (a + a + b)   ≡⟨ R zero-commutativity ⟩
    (a [ r ]> b) + (b + (a + a)) ≡⟨ R (symmetry associativity) ⟩
    (a [ r ]> b) + ((b + a) + a) ≡⟨ R (L zero-commutativity) ⟩
    (a [ r ]> b) + ((a + b) + a) ≡⟨ symmetry associativity ⟩
    (a [ r ]> b) + (a + b) + a   ≡⟨ L (symmetry associativity) ⟩
    (a [ r ]> b) + a + b + a     ≡⟨ L (symmetry absorption) ⟩
    (a [ r ]> b) + a
  ∎

right-absorption : ∀ {A D eq} {d : Dioid D eq} {a b : LabelledGraph d A} {r : D} -> a [ r ]> b ≡ a [ r ]> b + b
right-absorption {_} {_} {_} {_} {a} {b} {r} =
  begin
    (a [ r ]> b)               ≡⟨ absorption ⟩
    (a [ r ]> b) + a + b       ≡⟨ R idempotence ⟩
    (a [ r ]> b) + a + (b + b) ≡⟨ symmetry associativity ⟩
    (a [ r ]> b) + a + b + b   ≡⟨ L (symmetry absorption) ⟩
    (a [ r ]> b) + b
  ∎

right-distributivity : ∀ {A D eq} {d : Dioid D eq} {a b c : LabelledGraph d A} {r : D} -> (a + b) [ r ]> c ≡ a [ r ]> c + b [ r ]> c
right-distributivity {_} {_} {_} {_} {a} {b} {c} {r} =
  begin
    (a + b) [ r ]> c                       ≡⟨ right-decomposition ⟩
    a + b + (a [ r ]> c) + (b [ r ]> c)   ≡⟨ L zero-commutativity ⟩
    (a [ r ]> c) + (a + b) + (b [ r ]> c) ≡⟨ L (symmetry associativity) ⟩
    ((a [ r ]> c) + a) + b + (b [ r ]> c) ≡⟨ L (L (symmetry left-absorption)) ⟩
    (a [ r ]> c) + b + (b [ r ]> c)       ≡⟨ associativity ⟩
    (a [ r ]> c) + (b + (b [ r ]> c))     ≡⟨ R zero-commutativity ⟩
    (a [ r ]> c) + ((b [ r ]> c) + b)     ≡⟨ R (symmetry left-absorption) ⟩
    (a [ r ]> c) + (b [ r ]> c)
  ∎

left-distributivity : ∀ {A D eq} {d : Dioid D eq} {a b c : LabelledGraph d A} {r : D} -> a [ r ]> (b + c) ≡ a [ r ]> b + a [ r ]> c
left-distributivity {_} {_} {_} {_} {a} {b} {c} {r} =
  begin
    a [ r ]> (b + c)                   ≡⟨ left-decomposition ⟩
    a [ r ]> b + a [ r ]> c + (b + c) ≡⟨ symmetry associativity ⟩
    a [ r ]> b + a [ r ]> c + b + c   ≡⟨ L associativity ⟩
    a [ r ]> b + (a [ r ]> c + b) + c ≡⟨ L (R zero-commutativity) ⟩
    a [ r ]> b + (b + a [ r ]> c) + c ≡⟨ L (symmetry associativity) ⟩
    a [ r ]> b + b + a [ r ]> c + c   ≡⟨ L (L (symmetry right-absorption)) ⟩
    a [ r ]> b + a [ r ]> c + c       ≡⟨ associativity ⟩
    a [ r ]> b + (a [ r ]> c + c)     ≡⟨ R (symmetry right-absorption) ⟩
    a [ r ]> b + a [ r ]> c
  ∎

-- | Conversion functions
-- These allow for a conversion between LabelledGraphs labelled by Bools and ordinary Graphs.
-- As `graph-laws` and `labelled-graph-laws` demonstrates, these preserve their respective laws.

to-graph : ∀ {A} -> LabelledGraph Bool.bool-dioid A -> Graph A
to-graph ε = Graph.ε
to-graph (v x) = Graph.v x
to-graph (x [ Bool.false ]> y) = to-graph x Graph.+ to-graph y
to-graph (x [ Bool.true  ]> y) = to-graph x Graph.* to-graph y

labelled-graph-laws : ∀ {A} {x y : LabelledGraph Bool.bool-dioid A} -> x ≡ y -> (to-graph x) Graph.≡ (to-graph y)
labelled-graph-laws reflexivity = Graph.reflexivity
labelled-graph-laws (symmetry eq) = Graph.symmetry (labelled-graph-laws eq)
labelled-graph-laws (transitivity eq eq₁) = Graph.transitivity (labelled-graph-laws eq)
                                              (labelled-graph-laws eq₁)
labelled-graph-laws (left-congruence {r = r} eq) with r
... | Bool.true = Graph.*left-congruence (labelled-graph-laws eq)
... | Bool.false = Graph.+left-congruence (labelled-graph-laws eq)
labelled-graph-laws (right-congruence {r = r} eq) with r
... | Bool.true = Graph.*right-congruence (labelled-graph-laws eq)
... | Bool.false = Graph.+right-congruence (labelled-graph-laws eq)
labelled-graph-laws (dioid-congruence eq) = dioid-recur eq
  where
    dioid-recur : ∀ {A} {x y : LabelledGraph Bool.bool-dioid A} {r s : Bool.Bool}
               -> r Bool.≡ s -> (to-graph (x [ r ]> y)) Graph.≡ (to-graph (x [ s ]> y))
    dioid-recur Bool.reflexivity = Graph.reflexivity
    dioid-recur (Bool.symmetry eq) = Graph.symmetry (dioid-recur eq)
    dioid-recur (Bool.transitivity eq eq₁) = Graph.transitivity (dioid-recur eq) (dioid-recur eq₁)
labelled-graph-laws zero-commutativity = Graph.+commutativity
labelled-graph-laws (left-identity {r = r}) with r
... | Bool.true = Graph.*left-identity
... | Bool.false = Graph.+commutativity Graph.>> Graph.+identity
labelled-graph-laws (right-identity {r = r}) with r
... | Bool.true = Graph.*right-identity
... | Bool.false = Graph.+identity
labelled-graph-laws (left-decomposition {r = r} {s}) with r | s
... | Bool.true  | Bool.true  = Graph.*associativity Graph.>> Graph.decomposition
... | Bool.true  | Bool.false = Graph.*+ltriple
... | Bool.false | Bool.true  = Graph.+*ltriple
... | Bool.false | Bool.false = Graph.++ltriple
labelled-graph-laws (right-decomposition {r = r} {s}) with r | s
... | Bool.true  | Bool.true  = Graph.decomposition
... | Bool.true  | Bool.false = Graph.*+rtriple
... | Bool.false | Bool.true  = Graph.+*rtriple
... | Bool.false | Bool.false = Graph.++rtriple
labelled-graph-laws (label-addition {r = r} {s}) with r | s
... | Bool.true  | Bool.true  = Graph.+idempotence
... | Bool.true  | Bool.false = Graph.+associativity Graph.>> Graph.absorption
... | Bool.false | Bool.true  = (Graph.+commutativity Graph.>> Graph.+associativity) Graph.>> Graph.absorption
... | Bool.false | Bool.false = Graph.+idempotence

from-graph : ∀ {A D eq} {d : Dioid D eq} -> Graph A -> LabelledGraph d A
from-graph Graph.ε = ε
from-graph (Graph.v x) = v x
from-graph {_} {_} {_} {d} (x Graph.+ y) = from-graph x [ Dioid.zero d ]> from-graph y
from-graph {_} {_} {_} {d} (x Graph.* y) = from-graph x [ Dioid.one  d ]> from-graph y

graph-laws : ∀ {A D eq} {d : Dioid D eq} {x y : Graph A} -> x Graph.≡ y -> _≡_ {A} {D} {eq} {d} (from-graph x) (from-graph y)
graph-laws {x = x} {.x} Graph.reflexivity = reflexivity
graph-laws {x = x} {y} (Graph.symmetry eq) = symmetry (graph-laws eq)
graph-laws {x = x} {y} (Graph.transitivity eq eq₁) = transitivity (graph-laws eq) (graph-laws eq₁)
graph-laws {x = .(_ Graph.+ _)} {.(_ Graph.+ _)} (Graph.+left-congruence eq)  = left-congruence (graph-laws eq)
graph-laws {x = .(_ Graph.* _)} {.(_ Graph.* _)} (Graph.*left-congruence eq)  = left-congruence (graph-laws eq)
graph-laws {x = .(_ Graph.* _)} {.(_ Graph.* _)} (Graph.*right-congruence eq) = right-congruence (graph-laws eq)
graph-laws {x = .(_ Graph.+ _)} {.(_ Graph.+ _)} Graph.+commutativity = zero-commutativity
graph-laws {x = .(_ Graph.+ (_ Graph.+ _))} {.(_ Graph.+ _ Graph.+ _)} Graph.+associativity = symmetry associativity
graph-laws {x = .(Graph.ε Graph.* y)} {y} Graph.*left-identity = left-identity
graph-laws {x = .(y Graph.* Graph.ε)} {y} Graph.*right-identity = right-identity
graph-laws {x = .(_ Graph.* (_ Graph.* _))} {.(_ Graph.* _ Graph.* _)} Graph.*associativity = symmetry associativity
graph-laws {x = .(_ Graph.* (_ Graph.+ _))} {.(_ Graph.* _ Graph.+ _ Graph.* _)} Graph.left-distributivity = left-distributivity
graph-laws {x = .((_ Graph.+ _) Graph.* _)} {.(_ Graph.* _ Graph.+ _ Graph.* _)} Graph.right-distributivity = right-distributivity
graph-laws {x = .(_ Graph.* _ Graph.* _)} {.(_ Graph.* _ Graph.+ _ Graph.* _ Graph.+ _ Graph.* _)} Graph.decomposition = right-decomposition

to-from-identity : ∀ {A} {x : Graph A} -> (to-graph (from-graph x)) Graph.≡ x
to-from-identity {x = Graph.ε} = Graph.reflexivity
to-from-identity {x = Graph.v x} = Graph.reflexivity
to-from-identity {x = x₁ Graph.+ x₂} = Graph.symmetry (Graph.+left-congruence  (Graph.symmetry (to-from-identity {x = x₁})))
                              Graph.>> Graph.symmetry (Graph.+right-congruence (Graph.symmetry (to-from-identity {x = x₂})))
to-from-identity {x = x₁ Graph.* x₂} = Graph.symmetry (Graph.*left-congruence  (Graph.symmetry (to-from-identity {x = x₁})))
                              Graph.>> Graph.symmetry (Graph.*right-congruence (Graph.symmetry (to-from-identity {x = x₂})))

from-to-identity : ∀ {A} {x : LabelledGraph Bool.bool-dioid A} -> (from-graph (to-graph x)) ≡ x
from-to-identity {x = ε} = reflexivity
from-to-identity {x = v x} = reflexivity
from-to-identity {x = x₁ [ d ]> x₂} with d
... | Bool.true  = symmetry (left-congruence  (symmetry (from-to-identity {x = x₁})))
                >> symmetry (right-congruence (symmetry (from-to-identity {x = x₂})))
... | Bool.false = symmetry (left-congruence  (symmetry (from-to-identity {x = x₁})))
                >> symmetry (right-congruence (symmetry (from-to-identity {x = x₂})))


------------------------------------------------------------------------
-- Type checing of polymorphic and iso-recursive lambda terms
------------------------------------------------------------------------

module SystemF.TypeCheck where

open import Data.Fin using (Fin; suc; zero; pred)
open import Data.Nat as Nat using (ℕ; _+_)
open import Data.Product
open import Data.Vec using (_∷_; []; lookup)
open import Function hiding (typeOf)
open import Relation.Nullary
open import Relation.Nullary.Negation
open import Relation.Binary using (Decidable)
open import Relation.Binary.PropositionalEquality hiding ([_])
open ≡-Reasoning

open import SystemF.Type
open import SystemF.Term
open import SystemF.WtTerm

open TypeSubst using () renaming (_[/_]  to _[/tp_])
open CtxSubst  using () renaming (weaken to weakenCtx)

------------------------------------------------------------------------
-- Decision procedures for equality of variable names and types

-- This module contains two decision procedures for type checking:
--
--  * the function typeOf synthesizes a type a for a given (untyped)
--    term t and typing environment Γ, if possible;
--
--  * the function check_⊢_∈_ checks whether a given triple Γ, t, a is
--    in the well-typedness relation.
--
-- The two functions correspond to a synthetic resp. analytic view of
-- type-checking.  Both produce evidence in the form of a typing
-- derivation if type checking succeeds or a proof that no such
-- derivation exists otherwise.

infix 4 _≟n_ _≡tp_ _≟_

-- Equal successors have equal predecessors.
≡suc : ∀ {n} {x y : Fin n} → suc x ≡ suc y → x ≡ y
≡suc refl = refl

-- A decision procedure for equality of variable names.
_≟n_ : ∀ {n} → Decidable {A = Fin n} _≡_
zero  ≟n zero   = yes refl
suc x ≟n suc y  with x ≟n y
... | yes x≡y   = yes (cong suc x≡y)
... | no  x≢y   = no (x≢y ∘ ≡suc)
zero  ≟n suc y  = no λ()
suc x ≟n zero   = no λ()

-- A shorthand for (syntactic) type equality.
_≡tp_ : ∀ {n} → Type n → Type n → Set
a ≡tp b = a ≡ b

-- Equal type variables have equal names.
≡var : ∀ {n} {x y : Fin n} → var x ≡tp var y → x ≡ y
≡var refl = refl

-- Equal function types have equal domains.
≡dom→ : ∀ {n} {a a′ b b′ : Type n} → a →' b ≡tp a′ →' b′ → a ≡ a′
≡dom→ refl = refl

-- Equal function types have equal codomains.
≡cod→ : ∀ {n} {a a′ b b′ : Type n} → a →' b ≡tp a′ →' b′ → b ≡ b′
≡cod→ refl = refl

-- Equal univeral types have equal bodies.
≡∀ : ∀ {n} {a a′ : Type (1 + n)} → ∀' a ≡tp ∀' a′ → a ≡ a′
≡∀ refl = refl

-- Equal recursive types have equal bodies.
≡μ : ∀ {n} {a a′ : Type (1 + n)} → μ a ≡tp μ a′ → a ≡ a′
≡μ refl = refl

-- A decision procedure for (syntactic) type equality
_≟_ : ∀ {n} → Decidable {A = Type n} _≡_
var x  ≟ var  y    with x ≟n y
var x  ≟ var .x    | yes refl = yes refl
var x  ≟ var  y    | no  x≢y  = no (x≢y ∘ ≡var)
var _  ≟ _ →' _    = no λ()
var _  ≟ ∀' _      = no λ()
var _  ≟ μ _       = no λ()
a →' b ≟ var x     = no λ()
a →' b ≟  a′ →' b′ with a ≟ a′ | b ≟ b′
a →' b ≟ .a →' .b  | yes refl  | yes refl = yes refl
a →' b ≟  a′ →' b′ | yes _     | no  b≢b′ = no (b≢b′ ∘ ≡cod→)
a →' b ≟  a′ →' b′ | no  a≢a′  | _        = no (a≢a′ ∘ ≡dom→)
a →' b ≟ ∀' _      = no λ()
a →' b ≟ μ _       = no λ()
∀' _   ≟ var _     = no λ()
∀' _   ≟ _ →' _    = no λ()
∀' a   ≟ ∀'  a′    with a ≟ a′
∀' a   ≟ ∀' .a     | yes refl = yes refl
∀' a   ≟ ∀'  a′    | no  a≢a′ = no (a≢a′ ∘ ≡∀)
∀' _   ≟ μ _       = no λ()
μ _    ≟ var _     = no λ()
μ _    ≟ _ →' _    = no λ()
μ _    ≟ ∀' _      = no λ()
μ a    ≟ μ  a′     with a ≟ a′
μ a    ≟ μ .a      | yes refl = yes refl
μ a    ≟ μ  a′     | no  a≢a′ = no (a≢a′ ∘ ≡μ)

------------------------------------------------------------------------
-- Inversion and functionality of the well-typedness relation

-- Inversion of type application typing.
Λ-inversion : ∀ {m n} {Γ : Ctx m n} {t a} →
              Γ ⊢ Λ t ∈ a → ∃ λ a′ → (a ≡ ∀' a′) × (weakenCtx Γ ⊢ t ∈ a′)
Λ-inversion {a = ∀' a′} (Λ t∈a) = a′ , (refl , t∈a)

-- Inversion of term application typing.
λ'-inversion : ∀ {m n} {Γ : Ctx m n} {t a a→b} →
               Γ ⊢ λ' a t ∈ a→b → ∃ λ b → (a→b ≡ a →' b) × (a ∷ Γ ⊢ t ∈ b)
λ'-inversion {a→b = a →' b} (λ' .a t∈b) = b , (refl , t∈b)

-- Inversion of recursive term typing.
μ-inversion : ∀ {m n} {Γ : Ctx m n} {t a a′} →
              Γ ⊢ μ a t ∈ a′ → (a ≡ a′) × (a ∷ Γ ⊢ t ∈ a)
μ-inversion (μ a t∈b) = refl , t∈b

-- Inversion of type application.
[]-inversion : ∀ {m n} {Γ : Ctx m n} {t b a[/b]} → Γ ⊢ t [ b ] ∈ a[/b] →
               ∃ λ a → (a[/b] ≡ a [/tp b ]) × (Γ ⊢ t ∈ ∀' a)
[]-inversion (_[_] {a = a} t∈∀a b) = a , (refl , t∈∀a)

-- Inversion of term application.
·-inversion : ∀ {m n} {Γ : Ctx m n} {s t b} → Γ ⊢ s · t ∈ b →
              ∃ λ a → (Γ ⊢ s ∈ a →' b) × (Γ ⊢ t ∈ a)
·-inversion (_·_ {a = a} s∈a→b t∈a) = a , (s∈a→b , t∈a)

-- Inversion of recursive type folding.
fold-inversion : ∀ {m n} {Γ : Ctx m n} {t a μa} → Γ ⊢ fold a t ∈ μa →
                 (μa ≡ μ a) × (Γ ⊢ t ∈ a [/tp μ a ])
fold-inversion (fold a t∈a[/μa]) = refl , t∈a[/μa]

-- Inversion of recursive type unfolding.
unfold-inversion : ∀ {m n} {Γ : Ctx m n} {t a a[/μa]} →
                   Γ ⊢ unfold a t ∈ a[/μa] →
                   (a[/μa] ≡ a [/tp μ a ]) × (Γ ⊢ t ∈ μ a)
unfold-inversion (unfold a t∈μa) = refl , t∈μa

-- The relation _⊢_∈_ is functional in its last argument.
functional : ∀ {m n} {Γ : Ctx m n} {t a a′} → Γ ⊢ t ∈ a → Γ ⊢ t ∈ a′ → a ≡ a′
functional (var x)       (var .x)        = refl
functional (Λ t∈a)       (Λ t∈a′)        = cong ∀' (functional t∈a t∈a′)
functional (λ' a t∈b)    (λ' .a t∈b′)    = cong (_→'_ a) (functional t∈b t∈b′)
functional (μ a t∈a)     (μ .a t∈a′)     = functional t∈a t∈a′
functional (t∈∀a [ b ])  (t∈∀a′ [ .b ])  =
  cong (λ{ (∀' a)   → a [/tp b ] ; a → a }) (functional t∈∀a t∈∀a′)
functional (s∈a→b · _)   (s∈a→b′ · _)    =
  cong (λ{ (a →' b) → b          ; a → a }) (functional s∈a→b s∈a→b′)
functional (fold a t∈)   (fold .a t∈′)   = refl
functional (unfold a t∈) (unfold .a t∈′) = refl

-- A variant of functionality.
functional′ : ∀ {m n} {Γ : Ctx m n} {t a a′} → Γ ⊢ t ∈ a → a ≢ a′ → Γ ⊢ t ∉ a′
functional′ t∈a = contraposition (functional t∈a)

------------------------------------------------------------------------
-- Type checking

infix 5 check_⊢_∈_

-- A predicate for typable terms
HasType : ∀ {m n} → Ctx m n → Term m n → Set
HasType Γ t = ∃ λ a → Γ ⊢ t ∈ a

-- Type checking viewed as a decision procedure for the existence of
-- typings (i.e. type synthesis).  Note that together with
-- functionality, this proves that the well-typedness relation is a
-- decidable partial function.
typeOf : ∀ {m n} (Γ : Ctx m n) t → Dec (HasType Γ t)
typeOf Γ (var x)      = yes (lookup Γ x , var x)
typeOf Γ (Λ t)        with typeOf (weakenCtx Γ) t
... | yes (a , t∈a)   = yes (∀' a , Λ t∈a)
... | no ∄a           = no (∄a ∘ map id proj₂ ∘ Λ-inversion ∘ proj₂)
typeOf Γ (λ' a t)     with typeOf (a ∷ Γ) t
... | yes (b , t∈b)   = yes (a →' b , λ' a t∈b)
... | no ∄b           = no (∄b ∘ map id proj₂ ∘ λ'-inversion ∘ proj₂)
typeOf Γ (μ a t)      with typeOf (a ∷ Γ) t
typeOf Γ (μ a t)      | yes ( a′ , t∈a′) with a′ ≟ a
typeOf Γ (μ a t)      | yes (.a  , t∈a′) | yes refl = yes (a , μ a t∈a′)
... | no  a′≢a = no (a′≢a ∘ functional t∈a′ ∘ proj₂ ∘ μ-inversion ∘ proj₂)
typeOf Γ (μ a t)      | no ∄a′ =
  no (∄a′ ∘ map id (uncurry ⊢substTp ∘ μ-inversion))
typeOf Γ (t [ b ])    with typeOf Γ t
typeOf Γ (t [ b ])    | yes (var _  , t∈x   ) =
  no ((functional′ t∈x λ()) ∘ proj₂ ∘ proj₂ ∘ []-inversion ∘ proj₂)
typeOf Γ (t [ b ])    | yes (_ →' _ , t∈a→b ) =
  no ((functional′ t∈a→b λ()) ∘ proj₂ ∘ proj₂ ∘ []-inversion ∘ proj₂)
typeOf Γ (t [ b ])    | yes (∀' a   , t∈∀a  ) = yes (a [/tp b ] , t∈∀a [ b ])
typeOf Γ (t [ b ])    | yes (μ _    , t∈μa  ) =
  no ((functional′ t∈μa λ()) ∘ proj₂ ∘ proj₂ ∘ []-inversion ∘ proj₂)
typeOf Γ (t [ b ])    | no  ∄a = no (∄a ∘ map ∀' proj₂ ∘ []-inversion ∘ proj₂)
typeOf Γ (s · t)      with typeOf Γ s | typeOf Γ t
typeOf Γ (s · t)      | yes (var _  , s∈x  ) | _ =
  no ((functional′ s∈x λ()) ∘ proj₁ ∘ proj₂ ∘ ·-inversion ∘ proj₂)
typeOf Γ (s · t) | yes (a →' b , s∈a→b) | yes ( a′ , t∈a) with a′ ≟ a
typeOf Γ (s · t) | yes (a →' b , s∈a→b) | yes (.a  , t∈a) | yes refl =
  yes (b , s∈a→b · t∈a)
typeOf Γ (s · t) | yes (a →' b , s∈a→b) | yes ( a′ , t∈a) | no  a′≢a =
  no (a′≢a ∘ helper)
  where
    helper : HasType Γ (s · t) → a′ ≡ a
    helper (b , s·t∈b) with ·-inversion s·t∈b
    ... | c , s∈c→b , t∈c = begin
      a′ ≡⟨ functional t∈a t∈c ⟩
      c  ≡⟨ ≡dom→ (functional s∈c→b s∈a→b) ⟩
      a  ∎
typeOf Γ (s · t) | yes (a →' b , s∈a→b) | no  ∄a′ =
  no (∄a′ ∘ map id proj₂ ∘ ·-inversion ∘ proj₂)
typeOf Γ (s · t) | yes (∀' _   , s∈∀a ) | _ =
  no ((functional′ s∈∀a λ()) ∘ proj₁ ∘ proj₂ ∘ ·-inversion ∘ proj₂)
typeOf Γ (s · t) | yes (μ  _   , s∈μa ) | _ =
  no ((functional′ s∈μa λ()) ∘ proj₁ ∘ proj₂ ∘ ·-inversion ∘ proj₂)
typeOf Γ (s · t) | no  ∄a               | _ = no (∄a ∘ helper)
  where
    helper : HasType Γ (s · t) → HasType Γ s
    helper (b , s·t∈b) with ·-inversion s·t∈b
    ... | a , s∈a→b , _ = a →' b , s∈a→b
typeOf Γ (fold a t)   with typeOf Γ t
typeOf Γ (fold a t)   | yes (a′ , t∈a′) with a′ ≟ a [/tp μ a ]
typeOf Γ (fold a t)   | yes (._ , t∈a′) | yes refl = yes (μ a , fold a t∈a′)
typeOf Γ (fold a t)   | yes (a′ , t∈a′) | no a′≢a[/μa] =
  no (a′≢a[/μa] ∘ functional t∈a′ ∘ proj₂ ∘ fold-inversion ∘ proj₂)
typeOf Γ (fold a t)   | no  ∄a′ =
  no (∄a′ ∘ map (const (a [/tp μ a ])) id ∘ fold-inversion ∘ proj₂)
typeOf Γ (unfold a t) with typeOf Γ t
typeOf Γ (unfold a t) | yes (a′ , t∈a′) with a′ ≟ μ a
typeOf Γ (unfold a t) | yes (._ , t∈a′) | yes refl =
  yes (a [/tp μ a ] , unfold a t∈a′)
typeOf Γ (unfold a t) | yes (a′ , t∈a′) | no a′≢μa =
  no (a′≢μa ∘ functional t∈a′ ∘ proj₂ ∘ unfold-inversion ∘ proj₂)
typeOf Γ (unfold a t) | no  ∄a′ =
  no (∄a′ ∘ map (const (μ a)) id ∘ unfold-inversion ∘ proj₂)

-- Type checking as a decision procedure for the well-typedness
-- relation.
check_⊢_∈_ : ∀ {m n} (Γ : Ctx m n) t a → Dec (Γ ⊢ t ∈ a)
check Γ ⊢ t ∈ a with typeOf Γ t
check Γ ⊢ t ∈ a | yes ( a′ , t∈a′) with a′ ≟ a
check Γ ⊢ t ∈ a | yes (.a  , t∈a ) | yes refl = yes t∈a
check Γ ⊢ t ∈ a | yes ( a′ , t∈a′) | no  a′≢a = no (a′≢a ∘ functional t∈a′)
check Γ ⊢ t ∈ a | no   ∄a′                    = no (∄a′ ∘ helper)
  where
    helper : ∀ {m n} {Γ : Ctx m n} {t a} → Γ ⊢ t ∈ a → HasType Γ t
    helper {a = a} t∈a = a , t∈a

------------------------------------------------------------------------
-- Some simple test cases

private
  module TpOp = TypeOperators
  module TmOp = TermOperators
  module WtOp = WtTermOperators

-- Test: synthesize the type of the polymorphic identity.
test-typeOf-id : typeOf [] (TmOp.id {n = 0}) ≡ yes (TpOp.id , WtOp.id)
test-typeOf-id = refl

-- Test: check the type of the polymorphic identity.
test-check-id : check [] ⊢ TmOp.id {n = 0} ∈ TpOp.id ≡ yes WtOp.id
test-check-id = refl

-- Using the agda2-mode one can also run the above decision procedures
-- interactively in GNU/Emacs by typing C-x C-n <expression>.
-- E.g. typing
--
--   C-x C-n typeOf [] (Λ (λ' (var zero) (var zero)))
--
-- should return
--
--   yes (∀' (var zero →' var zero) , Λ (λ' (var zero) (var zero)))

------------------------------------------------------------------------
-- Uniqueness of typing derivations

-- There is at most one typing derivation for each triple Γ, t, a.
-- I.e. if there is an x : Γ ⊢ t ∈ a, it is unique.
unique : ∀ {m n} {Γ : Ctx m n} {t a} (t∈a t∈a′ : Γ ⊢ t ∈ a) → t∈a ≡ t∈a′
unique (var x)    (var .x)     = refl
unique (Λ t∈a)    (Λ t∈a′)     = cong Λ (unique t∈a t∈a′)
unique (λ' a t∈a) (λ' .a t∈a′) = cong (λ' a) (unique t∈a t∈a′)
unique (μ  a t∈a) (μ  .a t∈a′) = cong (μ  a) (unique t∈a t∈a′)
unique {Γ = Γ} {t [ b ]} (_[_] {a = a } t∈a .b) t∈a′[b] = helper t∈a′[b] refl
  where
    helper : ∀ {a′[/b]} (t∈a′[b] : Γ ⊢ t [ b ] ∈ a′[/b])
             (a[/b]≡a′[/b] : a [/tp b ] ≡ a′[/b]) →
             ⊢substTp a[/b]≡a′[/b] (t∈a [ b ]) ≡ t∈a′[b]
    helper (_[_] {a = a′} t∈a′ .b) _ with functional t∈a t∈a′
    helper (t∈a′ [ .b ]) refl | refl = cong _ (unique t∈a t∈a′)
unique (_·_ {a = a} s∈a→b t∈a) (_·_ {a = a′} s∈a′→b t∈a′) with
  functional s∈a→b s∈a′→b
unique (s∈a→b · t∈a) (s∈a′→b · t∈a′) | refl =
  cong₂ _·_ (unique s∈a→b s∈a′→b) (unique t∈a t∈a′)
unique (fold   a t∈a) (fold   .a t∈a′) = cong (fold   a) (unique t∈a t∈a′)
unique (unfold a t∈a) (unfold .a t∈a′) = cong (unfold a) (unique t∈a t∈a′)


module Prelude where

-- Simple data
open import Data.Bool public
  using (Bool ; false ; true ; not)
open import Data.Empty public
  using (⊥ ; ⊥-elim)
open import Data.Nat public
  using (
  ℕ ; zero ; suc
  ; _+_ ; _*_
  ; _≤_ ; z≤n ; s≤s
  ; _<_ ; _≟_ ; pred
  )
open import Data.Maybe public
  using (Maybe ; just ; nothing)
open import Data.Unit public
  using (⊤ ; tt)
open import Data.String public
  using (String)
  renaming (_++_ to _||_)

-- List-like modules

open import Data.List public
  using (
    List ; [] ; _∷_
    ; _++_ ; map ; drop
    ; reverse ; _∷ʳ_ ; length
    )
open import Data.List.All public
  using (All ; [] ; _∷_ ; lookup)
  renaming (map to ∀map)
open import Membership public
  using (
  _∈_ ; S ; Z
  ; _⊆_ ; _∷_ ; []
  ; ⊆-refl ; ⊆-suc ; find-∈
  ; lookup-parallel ; lookup-parallel-≡ ; translate-∈
  ; translate-⊆ ; ⊆-trans ; All-⊆
  ; ⊆++-l-refl ; lookup-all
  ; ∈-inc ; ⊆++-refl ; ⊆++comm'
  ; ⊆++comm ; ⊆-move ; ⊆-inc
  ; ⊆-skip
  )
open import Data.List.Any public
  using (Any ; here ; there)

open import Singleton public
  using ([_]ˡ ; [_]ᵃ ; [_]ᵐ)

-- Propositions and properties
open import Relation.Binary.PropositionalEquality public
  using (
    _≡_ ; refl ; sym
    ; cong ; cong₂ ; trans
    ; inspect ; [_]
    )
open import Relation.Nullary public
  using (Dec ; yes ; no ; ¬_)
open import Relation.Nullary.Decidable public
  using (⌊_⌋)

-- Other
open import Level public
  using    (Level; _⊔_ ; Lift ; lift)
  renaming (zero to lzero; suc to lsuc)
open import Size public
  using (Size ; Size<_ ; ↑_ ; ∞)


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

module Relation.Nullary.Discrete where

open import Relation.Nullary.Discrete.Base public


{-

Type quotients:

-}

{-# OPTIONS --cubical --no-import-sorts --safe #-}
module Cubical.HITs.TypeQuotients.Properties where

open import Cubical.HITs.TypeQuotients.Base

open import Cubical.Core.Everything

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Function
open import Cubical.Foundations.Isomorphism
open import Cubical.Foundations.Equiv
open import Cubical.Foundations.HLevels

open import Cubical.HITs.PropositionalTruncation as PropTrunc using (∥_∥ ; ∣_∣ ; squash)
open import Cubical.HITs.SetTruncation as SetTrunc using (∥_∥₂ ; ∣_∣₂ ; squash₂
                                                              ; setTruncIsSet)

private
  variable
    ℓ ℓ' ℓ'' : Level
    A : Type ℓ
    R : A → A → Type ℓ'
    B : A /ₜ R → Type ℓ''
    C : A /ₜ R → A /ₜ R → Type ℓ''

elim : (f : (a : A) → (B [ a ]))
     → ((a b : A) (r : R a b) → PathP (λ i → B (eq/ a b r i)) (f a) (f b))
    ------------------------------------------------------------------------
     → (x : A /ₜ R) → B x
elim f feq [ a ] = f a
elim f feq (eq/ a b r i) = feq a b r i

rec : {X : Type ℓ''}
    → (f : A → X)
    → (∀ (a b : A) → R a b → f a ≡ f b)
   -------------------------------------
    → A /ₜ R → X
rec f feq [ a ] = f a
rec f feq (eq/ a b r i) = feq a b r i

elimProp : ((x : A /ₜ R ) → isProp (B x))
         → ((a : A) → B ( [ a ]))
        ---------------------------------
         → (x : A /ₜ R) → B x
elimProp Bprop f [ a ] = f a
elimProp Bprop f (eq/ a b r i) = isOfHLevel→isOfHLevelDep 1 Bprop (f a) (f b) (eq/ a b r) i

elimProp2 : ((x y : A /ₜ R ) → isProp (C x y))
          → ((a b : A) → C [ a ] [ b ])
         --------------------------------------
          → (x y : A /ₜ R) → C x y
elimProp2 Cprop f = elimProp (λ x → isPropΠ (λ y → Cprop x y))
                             (λ x → elimProp (λ y → Cprop [ x ] y) (f x))


module Records where

open import Common.Nat
open import Common.IO
open import Common.Unit

record Test : Set where
  constructor mkTest
  field
    a b c : Nat

f : Test -> Nat
f (mkTest a b c) = a + b + c

open Test

g : Nat
g = (f (mkTest 34 12 54)) + (f (record {a = 100; b = 120; c = 140})) + a m + b m + c m
  where m = mkTest 200 300 400

main : IO Unit
main = printNat g


module WrongNamedArgument where

postulate
  f : {A : Set₁} → A → A

test : Set → Set
test = f {B = Set}

-- Good error:

-- Function does not accept argument {B = _}
-- when checking that {B = Set} are valid arguments to a function of
-- type {A : Set₁} → A → A


{-# OPTIONS --safe #-}

module Cubical.Algebra.CommAlgebra.FreeCommAlgebra.Properties where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Equiv
open import Cubical.Foundations.Isomorphism
open import Cubical.Foundations.HLevels
open import Cubical.Foundations.Structure
open import Cubical.Foundations.Function hiding (const)
open import Cubical.Foundations.Isomorphism

open import Cubical.Data.Sigma.Properties using (Σ≡Prop)
open import Cubical.HITs.SetTruncation

open import Cubical.Algebra.CommRing
open import Cubical.Algebra.CommAlgebra.FreeCommAlgebra.Base
open import Cubical.Algebra.Ring        using ()
open import Cubical.Algebra.CommAlgebra
open import Cubical.Algebra.CommAlgebra.Instances.Initial
open import Cubical.Algebra.Algebra

open import Cubical.Data.Empty
open import Cubical.Data.Sigma

private
  variable
    ℓ ℓ' ℓ'' : Level

module Theory {R : CommRing ℓ} {I : Type ℓ'} where
  open CommRingStr (snd R)
         using (0r; 1r)
         renaming (_·_ to _·r_; _+_ to _+r_; ·Comm to ·r-comm; ·Rid to ·r-rid)

  module _ (A : CommAlgebra R ℓ'') (φ : I → ⟨ A ⟩) where
    open CommAlgebraStr (A .snd)
    open AlgebraTheory (CommRing→Ring R) (CommAlgebra→Algebra A)
    open Construction using (var; const) renaming (_+_ to _+c_; -_ to -c_; _·_ to _·c_)

    imageOf0Works : 0r ⋆ 1a ≡ 0a
    imageOf0Works = 0-actsNullifying 1a

    imageOf1Works : 1r ⋆ 1a ≡ 1a
    imageOf1Works = ⋆-lid 1a

    inducedMap : ⟨ R [ I ] ⟩ → ⟨ A ⟩
    inducedMap (var x) = φ x
    inducedMap (const r) = r ⋆ 1a
    inducedMap (P +c Q) = (inducedMap P) + (inducedMap Q)
    inducedMap (-c P) = - inducedMap P
    inducedMap (Construction.+-assoc P Q S i) = +-assoc (inducedMap P) (inducedMap Q) (inducedMap S) i
    inducedMap (Construction.+-rid P i) =
      let
        eq : (inducedMap P) + (inducedMap (const 0r)) ≡ (inducedMap P)
        eq = (inducedMap P) + (inducedMap (const 0r)) ≡⟨ refl ⟩
             (inducedMap P) + (0r ⋆ 1a)               ≡⟨ cong
                                                         (λ u → (inducedMap P) + u)
                                                         (imageOf0Works) ⟩
             (inducedMap P) + 0a                      ≡⟨ +-rid _ ⟩
             (inducedMap P) ∎
      in eq i
    inducedMap (Construction.+-rinv P i) =
      let eq : (inducedMap P - inducedMap P) ≡ (inducedMap (const 0r))
          eq = (inducedMap P - inducedMap P) ≡⟨ +-rinv _ ⟩
               0a                            ≡⟨ sym imageOf0Works ⟩
               (inducedMap (const 0r))∎
      in eq i
    inducedMap (Construction.+-comm P Q i) = +-comm (inducedMap P) (inducedMap Q) i
    inducedMap (P ·c Q) = inducedMap P · inducedMap Q
    inducedMap (Construction.·-assoc P Q S i) = ·Assoc (inducedMap P) (inducedMap Q) (inducedMap S) i
    inducedMap (Construction.·-lid P i) =
      let eq = inducedMap (const 1r) · inducedMap P ≡⟨ cong (λ u → u · inducedMap P) imageOf1Works ⟩
               1a · inducedMap P                    ≡⟨ ·Lid (inducedMap P) ⟩
               inducedMap P ∎
      in eq i
    inducedMap (Construction.·-comm P Q i) = ·-comm (inducedMap P) (inducedMap Q) i
    inducedMap (Construction.ldist P Q S i) = ·Ldist+ (inducedMap P) (inducedMap Q) (inducedMap S) i
    inducedMap (Construction.+HomConst s t i) = ⋆-ldist s t 1a i
    inducedMap (Construction.·HomConst s t i) =
      let eq = (s ·r t) ⋆ 1a       ≡⟨ cong (λ u → u ⋆ 1a) (·r-comm _ _) ⟩
               (t ·r s) ⋆ 1a       ≡⟨ ⋆-assoc t s 1a ⟩
               t ⋆ (s ⋆ 1a)        ≡⟨ cong (λ u → t ⋆ u) (sym (·Rid _)) ⟩
               t ⋆ ((s ⋆ 1a) · 1a) ≡⟨ ⋆-rassoc t (s ⋆ 1a) 1a ⟩
               (s ⋆ 1a) · (t ⋆ 1a) ∎
      in eq i
    inducedMap (Construction.0-trunc P Q p q i j) =
      isSetAlgebra (CommAlgebra→Algebra A) (inducedMap P) (inducedMap Q) (cong _ p) (cong _ q) i j

    module _ where
      open IsAlgebraHom

      inducedHom : AlgebraHom (CommAlgebra→Algebra (R [ I ])) (CommAlgebra→Algebra A)
      inducedHom .fst = inducedMap
      inducedHom .snd .pres0 = 0-actsNullifying _
      inducedHom .snd .pres1 = imageOf1Works
      inducedHom .snd .pres+ x y = refl
      inducedHom .snd .pres· x y = refl
      inducedHom .snd .pres- x = refl
      inducedHom .snd .pres⋆ r x =
        (r ⋆ 1a) · inducedMap x ≡⟨ ⋆-lassoc r 1a (inducedMap x) ⟩
        r ⋆ (1a · inducedMap x) ≡⟨ cong (λ u → r ⋆ u) (·Lid (inducedMap x)) ⟩
        r ⋆ inducedMap x ∎

  module _ (A : CommAlgebra R ℓ'') where
    open CommAlgebraStr (A .snd)
    open AlgebraTheory (CommRing→Ring R) (CommAlgebra→Algebra A)
    open Construction using (var; const) renaming (_+_ to _+c_; -_ to -c_; _·_ to _·c_)

    Hom = CommAlgebraHom  (R [ I ]) A
    open IsAlgebraHom

    evaluateAt : Hom → I → ⟨ A ⟩
    evaluateAt φ x = φ .fst (var x)

    mapRetrievable : ∀ (φ : I → ⟨ A ⟩)
                     → evaluateAt (inducedHom A φ) ≡ φ
    mapRetrievable φ = refl

    proveEq : ∀ {X : Type ℓ''} (isSetX : isSet X) (f g : ⟨ R [ I ] ⟩ → X)
              → (var-eq : (x : I) → f (var x) ≡ g (var x))
              → (const-eq : (r : ⟨ R ⟩) → f (const r) ≡ g (const r))
              → (+-eq : (x y : ⟨ R [ I ] ⟩) → (eq-x : f x ≡ g x) → (eq-y : f y ≡ g y)
                        → f (x +c y) ≡ g (x +c y))
              → (·-eq : (x y : ⟨ R [ I ] ⟩) → (eq-x : f x ≡ g x) → (eq-y : f y ≡ g y)
                        → f (x ·c y) ≡ g (x ·c y))
              → (-eq : (x : ⟨ R [ I ] ⟩) → (eq-x : f x ≡ g x)
                        → f (-c x) ≡ g (-c x))
              → f ≡ g
    proveEq isSetX f g var-eq const-eq +-eq ·-eq -eq i (var x) = var-eq x i
    proveEq isSetX f g var-eq const-eq +-eq ·-eq -eq i (const x) = const-eq x i
    proveEq isSetX f g var-eq const-eq +-eq ·-eq -eq i (x +c y) =
      +-eq x y
           (λ i → proveEq isSetX f g var-eq const-eq +-eq ·-eq -eq i x)
           (λ i → proveEq isSetX f g var-eq const-eq +-eq ·-eq -eq i y)
           i
    proveEq isSetX f g var-eq const-eq +-eq ·-eq -eq i (-c x) =
      -eq x ((λ i → proveEq isSetX f g var-eq const-eq +-eq ·-eq -eq i x)) i
    proveEq isSetX f g var-eq const-eq +-eq ·-eq -eq i (x ·c y) =
      ·-eq x y
           (λ i → proveEq isSetX f g var-eq const-eq +-eq ·-eq -eq i x)
           (λ i → proveEq isSetX f g var-eq const-eq +-eq ·-eq -eq i y)
           i
    proveEq isSetX f g var-eq const-eq +-eq ·-eq -eq i (Construction.+-assoc x y z j) =
       let
        rec : (x : ⟨ R [ I ] ⟩) → f x ≡ g x
        rec x = (λ i → proveEq isSetX f g var-eq const-eq +-eq ·-eq -eq i x)
        a₀₋ : f (x +c (y +c z)) ≡ g (x +c (y +c z))
        a₀₋ = +-eq _ _ (rec x) (+-eq _ _ (rec y) (rec z))
        a₁₋ : f ((x +c y) +c z) ≡ g ((x +c y) +c z)
        a₁₋ = +-eq _ _ (+-eq _ _ (rec x) (rec y)) (rec z)
        a₋₀ : f (x +c (y +c z)) ≡ f ((x +c y) +c z)
        a₋₀ = cong f (Construction.+-assoc x y z)
        a₋₁ : g (x +c (y +c z)) ≡ g ((x +c y) +c z)
        a₋₁ = cong g (Construction.+-assoc x y z)
      in isSet→isSet' isSetX a₀₋ a₁₋ a₋₀ a₋₁ j i

    proveEq isSetX f g var-eq const-eq +-eq ·-eq -eq i (Construction.+-rid x j) =
       let
        rec : (x : ⟨ R [ I ] ⟩) → f x ≡ g x
        rec x = (λ i → proveEq isSetX f g var-eq const-eq +-eq ·-eq -eq i x)
        a₀₋ : f (x +c (const 0r)) ≡ g (x +c (const 0r))
        a₀₋ = +-eq _ _ (rec x) (const-eq 0r)
        a₁₋ : f x ≡ g x
        a₁₋ = rec x
        a₋₀ : f (x +c (const 0r)) ≡ f x
        a₋₀ = cong f (Construction.+-rid x)
        a₋₁ : g (x +c (const 0r)) ≡ g x
        a₋₁ = cong g (Construction.+-rid x)
      in isSet→isSet' isSetX a₀₋ a₁₋ a₋₀ a₋₁ j i

    proveEq isSetX f g var-eq const-eq +-eq ·-eq -eq i (Construction.+-rinv x j) =
       let
        rec : (x : ⟨ R [ I ] ⟩) → f x ≡ g x
        rec x = (λ i → proveEq isSetX f g var-eq const-eq +-eq ·-eq -eq i x)
        a₀₋ : f (x +c (-c x)) ≡ g (x +c (-c x))
        a₀₋ = +-eq x (-c x) (rec x) (-eq x (rec x))
        a₁₋ : f (const 0r) ≡ g (const 0r)
        a₁₋ = const-eq 0r
        a₋₀ : f (x +c (-c x)) ≡ f (const 0r)
        a₋₀ = cong f (Construction.+-rinv x)
        a₋₁ : g (x +c (-c x)) ≡ g (const 0r)
        a₋₁ = cong g (Construction.+-rinv x)
      in isSet→isSet' isSetX a₀₋ a₁₋ a₋₀ a₋₁ j i

    proveEq isSetX f g var-eq const-eq +-eq ·-eq -eq i (Construction.+-comm x y j) =
      let
        rec : (x : ⟨ R [ I ] ⟩) → f x ≡ g x
        rec x = (λ i → proveEq isSetX f g var-eq const-eq +-eq ·-eq -eq i x)
        a₀₋ : f (x +c y) ≡ g (x +c y)
        a₀₋ = +-eq x y (rec x) (rec y)
        a₁₋ : f (y +c x) ≡ g (y +c x)
        a₁₋ = +-eq y x (rec y) (rec x)
        a₋₀ : f (x +c y) ≡ f (y +c x)
        a₋₀ = cong f (Construction.+-comm x y)
        a₋₁ : g (x +c y) ≡ g (y +c x)
        a₋₁ = cong g (Construction.+-comm x y)
      in isSet→isSet' isSetX a₀₋ a₁₋ a₋₀ a₋₁ j i

    proveEq isSetX f g var-eq const-eq +-eq ·-eq -eq i (Construction.·-assoc x y z j) =
       let
        rec : (x : ⟨ R [ I ] ⟩) → f x ≡ g x
        rec x = (λ i → proveEq isSetX f g var-eq const-eq +-eq ·-eq -eq i x)
        a₀₋ : f (x ·c (y ·c z)) ≡ g (x ·c (y ·c z))
        a₀₋ = ·-eq _ _ (rec x) (·-eq _ _ (rec y) (rec z))
        a₁₋ : f ((x ·c y) ·c z) ≡ g ((x ·c y) ·c z)
        a₁₋ = ·-eq _ _ (·-eq _ _ (rec x) (rec y)) (rec z)
        a₋₀ : f (x ·c (y ·c z)) ≡ f ((x ·c y) ·c z)
        a₋₀ = cong f (Construction.·-assoc x y z)
        a₋₁ : g (x ·c (y ·c z)) ≡ g ((x ·c y) ·c z)
        a₋₁ = cong g (Construction.·-assoc x y z)
      in isSet→isSet' isSetX a₀₋ a₁₋ a₋₀ a₋₁ j i

    proveEq isSetX f g var-eq const-eq +-eq ·-eq -eq i (Construction.·-lid x j) =
       let
        rec : (x : ⟨ R [ I ] ⟩) → f x ≡ g x
        rec x = (λ i → proveEq isSetX f g var-eq const-eq +-eq ·-eq -eq i x)
        a₀₋ : f ((const 1r) ·c x) ≡ g ((const 1r) ·c x)
        a₀₋ = ·-eq _ _ (const-eq 1r) (rec x)
        a₁₋ : f x ≡ g x
        a₁₋ = rec x
        a₋₀ : f ((const 1r) ·c x) ≡ f x
        a₋₀ = cong f (Construction.·-lid x)
        a₋₁ : g ((const 1r) ·c x) ≡ g x
        a₋₁ = cong g (Construction.·-lid x)
      in isSet→isSet' isSetX a₀₋ a₁₋ a₋₀ a₋₁ j i

    proveEq isSetX f g var-eq const-eq +-eq ·-eq -eq i (Construction.·-comm x y j) =
       let
        rec : (x : ⟨ R [ I ] ⟩) → f x ≡ g x
        rec x = (λ i → proveEq isSetX f g var-eq const-eq +-eq ·-eq -eq i x)
        a₀₋ : f (x ·c y) ≡ g (x ·c y)
        a₀₋ = ·-eq _ _ (rec x) (rec y)
        a₁₋ : f (y ·c x) ≡ g (y ·c x)
        a₁₋ = ·-eq _ _ (rec y) (rec x)
        a₋₀ : f (x ·c y) ≡ f (y ·c x)
        a₋₀ = cong f (Construction.·-comm x y)
        a₋₁ : g (x ·c y) ≡ g (y ·c x)
        a₋₁ = cong g (Construction.·-comm x y)
      in isSet→isSet' isSetX a₀₋ a₁₋ a₋₀ a₋₁ j i

    proveEq isSetX f g var-eq const-eq +-eq ·-eq -eq i (Construction.ldist x y z j) =
       let
        rec : (x : ⟨ R [ I ] ⟩) → f x ≡ g x
        rec x = (λ i → proveEq isSetX f g var-eq const-eq +-eq ·-eq -eq i x)
        a₀₋ : f ((x +c y) ·c z) ≡ g ((x +c y) ·c z)
        a₀₋ = ·-eq (x +c y) z
           (+-eq _ _ (rec x) (rec y))
           (rec z)
        a₁₋ : f ((x ·c z) +c (y ·c z)) ≡ g ((x ·c z) +c (y ·c z))
        a₁₋ = +-eq _ _ (·-eq _ _ (rec x) (rec z)) (·-eq _ _ (rec y) (rec z))
        a₋₀ : f ((x +c y) ·c z) ≡ f ((x ·c z) +c (y ·c z))
        a₋₀ = cong f (Construction.ldist x y z)
        a₋₁ : g ((x +c y) ·c z) ≡ g ((x ·c z) +c (y ·c z))
        a₋₁ = cong g (Construction.ldist x y z)
      in isSet→isSet' isSetX a₀₋ a₁₋ a₋₀ a₋₁ j i

    proveEq isSetX f g var-eq const-eq +-eq ·-eq -eq i (Construction.+HomConst s t j) =
       let
        rec : (x : ⟨ R [ I ] ⟩) → f x ≡ g x
        rec x = (λ i → proveEq isSetX f g var-eq const-eq +-eq ·-eq -eq i x)
        a₀₋ : f (const (s +r t)) ≡ g (const (s +r t))
        a₀₋ = const-eq (s +r t)
        a₁₋ : f (const s +c const t) ≡ g (const s +c const t)
        a₁₋ = +-eq _ _ (const-eq s) (const-eq t)
        a₋₀ : f (const (s +r t)) ≡ f (const s +c const t)
        a₋₀ = cong f (Construction.+HomConst s t)
        a₋₁ : g (const (s +r t)) ≡ g (const s +c const t)
        a₋₁ = cong g (Construction.+HomConst s t)
      in isSet→isSet' isSetX a₀₋ a₁₋ a₋₀ a₋₁ j i

    proveEq isSetX f g var-eq const-eq +-eq ·-eq -eq i (Construction.·HomConst s t j) =
       let
        rec : (x : ⟨ R [ I ] ⟩) → f x ≡ g x
        rec x = (λ i → proveEq isSetX f g var-eq const-eq +-eq ·-eq -eq i x)
        a₀₋ : f (const (s ·r t)) ≡ g (const (s ·r t))
        a₀₋ = const-eq (s ·r t)
        a₁₋ : f (const s ·c const t) ≡ g (const s ·c const t)
        a₁₋ = ·-eq _ _ (const-eq s) (const-eq t)
        a₋₀ : f (const (s ·r t)) ≡ f (const s ·c const t)
        a₋₀ = cong f (Construction.·HomConst s t)
        a₋₁ : g (const (s ·r t)) ≡ g (const s ·c const t)
        a₋₁ = cong g (Construction.·HomConst s t)
      in isSet→isSet' isSetX a₀₋ a₁₋ a₋₀ a₋₁ j i

    proveEq isSetX f g var-eq const-eq +-eq ·-eq -eq i (Construction.0-trunc x y p q j k) =
      let
        P : (x : ⟨ R [ I ] ⟩) → f x ≡ g x
        P x i = proveEq isSetX f g var-eq const-eq +-eq ·-eq -eq i x
        Q : (x : ⟨ R [ I ] ⟩) → f x ≡ g x
        Q x i = proveEq isSetX f g var-eq const-eq +-eq ·-eq -eq i x
      in isOfHLevel→isOfHLevelDep 2
           (λ z → isProp→isSet (isSetX (f z) (g z))) _ _
           (cong P p)
           (cong Q q)
           (Construction.0-trunc x y p q) j k i

    homRetrievable : ∀ (f : Hom)
                     → inducedMap A (evaluateAt f) ≡ fst f
    homRetrievable f =
       proveEq
        (isSetAlgebra (CommAlgebra→Algebra A))
        (inducedMap A (evaluateAt f))
        (λ x → f $a x)
        (λ x → refl)
        (λ r → r ⋆ 1a                     ≡⟨ cong (λ u → r ⋆ u) (sym f.pres1) ⟩
               r ⋆ (f $a (const 1r))      ≡⟨ sym (f.pres⋆ r _) ⟩
               f $a (const r ·c const 1r) ≡⟨ cong (λ u → f $a u) (sym (Construction.·HomConst r 1r)) ⟩
               f $a (const (r ·r 1r))     ≡⟨ cong (λ u → f $a (const u)) (·r-rid r) ⟩
               f $a (const r) ∎)

        (λ x y eq-x eq-y →
              ι (x +c y)            ≡⟨ refl ⟩
              (ι x + ι y)           ≡⟨ cong (λ u → u + ι y) eq-x ⟩
              ((f $a x) + ι y)      ≡⟨
                                     cong (λ u → (f $a x) + u) eq-y ⟩
              ((f $a x) + (f $a y)) ≡⟨ sym (f.pres+ _ _) ⟩ (f $a (x +c y)) ∎)

        (λ x y eq-x eq-y →
           ι (x ·c y)          ≡⟨ refl ⟩
           ι x     · ι y       ≡⟨ cong (λ u → u · ι y) eq-x ⟩
           (f $a x) · (ι y)    ≡⟨ cong (λ u → (f $a x) · u) eq-y ⟩
           (f $a x) · (f $a y) ≡⟨ sym (f.pres· _ _) ⟩
           f $a (x ·c y) ∎)
       (λ x eq-x →
           ι (-c x)    ≡⟨ refl ⟩
           - ι x       ≡⟨ cong (λ u → - u) eq-x ⟩
           - (f $a x)  ≡⟨ sym (f.pres- x) ⟩
           f $a (-c x) ∎)
      where
      ι = inducedMap A (evaluateAt f)
      module f = IsAlgebraHom (f .snd)

evaluateAt : {R : CommRing ℓ} {I : Type ℓ'} (A : CommAlgebra R ℓ'')
             (f : CommAlgebraHom (R [ I ]) A)
             → (I → fst A)
evaluateAt A f x = f $a (Construction.var x)

inducedHom : {R : CommRing ℓ} {I : Type ℓ'} (A : CommAlgebra R ℓ'')
             (φ : I → fst A )
             → CommAlgebraHom (R [ I ]) A
inducedHom A φ = Theory.inducedHom A φ

homMapIso : {R : CommRing ℓ} {I : Type ℓ} (A : CommAlgebra R ℓ')
             → Iso (CommAlgebraHom (R [ I ]) A) (I → (fst A))
Iso.fun (homMapIso A) = evaluateAt A
Iso.inv (homMapIso A) = inducedHom A
Iso.rightInv (homMapIso A) = λ ϕ → Theory.mapRetrievable A ϕ
Iso.leftInv (homMapIso {R = R} {I = I} A) =
  λ f → Σ≡Prop (λ f → isPropIsCommAlgebraHom {M = R [ I ]} {N = A} f)
               (Theory.homRetrievable A f)

homMapPath : {R : CommRing ℓ} {I : Type ℓ} (A : CommAlgebra R ℓ')
             → CommAlgebraHom (R [ I ]) A ≡ (I → fst A)
homMapPath A = isoToPath (homMapIso A)

module _ {R : CommRing ℓ} {A B : CommAlgebra R ℓ''} where
  open AlgebraHoms
  A′ = CommAlgebra→Algebra A
  B′ = CommAlgebra→Algebra B
  R′ = (CommRing→Ring R)
  ν : AlgebraHom A′ B′ → (⟨ A ⟩ → ⟨ B ⟩)
  ν φ = φ .fst

  {-
    Hom(R[I],A) → (I → A)
         ↓          ↓
    Hom(R[I],B) → (I → B)
  -}
  naturalR : {I : Type ℓ'} (ψ : CommAlgebraHom A B)
             (f : CommAlgebraHom (R [ I ]) A)
             → (fst ψ) ∘ evaluateAt A f ≡ evaluateAt B (ψ ∘a f)
  naturalR ψ f = refl

  {-
    Hom(R[I],A) → (I → A)
         ↓          ↓
    Hom(R[J],A) → (J → A)
  -}
  naturalL : {I J : Type ℓ'} (φ : J → I)
             (f : CommAlgebraHom (R [ I ]) A)
             → (evaluateAt A f) ∘ φ
               ≡ evaluateAt A (f ∘a (inducedHom (R [ I ]) (λ x → Construction.var (φ x))))
  naturalL φ f = refl

module _ {R : CommRing ℓ} where
  {-
    Prove that the FreeCommAlgebra over R on zero generators is
    isomorphic to the initial R-Algebra - R itsself.
  -}
  freeOn⊥ : CommAlgebraEquiv (R [ ⊥ ]) (initialCAlg R)
  freeOn⊥ =
     equivByInitiality
        R (R [ ⊥ ])
          {- Show that R[⊥] has the universal property of the
             initial R-Algbera and conclude that those are isomorphic -}
        λ B →  let to : CommAlgebraHom (R [ ⊥ ]) B → (⊥ → fst B)
                   to = evaluateAt B

                   from :  (⊥ → fst B) → CommAlgebraHom (R [ ⊥ ]) B
                   from = inducedHom B

                   from-to : (x : _) → from (to x) ≡ x
                   from-to x =
                     Σ≡Prop (λ f → isPropIsCommAlgebraHom {M = R [ ⊥ ]} {N = B} f)
                            (Theory.homRetrievable B x)

                   equiv : CommAlgebraHom (R [ ⊥ ]) B ≃ (⊥ → fst B)
                   equiv =
                     isoToEquiv
                       (iso to from (λ x → isContr→isOfHLevel 1 isContr⊥→A _ _) from-to)
               in isOfHLevelRespectEquiv 0 (invEquiv equiv) isContr⊥→A


module Colist where

open import Size using (Size ; Size<_)

data Colist (i : Size) {a} (A : Set a) : Set a

record ∞Colist (i : Size) {a} (A : Set a) : Set a where
  coinductive
  constructor delay_
  field force : ∀ {j : Size< i} → Colist j A

data Colist (i : Size) {a} (A : Set a) where
  [] : Colist i A
  _∷_ : (x : A) (xs : ∞Colist i A) → Colist i A


module IPC.Metatheory.Gentzen-KripkeExploding where

open import IPC.Syntax.Gentzen public
open import IPC.Semantics.KripkeExploding public

-- Soundness with respect to all models, or evaluation.

eval : ∀ {A Γ} → Γ ⊢ A → Γ ⊨ A
eval (var i)                  γ = lookup i γ
eval (lam {A} {B} t)          γ = return {A ▻ B} λ ξ a →
                                    eval t (mono⊩⋆ ξ γ , a)
eval (app {A} {B} t u)        γ = bind {A ▻ B} {B} (eval t γ) λ ξ f →
                                    _⟪$⟫_ {A} {B} f (eval u (mono⊩⋆ ξ γ))
eval (pair {A} {B} t u)       γ = return {A ∧ B} (eval t γ , eval u γ)
eval (fst {A} {B} t)          γ = bind {A ∧ B} {A} (eval t γ) (K π₁)
eval (snd {A} {B} t)          γ = bind {A ∧ B} {B} (eval t γ) (K π₂)
eval unit                     γ = return {⊤} ∙
eval (boom {C} t)             γ = bind {⊥} {C} (eval t γ) (K elim𝟘)
eval (inl {A} {B} t)          γ = return {A ∨ B} (ι₁ (eval t γ))
eval (inr {A} {B} t)          γ = return {A ∨ B} (ι₂ (eval t γ))
eval (case {A} {B} {C} t u v) γ = bind {A ∨ B} {C} (eval t γ) λ ξ s → elim⊎ s
                                    (λ a → eval u (mono⊩⋆ ξ γ , λ ξ′ k → a ξ′ k))
                                    (λ b → eval v (mono⊩⋆ ξ γ , λ ξ′ k → b ξ′ k))

-- TODO: Correctness of evaluation with respect to conversion.

-- The canonical model.

private
  instance
    canon : Model
    canon = record
      { World   = Cx Ty
      ; _≤_     = _⊆_
      ; refl≤   = refl⊆
      ; trans≤  = trans⊆
      ; _⊪ᵅ_   = λ Γ P → Γ ⊢ α P
      ; mono⊪ᵅ = mono⊢
      ; _‼_     = λ Γ A → Γ ⊢ A
      }

-- Soundness and completeness with respect to the canonical model.

mutual
  reflectᶜ : ∀ {A Γ} → Γ ⊢ A → Γ ⊩ A
  reflectᶜ {α P}   t = return {α P} t
  reflectᶜ {A ▻ B} t = return {A ▻ B} λ η a →
                         reflectᶜ {B} (app (mono⊢ η t) (reifyᶜ {A} a))
  reflectᶜ {A ∧ B} t = return {A ∧ B} (reflectᶜ {A} (fst t) , reflectᶜ {B} (snd t))
  reflectᶜ {⊤}    t = return {⊤} ∙
  reflectᶜ {⊥}    t = λ η k → boom (mono⊢ η t)
  reflectᶜ {A ∨ B} t = λ η k → case (mono⊢ η t)
                                  (k weak⊆ (ι₁ (reflectᶜ {A} v₀)))
                                  (k weak⊆ (ι₂ (reflectᶜ {B} (v₀))))

  reifyᶜ : ∀ {A Γ} → Γ ⊩ A → Γ ⊢ A
  reifyᶜ {α P}   k = k refl≤ λ η s → s
  reifyᶜ {A ▻ B} k = k refl≤ λ η s → lam (reifyᶜ {B} (s weak⊆ (reflectᶜ {A} (v₀))))
  reifyᶜ {A ∧ B} k = k refl≤ λ η s → pair (reifyᶜ {A} (π₁ s)) (reifyᶜ {B} (π₂ s))
  reifyᶜ {⊤}    k = k refl≤ λ η s → unit
  reifyᶜ {⊥}    k = k refl≤ λ η ()
  reifyᶜ {A ∨ B} k = k refl≤ λ η s → elim⊎ s
                                        (λ a → inl (reifyᶜ {A} (λ η′ k → a η′ k)))
                                        (λ b → inr (reifyᶜ {B} (λ η′ k → b η′ k)))

reflectᶜ⋆ : ∀ {Ξ Γ} → Γ ⊢⋆ Ξ → Γ ⊩⋆ Ξ
reflectᶜ⋆ {∅}     ∙        = ∙
reflectᶜ⋆ {Ξ , A} (ts , t) = reflectᶜ⋆ ts , reflectᶜ t

reifyᶜ⋆ : ∀ {Ξ Γ} → Γ ⊩⋆ Ξ → Γ ⊢⋆ Ξ
reifyᶜ⋆ {∅}     ∙        = ∙
reifyᶜ⋆ {Ξ , A} (ts , t) = reifyᶜ⋆ ts , reifyᶜ t

-- Reflexivity and transitivity.

refl⊩⋆ : ∀ {Γ} → Γ ⊩⋆ Γ
refl⊩⋆ = reflectᶜ⋆ refl⊢⋆

trans⊩⋆ : ∀ {Γ Γ′ Γ″} → Γ ⊩⋆ Γ′ → Γ′ ⊩⋆ Γ″ → Γ ⊩⋆ Γ″
trans⊩⋆ ts us = reflectᶜ⋆ (trans⊢⋆ (reifyᶜ⋆ ts) (reifyᶜ⋆ us))

-- Completeness with respect to all models, or quotation.

quot : ∀ {A Γ} → Γ ⊨ A → Γ ⊢ A
quot s = reifyᶜ (s refl⊩⋆)

-- Normalisation by evaluation.

norm : ∀ {A Γ} → Γ ⊢ A → Γ ⊢ A
norm = quot ∘ eval

-- TODO: Correctness of normalisation with respect to conversion.


module UnSizedIO.IOObject where

open import Data.Product

open import UnSizedIO.Base
open import UnSizedIO.Object

-- An IO object is like a simple object,
-- but the method returns IO applied to the result type of a simple object
-- which means the method returns an IO program which when terminating
-- returns the result of the simple object

module _  (ioi  : IOInterface)  (let C  = Command ioi)  (let R   = Response ioi)
          (oi   : Interface)   (let M  = Method oi)    (let Rt  = Result oi)
  where

  record IOObject : Set where
    coinductive
    field
      method : (m : M) → IO ioi (Rt m × IOObject)

open IOObject public


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

module README where

-- Formalization for "Decidability of Conversion for Type Theory in Type Theory"
-- Git repository: https://github.com/mr-ohman/logrel-mltt

------------------
-- INTRODUCTION --
------------------

-- A minimal library necessary for formalization:

-- Embedding types into larger universes
import Tools.Embedding

-- The empty type and its elimination rule.
import Tools.Empty

-- The unit type.
import Tools.Unit

-- Sum type.
import Tools.Sum

-- Product type.
import Tools.Product

-- Identity function and composition.
import Tools.Function

-- Negation and decidability type.
import Tools.Nullary

-- Propositional equality and its properties.
import Tools.PropositionalEquality

-- Natural numbers and decidability of equality.
import Tools.Nat

---------------------------
-- LANGUAGE INTRODUCTION --
---------------------------

-- Syntax and semantics of weakening and substitution.
import Definition.Untyped

-- Propositional equality properties: Equalities between expressions,
-- weakenings, substitutions and their combined composition.
-- (These lemmas are not in the paper.)
import Definition.Untyped.Properties

-- Judgements: Typing rules, conversion, reduction rules
-- and well-formed substitutions and respective equality.
import Definition.Typed

-- Well-formed context extraction and reduction properties.
import Definition.Typed.Properties

-- Well-formed weakening and its properties.
import Definition.Typed.Weakening

------------------------------
-- KRIPKE LOGICAL RELATIONS --
------------------------------

-- Generic equality relation definition.
import Definition.Typed.EqualityRelation

-- The judgemental instance of the generic equality.
import Definition.Typed.EqRelInstance

-- Logical relations definitions.
import Definition.LogicalRelation

-- Properties of logical relation:

-- Reflexivity of the logical relation.
import Definition.LogicalRelation.Properties.Reflexivity

-- Escape lemma for the logical relation.
import Definition.LogicalRelation.Properties.Escape

-- Shape view of two or more types.
import Definition.LogicalRelation.ShapeView

-- Proof irrelevance for the logical relation.
import Definition.LogicalRelation.Irrelevance

-- Weakening of logical relation judgements.
import Definition.LogicalRelation.Weakening

-- Conversion of the logical relation.
import Definition.LogicalRelation.Properties.Conversion

-- Symmetry of the logical relation.
import Definition.LogicalRelation.Properties.Symmetry

-- Transitvity of the logical relation.
import Definition.LogicalRelation.Properties.Transitivity

-- Neutral introduction in the logical relation.
import Definition.LogicalRelation.Properties.Neutral

-- Weak head expansion of the logical relation.
import Definition.LogicalRelation.Properties.Reduction

-- Application in the logical relation.
import Definition.LogicalRelation.Application

-- Validity judgements definitions
import Definition.LogicalRelation.Substitution

-- Properties of validity judgements:

-- Proof irrelevance for the validity judgements.
import Definition.LogicalRelation.Substitution.Irrelevance

-- Properties about valid substitutions:
-- * Substitution well-formedness.
-- * Substitution weakening.
-- * Substitution lifting.
-- * Identity substitution.
-- * Reflexivity, symmetry and transitivity of substitution equality.
import Definition.LogicalRelation.Substitution.Properties

-- Single term substitution of validity judgements.
import Definition.LogicalRelation.Substitution.Introductions.SingleSubst

-- The fundamental theorem.
import Definition.LogicalRelation.Fundamental

-- Certain cases of the logical relation:

-- Validity of Π-types.
import Definition.LogicalRelation.Substitution.Introductions.Pi

-- Validity of applications.
import Definition.LogicalRelation.Substitution.Introductions.Application

-- Validity of λ-terms.
import Definition.LogicalRelation.Substitution.Introductions.Lambda

-- Validity of natural recursion of natural numbers.
import Definition.LogicalRelation.Substitution.Introductions.Natrec

-- Reducibility of well-formedness.
import Definition.LogicalRelation.Fundamental.Reducibility

-- Consequences of the fundamental theorem:

-- Canonicity of the system.
import Definition.Typed.Consequences.Canonicity

-- Injectivity of Π-types.
import Definition.Typed.Consequences.Injectivity

-- Syntactic validitiy of the system.
import Definition.Typed.Consequences.Syntactic

-- All types and terms fully reduce to WHNF.
import Definition.Typed.Consequences.Reduction

-- Strong equality of types.
import Definition.Typed.Consequences.Equality

-- Substiution in judgements and substitution composition.
import Definition.Typed.Consequences.Substitution

-- Uniqueness of the types of neutral terms.
import Definition.Typed.Consequences.NeTypeEq

-- Universe membership of types.
import Definition.Typed.Consequences.InverseUniv

-- Consistency of the type theory.
import Definition.Typed.Consequences.Consistency


module Issue734a where

module M₁ (Z : Set₁) where

  postulate
    P : Set
    Q : Set → Set

module M₂ (X Y : Set) where

  module M₁′ = M₁ Set
  open M₁′

  p : P
  p = {!!}

  -- Previous and current agda2-goal-and-context:

  -- Y : Set
  -- X : Set
  -- ---------
  -- Goal: P

  q : Q X
  q = {!!}

  -- Previous and current agda2-goal-and-context:

  -- Y : Set
  -- X : Set
  -- -----------
  -- Goal: Q X

postulate X : Set

pp : M₂.M₁′.P X X
pp = {!!}

  -- Previous agda2-goal-and-context:

  -- ----------------
  -- Goal: M₁.P Set

  -- Current agda2-goal-and-context:

  -- --------------------
  -- Goal: M₂.M₁′.P X X


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

open import Algebra

module Magma.Properties
  {a ℓ} (M : Magma a ℓ) where

open Magma M


{-# OPTIONS --safe --no-qualified-instances #-}
{- Noop removal transformation on bytecode -}
module JVM.Transform.Noooops where

open import Data.Product
open import Data.Sum
open import Function using (case_of_)
open import Data.List
open import Relation.Unary hiding (Empty)
open import Relation.Binary.Structures
open import Relation.Binary.PropositionalEquality using (refl; _≡_)
open import Relation.Ternary.Core
open import Relation.Ternary.Structures
open import Relation.Ternary.Structures.Syntax hiding (_∣_)

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

open import Relation.Ternary.Data.ReflexiveTransitive {{intf-rel}}

open IsEquivalence {{...}} using (sym)
open import Data.Maybe using (just; nothing; Maybe)

is-noop : ∀[ ⟨ 𝑭 ∣ ψ₁ ↝ ψ₂ ⟩ ⇒ (Empty (ψ₁ ≡ ψ₂) ∪ U) ]
is-noop noop = inj₁ (emp refl)
is-noop _    = inj₂ _

noooop : ∀[ ⟪ 𝑭 ∣ ψ₁ ↝ ψ₂ ⟫ ⇒ ⟪ 𝑭 ∣ ψ₁ ↝ ψ₂ ⟫ ]
noooop nil = nil

-- (1) not labeled
noooop (cons (instr (↓ i) ∙⟨ σ ⟩ is)) =
  case (is-noop i) of λ where
    (inj₂ _)          → instr (↓ i) ▹⟨ σ ⟩ noooop is
    (inj₁ (emp refl)) → coe (∙-id⁻ˡ σ) (noooop is)

-- (2) is labeled
noooop (cons (li@(labeled (l ∙⟨ σ₀ ⟩ ↓ i)) ∙⟨ σ ⟩ is)) =
  case (is-noop i) of λ where
    (inj₂ _)          → cons (li ∙⟨ σ ⟩ noooop is)
    (inj₁ (emp refl)) → label-start noop l ⟨ coe {{∙-respects-≈ˡ}} (≈-sym (∙-id⁻ʳ σ₀)) σ ⟩ (noooop is)


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

open import Categories.Category.Core

module Categories.Morphism.Extremal.Properties {o ℓ e} (𝒞 : Category o ℓ e) where

open import Level
open import Function using (_$_)

open import Categories.Diagram.Equalizer 𝒞
open import Categories.Diagram.Coequalizer 𝒞

open import Categories.Morphism 𝒞
open import Categories.Morphism.Extremal 𝒞
open import Categories.Morphism.Properties 𝒞
open import Categories.Morphism.Reasoning 𝒞
open import Categories.Morphism.Regular 𝒞

open Category 𝒞
open HomReasoning

private
  variable
    A B : Obj
    f g : A ⇒ B

--------------------------------------------------------------------------------
-- Extremal Epimorphisms

RegularEpi⇒IsExtremalEpi : ∀ {A B} {f : A ⇒ B} (e : RegularEpi f) → IsExtremalEpi (RegularEpi⇒Epi e)
RegularEpi⇒IsExtremalEpi {A = A} {B = B} {f = f} regular {X = X} {i = i} {g = k} i-mono f≈i∘k =
  record
    { inv = i⁻¹
    ; iso = record
      { isoˡ = isoˡ
      ; isoʳ = isoʳ
      }
    }
  where
    open RegularEpi regular renaming (g to r; h to s)
    open IsCoequalizer coequalizer

    i⁻¹ : B ⇒ X
    i⁻¹ = coequalize $ i-mono (k ∘ s) (k ∘ r) $ begin
        i ∘ k ∘ s ≈⟨ pullˡ (⟺ f≈i∘k) ⟩
        f ∘ s     ≈⟨ equality ⟩
        f ∘ r     ≈⟨ pushˡ f≈i∘k ⟩
        i ∘ k ∘ r ∎

    isoʳ : i ∘ i⁻¹ ≈ id
    isoʳ = RegularEpi⇒Epi regular (i ∘ i⁻¹) id $ begin
      (i ∘ i⁻¹) ∘ f ≈⟨ pullʳ (⟺ universal) ⟩
      i ∘ k         ≈˘⟨ f≈i∘k ⟩
      f             ≈˘⟨ identityˡ ⟩
      id ∘ f        ∎

    isoˡ : i⁻¹ ∘ i ≈ id
    isoˡ = i-mono (i⁻¹ ∘ i) id $ begin
      i ∘ i⁻¹ ∘ i ≈⟨ cancelˡ isoʳ ⟩
      i           ≈˘⟨ identityʳ ⟩
      i ∘ id      ∎

RegularEpi⇒ExtremalEpi : (e : RegularEpi f) → ExtremalEpi f
RegularEpi⇒ExtremalEpi e = record
  { epi = RegularEpi⇒Epi e
  ; extremal = RegularEpi⇒IsExtremalEpi e
  }

ExtremalEpi-∘₂ : ExtremalEpi (f ∘ g) → ExtremalEpi f
ExtremalEpi-∘₂ fg-extremal = record
  { epi = Epi-∘₂ epi
  ; extremal = λ i-mono eq → extremal i-mono (pushˡ eq)
  }
  where
    open ExtremalEpi fg-extremal

ExtremalEpi-∘ : ∀ {A B C} {f : B ⇒ C} {g : A ⇒ B} → ExtremalEpi f → RegularEpi g → ExtremalEpi (f ∘ g)
ExtremalEpi-∘ {A = A} {B = B} {C = C} {f = f} {g = g} f-extremal g-regular = record
  { epi = fg-epi
  ; extremal = fg-extremal
  }
  where
    module f-extremal = ExtremalEpi f-extremal
    module g-regular = RegularEpi g-regular
    open IsCoequalizer g-regular.coequalizer

    g-epi : Epi g
    g-epi = RegularEpi⇒Epi g-regular

    fg-epi : Epi (f ∘ g)
    fg-epi = Epi-∘ f-extremal.epi g-epi

    fg-extremal : IsExtremalEpi fg-epi
    fg-extremal {X = X} {i = i} {g = h} i-mono f∘g≈i∘h =
      f-extremal.extremal i-mono $ g-epi _ _ $ begin
        f ∘ g       ≈⟨ f∘g≈i∘h ⟩
        i ∘ h       ≈⟨ pushʳ universal ⟩
        (i ∘ k) ∘ g ∎
      where
        k : B ⇒ X
        k = coequalize $ i-mono _ _ $ begin
          i ∘ h ∘ g-regular.h ≈⟨ extendʳ (⟺ f∘g≈i∘h) ⟩
          f ∘ g ∘ g-regular.h ≈⟨ refl⟩∘⟨ equality ⟩
          f ∘ g ∘ g-regular.g ≈⟨ extendʳ f∘g≈i∘h ⟩
          i ∘ h ∘ g-regular.g ∎

ExtremalEpi+Mono⇒IsIso : ExtremalEpi f → Mono f → IsIso f
ExtremalEpi+Mono⇒IsIso {f = f} f-extremal f-mono = extremal f-mono (⟺ identityʳ)
  where
    open ExtremalEpi f-extremal

--------------------------------------------------------------------------------
-- Extremal Monomorphisms

RegularMono⇒IsExtremalMono : ∀ {A B} {f : A ⇒ B} (m : RegularMono f) → IsExtremalMono (RegularMono⇒Mono m)
RegularMono⇒IsExtremalMono {A = A} {B = B} {f = f} regular {X = X} {g = k} {i = i} i-epi f≈k∘i =
  record
    { inv = i⁻¹
    ; iso = record
      { isoˡ = isoˡ
      ; isoʳ = isoʳ
      }
    }
    where
      open RegularMono regular renaming (g to r; h to s)
      open IsEqualizer equalizer

      i⁻¹ : X ⇒ A
      i⁻¹ = equalize $ i-epi (s ∘ k) (r ∘ k) $ begin
        (s ∘ k) ∘ i ≈⟨ pullʳ (⟺ f≈k∘i) ⟩
        s ∘ f       ≈⟨ equality ⟩
        r ∘ f       ≈⟨ pushʳ f≈k∘i ⟩
        (r ∘ k) ∘ i ∎

      isoˡ : i⁻¹ ∘ i ≈ id
      isoˡ = RegularMono⇒Mono regular (i⁻¹ ∘ i) id $ begin
        f ∘ i⁻¹ ∘ i ≈⟨ pullˡ (⟺ universal) ⟩
        k ∘ i       ≈˘⟨ f≈k∘i ⟩
        f           ≈˘⟨ identityʳ ⟩
        f ∘ id      ∎

      isoʳ : i ∘ i⁻¹ ≈ id
      isoʳ = i-epi (i ∘ i⁻¹) id $ begin
        (i ∘ i⁻¹) ∘ i ≈⟨ cancelʳ isoˡ ⟩
        i             ≈˘⟨ identityˡ ⟩
        id ∘ i        ∎

RegularMono⇒ExtremalMono : RegularMono f → ExtremalMono f
RegularMono⇒ExtremalMono m = record
  { mono = RegularMono⇒Mono m
  ; extremal = RegularMono⇒IsExtremalMono m
  }

ExtremalMono-∘₂ : ExtremalMono (f ∘ g) → ExtremalMono g
ExtremalMono-∘₂ fg-extremal = record
  { mono = Mono-∘₂ mono
  ; extremal = λ i-epi eq → extremal i-epi (pushʳ eq)
  }
  where
    open ExtremalMono fg-extremal

ExtremalMono-∘ : ∀ {A B C} {f : B ⇒ C} {g : A ⇒ B} → RegularMono f → ExtremalMono g → ExtremalMono (f ∘ g)
ExtremalMono-∘ {A = A} {B = B} {f = f} {g = g} f-regular g-extremal = record
  { mono = fg-mono
  ; extremal = fg-extremal
  }
  where
    module f-regular = RegularMono f-regular
    open IsEqualizer f-regular.equalizer
    module g-extremal = ExtremalMono g-extremal

    f-mono : Mono f
    f-mono = (RegularMono⇒Mono f-regular)

    fg-mono : Mono (f ∘ g)
    fg-mono = Mono-∘ f-mono g-extremal.mono

    fg-extremal : IsExtremalMono fg-mono
    fg-extremal {X = X} {g = h} {i = e} e-epi f∘g≈h∘e =
      g-extremal.extremal e-epi $ f-mono _ _ $ begin
      f ∘ g     ≈⟨ f∘g≈h∘e ⟩
      h ∘ e     ≈⟨ pushˡ universal ⟩
      f ∘ k ∘ e ∎
      where
        k : X ⇒ B
        k = equalize $ e-epi _ _ $ begin
          (f-regular.h ∘ h) ∘ e ≈⟨ extendˡ (⟺ f∘g≈h∘e) ⟩
          (f-regular.h ∘ f) ∘ g ≈⟨ equality ⟩∘⟨refl ⟩
          (f-regular.g ∘ f) ∘ g ≈⟨ extendˡ f∘g≈h∘e ⟩
          (f-regular.g ∘ h) ∘ e ∎

ExtremalMono+Epi⇒IsIso : ExtremalMono f → Epi f → IsIso f
ExtremalMono+Epi⇒IsIso {f = f} f-extremal f-epi = extremal f-epi (⟺ identityˡ)
  where
    open ExtremalMono f-extremal

--------------------------------------------------------------------------------
-- Extremal Morphisms in Balanced Categories
-- https://ncatlab.org/nlab/show/balanced+category

module _ (balanced : ∀ {A B} {f : A ⇒ B} → Mono f → Epi f → IsIso f) where

  Mono+Epi⇒IsExtremalEpi : (e : Epi f) → IsExtremalEpi e
  Mono+Epi⇒IsExtremalEpi {f = f} f-epi {i = i} {g = g} i-mono f≈i∘g = balanced i-mono i-epi
    where
      i-epi : Epi i
      i-epi g₁ g₂ g₁∘i≈g₂∘i = f-epi g₁ g₂ $ begin
        g₁ ∘ f       ≈⟨ pushʳ f≈i∘g ⟩
        (g₁ ∘ i) ∘ g ≈⟨ g₁∘i≈g₂∘i ⟩∘⟨refl ⟩
        (g₂ ∘ i) ∘ g ≈⟨ pullʳ (⟺ f≈i∘g) ⟩
        g₂ ∘ f ∎

  Mono+Epi⇒IsExtremalMono : (m : Mono f) → IsExtremalMono m
  Mono+Epi⇒IsExtremalMono {f = f} f-mono {g = g} {i = i} i-epi f≈g∘i = balanced i-mono i-epi
    where
      i-mono : Mono i
      i-mono g₁ g₂ i∘g₁≈i∘g₂ = f-mono g₁ g₂ $ begin
        f ∘ g₁     ≈⟨ pushˡ f≈g∘i ⟩
        g ∘ i ∘ g₁ ≈⟨ refl⟩∘⟨ i∘g₁≈i∘g₂ ⟩
        g ∘ i ∘ g₂ ≈⟨ pullˡ (⟺ f≈g∘i) ⟩
        f ∘ g₂     ∎


open import MLib.Algebra.PropertyCode

module MLib.Algebra.PropertyCode.Dependent {k c ℓ} {code : Code k} (struct : Struct code c ℓ) where

open import MLib.Prelude
open import MLib.Algebra.PropertyCode.Core

open import Function.Equivalence using (Equivalence)

open Struct struct

private
  module FuncBased {c′ ℓ′} (depRawStruct : RawStruct K c′ ℓ′) (props : ∀ π → Maybe (∃ λ deps → ⦃ _ : Hasₚ deps ⦄ → ⟦ π ⟧P depRawStruct)) where
    Π′ : Properties code
    Π′ = properties λ π →
      case props π of λ
      { (just (deps , _)) → implies deps Π
      ; nothing → false
      }

    Π′-prop : ∀ {π} → π ∈ₚ Π′ → ∃ λ x → props π ≡ just x
    Π′-prop {π} π∈Π′ with props π | ≡.inspect props π
    Π′-prop {π} π∈Π′ | just x | _ = x , ≡.refl
    Π′-prop {π} (fromTruth truth) | nothing | ≡.[ eq ] rewrite eq = ⊥-elim truth

    reify′ : ∀ {π} → π ∈ₚ Π′ → ⟦ π ⟧P depRawStruct
    reify′ {π} π∈Π′ with Π′-prop π∈Π′ | hasProperty Π′ π | ≡.inspect (hasProperty Π′) π
    reify′ {_} (fromTruth truth) | (deps , f) , eq | false | ≡.[ eq₁ ] rewrite eq | eq₁ = ⊥-elim truth
    reify′ {_} (fromTruth truth) | (deps , f) , eq | true | ≡.[ eq₁ ] rewrite eq = f ⦃ fromTruth truth  ⦄

    dependentStruct :
      Struct code c′ ℓ′
    dependentStruct = record
      { rawStruct = depRawStruct
      ; Π = Π′
      ; reify = reify′
      }

  module ListBased {c′ ℓ′} (depRawStruct : RawStruct K c′ ℓ′) (props : List (∃₂ λ π deps → ⦃ _ : Hasₚ deps ⦄ → ⟦ π ⟧P depRawStruct)) where
    Func = ∀ π → Maybe (∃ (λ deps → ⦃ _ : Hasₚ deps ⦄ → ⟦ π ⟧P depRawStruct))

    singleFunc : (∃₂ λ π deps → ⦃ _ : Hasₚ deps ⦄ → ⟦ π ⟧P depRawStruct) → Func
    singleFunc (π , deps , f) π′ with π Property.≟ π′
    singleFunc (π , deps , f) π′ | yes p rewrite Property.≈⇒≡ p = just (deps , f)
    singleFunc (π , deps , f) π′ | no _ = nothing

    combineFuncs : Func → Func → Func
    combineFuncs f g π =
      case f π of λ
      { (just r) → just r
      ; nothing → case g π of λ
        { (just r) → just r
        ; nothing → nothing
        }
      }

    propsF : ∀ π → Maybe (∃ (λ deps → ⦃ _ : Hasₚ deps ⦄ → ⟦ π ⟧P depRawStruct))
    propsF = List.foldr combineFuncs (λ _ → nothing) (List.map singleFunc props)

    dependentStruct : Struct code c′ ℓ′
    dependentStruct = FuncBased.dependentStruct depRawStruct propsF

open ListBased using (dependentStruct) public


{-# OPTIONS --cubical #-}

module Cubical.Categories.Category where

open import Cubical.Foundations.Prelude

record Precategory ℓ ℓ' : Type (ℓ-suc (ℓ-max ℓ ℓ')) where
  no-eta-equality
  field
    ob : Type ℓ
    hom : ob → ob → Type ℓ'
    idn : ∀ x → hom x x
    seq : ∀ {x y z} (f : hom x y) (g : hom y z) → hom x z
    seq-λ : ∀ {x y : ob} (f : hom x y) → seq (idn x) f ≡ f
    seq-ρ : ∀ {x y} (f : hom x y) → seq f (idn y) ≡ f
    seq-α : ∀ {u v w x} (f : hom u v) (g : hom v w) (h : hom w x) → seq (seq f g) h ≡ seq f (seq g h)

open Precategory public

record isCategory {ℓ ℓ'} (𝒞 : Precategory ℓ ℓ') : Type (ℓ-max ℓ ℓ') where
  field
    homIsSet : ∀ {x y} → isSet (𝒞 .hom x y)

open isCategory public

_^op : ∀ {ℓ ℓ'} → Precategory ℓ ℓ' → Precategory ℓ ℓ'
(𝒞 ^op) .ob = 𝒞 .ob
(𝒞 ^op) .hom x y = 𝒞 .hom y x
(𝒞 ^op) .idn = 𝒞 .idn
(𝒞 ^op) .seq f g = 𝒞 .seq g f
(𝒞 ^op) .seq-λ = 𝒞 .seq-ρ
(𝒞 ^op) .seq-ρ = 𝒞 .seq-λ
(𝒞 ^op) .seq-α f g h = sym (𝒞 .seq-α _ _ _)


{-# OPTIONS --omega-in-omega --no-termination-check --overlapping-instances #-}

module Light.Literals.Definition.Negative where

open import Light.Library.Data.Natural as ℕ using (ℕ ; zero ; successor) renaming (ℓ to nℓ)
open import Light.Level using (++_ ; _⊔_)
open import Light.Variable.Sets
open import Light.Variable.Levels
open import Light.Package using (Package)

record FromNegative ⦃ package : Package record { ℕ } ⦄ (𝕒 : Set ℓ) : Set (++ (nℓ ⊔ ℓ)) where
      field convert : ℕ → 𝕒

open FromNegative ⦃ ... ⦄ using (convert)
open import Agda.Builtin.Nat as Nat using (Nat)

private
      change : ∀ ⦃ package : Package record { ℕ } ⦄ → Nat → ℕ
      change Nat.zero = zero
      change (Nat.suc n) = successor (change n)

from‐literal : ∀ ⦃ package : Package record { ℕ } ⦄ ⦃ natural : FromNegative 𝕒 ⦄ (n : Nat) → 𝕒
from‐literal n = convert (change n)
{-# BUILTIN FROMNEG from‐literal #-}


module Selective where

open import Prelude.Equality
open import Agda.Builtin.TrustMe

-----------------------------------------------------------------
-- id : ∀ {a} {A : Set a} → A → A
-- id x = x

id : ∀ {A : Set} → A → A
id x = x
{-# INLINE id #-}

infixl -10 id
syntax id {A = A} x = x ofType A

const : ∀ {a b} {A : Set a} {B : Set b} → A → B → A
const x _ = x
{-# INLINE const #-}

flip : ∀ {a b c} {A : Set a} {B : Set b} {C : A → B → Set c} →
      (∀ x y → C x y) → ∀ y x → C x y
flip f x y = f y x
{-# INLINE flip #-}

infixr 9 _∘_
_∘_ : ∀ {a b c} {A : Set a} {B : A → Set b} {C : ∀ x → B x → Set c}
        (f : ∀ {x} (y : B x) → C x y) (g : ∀ x → B x) →
        ∀ x → C x (g x)
(f ∘ g) x = f (g x)
{-# INLINE _∘_ #-}

infixr -20 _$_
_$_ : ∀ {a b} {A : Set a} {B : A → Set b} → (∀ x → B x) → ∀ x → B x
f $ x = f x

------------------------------------------------------------------
data Either (A : Set) (B : Set) : Set where
  left  : A → Either A B
  right : B → Either A B

either : ∀ {A : Set} {B : Set} {C : Set} →
           (A → C) → (B → C) → Either A B → C
either f g (left  x) = f x
either f g (right x) = g x

data Pair (a b : Set) : Set where
  _×_ : a → b → Pair a b
------------------------------------------------------------------
record Functor (F : Set → Set) : Set₁ where
  infixl 5 _<$>_
  field
    fmap : ∀ {A B} → (A → B) → F A → F B

    -- Functor laws
    fmap-id      : ∀ {A} {x : F A} → fmap id x ≡ id x
    fmap-compose : ∀ {A B C} {f : A → B} {g : B → C} {x : F A} →
                   fmap (g ∘ f) x ≡ (fmap g ∘ fmap f) x

  _<$>_ = fmap

open Functor {{...}} public

instance
  FunctorFunction : {X : Set} → Functor (λ Y → (X → Y))
  fmap {{FunctorFunction}} f g = λ x → (f ∘ g) x
  fmap-id {{FunctorFunction}} = refl
  fmap-compose {{FunctorFunction}} = refl

record Applicative (F : Set → Set) : Set₁ where
  infixl 5 _<*>_ _<*_ _*>_
  field
    overlap {{functor}} : Functor F
    pure  : ∀ {A} → A → F A
    _<*>_ : ∀ {A B} → F (A → B) → F A → F B

    -- Applicative laws
    ap-identity     : ∀ {A B} {f : F (A → B)} → (pure id <*> f) ≡ f
    ap-homomorphism : ∀ {A B} {x : A} {f : A → B} →
                      pure f <*> pure x ≡ pure (f x)
    ap-interchange  : ∀ {A B} {x : A} {f : F (A → B)} →
                      f <*> pure x ≡ pure (_$ x) <*> f
    -- ap-composition  : ∀ {A B C} {x : F A} {f : F (A → B)} {g : F (B → C)} →
    --                   (pure (_∘_) <*> g <*> f <*> x) ≡ (g <*> (f <*> x))
    fmap-pure-ap : ∀ {A B} {x : F A} {f : A → B} →
                   f <$> x ≡ pure f <*> x

  _<*_ : ∀ {A B} → F A → F B → F A
  a <* b = ⦇ const a b ⦈

  _*>_ : ∀ {A B} → F A → F B → F B
  a *> b = ⦇ (const id) a b ⦈

open Applicative {{...}} public

instance
  ApplicativeFunction : {X : Set} → Applicative (λ Y → (X → Y))
  pure {{ApplicativeFunction}} f = const f
  _<*>_ {{ApplicativeFunction}} f g = λ x → f x (g x)

  -- Applicative laws
  ap-identity {{ApplicativeFunction}} = refl
  ap-homomorphism {{ApplicativeFunction}} = refl
  ap-interchange {{ApplicativeFunction}} = refl
  fmap-pure-ap {{ApplicativeFunction}} {_} {_} {x} {f} = primTrustMe
    -- f <$> x -- f <$> x
    --   ≡⟨ {!!} ⟩
    -- pure f <*> x
    --   ∎

record Bifunctor (P : Set → Set → Set)  : Set₁ where
  field
    bimap : ∀ {A B C D} → (A → B) → (C → D) → P A C → P B D

    first : ∀ {A B C} → (A -> B) -> P A C -> P B C

    second : ∀ {A B C} → (B -> C) -> P A B -> P A C

open Bifunctor {{...}} public

instance
  BifunctorEither : Bifunctor Either
  bimap {{BifunctorEither}} f _ (left a)  = left (f a)
  bimap {{BifunctorEither}} _ g (right b) = right (g b)

  first {{BifunctorEither}} f = bimap f id

  second {{BifunctorEither}} = bimap id

record Selective (F : Set → Set) : Set₁ where
  field
    overlap {{applicative}} : Applicative F
    handle : ∀ {A B} → F (Either A B) → F (A → B) → F B

    -- Laws:
    -- (F1) Apply a pure function to the result:
    f1 : ∀ {A B C} {f : B → C} {x : F (Either A B)} {y : F (A → B)} →
         (f <$> (handle x y)) ≡ handle (second f <$> x) ((f ∘_) <$> y)

    -- (F2) Apply a pure function to the left (error) branch:
    f2 : ∀ {A B C} {f : A -> C} {x : F (Either A B)} {y : F (C → B)} →
         handle (first f <$> x) y ≡ handle x ((_∘ f) <$> y)

    -- (F3) Apply a pure function to the handler:
    f3 : ∀ {A B C} {f : C → A → B} {x : F (Either A B)} {y : F C} →
         (handle x (f <$> y)) ≡ handle (first (flip f) <$> x) (flip (_$_) <$> y)

    -- (P1) Apply a pure handler:
    p1 : ∀ {A B} {x : F (Either A B)} {y : A → B} →
         handle x (pure y) ≡ (either y id <$> x)

    -- (P2) Handle a pure error:
    p2 : ∀ {A B} {x : A} {y : F (A → B)} →
         handle (pure (left x)) y ≡ ((_$ x) <$> y)

    -- -- (A1) Associativity
    -- a1 : ∀ {A B C} {x : F (Either A B)}
    --                {y : F (Either C (A → B))}
    --                {z : F (C → A → B)} →
    --      handle x (handle y z) ≡
    --      handle (handle ((λ x → right x) <$> x) (λ a → bimap (λ x → (x × a)) (_$ a) y))

-- A1: handle x (handle y z) = handle (handle (f <$> x) (g <$> y)) (h <$> z)
--       where f x = Right <$> x
--             g y = \a -> bimap (,a) ($a) y
--             h z = uncurry z
-- a1 :: Selective f => f (Either a b) -> f (Either c (a -> b)) -> f (c -> a -> b) -> f b
-- a1 x y z = handle x (handle y z) === handle (handle (f <$> x) (g <$> y)) (h <$> z)
--   where
--     f x = Right <$> x
--     g y = \a -> bimap (,a) ($a) y
--     h z = uncurry z

open Selective {{...}} public

-- | 'Selective' is more powerful than 'Applicative': we can recover the
-- application operator '<*>'. In particular, the following 'Applicative' laws
-- hold when expressed using 'apS':
--
-- * Identity     : pure id <*> v = v
-- * Homomorphism : pure f <*> pure x = pure (f x)
-- * Interchange  : u <*> pure y = pure ($y) <*> u
-- * Composition  : (.) <$> u <*> v <*> w = u <*> (v <*> w)
apS : ∀ {A B : Set} {F : Set → Set} {{_ : Selective F}} →
      F (A → B) → F A → F B
apS f x = handle (left <$> f) (flip (_$_) <$> x)
---------------------------------------------------------------------


{-# OPTIONS --cubical  #-} --no-import-sorts

module Test2 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.Relation.Nullary.Base -- ¬_
open import Cubical.Data.Empty            -- ⊥
open import Cubical.Foundations.Logic renaming (¬_ to ¬ᵖ_; ⊥ to ⊥ᵖ)
-- open import Cubical.Relation.Binary.Base using (PropRel)

-- data ⊥ : Set where
-- ¬_ : ∀{ℓ} → Set ℓ → Set ℓ
-- ¬ A = A → ⊥

inst-¬ : ∀{ℓ} {A : Set ℓ} → (A → ⊥) → {{a : A }} → ⊥
inst-¬ f {{a}} = f a

-- record SquareRootSpace {ℓ ℓ' : Level} : Set (ℓ-suc (ℓ-max ℓ ℓ')) where
--   field
--     X : Set ℓ
--     0ˣ : X
--     _<_ : X → X → Set ℓ'

module TestA {ℓ ℓ'} (X : Set ℓ) (0ˣ : X) (_<_ : X → X → Set ℓ') where

  _≤_ : X → X → Set ℓ'
  a ≤ b = (b < a) → ⊥ -- ¬(b < a)

  _≤ᵢ_ : X → X → Set ℓ'
  a ≤ᵢ b = {{p : b < a}} → ⊥

  -- postulate _≤'_ : X → X → Set ℓ'

  _≤'_ : X → X → Set ℓ'
  abstract a ≤' b = (b < a) → ⊥

  -- field
  postulate
    sqrt  : (x : X) → {{p : (0ˣ ≤ᵢ x)}} → X
    sqrt' : (x : X) → {{p : (0ˣ ≤' x)}} → X

-- module _ {ℓ ℓ'} (SQS : SquareRootSpace {ℓ} {ℓ'}) where
--   open SquareRootSpace SQS
  test1 : (x : X) → (0ˣ ≤ x) → X
  test1 x 0≤x = let instance _ = inst-¬ 0≤x
                in sqrt x -- works!

  -- test2 : (x y z : X) → (0ˣ ≤ x) → (0ˣ ≤ y) → (0ˣ ≤ z) → X
  -- test2 x y z 0≤x 0≤y 0≤z =
  --   let instance 0≤xᵢ : 0ˣ ≤ᵢ x
  --                0≤xᵢ = inst-¬ 0≤x
  --                0≤yᵢ : 0ˣ ≤ᵢ y
  --                0≤yᵢ = inst-¬ 0≤y
  --                0≤zᵢ : 0ˣ ≤ᵢ z
  --                0≤zᵢ = inst-¬ 0≤z
  --   -- Goal: X
  --   -- Have: ⦃ p : 0ˣ ≤ᵢ x ⦄ → X
  --   in sqrt y -- error!

  test3 : (x y z : X) → (0ˣ ≤' x) → (0ˣ ≤' y) → (0ˣ ≤' z) → X
  test3 x y z 0≤x 0≤y 0≤z =
    let instance _ = 0≤x ; _ = 0≤y ; _ = 0≤z
    in sqrt' y -- works!

-- _p_51 : 0ˣ ≤ᵢ y
-- errorFailed to solve the following constraints:
--   Resolve instance argument
--     _p_51
--       : {ℓ = ℓ₁ : Agda.Primitive.Level} {ℓ' = ℓ'' : Agda.Primitive.Level}
--         (X₁ : Set ℓ₁) (0ˣ₁ : X₁) (_<₁_ : X₁ → X₁ → Set ℓ'') (x₁ y₁ z₁ : X₁)
--         (0≤x₁ : 0ˣ₁ ≤ x₁) (0≤y₁ : 0ˣ₁ ≤ y₁) (0≤z₁ : 0ˣ₁ ≤ z₁) →
--         0ˣ₁ ≤ᵢ y₁
--   Candidates
--     λ ⦃ a ⦄ → z a : ⦃ p : 0ˣ _<_ X ⦄ → ⊥
--     λ ⦃ a ⦄ → 0≤x a : ⦃ p : 0ˣ x X ⦄ → ⊥
--     λ ⦃ a ⦄ → 0≤y a : ⦃ p : 0ˣ y X ⦄ → ⊥

-- Instance arguments with explicit arguments are never considered by
-- instance search, so having an instance argument ⦃ p : 0ˣ ≤ x ⦄ has
-- no effect.
-- when checking that the expression ⦃ p : 0ˣ ≤ x ⦄ → X is a type

{- there is an email of Apostolis Xekoukoulotakis from 03.11.17, 11:52

data ⊥ : Set where

infix 3 ¬ᵢ_

¬ᵢ_ : ∀ {ℓ} → Set ℓ → Set ℓ
¬ᵢ P = {{p : P}} → ⊥

infix 3 ¬_

¬_ : ∀ {ℓ} → Set ℓ → Set ℓ
¬ P = (p : P) → ⊥

-}


{-# OPTIONS --cubical #-}

open import Cubical.Foundations.Prelude
open import Cubical.Relation.Nullary
open import Cubical.Data.Empty
open import Cubical.Data.Nat
open import Cubical.Data.Unit
open import Cubical.Data.Prod
open import Cubical.Data.Bool

module Direction where

-- some nat things. move to own module?

sucn : (n : ℕ) → (ℕ → ℕ)
sucn n = iter n suc

sucnsuc : (n m : ℕ) → sucn n (suc m) ≡ suc (sucn n m)
sucnsuc zero m = refl
sucnsuc (suc n) m =
    sucn (suc n) (suc m)
  ≡⟨ refl ⟩
    suc (sucn n (suc m))
  ≡⟨ cong suc (sucnsuc n m) ⟩
    suc (suc (sucn n m))
  ∎

doublePred : (n : ℕ) → doubleℕ (predℕ n) ≡ predℕ (predℕ (doubleℕ n))
doublePred zero = refl
doublePred (suc n) = refl

-- doubleDoublesPred : (n : ℕ) → doublesℕ n 1 ≡
-- doubleDoublesPred zero = refl
-- doubleDoublesPred (suc n) = {!!}

sucPred : (n : ℕ) → ¬ (n ≡ zero) → suc (predℕ n) ≡ n
sucPred zero 0≠0 = ⊥-elim (0≠0 refl)
sucPred (suc n) sucn≠0 = refl

predSucSuc : (n : ℕ) → ¬ (predℕ (suc (suc n)) ≡ 0)
predSucSuc n = snotz

doubleDoubles : (n m : ℕ) → doubleℕ (doublesℕ n m) ≡ doublesℕ (suc n) m
doubleDoubles zero m = refl
doubleDoubles (suc n) m = doubleDoubles n (doubleℕ m)

doublePos : (n : ℕ) → ¬ (n ≡ 0) → ¬ (doubleℕ n ≡ 0)
doublePos zero 0≠0 = ⊥-elim (0≠0 refl)
doublePos (suc n) sn≠0 = snotz

doublesPos : (n m : ℕ) → ¬ (m ≡ 0) → ¬ (doublesℕ n m ≡ 0)
doublesPos zero m m≠0 = m≠0
doublesPos (suc n) m m≠0 = doublesPos n (doubleℕ m) (doublePos m (m≠0))

predDoublePos : (n : ℕ) → ¬ (n ≡ 0) → ¬ (predℕ (doubleℕ n)) ≡ 0
predDoublePos zero n≠0 = ⊥-elim (n≠0 refl)
predDoublePos (suc n) sn≠0 = snotz

doubleDoublesOne≠0 : (n : ℕ) → ¬ (doubleℕ (doublesℕ n (suc zero)) ≡ 0)
doubleDoublesOne≠0 zero = snotz
doubleDoublesOne≠0 (suc n) = doublePos (doublesℕ n 2) (doublesPos n 2 (snotz))

predDoubleDoublesOne≠0 : (n : ℕ) → ¬ (predℕ (doubleℕ (doublesℕ n (suc zero))) ≡ 0)
predDoubleDoublesOne≠0 zero = snotz
predDoubleDoublesOne≠0 (suc n) = predDoublePos (doublesℕ n 2) (doublesPos n 2 snotz)

doublesZero : (n : ℕ) → doublesℕ n zero ≡ zero
doublesZero zero = refl
doublesZero (suc n) = doublesZero n

-- 2^n(m+1) = (2^n)m + 2^n
-- doublesSuc : (n m : ℕ) → doublesℕ n (suc m) ≡ sucn (doublesℕ n 1) (doublesℕ n m)
-- doublesSuc zero m = refl
-- doublesSuc (suc n) m =
--     doublesℕ n (suc (suc (doubleℕ m)))
--   ≡⟨ doublesSuc n (suc (doubleℕ m)) ⟩
--     sucn (doublesℕ n 1) (doublesℕ n (suc (doubleℕ m)))
--   ≡⟨ cong (λ z → sucn (doublesℕ n 1) z) (doublesSuc n (doubleℕ m)) ⟩
--      sucn (doublesℕ n 1) (sucn (doublesℕ n 1) (doublesℕ n (doubleℕ m)))
--    ≡⟨ sucnDoubles n (doublesℕ n (doubleℕ m)) ⟩
--      sucn (doublesℕ n 2) (doublesℕ n (doubleℕ m))
--    ∎
--    where
--      sucnDoubles : (n m : ℕ) → sucn (doublesℕ n 1) (sucn (doublesℕ n 1) m) ≡ sucn (doublesℕ n 2) m
--      sucnDoubles zero m = refl
--      sucnDoubles (suc n) m =
--          sucn (doublesℕ n 2) (sucn (doublesℕ n 2) m)
--        ≡⟨ sym (sucnDoubles n (sucn (doublesℕ n 2) m)) ⟩
--          sucn (doublesℕ n 1) (sucn (doublesℕ n 1) (sucn (doublesℕ n 2) m))
--        ≡⟨ {!!} ⟩ {!!}

-- 2 * (i + n) = 2*i + 2*n
doubleSucn : (i n : ℕ) →  doubleℕ (sucn i n) ≡ sucn (doubleℕ i) (doubleℕ n)
doubleSucn zero n = refl
doubleSucn (suc i) n =
    suc (suc (doubleℕ (sucn i n)))
  ≡⟨ cong (λ z → suc (suc z)) (doubleSucn i n) ⟩
    suc (suc (sucn (doubleℕ i) (doubleℕ n)))
  ≡⟨ refl ⟩
    suc (sucn (suc (doubleℕ i)) (doubleℕ n))
  ≡⟨ cong suc refl ⟩
    sucn (suc (suc (doubleℕ i))) (doubleℕ n)
  ∎

doublesSucn : (i n m : ℕ) → doublesℕ n (sucn i m) ≡ sucn (doublesℕ n i) (doublesℕ n m)
doublesSucn i zero m = refl
doublesSucn i (suc n) m =
    doublesℕ n (doubleℕ (sucn i m))
  ≡⟨  cong (doublesℕ n) (doubleSucn i m) ⟩
    doublesℕ n (sucn (doubleℕ i) (doubleℕ m))
  ≡⟨ doublesSucn (doubleℕ i) n (doubleℕ m) ⟩
     sucn (doublesℕ n (doubleℕ i)) (doublesℕ n (doubleℕ m))
  ∎

-- 2^n * (m + 2) =
doublesSucSuc : (n m : ℕ) → doublesℕ n (suc (suc m)) ≡ sucn (doublesℕ (suc n) 1) (doublesℕ n m)
doublesSucSuc zero m = refl
doublesSucSuc (suc n) m =
    doublesℕ (suc n) (suc (suc m))
  ≡⟨ refl ⟩
    doublesℕ n (sucn 4 (doubleℕ m))
  ≡⟨ doublesSucn 4 n (doubleℕ m) ⟩
    sucn (doublesℕ n 4) (doublesℕ n (doubleℕ m))
  ∎

n+n≡2n : (n : ℕ) → sucn n n ≡ doubleℕ n
n+n≡2n zero = refl
n+n≡2n (suc n) =
    sucn (suc n) (suc n)
  ≡⟨ sucnsuc (suc n) n ⟩
    suc (sucn (suc n) n)
  ≡⟨ refl ⟩
   suc (suc (sucn n n))
  ≡⟨ cong (λ z → suc (suc z)) (n+n≡2n n) ⟩
   suc (suc (doubleℕ n))
  ∎

-- predDoubles : (n m : ℕ) → ¬ (n ≡ 0) → ¬ (m ≡ 0) → ¬ (predℕ (doublesℕ n m)) ≡ 0
-- predDoubles zero m n≠0 m≠0 = ⊥-elim (n≠0 refl)
-- predDoubles (suc n) m sn≠0 m≠0 = {!!}

-- "Direction" type for determining direction in spatial structures.
-- We interpret ↓ as 0 and ↑ as 1 when used in numerals in
-- numerical types.
data Dir : Type₀ where
  ↓ : Dir
  ↑ : Dir

caseDir : ∀ {ℓ} → {A : Type ℓ} → (ad au : A) → Dir → A
caseDir ad au ↓ = ad
caseDir ad au ↑ = au

¬↓≡↑ : ¬ ↓ ≡ ↑
¬↓≡↑ eq = subst (caseDir Dir ⊥) eq ↓

¬↑≡↓ : ¬ ↑ ≡ ↓
¬↑≡↓ eq = subst (caseDir ⊥ Dir) eq ↓

-- Dependent "directional numerals":
-- for natural n, obtain 2ⁿ "numerals".
-- This is basically a little-endian binary notation.
-- NOTE: Would an implementation of DirNum with dependent vectors be preferable
--       over using products?
DirNum : ℕ → Type₀
DirNum zero = Unit
DirNum (suc n) = Dir × (DirNum n)

sucDoubleDirNum+ : (r : ℕ) → DirNum r → DirNum (suc r)
sucDoubleDirNum+ r x = (↑ , x)

-- bad name, since this is doubling "to" suc r
doubleDirNum+ : (r : ℕ) → DirNum r → DirNum (suc r)
doubleDirNum+ r x = (↓ , x)

DirNum→ℕ : ∀ {n} → DirNum n → ℕ
DirNum→ℕ {zero} tt = zero
DirNum→ℕ {suc n} (↓ , d) = doublesℕ (suc zero) (DirNum→ℕ d)
DirNum→ℕ {suc n} (↑ , d) = suc (doublesℕ (suc zero) (DirNum→ℕ d))

double-lemma : ∀ {r} → (d : DirNum r) →
                doubleℕ (DirNum→ℕ d) ≡ DirNum→ℕ (doubleDirNum+ r d)
double-lemma {r} d = refl

¬↓,d≡↑,d′ : ∀ {n} → ∀ (d d′ : DirNum n) → ¬ (↓ , d) ≡ (↑ , d′)
¬↓,d≡↑,d′ {n} d d′ ↓,d≡↑,d′ = ¬↓≡↑ (cong proj₁ ↓,d≡↑,d′)

¬↑,d≡↓,d′ : ∀ {n} → ∀ (d d′ : DirNum n) → ¬ (↑ , d) ≡ (↓ , d′)
¬↑,d≡↓,d′ {n} d d′ ↑,d≡↓,d′ = ¬↑≡↓ (cong proj₁ ↑,d≡↓,d′)

-- dropping least significant bit preserves equality
dropLeast≡ : ∀ {n} → ∀ (ds ds′ : DirNum n) (d : Dir)
              → ((d , ds) ≡ (d , ds′)) → ds ≡ ds′
dropLeast≡ {n} ds ds′ d d,ds≡d,ds′ = cong proj₂ d,ds≡d,ds′

-- give the next numeral, cycling back to 0
-- in case of 2ⁿ - 1
next : ∀ {n} → DirNum n → DirNum n
next {zero} tt = tt
next {suc n} (↓ , ds) = (↑ , ds)
next {suc n} (↑ , ds) = (↓ , next ds)

prev : ∀ {n} → DirNum n → DirNum n
prev {zero} tt = tt
prev {suc n} (↓ , ds) = (↓ , prev ds)
prev {suc n} (↑ , ds) = (↓ , ds)

zero-n : (n : ℕ) → DirNum n
zero-n zero = tt
zero-n (suc n) = (↓ , zero-n n)

zero-n→0 : ∀ {r} → DirNum→ℕ (zero-n r) ≡ zero
zero-n→0 {zero} = refl
zero-n→0 {suc r} =
    doubleℕ (DirNum→ℕ (zero-n r))
  ≡⟨ cong doubleℕ (zero-n→0 {r}) ⟩
    doubleℕ zero
  ≡⟨ refl ⟩
    zero
  ∎

zero-n? : ∀ {n} → (x : DirNum n) → Dec (x ≡ zero-n n)
zero-n? {zero} tt = yes refl
zero-n? {suc n} (↓ , ds) with zero-n? ds
... | no ds≠zero-n = no (λ y →
                            ds≠zero-n (dropLeast≡ ds (zero-n n) ↓ y))
... | yes ds≡zero-n = yes (cong (λ y → (↓ , y)) ds≡zero-n)
zero-n? {suc n} (↑ , ds) = no ((¬↑,d≡↓,d′ ds (zero-n n)))

zero-n≡0 : {r : ℕ} → DirNum→ℕ (zero-n r) ≡ zero
zero-n≡0{zero} = refl
zero-n≡0 {suc r} =
    doubleℕ (DirNum→ℕ {r} (zero-n r))
  ≡⟨ cong doubleℕ (zero-n≡0 {r}) ⟩
   0
  ∎

-- x is doubleable as a DirNum precisely when x's most significant bit is 0
-- this should return a Dec
doubleable-n? : {n : ℕ} → (x : DirNum n) → Bool
doubleable-n? {zero} tt = false
doubleable-n? {suc n} (x , x₁) with zero-n? x₁
... | yes _ = true
... | no _ = doubleable-n? x₁

dropMost : {r : ℕ} → DirNum (suc r) → DirNum r
dropMost {zero} d = tt
dropMost {suc zero} (x , (x₁ , x₂)) = (x₁ , x₂)
dropMost {suc (suc r)} (x , x₁) = (x , dropMost x₁)

-- need to prove property about doubleable
--doubleDirNum : (r : ℕ) (d : DirNum r) → doubleable-n? {r} d ≡ true → DirNum r
-- bad:
doubleDirNum : (r : ℕ) (d : DirNum r) → DirNum r
doubleDirNum zero d  = tt
doubleDirNum (suc r) d  = doubleDirNum+ r (dropMost {r} d)
-- doubleDirNum zero d doubleable = ⊥-elim (false≢true doubleable)
-- doubleDirNum (suc r) d doubleable = doubleDirNum+ r (dropMost {r} d)

one-n : (n : ℕ) → DirNum n
one-n zero = tt
one-n (suc n) = (↑ , zero-n n)

-- numeral for 2ⁿ - 1
max-n : (n : ℕ) → DirNum n
max-n zero = tt
max-n (suc n) = (↑ , max-n n)

--half-n : (n : ℕ) → DirNum n

max→ℕ : (r : ℕ) → DirNum→ℕ (max-n r) ≡ predℕ (doublesℕ r 1)
max→ℕ zero = refl
max→ℕ (suc r) =
    suc (doubleℕ (DirNum→ℕ (max-n r)))
  ≡⟨ cong (λ z → suc (doubleℕ z)) (max→ℕ r) ⟩
    suc (doubleℕ (predℕ (doublesℕ r 1)))
  ≡⟨ cong suc (doublePred (doublesℕ r 1)) ⟩
    suc (predℕ (predℕ (doubleℕ (doublesℕ r 1))))
  ≡⟨ cong (λ z → suc (predℕ (predℕ z))) (doubleDoubles r 1) ⟩
    suc (predℕ (predℕ (doublesℕ (suc r) 1)))
  ≡⟨ refl ⟩
    suc (predℕ (predℕ (doublesℕ r 2)))
  ≡⟨ sucPred (predℕ (doublesℕ r 2)) H ⟩
    predℕ (doublesℕ r 2)
  ∎
  where
    G : (r : ℕ) → doubleℕ (doublesℕ r 1) ≡ doublesℕ r 2
    G zero = refl
    G (suc r) = doubleℕ (doublesℕ r 2) ≡⟨ doubleDoubles r 2 ⟩
                 doublesℕ (suc r) 2 ≡⟨ refl ⟩ doublesℕ r (doubleℕ 2) ∎
    H : ¬ predℕ (doublesℕ r 2) ≡ zero
    H = λ h → (predDoublePos (doublesℕ r 1) (doublesPos r 1 snotz)
        ((
          predℕ (doubleℕ (doublesℕ r 1)) ≡⟨ cong predℕ (G r) ⟩
          predℕ (doublesℕ r 2) ≡⟨ h ⟩
          0 ∎
         )))

max? : ∀ {n} → (x : DirNum n) → Dec (x ≡ max-n n)
max? {zero} tt = yes refl
max? {suc n} (↓ , ds) = no ((¬↓,d≡↑,d′ ds (max-n n)))
max? {suc n} (↑ , ds) with max? ds
... | yes ds≡max-n = yes (
          (↑ , ds)
        ≡⟨ cong (λ x → (↑ , x)) ds≡max-n ⟩
          (↑ , max-n n)
        ∎
      )
... | no ¬ds≡max-n = no (λ d,ds≡d,max-n →
                            ¬ds≡max-n ((dropLeast≡ ds (max-n n) ↑ d,ds≡d,max-n)))

maxn+1≡↑maxn : ∀ n → max-n (suc n) ≡ (↑ , (max-n n))
maxn+1≡↑maxn n = refl

maxr≡pred2ʳ : (r : ℕ) (d : DirNum r) →
           d ≡ max-n r → DirNum→ℕ d ≡ predℕ (doublesℕ r (suc zero))
maxr≡pred2ʳ zero d d≡max = refl
maxr≡pred2ʳ (suc r) (↓ , ds) d≡max = ⊥-elim ((¬↓,d≡↑,d′ ds (max-n r)) d≡max)
maxr≡pred2ʳ (suc r) (↑ , ds) d≡max =
     suc (doubleℕ (DirNum→ℕ ds))
   ≡⟨ cong (λ x → suc (doubleℕ x)) (maxr≡pred2ʳ r ds ds≡max) ⟩
     suc (doubleℕ (predℕ (doublesℕ r (suc zero)))) -- 2*(2^r - 1) + 1 = 2^r+1 - 1
   ≡⟨ cong suc (doublePred (doublesℕ r (suc zero))) ⟩
     suc (predℕ (predℕ (doubleℕ (doublesℕ r (suc zero)))))
   ≡⟨ sucPred (predℕ (doubleℕ (doublesℕ r (suc zero)))) (
              (predDoublePos (doublesℕ r (suc zero)) ((doublesPos r 1 snotz)))) ⟩
     predℕ (doubleℕ (doublesℕ r (suc zero)))
   ≡⟨ cong predℕ (doubleDoubles r (suc zero)) ⟩
     predℕ (doublesℕ (suc r) 1)
   ≡⟨ refl ⟩
     predℕ (doublesℕ r 2) -- 2^r*2 - 1 = 2^(r+1) - 1
   ∎
  where
    ds≡max : ds ≡ max-n r
    ds≡max = dropLeast≡ ds (max-n r) ↑ d≡max

-- TODO: rename
embed-next : (r : ℕ) → DirNum r → DirNum (suc r)
embed-next zero tt = (↓ , tt)
embed-next (suc r) (d , ds) with zero-n? ds
... | no _ = (d , embed-next r ds)
... | yes _ = (d , zero-n (suc r))

-- embed-next-thm : (r : ℕ) (d : DirNum r) → DirNum→ℕ d ≡ DirNum→ℕ (embed-next r d)
-- embed-next-thm zero d = refl
-- embed-next-thm (suc r) (d , ds) with zero-n? ds
-- ... | no _ = {!!}
-- ... | yes _ = {!!}

-- TODO: rename?
nextsuc-lemma : (r : ℕ) (x : DirNum r) →
         ¬ ((sucDoubleDirNum+ r x) ≡ max-n (suc r)) → ¬ (x ≡ max-n r)
nextsuc-lemma zero tt ¬H = ⊥-elim (¬H refl)
nextsuc-lemma (suc r) (↓ , x) ¬H = ¬↓,d≡↑,d′ x (max-n r)
nextsuc-lemma (suc r) (↑ , x) ¬H =
  λ h → ¬H (H (dropLeast≡ x (max-n r) ↑ h)) --⊥-elim (¬H H)
  where
    H : (x ≡ max-n r) →
         sucDoubleDirNum+ (suc r) (↑ , x) ≡ (↑ , (↑ , max-n r))
    H x≡maxnr =
        sucDoubleDirNum+ (suc r) (↑ , x)
      ≡⟨ cong (λ y → sucDoubleDirNum+ (suc r) (↑ , y)) x≡maxnr ⟩
        sucDoubleDirNum+ (suc r) (↑ , max-n r)
      ≡⟨ refl ⟩
        (↑ , (↑ , max-n r))
      ∎

next≡suc : (r : ℕ) (x : DirNum r) →
            ¬ (x ≡ max-n r) → DirNum→ℕ (next x) ≡ suc (DirNum→ℕ x)
next≡suc zero tt ¬x≡maxnr = ⊥-elim (¬x≡maxnr refl)
next≡suc (suc r) (↓ , x) ¬x≡maxnr = refl
next≡suc (suc r) (↑ , x) ¬x≡maxnr =
    doubleℕ (DirNum→ℕ (next x))
  ≡⟨ cong doubleℕ (next≡suc r x (nextsuc-lemma r x ¬x≡maxnr)) ⟩
    doubleℕ (suc (DirNum→ℕ x))
  ≡⟨ refl ⟩
    suc (suc (doubleℕ (DirNum→ℕ x)))
  ∎

-- doublesuclemma : (r : ℕ) (x : DirNum (suc r)) →
--          doubleℕ (DirNum→ℕ (next x)) ≡ suc (suc (doubleℕ (DirNum→ℕ x)))
-- doublesuclemma zero (↓ , x₁) = refl
-- doublesuclemma zero (↑ , x₁) = {!!}
-- doublesuclemma (suc r) x = {!!}
  --     doubleℕ (DirNum→ℕ (next x))
  -- ≡⟨ cong doubleℕ (next≡suc r x ¬x≡maxnr) ⟩
  --   doubleℕ (suc (DirNum→ℕ x))
  -- ≡⟨ refl ⟩
  --   suc (suc (doubleℕ (DirNum→ℕ x)))
  -- ∎


{-# OPTIONS --safe #-}
module Cubical.Categories.Instances.Cospan where

open import Cubical.Foundations.Prelude
open import Cubical.Categories.Category
open import Cubical.Data.Unit
open import Cubical.Data.Empty

open Category

data 𝟛 : Type ℓ-zero where
  ⓪ : 𝟛
  ① : 𝟛
  ② : 𝟛

CospanCat : Category ℓ-zero ℓ-zero
CospanCat .ob = 𝟛

CospanCat .Hom[_,_] ⓪ ① = Unit
CospanCat .Hom[_,_] ② ① = Unit
CospanCat .Hom[_,_] ⓪ ⓪ = Unit
CospanCat .Hom[_,_] ① ① = Unit
CospanCat .Hom[_,_] ② ② = Unit
CospanCat .Hom[_,_] _ _ = ⊥

CospanCat ._⋆_ {x = ⓪} {⓪} {⓪} f g = tt
CospanCat ._⋆_ {x = ①} {①} {①} f g = tt
CospanCat ._⋆_ {x = ②} {②} {②} f g = tt
CospanCat ._⋆_ {x = ⓪} {①} {①} f g = tt
CospanCat ._⋆_ {x = ②} {①} {①} f g = tt
CospanCat ._⋆_ {x = ⓪} {⓪} {①} f g = tt
CospanCat ._⋆_ {x = ②} {②} {①} f g = tt

CospanCat .id {⓪} = tt
CospanCat .id {①} = tt
CospanCat .id {②} = tt

CospanCat .⋆IdL {⓪} {①} _ = refl
CospanCat .⋆IdL {②} {①} _ = refl
CospanCat .⋆IdL {⓪} {⓪} _ = refl
CospanCat .⋆IdL {①} {①} _ = refl
CospanCat .⋆IdL {②} {②} _ = refl

CospanCat .⋆IdR {⓪} {①} _ = refl
CospanCat .⋆IdR {②} {①} _ = refl
CospanCat .⋆IdR {⓪} {⓪} _ = refl
CospanCat .⋆IdR {①} {①} _ = refl
CospanCat .⋆IdR {②} {②} _ = refl

CospanCat .⋆Assoc {⓪} {⓪} {⓪} {⓪} _ _ _ = refl
CospanCat .⋆Assoc {⓪} {⓪} {⓪} {①} _ _ _ = refl
CospanCat .⋆Assoc {⓪} {⓪} {①} {①} _ _ _ = refl
CospanCat .⋆Assoc {⓪} {①} {①} {①} _ _ _ = refl
CospanCat .⋆Assoc {①} {①} {①} {①} _ _ _ = refl
CospanCat .⋆Assoc {②} {②} {②} {②} _ _ _ = refl
CospanCat .⋆Assoc {②} {②} {②} {①} _ _ _ = refl
CospanCat .⋆Assoc {②} {②} {①} {①} _ _ _ = refl
CospanCat .⋆Assoc {②} {①} {①} {①} _ _ _ = refl

CospanCat .isSetHom {⓪} {⓪} = isSetUnit
CospanCat .isSetHom {⓪} {①} = isSetUnit
CospanCat .isSetHom {①} {①} = isSetUnit
CospanCat .isSetHom {②} {①} = isSetUnit
CospanCat .isSetHom {②} {②} = isSetUnit