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

open import HoTT
open import lib.types.TwoSemiCategory

module homotopy.HSpace where

-- This is just an approximation because
-- not all higher cells are killed.
record HSpaceStructure {i} (X : Ptd i) : Type i where
  constructor hSpaceStructure
  field
    ⊙μ : (X ⊙× X) ⊙→ X

  μ : de⊙ X → de⊙ X → de⊙ X
  μ = curry (fst ⊙μ)

  field
    ⊙unit-l : ⊙μ ⊙∘ ⊙×-inr X X ⊙∼ ⊙idf X
    ⊙unit-r : ⊙μ ⊙∘ ⊙×-inl X X ⊙∼ ⊙idf X

  unit-l : ∀ x → μ (pt X) x == x
  unit-l = fst ⊙unit-l

  unit-r : ∀ x → μ x (pt X) == x
  unit-r = fst ⊙unit-r

  coh : unit-l (pt X) == unit-r (pt X)
  coh = ! (↓-idf=cst-out (snd ⊙unit-l) ∙ ∙-unit-r _)
      ∙ (↓-idf=cst-out (snd ⊙unit-r) ∙ ∙-unit-r _)

record AlternativeHSpaceStructure {i} (X : Ptd i) : Type i where
  constructor hSpaceStructure
  field
    μ : de⊙ X → de⊙ X → de⊙ X
    unit-l : ∀ x → μ (pt X) x == x
    unit-r : ∀ x → μ x (pt X) == x
    coh : unit-l (pt X) == unit-r (pt X)

  ⊙μ : (X ⊙× X) ⊙→ X
  ⊙μ = uncurry μ , unit-l (pt X)

  ⊙unit-l : ⊙μ ⊙∘ ⊙×-inr X X ⊙∼ ⊙idf X
  ⊙unit-l = unit-l , ↓-idf=cst-in' idp

  ⊙unit-r : ⊙μ ⊙∘ ⊙×-inl X X ⊙∼ ⊙idf X
  ⊙unit-r = unit-r , ↓-idf=cst-in' coh

from-alt-h-space : ∀ {i} {X : Ptd i} → AlternativeHSpaceStructure X → HSpaceStructure X
from-alt-h-space hss = record {AlternativeHSpaceStructure hss}

to-alt-h-space : ∀ {i} {X : Ptd i} → HSpaceStructure X → AlternativeHSpaceStructure X
to-alt-h-space hss = record {HSpaceStructure hss}

module ConnectedHSpace {i} {X : Ptd i} {{_ : is-connected 0 (de⊙ X)}}
  (hX : HSpaceStructure X) where

  open HSpaceStructure hX public

  {-
  Given that [X] is 0-connected, to prove that each [μ x] is an equivalence we
  only need to prove that one of them is. But for [x] = [pt X], [μ x] is the
  identity so we’re done.
  -}

  l-is-equiv : ∀ x → is-equiv (λ y → μ y x)
  l-is-equiv = prop-over-connected {a = pt X}
    (λ x → (is-equiv (λ y → μ y x) , is-equiv-is-prop))
    (transport! is-equiv (λ= unit-r) (idf-is-equiv _))

  r-is-equiv : ∀ x → is-equiv (λ y → μ x y)
  r-is-equiv = prop-over-connected {a = pt X}
    (λ x → (is-equiv (λ y → μ x y) , is-equiv-is-prop))
    (transport! is-equiv (λ= unit-l) (idf-is-equiv _))

  l-equiv : de⊙ X → de⊙ X ≃ de⊙ X
  l-equiv x = _ , l-is-equiv x

  r-equiv : de⊙ X → de⊙ X ≃ de⊙ X
  r-equiv x = _ , r-is-equiv x

module _ {i} {X : Ptd i} (hX : HSpaceStructure X) where

  module hX = HSpaceStructure hX

  associator : Type i
  associator = ∀ a b c → hX.μ (hX.μ a b) c == hX.μ a (hX.μ b c)

  coh-unit-l-eq : associator → de⊙ X → de⊙ X → Type i
  coh-unit-l-eq assoc a b =
    assoc (pt X) a b ◃∙
    hX.unit-l (hX.μ a b) ◃∎
    =ₛ
    ap (λ x → hX.μ x b) (hX.unit-l a) ◃∎

  coh-unit-l : associator → Type i
  coh-unit-l assoc = ∀ a b → coh-unit-l-eq assoc a b

  coh-unit-r-eq : associator → de⊙ X → de⊙ X → Type i
  coh-unit-r-eq assoc a b =
    hX.unit-r (hX.μ a b) ◃∎
    =ₛ
    assoc a b (pt X) ◃∙
    ap (hX.μ a) (hX.unit-r b) ◃∎

  coh-unit-r : associator → Type i
  coh-unit-r assoc = ∀ a b → coh-unit-r-eq assoc a b

  coh-unit-l-r-pentagon : associator → Type i
  coh-unit-l-r-pentagon assoc = ∀ a' →
    hX.unit-r (hX.μ (pt X) a') ◃∙
    hX.unit-l a' ◃∎
    =ₛ
    assoc (pt X) a' (pt X) ◃∙
    hX.unit-l (hX.μ a' (pt X)) ◃∙
    hX.unit-r a' ◃∎

  coh-unit-l-to-unit-l-r-pentagon : (assoc : associator)
    → coh-unit-l assoc → coh-unit-l-r-pentagon assoc
  coh-unit-l-to-unit-l-r-pentagon assoc c a' =
    hX.unit-r (hX.μ (pt X) a') ◃∙
    hX.unit-l a' ◃∎
      =ₛ⟨ !ₛ (homotopy-naturality-to-idf (λ x → hX.μ x (pt X)) hX.unit-r (hX.unit-l a')) ⟩
    ap (λ x → hX.μ x (pt X)) (hX.unit-l a') ◃∙
    hX.unit-r a' ◃∎
      =ₛ⟨ 0 & 1 & !ₛ (c a' (pt X)) ⟩
    assoc (pt X) a' (pt X) ◃∙
    hX.unit-l (hX.μ a' (pt X)) ◃∙
    hX.unit-r a' ◃∎ ∎ₛ

  coh-unit-r-to-unit-l-r-pentagon : (assoc : associator)
    → coh-unit-r assoc → coh-unit-l-r-pentagon assoc
  coh-unit-r-to-unit-l-r-pentagon assoc c a' =
    hX.unit-r (hX.μ (pt X) a') ◃∙
    hX.unit-l a' ◃∎
      =ₛ⟨ 0 & 1 & c (pt X) a' ⟩
    assoc (pt X) a' (pt X) ◃∙
    ap (hX.μ (pt X)) (hX.unit-r a') ◃∙
    hX.unit-l a' ◃∎
      =ₛ⟨ 1 & 3 &
          homotopy-naturality-to-idf (hX.μ (pt X))
                                     hX.unit-l
                                     (hX.unit-r a') ⟩
    assoc (pt X) a' (pt X) ◃∙
    hX.unit-l (hX.μ a' (pt X)) ◃∙
    hX.unit-r a' ◃∎ ∎ₛ

  coh-assoc-pentagon-eq : (assoc : associator) → (a b c d : de⊙ X) → Type i
  coh-assoc-pentagon-eq assoc a b c d =
    assoc (hX.μ a b) c d ◃∙ assoc a b (hX.μ c d) ◃∎
    =ₛ
    ap (λ s → hX.μ s d) (assoc a b c) ◃∙ assoc a (hX.μ b c) d ◃∙ ap (hX.μ a) (assoc b c d) ◃∎

  coh-assoc-pentagon : (assoc : associator) → Type i
  coh-assoc-pentagon assoc = ∀ a b c d → coh-assoc-pentagon-eq assoc a b c d

  HSpace-2-semi-category : {{X-level : has-level 1 (de⊙ X)}}
    → (assoc : associator)
    → coh-assoc-pentagon assoc
    → TwoSemiCategory lzero i
  HSpace-2-semi-category assoc assoc-coh =
    record
    { El = ⊤
    ; Arr = λ _ _ → de⊙ X
    ; Arr-level = λ _ _ → ⟨⟩
    ; two-semi-cat-struct =
      record
      { comp = hX.μ
      ; assoc = assoc
      ; pentagon-identity = assoc-coh
      }
    }


module Day4 where

open import Prelude.String as String
open import Data.Maybe
open import Foreign.Haskell using (Unit)
open import Prelude.List as List
open import Data.Nat
open import Data.Nat.DivMod
open import Data.Nat.Properties
import Data.Nat.Show as ℕs
open import Prelude.Char
open import Data.Vec as Vec renaming (_>>=_ to _VV=_ ; toList to VecToList)
open import Data.Product
open import Relation.Nullary
open import Data.Nat.Properties
open import Data.Bool.Base
open import AocIO
open import AocUtil
open import AocVec
open import Relation.Binary.PropositionalEquality
open import EvenOdd

count-falsy : List Bool → ℕ
count-falsy ls = length (filter not ls)

split-line : List Char → List String
split-line ls with (words ls)
... | ls-words = List.map packString ls-words

has-following-duplicates : List String → Bool
has-following-duplicates [] = false
has-following-duplicates (x ∷ []) = false
has-following-duplicates (x ∷ y ∷ ls) with primStringEquality x y
... | false = has-following-duplicates (y ∷ ls)
... | true = true

main : IO Unit
main = mainBuilder (readFileMain process-file)
  where
    sort-word : String → String
    sort-word s with unpackString s
    ... | ls with sort ls
    ... | ls-sorted = packString ls-sorted
    is-valid-passphrase : List String → Bool
    is-valid-passphrase ls with List.map sort-word ls
    ... | sorted-words with sort sorted-words
    ... | ls-sorted = has-following-duplicates ls-sorted
    process-file : String → IO Unit
    process-file file-content with (lines (unpackString file-content))
    ... | file-lines with (List.map split-line file-lines)
    ... | lines-split-into-words with (List.map is-valid-passphrase lines-split-into-words)
    ... | lines-are-valid with count-falsy lines-are-valid
    ... | valid-count = printString (ℕs.show valid-count)

main2 : IO Unit
main2 = mainBuilder (readFileMain process-file)
  where
    is-valid-passphrase : List String → Bool
    is-valid-passphrase ls with sort ls
    ... | ls-sorted = has-following-duplicates ls-sorted
    process-file : String → IO Unit
    process-file file-content with (lines (unpackString file-content))
    ... | file-lines with (List.map split-line file-lines)
    ... | lines-split-into-words with (List.map is-valid-passphrase lines-split-into-words)
    ... | lines-are-valid with count-falsy lines-are-valid
    ... | valid-count = printString (ℕs.show valid-count)


module binio where

open import Data.Word8
import Data.ByteString as BS
import Data.ByteString.IO as BSIO
open import Data.Fin using (Fin; toℕ)
open import Data.Vec using (Vec; toList; tabulate)
open import Data.List using (List)
open import Data.Colist using (Colist; fromList)
open import Agda.Builtin.Nat using (Nat; zero; suc; _<_)
open import IO
open import Coinduction using (♯_)

{-
instance
  finN<N : {n : Nat} {f : Fin n} → IsTrue (toℕ f < n)
  finN<N {.(suc _)} {Fin.zero} = itis
  finN<N {.(suc _)} {Fin.suc f} = finN<N {_} {f}

fin256 : Fin 256 → Word8
fin256 f = fromNat (toℕ f) {{finN<N {256} {f}}}

b256 : Colist Word8
b256 = fromList (toList (tabulate {256} fin256))
-}

fin256 : Fin 256 → Word8
fin256 f = primWord8fromNat (toℕ f)

b256 : List Word8
b256 = toList (tabulate {256} fin256)

b256′ : Colist Word8
b256′ = fromList b256

-- main = run (writeBinaryFile "256.bin" b256)
-- main = run (♯ readBinaryFile "256.bin" >>= λ x → ♯ writeBinaryFile "256'.bin" x)
-- main = run (readFile "256.bin")

main = run (BSIO.writeBinaryFile′ "256.bin" b256)
-- main = run (BS.IO.writeBinaryFile′ "256'.bin" b256′)

-- main = run (BS.IO.writeBinaryFile′ "256.bin" b256 >> BS.IO.writeBinaryFile′ "256'.bin" b256′)


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

syntax Combinatory | CL

type
  * : 0-ary

term
  app : *  *  ->  * | _$_ l20
  i   : *
  k   : *
  s   : *

theory
  (IA) x     |> app (i, x) = x
  (KA) x y   |> app (app(k, x), y) = x
  (SA) x y z |> app (app (app (s, x), y), z) = app (app(x, z), app(y, z))
-}

module Combinatory.Syntax where

open import SOAS.Common
open import SOAS.Context
open import SOAS.Variable
open import SOAS.Families.Core
open import SOAS.Construction.Structure
open import SOAS.ContextMaps.Inductive

open import SOAS.Metatheory.Syntax

open import Combinatory.Signature

private
  variable
    Γ Δ Π : Ctx
    α : *T
    𝔛 : Familyₛ

-- Inductive term declaration
module CL:Terms (𝔛 : Familyₛ) where

  data CL : Familyₛ where
    var  : ℐ ⇾̣ CL
    mvar : 𝔛 α Π → Sub CL Π Γ → CL α Γ

    _$_ : CL * Γ → CL * Γ → CL * Γ
    I   : CL * Γ
    K   : CL * Γ
    S   : CL * Γ

  infixl 20 _$_

  open import SOAS.Metatheory.MetaAlgebra ⅀F 𝔛

  CLᵃ : MetaAlg CL
  CLᵃ = record
    { 𝑎𝑙𝑔 = λ where
      (appₒ ⋮ a , b) → _$_ a b
      (iₒ   ⋮ _)     → I
      (kₒ   ⋮ _)     → K
      (sₒ   ⋮ _)     → S
    ; 𝑣𝑎𝑟 = var ; 𝑚𝑣𝑎𝑟 = λ 𝔪 mε → mvar 𝔪 (tabulate mε) }

  module CLᵃ = MetaAlg CLᵃ

  module _ {𝒜 : Familyₛ}(𝒜ᵃ : MetaAlg 𝒜) where

    open MetaAlg 𝒜ᵃ

    𝕤𝕖𝕞 : CL ⇾̣ 𝒜
    𝕊 : Sub CL Π Γ → Π ~[ 𝒜 ]↝ Γ
    𝕊 (t ◂ σ) new = 𝕤𝕖𝕞 t
    𝕊 (t ◂ σ) (old v) = 𝕊 σ v
    𝕤𝕖𝕞 (mvar 𝔪 mε) = 𝑚𝑣𝑎𝑟 𝔪 (𝕊 mε)
    𝕤𝕖𝕞 (var v) = 𝑣𝑎𝑟 v

    𝕤𝕖𝕞 (_$_ a b) = 𝑎𝑙𝑔 (appₒ ⋮ 𝕤𝕖𝕞 a , 𝕤𝕖𝕞 b)
    𝕤𝕖𝕞  I        = 𝑎𝑙𝑔 (iₒ   ⋮ tt)
    𝕤𝕖𝕞  K        = 𝑎𝑙𝑔 (kₒ   ⋮ tt)
    𝕤𝕖𝕞  S        = 𝑎𝑙𝑔 (sₒ   ⋮ tt)

    𝕤𝕖𝕞ᵃ⇒ : MetaAlg⇒ CLᵃ 𝒜ᵃ 𝕤𝕖𝕞
    𝕤𝕖𝕞ᵃ⇒ = record
      { ⟨𝑎𝑙𝑔⟩ = λ{ {t = t} → ⟨𝑎𝑙𝑔⟩ t }
      ; ⟨𝑣𝑎𝑟⟩ = refl
      ; ⟨𝑚𝑣𝑎𝑟⟩ = λ{ {𝔪 = 𝔪}{mε} → cong (𝑚𝑣𝑎𝑟 𝔪) (dext (𝕊-tab mε)) }  }
      where
      open ≡-Reasoning
      ⟨𝑎𝑙𝑔⟩ : (t : ⅀ CL α Γ) → 𝕤𝕖𝕞 (CLᵃ.𝑎𝑙𝑔 t) ≡ 𝑎𝑙𝑔 (⅀₁ 𝕤𝕖𝕞 t)
      ⟨𝑎𝑙𝑔⟩ (appₒ ⋮ _) = refl
      ⟨𝑎𝑙𝑔⟩ (iₒ   ⋮ _) = refl
      ⟨𝑎𝑙𝑔⟩ (kₒ   ⋮ _) = refl
      ⟨𝑎𝑙𝑔⟩ (sₒ   ⋮ _) = refl

      𝕊-tab : (mε : Π ~[ CL ]↝ Γ)(v : ℐ α Π) → 𝕊 (tabulate mε) v ≡ 𝕤𝕖𝕞 (mε v)
      𝕊-tab mε new = refl
      𝕊-tab mε (old v) = 𝕊-tab (mε ∘ old) v

    module _ (g : CL ⇾̣ 𝒜)(gᵃ⇒ : MetaAlg⇒ CLᵃ 𝒜ᵃ g) where

      open MetaAlg⇒ gᵃ⇒

      𝕤𝕖𝕞! : (t : CL α Γ) → 𝕤𝕖𝕞 t ≡ g t
      𝕊-ix : (mε : Sub CL Π Γ)(v : ℐ α Π) → 𝕊 mε v ≡ g (index mε v)
      𝕊-ix (x ◂ mε) new = 𝕤𝕖𝕞! x
      𝕊-ix (x ◂ mε) (old v) = 𝕊-ix mε v
      𝕤𝕖𝕞! (mvar 𝔪 mε) rewrite cong (𝑚𝑣𝑎𝑟 𝔪) (dext (𝕊-ix mε))
        = trans (sym ⟨𝑚𝑣𝑎𝑟⟩) (cong (g ∘ mvar 𝔪) (tab∘ix≈id mε))
      𝕤𝕖𝕞! (var v) = sym ⟨𝑣𝑎𝑟⟩

      𝕤𝕖𝕞! (_$_ a b) rewrite 𝕤𝕖𝕞! a | 𝕤𝕖𝕞! b = sym ⟨𝑎𝑙𝑔⟩
      𝕤𝕖𝕞! I = sym ⟨𝑎𝑙𝑔⟩
      𝕤𝕖𝕞! K = sym ⟨𝑎𝑙𝑔⟩
      𝕤𝕖𝕞! S = sym ⟨𝑎𝑙𝑔⟩

-- Syntax instance for the signature
CL:Syn : Syntax
CL:Syn = record
  { ⅀F = ⅀F
  ; ⅀:CS = ⅀:CompatStr
  ; mvarᵢ = CL:Terms.mvar
  ; 𝕋:Init = λ 𝔛 → let open CL:Terms 𝔛 in record
    { ⊥ = CL ⋉ CLᵃ
    ; ⊥-is-initial = record { ! = λ{ {𝒜 ⋉ 𝒜ᵃ} → 𝕤𝕖𝕞 𝒜ᵃ ⋉ 𝕤𝕖𝕞ᵃ⇒ 𝒜ᵃ }
    ; !-unique = λ{ {𝒜 ⋉ 𝒜ᵃ} (f ⋉ fᵃ⇒) {x = t} → 𝕤𝕖𝕞! 𝒜ᵃ f fᵃ⇒ t } } } }

-- Instantiation of the syntax and metatheory
open Syntax CL:Syn public
open CL:Terms public
open import SOAS.Families.Build public
open import SOAS.Syntax.Shorthands CLᵃ public
open import SOAS.Metatheory CL:Syn public


{-# OPTIONS --type-in-type #-}

module Compilation.Encode.Examples where

open import Context
open import Type.Core
open import Compilation.Data
open import Compilation.Encode.Core

open import Function
open import Data.Product
open import Data.List.Base

module ProdTreeTreeExample where
  open ProdTreeTree
  open prodTreeTree

  ProdTreeTree′ = ⟦ prodTreeTree ⟧ᵈ

  ProdTree′ : Set -> Set -> Set
  ProdTree′ with ProdTreeTree′
  ... | ø ▶ PT′ ▶ T′ = PT′

  Tree′ : Set -> Set
  Tree′ with ProdTreeTree′
  ... | ø ▶ PT′ ▶ T′ = T′

  mutual
    fromProdTree : ∀ {A B A′ B′} -> (A -> A′) -> (B -> B′) -> ProdTree A B -> ProdTree′ A′ B′
    fromProdTree f g (Prod tree) =
      Wrap λ R h -> h $ fromTree (λ{ (x , y) _ k -> k (f x) (g y) }) tree

    fromTree : ∀ {A A′} -> (A -> A′) -> Tree A -> Tree′ A′
    fromTree f (Leaf x)    = Wrap λ R g h -> g $ f x
    fromTree f (Fork prod) = Wrap λ R g h -> h $ fromProdTree f f prod

  {-# TERMINATING #-}
  mutual
    toProdTree : ∀ {A B A′ B′} -> (A -> A′) -> (B -> B′) -> ProdTree′ A B -> ProdTree A′ B′
    toProdTree f g (Wrap k) =
      k _ λ tree -> Prod $ toTree (λ k -> k _ λ x y -> f x , g y) tree

    toTree : ∀ {A A′} -> (A -> A′) -> Tree′ A -> Tree A′
    toTree f (Wrap k) = k _ (Leaf ∘ f) (Fork ∘ toProdTree f f)

module ListExample where
  list : Data⁺ (ε ▻ (ε ▻ ⋆))
  list
    = PackData
    $ ø
    ▶ ( endᶜ
      ∷ Var vz ⇒ᶜ Var (vs vz) ∙ Var vz ⇒ᶜ endᶜ
      ∷ []
      )

  List′ : Set -> Set
  List′ with ⟦ list ⟧ᵈ
  ... | ø ▶ L′ = L′

  fromList : ∀ {A} -> List A -> List′ A
  fromList  []      = Wrap λ R z f -> z
  fromList (x ∷ xs) = Wrap λ R z f -> f x $ fromList xs

  {-# TERMINATING #-}
  toList : ∀ {A} -> List′ A -> List A
  toList (Wrap k) = k _ [] λ x xs -> x ∷ toList xs

module InterListExample where
  data InterList (A B : Set) : Set where
    InterNil  : InterList A B
    InterCons : A -> B -> InterList B A -> InterList A B

  interlist : Data⁺ (ε ▻ (ε ▻ ⋆ ▻ ⋆))
  interlist
    = PackData
    $ ø
    ▶ ( endᶜ
      ∷ Var (vs vz) ⇒ᶜ Var vz ⇒ᶜ Var (vs vs vz) ∙ Var vz ∙ Var (vs vz) ⇒ᶜ endᶜ
      ∷ []
      )

  InterList′ : Set -> Set -> Set
  InterList′ with ⟦ interlist ⟧ᵈ
  ... | ø ▶ IL′ = IL′

  fromInterList : ∀ {A B} -> InterList A B -> InterList′ A B
  fromInterList  InterNil           = Wrap λ R z f -> z
  fromInterList (InterCons x y yxs) = Wrap λ R z f -> f x y $ fromInterList yxs

  {-# TERMINATING #-}
  toInterList : ∀ {A B} -> InterList′ A B -> InterList A B
  toInterList (Wrap k) = k _ InterNil λ x y yxs -> InterCons x y $ toInterList yxs

module TreeForestExample where
  mutual
    data Tree (A : Set) : Set where
      node : A -> Forest A -> Tree A

    data Forest (A : Set) : Set where
      nil  : Forest A
      cons : Tree A -> Forest A -> Forest A

  treeForest : Data⁺ (ε ▻ (ε ▻ ⋆) ▻ (ε ▻ ⋆))
  treeForest
    = PackData
    $ ø
    ▶ ( Var vz ⇒ᶜ Var (vs vz) ∙ Var vz ⇒ᶜ endᶜ
      ∷ []
      )
    ▶ ( endᶜ
      ∷ Var (vs vs vz) ∙ Var vz ⇒ᶜ Var (vs vz) ∙ Var vz ⇒ᶜ endᶜ
      ∷ []
      )

  TreeForest′ = ⟦ treeForest ⟧ᵈ

  Tree′ : Set -> Set
  Tree′ with TreeForest′
  ... | ø ▶ T′ ▶ F′ = T′

  Forest′ : Set -> Set
  Forest′ with TreeForest′
  ... | ø ▶ T′ ▶ F′ = F′

  mutual
    fromTree : ∀ {A} -> Tree A -> Tree′ A
    fromTree (node x forest) = Wrap λ R f -> f x $ fromForest forest

    fromForest : ∀ {A} -> Forest A -> Forest′ A
    fromForest  nil               = Wrap λ R z f -> z
    fromForest (cons tree forest) = Wrap λ R z f -> f (fromTree tree) (fromForest forest)

  {-# TERMINATING #-}
  mutual
    toTree : ∀ {A} -> Tree′ A -> Tree A
    toTree (Wrap k) = k _ λ x forest -> node x $ toForest forest

    toForest : ∀ {A} -> Forest′ A -> Forest A
    toForest (Wrap k) = k _ nil λ tree forest -> cons (toTree tree) (toForest forest)

module MNExample where
  mutual
    data M (A : Set) : Set where
      p : A -> M A
      n : N -> M A

    data N : Set where
      m : M N -> N

  mn : Data⁺ (ε ▻ (ε ▻ ⋆) ▻ ε)
  mn
    = PackData
    $ ø
    ▶ ( Var vz ⇒ᶜ endᶜ
      ∷ Var (vs vz) ⇒ᶜ endᶜ
      ∷ []
      )
    ▶ ( Var (vs vz) ∙ Var vz ⇒ᶜ endᶜ
      ∷ []
      )

  MN′ = ⟦ mn ⟧ᵈ

  M′ : Set -> Set
  M′ with MN′
  ... | ø ▶ M′ ▶ N′ = M′

  N′ : Set
  N′ with MN′
  ... | ø ▶ M′ ▶ N′ = N′

  {-# TERMINATING #-}
  mutual
    fromM : ∀ {A B} -> (A -> B) -> M A -> M′ B
    fromM f (p x) = Wrap λ R g h -> g $ f x
    fromM f (n x) = Wrap λ R g h -> h $ fromN x

    fromN : N -> N′
    fromN (m x) = Wrap λ R f -> f $ fromM fromN x

  {-# TERMINATING #-}
  mutual
    toM : ∀ {A B} -> (A -> B) -> M′ A -> M B
    toM f (Wrap k) = k _ (λ x -> p (f x)) (λ x -> n (toN x))

    toN : N′ -> N
    toN (Wrap k) = k _ λ x -> m (toM toN x)


------------------------------------------------------------------------
-- Some tactics aimed at making equational reasoning proofs more
-- readable for path equality
------------------------------------------------------------------------

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

module Tactic.By.Path where

import Agda.Builtin.Cubical.Path

open import Equality.Path
open import Prelude

open import List equality-with-J as L
open import Maybe equality-with-J
open import Monad equality-with-J
open import Tactic.By equality-with-J as TB
open import TC-monad equality-with-J as TC hiding (Type)

open TB public using (⟨_⟩)

private

  -- Constructs the type of equalities between its two arguments.

  equality : Term → Term → TC.Type
  equality lhs rhs = def (quote _≡_) (varg lhs ∷ varg rhs ∷ [])

  -- An illustration of what the cong functions constructed by
  -- make-cong-called look like.

  cong₃′ :
    ∀ {a b c d : Level}
      {A : Type a} {B : Type b} {C : Type c} {D : Type d}
      {x₁ y₁ x₂ y₂ x₃ y₃}
    (f : A → B → C → D) →
    x₁ ≡ y₁ → x₂ ≡ y₂ → x₃ ≡ y₃ → f x₁ x₂ x₃ ≡ f y₁ y₂ y₃
  cong₃′ f eq₁ eq₂ eq₃ = λ i → f (eq₁ i) (eq₂ i) (eq₃ i)

  -- Constructs a "cong" function, with the given name, for functions
  -- with the given number of arguments.

  make-cong-called : Name → ℕ → TC ⊤
  make-cong-called cong n = do
    declareDef (varg cong) (type-of-cong equality n)
    defineFun cong (the-clause ∷ [])
    where
    arguments : ℕ → List (Arg Term)
    arguments zero    = []
    arguments (suc m) = varg (var (suc m) (varg (var 0 []) ∷ [])) ∷
                        arguments m

    the-clause = clause
      (("f" , varg unknown) ∷ replicate n ("eq" , varg unknown))
      (varg (var n) ∷ L.map (varg ∘ var) (nats-< n))
      (lam visible $ abs "i" $
       var (n + 1) (arguments n))

  unquoteDecl cong₃  = make-cong-called cong₃   3
  unquoteDecl cong₄  = make-cong-called cong₄   4
  unquoteDecl cong₅  = make-cong-called cong₅   5
  unquoteDecl cong₆  = make-cong-called cong₆   6
  unquoteDecl cong₇  = make-cong-called cong₇   7
  unquoteDecl cong₈  = make-cong-called cong₈   8
  unquoteDecl cong₉  = make-cong-called cong₉   9
  unquoteDecl cong₁₀ = make-cong-called cong₁₀ 10

  -- Constructs a "cong" function (similar to cong and cong₂ in
  -- Equality) for functions with the given number of arguments. The
  -- name of the constructed function is returned (for 1 and 2 the
  -- functions in Equality are returned). The cong functions for
  -- functions with 3 up to 10 arguments are cached to avoid creating
  -- lots of copies of the same functions.

  make-cong : ℕ → TC Name
  make-cong  1 = return (quote cong)
  make-cong  2 = return (quote cong₂)
  make-cong  3 = return (quote cong₃)
  make-cong  4 = return (quote cong₄)
  make-cong  5 = return (quote cong₅)
  make-cong  6 = return (quote cong₆)
  make-cong  7 = return (quote cong₇)
  make-cong  8 = return (quote cong₈)
  make-cong  9 = return (quote cong₉)
  make-cong 10 = return (quote cong₁₀)
  make-cong n  = do
    cong ← freshName "cong"
    make-cong-called cong n
    return cong

open Tactics
  (λ where
     (def (quote Agda.Builtin.Cubical.Path.PathP)
          (arg _ a ∷ arg _ P ∷ arg _ x ∷ arg _ y ∷ [])) → do
       A ← case P of λ where
             (lam _ (abs _ A)) → case bound? 0 A of λ where
               (definitely true) → return unknown
               _                 → return (strengthen-term 0 1 A)
             _ → return unknown
       return $ just (a , A , x , y)
     _ → return nothing)
  equality
  (λ a A x → def (quote refl) (harg a ∷ harg A ∷ harg x ∷ []))
  (λ p → def (quote sym) (varg p ∷ []))
  (λ lhs rhs f p → def (quote cong)
                       (replicate 3 (harg unknown) ++
                        harg lhs ∷ harg rhs ∷ varg f ∷ varg p ∷ []))
  false
  make-cong
  true
  public

------------------------------------------------------------------------
-- Some unit tests

-- Test cases that are commented out fail (or at least they failed at
-- some point).

private

  module Tests
    (assumption : 48 ≡ 42)
    (lemma      : ∀ n → n + 8 ≡ n + 2)
    (f          : ℕ → ℕ → ℕ → ℕ)
    where

    g : ℕ → ℕ → ℕ → ℕ
    g zero    _ _ = 12
    g (suc _) _ _ = 12

    fst : ∀ {a b} {A : Type a} {B : A → Type b} →
          Σ A B → A
    fst = proj₁

    {-# NOINLINE fst #-}

    _≡′_ : {A : Type} → A → A → Type
    _≡′_ = _≡_

    {-# NOINLINE _≡′_ #-}

    record R (F : Type → Type) : Type₁ where
      field
        p : {A : Type} {x : F A} → x ≡ x

    open R ⦃ … ⦄ public

    -- Tests for by.

    module By-tests where

      test₁ : 40 + 2 ≡ 42
      test₁ = by definition

      test₂ : 48 ≡ 42 → 42 ≡ 48
      test₂ eq = by eq

      test₃ : (f : ℕ → ℕ) → f 42 ≡ f 48
      test₃ f = by assumption

      test₄ : (f : ℕ → ℕ) → f 48 ≡ f 42
      test₄ f = by assumption

      test₅ : (f : ℕ → ℕ → ℕ) → f 42 48 ≡ f 48 42
      test₅ f = by assumption

      test₆ : (f : ℕ → ℕ → ℕ → ℕ) → f 42 45 48 ≡ f 48 45 42
      test₆ f = by assumption

      test₇ : f 48 (f 42 45 48) 42 ≡ f 48 (f 48 45 42) 48
      test₇ = by assumption

      test₈ : ∀ n → g n (g n 45 48) 42 ≡ g n (g n 45 42) 48
      test₈ n = by assumption

      test₉ : (f : ℕ → ℕ) → f 42 ≡ f 48
      test₉ f = by (lemma 40)

      test₁₀ : (f : ℕ → ℕ) → f 42 ≡ f 48
      test₁₀ f = by (λ (_ : ⊤) → assumption)

      test₁₁ : (f : ℕ × ℕ → ℕ × ℕ) → (∀ x → f x ≡′ x) →
               fst (f (12 , 73)) ≡ fst {B = λ _ → ℕ} (12 , 73)
      test₁₁ _ hyp = by hyp

      test₁₂ : (h : ℕ → Maybe ℕ) →
               ((xs : ℕ) → h xs ≡ just xs) →
               (xs : ℕ) → suc ⟨$⟩ h xs ≡ suc ⟨$⟩ return xs
      test₁₂ h hyp xs =
        suc ⟨$⟩ h xs       ≡⟨ by (hyp xs) ⟩∎h
        suc ⟨$⟩ return xs  ∎

      -- test₁₃ : (h : List ⊤ → Maybe (List ⊤)) →
      --          ((xs : List ⊤) → h xs ≡ just xs) →
      --          (x : ⊤) (xs : List ⊤) → _ ≡ _
      -- test₁₃ h hyp x xs =
      --   _∷_ ⟨$⟩ return x ⊛ h xs       ≡⟨ by (hyp xs) ⟩∎
      --   _∷_ ⟨$⟩ return x ⊛ return xs  ∎

      test₁₅ :
        (F : Type → Type → Type)
        (G : Bool → Type → Type) →
        ((A : Type) → F (G false A) A ≡ G false (F A A)) →
        (A : Type) →
        G false (F (G false A) A) ≡
        G false (G false (F A A))
      test₁₅ F G hyp A =
        G false (F (G false A) A)  ≡⟨ by hyp ⟩∎
        G false (G false (F A A))  ∎

      test₁₇ :
        (P : ℕ → Type)
        (f : ∀ {n} → P n → P n)
        (p : P 0) →
        f (subst P refl p) ≡ f p
      test₁₇ P _ _ = by (subst-refl P)

      test₁₈ :
        (subst′ :
           ∀ {a p} {A : Type a} {x y : A}
           (P : A → Type p) → x ≡ y → P x → P y) →
        (∀ {a p} {A : Type a} {x : A} (P : A → Type p) (p : P x) →
         subst′ P refl p ≡ p) →
        (P : ℕ → Type)
        (f : ∀ {n} → P n → P n)
        (p : P 0) →
        f (subst′ P refl p) ≡ f p
      test₁₈ _ subst′-refl P _ _ = by (subst′-refl P)

      -- test₁₉ :
      --   {F : Type → Type} ⦃ r : R F ⦄ {A : Type} {x₁ x₂ : F A}
      --   (p₁ p₂ : x₁ ≡ x₂) (assumption : p₁ ≡ p₂) →
      --   trans p p₁ ≡ trans p p₂
      -- test₁₉ p₁ p₂ assumption =
      --   trans p p₁  ≡⟨ by assumption ⟩∎
      --   trans p p₂  ∎

    -- Tests for ⟨by⟩.

    module ⟨By⟩-tests where

      test₁ : ⟨ 40 + 2 ⟩ ≡ 42
      test₁ = ⟨by⟩ refl

      test₂ : 48 ≡ 42 → ⟨ 42 ⟩ ≡ 48
      test₂ eq = ⟨by⟩ eq

      test₃ : (f : ℕ → ℕ) → f ⟨ 42 ⟩ ≡ f 48
      test₃ f = ⟨by⟩ assumption

      test₄ : (f : ℕ → ℕ) → f ⟨ 48 ⟩ ≡ f 42
      test₄ f = ⟨by⟩ assumption

      test₅ : (f : ℕ → ℕ → ℕ) → f ⟨ 42 ⟩ ⟨ 42 ⟩ ≡ f 48 48
      test₅ f = ⟨by⟩ assumption

      test₆ : (f : ℕ → ℕ → ℕ → ℕ) → f ⟨ 48 ⟩ 45 ⟨ 48 ⟩ ≡ f 42 45 42
      test₆ f = ⟨by⟩ assumption

      test₇ : f ⟨ 48 ⟩ (f ⟨ 48 ⟩ 45 ⟨ 48 ⟩) ⟨ 48 ⟩ ≡ f 42 (f 42 45 42) 42
      test₇ = ⟨by⟩ assumption

      test₈ : ∀ n → g n (g n 45 ⟨ 48 ⟩) ⟨ 48 ⟩ ≡ g n (g n 45 42) 42
      test₈ n = ⟨by⟩ assumption

      test₉ : (f : ℕ → ℕ) → f ⟨ 42 ⟩ ≡ f 48
      test₉ f = ⟨by⟩ (lemma 40)

      test₁₀ : (f : ℕ → ℕ) → f ⟨ 42 ⟩ ≡ f 48
      test₁₀ f = ⟨by⟩ (λ (_ : ⊤) → assumption)

      test₁₁ : (f : ℕ × ℕ → ℕ × ℕ) → (∀ x → f x ≡′ x) →
               fst ⟨ f (12 , 73) ⟩ ≡ fst {B = λ _ → ℕ} (12 , 73)
      test₁₁ _ hyp = ⟨by⟩ hyp

      test₁₂ : (h : ℕ → Maybe ℕ) →
               ((xs : ℕ) → h xs ≡ just xs) →
               (xs : ℕ) → suc ⟨$⟩ h xs ≡ suc ⟨$⟩ return xs
      test₁₂ h hyp xs =
        suc ⟨$⟩ ⟨ h xs ⟩   ≡⟨ ⟨by⟩ (hyp xs) ⟩∎
        suc ⟨$⟩ return xs  ∎

      test₁₃ : (h : List ⊤ → Maybe (List ⊤)) →
               ((xs : List ⊤) → h xs ≡ just xs) →
               (x : ⊤) (xs : List ⊤) → _ ≡ _
      test₁₃ h hyp x xs =
        _∷_ ⟨$⟩ return x ⊛ ⟨ h xs ⟩   ≡⟨ ⟨by⟩ (hyp xs) ⟩∎
        _∷_ ⟨$⟩ return x ⊛ return xs  ∎

      test₁₄ : (h : List ℕ → Maybe (List ℕ)) →
               ((xs : List ℕ) → h xs ≡ just xs) →
               (x : ℕ) (xs : List ℕ) → _ ≡ _
      test₁₄ h hyp x xs =
        _∷_ ⟨$⟩ ⟨ h xs ⟩   ≡⟨ ⟨by⟩ (hyp xs) ⟩∎
        _∷_ ⟨$⟩ return xs  ∎

      test₁₅ :
        (F : Type → Type → Type)
        (G : Bool → Type → Type) →
        ((A : Type) → F (G false A) A ≡ G false (F A A)) →
        (A : Type) →
        G false (F (G false A) A) ≡
        G false (G false (F A A))
      test₁₅ F G hyp A =
        G false ⟨ F (G false A) A ⟩  ≡⟨ ⟨by⟩ hyp ⟩∎
        G false (G false (F A A))    ∎

      test₁₆ : 48 ≡ 42 →
               _≡_ {A = ℕ → ℕ} (λ x → x + ⟨ 42 ⟩) (λ x → x + 48)
      test₁₆ hyp = ⟨by⟩ hyp

      test₁₇ :
        (P : ℕ → Type)
        (f : ∀ {n} → P n → P n)
        (p : P 0) →
        f ⟨ subst P refl p ⟩ ≡ f p
      test₁₇ P _ _ = ⟨by⟩ (subst-refl P)

      test₁₈ :
        (subst′ :
           ∀ {a p} {A : Type a} {x y : A}
           (P : A → Type p) → x ≡ y → P x → P y) →
        (∀ {a p} {A : Type a} {x : A} (P : A → Type p) (p : P x) →
         subst′ P refl p ≡ p) →
        (P : ℕ → Type)
        (f : ∀ {n} → P n → P n)
        (p : P 0) →
        f ⟨ subst′ P refl p ⟩ ≡ f p
      test₁₈ _ subst′-refl _ _ _ = ⟨by⟩ subst′-refl

      -- test₁₉ :
      --   {F : Type → Type} ⦃ r : R F ⦄ {A : Type} {x₁ x₂ : F A}
      --   (p₁ p₂ : x₁ ≡ x₂) (assumption : p₁ ≡ p₂) →
      --   trans p p₁ ≡ trans p p₂
      -- test₁₉ p₁ p₂ assumption =
      --   trans p p₁      ≡⟨⟩
      --   trans p ⟨ p₁ ⟩  ≡⟨ ⟨by⟩ assumption ⟩∎
      --   trans p p₂      ∎


data C : Set₁ where
  c : Set → C

data D : Set where
  d : D

F : C → {y : D} → C → Set₁
F z (c _) = G d
  module M where
  G : D → Set₁
  G _ = Set

fail : Set
fail = M.G


------------------------------------------------------------------------
-- A type soundness result
------------------------------------------------------------------------

module Lambda.Closure.Functional.Type-soundness where

import Category.Monad.Partiality as Partiality
open import Category.Monad.Partiality.All as All
  using (All; now; later)
open import Codata.Musical.Notation
open import Data.Fin using (Fin; zero; suc)
open import Data.Maybe using (Maybe; just; nothing)
open import Data.Maybe.Relation.Unary.Any as Maybe using (just)
open import Data.Nat
open import Data.Vec using (Vec; []; _∷_; lookup)
open import Relation.Binary.PropositionalEquality using (_≡_)
open import Relation.Nullary

open All.Alternative
private
  open module E {A : Set} = Partiality.Equality (_≡_ {A = A})
    using (_≈_; now; laterˡ)

open import Lambda.Closure.Functional
open Lambda.Closure.Functional.PF using (fail)
open Lambda.Closure.Functional.Workaround using (⟪_⟫P)
open import Lambda.Syntax
open Lambda.Syntax.Closure Tm

-- WF-Value, WF-Env and WF-MV specify when a
-- value/environment/potential value is well-formed with respect to a
-- given context (and type).

mutual

  data WF-Value : Ty → Value → Set where
    con : ∀ {i} → WF-Value nat (con i)
    ƛ   : ∀ {n Γ σ τ} {t : Tm (1 + n)} {ρ}
          (t∈ : ♭ σ ∷ Γ ⊢ t ∈ ♭ τ) (ρ-wf : WF-Env Γ ρ) →
          WF-Value (σ ⇾ τ) (ƛ t ρ)

  infixr 5 _∷_

  data WF-Env : ∀ {n} → Ctxt n → Env n → Set where
    []  : WF-Env [] []
    _∷_ : ∀ {n} {Γ : Ctxt n} {ρ σ v}
          (v-wf : WF-Value σ v) (ρ-wf : WF-Env Γ ρ) →
          WF-Env (σ ∷ Γ) (v ∷ ρ)

WF-MV : Ty → Maybe Value → Set
WF-MV σ = Maybe.Any (WF-Value σ)

-- Variables pointing into a well-formed environment refer to
-- well-formed values.

lookup-wf : ∀ {n Γ ρ} (x : Fin n) → WF-Env Γ ρ →
            WF-Value (lookup Γ x) (lookup ρ x)
lookup-wf zero    (v-wf ∷ ρ-wf) = v-wf
lookup-wf (suc x) (v-wf ∷ ρ-wf) = lookup-wf x ρ-wf

-- If we can prove All (WF-MV σ) x, then x does not "go wrong".

does-not-go-wrong : ∀ {σ x} → All (WF-MV σ) x → ¬ x ≈ fail
does-not-go-wrong (now (just _)) (now ())
does-not-go-wrong (later x-wf)   (laterˡ x↯) =
  does-not-go-wrong (♭ x-wf) x↯

-- Well-typed programs do not "go wrong".

mutual

  ⟦⟧-wf : ∀ {n Γ} (t : Tm n) {σ} → Γ ⊢ t ∈ σ →
          ∀ {ρ} → WF-Env Γ ρ → AllP (WF-MV σ) (⟦ t ⟧ ρ)
  ⟦⟧-wf (con i)   con             ρ-wf = now (just con)
  ⟦⟧-wf (var x)   var             ρ-wf = now (just (lookup-wf x ρ-wf))
  ⟦⟧-wf (ƛ t)     (ƛ t∈)          ρ-wf = now (just (ƛ t∈ ρ-wf))
  ⟦⟧-wf (t₁ · t₂) (t₁∈ · t₂∈) {ρ} ρ-wf =
    ⟦ t₁ · t₂ ⟧ ρ          ≅⟨ ·-comp t₁ t₂ ⟩P
    ⟦ t₁ ⟧ ρ ⟦·⟧ ⟦ t₂ ⟧ ρ   ⟨ (⟦⟧-wf t₁ t₁∈ ρ-wf >>=-congP λ { .{_} (just f-wf) →
                               ⟦⟧-wf t₂ t₂∈ ρ-wf >>=-congP λ { .{_} (just v-wf) →
                               ∙-wf f-wf v-wf }}) ⟩P

  ∙-wf : ∀ {σ τ f v} →
         WF-Value (σ ⇾ τ) f → WF-Value (♭ σ) v →
         AllP (WF-MV (♭ τ)) ⟪ f ∙ v ⟫P
  ∙-wf (ƛ t₁∈ ρ₁-wf) v₂-wf = later (♯ ⟦⟧-wf _ t₁∈ (v₂-wf ∷ ρ₁-wf))

type-soundness : ∀ {t : Tm 0} {σ} → [] ⊢ t ∈ σ → ¬ ⟦ t ⟧ [] ≈ fail
type-soundness t∈ =
  does-not-go-wrong (All.Alternative.sound (⟦⟧-wf _ t∈ []))


-- {-# OPTIONS -v tc.cover.cover:10 -v tc.cover.strategy:20 -v tc.cover.splittree:100 #-}
-- Andreas, 2013-05-15 Reported by jesper.cockx
module Issue849 where

data Bool : Set where
  true false : Bool

¬ : Bool → Bool
¬ true = false
¬ false = true

data D : Bool → Set where
  d1 : (x : Bool) → D x
  d2 : (x : Bool) → D (¬ x)

data ⊥ : Set where

data Test : (x : Bool) → (y : D x) → Set where
  c1 : (x : Bool)   → Test x (d1 x)
  c2 : (y : D true) → Test true y

-- WAS: The following function passes the coverage checker
-- even though the case for "f false (d2 true)" is not covered.
f : (x : Bool) → (y : D x) → Test x y
f x      (d1 .x) = c1 x
f true   y       = c2 y

impossible : Test false (d2 true) → ⊥
impossible ()

error : ⊥
error = impossible (f false (d2 true))


------------------------------------------------------------------------
-- The Agda standard library
--
-- Boolean algebra expressions
------------------------------------------------------------------------

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

open import Algebra

module Algebra.Properties.BooleanAlgebra.Expression
  {b} (B : BooleanAlgebra b b)
  where

open BooleanAlgebra B

open import Category.Applicative
import Category.Applicative.Indexed as Applicative
open import Category.Monad
open import Data.Fin using (Fin)
open import Data.Nat
open import Data.Product using (_,_; proj₁; proj₂)
open import Data.Vec as Vec using (Vec)
import Data.Vec.Categorical as VecCat
import Function.Identity.Categorical as IdCat
open import Data.Vec.Properties using (lookup-map)
open import Data.Vec.Relation.Binary.Pointwise.Extensional as PW
  using (Pointwise; ext)
open import Function
open import Relation.Binary.PropositionalEquality as P using (_≗_)
import Relation.Binary.Reflection as Reflection

-- Expressions made up of variables and the operations of a boolean
-- algebra.

infixr 7 _and_
infixr 6 _or_

data Expr n : Set b where
  var        : (x : Fin n) → Expr n
  _or_ _and_ : (e₁ e₂ : Expr n) → Expr n
  not        : (e : Expr n) → Expr n
  top bot    : Expr n

-- The semantics of an expression, parametrised by an applicative
-- functor.

module Semantics
  {F : Set b → Set b}
  (A : RawApplicative F)
  where

  open RawApplicative A

  ⟦_⟧ : ∀ {n} → Expr n → Vec (F Carrier) n → F Carrier
  ⟦ var x     ⟧ ρ = Vec.lookup ρ x
  ⟦ e₁ or e₂  ⟧ ρ = pure _∨_ ⊛ ⟦ e₁ ⟧ ρ ⊛ ⟦ e₂ ⟧ ρ
  ⟦ e₁ and e₂ ⟧ ρ = pure _∧_ ⊛ ⟦ e₁ ⟧ ρ ⊛ ⟦ e₂ ⟧ ρ
  ⟦ not e     ⟧ ρ = pure ¬_ ⊛ ⟦ e ⟧ ρ
  ⟦ top       ⟧ ρ = pure ⊤
  ⟦ bot       ⟧ ρ = pure ⊥

-- flip Semantics.⟦_⟧ e is natural.

module Naturality
  {F₁ F₂ : Set b → Set b}
  {A₁ : RawApplicative F₁}
  {A₂ : RawApplicative F₂}
  (f : Applicative.Morphism A₁ A₂)
  where

  open P.≡-Reasoning
  open Applicative.Morphism f
  open Semantics A₁ renaming (⟦_⟧ to ⟦_⟧₁)
  open Semantics A₂ renaming (⟦_⟧ to ⟦_⟧₂)
  open RawApplicative A₁ renaming (pure to pure₁; _⊛_ to _⊛₁_)
  open RawApplicative A₂ renaming (pure to pure₂; _⊛_ to _⊛₂_)

  natural : ∀ {n} (e : Expr n) → op ∘ ⟦ e ⟧₁ ≗ ⟦ e ⟧₂ ∘ Vec.map op
  natural (var x) ρ = begin
    op (Vec.lookup ρ x)                                            ≡⟨ P.sym $ lookup-map x op ρ ⟩
    Vec.lookup (Vec.map op ρ) x                                    ∎
  natural (e₁ or e₂) ρ = begin
    op (pure₁ _∨_ ⊛₁ ⟦ e₁ ⟧₁ ρ ⊛₁ ⟦ e₂ ⟧₁ ρ)                       ≡⟨ op-⊛ _ _ ⟩
    op (pure₁ _∨_ ⊛₁ ⟦ e₁ ⟧₁ ρ) ⊛₂ op (⟦ e₂ ⟧₁ ρ)                  ≡⟨ P.cong₂ _⊛₂_ (op-⊛ _ _) P.refl ⟩
    op (pure₁ _∨_) ⊛₂ op (⟦ e₁ ⟧₁ ρ) ⊛₂ op (⟦ e₂ ⟧₁ ρ)             ≡⟨ P.cong₂ _⊛₂_ (P.cong₂ _⊛₂_ (op-pure _) (natural e₁ ρ))
                                                                                (natural e₂ ρ) ⟩
    pure₂ _∨_ ⊛₂ ⟦ e₁ ⟧₂ (Vec.map op ρ) ⊛₂ ⟦ e₂ ⟧₂ (Vec.map op ρ)  ∎
  natural (e₁ and e₂) ρ = begin
    op (pure₁ _∧_ ⊛₁ ⟦ e₁ ⟧₁ ρ ⊛₁ ⟦ e₂ ⟧₁ ρ)                       ≡⟨ op-⊛ _ _ ⟩
    op (pure₁ _∧_ ⊛₁ ⟦ e₁ ⟧₁ ρ) ⊛₂ op (⟦ e₂ ⟧₁ ρ)                  ≡⟨ P.cong₂ _⊛₂_ (op-⊛ _ _) P.refl ⟩
    op (pure₁ _∧_) ⊛₂ op (⟦ e₁ ⟧₁ ρ) ⊛₂ op (⟦ e₂ ⟧₁ ρ)             ≡⟨ P.cong₂ _⊛₂_ (P.cong₂ _⊛₂_ (op-pure _) (natural e₁ ρ))
                                                                                (natural e₂ ρ) ⟩
    pure₂ _∧_ ⊛₂ ⟦ e₁ ⟧₂ (Vec.map op ρ) ⊛₂ ⟦ e₂ ⟧₂ (Vec.map op ρ)  ∎
  natural (not e) ρ = begin
    op (pure₁ ¬_ ⊛₁ ⟦ e ⟧₁ ρ)                                      ≡⟨ op-⊛ _ _ ⟩
    op (pure₁ ¬_) ⊛₂ op (⟦ e ⟧₁ ρ)                                 ≡⟨ P.cong₂ _⊛₂_ (op-pure _) (natural e ρ) ⟩
    pure₂ ¬_ ⊛₂ ⟦ e ⟧₂ (Vec.map op ρ)                              ∎
  natural top ρ = begin
    op (pure₁ ⊤)                                                   ≡⟨ op-pure _ ⟩
    pure₂ ⊤                                                        ∎
  natural bot ρ = begin
    op (pure₁ ⊥)                                                   ≡⟨ op-pure _ ⟩
    pure₂ ⊥                                                        ∎

-- An example of how naturality can be used: Any boolean algebra can
-- be lifted, in a pointwise manner, to vectors of carrier elements.

lift : ℕ → BooleanAlgebra b b
lift n = record
  { Carrier          = Vec Carrier n
  ; _≈_              = Pointwise _≈_
  ; _∨_              = zipWith _∨_
  ; _∧_              = zipWith _∧_
  ; ¬_               = map ¬_
  ; ⊤                = pure ⊤
  ; ⊥                = pure ⊥
  ; isBooleanAlgebra = record
    { isDistributiveLattice = record
      { isLattice = record
        { isEquivalence = PW.isEquivalence isEquivalence
        ; ∨-comm        = λ _ _ → ext λ i →
                            solve i 2 (λ x y → x or y , y or x)
                                  (∨-comm _ _) _ _
        ; ∨-assoc       = λ _ _ _ → ext λ i →
                            solve i 3
                              (λ x y z → (x or y) or z , x or (y or z))
                              (∨-assoc _ _ _) _ _ _
        ; ∨-cong        = λ xs≈us ys≈vs → ext λ i →
                            solve₁ i 4 (λ x y u v → x or y , u or v)
                                   _ _ _ _
                                   (∨-cong (Pointwise.app xs≈us i)
                                           (Pointwise.app ys≈vs i))
        ; ∧-comm        = λ _ _ → ext λ i →
                            solve i 2 (λ x y → x and y , y and x)
                                  (∧-comm _ _) _ _
        ; ∧-assoc       = λ _ _ _ → ext λ i →
                            solve i 3
                              (λ x y z → (x and y) and z ,
                                         x and (y and z))
                              (∧-assoc _ _ _) _ _ _
        ; ∧-cong        = λ xs≈ys us≈vs → ext λ i →
                            solve₁ i 4 (λ x y u v → x and y , u and v)
                                   _ _ _ _
                                   (∧-cong (Pointwise.app xs≈ys i)
                                           (Pointwise.app us≈vs i))
        ; absorptive    =
          (λ _ _ → ext λ i →
            solve i 2 (λ x y → x or (x and y) , x) (∨-absorbs-∧ _ _) _ _) ,
          (λ _ _ → ext λ i →
            solve i 2 (λ x y → x and (x or y) , x) (∧-absorbs-∨ _ _) _ _)
        }
      ; ∨-∧-distribʳ = λ _ _ _ → ext λ i →
                         solve i 3
                               (λ x y z → (y and z) or x ,
                                          (y or x) and (z or x))
                               (∨-∧-distribʳ _ _ _) _ _ _
      }
    ; ∨-complementʳ = λ _ → ext λ i →
                        solve i 1 (λ x → x or (not x) , top)
                              (∨-complementʳ _) _
    ; ∧-complementʳ = λ _ → ext λ i →
                        solve i 1 (λ x → x and (not x) , bot)
                              (∧-complementʳ _) _
    ; ¬-cong        = λ xs≈ys → ext λ i →
                        solve₁ i 2 (λ x y → not x , not y) _ _
                               (¬-cong (Pointwise.app xs≈ys i))
    }
  }
  where
  open RawApplicative VecCat.applicative
    using (pure; zipWith) renaming (_<$>_ to map)

  ⟦_⟧Id : ∀ {n} → Expr n → Vec Carrier n → Carrier
  ⟦_⟧Id = Semantics.⟦_⟧ IdCat.applicative

  ⟦_⟧Vec : ∀ {m n} → Expr n → Vec (Vec Carrier m) n → Vec Carrier m
  ⟦_⟧Vec = Semantics.⟦_⟧ VecCat.applicative

  open module R {n} (i : Fin n) =
    Reflection setoid var
      (λ e ρ → Vec.lookup (⟦ e ⟧Vec ρ) i)
      (λ e ρ → ⟦ e ⟧Id (Vec.map (flip Vec.lookup i) ρ))
      (λ e ρ → sym $ reflexive $
                 Naturality.natural (VecCat.lookup-morphism i) e ρ)


module _ where

module M₁ (_ : Set) where

  postulate
    A : Set

record R : Set₁ where
  field
    A : Set

module M₂ (r : R) where

  open M₁ (R.A r) public

module Unused (A : Set) (_ : Set) where

  open M₁ A public

postulate
  r : R

open M₂ r

postulate
  P : A → Set

data D : Set where
  c : D

F : D → Set
F c = A

_ : ∀ x → F x → Set
_ = λ _ r → P r


{-# OPTIONS -v 2 #-}
module Leftovers.Junk where

open import Data.Bool
open import Relation.Binary.PropositionalEquality

id : ∀ {X : Set} → X → X
id x = x

the : ∀ X → X → X
the X = id {X}

badEq :
  let f = the (Bool -> Bool -> Bool) (λ x → λ {true → false ; false → true})
  in f true ≡ f false
badEq = {!!} -- refl does not typecheck

goodEq :
  let f = the (Bool -> Bool -> Bool) (λ x → id λ {true → false ; false → true})
  in f true ≡ f false
goodEq = {!!}


module combinators where

open import bool
open import bool-thms2
import closures
open import eq
open import list
open import list-thms
open import nat
open import nat-thms
open import product
open import product-thms
open import sum
open import string
open import termination

data comb : Set where
  S : comb
  K : comb
  app : comb → comb → comb

size : comb → ℕ
size S = 1
size K = 1
size (app a b) = suc (size a + size b)

data _↝_ : comb → comb → Set where
  ↝K : (a b : comb) → (app (app K a) b) ↝ a
  ↝S : (a b c : comb) → (app (app (app S a) b) c) ↝ (app (app a c) (app b c))
  ↝Cong1 : {a a' : comb} (b : comb) → a ↝ a' → (app a b) ↝ (app a' b)
  ↝Cong2 : (a : comb) {b b' : comb} → b ↝ b' → (app a b) ↝ (app a b')

Sfree : comb → 𝔹
Sfree S = ff
Sfree K = tt
Sfree (app a b) = Sfree a && Sfree b

Sfree-↝-size> : ∀{a b : comb} → Sfree a ≡ tt → a ↝ b → size a > size b ≡ tt
Sfree-↝-size> p (↝K a b) = ≤<-trans {size a} (≤+1 (size a) (size b))
                             (<+2 {size a + size b} {2})
Sfree-↝-size> () (↝S a b c)
Sfree-↝-size> p (↝Cong1{a}{a'} b u) with &&-elim{Sfree a} p
Sfree-↝-size> p (↝Cong1{a}{a'} b u) | p1 , _ = <+mono2 {size a'} (Sfree-↝-size> p1 u)
Sfree-↝-size> p (↝Cong2 a u) with &&-elim{Sfree a} p
Sfree-↝-size> p (↝Cong2 a u) | _ , p2 = <+mono1{size a} (Sfree-↝-size> p2 u)

↝-preserves-Sfree : ∀{a b : comb} → Sfree a ≡ tt → a ↝ b → Sfree b ≡ tt
↝-preserves-Sfree p (↝K a b) = fst (&&-elim p)
↝-preserves-Sfree () (↝S a b c)
↝-preserves-Sfree p (↝Cong1 b u) with &&-elim p
↝-preserves-Sfree p (↝Cong1 b u) | p1 , p2 = &&-intro (↝-preserves-Sfree p1 u) p2
↝-preserves-Sfree p (↝Cong2 a u) with &&-elim{Sfree a} p
↝-preserves-Sfree p (↝Cong2 a u) | p1 , p2 = &&-intro p1 (↝-preserves-Sfree p2 u)

Sfree-comb : Set
Sfree-comb = Σ comb (λ a → Sfree a ≡ tt)

↝-Sfree-comb : Sfree-comb → Sfree-comb → Set
↝-Sfree-comb (a , _) (b , _) = a ↝ b

size-Sfree-comb : Sfree-comb → ℕ
size-Sfree-comb (a , _) = size a

decrease-size : ∀ {x y : Sfree-comb} → ↝-Sfree-comb x y → size-Sfree-comb x > size-Sfree-comb y ≡ tt
decrease-size{a , u}{b , _} p = Sfree-↝-size> u p

open measure{A = Sfree-comb} ↝-Sfree-comb (λ x y → x > y ≡ tt) size-Sfree-comb decrease-size

measure-decreases : ∀(a : Sfree-comb) → ↓ ↝-Sfree-comb a
measure-decreases a = measure-↓ (↓-> (size-Sfree-comb a))

Sfree-terminatesh : ∀{a : comb}{p : Sfree a ≡ tt} → ↓ ↝-Sfree-comb (a , p) →  ↓ _↝_ a
Sfree-terminatesh{a}{p} (pf↓ f) = pf↓ h
  where h : {y : comb} → a ↝ y → ↓ _↝_ y
        h{y} u = Sfree-terminatesh (f {y , ↝-preserves-Sfree p u} u)

Sfree-terminates : ∀(a : comb) → Sfree a ≡ tt → ↓ _↝_ a
Sfree-terminates a p = Sfree-terminatesh (measure-decreases (a , p))

data varcomb : Set where
  S : varcomb
  K : varcomb
  app : varcomb → varcomb → varcomb
  var : (s : string) → varcomb

λ* : (s : string) → varcomb → varcomb
λ* s S = app K S
λ* s K = app K K
λ* s (app c1 c2) = app (app S (λ* s c1)) (λ* s c2)
λ* s (var s') = if (s =string s') then (app (app S K) K) else (app K (var s'))

subst : varcomb → string → varcomb → varcomb
subst c s S = S
subst c s K = K
subst c s (app c1 c2) = app (subst c s c1) (subst c s c2)
subst c s (var s') = if (s =string s') then c else var s'

data _↝vc_ : varcomb → varcomb → Set where
  ↝K : (a b : varcomb) → (app (app K a) b) ↝vc a
  ↝S : (a b c : varcomb) → (app (app (app S a) b) c) ↝vc (app (app a c) (app b c))
  ↝Cong1 : {a a' : varcomb} (b : varcomb) → a ↝vc a' → (app a b) ↝vc (app a' b)
  ↝Cong2 : (a : varcomb) {b b' : varcomb} → b ↝vc b' → (app a b) ↝vc (app a b')

-- open closures.basics _↝vc_

-- _↝vc+_ : varcomb → varcomb → Set
-- _↝vc+_ = tc

-- id↝ : ∀ (a : varcomb) → app (app (app S K) K) a ↝vc+ a
-- id↝ a = (tc-trans (tc-step (↝S K K a)) (tc-step (↝K a (app K a))))

-- trans-Cong1 : ∀{a a' : varcomb} (b : varcomb) → a ↝vc+ a' → (app a b) ↝vc+ (app a' b)
-- trans-Cong1 b (tc-trans d1 d2) = (tc-trans (trans-Cong1 b d1) (trans-Cong1 b d2))
-- trans-Cong1 b (tc-step d) = tc-step (↝Cong1 b d)

-- trans-Cong2 : ∀(a : varcomb) {b b' : varcomb} → b ↝vc+ b' → (app a b) ↝vc+ (app a b')
-- trans-Cong2 a (tc-trans d1 d2) = (tc-trans (trans-Cong2 a d1) (trans-Cong2 a d2))
-- trans-Cong2 a (tc-step d) = tc-step (↝Cong2 a d)

-- contains-var : string → varcomb → 𝔹
-- contains-var s S = ff
-- contains-var s K = ff
-- contains-var s (app c1 c2) = contains-var s c1 || contains-var s c2
-- contains-var s (var s') = s =string s'

-- λ*-binds : ∀(s : string)(v : varcomb) → contains-var s (λ* s v) ≡ ff
-- λ*-binds s S = refl
-- λ*-binds s K = refl
-- λ*-binds s (app c1 c2) rewrite λ*-binds s c1 | λ*-binds s c2 = refl
-- λ*-binds s (var s') with keep (s =string s')
-- λ*-binds s (var s') | tt , p rewrite p = refl
-- λ*-binds s (var s') | ff , p rewrite p = p

-- λ*-↝ : ∀ (v1 v2 : varcomb)(s : string) → (app (λ* s v1) v2) ↝vc+ (subst v2 s v1)
-- λ*-↝ S v2 s = tc-step (↝K S v2)
-- λ*-↝ K v2 s = tc-step (↝K K v2)
-- λ*-↝ (app c1 c2) v2 s =
--   (tc-trans (tc-step (↝S (λ* s c1) (λ* s c2) v2))
--   (tc-trans (trans-Cong1 (app (λ* s c2) v2) (λ*-↝ c1 v2 s))
--     (trans-Cong2 (subst v2 s c1) (λ*-↝ c2 v2 s))))
-- λ*-↝ (var s') v2 s with s =string s'
-- λ*-↝ (var s') v2 s | tt = id↝ v2
-- λ*-↝ (var s') v2 s | ff = tc-step (↝K (var s') v2)


------------------------------------------------------------------------
-- Alternative definitions of weak bisimilarity
------------------------------------------------------------------------

{-# OPTIONS --sized-types #-}

open import Prelude

module Delay-monad.Bisimilarity.Alternative {a} {A : Type a} where

open import Equality.Propositional as E
open import Logical-equivalence using (_⇔_)
open import Prelude.Size

open import Function-universe equality-with-J hiding (_∘_)
open import H-level equality-with-J
open import H-level.Closure equality-with-J

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

-- An alternative definition of weak bisimilarity (discussed by
-- Capretta in "General Recursion via Coinductive Types", and
-- basically the one used in the paper "Partiality, Revisited: The
-- Partiality Monad as a Quotient Inductive-Inductive Type" by
-- Altenkirch, Danielsson and Kraus).
--
-- This definition is pointwise logically equivalent to the one above,
-- see Delay-monad.Partial-order.≈⇔≈₂.

infix 4 _≈₂_

_≈₂_ : Delay A ∞ → Delay A ∞ → Type a
x ≈₂ y = ∀ z → x ⇓ z ⇔ y ⇓ z

-- If A is a set, then this alternative definition of weak
-- bisimilarity is propositional (assuming extensionality), unlike _≈_
-- (see Delay-monad.Bisimilarity.¬-≳≈-propositional).

≈₂-propositional :
  E.Extensionality a a →
  Is-set A → ∀ {x y} → Is-proposition (x ≈₂ y)
≈₂-propositional ext A-set =
  Π-closure ext 1 λ _ →
  ⇔-closure ext 1 (Terminates-propositional A-set)
                  (Terminates-propositional A-set)

-- Another alternative definition of weak bisimilarity, basically the
-- one given by Capretta in "General Recursion via Coinductive Types".

infix 4 [_]_≈₃_ [_]_≈₃′_ _≈₃_

mutual

  data [_]_≈₃_ (i : Size) : Delay A ∞ → Delay A ∞ → Type a where
    both-terminate : ∀ {x y v} → x ⇓ v → y ⇓ v → [ i ] x ≈₃ y
    later          : ∀ {x y} →
                     [ i ] force x ≈₃′ force y →
                     [ i ] later x ≈₃  later y

  record [_]_≈₃′_ (i : Size) (x y : Delay A ∞) : Type a where
    coinductive
    field
      force : {j : Size< i} → [ j ] x ≈₃ y

open [_]_≈₃′_ public

_≈₃_ : Delay A ∞ → Delay A ∞ → Type a
_≈₃_ = [ ∞ ]_≈₃_

-- If A is inhabited, then this definition is not propositional.

¬-≈₃-propositional : A → ¬ (∀ {x y} → Is-proposition (x ≈₃ y))
¬-≈₃-propositional x =
  (∀ {x y} → Is-proposition (x ≈₃ y))  ↝⟨ (λ prop → prop) ⟩
  Is-proposition (y ≈₃ y)              ↝⟨ (_$ _) ∘ (_$ _) ⟩
  proof₁ ≡ proof₂                      ↝⟨ (λ ()) ⟩□
  ⊥                                    □
  where
  y : Delay A ∞
  y = later λ { .force → now x }

  proof₁ : y ≈₃ y
  proof₁ = both-terminate (laterʳ now) (laterʳ now)

  proof₂ : y ≈₃ y
  proof₂ = later λ { .force → both-terminate now now }

-- The last definition of weak bisimilarity given above is pointwise
-- logically equivalent to _≈_. Note that the proof is
-- size-preserving.
--
-- (Given suitable notions of extensionality the two definitions are
-- not pointwise isomorphic, because given such assumptions there is
-- only one proof of never ≈₃ never, but multiple proofs of
-- never ≈ never. However, there is no Agda proof of this claim in
-- this module.)

≈⇔≈₃ : ∀ {i x y} → [ i ] x ≈ y ⇔ [ i ] x ≈₃ y
≈⇔≈₃ = record { to = to; from = from }
  where
  mutual

    laterˡ′ : ∀ {i x x′ y} →
              x′ ≡ force x →
              [ i ] x′      ≈₃ y →
              [ i ] later x ≈₃ y
    laterˡ′ eq (both-terminate x⇓ y⇓) = both-terminate
                                          (laterʳ (subst (_⇓ _) eq x⇓))
                                          y⇓
    laterˡ′ eq (later p)              = later (laterˡ″ eq p)

    laterˡ″ : ∀ {i x x′ y} →
              later x′ ≡ x →
              [ i ] force x′ ≈₃′ y →
              [ i ] x        ≈₃′ y
    force (laterˡ″ refl p) = laterˡ′ refl (force p)

  mutual

    laterʳ′ : ∀ {i x y y′} →
              y′ ≡ force y →
              [ i ] x ≈₃ y′ →
              [ i ] x ≈₃ later y
    laterʳ′ eq (both-terminate x⇓ y⇓) = both-terminate
                                          x⇓
                                          (laterʳ (subst (_⇓ _) eq y⇓))
    laterʳ′ eq (later p)              = later (laterʳ″ eq p)

    laterʳ″ : ∀ {i x y y′} →
              later y′ ≡ y →
              [ i ] x ≈₃′ force y′ →
              [ i ] x ≈₃′ y
    force (laterʳ″ refl p) = laterʳ′ refl (force p)

  to : ∀ {i x y} → [ i ] x ≈ y → [ i ] x ≈₃ y
  to now        = both-terminate now now
  to (later  p) = later λ { .force → to (force p) }
  to (laterˡ p) = laterˡ′ refl (to p)
  to (laterʳ p) = laterʳ′ refl (to p)

  from⇓ : ∀ {i x y v} → x ⇓ v → y ⇓ v → [ i ] x ≈ y
  from⇓ now        now        = now
  from⇓ p          (laterʳ q) = laterʳ (from⇓ p q)
  from⇓ (laterʳ p) q          = laterˡ (from⇓ p q)

  from : ∀ {i x y} → [ i ] x ≈₃ y → [ i ] x ≈ y
  from (both-terminate x⇓v y⇓v) = from⇓ x⇓v y⇓v
  from (later p)                = later λ { .force → from (force p) }


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

open import lib.Basics
open import lib.NType2
open import lib.NConnected
open import lib.types.Truncation
open import lib.types.Group

module lib.types.EilenbergMacLane1.Core {i} where

module _ (G : Group i) where
  private
    module G = Group G

  postulate  -- HIT
    EM₁ : Type i
    embase' : EM₁
    emloop' : G.El → embase' == embase'
    emloop-comp' : ∀ g₁ g₂ → emloop' (G.comp g₁ g₂) == emloop' g₁ ∙ emloop' g₂

  emloop-coh₁' : (g₁ g₂ g₃ : G.El)
    → emloop' (G.comp (G.comp g₁ g₂) g₃) =-= emloop' g₁ ∙ (emloop' g₂ ∙ emloop' g₃)
  emloop-coh₁' g₁ g₂ g₃ =
    emloop' (G.comp (G.comp g₁ g₂) g₃)
      =⟪ emloop-comp' (G.comp g₁ g₂) g₃ ⟫
    emloop' (G.comp g₁ g₂) ∙ emloop' g₃
      =⟪ ap (λ l → l ∙ emloop' g₃) (emloop-comp' g₁ g₂) ⟫
    (emloop' g₁ ∙ emloop' g₂) ∙ emloop' g₃
      =⟪ ∙-assoc (emloop' g₁) (emloop' g₂) (emloop' g₃) ⟫
    emloop' g₁ ∙ (emloop' g₂ ∙ emloop' g₃) ∎∎

  emloop-coh₂' : (g₁ g₂ g₃ : G.El)
    → emloop' (G.comp (G.comp g₁ g₂) g₃) =-= emloop' g₁ ∙ (emloop' g₂ ∙ emloop' g₃)
  emloop-coh₂' g₁ g₂ g₃ =
    emloop' (G.comp (G.comp g₁ g₂) g₃)
      =⟪ ap emloop' (Group.assoc G g₁ g₂ g₃) ⟫
    emloop' (G.comp g₁ (G.comp g₂ g₃))
      =⟪ emloop-comp' g₁ (Group.comp G g₂ g₃) ⟫
    emloop' g₁ ∙ emloop' (G.comp g₂ g₃)
      =⟪ ap (λ l → emloop' g₁ ∙ l) (emloop-comp' g₂ g₃) ⟫
    emloop' g₁ ∙ (emloop' g₂ ∙ emloop' g₃) ∎∎

  postulate
    emloop-coh' : ∀ g₁ g₂ g₃ → emloop-coh₁' g₁ g₂ g₃ =ₛ emloop-coh₂' g₁ g₂ g₃
    EM₁-level' : has-level 2 EM₁

  ⊙EM₁ : Ptd i
  ⊙EM₁ = ⊙[ EM₁ , embase' ]

module _ {G : Group i} where
  private
    module G = Group G

  embase = embase' G
  emloop = emloop' G
  emloop-comp = emloop-comp' G
  emloop-coh₁ = emloop-coh₁' G
  emloop-coh₂ = emloop-coh₂' G
  emloop-coh = emloop-coh' G

  instance
    EM₁-level : {n : ℕ₋₂} → has-level (S (S (S (S n)))) (EM₁ G)
    EM₁-level {⟨-2⟩} = EM₁-level' G
    EM₁-level  {S n} = raise-level _ EM₁-level

  abstract
    -- This was in the original paper, but is actually derivable.
    emloop-ident : emloop G.ident == idp
    emloop-ident = ! $ anti-whisker-right (emloop G.ident) $
      ap emloop (! $ G.unit-r G.ident) ∙ emloop-comp G.ident G.ident

  module EM₁Elim {j} {P : EM₁ G → Type j}
    {{_ : (x : EM₁ G) → has-level 2 (P x)}}
    (embase* : P embase)
    (emloop* : ∀ g → embase* == embase* [ P ↓ emloop g ])
    (emloop-comp* : ∀ g₁ g₂ →
       emloop* (G.comp g₁ g₂) == emloop* g₁ ∙ᵈ emloop* g₂
       [ (λ p → embase* == embase* [ P ↓ p ]) ↓ emloop-comp g₁ g₂ ])
    (emloop-coh* : ∀ g₁ g₂ g₃ →
      emloop-comp* (G.comp g₁ g₂) g₃ ∙ᵈ
      (emloop-comp* g₁ g₂ ∙ᵈᵣ emloop* g₃) ∙ᵈ
      ∙ᵈ-assoc (emloop* g₁) (emloop* g₂) (emloop* g₃)
      ==
      ↓-ap-in (λ p → embase* == embase* [ P ↓ p ]) emloop (apd emloop* (G.assoc g₁ g₂ g₃)) ∙ᵈ
      emloop-comp* g₁ (G.comp g₂ g₃) ∙ᵈ
      (emloop* g₁ ∙ᵈₗ emloop-comp* g₂ g₃)
      [ (λ e → emloop* (G.comp (G.comp g₁ g₂) g₃) == emloop* g₁ ∙ᵈ (emloop* g₂ ∙ᵈ emloop* g₃)
               [ (λ p → embase* == embase* [ P ↓ p ]) ↓ e ])
        ↓ =ₛ-out (emloop-coh g₁ g₂ g₃) ])
    where

    postulate  -- HIT
      f : Π (EM₁ G) P
      embase-β : f embase ↦ embase*
    {-# REWRITE embase-β #-}

    postulate  -- HIT
      emloop-β : (g : G.El) → apd f (emloop g) == emloop* g
      emloop-comp-path : (g₁ g₂ : G.El)
        → apd (apd f) (emloop-comp g₁ g₂) ▹
          apd-∙ f (emloop g₁) (emloop g₂) ∙
          ap2 _∙ᵈ_ (emloop-β g₁) (emloop-β g₂)
          ==
          emloop-β (G.comp g₁ g₂) ◃
          emloop-comp* g₁ g₂

  open EM₁Elim public using () renaming (f to EM₁-elim)

  module EM₁Level₁Elim {j} {P : EM₁ G → Type j}
    {{is-1-type : (x : EM₁ G) → has-level 1 (P x)}}
    (embase* : P embase)
    (emloop* : (g : G.El) → embase* == embase* [ P ↓ emloop g ])
    (emloop-comp* : (g₁ g₂ : G.El) →
      emloop* (G.comp g₁ g₂) == emloop* g₁ ∙ᵈ emloop* g₂
      [ (λ p → embase* == embase* [ P ↓ p ]) ↓ emloop-comp g₁ g₂ ]) where

    private
      module M = EM₁Elim {{λ x → raise-level 1 (is-1-type x)}}
                         embase* emloop* emloop-comp*
                         (λ g₁ g₂ g₃ → prop-has-all-paths-↓ {{↓-level (↓-level (is-1-type embase))}})
    abstract
      f : Π (EM₁ G) P
      f = M.f

      embase-β : f embase ↦ embase*
      embase-β = M.embase-β
      {-# REWRITE embase-β #-}

      emloop-β : (g : G.El) → apd f (emloop g) == emloop* g
      emloop-β = M.emloop-β

  open EM₁Level₁Elim public using () renaming (f to EM₁-level₁-elim)

  module EM₁SetElim {j} {P : EM₁ G → Type j}
    {{is-set : (x : EM₁ G) → is-set (P x)}}
    (embase* : P embase)
    (emloop* : (g : G.El) → embase* == embase* [ P ↓ emloop g ]) where

    private
      module M = EM₁Level₁Elim {P = P} {{λ x → raise-level 0 (is-set x)}}
                               embase* emloop*
                               (λ g₁ g₂ → set-↓-has-all-paths-↓ {{is-set embase}})
    open M public

  open EM₁SetElim public using () renaming (f to EM₁-set-elim)

  module EM₁PropElim {j} {P : EM₁ G → Type j}
    {{is-prop : (x : EM₁ G) → is-prop (P x)}}
    (embase* : P embase) where

    module P = EM₁SetElim {{λ x → raise-level -1 (is-prop x)}}
                          embase*
                          (λ g → prop-has-all-paths-↓ {{is-prop embase}})
    open P public

  open EM₁PropElim public using () renaming (f to EM₁-prop-elim)

-- basic lemmas about [EM₁]

module _ {G : Group i} where
  private
    module G = Group G

  abstract
    emloop-inv : ∀ g → emloop' G (G.inv g) == ! (emloop g)
    emloop-inv g = cancels-inverse _ _ lemma
      where
        cancels-inverse : ∀ {i} {A : Type i} {x y : A}
          (p : x == y) (q : y == x) → p ∙ q == idp → p == ! q
        cancels-inverse p idp r = ! (∙-unit-r p) ∙ r

        lemma : emloop' G (G.inv g) ∙ emloop g  == idp
        lemma = ! (emloop-comp (G.inv g) g) ∙ ap emloop (G.inv-l g) ∙ emloop-ident

    {- EM₁ is 0-connected -}
    instance
      EM₁-conn : is-connected 0 (EM₁ G)
      EM₁-conn = has-level-in ([ embase ] , Trunc-elim
        (EM₁-level₁-elim
          {P = λ x → [ embase ] == [ x ]}
          {{λ _ → raise-level _ (=-preserves-level Trunc-level)}}
          idp
          (λ _ → prop-has-all-paths-↓)
          (λ _ _ → set-↓-has-all-paths-↓)))


{-# OPTIONS --allow-incomplete-matches #-}

module Issue3295.Incomplete where

open import Agda.Builtin.Nat

f : Nat → Nat
f zero = zero


-- Occurs there are several ways to parse a left-hand side.
module AmbiguousParseForLHS where

data X : Set where
  if_then_else_ : X -> X -> X -> X
  if_then_      : X -> X -> X
  x             : X

bad : X -> X
bad (if x then if x then x else x) = x
bad _                              = if x then x


module Structure.Category.Functor.Functors where

import      Functional as Fn
open import Function.Proofs
open import Logic.Predicate
import      Lvl
open import Structure.Category
open import Structure.Category.Functor
open import Structure.Categorical.Properties
open import Structure.Function
open import Structure.Relator.Equivalence
open import Structure.Relator.Properties
open import Structure.Setoid
open import Syntax.Transitivity
open import Type

private variable ℓ ℓₒ ℓₘ ℓₑ ℓₗₑ ℓᵣₑ ℓₑ₁ ℓₑ₂ ℓₑ₃ : Lvl.Level
private variable Obj Obj₁ Obj₂ Obj₃ : Type{ℓ}
private variable Morphism Morphism₁ Morphism₂ Morphism₃ : Obj → Obj → Type{ℓ}

module Raw where
  constᶠᵘⁿᶜᵗᵒʳ : Obj₂ → (Obj₁ → Obj₂)
  constᶠᵘⁿᶜᵗᵒʳ = Fn.const

  idᶠᵘⁿᶜᵗᵒʳ : Obj → Obj
  idᶠᵘⁿᶜᵗᵒʳ = Fn.id

  _∘ᶠᵘⁿᶜᵗᵒʳ_ : (Obj₂ → Obj₃) → (Obj₁ → Obj₂) → (Obj₁ → Obj₃)
  _∘ᶠᵘⁿᶜᵗᵒʳ_ = Fn._∘_

  infixl 10000 _∘ᶠᵘⁿᶜᵗᵒʳ_

module _
  ⦃ morphism-equivₗ : ∀{x y : Obj₁} → Equiv{ℓₗₑ}(Morphism₁ x y) ⦄
  ⦃ morphism-equivᵣ : ∀{x y : Obj₂} → Equiv{ℓᵣₑ}(Morphism₂ x y) ⦄
  {Category₁ : Category(Morphism₁)}
  {Category₂ : Category(Morphism₂)}
  where

  module _ where
    private open module Equivₗ {x}{y} = Equivalence (Equiv-equivalence ⦃ morphism-equivₗ{x}{y} ⦄) using ()
    private open module Equivᵣ {x}{y} = Equivalence (Equiv-equivalence ⦃ morphism-equivᵣ{x}{y} ⦄) using ()
    open Category ⦃ … ⦄
    open Functor
    open Raw

    private instance _ = Category₁
    private instance _ = Category₂

    -- A constant functor maps every object and morphism in a category to a single specified object and the identity morphism.
    constant : (objᵣ : Obj₂) → Functor(Category₁)(Category₂)(constᶠᵘⁿᶜᵗᵒʳ(objᵣ))
    map           (constant(objᵣ)) = Fn.const(id)
    op-preserving (constant(objᵣ)) = symmetry(_≡_) (Morphism.identityₗ(_∘_)(id))
    id-preserving (constant(objᵣ)) = reflexivity(_≡_)

module _
  ⦃ morphism-equiv : ∀{x y : Obj} → Equiv{ℓₑ}(Morphism x y) ⦄
  {Category : Category(Morphism)}
  where

  private open module [≡]-Equivalence {x}{y} = Equivalence (Equiv-equivalence ⦃ morphism-equiv{x}{y} ⦄) using ()
  open Functor
  open Raw

  private instance _ = Category

  identity : Endofunctor(Category)(idᶠᵘⁿᶜᵗᵒʳ)
  map           (identity) = Fn.id
  op-preserving (identity) = reflexivity(_≡_)
  id-preserving (identity) = reflexivity(_≡_)

module _
  ⦃ morphism-equiv₁ : ∀{x y : Obj₁} → Equiv{ℓₑ₁}(Morphism₁ x y) ⦄
  ⦃ morphism-equiv₂ : ∀{x y : Obj₂} → Equiv{ℓₑ₂}(Morphism₂ x y) ⦄
  ⦃ morphism-equiv₃ : ∀{x y : Obj₃} → Equiv{ℓₑ₃}(Morphism₃ x y) ⦄
  {Category₁ : Category(Morphism₁)}
  {Category₂ : Category(Morphism₂)}
  {Category₃ : Category(Morphism₃)}
  where

  private open module Equiv₃ {x}{y} = Equivalence (Equiv-equivalence ⦃ morphism-equiv₃{x}{y} ⦄) using ()
  open Category ⦃ … ⦄
  open Functor
  open Raw

  private instance _ = Category₁
  private instance _ = Category₂
  private instance _ = Category₃

  composition :
    ∀{F₂₃}{F₁₂}
    → (functor₂₃ : Functor(Category₂)(Category₃)(F₂₃))
    → (functor₁₂ : Functor(Category₁)(Category₂)(F₁₂))
    → Functor(Category₁)(Category₃)(F₂₃ ∘ᶠᵘⁿᶜᵗᵒʳ F₁₂)

  map              (composition{F₂₃}{F₁₂}(functor₂₃)(functor₁₂)){x}{y} = (map(functor₂₃){F₁₂(x)}{F₁₂(y)}) Fn.∘ (map(functor₁₂){x}{y})
  map-function     (composition{F₂₃}{F₁₂}(functor₂₃)(functor₁₂)) = [∘]-function ⦃ func-f = map-function(functor₂₃) ⦄ ⦃ func-g = map-function(functor₁₂) ⦄
  op-preserving    (composition{F₂₃}{F₁₂}(functor₂₃)(functor₁₂)){x}{y}{z} {f}{g} =
    map(functor₂₃) (map(functor₁₂) (f ∘ g))                               🝖-[ congruence₁(map(functor₂₃)) (op-preserving(functor₁₂)) ]
    map(functor₂₃) (map(functor₁₂) f ∘ map functor₁₂ g)                   🝖-[ op-preserving(functor₂₃)]
    map(functor₂₃) (map(functor₁₂) f) ∘ map(functor₂₃) (map(functor₁₂) g) 🝖-end
  id-preserving    (composition{F₂₃}{F₁₂}(functor₂₃)(functor₁₂)) {x} =
    map(functor₂₃) (map(functor₁₂) id) 🝖-[ congruence₁(_) (id-preserving(functor₁₂)) ]
    map(functor₂₃) id                  🝖-[ id-preserving(functor₂₃) ]
    id                                 🝖-end

module Wrapped where
  open CategoryObject

  private variable A B C : CategoryObject{ℓₒ}{ℓₘ}{ℓₑ}

  constᶠᵘⁿᶜᵗᵒʳ : let _ = A in Object(B) → (A →ᶠᵘⁿᶜᵗᵒʳ B)
  ∃.witness (constᶠᵘⁿᶜᵗᵒʳ c) = Raw.constᶠᵘⁿᶜᵗᵒʳ c
  ∃.proof   (constᶠᵘⁿᶜᵗᵒʳ c) = constant c

  idᶠᵘⁿᶜᵗᵒʳ : A →ᶠᵘⁿᶜᵗᵒʳ A
  ∃.witness idᶠᵘⁿᶜᵗᵒʳ = Raw.idᶠᵘⁿᶜᵗᵒʳ
  ∃.proof   idᶠᵘⁿᶜᵗᵒʳ = identity

  _∘ᶠᵘⁿᶜᵗᵒʳ_ : let _ = A ; _ = B ; _ = C in (B →ᶠᵘⁿᶜᵗᵒʳ C) → (A →ᶠᵘⁿᶜᵗᵒʳ B) → (A →ᶠᵘⁿᶜᵗᵒʳ C)
  ∃.witness (_∘ᶠᵘⁿᶜᵗᵒʳ_ ([∃]-intro F)               ([∃]-intro G))               = Raw._∘ᶠᵘⁿᶜᵗᵒʳ_ F G
  ∃.proof   (_∘ᶠᵘⁿᶜᵗᵒʳ_ ([∃]-intro _ ⦃ F-functor ⦄) ([∃]-intro _ ⦃ G-functor ⦄)) = composition F-functor G-functor


{-# OPTIONS --copatterns #-}

mutual
  data D : Set where
    c : R → D

  record R : Set where
    coinductive
    field
      out : D
open R

mutual
  d : D
  d = c r

  r : R
  out r = d

f : D → {A : Set} → A
f (c x) = f (out x)
-- should not termination check

absurd : {A : Set} → A
absurd = f d


------------------------------------------------------------------------
-- The SKI encoding into types
------------------------------------------------------------------------

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

module FOmegaInt.Undecidable.Encoding where

open import Data.Context.WellFormed
open import Data.List using ([]; _∷_)
open import Data.Nat using (ℕ; zero; suc; _+_)
open import Data.Fin using (Fin; zero; suc; raise)
open import Data.Fin.Substitution
open import Data.Fin.Substitution.ExtraLemmas
open import Relation.Binary.PropositionalEquality hiding ([_])

open import FOmegaInt.Syntax
open import FOmegaInt.Syntax.SingleVariableSubstitution
open import FOmegaInt.Syntax.HereditarySubstitution
open import FOmegaInt.Syntax.Normalization
open import FOmegaInt.Kinding.Canonical
open import FOmegaInt.Undecidable.SK

open Syntax
open ElimCtx
open ContextConversions using (⌞_⌟Ctx)
open RenamingCommutes
open Kinding
open ≡-Reasoning

----------------------------------------------------------------------
-- Support for the encoding: injection of shapes into kinds.

-- For every shape `k' there is a kind `⌈ k ⌉' that erases/simplifies
-- back to `k', i.e. `⌈_⌉' is a right inverse of kind erasure `⌊_⌋'.
--
-- NOTE. The definition here is almost identical to that in
-- FOmegaInt.Typing.Encodings except we inject shapes into `Kind Elim
-- n' rather than `Kind Term n'.

⌈_⌉ : ∀ {n} → SKind → Kind Elim n
⌈ ★     ⌉ = ⌜*⌝
⌈ j ⇒ k ⌉ = Π ⌈ j ⌉ ⌈ k ⌉

⌊⌋∘⌈⌉-id : ∀ {n} k → ⌊ ⌈_⌉ {n} k ⌋ ≡ k
⌊⌋∘⌈⌉-id ★       = refl
⌊⌋∘⌈⌉-id (j ⇒ k) = cong₂ _⇒_ (⌊⌋∘⌈⌉-id j) (⌊⌋∘⌈⌉-id k)

-- The kind `⌈ k ⌉' is well-formed (in any well-formed context).

⌈⌉-kd : ∀ {n} {Γ : Ctx n} k → Γ ctx → Γ ⊢ ⌈ k ⌉ kd
⌈⌉-kd ★       Γ-ctx = kd-⌜*⌝ Γ-ctx
⌈⌉-kd (j ⇒ k) Γ-ctx =
  let ⌈j⌉-kd = ⌈⌉-kd j Γ-ctx
  in kd-Π ⌈j⌉-kd (⌈⌉-kd k (wf-kd ⌈j⌉-kd ∷ Γ-ctx))

-- Injected kinds are stable under application of substitutions.

module InjSubstAppLemmas {T : ℕ → Set} (l : Lift T Term) where
  open Lift l
  open SubstApp l

  ⌈⌉-Kind/ : ∀ {m n} k {σ : Sub T m n} → ⌈ k ⌉ Kind′/ σ ≡ ⌈ k ⌉
  ⌈⌉-Kind/ ★       = refl
  ⌈⌉-Kind/ (j ⇒ k) = cong₂ Π (⌈⌉-Kind/ j) (⌈⌉-Kind/ k)

open Substitution hiding (subst; _[_]; _↑; sub)
open TermSubst termSubst using (varLift; termLift)

open InjSubstAppLemmas varLift public renaming (⌈⌉-Kind/ to ⌈⌉-Kind/Var)

⌈⌉-weaken : ∀ {n} k → weakenKind′ {n} ⌈ k ⌉ ≡ ⌈ k ⌉
⌈⌉-weaken k = ⌈⌉-Kind/Var k

kd-⌈⌉-weaken : ∀ {n} k → weakenElimAsc {n} (kd ⌈ k ⌉) ≡ kd ⌈ k ⌉
kd-⌈⌉-weaken k = cong kd (⌈⌉-weaken k)

kd-⌈⌉-weaken⋆ : ∀ {n k} m → weakenElimAsc⋆ m {n} (kd ⌈ k ⌉) ≡ kd ⌈ k ⌉
kd-⌈⌉-weaken⋆ zero    = refl
kd-⌈⌉-weaken⋆ (suc m) =
  trans (cong weakenElimAsc (kd-⌈⌉-weaken⋆ m)) (kd-⌈⌉-weaken _)

lookup-raise-* : ∀ {n m} {Γ : Ctx n} (E : CtxExt n m) {x} k →
                 lookup Γ x ≡ kd ⌈ k ⌉ →
                 lookup (E ++ Γ) (raise m x) ≡ kd ⌈ k ⌉
lookup-raise-* {_} {m} {Γ} E {x} k hyp = begin
  lookup (E ++ Γ) (raise m x)    ≡⟨ lookup-weaken⋆ m E Γ x ⟩
  weakenElimAsc⋆ m (lookup Γ x)  ≡⟨ cong (weakenElimAsc⋆ m) hyp ⟩
  weakenElimAsc⋆ m (kd ⌈ k ⌉)    ≡⟨ kd-⌈⌉-weaken⋆ m ⟩
  kd ⌈ k ⌉                       ∎
  where

------------------------------------------------------------------------
-- Encoding of SK terms into types

-- The encoding uses 7 type variables:
--
--  2 nullary operators encoding the combinators S and K,
--  1 binary operator encoding application,
--  2 ternary operators encoding the S reduction/expansion laws,
--  2 binary operators encoding the K reduction/expansion laws.
--
-- We define some pattern synonyms for readability of definitions.

|Γ| = 7

pattern x₀ = zero
pattern x₁ = suc zero
pattern x₂ = suc (suc zero)
pattern x₃ = suc (suc (suc zero))
pattern x₄ = suc (suc (suc (suc zero)))
pattern x₅ = suc (suc (suc (suc (suc zero))))
pattern x₆ = suc (suc (suc (suc (suc (suc zero)))))

module _ {n} where

  -- Shorthands to help with the encodings

  v₀ : Elim (1 + n)
  v₀ = var∙ x₀

  v₁ : Elim (2 + n)
  v₁ = var∙ x₁

  v₂ : Elim (3 + n)
  v₂ = var∙ x₂

module EncodingWeakened {n} m where

  -- NOTE. Here we assume (m + 3) variables in context, with the names
  -- of S, K and App being the first three.

  infixl 9 _⊛_

  encS : Elim (m + (3 + n))
  encS = var∙ (raise m x₂)

  encK : Elim (m + (3 + n))
  encK = var∙ (raise m x₁)

  _⊛_ : (a b : Elim (m + (3 + n))) → Elim (m + (3 + n))
  a ⊛ b = var (raise m x₀) ∙ (a ∷ b ∷ [])

  -- Encoding of SK terms into raw types with (m + 3) free variables.

  encode : SKTerm → Elim (m + (3 + n))
  encode S       = encS
  encode K       = encK
  encode (s · t) = (encode s) ⊛ (encode t)

module Encoding = EncodingWeakened {0} 4

module _ {n} where

  -- Operator kinds for combinator terms.

  kdS : Kind Elim (0 + n)
  kdS = ⌜*⌝

  kdK : Kind Elim (1 + n)
  kdK = ⌜*⌝

  kdApp : Kind Elim (2 + n)
  kdApp = Π ⌜*⌝ (Π ⌜*⌝ ⌜*⌝)

  -- Operator kinds reduction/expansion laws.

  kdSRed : Kind Elim (3 + n)
  kdSRed = Π ⌜*⌝ (Π ⌜*⌝ (Π ⌜*⌝
    (encS ⊛ v₂ ⊛ v₁ ⊛ v₀ ⋯ v₂ ⊛ v₀ ⊛ (v₁ ⊛ v₀))))
    where open EncodingWeakened (3 + 0)

  kdKRed : Kind Elim (4 + n)
  kdKRed = Π ⌜*⌝ (Π ⌜*⌝
    (encK ⊛ v₁ ⊛ v₀ ⋯ v₁))
    where open EncodingWeakened (2 + 1)

  kdSExp : Kind Elim (5 + n)
  kdSExp = Π ⌜*⌝ (Π ⌜*⌝ (Π ⌜*⌝
    (v₂ ⊛ v₀ ⊛ (v₁ ⊛ v₀) ⋯ encS ⊛ v₂ ⊛ v₁ ⊛ v₀)))
    where open EncodingWeakened (3 + 2)

  kdKExp : Kind Elim (6 + n)
  kdKExp = Π ⌜*⌝ (Π ⌜*⌝
    (v₁ ⋯ encK ⊛ v₁ ⊛ v₀))
    where open EncodingWeakened (2 + 3)

-- The context for the SK encoding (aka the signature)

Γ-SK : Ctx 3
Γ-SK = kd kdApp ∷ kd kdK ∷ kd kdS ∷ []

Γ-SK? : Ctx |Γ|
Γ-SK? = kd kdKExp ∷ kd kdSExp ∷ kd kdKRed ∷ kd kdSRed ∷ Γ-SK

⌞Γ-SK?⌟ : TermCtx.Ctx |Γ|
⌞Γ-SK?⌟ = ⌞ Γ-SK? ⌟Ctx

module _ where
  open Encoding
  private Γ-nf = nfCtx ⌞Γ-SK?⌟

  -- Encoded SK terms are in normal form.

  nf-encode : ∀ t → nf Γ-nf ⌞ encode t ⌟ ≡ encode t
  nf-encode S       = refl
  nf-encode K       = refl
  nf-encode (s · t) =
    cong₂ _⊛_ (begin
        weakenElim (nf Γ-nf ⌞ encode s ⌟) /⟨ ★ ⟩ sub (nf Γ-nf ⌞ encode t ⌟)
      ≡⟨ /Var-wk-↑⋆-hsub-vanishes 0 (nf Γ-nf ⌞ encode s ⌟) ⟩
        nf Γ-nf ⌞ encode s ⌟
      ≡⟨ nf-encode s ⟩
        encode s
      ∎) (nf-encode t)

------------------------------------------------------------------------
-- Canonical operator kinding of encodings

module KindedEncodingWeakened {m} (E : CtxExt 3 m)
                              (Γ-ctx : E ++ Γ-SK ctx) where

  open EncodingWeakened {0} m

  private Γ = E ++ Γ-SK

  -- Kinded encodings of the SK terms

  Ne∈-S : Γ ⊢Ne encS ∈ ⌜*⌝
  Ne∈-S = ∈-∙ (⇉-var _ Γ-ctx (lookup-raise-* E ★ refl)) ⇉-[]

  Ne∈-K : Γ ⊢Ne encK ∈ ⌜*⌝
  Ne∈-K = ∈-∙ (⇉-var _ Γ-ctx (lookup-raise-* E ★ refl)) ⇉-[]

  Ne∈-⊛ : ∀ {a b} → Γ ⊢Ne a ∈ ⌜*⌝ → Γ ⊢Ne b ∈ ⌜*⌝ → Γ ⊢Ne a ⊛ b ∈ ⌜*⌝
  Ne∈-⊛ a∈* b∈* =
    ∈-∙ (⇉-var _ Γ-ctx (lookup-raise-* E (★ ⇒ ★ ⇒ ★) refl))
        (⇉-∷ (Nf⇇-ne a∈*) (kd-⌜*⌝ Γ-ctx)
             (⇉-∷ (Nf⇇-ne b∈*) (kd-⌜*⌝ Γ-ctx) ⇉-[]))

  Ne∈-encode : (t : SKTerm) → Γ ⊢Ne encode t ∈ ⌜*⌝
  Ne∈-encode S       = Ne∈-S
  Ne∈-encode K       = Ne∈-K
  Ne∈-encode (s · t) = Ne∈-⊛ (Ne∈-encode s) (Ne∈-encode t)

-- Another shorthand

Ne∈-var : ∀ {n} {Γ : Ctx n} {k} x →
          Γ ctx → lookup Γ x ≡ kd k → Γ ⊢Ne var∙ x ∈ k
Ne∈-var x Γ-ctx Γ[x]≡k = ∈-∙ (⇉-var x Γ-ctx Γ[x]≡k) ⇉-[]

-- The signatures Γ-SK and Γ-SK? are well-formed

kdS-kd : [] ⊢ kdS kd
kdS-kd = kd-⌜*⌝ []

Γ₁-ctx : kd kdS ∷ [] ctx
Γ₁-ctx = wf-kd kdS-kd ∷ []

kdK-kd : kd kdS ∷ [] ⊢ kdK kd
kdK-kd = kd-⌜*⌝ Γ₁-ctx

Γ₂-ctx : kd kdK ∷ kd kdS ∷ [] ctx
Γ₂-ctx = wf-kd kdK-kd ∷ Γ₁-ctx

kdApp-kd : kd kdK ∷ kd kdS ∷ [] ⊢ kdApp kd
kdApp-kd = kd-Π *₂-kd (kd-Π *₃-kd (kd-⌜*⌝ (wf-kd *₃-kd ∷ Γ₃-ctx′)))
  where
    *₂-kd   = kd-⌜*⌝ Γ₂-ctx
    Γ₃-ctx′ = wf-kd *₂-kd ∷ Γ₂-ctx
    *₃-kd   = kd-⌜*⌝ Γ₃-ctx′

Γ-SK-ctx : Γ-SK ctx
Γ-SK-ctx = wf-kd kdApp-kd ∷ Γ₂-ctx

kdSRed-kd : Γ-SK ⊢ kdSRed kd
kdSRed-kd = kd-Π *₃-kd (kd-Π *₄-kd (kd-Π *₅-kd (kd-⋯
  (⇉-s-i (Ne∈-⊛ (Ne∈-⊛ (Ne∈-⊛ Ne∈-S (Ne∈-var x₂ Γ₆-ctx′ refl))
                       (Ne∈-var x₁ Γ₆-ctx′ refl)) (Ne∈-var x₀ Γ₆-ctx′ refl)))
  (⇉-s-i (Ne∈-⊛ (Ne∈-⊛ (Ne∈-var x₂ Γ₆-ctx′ refl) (Ne∈-var x₀ Γ₆-ctx′ refl))
                (Ne∈-⊛ (Ne∈-var x₁ Γ₆-ctx′ refl) (Ne∈-var x₀ Γ₆-ctx′ refl)))))))
  where
    *₃-kd   = kd-⌜*⌝ Γ-SK-ctx
    Γ₄-ctx′ = wf-kd *₃-kd ∷ Γ-SK-ctx
    *₄-kd   = kd-⌜*⌝ Γ₄-ctx′
    Γ₅-ctx′ = wf-kd *₄-kd ∷ Γ₄-ctx′
    *₅-kd   = kd-⌜*⌝ Γ₅-ctx′
    Γ₆-ctx′ = wf-kd *₅-kd ∷ Γ₅-ctx′

    open KindedEncodingWeakened (kd ⌜*⌝ ∷ kd ⌜*⌝ ∷ kd ⌜*⌝ ∷ []) Γ₆-ctx′

Γ₄-ctx : kd kdSRed ∷ Γ-SK ctx
Γ₄-ctx = wf-kd kdSRed-kd ∷ Γ-SK-ctx

kdKRed-kd : kd kdSRed ∷ Γ-SK ⊢ kdKRed kd
kdKRed-kd = (kd-Π *₄-kd (kd-Π *₅-kd (kd-⋯
  (⇉-s-i (Ne∈-⊛ (Ne∈-⊛ Ne∈-K (Ne∈-var x₁ Γ₆-ctx′ refl))
                (Ne∈-var x₀ Γ₆-ctx′ refl)))
  (⇉-s-i (Ne∈-var x₁ Γ₆-ctx′ refl)))))
  where
    *₄-kd   = kd-⌜*⌝ Γ₄-ctx
    Γ₅-ctx′ = wf-kd *₄-kd ∷ Γ₄-ctx
    *₅-kd   = kd-⌜*⌝ Γ₅-ctx′
    Γ₆-ctx′ = wf-kd *₅-kd ∷ Γ₅-ctx′

    open KindedEncodingWeakened (kd ⌜*⌝ ∷ kd ⌜*⌝ ∷ kd kdSRed ∷ []) Γ₆-ctx′

Γ₅-ctx : kd kdKRed ∷ kd kdSRed ∷ Γ-SK ctx
Γ₅-ctx = wf-kd kdKRed-kd ∷ Γ₄-ctx

kdSExp-kd : kd kdKRed ∷ kd kdSRed ∷ Γ-SK ⊢ kdSExp kd
kdSExp-kd = kd-Π *₅-kd (kd-Π *₆-kd (kd-Π *₇-kd (kd-⋯
  (⇉-s-i (Ne∈-⊛ (Ne∈-⊛ (Ne∈-var x₂ Γ₈-ctx′ refl) (Ne∈-var x₀ Γ₈-ctx′ refl))
                (Ne∈-⊛ (Ne∈-var x₁ Γ₈-ctx′ refl) (Ne∈-var x₀ Γ₈-ctx′ refl))))
  (⇉-s-i (Ne∈-⊛ (Ne∈-⊛ (Ne∈-⊛ Ne∈-S (Ne∈-var x₂ Γ₈-ctx′ refl))
                       (Ne∈-var x₁ Γ₈-ctx′ refl))
                (Ne∈-var x₀ Γ₈-ctx′ refl))))))
  where
    *₅-kd   = kd-⌜*⌝ Γ₅-ctx
    Γ₆-ctx′ = wf-kd *₅-kd ∷ Γ₅-ctx
    *₆-kd   = kd-⌜*⌝ Γ₆-ctx′
    Γ₇-ctx′ = wf-kd *₆-kd ∷ Γ₆-ctx′
    *₇-kd   = kd-⌜*⌝ Γ₇-ctx′
    Γ₈-ctx′ = wf-kd *₇-kd ∷ Γ₇-ctx′

    open KindedEncodingWeakened
      (kd ⌜*⌝ ∷ kd ⌜*⌝ ∷ kd ⌜*⌝ ∷ kd kdKRed ∷ kd kdSRed ∷ []) Γ₈-ctx′

Γ₆-ctx : kd kdSExp ∷ kd kdKRed ∷ kd kdSRed ∷ Γ-SK ctx
Γ₆-ctx = wf-kd kdSExp-kd ∷ Γ₅-ctx

kdKExp-kd : kd kdSExp ∷ kd kdKRed ∷ kd kdSRed ∷ Γ-SK ⊢ kdKExp kd
kdKExp-kd = (kd-Π *₆-kd (kd-Π *₇-kd (kd-⋯
  (⇉-s-i (Ne∈-var x₁ Γ₈-ctx′ refl))
  (⇉-s-i (Ne∈-⊛ (Ne∈-⊛ Ne∈-K (Ne∈-var x₁ Γ₈-ctx′ refl))
                (Ne∈-var x₀ Γ₈-ctx′ refl))))))
  where
    *₆-kd   = kd-⌜*⌝ Γ₆-ctx
    Γ₇-ctx′ = wf-kd *₆-kd ∷ Γ₆-ctx
    *₇-kd   = kd-⌜*⌝ Γ₇-ctx′
    Γ₈-ctx′ = wf-kd *₇-kd ∷ Γ₇-ctx′

    open KindedEncodingWeakened
      (kd ⌜*⌝ ∷ kd ⌜*⌝ ∷ kd kdSExp ∷ kd kdKRed ∷ kd kdSRed ∷ []) Γ₈-ctx′

Γ-SK?-ctx : Γ-SK? ctx
Γ-SK?-ctx = wf-kd kdKExp-kd ∷ Γ₆-ctx

module KindedEncoding =
  KindedEncodingWeakened
    (kd kdKExp ∷ kd kdSExp ∷ kd kdKRed ∷ kd kdSRed ∷ []) Γ-SK?-ctx

------------------------------------------------------------------------
-- Encoding of SK term equality in canonical subtyping

open Encoding
open KindedEncoding

-- Some helper lemmas.

wk-hsub-helper : ∀ {n} (a b c : Elim n) →
  (weakenElim (weakenElim a) /⟨ ★ ⟩ sub b ↑) [ c ∈ ★ ] ≡ a
wk-hsub-helper a b c = begin
    (weakenElim (weakenElim a) /⟨ ★ ⟩ sub b ↑) [ c ∈ ★ ]
  ≡⟨ cong (λ a → (a /⟨ ★ ⟩ sub b ↑) [ c ∈ ★ ]) (ELV.wk-commutes a) ⟩
    (weakenElim a Elim/Var V.wk V.↑ /⟨ ★ ⟩ sub b ↑) [ c ∈ ★ ]
  ≡⟨ cong (_[ c ∈ ★ ]) (/Var-wk-↑⋆-hsub-vanishes 1 (weakenElim a)) ⟩
    weakenElim a [ c ∈ ★ ]
  ≡⟨ /Var-wk-↑⋆-hsub-vanishes 0 a ⟩
    a
  ∎
  where
    module EL  = TermLikeLemmas termLikeLemmasElim
    module ELV = LiftAppLemmas EL.varLiftAppLemmas
    module V   = VarSubst

-- Admissible kinding and subtyping rules for construction the encoded
-- SK derivations.

<:-⊛ : ∀ {a₁ a₂ b₁ b₂} → Γ-SK? ⊢ a₁ ≃ a₂ ⇇ ⌜*⌝ → Γ-SK? ⊢ b₁ ≃ b₂ ⇇ ⌜*⌝ →
       Γ-SK? ⊢ a₁ ⊛ b₁ <: a₂ ⊛ b₂
<:-⊛ a₁≃a₂ b₁≃b₂ = <:-∙ (⇉-var _ Γ-SK?-ctx refl) (≃-∷ a₁≃a₂ (≃-∷ b₁≃b₂ ≃-[]))

Ne∈-Sᵣ : ∀ {a b c} →
         Γ-SK? ⊢Ne a ∈ ⌜*⌝ → Γ-SK? ⊢Ne b ∈ ⌜*⌝ → Γ-SK? ⊢Ne c ∈ ⌜*⌝ →
         Γ-SK? ⊢Ne var x₃ ∙ (a ∷ b ∷ c ∷ []) ∈
                   encS ⊛ a ⊛ b ⊛ c ⋯ a ⊛ c ⊛ (b ⊛ c)
Ne∈-Sᵣ {a} {b} {c} a∈* b∈* c∈* =
  ∈-∙ (⇉-var _ Γ-SK?-ctx refl)
      (⇉-∷ (Nf⇇-ne a∈*) *-kd
           (⇉-∷ (Nf⇇-ne b∈*) *-kd (⇉-∷ (Nf⇇-ne c∈*) *-kd ⇉-[]′)))
  where
    *-kd = kd-⌜*⌝ Γ-SK?-ctx
    a≡⟨⟨a/wk⟩/wk⟩[b][c] = wk-hsub-helper a b c
    b≡⟨b/wk⟩[c] = /Var-wk-↑⋆-hsub-vanishes 0 b
    ⇉-[]′ =
      subst₂ (λ a′ b′ →
        Γ-SK? ⊢ encS ⊛ a′ ⊛ b′ ⊛ c ⋯ a′ ⊛ c ⊛ (b′ ⊛ c) ⇉∙ [] ⇉
                encS ⊛ a ⊛ b ⊛ c ⋯ a ⊛ c ⊛ (b ⊛ c))
        (sym a≡⟨⟨a/wk⟩/wk⟩[b][c]) (sym b≡⟨b/wk⟩[c]) ⇉-[]

<:-Sᵣ : ∀ {a b c} →
        Γ-SK? ⊢Ne a ∈ ⌜*⌝ → Γ-SK? ⊢Ne b ∈ ⌜*⌝ → Γ-SK? ⊢Ne c ∈ ⌜*⌝ →
        Γ-SK? ⊢ encS ⊛ a ⊛ b ⊛ c <: a ⊛ c ⊛ (b ⊛ c)
<:-Sᵣ a∈* b∈* c∈* =
  <:-trans (<:-⟨| (Ne∈-Sᵣ a∈* b∈* c∈*)) (<:-|⟩ (Ne∈-Sᵣ a∈* b∈* c∈*))

Ne∈-Kᵣ : ∀ {a b} → Γ-SK? ⊢Ne a ∈ ⌜*⌝ → Γ-SK? ⊢Ne b ∈ ⌜*⌝ →
         Γ-SK? ⊢Ne var x₂ ∙ (a ∷ b ∷ []) ∈ encK ⊛ a ⊛ b ⋯ a
Ne∈-Kᵣ {a} {b} a∈* b∈* =
  ∈-∙ (⇉-var _ Γ-SK?-ctx refl)
      (⇉-∷ (Nf⇇-ne a∈*) *-kd
           (⇉-∷ (Nf⇇-ne b∈*) *-kd ⇉-[]′))
  where
    *-kd  = kd-⌜*⌝ Γ-SK?-ctx
    ⇉-[]′ =
      subst (λ a′ → Γ-SK? ⊢ encK ⊛ a′ ⊛ b ⋯ a′ ⇉∙ [] ⇉ encK ⊛ a ⊛ b ⋯ a)
            (sym (/Var-wk-↑⋆-hsub-vanishes 0 a)) ⇉-[]

<:-Kᵣ : ∀ {a b} → Γ-SK? ⊢Ne a ∈ ⌜*⌝ →
        Γ-SK? ⊢Ne b ∈ ⌜*⌝ → Γ-SK? ⊢ encK ⊛ a ⊛ b <: a
<:-Kᵣ a∈* b∈* = <:-trans (<:-⟨| (Ne∈-Kᵣ a∈* b∈*)) (<:-|⟩ (Ne∈-Kᵣ a∈* b∈*))

Ne∈-Sₑ : ∀ {a b c} →
         Γ-SK? ⊢Ne a ∈ ⌜*⌝ → Γ-SK? ⊢Ne b ∈ ⌜*⌝ → Γ-SK? ⊢Ne c ∈ ⌜*⌝ →
         Γ-SK? ⊢Ne var x₁ ∙ (a ∷ b ∷ c ∷ []) ∈
                   a ⊛ c ⊛ (b ⊛ c) ⋯ encS ⊛ a ⊛ b ⊛ c
Ne∈-Sₑ {a} {b} {c} a∈* b∈* c∈* =
  ∈-∙ (⇉-var _ Γ-SK?-ctx refl)
      (⇉-∷ (Nf⇇-ne a∈*) *-kd
           (⇉-∷ (Nf⇇-ne b∈*) *-kd (⇉-∷ (Nf⇇-ne c∈*) *-kd ⇉-[]′)))
  where
    *-kd = kd-⌜*⌝ Γ-SK?-ctx
    a≡⟨⟨a/wk⟩/wk⟩[b][c] = wk-hsub-helper a b c
    b≡⟨b/wk⟩[c] = /Var-wk-↑⋆-hsub-vanishes 0 b
    ⇉-[]′ =
      subst₂ (λ a′ b′ →
        Γ-SK? ⊢ a′ ⊛ c ⊛ (b′ ⊛ c) ⋯ encS ⊛ a′ ⊛ b′ ⊛ c ⇉∙ [] ⇉
                a ⊛ c ⊛ (b ⊛ c) ⋯ encS ⊛ a ⊛ b ⊛ c)
        (sym a≡⟨⟨a/wk⟩/wk⟩[b][c]) (sym b≡⟨b/wk⟩[c]) ⇉-[]

<:-Sₑ : ∀ {a b c} →
        Γ-SK? ⊢Ne a ∈ ⌜*⌝ → Γ-SK? ⊢Ne b ∈ ⌜*⌝ → Γ-SK? ⊢Ne c ∈ ⌜*⌝ →
        Γ-SK? ⊢ a ⊛ c ⊛ (b ⊛ c) <: encS ⊛ a ⊛ b ⊛ c
<:-Sₑ a∈* b∈* c∈* =
  <:-trans (<:-⟨| (Ne∈-Sₑ a∈* b∈* c∈*)) (<:-|⟩ (Ne∈-Sₑ a∈* b∈* c∈*))

Ne∈-Kₑ : ∀ {a b} → Γ-SK? ⊢Ne a ∈ ⌜*⌝ → Γ-SK? ⊢Ne b ∈ ⌜*⌝ →
         Γ-SK? ⊢Ne var x₀ ∙ (a ∷ b ∷ []) ∈ a ⋯ encK ⊛ a ⊛ b
Ne∈-Kₑ {a} {b} a∈* b∈* =
  ∈-∙ (⇉-var _ Γ-SK?-ctx refl)
      (⇉-∷ (Nf⇇-ne a∈*) *-kd
           (⇉-∷ (Nf⇇-ne b∈*) *-kd ⇉-[]′))
  where
    *-kd  = kd-⌜*⌝ Γ-SK?-ctx
    ⇉-[]′ =
      subst (λ a′ → Γ-SK? ⊢ a′ ⋯ encK ⊛ a′ ⊛ b ⇉∙ [] ⇉ a ⋯ encK ⊛ a ⊛ b)
            (sym (/Var-wk-↑⋆-hsub-vanishes 0 a)) ⇉-[]

<:-Kₑ : ∀ {a b} → Γ-SK? ⊢Ne a ∈ ⌜*⌝ →
        Γ-SK? ⊢Ne b ∈ ⌜*⌝ → Γ-SK? ⊢ a <: encK ⊛ a ⊛ b
<:-Kₑ a∈* b∈* = <:-trans (<:-⟨| (Ne∈-Kₑ a∈* b∈*)) (<:-|⟩ (Ne∈-Kₑ a∈* b∈*))

-- Encoding of SK term equality in canonical subtyping

mutual

  <:-encode : ∀ {s t} → s ≡SK t → Γ-SK? ⊢ encode s <: encode t
  <:-encode (≡-refl {t})         = <:-reflNf⇉ (⇉-s-i (Ne∈-encode t))
  <:-encode (≡-trans s≡t t≡u)    = <:-trans (<:-encode s≡t) (<:-encode t≡u)
  <:-encode (≡-sym t≡s)          = :>-encode t≡s
  <:-encode (≡-Sred {s} {t} {u}) =
    <:-Sᵣ (Ne∈-encode s) (Ne∈-encode t) (Ne∈-encode u)
  <:-encode (≡-Kred {s} {t})     = <:-Kᵣ (Ne∈-encode s) (Ne∈-encode t)
  <:-encode (≡-· s₁≡t₁ s₂≡t₂)    = <:-⊛ (≃-encode s₁≡t₁) (≃-encode s₂≡t₂)

  :>-encode : ∀ {s t} → s ≡SK t → Γ-SK? ⊢ encode t <: encode s
  :>-encode (≡-refl {t})         = <:-reflNf⇉ (⇉-s-i (Ne∈-encode t))
  :>-encode (≡-trans s≡t t≡u)    = <:-trans (:>-encode t≡u) (:>-encode s≡t)
  :>-encode (≡-sym t≡s)          = <:-encode t≡s
  :>-encode (≡-Sred {s} {t} {u}) =
    <:-Sₑ (Ne∈-encode s) (Ne∈-encode t) (Ne∈-encode u)
  :>-encode (≡-Kred {s} {t})     = <:-Kₑ (Ne∈-encode s) (Ne∈-encode t)
  :>-encode (≡-· s₁≡t₁ s₂≡t₂)    =
    <:-⊛ (≃-sym (≃-encode s₁≡t₁)) (≃-sym (≃-encode s₂≡t₂))

  ≃-encode : ∀ {s t} → s ≡SK t → Γ-SK? ⊢ encode s ≃ encode t ⇇ ⌜*⌝
  ≃-encode {s} {t} s≡t =
    let es⇇* = Nf⇇-ne (Ne∈-encode s)
        et⇇* = Nf⇇-ne (Ne∈-encode t)
    in <:-antisym (kd-⌜*⌝ Γ-SK?-ctx)
                  (<:-⇇ es⇇* et⇇* (<:-encode s≡t))
                  (<:-⇇ et⇇* es⇇* (:>-encode s≡t))

<:⇇-encode : ∀ {s t} → s ≡SK t → Γ-SK? ⊢ encode s <: encode t ⇇ ⌜*⌝
<:⇇-encode {s} {t} s≡t =
  <:-⇇ (Nf⇇-ne (Ne∈-encode s)) (Nf⇇-ne (Ne∈-encode t)) (<:-encode s≡t)


------------------------------------------------------------------------
-- Examples related to Univalence-axiom.Isomorphism-is-equality.More
------------------------------------------------------------------------

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

-- Note that this module uses ordinary propositional equality, with a
-- computing J rule.

-- This module has been developed in collaboration with Thierry
-- Coquand.

module Univalence-axiom.Isomorphism-is-equality.More.Examples where

open import Equality.Propositional renaming (equality-with-J to eq)

open import Equivalence eq hiding (id)
open import Function-universe eq hiding (id)
open import H-level.Closure eq
open import Prelude hiding (id)
open import Univalence-axiom.Isomorphism-is-equality.More

------------------------------------------------------------------------
-- Magmas

magma : Code
magma = ε ▻ A-type ▻ N-ary [0] 2

Magma : Type₁
Magma = ⟦ magma ⟧

private

  -- An unfolding of Magma.

  Magma-unfolded :
    Magma ≡ Σ (Σ (↑ _ ⊤) λ _ →
    Type                   ) λ { (_ , A) →
    ↑ _ A → ↑ _ A → ↑ _ A }
  Magma-unfolded = refl

  -- An unfolding of Isomorphic magma.

  Isomorphic-magma-unfolded :
    ∀ {ass A₁ f₁ A₂ f₂} →
    Isomorphic ass magma ((_ , A₁) , f₁) ((_ , A₂) , f₂) ≡
    Σ (Σ (↑ _ ⊤) λ _ →
      ↑ _ (A₁ ≃ A₂)                             ) λ { (_ , lift A₁≃A₂) →
      let open _≃_ (↑-cong A₁≃A₂) in
        ∀ x y → to (f₁ x y) ≡ f₂ (to x) (to y) }
  Isomorphic-magma-unfolded = refl

------------------------------------------------------------------------
-- Semigroups

-- Note that one axiom states that the underlying type is a set. This
-- assumption is used to prove that the other axiom is propositional.

semigroup : Code
semigroup =
  ε

  ▻ A-type

  ▻ Is-a-set [0]

  ▻ N-ary (1+ [0]) 2

  ▻ Proposition
      (λ { (_ , _∙_) →
           ∀ x y z → (x ∙ (y ∙ z)) ≡ ((x ∙ y) ∙ z) })
      assoc-prop

  where
  assoc-prop = λ { ass ((_ , A-set) , _) →
    let open Assumptions ass in
    Π-closure ext₁ 1 λ _ →
    Π-closure ext₁ 1 λ _ →
    Π-closure ext₁ 1 λ _ →
    A-set }

Semigroup : Type₁
Semigroup = ⟦ semigroup ⟧

private

  -- An unfolding of Semigroup.

  Semigroup-unfolded :
    Semigroup ≡ Σ (Σ (Σ (Σ (↑ _ ⊤) λ _ →
      Type                                     ) λ {  (_ , A) →
      Is-set (↑ _ A)                          }) λ { ((_ , A) , _) →
      ↑ _ A → ↑ _ A → ↑ _ A                   }) λ { (_ , _∙_) →
      ∀ x y z → (x ∙ (y ∙ z)) ≡ ((x ∙ y) ∙ z) }
  Semigroup-unfolded = refl

  -- An unfolding of Isomorphic semigroup.

  Isomorphic-semigroup-unfolded :
    ∀ {ass A₁} {is₁ : Is-set (↑ _ A₁)} {_∙₁_ assoc₁}
          {A₂} {is₂ : Is-set (↑ _ A₂)} {_∙₂_ assoc₂} →
    Isomorphic ass semigroup ((((_ , A₁) , is₁) , _∙₁_) , assoc₁)
                             ((((_ , A₂) , is₂) , _∙₂_) , assoc₂) ≡
    Σ (Σ (Σ (Σ (↑ _ ⊤) λ _ →
      ↑ _ (A₁ ≃ A₂)                           ) λ { _ →
      ↑ _ ⊤                                  }) λ { ((_ , lift A₁≃A₂) , _) →
      let open _≃_ (↑-cong A₁≃A₂) in
        ∀ x y → to (x ∙₁ y) ≡ (to x ∙₂ to y) }) λ { _ →
      ↑ _ ⊤                                  }
  Isomorphic-semigroup-unfolded = refl

------------------------------------------------------------------------
-- Sets with fixed-point operators

set-with-fixed-point-operator : Code
set-with-fixed-point-operator =
  ε

  ▻ A-type

  ▻ Is-a-set [0]

  ▻ Simple ((base (1+ [0]) ⟶ base (1+ [0])) ⟶ base (1+ [0]))

  ▻ Proposition
      (λ { (_ , fix) →
           ∀ f → fix f ≡ f (fix f) })
      fix-point-prop

  where
  fix-point-prop = λ { ass ((_ , A-set) , _) →
    let open Assumptions ass in
    Π-closure ext₁ 1 λ _ →
    A-set }

Set-with-fixed-point-operator : Type₁
Set-with-fixed-point-operator = ⟦ set-with-fixed-point-operator ⟧

private

  -- An unfolding of Set-with-fixed-point-operator.

  Set-with-fixed-point-operator-unfolded :
    Set-with-fixed-point-operator ≡ Σ (Σ (Σ (Σ (↑ _ ⊤) λ _ →
      Type                     ) λ {  (_ , A) →
      Is-set (↑ _ A)          }) λ { ((_ , A) , _) →
      (↑ _ A → ↑ _ A) → ↑ _ A }) λ { (_ , fix) →
      ∀ f → fix f ≡ f (fix f) }
  Set-with-fixed-point-operator-unfolded = refl

  -- An unfolding of Isomorphic set-with-fixed-point-operator.

  Isomorphic-set-with-fixed-point-operator-unfolded :
    ∀ {ass A₁} {is₁ : Is-set (↑ _ A₁)} {fix₁ fixed-point₁}
          {A₂} {is₂ : Is-set (↑ _ A₂)} {fix₂ fixed-point₂} →
    Isomorphic ass set-with-fixed-point-operator
               ((((_ , A₁) , is₁) , fix₁) , fixed-point₁)
               ((((_ , A₂) , is₂) , fix₂) , fixed-point₂) ≡
    Σ (Σ (Σ (Σ (↑ _ ⊤) λ _ →
      ↑ _ (A₁ ≃ A₂)                             ) λ { _ →
      ↑ _ ⊤                                    }) λ { ((_ , lift A₁≃A₂) , _) →
      let open _≃_ (↑-cong A₁≃A₂) in
        ∀ f g →
        (∀ x y → to x ≡ y → to (f x) ≡ g y) →
        to (fix₁ f) ≡ fix₂ g                   }) λ { _ →
      ↑ _ ⊤                                    }
  Isomorphic-set-with-fixed-point-operator-unfolded = refl

------------------------------------------------------------------------
-- Abelian groups

abelian-group : Code
abelian-group =
  ε

  -- The underlying type.
  ▻ A-type

  -- The underlying type is a set.
  ▻ Is-a-set [0]

  -- The binary group operation.
  ▻ N-ary (1+ [0]) 2

  -- Commutativity.
  ▻ Comm

  -- Associativity.
  ▻ Assoc

  -- Identity.
  ▻ N-ary (1+ 1+ 1+ 1+ [0]) 0

  -- Left identity.
  ▻ Left-identity

  -- Right identity.
  ▻ Right-identity

  -- Inverse.
  ▻ N-ary (1+ 1+ 1+ 1+ 1+ 1+ 1+ [0]) 1

  -- Left inverse.
  ▻ Left-inverse

  -- Right inverse.
  ▻ Right-inverse

  where
  Comm = Proposition
    (λ { (_ , _∙_) →
       ∀ x y → (x ∙ y) ≡ (y ∙ x) })

    (λ { ass ((_ , A-set) , _) →
       let open Assumptions ass in
       Π-closure ext₁ 1 λ _ →
       Π-closure ext₁ 1 λ _ →
       A-set
     })

  Assoc = Proposition
    (λ { ((_ , _∙_) , _) →
         ∀ x y z → (x ∙ (y ∙ z)) ≡ ((x ∙ y) ∙ z) })

    (λ { ass (((_ , A-set) , _) , _) →
       let open Assumptions ass in
       Π-closure ext₁ 1 λ _ →
       Π-closure ext₁ 1 λ _ →
       Π-closure ext₁ 1 λ _ →
       A-set
     })

  Left-identity = Proposition
    (λ { ((((_ , _∙_) , _) , _) , e) →
         ∀ x → (e ∙ x) ≡ x })

    (λ { ass (((((_ , A-set) , _) , _) , _) , _) →
       let open Assumptions ass in
       Π-closure ext₁ 1 λ _ →
       A-set
     })

  Right-identity = Proposition
    (λ { (((((_ , _∙_) , _) , _) , e) , _) →
         ∀ x → (x ∙ e) ≡ x })

    (λ { ass ((((((_ , A-set) , _) , _) , _) , _) , _) →
       let open Assumptions ass in
       Π-closure ext₁ 1 λ _ →
       A-set
     })

  Left-inverse = Proposition
    (λ { (((((((_ , _∙_) , _) , _) , e) , _) , _) , _⁻¹) →
         ∀ x → ((x ⁻¹) ∙ x) ≡ e })

    (λ { ass ((((((((_ , A-set) , _) , _) , _) , _) , _) , _) , _) →
       let open Assumptions ass in
       Π-closure ext₁ 1 λ _ →
       A-set
     })

  Right-inverse = Proposition
    (λ { ((((((((_ , _∙_) , _) , _) , e) , _) , _) , _⁻¹) , _) →
         ∀ x → (x ∙ (x ⁻¹)) ≡ e })

    (λ { ass (((((((((_ , A-set) , _) , _) , _) , _) , _) , _) , _) , _) →
       let open Assumptions ass in
       Π-closure ext₁ 1 λ _ →
       A-set
     })

Abelian-group : Type₁
Abelian-group = ⟦ abelian-group ⟧

private

  -- An unfolding of Abelian-group. Note that the inner structure is
  -- left-nested.

  Abelian-group-unfolded :
    Abelian-group ≡ Σ (Σ (Σ (Σ (Σ (Σ (Σ (Σ (Σ (Σ (Σ (↑ _ ⊤) λ _ →
      Type                                     ) λ {        (_ , A) →
      Is-set (↑ _ A)                          }) λ {       ((_ , A) , _) →
      ↑ _ A → ↑ _ A → ↑ _ A                   }) λ {                  (_ , _∙_) →
      ∀ x y → (x ∙ y) ≡ (y ∙ x)               }) λ {                 ((_ , _∙_) , _) →
      ∀ x y z → (x ∙ (y ∙ z)) ≡ ((x ∙ y) ∙ z) }) λ {    (((((_ , A) , _) , _  ) , _) , _) →
      ↑ _ A                                   }) λ {               ((((_ , _∙_) , _) , _) , e) →
      ∀ x → (e ∙ x) ≡ x                       }) λ {              (((((_ , _∙_) , _) , _) , e) , _) →
      ∀ x → (x ∙ e) ≡ x                       }) λ { ((((((((_ , A) , _) , _  ) , _) , _) , _) , _) , _) →
      ↑ _ A → ↑ _ A                           }) λ {            (((((((_ , _∙_) , _) , _) , e) , _) , _) , _⁻¹) →
      ∀ x → ((x ⁻¹) ∙ x) ≡ e                  }) λ {           ((((((((_ , _∙_) , _) , _) , e) , _) , _) , _⁻¹) , _) →
      ∀ x → (x ∙ (x ⁻¹)) ≡ e                  }
  Abelian-group-unfolded = refl

  -- An unfolding of Isomorphic abelian-group.

  Isomorphic-abelian-group-unfolded :
    ∀ {ass A₁} {is₁ : Is-set (↑ _ A₁)}
      {_∙₁_ comm₁ assoc₁ e₁ lid₁ rid₁ _⁻¹₁ linv₁ rinv₁}
      {A₂} {is₂ : Is-set (↑ _ A₂)}
      {_∙₂_ comm₂ assoc₂ e₂ lid₂ rid₂ _⁻¹₂ linv₂ rinv₂} →
    Isomorphic ass abelian-group
      (((((((((((_ , A₁) , is₁) , _∙₁_) , comm₁) ,
       assoc₁) , e₁) , lid₁) , rid₁) , _⁻¹₁) , linv₁) , rinv₁)
      (((((((((((_ , A₂) , is₂) , _∙₂_) , comm₂) ,
       assoc₂) , e₂) , lid₂) , rid₂) , _⁻¹₂) , linv₂) , rinv₂) ≡
    Σ (Σ (Σ (Σ (Σ (Σ (Σ (Σ (Σ (Σ (Σ (↑ _ ⊤) λ _ →
      ↑ _ (A₁ ≃ A₂)                           ) λ { _ →
      ↑ _ ⊤                                  }) λ {       ((_ , lift A₁≃A₂) , _) →
      let open _≃_ (↑-cong A₁≃A₂) in
        ∀ x y → to (x ∙₁ y) ≡ (to x ∙₂ to y) }) λ { _ →
      ↑ _ ⊤                                  }) λ { _ →
      ↑ _ ⊤                                  }) λ {    (((((_ , lift A₁≃A₂) , _) , _) , _) , _) →
      let open _≃_ (↑-cong A₁≃A₂) in
        to e₁ ≡ e₂                           }) λ { _ →
      ↑ _ ⊤                                  }) λ { _ →
      ↑ _ ⊤                                  }) λ { ((((((((_ , lift A₁≃A₂) , _) , _) , _) , _) , _) , _) , _) →
      let open _≃_ (↑-cong A₁≃A₂) in
        ∀ x → to (x ⁻¹₁) ≡ (to x ⁻¹₂)        }) λ { _ →
      ↑ _ ⊤                                  }) λ { _ →
      ↑ _ ⊤                                  }
  Isomorphic-abelian-group-unfolded = refl

------------------------------------------------------------------------
-- Church-encoded natural numbers for which we can do induction

-- Church-encoded natural numbers.

Nat : Type₁
Nat = (A : Type) → ↑ (# 1) A → (↑ (# 1) A → ↑ (# 1) A) → ↑ (# 1) A

-- Zero and successor.

Zero : Nat
Zero = λ A z s → z

Suc : Nat → Nat
Suc = λ n A z s → s (n A z s)

-- The code.

inductive-natural-numbers : Code
inductive-natural-numbers =
  ε

  ▻ Dep (Π set (Π (base ⟨0⟩)
                  (Π (Π (base (1+ ⟨0⟩)) (base (1+ 1+ ⟨0⟩)))
                     (base (1+ 1+ ⟨0⟩)))))

  ▻ Proposition
      (λ { (_ , n) →
           (P : Nat → Type) →
           Is-proposition (P n) →
           P Zero →
           (∀ m → P m → P (Suc m)) →
           P n })
      (λ ass _ →
           let open Assumptions ass in
           Π-closure ext₁ 1 λ _ →
           Π-closure (lower-extensionality (# 1) (# 0) ext₁) 1 λ Pn-prop →
           Π-closure (lower-extensionality (# 1) (# 0) ext₁) 1 λ _ →
           Π-closure (lower-extensionality (# 0) (# 1) ext₁) 1 λ _ →
           Pn-prop)

  where open Dependent

private

  -- The usual unfolding lemmas.

  ⟦inductive-natural-numbers⟧ :

    ⟦ inductive-natural-numbers ⟧
      ≡
    Σ (Σ (↑ _ ⊤) λ _ →
      Nat                        ) λ { (_ , n) →
      (P : Nat → Type) →
      Is-proposition (P n) →
      P Zero →
      (∀ m → P m → P (Suc m)) →
      P n                       }
  ⟦inductive-natural-numbers⟧ = refl

  Isomorphic-inductive-natural-numbers :
    ∀ {ass : Assumptions}
      {n₁ n₂ : Nat}
      {prop₁ : (P : Nat → Type) → Is-proposition (P n₁) →
               P Zero → (∀ m → P m → P (Suc m)) → P n₁}
      {prop₂ : (P : Nat → Type) → Is-proposition (P n₂) →
               P Zero → (∀ m → P m → P (Suc m)) → P n₂} →

    Isomorphic ass inductive-natural-numbers
                   ((_ , n₁) , prop₁) ((_ , n₂) , prop₂)
      ≡
    Σ (Σ (↑ (# 1) ⊤) λ _ →
    ((A₁ A₂ : Type) → (A₁≃A₂ : ↑ (# 1) (A₁ ≃ A₂)) →
     let cast = _≃_.from (↑-cong (lower A₁≃A₂)) in
     (z₁ : ↑ (# 1) A₁) (z₂ : ↑ (# 1) A₂) →
       z₁ ≡ cast z₂ →
     (s₁ : ↑ (# 1) A₁ → ↑ (# 1) A₁) (s₂ : ↑ (# 1) A₂ → ↑ (# 1) A₂) →
       (∀ n₁ n₂ → n₁ ≡ cast n₂ → s₁ n₁ ≡ cast (s₂ n₂)) →
     n₁ A₁ z₁ s₁ ≡ cast (n₂ A₂ z₂ s₂))) λ _ →
    ↑ (# 1) ⊤

  Isomorphic-inductive-natural-numbers = refl


{-# OPTIONS --cubical --no-import-sorts --safe #-}
module Cubical.HITs.2GroupoidTruncation where

open import Cubical.HITs.2GroupoidTruncation.Base public
open import Cubical.HITs.2GroupoidTruncation.Properties public


{-# OPTIONS --safe #-}
module Cubical.HITs.Cost where

open import Cubical.HITs.Cost.Base