------------------------------------------------------------------------
-- A definitional interpreter that is instrumented with information
-- about the number of steps required to run the compiled program
------------------------------------------------------------------------

open import Prelude

import Lambda.Syntax

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

import Equality.Propositional as E

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

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

open import Lambda.Delay-crash
import Lambda.Interpreter def as I

open Closure Tm

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

-- A step annotation.

infix 1 ✓_

✓_ : ∀ {A i} → Delay-crash A i → Delay-crash A i
✓ x = later λ { .force → x }

-- The instrumented interpreter.

infix 10 _∙_

mutual

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

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

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

------------------------------------------------------------------------
-- The semantics given above gives the same (uninstrumented) result as
-- the one in Lambda.Interpreter

mutual

  -- The result of the instrumented interpreter is an expansion of
  -- that of the uninstrumented interpreter.

  ⟦⟧≳⟦⟧ :
    ∀ {i n} (t : Tm n) {ρ : Env n} →
    [ i ] ⟦ t ⟧ ρ ≳ I.⟦ t ⟧ ρ
  ⟦⟧≳⟦⟧ (var x)       = laterˡ (reflexive _)
  ⟦⟧≳⟦⟧ (lam t)       = laterˡ (reflexive _)
  ⟦⟧≳⟦⟧ (t₁ · t₂)     = ⟦⟧≳⟦⟧ t₁ >>=-cong λ _ →
                        ⟦⟧≳⟦⟧ t₂ >>=-cong λ _ →
                        ∙≳∙ _
  ⟦⟧≳⟦⟧ (call f t)    = ⟦⟧≳⟦⟧ t >>=-cong λ _ →
                        ∙≳∙ _
  ⟦⟧≳⟦⟧ (con b)       = laterˡ (reflexive _)
  ⟦⟧≳⟦⟧ (if t₁ t₂ t₃) = ⟦⟧≳⟦⟧ t₁ >>=-cong λ _ →
                        ⟦if⟧≳⟦if⟧ _ t₂ t₃

  ∙≳∙ :
    ∀ {i} (v₁ {v₂} : Value) →
    [ i ] v₁ ∙ v₂ ≳ v₁ I.∙ v₂
  ∙≳∙ (lam t₁ ρ) = later λ { .force → ⟦⟧≳⟦⟧ t₁ }
  ∙≳∙ (con _)    = reflexive _

  ⟦if⟧≳⟦if⟧ :
    ∀ {i n} v₁ (t₂ t₃ : Tm n) {ρ} →
    [ i ] ⟦if⟧ v₁ t₂ t₃ ρ ≳ I.⟦if⟧ v₁ t₂ t₃ ρ
  ⟦if⟧≳⟦if⟧ (lam _ _)   _  _  = reflexive _
  ⟦if⟧≳⟦if⟧ (con true)  t₂ t₃ = laterˡ (⟦⟧≳⟦⟧ t₂)
  ⟦if⟧≳⟦if⟧ (con false) t₂ t₃ = laterˡ (⟦⟧≳⟦⟧ t₃)


open import FRP.JS.RSet using ( RSet ; _⇒_ ; ⟦_⟧ ; ⟨_⟩ )

module FRP.JS.Event where

infixr 4 _∪_

postulate
  Evt : RSet → RSet
  map : ∀ {A B} → ⟦ A ⇒ B ⟧ → ⟦ Evt A ⇒ Evt B ⟧
  ∅ : ∀ {A} → ⟦ Evt A ⟧
  _∪_ : ∀ {A} → ⟦ Evt A ⇒ Evt A ⇒ Evt A ⟧
  accumBy : ∀ {A B} → ⟦ ⟨ B ⟩ ⇒ A ⇒ ⟨ B ⟩ ⟧ → B → ⟦ Evt A ⇒ Evt ⟨ B ⟩ ⟧

{-# COMPILED_JS map function(A) { return function(B) {
  return function(f) { return function(s) { return function(e) {
    return e.map(function (t,v) { return f(t)(v); });
  }; }; };
}; } #-}

{-# COMPILED_JS ∅ function(A) { return require("agda.frp.signal").zero; } #-}

{-# COMPILED_JS _∪_ function(A) { return function(s) {
  return function(x) { return function(y) { return x.merge(y); }; };
}; } #-}

{-# COMPILED_JS accumBy function(A) { return function(B) { return function(f) {
  return function(b) { return function(s) { return function(e) {
    return e.accumBy(function(t,b,a) { return f(t)(b)(a); },b);
  }; }; };
}; }; } #-}

tag : ∀ {A B} → ⟦ B ⟧ → ⟦ Evt A ⇒ Evt B ⟧
tag b = map (λ _ → b)


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

syntax Inception | IA

type
  L : 0-ary
  P : 0-ary
  A : 0-ary

term
  rec : L  P  ->  A
  inc : L.A  P.A  ->  A

theory
  (S) p : P   a : P.A |> inc (l. rec (l, p[]), x. a[x]) = a[p[]]
  (E) a : L.A  |> k : L |- inc (l. a[l], x. rec(k, x)) = a[k]
  (W) m : A  a : P.A  |> inc (l. m[], x. a[x]) = m[]
  (A) p : (L,L).A  a : (L,P).A  b : P.A |>         inc (l. inc (k. p[l, k], x. a[l,x]), y. b[y])       = inc (k. inc(l. p[l,k], y.b[y]), x. inc(l. a[l,x], y.b[y]))
-}

module Inception.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 Inception.Signature

private
  variable
    Γ Δ Π : Ctx
    α : IAT
    𝔛 : Familyₛ

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

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

    rec : IA L Γ → IA P Γ → IA A Γ
    inc : IA A (L ∙ Γ) → IA A (P ∙ Γ) → IA A Γ

  open import SOAS.Metatheory.MetaAlgebra ⅀F 𝔛

  IAᵃ : MetaAlg IA
  IAᵃ = record
    { 𝑎𝑙𝑔 = λ where
      (recₒ ⋮ a , b) → rec a b
      (incₒ ⋮ a , b) → inc a b
    ; 𝑣𝑎𝑟 = var ; 𝑚𝑣𝑎𝑟 = λ 𝔪 mε → mvar 𝔪 (tabulate mε) }

  module IAᵃ = MetaAlg IAᵃ

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

    open MetaAlg 𝒜ᵃ

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

    𝕤𝕖𝕞 (rec a b) = 𝑎𝑙𝑔 (recₒ ⋮ 𝕤𝕖𝕞 a , 𝕤𝕖𝕞 b)
    𝕤𝕖𝕞 (inc a b) = 𝑎𝑙𝑔 (incₒ ⋮ 𝕤𝕖𝕞 a , 𝕤𝕖𝕞 b)

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

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

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

      open MetaAlg⇒ gᵃ⇒

      𝕤𝕖𝕞! : (t : IA α Γ) → 𝕤𝕖𝕞 t ≡ g t
      𝕊-ix : (mε : Sub IA Π Γ)(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 ⟨𝑣𝑎𝑟⟩

      𝕤𝕖𝕞! (rec a b) rewrite 𝕤𝕖𝕞! a | 𝕤𝕖𝕞! b = sym ⟨𝑎𝑙𝑔⟩
      𝕤𝕖𝕞! (inc a b) rewrite 𝕤𝕖𝕞! a | 𝕤𝕖𝕞! b = sym ⟨𝑎𝑙𝑔⟩

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

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


module STLC.Kovacs.Embedding where

open import STLC.Syntax public
open import Category

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

-- Embeddings (OPE ; ∙ ; drop ; keep)
infix 4 _⊇_
data _⊇_ : 𝒞 → 𝒞 → Set
  where
    done  : ∅ ⊇ ∅

    wkₑ   : ∀ {Γ Γ′ A} → (η : Γ′ ⊇ Γ)
                       → Γ′ , A ⊇ Γ

    liftₑ : ∀ {Γ Γ′ A} → (η : Γ′ ⊇ Γ)
                       → Γ′ , A ⊇ Γ , A

idₑ : ∀ {Γ} → Γ ⊇ Γ
idₑ {∅}     = done
idₑ {Γ , A} = liftₑ idₑ

-- (_∘ₑ_)
_○_ : ∀ {Γ Γ′ Γ″} → Γ′ ⊇ Γ → Γ″ ⊇ Γ′ → Γ″ ⊇ Γ
η₂       ○ done     = η₂
η₂       ○ wkₑ η₁   = wkₑ (η₂ ○ η₁)
wkₑ η₂   ○ liftₑ η₁ = wkₑ (η₂ ○ η₁)
liftₑ η₂ ○ liftₑ η₁ = liftₑ (η₂ ○ η₁)

-- (idlₑ)
lid○ : ∀ {Γ Γ′} → (η : Γ′ ⊇ Γ)
                → idₑ ○ η ≡ η
lid○ done      = refl
lid○ (wkₑ η)   = wkₑ & lid○ η
lid○ (liftₑ η) = liftₑ & lid○ η

-- (idrₑ)
rid○ : ∀ {Γ Γ′} → (η : Γ′ ⊇ Γ)
                → η ○ idₑ ≡ η
rid○ done      = refl
rid○ (wkₑ η)   = wkₑ & rid○ η
rid○ (liftₑ η) = liftₑ & rid○ η

-- (assₑ)
assoc○ : ∀ {Γ Γ′ Γ″ Γ‴} → (η₁ : Γ‴ ⊇ Γ″) (η₂ : Γ″ ⊇ Γ′) (η₃ : Γ′ ⊇ Γ)
                        → (η₃ ○ η₂) ○ η₁ ≡ η₃ ○ (η₂ ○ η₁)
assoc○ done       η₂         η₃         = refl
assoc○ (wkₑ η₁)   η₂         η₃         = wkₑ & assoc○ η₁ η₂ η₃
assoc○ (liftₑ η₁) (wkₑ η₂)   η₃         = wkₑ & assoc○ η₁ η₂ η₃
assoc○ (liftₑ η₁) (liftₑ η₂) (wkₑ η₃)   = wkₑ & assoc○ η₁ η₂ η₃
assoc○ (liftₑ η₁) (liftₑ η₂) (liftₑ η₃) = liftₑ & assoc○ η₁ η₂ η₃

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

-- (∈ₑ)
getₑ : ∀ {Γ Γ′ A} → Γ′ ⊇ Γ → Γ ∋ A → Γ′ ∋ A
getₑ done      i       = i
getₑ (wkₑ η)   i       = suc (getₑ η i)
getₑ (liftₑ η) zero    = zero
getₑ (liftₑ η) (suc i) = suc (getₑ η i)

-- (∈-idₑ)
idgetₑ : ∀ {Γ A} → (i : Γ ∋ A)
                 → getₑ idₑ i ≡ i
idgetₑ zero    = refl
idgetₑ (suc i) = suc & idgetₑ i

-- (∈-∘ₑ)
get○ : ∀ {Γ Γ′ Γ″ A} → (η₁ : Γ″ ⊇ Γ′) (η₂ : Γ′ ⊇ Γ) (i : Γ ∋ A)
                     → getₑ (η₂ ○ η₁) i ≡ (getₑ η₁ ∘ getₑ η₂) i
get○ done       done       ()
get○ (wkₑ η₁)   η₂         i       = suc & get○ η₁ η₂ i
get○ (liftₑ η₁) (wkₑ η₂)   i       = suc & get○ η₁ η₂ i
get○ (liftₑ η₁) (liftₑ η₂) zero    = refl
get○ (liftₑ η₁) (liftₑ η₂) (suc i) = suc & get○ η₁ η₂ i

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

-- (Tmₑ)
ren : ∀ {Γ Γ′ A} → Γ′ ⊇ Γ → Γ ⊢ A → Γ′ ⊢ A
ren η (𝓋 i)   = 𝓋 (getₑ η i)
ren η (ƛ M)   = ƛ (ren (liftₑ η) M)
ren η (M ∙ N) = ren η M ∙ ren η N

wk : ∀ {B Γ A} → Γ ⊢ A → Γ , B ⊢ A
wk M = ren (wkₑ idₑ) M

-- (Tm-idₑ)
idren : ∀ {Γ A} → (M : Γ ⊢ A)
                → ren idₑ M ≡ M
idren (𝓋 i)   = 𝓋 & idgetₑ i
idren (ƛ M)   = ƛ & idren M
idren (M ∙ N) = _∙_ & idren M
                    ⊗ idren N

-- (Tm-∘ₑ)
ren○ : ∀ {Γ Γ′ Γ″ A} → (η₁ : Γ″ ⊇ Γ′) (η₂ : Γ′ ⊇ Γ) (M : Γ ⊢ A)
                     → ren (η₂ ○ η₁) M ≡ (ren η₁ ∘ ren η₂) M
ren○ η₁ η₂ (𝓋 i)   = 𝓋 & get○ η₁ η₂ i
ren○ η₁ η₂ (ƛ M)   = ƛ & ren○ (liftₑ η₁) (liftₑ η₂) M
ren○ η₁ η₂ (M ∙ N) = _∙_ & ren○ η₁ η₂ M
                         ⊗ ren○ η₁ η₂ N

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

𝗢𝗣𝗘 : Category 𝒞 _⊇_
𝗢𝗣𝗘 =
  record
    { idₓ    = idₑ
    ; _⋄_    = _○_
    ; lid⋄   = lid○
    ; rid⋄   = rid○
    ; assoc⋄ = assoc○
    }

getₑPsh : 𝒯 → Presheaf₀ 𝗢𝗣𝗘
getₑPsh A =
  record
    { Fₓ  = _∋ A
    ; F   = getₑ
    ; idF = fext! idgetₑ
    ; F⋄  = λ η₁ η₂ → fext! (get○ η₂ η₁)
    }

renPsh : 𝒯 → Presheaf₀ 𝗢𝗣𝗘
renPsh A =
  record
    { Fₓ  = _⊢ A
    ; F   = ren
    ; idF = fext! idren
    ; F⋄  = λ η₁ η₂ → fext! (ren○ η₂ η₁)
    }

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


open import Categories
open import Functors
open import RMonads

module RMonads.CatofRAdj.TermRAdj {a b c d}{C : Cat {a}{b}}{D : Cat {c}{d}}
                                     {J : Fun C D}(M : RMonad J) where

open import Library
open import RAdjunctions
open import RMonads.CatofRAdj M
open import Categories.Terminal
open import RMonads.REM M
open import RMonads.REM.Adjunction M
open import RAdjunctions.RAdj2RMon
open import RMonads.CatofRAdj.TermRAdjObj M
open import RMonads.CatofRAdj.TermRAdjHom M

open Cat
open Fun
open RAdj

omaplem : {X : Obj CatofAdj} {f : Hom CatofAdj X EMObj} →
          OMap (HomAdj.K (EMHom {X})) ≅ OMap (HomAdj.K f)
omaplem {A}{f} = ext (λ X → AlgEq
  (fcong X (cong OMap (HomAdj.Rlaw f)))
  (iext λ Y →
       dext
       (λ {g} {g'} p →
          trans
          (trans
           (stripsubst (λ Z → Hom D Z (OMap (R (ObjAdj.adj A)) X))
            (HMap (R (ObjAdj.adj A)) (right (ObjAdj.adj A) g))
            (fcong Y (cong OMap (ObjAdj.law A))))
           (cong' refl (ext (λ g₁ →
             cong
               (λ (F : Obj (ObjAdj.E A) → Obj D) →
                  Hom D (F (OMap (L (ObjAdj.adj A)) Y)) (F X))
               (cong OMap (HomAdj.Rlaw f))))
            (icong' refl (ext (λ Z →
              cong
                (λ (F : Obj (ObjAdj.E A) → Obj D) →
                   Hom (ObjAdj.E A) (OMap (L (ObjAdj.adj A)) Y) Z →
                   Hom D (F (OMap (L (ObjAdj.adj A)) Y)) (F Z))
                (cong OMap (HomAdj.Rlaw f))))
             (icong'
               refl
               (ext (λ Z → cong
                             (λ (F : Obj (ObjAdj.E A) → Obj D) →
                                {Y₁ : Obj (ObjAdj.E A)} →
                                Hom (ObjAdj.E A) Z Y₁ → Hom D (F Z) (F Y₁))
                             (cong OMap (HomAdj.Rlaw f))))
              (cong HMap (HomAdj.Rlaw f))
              (refl {x = OMap (L (ObjAdj.adj A)) Y}))
             (refl {x = X}))
            (refl {x = right (ObjAdj.adj A) g})))
          (trans
           (cong₃ (λ A1 A2 → RAlgMorph.amor {A1}{A2})
            (fcong Y (cong OMap (HomAdj.Llaw f))) refl
            (HomAdj.rightlaw f {Y} {X} {g}))
           (cong (RAlg.astr (OMap (HomAdj.K f) X))
            (trans
             (stripsubst (Hom D (OMap J Y)) g
              (fcong X (cong OMap (HomAdj.Rlaw f))))
             p))))))

hmaplem : {X : Obj CatofAdj} {f : Hom CatofAdj X EMObj} →
          {X₁ Y : Obj (ObjAdj.E X)} (f₁ : Hom (ObjAdj.E X) X₁ Y) →
            HMap (HomAdj.K (EMHom {X})) f₁ ≅ HMap (HomAdj.K f) f₁
hmaplem {A}{V}{X}{Y} f = lemZ
  (fcong X (omaplem {A} {V}))
  (fcong Y (omaplem {A} {V}))
  (cong'
    refl
    (ext (λ Z → cong
       (λ (F : Obj (ObjAdj.E A) → Obj D) → Hom D (F X) (F Y))
       (cong OMap (HomAdj.Rlaw V))))
    (icong'
      refl
      (ext (λ Z → cong
        (λ (F : Obj (ObjAdj.E A) → Obj D) →
           Hom (ObjAdj.E A) X Z → Hom D (F X) (F Z))
        (cong OMap (HomAdj.Rlaw V))))
      (icong'
        refl
        (ext (λ Z → cong
                      (λ (F : Obj (ObjAdj.E A) → Obj D) →
                         {Y₁ : Obj (ObjAdj.E A)} →
                         Hom (ObjAdj.E A) Z Y₁ → Hom D (F Z) (F Y₁))
                      (cong OMap (HomAdj.Rlaw V))))
        (cong HMap (HomAdj.Rlaw V))
        (refl {x = X}))
      (refl {x = Y}))
     (refl {x = f}))

uniq : {X : Obj CatofAdj} {f : Hom CatofAdj X EMObj} →
       EMHom {X} ≅ f
uniq {X} {f} = HomAdjEq _ _ (FunctorEq _ _
  (omaplem {X} {f})
  (iext λ _ → iext λ _ → ext (hmaplem {X}{f})))

EMIsTerm : Term CatofAdj EMObj
EMIsTerm = record {
  t   = EMHom;
  law = uniq}


{-# OPTIONS --safe --warning=error #-}

open import Sets.EquivalenceRelations
open import Functions.Definition
open import Agda.Primitive using (Level; lzero; lsuc; _⊔_; Setω)
open import Setoids.Setoids
open import Groups.Definition
open import LogicalFormulae
open import Orders.WellFounded.Definition
open import Numbers.Naturals.Semiring
open import Groups.Lemmas
open import Groups.Homomorphisms.Definition
open import Groups.Homomorphisms.Lemmas

module Groups.FreeProduct.UniversalProperty {i : _} {I : Set i} (decidableIndex : (x y : I) → ((x ≡ y) || ((x ≡ y) → False))) {a b : _} {A : I → Set a} {S : (i : I) → Setoid {a} {b} (A i)} {_+_ : (i : I) → (A i) → (A i) → A i} (decidableGroups : (i : I) → (x y : A i) → ((Setoid._∼_ (S i) x y)) || ((Setoid._∼_ (S i) x y) → False)) (G : (i : I) → Group (S i) (_+_ i)) where

open import Groups.FreeProduct.Definition decidableIndex decidableGroups G
open import Groups.FreeProduct.Setoid decidableIndex decidableGroups G
open import Groups.FreeProduct.Addition decidableIndex decidableGroups G
open import Groups.FreeProduct.Group decidableIndex decidableGroups G

private
  universalPropertyFunction' : {c d : _} {C : Set c} {T : Setoid {c} {d} C} {_+_ : C → C → C} (H : Group T _+_) → (fs : (i : I) → (A i → C)) → (homs : (i : I) → GroupHom (G i) H (fs i)) → {i : I} → ReducedSequenceBeginningWith i → C
  universalPropertyFunction' {_+_ = _+_} H fs homs {i} (ofEmpty .i g nonZero) = fs i g
  universalPropertyFunction' {_+_ = _+_} H fs homs {i} (prependLetter .i g nonZero x x₁) = (fs i g) + universalPropertyFunction' H fs homs x

universalPropertyFunction : {c d : _} {C : Set c} {T : Setoid {c} {d} C} {_+_ : C → C → C} (H : Group T _+_) → (fs : (i : I) → (A i → C)) → (homs : (i : I) → GroupHom (G i) H (fs i)) → ReducedSequence → C
universalPropertyFunction H fs homs empty = Group.0G H
universalPropertyFunction H fs homs (nonempty i x) = universalPropertyFunction' H fs homs x

private
  upWellDefined' : {c d : _} {C : Set c} {T : Setoid {c} {d} C} {_+_ : C → C → C} (H : Group T _+_) → (fs : (i : I) → (A i → C)) → (homs : (i : I) → GroupHom (G i) H (fs i)) → {m n : I} → (x : ReducedSequenceBeginningWith m) (y : ReducedSequenceBeginningWith n) → (eq : =RP' x y) → Setoid._∼_ T (universalPropertyFunction H fs homs (nonempty m x)) (universalPropertyFunction H fs homs (nonempty n y))
  upWellDefined' H fs homs (ofEmpty m g nonZero) (ofEmpty n g₁ nonZero₁) eq with decidableIndex m n
  ... | inl refl = GroupHom.wellDefined (homs m) eq
  upWellDefined' H fs homs (prependLetter m g nonZero x x₁) (prependLetter n g₁ nonZero₁ y x₂) eq with decidableIndex m n
  ... | inl refl = Group.+WellDefined H (GroupHom.wellDefined (homs m) (_&&_.fst eq)) (upWellDefined' H fs homs x y (_&&_.snd eq))

  upWellDefined : {c d : _} {C : Set c} {T : Setoid {c} {d} C} {_+_ : C → C → C} (H : Group T _+_) → (fs : (i : I) → (A i → C)) → (homs : (i : I) → GroupHom (G i) H (fs i)) → (x : ReducedSequence) (y : ReducedSequence) → (eq : _=RP_ x y) → Setoid._∼_ T (universalPropertyFunction H fs homs x) (universalPropertyFunction H fs homs y)
  upWellDefined {T = T} H fs homs empty empty eq = Equivalence.reflexive (Setoid.eq T)
  upWellDefined H fs homs (nonempty i w1) (nonempty j w2) eq = upWellDefined' H fs homs w1 w2 eq

private
  upPrepend : {c d : _} {C : Set c} {T : Setoid {c} {d} C} {_+_ : C → C → C} (H : Group T _+_) → (fs : (i : I) → (A i → C)) → (homs : (i : I) → GroupHom (G i) H (fs i)) → {j : I} (y : ReducedSequence) → (g : A j) .(pr : _) → Setoid._∼_ T (universalPropertyFunction H fs homs (prepend j g pr y)) ((fs j g) + universalPropertyFunction H fs homs y)
  upPrepend {T = T} H fs homs empty g pr = Equivalence.symmetric (Setoid.eq T) (Group.identRight H)
  upPrepend {T = T} H fs homs {j} (nonempty i (ofEmpty .i h nonZero)) g pr with decidableIndex j i
  ... | inr j!=i = Equivalence.reflexive (Setoid.eq T)
  ... | inl refl with decidableGroups j ((j + g) h) (Group.0G (G j))
  ... | inl x = Equivalence.transitive (Setoid.eq T) (Equivalence.symmetric (Setoid.eq T) (imageOfIdentityIsIdentity (homs j))) (Equivalence.transitive (Setoid.eq T) (Equivalence.symmetric (Setoid.eq T) (GroupHom.wellDefined (homs j) x)) (GroupHom.groupHom (homs j)))
  ... | inr x = GroupHom.groupHom (homs j)
  upPrepend {T = T} H fs homs {j} (nonempty k (prependLetter .k h nonZero y _)) g pr with decidableIndex j k
  ... | inr j!=k = Equivalence.reflexive (Setoid.eq T)
  ... | inl refl with decidableGroups j ((j + g) h) (Group.0G (G j))
  ... | inl x = transitive (symmetric (Group.identLeft H)) (transitive (Group.+WellDefined H (transitive (symmetric (imageOfIdentityIsIdentity (homs k))) (transitive (GroupHom.wellDefined (homs k) (Equivalence.symmetric (Setoid.eq (S k)) x)) (GroupHom.groupHom (homs k)))) reflexive) (symmetric (Group.+Associative H)))
    where
      open Setoid T
      open Equivalence eq
  ... | inr x = transitive (Group.+WellDefined H (GroupHom.groupHom (homs k)) reflexive) (symmetric (Group.+Associative H))
    where
      open Setoid T
      open Equivalence eq

private
  upHom : {c d : _} {C : Set c} {T : Setoid {c} {d} C} {_+_ : C → C → C} (H : Group T _+_) → (fs : (i : I) → (A i → C)) → (homs : (i : I) → GroupHom (G i) H (fs i)) → {i : I} (x : ReducedSequenceBeginningWith i) (y : ReducedSequence) → Setoid._∼_ T (universalPropertyFunction H fs homs (plus' x y)) (universalPropertyFunction' H fs homs x + universalPropertyFunction H fs homs y)
  upHom {T = T} H fs homs (ofEmpty _ g nonZero) empty = Equivalence.symmetric (Setoid.eq T) (Group.identRight H)
  upHom {T = T} H fs homs (ofEmpty j g nonZero) (nonempty i (ofEmpty .i h nonZero1)) with decidableIndex j i
  ... | inr j!=i = Equivalence.reflexive (Setoid.eq T)
  ... | inl refl with decidableGroups j ((j + g) h) (Group.0G (G j))
  ... | inl x = Equivalence.transitive (Setoid.eq T) (Equivalence.symmetric (Setoid.eq T) (imageOfIdentityIsIdentity (homs j))) (Equivalence.transitive (Setoid.eq T) (Equivalence.symmetric (Setoid.eq T) (GroupHom.wellDefined (homs j) x)) (GroupHom.groupHom (homs j)))
  ... | inr x = GroupHom.groupHom (homs j)
  upHom {T = T} H fs homs (ofEmpty j g nonZero) (nonempty i (prependLetter .i h nonZero1 x x₁)) with decidableIndex j i
  ... | inr j!=i = Equivalence.reflexive (Setoid.eq T)
  ... | inl refl with decidableGroups j ((j + g) h) (Group.0G (G j))
  ... | inr _ = Equivalence.transitive (Setoid.eq T) (Group.+WellDefined H (GroupHom.groupHom (homs j)) (Equivalence.reflexive (Setoid.eq T))) (Equivalence.symmetric (Setoid.eq T) (Group.+Associative H))
  ... | inl eq1 = Equivalence.transitive (Setoid.eq T) (Equivalence.symmetric (Setoid.eq T) (Group.identLeft H)) (Equivalence.transitive (Setoid.eq T) (Group.+WellDefined H (Equivalence.transitive (Setoid.eq T) (Equivalence.symmetric (Setoid.eq T) (imageOfIdentityIsIdentity (homs j))) (Equivalence.transitive (Setoid.eq T) (GroupHom.wellDefined (homs j) (Equivalence.symmetric (Setoid.eq (S j)) eq1)) (GroupHom.groupHom (homs j)))) (Equivalence.reflexive (Setoid.eq T))) (Equivalence.symmetric (Setoid.eq T) (Group.+Associative H)))
  upHom {T = T} H fs homs (prependLetter j g nonZero {k} w k!=j) empty = Equivalence.transitive (Setoid.eq T) (Equivalence.transitive (Setoid.eq T) (upWellDefined H fs homs (plus' (prependLetter j g _ w k!=j) empty) (prepend j g _ (nonempty k w)) (prependWD' g nonZero (plus' w empty) (nonempty k w) (plusEmptyRight w))) (upPrepend H fs homs (nonempty k w) g nonZero)) (Equivalence.symmetric (Setoid.eq T) (Group.identRight H))
  upHom {T = T} H fs homs (prependLetter j g nonZero {k} m k!=j) (nonempty i x2) = transitive (upPrepend H fs homs (plus' m (nonempty i x2)) g nonZero) (transitive (Group.+WellDefined H reflexive (upHom H fs homs m (nonempty i x2))) (Group.+Associative H))
    where
      open Setoid T
      open Equivalence eq

universalPropertyHom : {c d : _} {C : Set c} {T : Setoid {c} {d} C} {_+_ : C → C → C} (H : Group T _+_) → (fs : (i : I) → (A i → C)) → (homs : (i : I) → GroupHom (G i) H (fs i)) → GroupHom FreeProductGroup H (universalPropertyFunction H fs homs)
GroupHom.wellDefined (universalPropertyHom {T = T} H fs homs) {x} {y} eq = upWellDefined H fs homs x y eq
GroupHom.groupHom (universalPropertyHom {T = T} H fs homs) {empty} {y} = Equivalence.symmetric (Setoid.eq T) (Group.identLeft H)
GroupHom.groupHom (universalPropertyHom {T = T} H fs homs) {nonempty i x} {empty} = transitive (upWellDefined H fs homs (nonempty i x +RP empty) (nonempty i x) (plusEmptyRight x)) (symmetric (Group.identRight H))
  where
    open Setoid T
    open Equivalence eq
GroupHom.groupHom (universalPropertyHom H fs homs) {nonempty i x} {nonempty j y} = upHom H fs homs x (nonempty j y)

universalPropertyFunctionHasProperty : {c d : _} {C : Set c} {T : Setoid {c} {d} C} {_+_ : C → C → C} (H : Group T _+_) → (fs : (i : I) → (A i → C)) → (homs : (i : I) → GroupHom (G i) H (fs i)) → {i : I} → (g : A i) → (nz : (Setoid._∼_ (S i) g (Group.0G (G i))) → False) → Setoid._∼_ T (fs i g) (universalPropertyFunction H fs homs (injection g nz))
universalPropertyFunctionHasProperty {T = T} H fs homs g nz = Equivalence.reflexive (Setoid.eq T)

private
  universalPropertyFunctionUniquelyHasPropertyLemma : {c d : _} {C : Set c} {T : Setoid {c} {d} C} {_+_ : C → C → C} (H : Group T _+_) → (fs : (i : I) → (A i → C)) → (homs : (i : I) → GroupHom (G i) H (fs i)) → (otherFunction : ReducedSequence → C) → (isHom : GroupHom FreeProductGroup H otherFunction) → ({i : I} → (g : A i) → .(nz : (Setoid._∼_ (S i) g (Group.0G (G i))) → False) → Setoid._∼_ T (fs i g) (otherFunction (injection g nz))) → {k l : I} (neq : (k ≡ l) → False) (r : ReducedSequenceBeginningWith l) (g : A k) .(nz : (Setoid._∼_ (S k) g (Group.0G (G k)) → False)) → Setoid._∼_ T (otherFunction (nonempty k (prependLetter k g nz r neq))) (fs k g + universalPropertyFunction' H fs homs r)
  universalPropertyFunctionUniquelyHasPropertyLemma {T = T} H fs homs otherFunction hom x {k} {l} neq (ofEmpty .l g2 nonZero) g nz = transitive (GroupHom.wellDefined hom {nonempty k (prependLetter k g nz (ofEmpty l g2 nonZero) neq)} {nonempty _ (ofEmpty k g nz) +RP nonempty _ (ofEmpty l g2 nonZero)} t) (transitive (GroupHom.groupHom hom {nonempty k (ofEmpty k g nz)} {nonempty _ (ofEmpty l g2 nonZero)}) (Group.+WellDefined H (symmetric (x g nz)) (symmetric (x g2 nonZero))))
    where
      open Setoid T
      open Equivalence eq
      t : Setoid._∼_ freeProductSetoid (nonempty k (prependLetter k g nz (ofEmpty l g2 nonZero) neq)) (prepend k g nz (nonempty l (ofEmpty l g2 nonZero)))
      t with decidableIndex k l
      ... | inl p = exFalso (neq p)
      ... | inr _ with decidableIndex k k
      ... | inr bad = exFalso (bad refl)
      ... | inl refl = Equivalence.reflexive (Setoid.eq (S k)) ,, =RP'reflex (ofEmpty l g2 _)
  universalPropertyFunctionUniquelyHasPropertyLemma {T = T} H fs homs otherFunction hom x {k} {l} neq (prependLetter .l h nonZero r pr) g nz = transitive (GroupHom.wellDefined hom {nonempty _ (prependLetter k g nz (prependLetter l h nonZero r pr) neq)} {(nonempty k (ofEmpty k g nz)) +RP (nonempty l (prependLetter l h nonZero r pr))} t) (transitive (GroupHom.groupHom hom {nonempty k (ofEmpty k g nz)} {nonempty l (prependLetter l h nonZero r pr)}) (Group.+WellDefined H (symmetric (x g nz)) (universalPropertyFunctionUniquelyHasPropertyLemma H fs homs otherFunction hom x pr r h nonZero)))
    where
      open Setoid T
      open Equivalence eq
      t : Setoid._∼_ freeProductSetoid (nonempty k (prependLetter k g nz (prependLetter l h nonZero r pr) neq)) (prepend k g nz (nonempty l (prependLetter l h nonZero r pr)))
      t with decidableIndex k l
      ... | inl bad = exFalso (neq bad)
      ... | inr k!=l with decidableIndex k k
      ... | inr bad = exFalso (bad refl)
      ... | inl refl with decidableIndex l l
      ... | inr bad = exFalso (bad refl)
      ... | inl refl = Equivalence.reflexive (Setoid.eq (S k)) ,, ((Equivalence.reflexive (Setoid.eq (S l))) ,, =RP'reflex r)

universalPropertyFunctionUniquelyHasProperty : {c d : _} {C : Set c} {T : Setoid {c} {d} C} {_+_ : C → C → C} (H : Group T _+_) → (fs : (i : I) → (A i → C)) → (homs : (i : I) → GroupHom (G i) H (fs i)) → (otherFunction : ReducedSequence → C) → (isHom : GroupHom FreeProductGroup H otherFunction) → ({i : I} → (g : A i) → .(nz : (Setoid._∼_ (S i) g (Group.0G (G i))) → False) → Setoid._∼_ T (fs i g) (otherFunction (injection g nz))) → (r : ReducedSequence) → Setoid._∼_ T (otherFunction r) (universalPropertyFunction H fs homs r)
universalPropertyFunctionUniquelyHasProperty H fs homs otherFunction hom prop empty = imageOfIdentityIsIdentity hom
universalPropertyFunctionUniquelyHasProperty {T = T} H fs homs otherFunction hom prop (nonempty i (ofEmpty .i g nonZero)) = Equivalence.symmetric (Setoid.eq T) (prop g nonZero)
universalPropertyFunctionUniquelyHasProperty {T = T} H fs homs otherFunction hom prop (nonempty i (prependLetter .i g nonZero {k} (ofEmpty .k g1 nonZero1) x1)) = transitive (GroupHom.wellDefined hom {_} {(nonempty i (ofEmpty i g nonZero)) +RP (nonempty k (ofEmpty k g1 nonZero1))} t) (transitive (GroupHom.groupHom hom {nonempty i (ofEmpty i g nonZero)}) (Group.+WellDefined H (symmetric (prop g nonZero)) (symmetric (prop g1 nonZero1))))
  where
    open Setoid T
    open Equivalence eq
    t : Setoid._∼_ freeProductSetoid (nonempty i (prependLetter i g nonZero (ofEmpty k g1 nonZero1) x1)) (prepend i g nonZero (nonempty k (ofEmpty k g1 nonZero1)))
    t with decidableIndex i k
    ... | inl p = exFalso (x1 p)
    ... | inr _ with decidableIndex i i
    ... | inr bad = exFalso (bad refl)
    ... | inl refl = Equivalence.reflexive (Setoid.eq (S i)) ,, =RP'reflex (ofEmpty k g1 nonZero1)
universalPropertyFunctionUniquelyHasProperty {T = T} H fs homs otherFunction hom prop (nonempty i (prependLetter .i g nonZero {k} (prependLetter .k g2 nonZero2 x x2) x1)) = transitive (GroupHom.wellDefined hom {nonempty i (prependLetter i g nonZero (prependLetter k g2 nonZero2 x x2) x1)} {(nonempty i (ofEmpty i g nonZero)) +RP (nonempty k (prependLetter k g2 nonZero2 x x2))} t) (transitive (GroupHom.groupHom hom {nonempty i (ofEmpty i g nonZero)} {nonempty k (prependLetter k g2 nonZero2 x x2)}) (Group.+WellDefined H (symmetric (prop g nonZero)) (universalPropertyFunctionUniquelyHasPropertyLemma H fs homs otherFunction hom prop x2 x g2 nonZero2)))
  where
    open Setoid T
    open Equivalence eq
    t : Setoid._∼_ freeProductSetoid (nonempty i (prependLetter i g nonZero (prependLetter k g2 nonZero2 x x2) x1)) (prepend i g nonZero (nonempty k (prependLetter k g2 nonZero2 x x2)))
    t with decidableIndex i k
    ... | inl x = exFalso (x1 x)
    ... | inr _ = =RP'reflex (prependLetter i g nonZero (prependLetter k g2 nonZero2 x x2) x1)


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

module Path.Reasoning where

open import Prelude

infixr 2 ≡˘⟨⟩-syntax _≡⟨⟩_ ≡⟨∙⟩-syntax

≡˘⟨⟩-syntax : ∀ (x : A) {y z} → y ≡ z → y ≡ x → x ≡ z
≡˘⟨⟩-syntax _ y≡z y≡x = sym y≡x ; y≡z

syntax ≡˘⟨⟩-syntax x y≡z y≡x = x ≡˘⟨ y≡x ⟩ y≡z

≡⟨∙⟩-syntax : ∀ (x : A) {y z} → y ≡ z → x ≡ y → x ≡ z
≡⟨∙⟩-syntax _ y≡z x≡y = x≡y ; y≡z

syntax ≡⟨∙⟩-syntax x y≡z x≡y = x ≡⟨ x≡y ⟩ y≡z

_≡⟨⟩_ : ∀ (x : A) {y} → x ≡ y → x ≡ y
_ ≡⟨⟩ x≡y = x≡y

infix 2.5 _∎
_∎ : ∀ {A : Type a} (x : A) → x ≡ x
_∎ x = refl


{- Other common operations and lemmas. -}
module TemporalOps.Common.Other where

open import Relation.Binary.HeterogeneousEquality as ≅ hiding (inspect)
open import Relation.Binary.PropositionalEquality hiding (inspect)

-- Time indexing (for clarity, synonym of function appliation at any level)
_at_ : ∀ {a b} {A : Set a} {B : A → Set b} →
      ((x : A) → B x) → ((x : A) → B x)
f at n = f n
infixl 45 _at_

-- Inspect idiom
data Singleton {a} {A : Set a} (x : A) : Set a where
  _with≡_ : (y : A) → x ≡ y → Singleton x

inspect : ∀ {a} {A : Set a} (x : A) → Singleton x
inspect x = x with≡ refl


module Data.String.Instance where

open import Agda.Builtin.String
open import Class.Equality
open import Class.Monoid
open import Class.Show
open import Data.String renaming (_≟_ to _≟S_)

instance
  String-Eq : Eq String
  String-Eq = record { _≟_ = _≟S_ }

  String-EqB : EqB String
  String-EqB = record { _≣_ = primStringEquality }

  String-Monoid : Monoid String
  String-Monoid = record { mzero = "" ; _+_ = _++_ }

  String-Show : Show String
  String-Show = record { show = λ x -> x }


{-# OPTIONS --cubical --no-import-sorts --safe #-}
module Cubical.Data.Bool.SwitchStatement where

open import Cubical.Core.Everything

open import Cubical.Foundations.Prelude

open import Cubical.Data.Bool.Base
open import Cubical.Data.Nat

{-
  Switch-case:

    _==_ : A → A → Bool

    _ : B
    _ = switch (λ x → x == fixedValue) cases
           case value1 ⇒ result1 break
           case value2 ⇒ result2 break
           ...
           case valueN ⇒ resultN break
           default⇒ defaultResult
-}

private
  variable
    ℓ ℓ′ : Level

infixr 6 default⇒_
infixr 5 case_⇒_break_
infixr 4 switch_cases_

switch_cases_ : {A : Type ℓ} {B : Type ℓ′} → (A → Bool) → ((A → Bool) → B) → B
switch caseIndicator cases caseData = caseData caseIndicator

case_⇒_break_ : {A : Type ℓ} {B : Type ℓ′} → A → B → (otherCases : (A → Bool) → B) → (A → Bool) → B
case forValue ⇒ result break otherCases = λ caseIndicator → if (caseIndicator forValue) then result else (otherCases caseIndicator)

default⇒_ : {A : Type ℓ} {B : Type ℓ′} → B → (A → Bool) → B
default⇒_ value caseIndicator = value


module Issue347 where
import Common.Irrelevance

{- Dan Doel, 2010-10-09

This is a boiling down of a problem encountered by Eric Mertens. It
seems the unifier will make up values for records without bothering
with irrelevant fields: -}

data ⊥ : Set where

⊥-elim : {A : Set} → ⊥ → A
⊥-elim ()

⊥-elimⁱ : {A : Set} → .⊥ → A
⊥-elimⁱ ()

module Bad where
  record ○ (A : Set) : Set where
    constructor poof
    field
      .inflate : A

  open ○

  -- This, for some reason, doesn't. Apparently it thinks it can
  -- make up records without bothering to infer the irrelevant fields.
  evil : ∀ A → A
  evil A = ⊥-elimⁱ (inflate _)

  -- the meta var  ?a : Squash A  eta-expands to
  -- ?a = poof Bot ?b
  -- meta var ?b should be left over


------------------------------------------------------------------------
-- Searchable set
------------------------------------------------------------------------

-- http://citeseerx.ist.psu.edu/viewdoc/download?doi=10.1.1.127.3062&rep=rep1&type=pdf
-- http://www.cs.bham.ac.uk/~mhe/papers/omniscient-2011-07-06.pdf

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

module Constructive.Searchable where

-- agda-stdlib
open import Data.Bool
open import Data.Empty
open import Data.Product as Prod
open import Data.Sum as Sum
open import Function.Base
open import Relation.Binary.PropositionalEquality
import Function.Equivalence as Eqv -- TOOD use new function bundle

-- agda-misc
open import Constructive.Axiom
open import Constructive.Axiom.Properties.Base
open import Constructive.Axiom.Properties.Bool
open import Constructive.Common
open import Constructive.Combinators

module SearchModule {a} {A : Set a} (searchable : Searchable-Bool A) where
  ε : ((A → Bool) → A)
  ε = proj₁ searchable
  ε-correct : (P : A → Bool) → P (ε P) ≡ true → (x : A) → P x ≡ true
  ε-correct = proj₂ searchable

-- Lemma 2.1
searchable-Bool⇒lpo-Bool-Alt : ∀ {a} {A : Set a} → Searchable-Bool A → LPO-Bool-Alt A
searchable-Bool⇒lpo-Bool-Alt (ε , ε-correct) P with P (ε P) | inspect P (ε P)
... | false | [ P[εP]≡false ] = inj₁ (ε P , P[εP]≡false)
... | true  | [ P[εP]≡true  ] = inj₂ (ε-correct P P[εP]≡true)

searchable-Bool⇒inhabited : ∀ {a} {A : Set a} → Searchable-Bool A → Inhabited A
searchable-Bool⇒inhabited searchable-Bool = (proj₁ searchable-Bool) λ _ → true

-- Inhabited ∧ LPO-Bool-Alt => Searchable-Bool
inhabited∧lpo-Bool-Alt⇒ε : ∀ {a} {A : Set a} → Inhabited A → LPO-Bool-Alt A → (A → Bool) → A
inhabited∧lpo-Bool-Alt⇒ε inhabited lpo-Bool-Alt P with lpo-Bool-Alt P
... | inj₁ (x , _) = x
... | inj₂ _       = inhabited

inhabited∧lpo-Bool-Alt⇒ε-correct :
  ∀ {a} {A : Set a} (i : Inhabited A) (lpo-Bool-Alt : LPO-Bool-Alt A) (P : A → Bool) →
 P ((inhabited∧lpo-Bool-Alt⇒ε i lpo-Bool-Alt) P) ≡ true → (x : A) → P x ≡ true
inhabited∧lpo-Bool-Alt⇒ε-correct inhabited lpo-Bool-Alt P with lpo-Bool-Alt P
... | inj₁ (x , Px≡false) =
  λ Px≡true → ⊥-elim $ false≢true $ trans (sym Px≡false) Px≡true
  where
  false≢true : false ≢ true
  false≢true ()
... | inj₂ ∀x→Px≡true     = λ _ → ∀x→Px≡true

inhabited∧lpo-Bool-Alt⇒searchable-Bool :
  ∀ {a} {A : Set a} → Inhabited A → LPO-Bool-Alt A → Searchable-Bool A
inhabited∧lpo-Bool-Alt⇒searchable-Bool inhabited lpo-Bool-Alt =
  inhabited∧lpo-Bool-Alt⇒ε inhabited lpo-Bool-Alt ,
  inhabited∧lpo-Bool-Alt⇒ε-correct inhabited lpo-Bool-Alt

-- Searchable-Bool <=> Searchable
searchable-Bool⇒searchable : ∀ {a p} {A : Set a} →
                             Searchable-Bool A → Searchable A p
searchable-Bool⇒searchable {a} {p} {A} searchable-Bool =
  inhabited∧lpo⇒searchable inhabited lpo
  where
  inhabited = searchable-Bool⇒inhabited searchable-Bool
  lpo : LPO A p
  lpo = lpo-Bool⇒lpo p $ lpo-Bool-Alt⇒lpo-Bool $
          searchable-Bool⇒lpo-Bool-Alt searchable-Bool

searchable⇒searchable-Bool : ∀ {a p} {A : Set a} →
                             Searchable A p → Searchable-Bool A
searchable⇒searchable-Bool searchable =
  inhabited∧lpo-Bool-Alt⇒searchable-Bool inhabited lpo-Bool-Alt
  where
  inhabited = searchable⇒inhabited searchable
  lpo-Bool-Alt = lpo-Bool⇒lpo-Bool-Alt $ lpo⇒lpo-Bool $ searchable⇒lpo searchable

-- Lemma 2.2
module Lemma2-2 {a} {A : Set a} (searchable-Bool : Searchable-Bool A) where
  open SearchModule searchable-Bool
  module _ {P : A → Bool} where
    ∃x→Px≡false→P[εP]≡false : (∃ λ x → P x ≡ false) → P (ε P) ≡ false
    ∃x→Px≡false→P[εP]≡false e =
      x≢true⇒x≡false $ contraposition (ε-correct P)
                                      (∃¬P→¬∀P (Prod.map₂ x≡false⇒x≢true e))
        where
        x≡false⇒x≢true : ∀ {x} → x ≡ false → x ≢ true
        x≡false⇒x≢true {false} refl ()
        x≢true⇒x≡false : ∀ {x} → x ≢ true → x ≡ false
        x≢true⇒x≡false {false} neq = refl
        x≢true⇒x≡false {true } neq = ⊥-elim $ neq refl

    ∃x→Px≡false⇔P[εP]≡false : (∃ λ x → P x ≡ false) Eqv.⇔ P (ε P) ≡ false
    ∃x→Px≡false⇔P[εP]≡false =
      Eqv.equivalence ∃x→Px≡false→P[εP]≡false λ eq → ε P , eq

  -- E_X
  Exist : (A → Bool) → Bool
  Exist P = P (ε P)

  Exist[P]≡false⇔∃x→Px≡false :
    {P : A → Bool} → Exist P ≡ false Eqv.⇔ (∃ λ x → P x ≡ false)
  Exist[P]≡false⇔∃x→Px≡false = Eqv.sym ∃x→Px≡false⇔P[εP]≡false

open Lemma2-2

Exhaustible : ∀ {a} → Set a → Set a
Exhaustible A = Σ ((A → Bool) → Bool) λ ∀K →
  (P : A → Bool) → ∀K P ≡ true → ∀ x → P x ≡ true


-- Checks that UHC FFI calls using non-magic datatypes work
module UHC-FFI where

data Nat : Set where
  Zero : Nat
  Suc : Nat -> Nat
{-# COMPILE UHC Nat = data UHC.Agda.Builtins.Nat (Zero | Suc) #-}

{-# FOREIGN UHC __IMPORT__ Data.Char #-}

open import Common.IO
open import Common.Unit
open import Common.String
open import Common.Char

postulate toLower : Char -> Char
{-# COMPILE UHC toLower = Data.Char.toLower #-}

main : IO Unit
main = putStr (charToStr (toLower 'A'))


{-# OPTIONS --cubical --no-import-sorts --safe #-}
module Cubical.DStructures.Equivalences.GroupSplitEpiAction where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Isomorphism
open import Cubical.Foundations.Function
open import Cubical.Foundations.Structure

open import Cubical.Data.Sigma
open import Cubical.Data.Unit

open import Cubical.Relation.Binary

open import Cubical.Structures.Subtype
open import Cubical.Algebra.Group
open import Cubical.Structures.LeftAction
open import Cubical.Algebra.Group.Semidirect

open import Cubical.DStructures.Base
open import Cubical.DStructures.Meta.Isomorphism
open import Cubical.DStructures.Structures.Group
open import Cubical.DStructures.Structures.SplitEpi
open import Cubical.DStructures.Structures.Action

open Kernel
open GroupHom -- such .fun!
open GroupLemmas
open MorphismLemmas

{-
After associating, we have two DURGs over Grp

 Grp × LAS × isAction   Grp × (F × B) × isSecRet
                 |     |
                  \    /
                   Grp

Action gives split mono:

    α             π₂
G₀ --> H   ↦  G₀ ↔ H ⋊⟨ α ⟩ G₀
                  ι₂

Split mono gives Action:

   σ            Ad∘ι
G₀ ↔ G₁   ↦ G₀ --> ker σ
   ι

-}

module _ (ℓ ℓ' : Level) where

  𝒮ᴰ-Iso-GroupAct-SplitEpi-* : 𝒮ᴰ-♭PIso (idfun (Group {ℓ}))
                                         (𝒮ᴰ-G\GLasAction ℓ (ℓ-max ℓ ℓ'))
                                         (𝒮ᴰ-G\GFBSplitEpi ℓ (ℓ-max ℓ ℓ'))
  RelIso.fun (𝒮ᴰ-Iso-GroupAct-SplitEpi-* G₀) (H , _α_ , isAct) = H⋊G₀ , (ι₂ α , π₂ α) , π₂-hasSec α
      where
        -- combine the action structure and axioms
        α = groupaction _α_ isAct
        -- semidirect product induced by the action α
        H⋊G₀ : Group {ℓ-max ℓ ℓ'}
        H⋊G₀ = H ⋊⟨ α ⟩ G₀
  RelIso.inv (𝒮ᴰ-Iso-GroupAct-SplitEpi-* G₀) (G₁ , (ι , σ) , isSplit) = ker-σ , _α_ , isAct
      where
        open GroupNotation₀ G₀
        open GroupNotation₁ G₁
        open SplitEpiNotation ι σ isSplit
        open IsGroupAction

        -- G₀ will act on ker σ
        ker-σ : Group {ℓ-max ℓ ℓ'}
        ker-σ = ker σ

        -- notation: group operation of ker σ
        _+ₖ_ = GroupStr._+_ (snd ker-σ)

        -- the left action structure of G₀ on ker σ
        -- is given by
        -- g α h := ιg + h - ιg
        _α_ : LeftActionStructure ⟨ G₀ ⟩ ⟨ ker-σ ⟩
        g α (h , p) = (ig +₁ h) -₁ ig , q
          where
            ig = 𝒾 g
            abstract
              -- proof that (ig +₁ h) -₁ ig
              -- lies in ker-σ
              q = s ((ig +₁ h) -₁ ig)
                    ≡⟨ σ .isHom (ig +₁ h) (-₁ ig) ⟩
                  s (ig +₁ h) +₀ s (-₁ ig)
                     ≡⟨ cong (s (ig +₁ h) +₀_)
                             (mapInv σ ig) ⟩
                  s (ig +₁ h) -₀ si g
                     ≡⟨ cong (_+₀ -₀ (s ig))
                             (σ .isHom ig h) ⟩
                  (si g +₀ s h) -₀ si g
                      ≡⟨ cong (λ z → ((si g) +₀ z) -₀ (si g))
                              p ⟩
                  ((si g) +₀ 0₀) -₀ (si g)
                      ≡⟨ cong (_+₀ -₀ (s ig))
                              (rId₀ (s ig)) ⟩
                  (si g) -₀ (si g)
                     ≡⟨ rCancel₀ (si g) ⟩
                  0₀ ∎

        -- proof that the left action structure α
        -- satisfies the group action axioms
        abstract
          isAct : IsGroupAction G₀ ker-σ _α_
          -- at every g, g α_ is a homomorphism, that is
          -- g α (h + h') ≡ g α h + g α h'
          isAct .isHom g (h , p) (h' , p') = subtypeWitnessIrrelevance (sg-typeProp σ) q
            where
              ig = ι .fun g
              -ig = -₁ ig
              q = fst (g α ((h , p) +ₖ (h' , p')))
                      ≡⟨ refl ⟩
                  (ig +₁ (h +₁ h')) -₁ ig
                      ≡⟨ cong (λ z → (ig +₁ (z +₁ h')) +₁ (-₁ ig))
                              (sym (rId₁ h)
                                ∙ cong (h +₁_) (sym (lCancel₁ ig))) ⟩
                  (ig +₁ ((h +₁ (-ig +₁ ig)) +₁ h')) -₁ ig
                      ≡⟨ cong (λ z → (ig +₁ (z +₁ h')) -₁ ig)
                              (assoc₁ h -ig ig) ⟩
                  (ig +₁ (((h +₁ -ig) +₁ ig) +₁ h')) -₁ ig
                      ≡⟨ cong (λ z → (ig +₁ z) -₁ ig)
                              (sym (assoc₁ (h -₁ ig) ig h')) ⟩
                  (ig +₁ ((h +₁ -ig) +₁ (ig +₁ h'))) -₁ ig
                      ≡⟨ cong (_+₁ -ig)
                              (assoc₁ ig (h -₁ ig) (ig +₁ h')) ⟩
                  ((ig +₁ (h +₁ -ig)) +₁ (ig +₁ h')) -₁ ig
                       ≡⟨ cong (λ z → (z +₁ (ig +₁ h')) -₁ ig)
                               (assoc₁ ig h -ig) ⟩
                  (((ig +₁ h) +₁ -ig) +₁ (ig +₁ h')) -₁ ig
                    ≡⟨ sym (assoc₁ ((ig +₁ h) -₁ ig) (ig +₁ h') -ig) ⟩
                  ((ig +₁ h) +₁ -ig) +₁ ((ig +₁ h') +₁ -ig)
                       ≡⟨ refl ⟩
                  fst ((g α (h , p)) +ₖ (g α (h' , p'))) ∎
          -- α satisfies the identity law, that is
          -- 0 α h = h for every h
          isAct .identity (h , p) = subtypeWitnessIrrelevance (sg-typeProp σ) q
            where
              q = fst (0₀ α (h , p))
                      ≡⟨ cong (λ z → (z +₁ h) +₁ (-₁ z))
                              (mapId ι) ⟩
                  (0₁ +₁ h) +₁ (-₁ 0₁)
                    ≡⟨ cong ((0₁ +₁ h) +₁_)
                            (invId G₁) ∙∙
                       rId₁ (0₁ +₁ h) ∙∙
                       lId₁ h ⟩
                  h ∎
          -- α is associative in the sense that
          -- (g +₀ g') α h = g α (g' α h)
          isAct .assoc g g' (h , p) = subtypeWitnessIrrelevance (sg-typeProp σ) q
            where
              ig = ι .fun g
              ig' = ι .fun g'
              -ig = -₁ ig
              -ig' = -₁ ig'
              q = (ι .fun (g +₀ g') +₁ h) -₁ (ι .fun (g +₀ g'))
                     ≡⟨ cong (λ z → (z +₁ h) -₁ z)
                             (ι .isHom g g') ⟩
                  ((ig +₁ ig') +₁ h) -₁ (ig +₁ ig')
                    ≡⟨ cong (((ig +₁ ig') +₁ h) +₁_)
                            (invDistr G₁ ig ig') ⟩
                  ((ig +₁ ig') +₁ h) +₁ (-ig' -₁ ig)
                    ≡⟨ cong (_+₁ (-ig' +₁ -ig))
                            (sym (assoc₁ ig ig' h)) ⟩
                  (ig +₁ (ig' +₁ h)) +₁ (-ig' -₁ ig)
                    ≡⟨ assoc₁ (ig +₁ (ig' +₁ h)) -ig' -ig ⟩
                  ((ig +₁ (ig' +₁ h)) -₁ ig') -₁ ig
                    ≡⟨ cong (_+₁ -ig)
                            (sym (assoc₁ ig (ig' +₁ h) -ig')) ⟩
                  fst (g α (g' α (h , p))) ∎
        -- end of abstract
  RelIso.rightInv (𝒮ᴰ-Iso-GroupAct-SplitEpi-* G₀) (G₁ , (ι , σ) , isSplit) = G₁-≅ , (ι-≅ , σ-≅) , isSplit-≅
    where
      -- get our hands dirty with shameless reference to what we're constructing,
      -- such is the power of copatterns!
      -- back: turn the given split epi into the group action tuple ga
      ga = RelIso.inv (𝒮ᴰ-Iso-GroupAct-SplitEpi-* G₀) (G₁ , (ι , σ) , isSplit)
      -- map ga forth to the split epi tuple se'
      se' = RelIso.fun (𝒮ᴰ-Iso-GroupAct-SplitEpi-* G₀) ga

      -- notation

      -- short for (ker σ) ⋊⟨ Adᵢ ⟩ G₀
      kσ⋊G₀ = fst se'
      -- the group action ga
      _α_ = fst (snd ga)
      isAct = snd (snd ga)

      open GroupNotation₀ G₀
      open GroupNotation₁ G₁

      -- notational convention:
      -- g : ⟨ G₀ ⟩
      -- h : ⟨ G₁ ⟩
      -- p : witness that g is in ker σ

      open SplitEpiNotation ι σ isSplit

      -- (ker σ) ⋊⟨ Adᵢ ⟩ G₀ ≃ G₁
      G₁-≅ : GroupEquiv kσ⋊G₀ G₁
      GroupEquiv.eq G₁-≅ = isoToEquiv isom
        where
          isom : Iso ⟨ kσ⋊G₀ ⟩ ⟨ G₁ ⟩
          -- map forth is straight forward
          Iso.fun isom ((h , p) , g) = h +₁ 𝒾 g

          -- beginning of Iso.inv isom h

          -- G₁ part of the map
          fst (fst (Iso.inv isom h)) = h +₁ (is- h)
          -- proof that G₁ part is in ker σ
          snd (fst (Iso.inv isom h)) = q
            where
              abstract
                q = s (h +₁ is- h)
                      ≡⟨ σ .isHom h (is- h) ⟩
                    s h +₀ s (is- h)
                      ≡⟨ cong (s h +₀_)
                              (funExt⁻ (cong GroupHom.fun isSplit) (s- h)) ⟩
                    s h +₀ (s- h)
                      ≡⟨ cong (s h +₀_)
                              (mapInv σ h) ⟩
                    s h -₀ (s h)
                      ≡⟨ rCancel₀ (s h) ⟩
                    0₀ ∎
          -- G₀ part of the map
          snd (Iso.inv isom h) = s h

          -- end of Iso.inv isom h

          -- beginning of Iso.leftInv isom ((h , p) , g)

          Iso.leftInv isom ((h , p) , g) = ΣPathP (subtypeWitnessIrrelevance (sg-typeProp σ) q , q')
            where
              abstract
                q = (h +₁ 𝒾 g) +₁ is- (h +₁ 𝒾 g)
                       ≡⟨ cong (λ z → (h +₁ 𝒾 g) +₁ is z)
                               (invDistr G₁ h (𝒾 g)) ⟩
                    (h +₁ 𝒾 g) +₁ is ((-i g) -₁ h)
                      ≡⟨ cong (λ z → (h +₁ 𝒾 g) +₁ 𝒾 z)
                              (σ .isHom (-i g) (-₁ h)) ⟩
                    (h +₁ 𝒾 g) +₁ 𝒾 ((s-i g) +₀ (s- h))
                      ≡⟨ cong (λ z → (h +₁ 𝒾 g) +₁ 𝒾 ((s-i g) +₀ z))
                              (mapInv σ h ∙∙
                               cong -₀_ p ∙∙
                               invId G₀) ⟩
                    (h +₁ 𝒾 g) +₁ 𝒾 ((s-i g) +₀ 0₀)
                      ≡⟨ cong (λ z → (h +₁ 𝒾 g) +₁ 𝒾 z)
                              (rId₀ (s-i g)) ⟩
                    (h +₁ 𝒾 g) +₁ 𝒾 (s-i g)
                      ≡⟨ cong (λ z → (h +₁ 𝒾 g) +₁ 𝒾 z )
                              (mapInv σ (𝒾 g)) ⟩
                    (h +₁ 𝒾 g) +₁ 𝒾 (-si g)
                      ≡⟨ cong ((h +₁ 𝒾 g) +₁_)
                              (mapInv ι (si g)) ⟩
                    (h +₁ 𝒾 g) -₁ (isi g)
                      ≡⟨ cong (λ z → (h +₁ 𝒾 g) -₁ (𝒾 z))
                              (funExt⁻ (cong GroupHom.fun isSplit) g ) ⟩
                    (h +₁ 𝒾 g) -₁ (𝒾 g)
                      ≡⟨ sym (assoc₁ h (𝒾 g) (-i g)) ⟩
                    h +₁ (𝒾 g -₁ (𝒾 g))
                      ≡⟨ cong (h +₁_)
                              (rCancel₁ (𝒾 g)) ⟩
                    h +₁ 0₁
                      ≡⟨ rId₁ h ⟩
                    h ∎

                q' = s (h +₁ 𝒾 g)
                       ≡⟨ σ .isHom h (𝒾 g) ⟩
                     s h +₀ si g
                       ≡⟨ cong (_+₀ si g) p ⟩
                     0₀ +₀ si g
                       ≡⟨ lId₀ (si g) ⟩
                     si g
                       ≡⟨ funExt⁻ (cong GroupHom.fun isSplit) g ⟩
                     g ∎

          -- end of Iso.leftInv isom ((h , p) , g)

          Iso.rightInv isom h = q
            where
              ish = 𝒾 (s h)
              abstract
                q = (h +₁ 𝒾 (s (-₁ h))) +₁ ish
                       ≡⟨ cong (λ z → (h +₁ z) +₁ ish) (cong 𝒾 (mapInv σ h) ∙ mapInv ι (s h)) ⟩
                    (h +₁ (-₁ ish)) +₁ ish
                       ≡⟨ sym (assoc₁ h (-₁ ish) ish) ⟩
                    h +₁ ((-₁ ish) +₁ ish)
                       ≡⟨ (cong (h +₁_) (lCancel₁ ish)) ∙ (rId₁ h) ⟩
                    h ∎

          -- end of Iso.rightInv isom h

          -- end of Iso ⟨ kσ⋊G₀ ⟩ ⟨ G₁ ⟩

      GroupEquiv.isHom G₁-≅ ((h , p) , g) ((h' , p') , g') = q
        where
          abstract
            q = (h +₁ ((𝒾 g +₁ h') +₁ (-₁ 𝒾 g))) +₁ 𝒾 (g +₀ g')
                   ≡⟨ cong ((h +₁ ((𝒾 g +₁ h') +₁ (-₁ 𝒾 g))) +₁_)
                           (ι .isHom g g') ⟩
                (h +₁ ((𝒾 g +₁ h') +₁ (-₁ 𝒾 g))) +₁ (𝒾 g +₁ 𝒾 g')
                   ≡⟨ sym (assoc₁ h ((𝒾 g +₁ h') +₁ (-₁ 𝒾 g)) (𝒾 g +₁ 𝒾 g')) ⟩
                h +₁ (((𝒾 g +₁ h') +₁ (-₁ 𝒾 g)) +₁ (𝒾 g +₁ 𝒾 g'))
                   ≡⟨ cong (h +₁_)
                           (sym (assoc₁ (𝒾 g +₁ h') (-₁ 𝒾 g) (𝒾 g +₁ 𝒾 g'))) ⟩
                h +₁ ((𝒾 g +₁ h') +₁ ((-₁ 𝒾 g) +₁ (𝒾 g +₁ 𝒾 g')))
                   ≡⟨ cong (λ z → h +₁ ((𝒾 g +₁ h') +₁ z))
                           (assoc₁ (-₁ 𝒾 g) (𝒾 g) (𝒾 g')) ⟩
                h +₁ ((𝒾 g +₁ h') +₁ (((-₁ 𝒾 g) +₁ 𝒾 g) +₁ 𝒾 g'))
                   ≡⟨ cong (λ z → h +₁ ((𝒾 g +₁ h') +₁ (z +₁ 𝒾 g')))
                           (lCancel₁ (𝒾 g)) ⟩
                h +₁ ((𝒾 g +₁ h') +₁ (0₁ +₁ 𝒾 g'))
                   ≡⟨ cong (λ z → h +₁ ((𝒾 g +₁ h') +₁ z))
                           (lId₁ (𝒾 g')) ⟩
                h +₁ ((𝒾 g +₁ h') +₁ 𝒾 g')
                   ≡⟨ cong (h +₁_)
                           (sym (assoc₁ (𝒾 g) h' (𝒾 g'))) ⟩
                h +₁ (𝒾 g +₁ (h' +₁ 𝒾 g'))
                   ≡⟨ assoc₁ h (𝒾 g) (h' +₁ 𝒾 g') ⟩
                (h +₁ 𝒾 g) +₁ (h' +₁ 𝒾 g') ∎

      -- end of GroupEquiv kσ⋊G₀ G₁

      ι-≅ : (g : ⟨ G₀ ⟩) → 0₁ +₁ (𝒾 g) ≡ 𝒾 g
      ι-≅ g = lId₁ (𝒾 g)

      σ-≅ : (((h , _) , g) : ⟨ kσ⋊G₀ ⟩) → g ≡ s (h +₁ 𝒾 g)
      σ-≅ ((h , p) , g) = q
        where
          abstract
            q = g
                  ≡⟨ funExt⁻ (cong fun (sym isSplit)) g ⟩
                s (𝒾 g)
                  ≡⟨ sym (lId₀ (s (𝒾 g))) ⟩
                0₀ +₀ s (𝒾 g)
                  ≡⟨ cong (_+₀ s (𝒾 g)) (sym p) ⟩
                s h +₀ s (𝒾 g)
                  ≡⟨ sym (σ .isHom h (𝒾 g)) ⟩
                s (h +₁ 𝒾 g) ∎

      isSplit-≅ : Unit
      isSplit-≅ = tt
  RelIso.leftInv (𝒮ᴰ-Iso-GroupAct-SplitEpi-* G₀) (H , _α_ , isAct) =  H-≅ , α-≅ , isAct-≅
    where
      -- import notation
      open GroupNotation₀ G₀
      open GroupNotationᴴ H
      open ActionNotationα (groupaction _α_ isAct) using (α-id)

      se = RelIso.fun (𝒮ᴰ-Iso-GroupAct-SplitEpi-* G₀) (H , _α_ , isAct)
      ga' = RelIso.inv (𝒮ᴰ-Iso-GroupAct-SplitEpi-* G₀) se

      -- H under fun and then inv
      ker-π₂ = fst ga'
      -- the adjoint action w.t.r. ι₂
      _β_ = fst (snd ga')
      β-isAct = snd (snd ga')
      -- inclusion of G₀ into H ⋊⟨ α ⟩ G₀
      ι = ι₂ (groupaction _α_ isAct)
      𝒾 = ι .fun

      G₀-≅ : GroupEquiv G₀ G₀
      G₀-≅ = idGroupEquiv G₀

      H-≅ : GroupEquiv ker-π₂ H
      GroupEquiv.eq H-≅ = isoToEquiv isom
        where
          isom : Iso ⟨ ker-π₂ ⟩ ⟨ H ⟩
          Iso.fun isom ((h , g) , p) = h
          Iso.inv isom h = (h , 0₀) , refl
          Iso.leftInv isom ((h , g) , p) = q
            where
              abstract
                r : (h , 0₀) ≡ (h , g)
                r = ΣPathP (refl , sym p)
                q : ((h , 0₀) , refl) ≡ ((h , g) , p)
                q = ΣPathP (r , isProp→PathP (λ i → set₀ (snd (r i)) 0₀) refl p)
          Iso.rightInv isom h = refl

      GroupEquiv.isHom H-≅ ((h , g) , p) ((h' , g') , p') = q
        where
          abstract
            q : h +ᴴ (g α h') ≡ h +ᴴ h'
            q = h +ᴴ (g α h')
                  ≡⟨ cong (λ z → h +ᴴ (z α h')) p ⟩
                h +ᴴ (0₀ α h')
                  ≡⟨ cong (h +ᴴ_) (α-id h') ⟩
                h +ᴴ h' ∎

      α-≅ : (g : ⟨ G₀ ⟩) (((h , g') , p) : ⟨ ker-π₂ ⟩)
            → GroupEquiv.eq H-≅ .fst (g β ((h , g') , p)) ≡ g α h
      α-≅ g ((h , g') , p) = q
        where
          open ActionLemmas (groupaction _α_ isAct)
          abstract
            q = (0ᴴ +ᴴ (g α h)) +ᴴ ((g +₀ g') α ((-₀ g) α (-ᴴ 0ᴴ)))
                  ≡⟨ cong (_+ᴴ ((g +₀ g') α ((-₀ g) α (-ᴴ 0ᴴ))))
                          (lIdᴴ (g α h)) ⟩
                (g α h) +ᴴ ((g +₀ g') α ((-₀ g) α (-ᴴ 0ᴴ)))
                  ≡⟨ cong (λ z → (g α h) +ᴴ ((g +₀ g') α ((-₀ g) α z)))
                          (invId H) ⟩
                (g α h) +ᴴ ((g +₀ g') α ((-₀ g) α 0ᴴ))
                  ≡⟨ cong (λ z → (g α h) +ᴴ ((g +₀ g') α z))
                          (actOnUnit (-₀ g)) ⟩
                (g α h) +ᴴ ((g +₀ g') α 0ᴴ)
                  ≡⟨ cong ((g α h) +ᴴ_)
                          (actOnUnit (g +₀ g')) ⟩
                (g α h) +ᴴ 0ᴴ
                  ≡⟨ rIdᴴ (g α h) ⟩
                g α h ∎

      isAct-≅ : Unit
      isAct-≅ = tt

  IsoActionSplitEpi-* : Iso (GGLasAct ℓ (ℓ-max ℓ ℓ')) (SplitEpi' ℓ (ℓ-max ℓ ℓ'))
  IsoActionSplitEpi-* =
    𝒮ᴰ-♭PIso-Over→TotalIso idIso
                            (𝒮ᴰ-G\GLasAction ℓ (ℓ-max ℓ ℓ'))
                            (𝒮ᴰ-G\GFBSplitEpi ℓ (ℓ-max ℓ ℓ'))
                            𝒮ᴰ-Iso-GroupAct-SplitEpi-*

  IsoActionSplitEpi : Iso (Action ℓ (ℓ-max ℓ ℓ')) (SplitEpi ℓ (ℓ-max ℓ ℓ'))
  IsoActionSplitEpi = compIso (IsoAction ℓ (ℓ-max ℓ ℓ'))
                              (compIso IsoActionSplitEpi-* (IsoSplitEpi' ℓ (ℓ-max ℓ ℓ')))


-- Andreas, 2016-02-02, issues 480, 1159, 1811

data Unit : Set where
  unit : Unit

-- To make it harder for Agda, we make constructor unit ambiguous.
data Ambiguous : Set where
  unit : Ambiguous

postulate
  f : ∀{A : Set} → (A → A) → A

test : Unit
test = f \{ unit → unit }

-- Extended lambda checking should be postponed until
-- type A has been instantiated to Unit.

-- Should succeed.


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

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.GroupoidLaws
open import Cubical.Foundations.Equiv
open import Cubical.Foundations.Isomorphism
open import Cubical.Foundations.Transport
open import Cubical.Foundations.Univalence

open import Cubical.Reflection.StrictEquiv

private
  variable
    ℓ ℓ' : Level
    A : Type ℓ

-- Less polymorphic version of `cong`, to avoid some unresolved metas
cong′ : ∀ {B : Type ℓ'} (f : A → B) {x y : A} (p : x ≡ y)
      → Path B (f x) (f y)
cong′ f = cong f
{-# INLINE cong′ #-}

PathP≡Path : ∀ (P : I → Type ℓ) (p : P i0) (q : P i1) →
             PathP P p q ≡ Path (P i1) (transport (λ i → P i) p) q
PathP≡Path P p q i = PathP (λ j → P (i ∨ j)) (transport-filler (λ j → P j) p i) q

PathP≡Path⁻ : ∀ (P : I → Type ℓ) (p : P i0) (q : P i1) →
             PathP P p q ≡ Path (P i0) p (transport⁻ (λ i → P i) q)
PathP≡Path⁻ P p q i = PathP (λ j → P (~ i ∧ j)) p (transport⁻-filler (λ j → P j) q i)

PathPIsoPath : ∀ (A : I → Type ℓ) (x : A i0) (y : A i1) → Iso (PathP A x y) (transport (λ i → A i) x ≡ y)
PathPIsoPath A x y .Iso.fun = fromPathP
PathPIsoPath A x y .Iso.inv = toPathP
PathPIsoPath A x y .Iso.rightInv q k i =
  hcomp
    (λ j → λ
      { (i = i0) → slide (j ∨ ~ k)
      ; (i = i1) → q j
      ; (k = i0) → transp (λ l → A (i ∨ l)) i (fromPathPFiller j)
      ; (k = i1) → ∧∨Square i j
      })
    (transp (λ l → A (i ∨ ~ k ∨ l)) (i ∨ ~ k)
      (transp (λ l → (A (i ∨ (~ k ∧ l)))) (k ∨ i)
        (transp (λ l → A (i ∧ l)) (~ i)
          x)))
  where
  fromPathPFiller : _
  fromPathPFiller =
    hfill
      (λ j → λ
        { (i = i0) → x
        ; (i = i1) → q j })
      (inS (transp (λ j → A (i ∧ j)) (~ i) x))

  slide : I → _
  slide i = transp (λ l → A (i ∨ l)) i (transp (λ l → A (i ∧ l)) (~ i) x)

  ∧∨Square : I → I → _
  ∧∨Square i j =
    hcomp
      (λ l → λ
        { (i = i0) → slide j
        ; (i = i1) → q (j ∧ l)
        ; (j = i0) → slide i
        ; (j = i1) → q (i ∧ l)
        })
      (slide (i ∨ j))
PathPIsoPath A x y .Iso.leftInv q k i =
  outS
    (hcomp-unique
      (λ j → λ
        { (i = i0) → x
        ; (i = i1) → transp (λ l → A (j ∨ l)) j (q j)
        })
      (inS (transp (λ l → A (i ∧ l)) (~ i) x))
      (λ j → inS (transp (λ l → A (i ∧ (j ∨ l))) (~ i ∨ j) (q (i ∧ j)))))
    k

PathP≃Path : (A : I → Type ℓ) (x : A i0) (y : A i1) →
             PathP A x y ≃ (transport (λ i → A i) x ≡ y)
PathP≃Path A x y = isoToEquiv (PathPIsoPath A x y)

PathP≡compPath : ∀ {A : Type ℓ} {x y z : A} (p : x ≡ y) (q : y ≡ z) (r : x ≡ z)
                 → (PathP (λ i → x ≡ q i) p r) ≡ (p ∙ q ≡ r)
PathP≡compPath p q r k = PathP (λ i → p i0 ≡ q (i ∨ k)) (λ j → compPath-filler p q k j) r

PathP≡doubleCompPathˡ : ∀ {A : Type ℓ} {w x y z : A} (p : w ≡ y) (q : w ≡ x) (r : y ≡ z) (s : x ≡ z)
                        → (PathP (λ i → p i ≡ s i) q r) ≡ (p ⁻¹ ∙∙ q ∙∙ s ≡ r)
PathP≡doubleCompPathˡ p q r s k = PathP (λ i → p (i ∨ k) ≡ s (i ∨ k))
                                        (λ j → doubleCompPath-filler (p ⁻¹) q s k j) r

PathP≡doubleCompPathʳ : ∀ {A : Type ℓ} {w x y z : A} (p : w ≡ y) (q : w ≡ x) (r : y ≡ z) (s : x ≡ z)
                        → (PathP (λ i → p i ≡ s i) q r) ≡ (q ≡ p ∙∙ r ∙∙ s ⁻¹)
PathP≡doubleCompPathʳ p q r s k  = PathP (λ i → p (i ∧ (~ k)) ≡ s (i ∧ (~ k)))
                                         q (λ j → doubleCompPath-filler p r (s ⁻¹) k j)

compPathl-cancel : ∀ {ℓ} {A : Type ℓ} {x y z : A} (p : x ≡ y) (q : x ≡ z) → p ∙ (sym p ∙ q) ≡ q
compPathl-cancel p q = p ∙ (sym p ∙ q) ≡⟨ assoc p (sym p) q ⟩
                       (p ∙ sym p) ∙ q ≡⟨ cong (_∙ q) (rCancel p) ⟩
                              refl ∙ q ≡⟨ sym (lUnit q) ⟩
                                     q ∎

compPathr-cancel : ∀ {ℓ} {A : Type ℓ} {x y z : A} (p : z ≡ y) (q : x ≡ y) → (q ∙ sym p) ∙ p ≡ q
compPathr-cancel {x = x} p q i j =
  hcomp-equivFiller (doubleComp-faces (λ _ → x) (sym p) j) (inS (q j)) (~ i)

compPathl-isEquiv : {x y z : A} (p : x ≡ y) → isEquiv (λ (q : y ≡ z) → p ∙ q)
compPathl-isEquiv p = isoToIsEquiv (iso (p ∙_) (sym p ∙_) (compPathl-cancel p) (compPathl-cancel (sym p)))

compPathlEquiv : {x y z : A} (p : x ≡ y) → (y ≡ z) ≃ (x ≡ z)
compPathlEquiv p = (p ∙_) , compPathl-isEquiv p

compPathr-isEquiv : {x y z : A} (p : y ≡ z) → isEquiv (λ (q : x ≡ y) → q ∙ p)
compPathr-isEquiv p = isoToIsEquiv (iso (_∙ p) (_∙ sym p) (compPathr-cancel p) (compPathr-cancel (sym p)))

compPathrEquiv : {x y z : A} (p : y ≡ z) → (x ≡ y) ≃ (x ≡ z)
compPathrEquiv p = (_∙ p) , compPathr-isEquiv p

-- Variations of isProp→isSet for PathP
isProp→SquareP : ∀ {B : I → I → Type ℓ} → ((i j : I) → isProp (B i j))
             → {a : B i0 i0} {b : B i0 i1} {c : B i1 i0} {d : B i1 i1}
             → (r : PathP (λ j → B j i0) a c) (s : PathP (λ j → B j i1) b d)
             → (t : PathP (λ j → B i0 j) a b) (u : PathP (λ j → B i1 j) c d)
             → SquareP B t u r s
isProp→SquareP {B = B} isPropB {a = a} r s t u i j =
  hcomp (λ { k (i = i0) → isPropB i0 j (base i0 j) (t j) k
           ; k (i = i1) → isPropB i1 j (base i1 j) (u j) k
           ; k (j = i0) → isPropB i i0 (base i i0) (r i) k
           ; k (j = i1) → isPropB i i1 (base i i1) (s i) k
        }) (base i j) where
    base : (i j : I) → B i j
    base i j = transport (λ k → B (i ∧ k) (j ∧ k)) a

isProp→isPropPathP : ∀ {ℓ} {B : I → Type ℓ} → ((i : I) → isProp (B i))
                   → (b0 : B i0) (b1 : B i1)
                   → isProp (PathP (λ i → B i) b0 b1)
isProp→isPropPathP {B = B} hB b0 b1 = isProp→SquareP (λ _ → hB) refl refl

isProp→isContrPathP : {A : I → Type ℓ} → (∀ i → isProp (A i))
                    → (x : A i0) (y : A i1)
                    → isContr (PathP A x y)
isProp→isContrPathP h x y = isProp→PathP h x y , isProp→isPropPathP h x y _

-- Flipping a square along its diagonal

flipSquare : {a₀₀ a₀₁ : A} {a₀₋ : a₀₀ ≡ a₀₁}
  {a₁₀ a₁₁ : A} {a₁₋ : a₁₀ ≡ a₁₁}
  {a₋₀ : a₀₀ ≡ a₁₀} {a₋₁ : a₀₁ ≡ a₁₁}
  → Square a₀₋ a₁₋ a₋₀ a₋₁ → Square a₋₀ a₋₁ a₀₋ a₁₋
flipSquare sq i j = sq j i

module _ {a₀₀ a₀₁ : A} {a₀₋ : a₀₀ ≡ a₀₁} {a₁₀ a₁₁ : A} {a₁₋ : a₁₀ ≡ a₁₁}
  {a₋₀ : a₀₀ ≡ a₁₀} {a₋₁ : a₀₁ ≡ a₁₁}
  where

  flipSquareEquiv : Square a₀₋ a₁₋ a₋₀ a₋₁ ≃ Square a₋₀ a₋₁ a₀₋ a₁₋
  unquoteDef flipSquareEquiv = defStrictEquiv flipSquareEquiv flipSquare flipSquare

  flipSquarePath : Square a₀₋ a₁₋ a₋₀ a₋₁ ≡ Square a₋₀ a₋₁ a₀₋ a₁₋
  flipSquarePath = ua flipSquareEquiv

module _ {a₀₀ a₁₁ : A} {a₋ : a₀₀ ≡ a₁₁}
  {a₁₀ : A} {a₁₋ : a₁₀ ≡ a₁₁} {a₋₀ : a₀₀ ≡ a₁₀} where

  slideSquareFaces : (i j k : I) → Partial (i ∨ ~ i ∨ j ∨ ~ j) A
  slideSquareFaces i j k (i = i0) = a₋ (j ∧ ~ k)
  slideSquareFaces i j k (i = i1) = a₁₋ j
  slideSquareFaces i j k (j = i0) = a₋₀ i
  slideSquareFaces i j k (j = i1) = a₋ (i ∨ ~ k)

  slideSquare : Square a₋ a₁₋ a₋₀ refl → Square refl a₁₋ a₋₀ a₋
  slideSquare sq i j = hcomp (slideSquareFaces i j) (sq i j)

  slideSquareEquiv : (Square a₋ a₁₋ a₋₀ refl) ≃ (Square refl a₁₋ a₋₀ a₋)
  slideSquareEquiv = isoToEquiv (iso slideSquare slideSquareInv fillerTo fillerFrom) where
    slideSquareInv : Square refl a₁₋ a₋₀ a₋ → Square a₋ a₁₋ a₋₀ refl
    slideSquareInv sq i j = hcomp (λ k → slideSquareFaces i j (~ k)) (sq i j)
    fillerTo : ∀ p → slideSquare (slideSquareInv p) ≡ p
    fillerTo p k i j = hcomp-equivFiller (λ k → slideSquareFaces i j (~ k)) (inS (p i j)) (~ k)
    fillerFrom : ∀ p → slideSquareInv (slideSquare p) ≡ p
    fillerFrom p k i j = hcomp-equivFiller (slideSquareFaces i j) (inS (p i j)) (~ k)

-- The type of fillers of a square is equivalent to the double composition identites
Square≃doubleComp : {a₀₀ a₀₁ a₁₀ a₁₁ : A}
                    (a₀₋ : a₀₀ ≡ a₀₁) (a₁₋ : a₁₀ ≡ a₁₁)
                    (a₋₀ : a₀₀ ≡ a₁₀) (a₋₁ : a₀₁ ≡ a₁₁)
                    → Square a₀₋ a₁₋ a₋₀ a₋₁ ≃ (a₋₀ ⁻¹ ∙∙ a₀₋ ∙∙ a₋₁ ≡ a₁₋)
Square≃doubleComp a₀₋ a₁₋ a₋₀ a₋₁ = transportEquiv (PathP≡doubleCompPathˡ a₋₀ a₀₋ a₁₋ a₋₁)

-- Flipping a square in Ω²A is the same as inverting it
sym≡flipSquare : {x : A} (P : Square (refl {x = x}) refl refl refl)
  → sym P ≡ flipSquare P
sym≡flipSquare {x = x} P = sym (main refl P)
  where
  B : (q : x ≡ x) → I → Type _
  B q i = PathP (λ j → x ≡ q (i ∨ j)) (λ k → q (i ∧ k)) refl

  main : (q : x ≡ x) (p : refl ≡ q) → PathP (λ i → B q i) (λ i j → p j i) (sym p)
  main q = J (λ q p → PathP (λ i → B q i) (λ i j → p j i) (sym p)) refl

-- Inverting both interval arguments of a square in Ω²A is the same as doing nothing
sym-cong-sym≡id : {x : A} (P : Square (refl {x = x}) refl refl refl)
  → P ≡ λ i j → P (~ i) (~ j)
sym-cong-sym≡id {x = x} P = sym (main refl P)
  where
  B : (q : x ≡ x) → I → Type _
  B q i = Path (x ≡ q i) (λ j → q (i ∨ ~ j)) λ j → q (i ∧ j)

  main : (q : x ≡ x) (p : refl ≡ q) → PathP (λ i → B q i) (λ i j → p (~ i) (~ j)) p
  main q = J (λ q p → PathP (λ i → B q i) (λ i j → p (~ i) (~ j)) p) refl

-- Applying cong sym is the same as flipping a square in Ω²A
flipSquare≡cong-sym : ∀ {ℓ} {A : Type ℓ} {x : A} (P : Square (refl {x = x}) refl refl refl)
  → flipSquare P ≡ λ i j → P i (~ j)
flipSquare≡cong-sym P = sym (sym≡flipSquare P) ∙ sym (sym-cong-sym≡id (cong sym P))

-- Applying cong sym is the same as inverting a square in Ω²A
sym≡cong-sym : ∀ {ℓ} {A : Type ℓ} {x : A} (P : Square (refl {x = x}) refl refl refl)
  → sym P ≡ cong sym P
sym≡cong-sym P = sym-cong-sym≡id (sym P)

-- sym induces an equivalence on identity types of paths
symIso : {a b : A} (p q : a ≡ b) → Iso (p ≡ q) (q ≡ p)
symIso p q = iso sym sym (λ _ → refl) λ _ → refl

-- J is an equivalence
Jequiv : {x : A} (P : ∀ y → x ≡ y → Type ℓ') → P x refl ≃ (∀ {y} (p : x ≡ y) → P y p)
Jequiv P = isoToEquiv isom
  where
  isom : Iso _ _
  Iso.fun isom = J P
  Iso.inv isom f = f refl
  Iso.rightInv isom f =
    implicitFunExt λ {_} →
    funExt λ t →
    J (λ _ t → J P (f refl) t ≡ f t) (JRefl P (f refl)) t
  Iso.leftInv isom = JRefl P

-- Action of PathP on equivalences (without relying on univalence)

congPathIso : ∀ {ℓ ℓ'} {A : I → Type ℓ} {B : I → Type ℓ'}
  (e : ∀ i → A i ≃ B i) {a₀ : A i0} {a₁ : A i1}
  → Iso (PathP A a₀ a₁) (PathP B (e i0 .fst a₀) (e i1 .fst a₁))
congPathIso {A = A} {B} e {a₀} {a₁} .Iso.fun p i = e i .fst (p i)
congPathIso {A = A} {B} e {a₀} {a₁} .Iso.inv q i =
  hcomp
    (λ j → λ
      { (i = i0) → retEq (e i0) a₀ j
      ; (i = i1) → retEq (e i1) a₁ j
      })
    (invEq (e i) (q i))
congPathIso {A = A} {B} e {a₀} {a₁} .Iso.rightInv q k i =
  hcomp
    (λ j → λ
      { (i = i0) → commSqIsEq (e i0 .snd) a₀ j k
      ; (i = i1) → commSqIsEq (e i1 .snd) a₁ j k
      ; (k = i0) →
        e i .fst
          (hfill
            (λ j → λ
              { (i = i0) → retEq (e i0) a₀ j
              ; (i = i1) → retEq (e i1) a₁ j
              })
            (inS (invEq (e i) (q i)))
            j)
      ; (k = i1) → q i
      })
    (secEq (e i) (q i) k)
    where b = commSqIsEq
congPathIso {A = A} {B} e {a₀} {a₁} .Iso.leftInv p k i =
  hcomp
    (λ j → λ
      { (i = i0) → retEq (e i0) a₀ (j ∨ k)
      ; (i = i1) → retEq (e i1) a₁ (j ∨ k)
      ; (k = i1) → p i
      })
    (retEq (e i) (p i) k)

congPathEquiv : ∀ {ℓ ℓ'} {A : I → Type ℓ} {B : I → Type ℓ'}
  (e : ∀ i → A i ≃ B i) {a₀ : A i0} {a₁ : A i1}
  → PathP A a₀ a₁ ≃ PathP B (e i0 .fst a₀) (e i1 .fst a₁)
congPathEquiv e = isoToEquiv (congPathIso e)

-- Characterizations of dependent paths in path types

doubleCompPath-filler∙ : {a b c d : A} (p : a ≡ b) (q : b ≡ c) (r : c ≡ d)
  → PathP (λ i → p i ≡ r (~ i)) (p ∙ q ∙ r) q
doubleCompPath-filler∙ {A = A} {b = b} p q r j i =
  hcomp (λ k → λ { (i = i0) → p j
                  ; (i = i1) → side j k
                  ; (j = i1) → q (i ∧ k)})
        (p (j ∨ i))
  where
  side : I → I → A
  side i j =
    hcomp (λ k → λ { (i = i1) → q j
                    ; (j = i0) → b
                    ; (j = i1) → r (~ i ∧ k)})
          (q j)

PathP→compPathL : {a b c d : A} {p : a ≡ c} {q : b ≡ d} {r : a ≡ b} {s : c ≡ d}
  → PathP (λ i → p i ≡ q i) r s
  → sym p ∙ r ∙ q ≡ s
PathP→compPathL {p = p} {q = q} {r = r} {s = s} P j i =
  hcomp (λ k → λ { (i = i0) → p (j ∨ k)
                 ; (i = i1) → q (j ∨ k)
                 ; (j = i0) → doubleCompPath-filler∙ (sym p) r q (~ k) i
                 ; (j = i1) → s i })
        (P j i)

PathP→compPathR : {a b c d : A} {p : a ≡ c} {q : b ≡ d} {r : a ≡ b} {s : c ≡ d}
  → PathP (λ i → p i ≡ q i) r s
  → r ≡ p ∙ s ∙ sym q
PathP→compPathR {p = p} {q = q} {r = r} {s = s} P j i =
  hcomp (λ k → λ { (i = i0) → p (j ∧ (~ k))
                 ; (i = i1) → q (j ∧ (~ k))
                 ; (j = i0) → r i
                 ; (j = i1) → doubleCompPath-filler∙ p s (sym q) (~ k) i})
        (P j i)

-- Other direction

compPathL→PathP : {a b c d : A} {p : a ≡ c} {q : b ≡ d} {r : a ≡ b} {s : c ≡ d}
  → sym p ∙ r ∙ q ≡ s
  → PathP (λ i → p i ≡ q i) r s
compPathL→PathP {p = p} {q = q} {r = r} {s = s} P j i =
  hcomp (λ k → λ { (i = i0) → p (~ k ∨ j)
                 ; (i = i1) → q (~ k ∨ j)
                 ; (j = i0) → doubleCompPath-filler∙ (sym p) r q k i
                 ; (j = i1) → s i})
        (P j i)

compPathR→PathP : {a b c d : A} {p : a ≡ c} {q : b ≡ d} {r : a ≡ b} {s : c ≡ d}
  → r ≡ p ∙ s ∙ sym q
  → PathP (λ i → p i ≡ q i) r s
compPathR→PathP {p = p} {q = q} {r = r} {s = s} P j i =
  hcomp (λ k → λ { (i = i0) → p (k ∧ j)
                 ; (i = i1) → q (k ∧ j)
                 ; (j = i0) → r i
                 ; (j = i1) → doubleCompPath-filler∙  p s (sym q) k i})
        (P j i)

compPathR→PathP∙∙ : {a b c d : A} {p : a ≡ c} {q : b ≡ d} {r : a ≡ b} {s : c ≡ d}
  → r ≡ p ∙∙ s ∙∙ sym q
  → PathP (λ i → p i ≡ q i) r s
compPathR→PathP∙∙ {p = p} {q = q} {r = r} {s = s} P j i =
    hcomp (λ k → λ { (i = i0) → p (k ∧ j)
                   ; (i = i1) → q (k ∧ j)
                   ; (j = i0) → r i
                   ; (j = i1) → doubleCompPath-filler  p s (sym q) (~ k) i})
          (P j i)


------------------------------------------------------------------------
-- A binary representation of natural numbers
------------------------------------------------------------------------

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

open import Equality
import Erased.Without-box-cong

module Nat.Binary
  {c⁺}
  (eq : ∀ {a p} → Equality-with-J a p c⁺)

  -- An instantiation of the []-cong axioms.
  (ax : ∀ {a} → Erased.Without-box-cong.[]-cong-axiomatisation eq a)
  where

open Derived-definitions-and-properties eq

open import Dec
open import Logical-equivalence using (_⇔_)
open import Prelude hiding (suc; _^_) renaming (_+_ to _⊕_; _*_ to _⊛_)

open import Bijection eq using (_↔_)
open import Equality.Decision-procedures eq
open import Erased eq ax
open import Function-universe eq hiding (id; _∘_)
open import List eq
open import Nat.Solver eq
import Nat.Wrapper eq as Wrapper
open import Surjection eq using (_↠_)

private

  module N where
    open import Nat eq public
    open Prelude public using (zero; suc; _^_)

  variable
    A     : Type
    inv n : A
    b     : Bool
    bs    : List Bool

------------------------------------------------------------------------
-- The underlying representation

private

  module Bin′ where

    abstract

      -- The underlying representation of binary natural numbers. The
      -- least significant digit comes first; true stands for one and
      -- false for zero. Leading zeros (at the end of the lists) are
      -- not allowed.
      --
      -- The type is abstract to ensure that a change to a different
      -- representation does not break code that uses this module.

      mutual

        infixr 5 _∷_

        data Bin′ : Type where
          []  : Bin′
          _∷_ : (b : Bool) (n : Bin′)
                { @0 invariant : Invariant b n } → Bin′

        private

          Invariant : Bool → Bin′ → Type
          Invariant true  _       = ⊤
          Invariant false (_ ∷ _) = ⊤
          Invariant false []      = ⊥

          -- A variant of _∷_ with three explicit arguments.

          pattern _∷_⟨_⟩ b n inv = _∷_ b n {invariant = inv}

          -- Synonyms that can be used in type signatures (Bin′ is
          -- abstract, so the constructors cannot be used there).

          []′ : Bin′
          []′ = []

          _∷_⟨_⟩′ : (b : Bool) (n : Bin′) → @0 Invariant b n → Bin′
          _∷_⟨_⟩′ = _∷_⟨_⟩

      private

        -- The underlying list.

        to-List : Bin′ → List Bool
        to-List []       = []
        to-List (b ∷ bs) = b ∷ to-List bs

        -- The invariant implies that the last element in the
        -- underlying list, if any, is not false, so there are no
        -- leading zeros in the number.

        invariant-correct : ∀ n bs → ¬ to-List n ≡ bs ++ false ∷ []
        invariant-correct [] bs =
          [] ≡ bs ++ false ∷ []  ↝⟨ []≢++∷ bs ⟩□
          ⊥                      □
        invariant-correct (true ∷ n) [] =
          true ∷ to-List n ≡ false ∷ []  ↝⟨ List.cancel-∷-head ⟩
          true ≡ false                   ↝⟨ Bool.true≢false ⟩□
          ⊥                              □
        invariant-correct (false ∷ n@(_ ∷ _)) [] =
          false ∷ to-List n ≡ false ∷ []  ↝⟨ List.cancel-∷-tail ⟩
          to-List n ≡ []                  ↝⟨ List.[]≢∷ ∘ sym ⟩□
          ⊥                               □
        invariant-correct (b ∷ n) (b′ ∷ bs) =
          b ∷ to-List n ≡ b′ ∷ bs ++ false ∷ []  ↝⟨ List.cancel-∷-tail ⟩
          to-List n ≡ bs ++ false ∷ []           ↝⟨ invariant-correct n bs ⟩□
          ⊥                                      □

        -- The invariant is propositional.

        Invariant-propositional :
          {b : Bool} {n : Bin′} → Is-proposition (Invariant b n)
        Invariant-propositional {b = true}              _ _ = refl _
        Invariant-propositional {b = false} {n = _ ∷ _} _ _ = refl _

        -- Converts from Bool to ℕ.

        from-Bool : Bool → ℕ
        from-Bool = if_then 1 else 0

        -- Converts from List Bool to ℕ.

        List-to-ℕ : List Bool → ℕ
        List-to-ℕ = foldr (λ b n → from-Bool b ⊕ 2 ⊛ n) 0

      -- Converts from Bin′ to ℕ.

      to-ℕ′ : Bin′ → ℕ
      to-ℕ′ = List-to-ℕ ∘ to-List

      private

        -- A smart constructor.

        infixr 5 _∷ˢ_

        _∷ˢ_ : Bool → Bin′ → Bin′
        true  ∷ˢ n         = true ∷ n
        false ∷ˢ []        = []
        false ∷ˢ n@(_ ∷ _) = false ∷ n

        -- A lemma relating to-ℕ′ and _∷ˢ_.

        to-ℕ′-∷ˢ : ∀ b n → to-ℕ′ (b ∷ˢ n) ≡ from-Bool b ⊕ 2 ⊛ to-ℕ′ n
        to-ℕ′-∷ˢ true  _       = refl _
        to-ℕ′-∷ˢ false []      = refl _
        to-ℕ′-∷ˢ false (_ ∷ _) = refl _

      -- Zero.

      zero′ : Bin′
      zero′ = []

      -- A lemma relating zero′ and N.zero.

      to-ℕ′-zero′ : to-ℕ′ zero′ ≡ N.zero
      to-ℕ′-zero′ = refl _

      -- The number's successor.

      suc′ : Bin′ → Bin′
      suc′ []          = true ∷ˢ []
      suc′ (false ∷ n) = true ∷ˢ n
      suc′ (true  ∷ n) = false ∷ˢ suc′ n

      private

        -- The successor of the smart cons constructor applied to
        -- false and n is the smart cons constructor applied to true
        -- and n.

        suc′-false-∷ˢ : ∀ n → suc′ (false ∷ˢ n) ≡ true ∷ˢ n
        suc′-false-∷ˢ []      = refl _
        suc′-false-∷ˢ (_ ∷ _) = refl _

      -- A lemma relating suc′ and N.suc.

      to-ℕ′-suc′ : ∀ bs → to-ℕ′ (suc′ bs) ≡ N.suc (to-ℕ′ bs)
      to-ℕ′-suc′ []             = refl _
      to-ℕ′-suc′ n@(false ∷ n′) =
        to-ℕ′ (suc′ n)      ≡⟨⟩
        to-ℕ′ (true ∷ˢ n′)  ≡⟨ to-ℕ′-∷ˢ true n′ ⟩
        1 ⊕ 2 ⊛ to-ℕ′ n′    ≡⟨⟩
        N.suc (to-ℕ′ n)     ∎
      to-ℕ′-suc′ n@(true ∷ n′) =
        to-ℕ′ (suc′ n)            ≡⟨⟩
        to-ℕ′ (false ∷ˢ suc′ n′)  ≡⟨ to-ℕ′-∷ˢ false (suc′ n′) ⟩
        2 ⊛ to-ℕ′ (suc′ n′)       ≡⟨ cong (2 ⊛_) (to-ℕ′-suc′ n′) ⟩
        2 ⊛ N.suc (to-ℕ′ n′)      ≡⟨ solve 1 (λ n → con 2 :* (con 1 :+ n) := con 2 :+ con 2 :* n) (refl _) _ ⟩
        2 ⊕ 2 ⊛ to-ℕ′ n′          ≡⟨⟩
        N.suc (to-ℕ′ n)           ∎

      private

        -- Converts from ℕ to Bin′.

        from-ℕ′ : ℕ → Bin′
        from-ℕ′ zero      = []
        from-ℕ′ (N.suc n) = suc′ (from-ℕ′ n)

        -- The function from-ℕ′ commutes with "multiplication by two".

        from-ℕ′-2-⊛ : ∀ n → from-ℕ′ (2 ⊛ n) ≡ false ∷ˢ from-ℕ′ n
        from-ℕ′-2-⊛ zero      = refl _
        from-ℕ′-2-⊛ (N.suc n) =
          from-ℕ′ (2 ⊛ N.suc n)               ≡⟨⟩
          suc′ (from-ℕ′ (n ⊕ N.suc (n ⊕ 0)))  ≡⟨ cong (suc′ ∘ from-ℕ′) $ sym $ N.suc+≡+suc n ⟩
          suc′ (from-ℕ′ (N.suc (2 ⊛ n)))      ≡⟨⟩
          suc′ (suc′ (from-ℕ′ (2 ⊛ n)))       ≡⟨ cong (suc′ ∘ suc′) (from-ℕ′-2-⊛ n) ⟩
          suc′ (suc′ (false ∷ˢ from-ℕ′ n))    ≡⟨ cong suc′ (suc′-false-∷ˢ (from-ℕ′ n)) ⟩
          suc′ (true ∷ˢ from-ℕ′ n)            ≡⟨⟩
          false ∷ˢ suc′ (from-ℕ′ n)           ≡⟨⟩
          false ∷ˢ from-ℕ′ (N.suc n)          ∎

    -- There is a bijection from Bin′ to ℕ.

    Bin′↔ℕ : Bin′ ↔ ℕ
    Bin′↔ℕ = record
      { surjection = record
        { logical-equivalence = record
          { to   = to-ℕ′
          ; from = from-ℕ′
          }
        ; right-inverse-of = to-ℕ′∘from-ℕ′
        }
      ; left-inverse-of = from-ℕ′∘to-ℕ′
      }
      where

      abstract

        to-ℕ′∘from-ℕ′ : ∀ n → to-ℕ′ (from-ℕ′ n) ≡ n
        to-ℕ′∘from-ℕ′ zero      = refl _
        to-ℕ′∘from-ℕ′ (N.suc n) =
          to-ℕ′ (from-ℕ′ (N.suc n))  ≡⟨⟩
          to-ℕ′ (suc′ (from-ℕ′ n))   ≡⟨ to-ℕ′-suc′ (from-ℕ′ n) ⟩
          N.suc (to-ℕ′ (from-ℕ′ n))  ≡⟨ cong N.suc (to-ℕ′∘from-ℕ′ n) ⟩∎
          N.suc n                    ∎

        from-ℕ′∘to-ℕ′ : ∀ n → from-ℕ′ (to-ℕ′ n) ≡ n
        from-ℕ′∘to-ℕ′ [] = refl _

        from-ℕ′∘to-ℕ′ n@(true ∷ n′) =
          from-ℕ′ (to-ℕ′ n)                   ≡⟨⟩
          from-ℕ′ (1 ⊕ 2 ⊛ to-ℕ′ n′)          ≡⟨⟩
          suc′ (from-ℕ′ (2 ⊛ to-ℕ′ n′))       ≡⟨ cong suc′ (from-ℕ′-2-⊛ (to-ℕ′ n′)) ⟩
          suc′ (false ∷ˢ from-ℕ′ (to-ℕ′ n′))  ≡⟨ cong (suc′ ∘ (false ∷ˢ_)) (from-ℕ′∘to-ℕ′ n′) ⟩
          suc′ (false ∷ˢ n′)                  ≡⟨ suc′-false-∷ˢ n′ ⟩
          true ∷ˢ n′                          ≡⟨⟩
          n                                   ∎

        from-ℕ′∘to-ℕ′ n@(false ∷ n′@(_ ∷ _)) =
          from-ℕ′ (to-ℕ′ n)            ≡⟨⟩
          from-ℕ′ (2 ⊛ to-ℕ′ n′)       ≡⟨ from-ℕ′-2-⊛ (to-ℕ′ n′) ⟩
          false ∷ˢ from-ℕ′ (to-ℕ′ n′)  ≡⟨ cong (false ∷ˢ_) (from-ℕ′∘to-ℕ′ n′) ⟩
          false ∷ˢ n′                  ≡⟨⟩
          n                            ∎

    abstract

      private

        -- Helper functions used to implement addition.

        add-with-carryᴮ : Bool → Bool → Bool → Bool × Bool
        add-with-carryᴮ false false false = false , false
        add-with-carryᴮ false false true  = true  , false
        add-with-carryᴮ false true  false = true  , false
        add-with-carryᴮ false true  true  = false , true
        add-with-carryᴮ true  false false = true  , false
        add-with-carryᴮ true  false true  = false , true
        add-with-carryᴮ true  true  false = false , true
        add-with-carryᴮ true  true  true  = true  , true

        add-with-carry₁ : Bool → Bin′ → Bin′
        add-with-carry₁ false = id
        add-with-carry₁ true  = suc′

        add-with-carry₂ : Bool → Bin′ → Bin′ → Bin′
        add-with-carry₂ b []        n  = add-with-carry₁ b n
        add-with-carry₂ b m@(_ ∷ _) [] = add-with-carry₁ b m

        add-with-carry₂ b (c ∷ m) (d ∷ n) =
          case add-with-carryᴮ b c d of λ where
            (e , f) → e ∷ˢ add-with-carry₂ f m n

        to-ℕ′-add-with-carry₁ :
          ∀ b cs →
          to-ℕ′ (add-with-carry₁ b cs) ≡
          from-Bool b ⊕ to-ℕ′ cs
        to-ℕ′-add-with-carry₁ false n = refl _
        to-ℕ′-add-with-carry₁ true  n = to-ℕ′-suc′ n

        to-ℕ′-add-with-carry₂ :
          ∀ b m n →
          to-ℕ′ (add-with-carry₂ b m n) ≡
          from-Bool b ⊕ (to-ℕ′ m ⊕ to-ℕ′ n)
        to-ℕ′-add-with-carry₂ b [] n = to-ℕ′-add-with-carry₁ b n

        to-ℕ′-add-with-carry₂ b m@(_ ∷ _) [] =
          to-ℕ′ (add-with-carry₁ b m)         ≡⟨ to-ℕ′-add-with-carry₁ b m ⟩
          from-Bool b ⊕ to-ℕ′ m               ≡⟨ solve 2 (λ b c → b :+ c := b :+ (c :+ con 0)) (refl _) (from-Bool b) _ ⟩
          from-Bool b ⊕ (to-ℕ′ m ⊕ 0)         ≡⟨⟩
          from-Bool b ⊕ (to-ℕ′ m ⊕ to-ℕ′ [])  ∎

        to-ℕ′-add-with-carry₂ false m@(false ∷ m′) n@(false ∷ n′) =
          to-ℕ′ (false ∷ˢ add-with-carry₂ false m′ n′)  ≡⟨ to-ℕ′-∷ˢ false (add-with-carry₂ false m′ n′) ⟩
          2 ⊛ to-ℕ′ (add-with-carry₂ false m′ n′)       ≡⟨ cong (2 ⊛_) (to-ℕ′-add-with-carry₂ false m′ n′) ⟩
          2 ⊛ (to-ℕ′ m′ ⊕ to-ℕ′ n′)                     ≡⟨ solve 2 (λ c d → con 2 :* (c :+ d) :=
                                                                            con 2 :* c :+ con 2 :* d)
                                                                 (refl _) (to-ℕ′ m′) _ ⟩
          2 ⊛ to-ℕ′ m′ ⊕ 2 ⊛ to-ℕ′ n′                   ≡⟨⟩
          to-ℕ′ m ⊕ to-ℕ′ n       ∎

        to-ℕ′-add-with-carry₂ false m@(false ∷ m′) n@(true  ∷ n′) =
          to-ℕ′ (true ∷ˢ add-with-carry₂ false m′ n′)  ≡⟨ to-ℕ′-∷ˢ true (add-with-carry₂ false m′ n′) ⟩
          1 ⊕ 2 ⊛ to-ℕ′ (add-with-carry₂ false m′ n′)  ≡⟨ cong ((1 ⊕_) ∘ (2 ⊛_)) (to-ℕ′-add-with-carry₂ false m′ n′) ⟩
          1 ⊕ 2 ⊛ (to-ℕ′ m′ ⊕ to-ℕ′ n′)                ≡⟨ solve 2 (λ c d → con 1 :+ con 2 :* (c :+ d) :=
                                                                           con 2 :* c :+ (con 1 :+ con 2 :* d))
                                                                (refl _) (to-ℕ′ m′) _ ⟩
          2 ⊛ to-ℕ′ m′ ⊕ (1 ⊕ 2 ⊛ to-ℕ′ n′)            ≡⟨⟩
          to-ℕ′ m ⊕ to-ℕ′ n       ∎

        to-ℕ′-add-with-carry₂ false m@(true  ∷ m′) n@(false ∷ n′) =
          to-ℕ′ (true ∷ˢ add-with-carry₂ false m′ n′)  ≡⟨ to-ℕ′-∷ˢ true (add-with-carry₂ false m′ n′) ⟩
          1 ⊕ 2 ⊛ to-ℕ′ (add-with-carry₂ false m′ n′)  ≡⟨ cong ((1 ⊕_) ∘ (2 ⊛_)) (to-ℕ′-add-with-carry₂ false m′ n′) ⟩
          1 ⊕ 2 ⊛ (to-ℕ′ m′ ⊕ to-ℕ′ n′)                ≡⟨ solve 2 (λ c d → con 1 :+ con 2 :* (c :+ d) :=
                                                                           con 1 :+ con 2 :* c :+ con 2 :* d)
                                                                (refl _) (to-ℕ′ m′) _ ⟩
          1 ⊕ 2 ⊛ to-ℕ′ m′ ⊕ 2 ⊛ to-ℕ′ n′              ≡⟨⟩
          to-ℕ′ m ⊕ to-ℕ′ n                            ∎

        to-ℕ′-add-with-carry₂ false m@(true ∷ m′) n@(true ∷ n′) =
          to-ℕ′ (false ∷ˢ add-with-carry₂ true m′ n′)  ≡⟨ to-ℕ′-∷ˢ false (add-with-carry₂ true m′ n′) ⟩
          2 ⊛ to-ℕ′ (add-with-carry₂ true m′ n′)       ≡⟨ cong (2 ⊛_) (to-ℕ′-add-with-carry₂ true m′ n′) ⟩
          2 ⊛ (1 ⊕ to-ℕ′ m′ ⊕ to-ℕ′ n′)                ≡⟨ solve 2 (λ c d → con 2 :* (con 1 :+ c :+ d) :=
                                                                           con 1 :+ con 2 :* c :+ (con 1 :+ con 2 :* d))
                                                                (refl _) (to-ℕ′ m′) _ ⟩
          1 ⊕ 2 ⊛ to-ℕ′ m′ ⊕ (1 ⊕ 2 ⊛ to-ℕ′ n′)        ≡⟨⟩
          to-ℕ′ m ⊕ to-ℕ′ n                            ∎

        to-ℕ′-add-with-carry₂ true m@(false ∷ m′) n@(false ∷ n′) =
          to-ℕ′ (true ∷ˢ add-with-carry₂ false m′ n′)  ≡⟨ to-ℕ′-∷ˢ true (add-with-carry₂ false m′ n′) ⟩
          1 ⊕ 2 ⊛ to-ℕ′ (add-with-carry₂ false m′ n′)  ≡⟨ cong ((1 ⊕_) ∘ (2 ⊛_)) (to-ℕ′-add-with-carry₂ false m′ n′) ⟩
          1 ⊕ 2 ⊛ (to-ℕ′ m′ ⊕ to-ℕ′ n′)                ≡⟨ solve 2 (λ c d → con 1 :+ con 2 :* (c :+ d) :=
                                                                           con 1 :+ con 2 :* c :+ con 2 :* d)
                                                                (refl _) (to-ℕ′ m′) _ ⟩
          1 ⊕ 2 ⊛ to-ℕ′ m′ ⊕ 2 ⊛ to-ℕ′ n′              ≡⟨⟩
          1 ⊕ to-ℕ′ m ⊕ to-ℕ′ n                        ∎

        to-ℕ′-add-with-carry₂ true m@(false ∷ m′) n@(true  ∷ n′) =
          to-ℕ′ (false ∷ˢ add-with-carry₂ true m′ n′)  ≡⟨ to-ℕ′-∷ˢ false (add-with-carry₂ true m′ n′) ⟩
          2 ⊛ to-ℕ′ (add-with-carry₂ true m′ n′)       ≡⟨ cong (2 ⊛_) (to-ℕ′-add-with-carry₂ true m′ n′) ⟩
          2 ⊛ (1 ⊕ to-ℕ′ m′ ⊕ to-ℕ′ n′)                ≡⟨ solve 2 (λ c d → con 2 :* (con 1 :+ c :+ d) :=
                                                                           con 1 :+ con 2 :* c :+ (con 1 :+ con 2 :* d))
                                                                (refl _) (to-ℕ′ m′) _ ⟩
          1 ⊕ 2 ⊛ to-ℕ′ m′ ⊕ (1 ⊕ 2 ⊛ to-ℕ′ n′)        ≡⟨⟩
          1 ⊕ to-ℕ′ m ⊕ to-ℕ′ n                        ∎

        to-ℕ′-add-with-carry₂ true m@(true  ∷ m′) n@(false ∷ n′) =
          to-ℕ′ (false ∷ˢ add-with-carry₂ true m′ n′)  ≡⟨ to-ℕ′-∷ˢ false (add-with-carry₂ true m′ n′) ⟩
          2 ⊛ to-ℕ′ (add-with-carry₂ true m′ n′)       ≡⟨ cong (2 ⊛_) (to-ℕ′-add-with-carry₂ true m′ n′) ⟩
          2 ⊛ (1 ⊕ to-ℕ′ m′ ⊕ to-ℕ′ n′)                ≡⟨ solve 2 (λ c d → con 2 :* (con 1 :+ c :+ d) :=
                                                                           con 2 :+ con 2 :* c :+ con 2 :* d)
                                                                (refl _) (to-ℕ′ m′) _ ⟩
          2 ⊕ 2 ⊛ to-ℕ′ m′ ⊕ 2 ⊛ to-ℕ′ n′              ≡⟨⟩
          1 ⊕ to-ℕ′ m ⊕ to-ℕ′ n                        ∎

        to-ℕ′-add-with-carry₂ true m@(true ∷ m′) n@(true ∷ n′) =
          to-ℕ′ (true ∷ˢ add-with-carry₂ true m′ n′)  ≡⟨ to-ℕ′-∷ˢ true (add-with-carry₂ true m′ n′) ⟩
          1 ⊕ 2 ⊛ to-ℕ′ (add-with-carry₂ true m′ n′)  ≡⟨ cong ((1 ⊕_) ∘ (2 ⊛_)) (to-ℕ′-add-with-carry₂ true m′ n′) ⟩
          1 ⊕ 2 ⊛ (1 ⊕ to-ℕ′ m′ ⊕ to-ℕ′ n′)           ≡⟨ solve 2 (λ c d → con 1 :+ con 2 :* (con 1 :+ c :+ d) :=
                                                                          con 2 :+ con 2 :* c :+ (con 1 :+ con 2 :* d))
                                                               (refl _) (to-ℕ′ m′) _ ⟩
          2 ⊕ 2 ⊛ to-ℕ′ m′ ⊕ (1 ⊕ 2 ⊛ to-ℕ′ n′)       ≡⟨⟩
          1 ⊕ to-ℕ′ m ⊕ to-ℕ′ n                       ∎

      -- Addition.

      add-with-carry : Bin′ → Bin′ → Bin′
      add-with-carry = add-with-carry₂ false

      to-ℕ′-add-with-carry :
        ∀ m n →
        to-ℕ′ (add-with-carry m n) ≡
        to-ℕ′ m ⊕ to-ℕ′ n
      to-ℕ′-add-with-carry = to-ℕ′-add-with-carry₂ false

      -- Division by two, rounded downwards.

      ⌊_/2⌋ : Bin′ → Bin′
      ⌊ []    /2⌋ = []
      ⌊ _ ∷ n /2⌋ = n

      to-ℕ′-⌊/2⌋ : ∀ n → to-ℕ′ ⌊ n /2⌋ ≡ N.⌊ to-ℕ′ n /2⌋
      to-ℕ′-⌊/2⌋ []          = refl _
      to-ℕ′-⌊/2⌋ (false ∷ n) =
        to-ℕ′ n              ≡⟨ sym $ N.⌊2*/2⌋≡ _ ⟩∎
        N.⌊ 2 ⊛ to-ℕ′ n /2⌋  ∎

      to-ℕ′-⌊/2⌋ (true ∷ n) =
        to-ℕ′ n                  ≡⟨ sym $ N.⌊1+2*/2⌋≡ _ ⟩∎
        N.⌊ 1 ⊕ 2 ⊛ to-ℕ′ n /2⌋  ∎

      -- Division by two, rounded upwards.

      ⌈_/2⌉ : Bin′ → Bin′
      ⌈ []        /2⌉ = []
      ⌈ false ∷ n /2⌉ = n
      ⌈ true  ∷ n /2⌉ = suc′ n

      to-ℕ′-⌈/2⌉ : ∀ n → to-ℕ′ ⌈ n /2⌉ ≡ N.⌈ to-ℕ′ n /2⌉
      to-ℕ′-⌈/2⌉ []          = refl _
      to-ℕ′-⌈/2⌉ (false ∷ n) =
        to-ℕ′ n              ≡⟨ sym $ N.⌈2*/2⌉≡ _ ⟩∎
        N.⌈ 2 ⊛ to-ℕ′ n /2⌉  ∎

      to-ℕ′-⌈/2⌉ (true ∷ n) =
        to-ℕ′ (suc′ n)           ≡⟨ to-ℕ′-suc′ n ⟩
        1 ⊕ to-ℕ′ n              ≡⟨ sym $ N.⌈1+2*/2⌉≡ _ ⟩∎
        N.⌈ 1 ⊕ 2 ⊛ to-ℕ′ n /2⌉  ∎

      -- Multiplication.

      infixl 7 _*_

      _*_ : Bin′ → Bin′ → Bin′
      []      * n = zero′
      (b ∷ m) * n =
        (if b then add-with-carry n else id)
          (false ∷ˢ m * n)

      to-ℕ′-* : ∀ m n → to-ℕ′ (m * n) ≡ to-ℕ′ m ⊛ to-ℕ′ n
      to-ℕ′-* []                  n = refl _
      to-ℕ′-* (false ∷ m ⟨ inv ⟩) n =
        to-ℕ′ (false ∷ˢ m * n)               ≡⟨ to-ℕ′-∷ˢ false (m * n) ⟩
        2 ⊛ to-ℕ′ (m * n)                    ≡⟨ cong (2 ⊛_) (to-ℕ′-* m _) ⟩
        2 ⊛ (to-ℕ′ m ⊛ to-ℕ′ n)              ≡⟨ N.*-assoc 2 {n = to-ℕ′ m} ⟩
        (2 ⊛ to-ℕ′ m) ⊛ to-ℕ′ n              ≡⟨⟩
        to-ℕ′ (false ∷ m ⟨ inv ⟩) ⊛ to-ℕ′ n  ∎
      to-ℕ′-* (true ∷ m) n =
        to-ℕ′ (add-with-carry n (false ∷ˢ m * n))  ≡⟨ to-ℕ′-add-with-carry n _ ⟩
        to-ℕ′ n ⊕ to-ℕ′ (false ∷ˢ m * n)           ≡⟨ cong (to-ℕ′ n ⊕_) (to-ℕ′-∷ˢ false (m * n)) ⟩
        to-ℕ′ n ⊕ 2 ⊛ to-ℕ′ (m * n)                ≡⟨ cong (λ x → to-ℕ′ n ⊕ 2 ⊛ x) (to-ℕ′-* m _) ⟩
        to-ℕ′ n ⊕ 2 ⊛ (to-ℕ′ m ⊛ to-ℕ′ n)          ≡⟨ solve 2 (λ m n → n :+ con 2 :* (m :* n) :=
                                                                       (con 1 :+ con 2 :* m) :* n)
                                                            (refl _) (to-ℕ′ m) _ ⟩
        (1 ⊕ 2 ⊛ to-ℕ′ m) ⊛ to-ℕ′ n                ≡⟨⟩
        to-ℕ′ (true ∷ m) ⊛ to-ℕ′ n                 ∎

      -- Exponentiation.

      infixr 8 _^_

      _^_ : Bin′ → Bin′ → Bin′
      m ^ []      = suc′ zero′
      m ^ (b ∷ n) =
        (if b then (m *_) else id)
          ((m * m) ^ n)

      to-ℕ′-^ : ∀ m n → to-ℕ′ (m ^ n) ≡ to-ℕ′ m N.^ to-ℕ′ n
      to-ℕ′-^ m []                  = refl _
      to-ℕ′-^ m (false ∷ n ⟨ inv ⟩) =
        to-ℕ′ (m ^ (false ∷ n ⟨ inv ⟩))        ≡⟨⟩
        to-ℕ′ ((m * m) ^ n)                    ≡⟨ to-ℕ′-^ (m * m) n ⟩
        to-ℕ′ (m * m) N.^ to-ℕ′ n              ≡⟨ cong (N._^ to-ℕ′ n) (to-ℕ′-* m m) ⟩
        (to-ℕ′ m ⊛ to-ℕ′ m) N.^ to-ℕ′ n        ≡⟨ cong (λ x → (to-ℕ′ m ⊛ x) N.^ to-ℕ′ n) (sym (N.*-right-identity (to-ℕ′ m))) ⟩
        (to-ℕ′ m N.^ 2) N.^ to-ℕ′ n            ≡⟨ N.^^≡^* 2 {k = to-ℕ′ n} ⟩
        to-ℕ′ m N.^ (2 ⊛ to-ℕ′ n)              ≡⟨⟩
        to-ℕ′ m N.^ to-ℕ′ (false ∷ n ⟨ inv ⟩)  ∎
      to-ℕ′-^ m (true ∷ n) =
        to-ℕ′ (m ^ (true ∷ n))                     ≡⟨⟩
        to-ℕ′ (m * (m * m) ^ n)                    ≡⟨ to-ℕ′-* m ((m * m) ^ n) ⟩
        to-ℕ′ m ⊛ to-ℕ′ ((m * m) ^ n)              ≡⟨ cong (to-ℕ′ m ⊛_) (to-ℕ′-^ (m * m) n) ⟩
        to-ℕ′ m ⊛ to-ℕ′ (m * m) N.^ to-ℕ′ n        ≡⟨ cong (λ x → to-ℕ′ m ⊛ x N.^ to-ℕ′ n) (to-ℕ′-* m m) ⟩
        to-ℕ′ m ⊛ (to-ℕ′ m ⊛ to-ℕ′ m) N.^ to-ℕ′ n  ≡⟨ cong (λ x → to-ℕ′ m ⊛ (to-ℕ′ m ⊛ x) N.^ to-ℕ′ n) (sym (N.*-right-identity (to-ℕ′ m))) ⟩
        to-ℕ′ m ⊛ (to-ℕ′ m N.^ 2) N.^ to-ℕ′ n      ≡⟨ cong₂ _⊛_ (sym (N.^-right-identity {n = to-ℕ′ m})) (N.^^≡^* 2 {k = to-ℕ′ n}) ⟩
        to-ℕ′ m N.^ 1 ⊛ to-ℕ′ m N.^ (2 ⊛ to-ℕ′ n)  ≡⟨ sym $ N.^+≡^*^ {m = to-ℕ′ m} 1 {k = 2 ⊛ to-ℕ′ n} ⟩
        to-ℕ′ m N.^ (1 ⊕ 2 ⊛ to-ℕ′ n)              ≡⟨⟩
        to-ℕ′ m N.^ to-ℕ′ (true ∷ n)               ∎

      -- "Left shift".

      infixl 8 _*2^_

      _*2^_ : Bin′ → ℕ → Bin′
      m *2^ zero    = m
      m *2^ N.suc n = (false ∷ˢ m) *2^ n

      to-ℕ′-*2^ :
        ∀ m n →
        to-ℕ′ (m *2^ n) ≡
        to-ℕ′ m ⊛ 2 N.^ n
      to-ℕ′-*2^ m zero =
        to-ℕ′ m      ≡⟨ sym $ N.*-right-identity _ ⟩∎
        to-ℕ′ m ⊛ 1  ∎
      to-ℕ′-*2^ m (N.suc n) =
        to-ℕ′ ((false ∷ˢ m) *2^ n)    ≡⟨ to-ℕ′-*2^ (false ∷ˢ m) n ⟩
        to-ℕ′ (false ∷ˢ m) ⊛ 2 N.^ n  ≡⟨ cong (_⊛ _) $ to-ℕ′-∷ˢ false m ⟩
        2 ⊛ to-ℕ′ m ⊛ 2 N.^ n         ≡⟨ cong (_⊛ (2 N.^ n)) $ N.*-comm 2 {n = to-ℕ′ m} ⟩
        to-ℕ′ m ⊛ 2 ⊛ 2 N.^ n         ≡⟨ sym $ N.*-assoc (to-ℕ′ m) ⟩∎
        to-ℕ′ m ⊛ 2 N.^ N.suc n       ∎

      private

        -- The empty list is not equal to any non-empty list.

        []≢∷ : []′ ≢ b ∷ n ⟨ inv ⟩′
        []≢∷ {b = b} {n = n} =
          [] ≡ b ∷ n          ↝⟨ cong to-List ⟩
          [] ≡ b ∷ to-List n  ↝⟨ List.[]≢∷ ⟩□
          ⊥                   □

        -- Equality is decidable for Bin′.
        --
        -- This definition uses Dec-Erased instead of Dec ∘ Erased
        -- because I thought this made the code a little less
        -- complicated.

        equal? : (m n : Bin′) → Dec-Erased (m ≡ n)
        equal? [] [] = yes [ refl _ ]

        equal? [] (b ∷ n) = no [ []≢∷ ]

        equal? (b ∷ n) [] = no [ []≢∷ ∘ sym ]

        equal? (b₁ ∷ n₁) (b₂ ∷ n₂) =
          helper₁ _ _ (b₁ Bool.≟ b₂)
          where
          helper₂ :
            ∀ n₁ n₂
            (@0 inv₁ : Invariant b₁ n₁) (@0 inv₂ : Invariant b₂ n₂) →
            b₁ ≡ b₂ →
            Dec-Erased (n₁ ≡ n₂) →
            Dec-Erased ((b₁ ∷ n₁ ⟨ inv₁ ⟩′) ≡ (b₂ ∷ n₂ ⟨ inv₂ ⟩′))
          helper₂ n₁ n₂ _ _ _ (no [ n₁≢n₂ ]) = no [
            (b₁ ∷ n₁ ⟨ _ ⟩) ≡ (b₂ ∷ n₂ ⟨ _ ⟩)  ↝⟨ cong to-List ⟩
            b₁ ∷ to-List n₁ ≡ b₂ ∷ to-List n₂  ↝⟨ List.cancel-∷-tail ⟩
            to-List n₁ ≡ to-List n₂            ↝⟨ cong List-to-ℕ ⟩
            to-ℕ′ n₁ ≡ to-ℕ′ n₂                ↝⟨ _↔_.injective Bin′↔ℕ ⟩
            n₁ ≡ n₂                            ↝⟨ n₁≢n₂ ⟩□
            ⊥                                  □ ]

          helper₂ n₁ n₂ inv₁ inv₂ b₁≡b₂ (yes [ n₁≡n₂ ]) = yes [  $⟨ b₁≡b₂ , n₁≡n₂ ⟩
            b₁ ≡ b₂ × n₁ ≡ n₂                                    ↝⟨ Σ-map id (cong to-List) ⟩
            b₁ ≡ b₂ × to-List n₁ ≡ to-List n₂                    ↔⟨ inverse ∷≡∷↔≡×≡ ⟩
            b₁ ∷ to-List n₁ ≡ b₂ ∷ to-List n₂                    ↝⟨ cong List-to-ℕ ⟩
            to-ℕ′ (b₁ ∷ n₁ ⟨ inv₁ ⟩) ≡ to-ℕ′ (b₂ ∷ n₂ ⟨ inv₂ ⟩)  ↝⟨ _↔_.injective Bin′↔ℕ ⟩□
            b₁ ∷ n₁ ≡ b₂ ∷ n₂                                    □ ]

          helper₁ :
            ∀ n₁ n₂
              {@0 inv₁ : Invariant b₁ n₁} {@0 inv₂ : Invariant b₂ n₂} →
            Dec (b₁ ≡ b₂) →
            Dec-Erased ((b₁ ∷ n₁ ⟨ inv₁ ⟩′) ≡ (b₂ ∷ n₂ ⟨ inv₂ ⟩′))
          helper₁ n₁ n₂ (yes b₁≡b₂) =
            helper₂ _ _ _ _ b₁≡b₂ (equal? n₁ n₂)

          helper₁ n₁ n₂ (no b₁≢b₂) = no [
            b₁ ∷ n₁ ≡ b₂ ∷ n₂                  ↝⟨ cong to-List ⟩
            b₁ ∷ to-List n₁ ≡ b₂ ∷ to-List n₂  ↝⟨ List.cancel-∷-head ⟩
            b₁ ≡ b₂                            ↝⟨ b₁≢b₂ ⟩□
            ⊥                                  □ ]

      -- An equality test.

      infix 4 _≟_

      _≟_ : (m n : Bin′) → Dec (Erased (to-ℕ′ m ≡ to-ℕ′ n))
      m ≟ n =                             $⟨ equal? m n ⟩
        Dec-Erased (m ≡ n)                ↝⟨ Dec-Erased-map lemma ⟩
        Dec-Erased (to-ℕ′ m ≡ to-ℕ′ n)    ↝⟨ Dec-Erased↔Dec-Erased _ ⟩□
        Dec (Erased (to-ℕ′ m ≡ to-ℕ′ n))  □
        where
        lemma : m ≡ n ⇔ to-ℕ′ m ≡ to-ℕ′ n
        lemma = record { to = cong to-ℕ′; from = _↔_.injective Bin′↔ℕ }

      private

        -- A lemma used to prove that from-bits and to-bits are
        -- correct.

        to-ℕ′-foldr-∷ˢ-[] :
          ∀ bs →
          to-ℕ′ (foldr _∷ˢ_ []′ bs) ≡
          foldr (λ b n → from-Bool b ⊕ 2 ⊛ n) 0 bs
        to-ℕ′-foldr-∷ˢ-[] []       = refl _
        to-ℕ′-foldr-∷ˢ-[] (b ∷ bs) =
          to-ℕ′ (foldr _∷ˢ_ [] (b ∷ bs))                              ≡⟨⟩
          to-ℕ′ (b ∷ˢ foldr _∷ˢ_ [] bs)                               ≡⟨ to-ℕ′-∷ˢ b _ ⟩
          from-Bool b ⊕ 2 ⊛ to-ℕ′ (foldr _∷ˢ_ [] bs)                  ≡⟨ cong (λ n → from-Bool b ⊕ 2 ⊛ n) (to-ℕ′-foldr-∷ˢ-[] bs) ⟩
          from-Bool b ⊕ 2 ⊛ foldr (λ b n → from-Bool b ⊕ 2 ⊛ n) 0 bs  ≡⟨⟩
          foldr (λ b n → from-Bool b ⊕ 2 ⊛ n) 0 (b ∷ bs)              ∎

      -- Converts from lists of bits. (The most significant bit comes
      -- first.)

      from-bits : List Bool → Bin′
      from-bits = foldr _∷ˢ_ [] ∘ reverse

      to-ℕ′-from-bits :
        ∀ bs →
        to-ℕ′ (from-bits bs) ≡
        foldl (λ n b → (if b then 1 else 0) ⊕ 2 ⊛ n) 0 bs
      to-ℕ′-from-bits bs =
        to-ℕ′ (from-bits bs)                                ≡⟨⟩
        to-ℕ′ (foldr _∷ˢ_ [] (reverse bs))                  ≡⟨ to-ℕ′-foldr-∷ˢ-[] (reverse bs) ⟩
        foldr (λ b n → from-Bool b ⊕ 2 ⊛ n) 0 (reverse bs)  ≡⟨ foldr-reverse bs ⟩∎
        foldl (λ n b → from-Bool b ⊕ 2 ⊛ n) 0 bs            ∎

      -- Converts to lists of bits. (The most significant bit comes
      -- first.)

      to-bits : Bin′ → List Bool
      to-bits = reverse ∘ to-List

      to-ℕ′-from-bits-to-bits :
        ∀ n → to-ℕ′ (from-bits (to-bits n)) ≡ to-ℕ′ n
      to-ℕ′-from-bits-to-bits n =
        to-ℕ′ (foldr _∷ˢ_ [] (reverse (reverse (to-List n))))  ≡⟨ cong (to-ℕ′ ∘ foldr _∷ˢ_ []) (reverse-reverse (to-List n)) ⟩
        to-ℕ′ (foldr _∷ˢ_ [] (to-List n))                      ≡⟨ to-ℕ′-foldr-∷ˢ-[] (to-List n) ⟩
        foldr (λ b n → from-Bool b ⊕ 2 ⊛ n) 0 (to-List n)      ≡⟨⟩
        to-ℕ′ n                                                ∎

------------------------------------------------------------------------
-- Binary natural numbers

private

  module Bin-wrapper = Wrapper Bin′.Bin′ Bin′.Bin′↔ℕ
  open Bin-wrapper using (Operations)

-- Some definitions from Nat.Wrapper are reexported.

open Bin-wrapper public
  using (⌊_⌋; ⌈_⌉; ≡⌊⌋;
         nullary-[]; nullary; nullary-correct;
         unary-[]; unary; unary-correct;
         binary-[]; binary; binary-correct;
         n-ary-[]; n-ary; n-ary-correct)
  renaming
    ( Nat-[_] to Bin-[_]
    ; Nat to Bin
    ; Nat-[]↔Σℕ to Bin-[]↔Σℕ
    )

open Bin-wrapper.[]-cong ax public
  using (≡-for-indices↔≡)
  renaming
    ( Nat-[]-propositional to Bin-[]-propositional
    ; Nat↔ℕ to Bin↔ℕ
    )

private

  -- An implementation of some operations for Bin′.

  Operations-for-Bin′ : Operations
  Operations-for-Bin′ = λ where
    .Operations.zero                   → Bin′.zero′
    .Operations.to-ℕ-zero              → Bin′.to-ℕ′-zero′
    .Operations.suc                    → Bin′.suc′
    .Operations.to-ℕ-suc               → Bin′.to-ℕ′-suc′
    .Operations._+_                    → Bin′.add-with-carry
    .Operations.to-ℕ-+                 → Bin′.to-ℕ′-add-with-carry
    .Operations._*_                    → Bin′._*_
    .Operations.to-ℕ-*                 → Bin′.to-ℕ′-*
    .Operations._^_                    → Bin′._^_
    .Operations.to-ℕ-^                 → Bin′.to-ℕ′-^
    .Operations.⌊_/2⌋                  → Bin′.⌊_/2⌋
    .Operations.to-ℕ-⌊/2⌋              → Bin′.to-ℕ′-⌊/2⌋
    .Operations.⌈_/2⌉                  → Bin′.⌈_/2⌉
    .Operations.to-ℕ-⌈/2⌉              → Bin′.to-ℕ′-⌈/2⌉
    .Operations._*2^_                  → Bin′._*2^_
    .Operations.to-ℕ-*2^               → Bin′.to-ℕ′-*2^
    .Operations._≟_                    → Bin′._≟_
    .Operations.from-bits              → Bin′.from-bits
    .Operations.to-ℕ-from-bits         → Bin′.to-ℕ′-from-bits
    .Operations.to-bits                → Bin′.to-bits
    .Operations.to-ℕ-from-bits-to-bits → Bin′.to-ℕ′-from-bits-to-bits

-- Operations for Bin-[_].

module Operations-for-Bin-[] =
  Bin-wrapper.Operations-for-Nat-[] Operations-for-Bin′

-- Operations for Bin.

module Operations-for-Bin =
  Bin-wrapper.Operations-for-Nat Operations-for-Bin′

------------------------------------------------------------------------
-- Some examples

private

  module Bin-[]-examples where

    open Operations-for-Bin-[]

    -- Converts unary natural numbers to binary natural numbers.

    from-ℕ : ∀ n → Bin-[ n ]
    from-ℕ = proj₂ ∘ _↔_.from Bin↔ℕ

    -- Bin n is a proposition, so it is easy to prove that two values
    -- of this type are equal.

    example₁ : from-ℕ 4 + ⌊ from-ℕ 12 /2⌋ ≡ from-ℕ 10
    example₁ = Bin-[]-propositional _ _

    -- However, stating that two values of type Bin m and Bin n are
    -- equal, for equal natural numbers m and n, can be awkward.

    @0 example₂ :
      {@0 m n : ℕ}
      (b : Bin-[ m ]) (c : Bin-[ n ]) →
      subst (λ n → Bin-[ n ]) (N.+-comm m) (b + c) ≡ c + b
    example₂ _ _ = Bin-[]-propositional _ _

  module Bin-examples where

    open Operations-for-Bin

    -- If Bin is used instead of Bin-[_], then it can be easier to
    -- state that two values are equal.

    example₁ : ⌈ 4 ⌉ + ⌊ ⌈ 12 ⌉ /2⌋ ≡ ⌈ 10 ⌉
    example₁ = _↔_.to ≡-for-indices↔≡ [ refl _ ]

    example₂ : ∀ m n → m + n ≡ n + m
    example₂ m n = _↔_.to ≡-for-indices↔≡
      [ ⌊ m ⌋ ⊕ ⌊ n ⌋  ≡⟨ N.+-comm ⌊ m ⌋ ⟩∎
        ⌊ n ⌋ ⊕ ⌊ m ⌋  ∎
      ]

    -- One can construct a proof showing that ⌈ 5 ⌉ is either equal or
    -- not equal to ⌈ 2 ⌉ + ⌈ 3 ⌉, but the proof does not compute to
    -- "inj₁ something" at compile-time.

    example₃ : Dec (⌈ 5 ⌉ ≡ ⌈ 2 ⌉ + ⌈ 3 ⌉)
    example₃ =
      Dec-map (_↔_.logical-equivalence ≡-for-indices↔≡)
        (⌈ 5 ⌉ ≟ ⌈ 2 ⌉ + ⌈ 3 ⌉)


-- Andreas, 2017-10-04, issue #2765, reported by nad
-- Problem: inferred level expressions are often "reversed"

open import Agda.Primitive

postulate
  F : (ℓ : Level) → Set ℓ

G : (a b c : Level) → Set {!!}  -- C-c C-=
G a b c = F a → F b → F c

-- WAS:
-- ?0 := c ⊔ (b ⊔ a)

-- Expected: Inferred level should be
-- ?0 := a ⊔ (b ⊔ c)