module NaturalTransFacts where

open import Level
open import Categories.Support.Equivalence
open import Categories.Category
open import Categories.Functor
open import Categories.NaturalTransformation
  renaming (id to natId; _≡_ to _≡N_; setoid to natSetoid)
  hiding (_∘ˡ_; _∘ʳ_)
open import Categories.Support.EqReasoning

_⇒_ = NaturalTransformation

_∘ˡ_ : ∀ {o₀ ℓ₀ e₀ o₁ ℓ₁ e₁ o₂ ℓ₂ e₂}
     → {C : Category o₀ ℓ₀ e₀} {D : Category o₁ ℓ₁ e₁} {E : Category o₂ ℓ₂ e₂}
     → {F G : Functor C D}
     → (H : Functor D E) → (η : NaturalTransformation F G)
     → (H ∘ F) ⇒ (H ∘ G)
H ∘ˡ η = (natId {F = H}) ∘₀ η

_∘ʳ_ : ∀ {o₀ ℓ₀ e₀ o₁ ℓ₁ e₁ o₂ ℓ₂ e₂}
     → {C : Category o₀ ℓ₀ e₀} {D : Category o₁ ℓ₁ e₁} {E : Category o₂ ℓ₂ e₂}
     → {F G : Functor C D}
     → (η : NaturalTransformation F G) → (K : Functor E C)
     → (F ∘ K) ⇒ (G ∘ K)
η ∘ʳ K = η ∘₀ (natId {F = K})

.∘₁-resp-≡ˡ : ∀ {o ℓ e} {o′ ℓ′ e′}
               {D : Category o ℓ e} {E : Category o′ ℓ′ e′}
               {A B C : Functor D E}
               {f h : B ⇒ C} {g : A ⇒ B}
            → f ≡N h → f ∘₁ g ≡N h ∘₁ g
∘₁-resp-≡ˡ {f = f} {h} {g} f≡h
  = ∘₁-resp-≡ {f = f} {h} {g} {g} f≡h (Setoid.refl natSetoid {g})

.∘₁-resp-≡ʳ : ∀ {o ℓ e} {o′ ℓ′ e′}
               {D : Category o ℓ e} {E : Category o′ ℓ′ e′}
               {A B C : Functor D E}
               {f : B ⇒ C} {g i : A ⇒ B}
            → g ≡N i → f ∘₁ g ≡N f ∘₁ i
∘₁-resp-≡ʳ {f = f} {g} {i} g≡i
  = ∘₁-resp-≡ {f = f} {f} {g} {i}  (Setoid.refl natSetoid {f}) g≡i

.∘ʳ-distr-∘₁ : ∀ {o₀ ℓ₀ e₀ o₁ ℓ₁ e₁ o₂ ℓ₂ e₂}
             → {C : Category o₀ ℓ₀ e₀} {D : Category o₁ ℓ₁ e₁} {E : Category o₂ ℓ₂ e₂}
             → {F G H : Functor C D}
             → (β : G ⇒ H) → (α : F ⇒ G) → (K : Functor E C)
             → (β ∘₁ α) ∘ʳ K ≡N (β ∘ʳ K) ∘₁ (α ∘ʳ K)
∘ʳ-distr-∘₁ {F = F} {G} {H} β α K =
  begin
    (β ∘₁ α) ∘ʳ K
  ↓⟨ Setoid.refl natSetoid {(β ∘₁ α) ∘ʳ K} ⟩
    (β ∘₁ α) ∘₀ idK
  ↑⟨ ∘₀-resp-≡
     {f = (β ∘₁ α)} {(β ∘₁ α)} {idK ∘₁ idK} {idK}
     (Setoid.refl natSetoid {β ∘₁ α})
     (identity₁ʳ {X = idK})
   ⟩
    (β ∘₁ α) ∘₀ (idK ∘₁ idK)
  ↑⟨ interchange {α = β} {idK} {α} {idK} ⟩
    (β ∘₀ idK) ∘₁ (α ∘₀ idK)
  ↓⟨ ∘₁-resp-≡
     {f = β ∘₀ idK} {β ∘ʳ K} {α ∘₀ idK} {α ∘ʳ K}
     (Setoid.refl natSetoid {β ∘₀ idK})
     (Setoid.refl natSetoid {α ∘₀ idK})
   ⟩
    (β ∘ʳ K) ∘₁ (α ∘ʳ K)
  ∎
  where
    open SetoidReasoning (natSetoid {F = F ∘ K} {H ∘ K})
    idK = natId {F = K}

.∘ˡ-distr-∘₁ : ∀ {o₀ ℓ₀ e₀ o₁ ℓ₁ e₁ o₂ ℓ₂ e₂}
             → {C : Category o₀ ℓ₀ e₀} {D : Category o₁ ℓ₁ e₁} {E : Category o₂ ℓ₂ e₂}
             → {F G H : Functor C D}
             → (K : Functor D E)
             → (β : G ⇒ H) → (α : F ⇒ G)
             → K ∘ˡ (β ∘₁ α) ≡N (K ∘ˡ β) ∘₁ (K ∘ˡ α)
∘ˡ-distr-∘₁ {F = F} {G} {H} K β α =
  begin
    K ∘ˡ (β ∘₁ α)
  ↓⟨ Setoid.refl natSetoid {K ∘ˡ (β ∘₁ α)} ⟩
    idK ∘₀ (β ∘₁ α)
  ↑⟨ ∘₀-resp-≡
     {f = idK ∘₁ idK} {idK} {(β ∘₁ α)} {(β ∘₁ α)}
     (identity₁ʳ {X = idK})
     (Setoid.refl natSetoid {β ∘₁ α})
   ⟩
    (idK ∘₁ idK) ∘₀ (β ∘₁ α)
  ↑⟨ interchange {α = idK} {β} {idK} {α} ⟩
    (idK ∘₀ β) ∘₁ (idK ∘₀ α)
  ↓⟨ ∘₁-resp-≡
     {f = idK ∘₀ β} {K ∘ˡ β} {idK ∘₀ α} {K ∘ˡ α}
     (Setoid.refl natSetoid {idK ∘₀ β})
     (Setoid.refl natSetoid {idK ∘₀ α})
   ⟩
    (K ∘ˡ β) ∘₁ (K ∘ˡ α)
  ∎
  where
    open SetoidReasoning (natSetoid {F = K ∘ F} {K ∘ H})
    idK = natId {F = K}

.identityNatˡ : ∀ {o₀ ℓ₀ e₀ o₁ ℓ₁ e₁ o₂ ℓ₂ e₂}
              → {C : Category o₀ ℓ₀ e₀} {D : Category o₁ ℓ₁ e₁} {E : Category o₂ ℓ₂ e₂}
              → {F : Functor C D}
              → (H : Functor D E)
              → H ∘ˡ natId {F = F} ≡N natId
identityNatˡ H = identity₀ʳ {X = natId {F = H}}

.identityNatʳ : ∀ {o₀ ℓ₀ e₀ o₁ ℓ₁ e₁ o₂ ℓ₂ e₂}
             → {C : Category o₀ ℓ₀ e₀} {D : Category o₁ ℓ₁ e₁} {E : Category o₂ ℓ₂ e₂}
             → {F : Functor C D}
             → (K : Functor E C)
             → natId {F = F} ∘ʳ K ≡N natId
identityNatʳ {F = F} K = identity₀ʳ {X = natId {F = F}}


module README where

----------------------------------------------------------------------
-- The Agda smallib library, version 0.1
----------------------------------------------------------------------
--
-- This library implements a type theory which is described in the
-- Appendix of the HoTT book. It also contains some properties derived
-- from the rules of this theory.
----------------------------------------------------------------------
--
-- This project is meant to be a practice for the author but as a
-- secondary goal it would be nice to create a small library which is
-- less intimidating than the standard one.
--
-- This version was tested using Agda 2.6.1.
----------------------------------------------------------------------

----------------------------------------------------------------------
-- High-level overview of contents
----------------------------------------------------------------------
--
-- The top-level module L is not implemented (yet), it's sole purpose
-- is to prepend all of the module names with something to avoid
-- possible name clashes with the standard library.
--
-- The structure of the library is the following:
--
-- • Base
--    The derivation rules of the implemented type theory and some
--    useful properties which can be derived from these. To make a
--    clear distinction between these every type has a Core and a
--    Properties submodule. In some cases the latter might be empty.
--
-- • Data
--  ◦ Bool
--     A specialized form of the Coproduct type. It implements if as
--     an elimination rule. The following operations are defined on
--     them: not, ∧, ∨, xor.
----------------------------------------------------------------------

----------------------------------------------------------------------
-- Some useful modules
----------------------------------------------------------------------
--
-- • To use several things at once
import L.Base      -- Type theory with it's properties.
import L.Base.Core -- Derivation rules.
--
-- • To use only one base type
import L.Base.Sigma     -- Products (universe polymorphic).
import L.Base.Coproduct -- Disjoint sums (universe polymorphic).
import L.Base.Empty     -- Empty type.
import L.Base.Unit      -- Unit type.
import L.Base.Nat       -- Natural numbers.
import L.Base.Id        -- Propositional equality (universe poly.).
--
-- • To use the properties of the above
import L.Base.Sigma.Properties
import L.Base.Coproduct.Properties
import L.Base.Empty.Properties
import L.Base.Unit.Properties
import L.Base.Nat.Properties
import L.Base.Id.Properties
--
-- • Some datatypes
import L.Data.Bool -- Booleans.
----------------------------------------------------------------------

----------------------------------------------------------------------
-- Notes
----------------------------------------------------------------------
--
-- • L.Base exports L.Coproduct.Core._+_ as _⊎_ to avoid multiple
--   definitions of _+_, as L.Base.Nat declares it as well.
----------------------------------------------------------------------


module Prelude.List where

open import Prelude.List.Base public


-- 2014-03-05 Andreas, issue reported by James

-- {-# OPTIONS -v tc.with.strip:60 -v:impossible:10 #-}

data Nat : Set where
  zero : Nat

pattern pzero = zero

f : Nat → Nat
f pzero with pzero
f pzero | pzero = pzero

-- ERROR WAS:
-- With clause pattern pzero is not an instance of its parent pattern
-- when checking that the clause
-- f pzero with pzero
-- f pzero | pzero = pzero
-- has type Nat → Nat


------------------------------------------------------------------------------
-- A simple network using the Agda standard library
------------------------------------------------------------------------------

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

-- From (Sander, 1992, pp. 68-69).

module FOT.FOTC.Program.ABP.SimpleNetwork-SL where

open import Codata.Musical.Stream
open import Data.Bool.Base

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

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

{-# TERMINATING #-}
trans : {A : Set} → Stream A → Stream A
trans {A} is = os
  where
  ys os : Stream A
  ys = f₁ os is
  os = f₂ ys

Ty : Set → Set
Ty A = (Stream A → Stream A → Stream A) → (Stream A → Stream A) →
       Stream A → Stream A

{-# TERMINATING #-}
trans' hys : {A : Set} → Ty A
trans' f₁ f₂ is = f₂ (hys f₁ f₂ is)
hys   f₁ f₂ is = f₁ (trans' f₁ f₂ is) is

------------------------------------------------------------------------------
-- References
--
-- Sander, Herbert P. (1992). A Logic of Functional Programs with an
-- Application to Concurrency. PhD thesis. Department of Computer
-- Sciences: Chalmers University of Technology and University of
-- Gothenburg.


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

module Fusion where

open import Data.Product renaming  (proj₁ to ₁; proj₂ to ₂) hiding (map; zip)
open import Relation.Binary.PropositionalEquality
open import Data.Sum hiding (map)
open import Data.Bool
open import Data.Nat
open import Data.Unit
open import Data.Empty
open import Function
open import Data.Maybe hiding (map; zip; zipWith)
open import Data.List hiding (map; zip; _++_; filter; foldr; foldl; zipWith; drop; take)

module Stream1 where

  data Step (S A : Set) : Set where
    stop  : Step S A
    yield : A → S → Step S A
    skip  : S → Step S A

  mapStep : ∀ {A A' S S'} → (A → A') → (S → S') → Step S A → Step S' A'
  mapStep f g stop        = stop
  mapStep f g (yield a s) = yield (f a) (g s)
  mapStep f g (skip s)    = skip (g s)

  record Stream (A : Set) : Set where
    constructor stream
    field
      S    : Set
      seed : S
      step : S → Step S A
  open Stream public

  infixr 4 _++_
  _++_ : ∀ {A} → Stream A → Stream A → Stream A
  S    (xs ++ ys)           = S xs ⊎ S ys
  seed (xs ++ ys)           = inj₁ (seed xs)
  step (xs ++ ys) (inj₁ s ) with step xs s
  ... | stop       = skip (inj₂ (seed ys))
  ... | yield a s' = yield a (inj₁ s')
  ... | skip s'    = skip (inj₁ s')
  step (xs ++ ys) (inj₂ s) = mapStep id inj₂ (step ys s)

  filter : ∀ {A} → (A → Bool) → Stream A → Stream A
  S    (filter f as) = S as
  seed (filter f as) = seed as
  step (filter f as) s with step as s
  ... | stop       = stop
  ... | yield a s' = if f a then yield a s' else skip s'
  ... | skip s'    = skip s'

  map : ∀ {A B} → (A → B) → Stream A → Stream B
  S    (map f as) = S as
  seed (map f as) = seed as
  step (map f as) = mapStep f id ∘ step as

  empty : ∀ {A} → Stream A
  S    empty = ⊤
  seed empty = tt
  step empty = λ _ → stop

  pure : ∀ {A} → A → Stream A
  S    (pure a)       = Bool
  seed (pure a)       = true
  step (pure a) false = stop
  step (pure a) true  = yield a false

  bind : ∀ {A B} → Stream A → (A → Stream B) → Stream B
  S    (bind as f) = S as ⊎ (S as × ∃ (S ∘ f))
  seed (bind as f) = inj₁ (seed as)
  step (bind as f) (inj₁ s) with step as s
  ... | stop       = stop
  ... | yield a s' = skip (inj₂ (s' , a , seed (f a)))
  ... | skip s'    = skip (inj₁ s')
  step (bind as f) (inj₂ (s , a , s')) with step (f a) s'
  ... | stop        = skip (inj₁ s)
  ... | yield b s'' = yield b (inj₂ (s , a , s''))
  ... | skip s''    = skip (inj₂ (s , a , s''))

  zip : ∀ {A B} → Stream A → Stream B → Stream (A × B)
  S    (zip {A} as bs)                     = S as × S bs × Maybe A
  seed (zip {A} as bs)                     = seed as , seed bs , nothing
  step (zip {A} as bs) (sa , sb , nothing) with step as sa
  ... | stop        = stop
  ... | yield a sa' = skip (sa' , sb , just a)
  ... | skip sa'    = skip (sa' , sb , nothing)
  step (zip {A} as bs) (sa , sb , just a) with step bs sb
  ... | stop        = stop
  ... | yield b sb' = yield (a , b) (sa , sb' , nothing)
  ... | skip sb'    = skip (sa , sb' , just a)

  {-# NON_TERMINATING #-}
  foldr : ∀ {A B : Set} → (A → B → B) → B → Stream A → B
  foldr f b (stream S s step) with step s
  ... | stop       = b
  ... | yield a s' = f a (foldr f b (stream S s' step))
  ... | skip s'    = foldr f b (stream S s' step)

  {-# NON_TERMINATING #-}
  foldl : ∀ {A B : Set} → (B → A → B) → B → Stream A → B
  foldl f b (stream S s step) with step s
  ... | stop       = b
  ... | yield a s' = foldl f (f b a) (stream S s' step)
  ... | skip s'    = foldl f b (stream S s' step)

module Stream2 where

  data Step (S A : Set) : Set where
    stop  : Step S A
    yield : A → S → Step S A
    skip  : S → Step S A

  mapStep : ∀ {A A' S S'} → (A → A') → (S → S') → Step S A → Step S' A'
  mapStep f g stop        = stop
  mapStep f g (yield a s) = yield (f a) (g s)
  mapStep f g (skip s)    = skip (g s)

  record Prod (A : Set) : Set where
    constructor stream
    field
      S    : Set
      seed : S
      step : S → Step S A
  open Prod public

  infixr 4 _++_
  data Stream (A : Set) : Set where
    prod    : Prod A → Stream A
    _++_    : Stream A → Stream A → Stream A
    bind    : ∀ {B} → Stream B → (B → Stream A) → Stream A
    zipWith : ∀ {B C} → (B → C → A) → Stream B → Stream C → Stream A

  filter : ∀ {A} → (A → Bool) → Stream A → Stream A
  filter f (prod x) = {!!}
  filter f (str ++ str₁) = filter f str ++ filter f str₁
  filter f (bind str g) = bind str λ b → filter f (g b)
  filter f (zipWith x str str₁) = {!!} -- issue

  map : ∀ {A B} → (A → B) → Stream A → Stream B
  map f (prod as) = {!!}
  map f (as ++ as') = map f as ++ map f as'
  map f (bind bs g) = bind bs λ b → map f (g b)
      -- no bind fusion! (i.e. monad laws)
  map f (zipWith g bc cs) = {!!} -- can convert to prod, but better to freely add map...
                                 -- but then we don't have map fusion unless we just add it
                                 -- perhaps first-order syntax is OK, if we hand-write
                                 -- enough fusion?

  {-# NON_TERMINATING #-}
  foldr : ∀ {A B : Set} → (A → B → B) → B → Stream A → B
  foldr f b (prod x) = {!!}
  foldr f b (as ++ as') = foldr f (foldr f b as') as
  foldr {A} {B} f b (bind {C} cs g) = foldr (λ c b → foldr f b (g c)) b cs
  foldr {A} {B} f b (zipWith {C} {D} g cs ds) = {!!}
    -- first I have to convert cs/ds to producers to fold them!
    -- this means that optimization from first-order rep is blocked at the first zip!
    -- general solution: robust producer-to-state-machine compilation

module Stream3 where

  Step : Set → Set → Set
  Step S A = (Step : Set) → Step → (A → S → Step) → Step

  record Pull (A : Set) : Set where
    constructor pull
    field
      S    : Set
      seed : S
      step : S → Step S A
  open Pull public

  zip : ∀ {A B} → Pull A → Pull B → Pull (A × B)
  S    (zip as bs) = S as × S bs
  seed (zip as bs) = seed as , seed bs
  step (zip as bs) (sa , sb) _ stop yield =
    step as sa _
      stop
      λ a sa' → step bs sb _
        stop
        λ b sb' → yield (a , b) (sa , sb')

  map : ∀ {A B} → (A → B) → Pull A → Pull B
  S    (map f as) = S as
  seed (map f as) = seed as
  step (map f as) s _ stop yield = step as s _
    stop
    λ a s → yield (f a) s

  {-# NON_TERMINATING #-}
  find : ∀ {A S} → (A → Bool) → (S → Step S A) → S → Step S A
  find f step s _ stop yield = step s _
    stop
    λ a s → if f a then yield a s
                   else find f step s _ stop yield

  -- fusing filter without Skip!

  -- we can inline continuations in tail-recursive functions, and skipping to the next
  -- yield is such a loop
  filter : ∀ {A} → (A → Bool) → Pull A → Pull A
  S    (filter f as) = S as
  seed (filter f as) = seed as
  step (filter f as) = find f (step as)

  {-# NON_TERMINATING #-}
  drop' : ∀ {A S} → ℕ → (S → Step S A) → S → S
  drop' zero    step s = s
  drop' (suc n) step s = step s _ s λ a s → drop' n step s

  drop : ∀ {A} → ℕ → Pull A → Pull A
  S    (drop n as) = S as
  seed (drop n as) = drop' n (step as) (seed as)
  step (drop n as) = step as

  take : ∀ {A} → ℕ → Pull A → Pull A
  S    (take n as) = S as × ℕ
  seed (take n as) = seed as , n
  step (take n as) (s , zero)  _ stop yield = stop
  step (take n as) (s , suc x) _ stop yield = step as s _ stop λ a s → yield a (s , x)

  infixr 4 _++_
  _++_ : ∀ {A} → Pull A → Pull A → Pull A
  S    (xs ++ ys) = S xs ⊎ S ys
  seed (xs ++ ys) = inj₁ (seed xs)
  step (xs ++ ys) (inj₁ s) _ stop yield =
    step xs s _
      (step ys (seed ys) _
        stop
        λ a s → yield a (inj₂ s))
      λ a s → yield a (inj₁ s)
  step (xs ++ ys) (inj₂ s) _ stop yield =
    step ys s _
      stop
      λ a s → yield a (inj₂ s)

  {-# NON_TERMINATING #-}
  bind' : ∀ {A B : Set} (as : Pull A) (f : A → Pull B)
          → S as × Maybe (∃ (S ∘ f)) → Step (S as × Maybe (∃ (S ∘ f))) B
  bind' as f (sa , nothing)       _ stop yield =
    step as sa _
      stop
      λ a sa → step (f a) (seed (f a)) _
        (bind' as f (sa , nothing) _ stop yield)
        λ b sb → yield b (sa , (just (a , sb)))
  bind' as f (sa , just (a , sb)) _ stop yield =
    step (f a) sb _
      (bind' as f (sa , nothing) _ stop yield)
      λ b sb → yield b (sa , just (a , sb))

  {-# NON_TERMINATING #-}
  bindNothing' : ∀ {A B : Set} (as : Pull A) (f : A → Pull B)
          → S as → Step (S as × Maybe (∃ (S ∘ f))) B
  bindJust' : ∀ {A B : Set} (as : Pull A) (f : A → Pull B)
          → S as × ∃ (S ∘ f) → Step (S as × Maybe (∃ (S ∘ f))) B
  bindNothing' as f sa _ stop yield =
    step as sa _
      stop
      λ a sa → bindJust' as f (sa , a , seed (f a)) _ stop yield
  bindJust' as f (sa , a , sb) _ stop yield =
    step (f a) sb _
      (bindNothing' as f sa _ stop yield)
      λ b sb → yield b (sa , just (a , sb))

  bind : ∀ {A B} → Pull A → (A → Pull B) → Pull B
  S    (bind as f) = S as × Maybe (∃ (S ∘ f))
  seed (bind as f) = seed as , nothing
  step (bind as f) (sa , nothing) _ stop yield = bindNothing' as f sa _ stop yield
  step (bind as f) (sa , just x)  _ stop yield = bindJust' as f (sa , x) _ stop yield


(1 ∷ 4 ∷ []) ∷ (2 ∷ 5 ∷ []) ∷ (3 ∷ 6 ∷ []) ∷ []


module Example where

data Nat : Set where
  zero : Nat
  suc  : Nat -> Nat

postulate
  case-Nat : (P : Nat -> Set) -> P zero ->
	     ((n:Nat) -> P (suc n)) ->
	     (n : Nat) -> P n

-- test : Nat -> Nat
test = case-Nat _ zero (\n -> n)

{-
data Size : Set where
  empty	   : Size
  nonempty : Size
  whatever : Size

data Nat : Set where
  zero : Nat
  suc  : Nat -> Nat

data List (A:Set) : Set where
  nil  : List A
  (::) : A -> List A -> List A

data Monad (M:Set -> Set) : Set1 where
  monad : Monad M

postulate
  build : {M:Set -> Set} -> Monad M -> {C:Size -> Set} -> (A:Set) ->
	  (A -> C nonempty) ->
	  ((n:Size) -> List (C n) -> M (List A)) ->
	  List A -> M (C whatever)

test : (A:Set) -> Nat
test A = build monad A (\x -> x) (\n xs -> xs) nil
-}


------------------------------------------------------------------------
-- The Agda standard library
--
-- Finite sets, based on AVL trees
------------------------------------------------------------------------

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

open import Relation.Binary using (StrictTotalOrder)

module Data.AVL.Sets
  {a ℓ₁ ℓ₂} (strictTotalOrder : StrictTotalOrder a ℓ₁ ℓ₂)
  where

open import Data.Bool
open import Data.List.Base as List using (List)
open import Data.Maybe.Base as Maybe
open import Data.Product as Prod using (_×_; _,_; proj₁)
open import Data.Unit
open import Function
open import Level

import Data.AVL strictTotalOrder as AVL
open StrictTotalOrder strictTotalOrder renaming (Carrier to A)

------------------------------------------------------------------------
-- The set type (note that Set is a reserved word)

⟨Set⟩ : Set (a ⊔ ℓ₂)
⟨Set⟩ = AVL.Tree (AVL.const ⊤)

------------------------------------------------------------------------
-- Repackaged functions

empty : ⟨Set⟩
empty = AVL.empty

singleton : A → ⟨Set⟩
singleton k = AVL.singleton k _

insert : A → ⟨Set⟩ → ⟨Set⟩
insert k = AVL.insert k _

delete : A → ⟨Set⟩ → ⟨Set⟩
delete = AVL.delete

infix 4 _∈?_

_∈?_ : A → ⟨Set⟩ → Bool
_∈?_ = AVL._∈?_

headTail : ⟨Set⟩ → Maybe (A × ⟨Set⟩)
headTail s = Maybe.map (Prod.map₁ proj₁) (AVL.headTail s)

initLast : ⟨Set⟩ → Maybe (⟨Set⟩ × A)
initLast s = Maybe.map (Prod.map₂ proj₁) (AVL.initLast s)

fromList : List A → ⟨Set⟩
fromList = AVL.fromList ∘ List.map (_, _)

toList : ⟨Set⟩ → List A
toList = List.map proj₁ ∘ AVL.toList


open import FRP.JS.Bool using ( Bool )
open import FRP.JS.True using ( ⊤ ; tt )
open import FRP.JS.String using ( String )
open import FRP.JS.True using ( True )
open import FRP.JS.RSet
open import FRP.JS.Behaviour

module FRP.JS.QUnit where

infixr 4 _,_

data Test : Set where
  ε : Test
  _,_ : Test → Test → Test
  ok : String → (b : {t : ⊤} → Bool) → {b✓ : True b} → Test
  ok! : String → (b : {t : ⊤} → Bool) → Test
  ok◇ : String → (b : ⟦ Beh ⟨ Bool ⟩ ⟧) → Test

data TestSuite : Set where
  ε : TestSuite
  _,_ : TestSuite → TestSuite → TestSuite
  test : String → Test → TestSuite

data TestSuites : Set where
  ε : TestSuites
  _,_ : TestSuites → TestSuites → TestSuites
  suite : String → TestSuite → TestSuites


module SyntaxForOperators where

postulate _+_ : Set → Set → Set

syntax _+_ A B = A ⊎ B


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

open import lib.Basics
open import lib.NType2

-- [Subtype] is defined in lib.NType.

module lib.types.Subtype where

infix 40 _⊆_
_⊆_ : ∀ {i j₁ j₂} {A : Type i} → SubtypeProp A j₁ → SubtypeProp A j₂
  → Type (lmax i (lmax j₁ j₂))
P₁ ⊆ P₂ = ∀ a → SubtypeProp.prop P₁ a → SubtypeProp.prop P₂ a

infix 80 _∘sub_
_∘sub_ : ∀ {i j k} {A : Type i} {B : Type j}
  → SubtypeProp B k → (A → B) → SubtypeProp A k
P ∘sub f = SubtypeProp.prop P ∘ f , level where
  abstract level = SubtypeProp.level P ∘ f

Subtype-has-dec-eq : ∀ {i j} {A : Type i} (subProp : SubtypeProp A j)
  → has-dec-eq A → has-dec-eq (Subtype subProp)
Subtype-has-dec-eq subProp dec s₁ s₂ with dec (fst s₁) (fst s₂)
... | inl s₁=s₂ = inl (Subtype=-out subProp s₁=s₂)
... | inr s₁≠s₂ = inr λ s₁=s₂ → s₁≠s₂ (ap fst s₁=s₂)

{- Dependent paths in a Σ-type -}
module _ {i j k} {A : Type i} {B : A → Type j} (subB : (a : A) → SubtypeProp (B a) k)
  where

  ↓-Subtype-in : {x x' : A} {p : x == x'} {r : B x} {r' : B x'}
    {s : SubtypeProp.prop (subB x) r} {s' : SubtypeProp.prop (subB x') r'}
    (q : r == r' [ B ↓ p ])
    → (r , s) == (r' , s') [ (λ x → Subtype (subB x)) ↓ p ]
  ↓-Subtype-in {p = idp} q = Subtype=-out (subB _) q


------------------------------------------------------------------------------
-- Discussion about the inductive approach
------------------------------------------------------------------------------

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

-- Peter: If you take away the proof objects (as you do when you go to
-- predicate logic) the K axiom doesn't give you any extra power.

module FOT.FOTC.InductiveApproach.ProofTerm where

open import FOTC.Base

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

foo : (∃ λ x → ∃ λ y → x ≡ y) → (∃ λ x → ∃ λ y → y ≡ x)
foo (x , .x , refl) = x , x , refl


-- Andreas, 2015-12-29

record ⊤ : Set where

data P : ⊤ → Set where
  c : P record{}

test : (x : ⊤) (p : P x) → Set
test _ c with ⊤
test _ y | z = ⊤

-- Expected error: with-clause pattern mismatch.
-- The error should be printed nicely, like:
--
-- With clause pattern x is not an instance of its parent pattern
-- record {}
-- when checking that the clause
-- test c with Set
-- test x y | z = ⊤
-- has type (x : ⊤) → P x → Set


module Examples.Type where

open import Agda.Builtin.Equality using (_≡_; refl)
open import FFI.Data.String using (_++_)
open import Luau.Type using (nil; _∪_; _∩_; _⇒_)
open import Luau.Type.ToString using (typeToString)

ex1 : typeToString(nil) ≡ "nil"
ex1 = refl

ex2 : typeToString(nil ⇒ nil) ≡ "(nil) -> nil"
ex2 = refl

ex3 : typeToString(nil ⇒ (nil ⇒ nil)) ≡ "(nil) -> (nil) -> nil"
ex3 = refl

ex4 : typeToString(nil ∪ (nil ⇒ (nil ⇒ nil))) ≡ "((nil) -> (nil) -> nil)?"
ex4 = refl

ex5 : typeToString(nil ⇒ ((nil ⇒ nil) ∪ nil)) ≡ "(nil) -> ((nil) -> nil)?"
ex5 = refl

ex6 : typeToString((nil ⇒ nil) ∪ (nil ⇒ (nil ⇒ nil))) ≡ "((nil) -> nil | (nil) -> (nil) -> nil)"
ex6 = refl

ex7 : typeToString((nil ⇒ nil) ∪ ((nil ⇒ (nil ⇒ nil)) ∪ nil)) ≡ "((nil) -> nil | (nil) -> (nil) -> nil)?"
ex7 = refl


{-# OPTIONS --prop --rewriting #-}

open import Examples.Sorting.Parallel.Comparable

module Examples.Sorting.Parallel.MergeSortPar.Merge (M : Comparable) where

open Comparable M
open import Examples.Sorting.Parallel.Core M

open import Calf costMonoid
open import Calf.ParMetalanguage parCostMonoid
open import Calf.Types.Bool
open import Calf.Types.Nat
open import Calf.Types.List
open import Calf.Types.Eq
open import Calf.Types.Bounded costMonoid

open import Relation.Nullary
open import Relation.Nullary.Negation
open import Relation.Binary.PropositionalEquality as Eq using (_≡_; refl; module ≡-Reasoning)
open import Data.Product using (_×_; _,_; ∃; proj₁; proj₂)
open import Data.Sum using (inj₁; inj₂)
open import Data.Nat as Nat using (ℕ; zero; suc; z≤n; s≤s; _+_; _*_; ⌊_/2⌋; ⌈_/2⌉; pred; _⊔_)
open import Data.Nat.Properties as N using (module ≤-Reasoning)
open import Data.Nat.Log2
open import Data.Nat.PredExp2

open import Examples.Sorting.Parallel.MergeSort.Split M

triple = Σ++ (list A) λ _ → Σ++ A λ _ → (list A)

splitMid/clocked : cmp (Π nat λ k → Π (list A) λ l → Π (U (meta (k Nat.< length l))) λ _ → F triple)
splitMid/clocked zero    (x ∷ xs) (s≤s h) = ret ([] , x , xs)
splitMid/clocked (suc k) (x ∷ xs) (s≤s h) =
  bind (F triple) (splitMid/clocked k xs h) λ (l₁ , mid , l₂) → ret ((x ∷ l₁) , mid , l₂)

splitMid/clocked/correct : ∀ k k' l h → k + suc k' ≡ length l →
  ◯ (∃ λ l₁ → ∃ λ mid → ∃ λ l₂ → splitMid/clocked k l h ≡ ret (l₁ , mid , l₂) × length l₁ ≡ k × length l₂ ≡ k' × l ≡ (l₁ ++ [ mid ] ++ l₂))
splitMid/clocked/correct zero    k' (x ∷ xs) (s≤s h) refl     u = [] , x , xs , refl , refl , refl , refl
splitMid/clocked/correct (suc k) k' (x ∷ xs) (s≤s h) h-length u =
  let (l₁ , mid , l₂ , ≡ , h₁ , h₂ , ≡-↭) = splitMid/clocked/correct k k' xs h (N.suc-injective h-length) u in
  x ∷ l₁ , mid , l₂ , Eq.cong (λ e → bind (F triple) e _) ≡ , Eq.cong suc h₁ , h₂ , Eq.cong (x ∷_) ≡-↭

splitMid/clocked/cost : cmp (Π nat λ k → Π (list A) λ l → Π (U (meta (k Nat.< length l))) λ _ → cost)
splitMid/clocked/cost _ _ _ = 𝟘

splitMid/clocked≤splitMid/clocked/cost : ∀ k l h → IsBounded triple (splitMid/clocked k l h) (splitMid/clocked/cost k l h)
splitMid/clocked≤splitMid/clocked/cost zero    (x ∷ xs) (s≤s h) = bound/ret
splitMid/clocked≤splitMid/clocked/cost (suc k) (x ∷ xs) (s≤s h) =
  bound/bind/const 𝟘 𝟘 (splitMid/clocked≤splitMid/clocked/cost k xs h) λ _ → bound/ret

splitMid : cmp (Π (list A) λ l → Π (U (meta (0 Nat.< length l))) λ _ → F triple)
splitMid (x ∷ xs) (s≤s h) = splitMid/clocked ⌊ length (x ∷ xs) /2⌋ (x ∷ xs) (N.⌊n/2⌋<n _)

splitMid/correct : ∀ l h →
  ◯ (∃ λ l₁ → ∃ λ mid → ∃ λ l₂ → splitMid l h ≡ ret (l₁ , mid , l₂) × length l₁ Nat.≤ ⌊ length l /2⌋ × length l₂ Nat.≤ ⌊ length l /2⌋ × l ≡ (l₁ ++ [ mid ] ++ l₂))
splitMid/correct (x ∷ xs) (s≤s h) u =
  let (l₁ , mid , l₂ , ≡ , h₁ , h₂ , ≡-↭) = splitMid/clocked/correct ⌊ length (x ∷ xs) /2⌋ ⌊ pred (length (x ∷ xs)) /2⌋ (x ∷ xs) (N.⌊n/2⌋<n _)
                                              (let open ≡-Reasoning in
                                              begin
                                                ⌊ length (x ∷ xs) /2⌋ + suc ⌊ pred (length (x ∷ xs)) /2⌋
                                              ≡⟨⟩
                                                ⌊ length (x ∷ xs) /2⌋ + suc ⌊ length xs /2⌋
                                              ≡⟨⟩
                                                ⌈ length xs /2⌉ + suc ⌊ length xs /2⌋
                                              ≡⟨ N.+-suc ⌈ length xs /2⌉ ⌊ length xs /2⌋ ⟩
                                                suc (⌈ length xs /2⌉ + ⌊ length xs /2⌋)
                                              ≡⟨ Eq.cong suc (N.+-comm ⌈ length xs /2⌉ ⌊ length xs /2⌋) ⟩
                                                suc (⌊ length xs /2⌋ + ⌈ length xs /2⌉)
                                              ≡⟨ Eq.cong suc (N.⌊n/2⌋+⌈n/2⌉≡n (length xs)) ⟩
                                                suc (length xs)
                                              ≡⟨⟩
                                                length (x ∷ xs)
                                              ∎) u in
  l₁ , mid , l₂ , ≡ , N.≤-reflexive h₁ , (
    let open ≤-Reasoning in
    begin
      length l₂
    ≡⟨ h₂ ⟩
      ⌊ pred (length (x ∷ xs)) /2⌋
    ≤⟨ N.⌊n/2⌋-mono N.pred[n]≤n ⟩
      ⌊ length (x ∷ xs) /2⌋
    ∎
  ), ≡-↭

splitMid/cost : cmp (Π (list A) λ l → Π (U (meta (0 Nat.< length l))) λ _ → cost)
splitMid/cost (x ∷ xs) (s≤s h) = splitMid/clocked/cost ⌊ length (x ∷ xs) /2⌋ (x ∷ xs) (N.⌊n/2⌋<n _)

splitMid≤splitMid/cost : ∀ l h → IsBounded triple (splitMid l h) (splitMid/cost l h)
splitMid≤splitMid/cost (x ∷ xs) (s≤s h) = splitMid/clocked≤splitMid/clocked/cost ⌊ length (x ∷ xs) /2⌋ (x ∷ xs) (N.⌊n/2⌋<n _)

splitBy/clocked : cmp (Π nat λ _ → Π (list A) λ _ → Π A λ _ → F pair)
splitBy/clocked/aux : cmp (Π nat λ _ → Π A λ _ → Π (list A) λ _ → Π A λ _ → Π (list A) λ _ → Π bool λ _ → F pair)

splitBy/clocked zero    l        pivot = ret ([] , l)
splitBy/clocked (suc k) []       pivot = ret ([] , [])
splitBy/clocked (suc k) (x ∷ xs) pivot =
  bind (F pair) (splitMid (x ∷ xs) (s≤s z≤n)) λ (l₁ , mid , l₂) →
    bind (F pair) (mid ≤ᵇ pivot) (splitBy/clocked/aux k pivot l₁ mid l₂)

splitBy/clocked/aux k pivot l₁ mid l₂ false =
  bind (F pair) (splitBy/clocked k l₁ pivot) λ (l₁₁ , l₁₂) → ret (l₁₁ , l₁₂ ++ mid ∷ l₂)
splitBy/clocked/aux k pivot l₁ mid l₂ true  =
  bind (F pair) (splitBy/clocked k l₂ pivot) λ (l₂₁ , l₂₂) → ret (l₁ ++ mid ∷ l₂₁ , l₂₂)

splitBy/clocked/correct : ∀ k l pivot → ⌈log₂ suc (length l) ⌉ Nat.≤ k →
  ◯ (∃ λ l₁ → ∃ λ l₂ → splitBy/clocked k l pivot ≡ ret (l₁ , l₂) × (Sorted l → All (_≤ pivot) l₁ × All (pivot ≤_) l₂) × l ≡ (l₁ ++ l₂))
splitBy/clocked/correct zero    l        pivot h u with ⌈log₂n⌉≡0⇒n≤1 {suc (length l)} (N.n≤0⇒n≡0 h)
splitBy/clocked/correct zero    []       pivot h u | s≤s z≤n = [] , [] , refl , (λ _ → [] , []) , refl
splitBy/clocked/correct (suc k) []       pivot h u = [] , [] , refl , (λ _ → [] , []) , refl
splitBy/clocked/correct (suc k) (x ∷ xs) pivot (s≤s h) u with splitMid/correct (x ∷ xs) (s≤s z≤n) u
splitBy/clocked/correct (suc k) (x ∷ xs) pivot (s≤s h) u | (l₁ , mid , l₂ , ≡ , h₁ , h₂ , ≡-↭) with h-cost mid pivot
splitBy/clocked/correct (suc k) (x ∷ xs) pivot (s≤s h) u | (l₁ , mid , l₂ , ≡ , h₁ , h₂ , ≡-↭) | ⇓ b withCost q [ _ , h-eq ]
  with ≤ᵇ-reflects-≤ u (Eq.trans (eq/ref h-eq) (step/ext (F bool) (ret b) q u)) | ≤-total mid pivot
splitBy/clocked/correct (suc k) (x ∷ xs) pivot (s≤s h) u | (l₁ , mid , l₂ , ≡ , h₁ , h₂ , ≡-↭) | ⇓ b     withCost q [ _ , h-eq ] | ofⁿ ¬p | inj₁ mid≤pivot = contradiction mid≤pivot ¬p
splitBy/clocked/correct (suc k) (x ∷ xs) pivot (s≤s h) u | (l₁ , mid , l₂ , ≡ , h₁ , h₂ , ≡-↭) | ⇓ false withCost q [ _ , h-eq ] | ofⁿ ¬p | inj₂ pivot≤mid =
  let (l₁₁ , l₁₂ , ≡' , h-sorted , ≡-↭') = splitBy/clocked/correct k l₁ pivot (
                                              let open ≤-Reasoning in
                                              begin
                                                ⌈log₂ suc (length l₁) ⌉
                                              ≤⟨ log₂-mono (s≤s h₁) ⟩
                                                ⌈log₂ suc ⌊ length (x ∷ xs) /2⌋ ⌉
                                              ≤⟨ h ⟩
                                                k
                                              ∎
                                            ) u in
  l₁₁ , l₁₂ ++ mid ∷ l₂ , (
    let open ≡-Reasoning in
    begin
      splitBy/clocked (suc k) (x ∷ xs) pivot
    ≡⟨⟩
      (bind (F pair) (splitMid (x ∷ xs) (s≤s z≤n)) λ (l₁ , mid , l₂) →
        bind (F pair) (mid ≤ᵇ pivot) (splitBy/clocked/aux k pivot l₁ mid l₂))
    ≡⟨ Eq.cong (λ e → bind (F pair) e _) (≡) ⟩
      bind (F pair) (mid ≤ᵇ pivot) (splitBy/clocked/aux k pivot l₁ mid l₂)
    ≡⟨ Eq.cong (λ e → bind (F pair) e (splitBy/clocked/aux k pivot l₁ mid l₂)) (eq/ref h-eq) ⟩
      step (F pair) q (splitBy/clocked/aux k pivot l₁ mid l₂ false)
    ≡⟨ step/ext (F pair) (splitBy/clocked/aux k pivot l₁ mid l₂ false) q u ⟩
      splitBy/clocked/aux k pivot l₁ mid l₂ false
    ≡⟨⟩
      (bind (F pair) (splitBy/clocked k l₁ pivot) λ (l₁₁ , l₁₂) → ret (l₁₁ , l₁₂ ++ mid ∷ l₂))
    ≡⟨ Eq.cong (λ e → bind (F pair) e _) ≡' ⟩
      ret (l₁₁ , l₁₂ ++ mid ∷ l₂)
    ∎
  ) , (
    λ sorted →
      let sorted' = Eq.subst Sorted ≡-↭ sorted in
      let (h₁₁ , h₁₂) = h-sorted (++⁻ˡ l₁ sorted') in
      h₁₁ , ++⁺-All h₁₂ (pivot≤mid ∷ ≤-≤* pivot≤mid (uncons₁ (++⁻ʳ l₁ sorted')))
  ) , (
    let open ≡-Reasoning in
    begin
      (x ∷ xs)
    ≡⟨ ≡-↭ ⟩
      l₁ ++ mid ∷ l₂
    ≡⟨ Eq.cong (_++ (mid ∷ l₂)) ≡-↭' ⟩
      (l₁₁ ++ l₁₂) ++ mid ∷ l₂
    ≡⟨ ++-assoc l₁₁ l₁₂ (mid ∷ l₂) ⟩
      l₁₁ ++ (l₁₂ ++ mid ∷ l₂)
    ∎
  )
splitBy/clocked/correct (suc k) (x ∷ xs) pivot (s≤s h) u | (l₁ , mid , l₂ , ≡ , h₁ , h₂ , ≡-↭) | ⇓ true withCost q [ _ , h-eq ] | ofʸ p  | _              =
  let (l₂₁ , l₂₂ , ≡' , h-sorted , ≡-↭') = splitBy/clocked/correct k l₂ pivot (
                                              let open ≤-Reasoning in
                                              begin
                                                ⌈log₂ suc (length l₂) ⌉
                                              ≤⟨ log₂-mono (s≤s h₂) ⟩
                                                ⌈log₂ suc ⌊ length (x ∷ xs) /2⌋ ⌉
                                              ≤⟨ h ⟩
                                                k
                                              ∎
                                            ) u in
  l₁ ++ mid ∷ l₂₁ , l₂₂ , (
    let open ≡-Reasoning in
    begin
      splitBy/clocked (suc k) (x ∷ xs) pivot
    ≡⟨⟩
      (bind (F pair) (splitMid (x ∷ xs) (s≤s z≤n)) λ (l₁ , mid , l₂) →
        bind (F pair) (mid ≤ᵇ pivot) (splitBy/clocked/aux k pivot l₁ mid l₂))
    ≡⟨ Eq.cong (λ e → bind (F pair) e _) (≡) ⟩
      bind (F pair) (mid ≤ᵇ pivot) (splitBy/clocked/aux k pivot l₁ mid l₂)
    ≡⟨ Eq.cong (λ e → bind (F pair) e (splitBy/clocked/aux k pivot l₁ mid l₂)) (eq/ref h-eq) ⟩
      step (F pair) q (splitBy/clocked/aux k pivot l₁ mid l₂ true)
    ≡⟨ step/ext (F pair) (splitBy/clocked/aux k pivot l₁ mid l₂ true) q u ⟩
      splitBy/clocked/aux k pivot l₁ mid l₂ true
    ≡⟨⟩
      (bind (F pair) (splitBy/clocked k l₂ pivot) λ (l₂₁ , l₂₂) → ret (l₁ ++ mid ∷ l₂₁ , l₂₂))
    ≡⟨ Eq.cong (λ e → bind (F pair) e _) ≡' ⟩
      ret (l₁ ++ mid ∷ l₂₁ , l₂₂)
    ∎
  ) , (
    λ sorted →
      let sorted' = Eq.subst Sorted ≡-↭ sorted in
      let (h₂₁ , h₂₂) = h-sorted (uncons₂ (++⁻ʳ l₁ sorted')) in
      ++⁺-All
        (map (λ h → ≤-trans h p) (split-sorted₁ l₁ (++⁻ˡ (l₁ ∷ʳ mid) (Eq.subst Sorted (Eq.sym (++-assoc l₁ [ mid ] l₂)) sorted'))))
        (p ∷ h₂₁) ,
      h₂₂
  ) , (
    let open ≡-Reasoning in
    begin
      (x ∷ xs)
    ≡⟨ ≡-↭ ⟩
      l₁ ++ mid ∷ l₂
    ≡⟨ Eq.cong (λ l₂ → l₁ ++ mid ∷ l₂) ≡-↭' ⟩
      l₁ ++ mid ∷ (l₂₁ ++ l₂₂)
    ≡˘⟨ ++-assoc l₁ (mid ∷ l₂₁) l₂₂ ⟩
      (l₁ ++ mid ∷ l₂₁) ++ l₂₂
    ∎
  )

splitBy/clocked/cost : cmp (Π nat λ _ → Π (list A) λ _ → Π A λ _ → cost)
splitBy/clocked/cost/aux : cmp (Π nat λ _ → Π A λ _ → Π (list A) λ _ → Π A λ _ → Π (list A) λ _ → Π bool λ _ → cost)

splitBy/clocked/cost zero    l        pivot = 𝟘
splitBy/clocked/cost (suc k) []       pivot = 𝟘
splitBy/clocked/cost (suc k) (x ∷ xs) pivot =
  bind cost (splitMid (x ∷ xs) (s≤s z≤n)) λ (l₁ , mid , l₂) → splitMid/cost (x ∷ xs) (s≤s z≤n) ⊕
    bind cost (mid ≤ᵇ pivot) λ b → (1 , 1) ⊕ splitBy/clocked/cost/aux k pivot l₁ mid l₂ b

splitBy/clocked/cost/aux k pivot l₁ mid l₂ false =
  bind cost (splitBy/clocked k l₁ pivot) λ (l₁₁ , l₁₂) → splitBy/clocked/cost k l₁ pivot ⊕ 𝟘
splitBy/clocked/cost/aux k pivot l₁ mid l₂ true  =
  bind cost (splitBy/clocked k l₂ pivot) λ (l₂₁ , l₂₂) → splitBy/clocked/cost k l₂ pivot ⊕ 𝟘

splitBy/clocked/cost/closed : cmp (Π nat λ _ → Π (list A) λ _ → Π A λ _ → cost)
splitBy/clocked/cost/closed k _ _ = k , k

splitBy/clocked/cost≤splitBy/clocked/cost/closed : ∀ k l pivot → ⌈log₂ suc (length l) ⌉ Nat.≤ k →
  ◯ (splitBy/clocked/cost k l pivot ≤ₚ splitBy/clocked/cost/closed k l pivot)
splitBy/clocked/cost/aux≤k : ∀ k pivot l₁ mid l₂ b → ⌈log₂ suc (length l₁) ⌉ Nat.≤ k → ⌈log₂ suc (length l₂) ⌉ Nat.≤ k →
  ◯ (splitBy/clocked/cost/aux k pivot l₁ mid l₂ b ≤ₚ (k , k))

splitBy/clocked/cost≤splitBy/clocked/cost/closed zero    l        pivot h u = z≤n , z≤n
splitBy/clocked/cost≤splitBy/clocked/cost/closed (suc k) []       pivot h u = z≤n , z≤n
splitBy/clocked/cost≤splitBy/clocked/cost/closed (suc k) (x ∷ xs) pivot (s≤s h) u with splitMid/correct (x ∷ xs) (s≤s z≤n) u
... | (l₁ , mid , l₂ , ≡ , h₁ , h₂ , ≡-↭) with h-cost mid pivot
... | ⇓ b withCost q [ _ , h-eq ] =
  begin
    splitBy/clocked/cost (suc k) (x ∷ xs) pivot
  ≡⟨⟩
    (bind cost (splitMid (x ∷ xs) (s≤s z≤n)) λ (l₁ , mid , l₂) → splitMid/cost (x ∷ xs) (s≤s z≤n) ⊕
      bind cost (mid ≤ᵇ pivot) λ b → (1 , 1) ⊕ splitBy/clocked/cost/aux k pivot l₁ mid l₂ b)
  ≡⟨ Eq.cong (λ e → bind cost e _) (≡) ⟩
    (splitMid/cost (x ∷ xs) (s≤s z≤n) ⊕
      bind cost (mid ≤ᵇ pivot) λ b → (1 , 1) ⊕ splitBy/clocked/cost/aux k pivot l₁ mid l₂ b)
  ≡⟨⟩
    (𝟘 ⊕
      bind cost (mid ≤ᵇ pivot) λ b → (1 , 1) ⊕ splitBy/clocked/cost/aux k pivot l₁ mid l₂ b)
  ≡⟨ ⊕-identityˡ _ ⟩
    (bind cost (mid ≤ᵇ pivot) λ b → (1 , 1) ⊕ splitBy/clocked/cost/aux k pivot l₁ mid l₂ b)
  ≡⟨ Eq.cong (λ e → bind cost e λ b → (1 , 1) ⊕ splitBy/clocked/cost/aux k pivot l₁ mid l₂ b) (eq/ref h-eq) ⟩
    step cost q ((1 , 1) ⊕ splitBy/clocked/cost/aux k pivot l₁ mid l₂ b)
  ≡⟨ step/ext cost _ q u ⟩
    (1 , 1) ⊕ splitBy/clocked/cost/aux k pivot l₁ mid l₂ b
  ≤⟨
    ⊕-monoʳ-≤ (1 , 1) (
      splitBy/clocked/cost/aux≤k k pivot l₁ mid l₂ b
        (N.≤-trans (log₂-mono (s≤s h₁)) h)
        (N.≤-trans (log₂-mono (s≤s h₂)) h)
        u
    )
  ⟩
    (1 , 1) ⊕ (k , k)
  ≡⟨⟩
    (suc k , suc k)
  ≡⟨⟩
    splitBy/clocked/cost/closed (suc k) (x ∷ xs) pivot
  ∎
    where open ≤ₚ-Reasoning

splitBy/clocked/cost/aux≤k k pivot l₁ mid l₂ false h₁ h₂ u =
  let (l₁₁ , l₁₂ , ≡' , _ , ≡-↭') = splitBy/clocked/correct k l₁ pivot h₁ u in
  begin
    splitBy/clocked/cost/aux k pivot l₁ mid l₂ false
  ≡⟨⟩
    (bind cost (splitBy/clocked k l₁ pivot) λ (l₁₁ , l₁₂) → splitBy/clocked/cost k l₁ pivot ⊕ 𝟘)
  ≡⟨ Eq.cong (λ e → bind cost e λ (l₁₁ , l₁₂) → splitBy/clocked/cost k l₁ pivot ⊕ 𝟘) ≡' ⟩
    splitBy/clocked/cost k l₁ pivot ⊕ 𝟘
  ≡⟨ ⊕-identityʳ _ ⟩
    splitBy/clocked/cost k l₁ pivot
  ≤⟨ splitBy/clocked/cost≤splitBy/clocked/cost/closed k l₁ pivot h₁ u ⟩
    (k , k)
  ∎
    where open ≤ₚ-Reasoning
splitBy/clocked/cost/aux≤k k pivot l₁ mid l₂ true  h₁ h₂ u =
  let (l₂₁ , l₂₂ , ≡' , _ , ≡-↭') = splitBy/clocked/correct k l₂ pivot h₂ u in
  begin
    splitBy/clocked/cost/aux k pivot l₁ mid l₂ true
  ≡⟨⟩
    (bind cost (splitBy/clocked k l₂ pivot) λ (l₂₁ , l₂₂) → splitBy/clocked/cost k l₂ pivot ⊕ 𝟘)
  ≡⟨ Eq.cong (λ e → bind cost e λ (l₂₁ , l₂₂) → splitBy/clocked/cost k l₂ pivot ⊕ 𝟘) ≡' ⟩
    splitBy/clocked/cost k l₂ pivot ⊕ 𝟘
  ≡⟨ ⊕-identityʳ _ ⟩
    splitBy/clocked/cost k l₂ pivot
  ≤⟨ splitBy/clocked/cost≤splitBy/clocked/cost/closed k l₂ pivot h₂ u ⟩
    (k , k)
  ∎
    where open ≤ₚ-Reasoning

splitBy/clocked≤splitBy/clocked/cost : ∀ k l pivot → IsBounded pair (splitBy/clocked k l pivot) (splitBy/clocked/cost k l pivot)
splitBy/clocked≤splitBy/clocked/cost zero    l        pivot = bound/ret
splitBy/clocked≤splitBy/clocked/cost (suc k) []       pivot = bound/ret
splitBy/clocked≤splitBy/clocked/cost (suc k) (x ∷ xs) pivot =
  bound/bind {e = splitMid (x ∷ xs) (s≤s z≤n)} (splitMid/cost (x ∷ xs) (s≤s z≤n)) _ (splitMid≤splitMid/cost (x ∷ xs) (s≤s z≤n)) λ (l₁ , mid , l₂) →
    bound/bind (1 , 1) _ (h-cost mid pivot)
      λ { false → bound/bind (splitBy/clocked/cost k l₁ pivot) (λ _ → 𝟘) (splitBy/clocked≤splitBy/clocked/cost k l₁ pivot) λ _ → bound/ret
        ; true  → bound/bind (splitBy/clocked/cost k l₂ pivot) (λ _ → 𝟘) (splitBy/clocked≤splitBy/clocked/cost k l₂ pivot) λ _ → bound/ret }

splitBy/clocked≤splitBy/clocked/cost/closed : ∀ k l pivot → ⌈log₂ suc (length l) ⌉ Nat.≤ k → IsBounded pair (splitBy/clocked k l pivot) (splitBy/clocked/cost/closed k l pivot)
splitBy/clocked≤splitBy/clocked/cost/closed k l pivot h = bound/relax (splitBy/clocked/cost≤splitBy/clocked/cost/closed k l pivot h) (splitBy/clocked≤splitBy/clocked/cost k l pivot)

splitBy : cmp (Π (list A) λ _ → Π A λ _ → F pair)
splitBy l pivot = splitBy/clocked ⌈log₂ suc (length l) ⌉ l pivot

splitBy/correct : ∀ l pivot →
  ◯ (∃ λ l₁ → ∃ λ l₂ → splitBy l pivot ≡ ret (l₁ , l₂) × (Sorted l → All (_≤ pivot) l₁ × All (pivot ≤_) l₂) × l ≡ (l₁ ++ l₂))
splitBy/correct l pivot = splitBy/clocked/correct ⌈log₂ suc (length l) ⌉ l pivot N.≤-refl

splitBy/cost : cmp (Π (list A) λ _ → Π A λ _ → cost)
splitBy/cost l pivot = splitBy/clocked/cost ⌈log₂ suc (length l) ⌉ l pivot

splitBy/cost/closed : cmp (Π (list A) λ _ → Π A λ _ → cost)
splitBy/cost/closed l pivot = splitBy/clocked/cost/closed ⌈log₂ suc (length l) ⌉ l pivot

splitBy≤splitBy/cost : ∀ l pivot → IsBounded pair (splitBy l pivot) (splitBy/cost l pivot)
splitBy≤splitBy/cost l pivot = splitBy/clocked≤splitBy/clocked/cost ⌈log₂ suc (length l) ⌉ l pivot

splitBy≤splitBy/cost/closed : ∀ l pivot → IsBounded pair (splitBy l pivot) (splitBy/cost/closed l pivot)
splitBy≤splitBy/cost/closed l pivot = splitBy/clocked≤splitBy/clocked/cost/closed ⌈log₂ suc (length l) ⌉ l pivot N.≤-refl

merge/clocked : cmp (Π nat λ _ → Π pair λ _ → F (list A))
merge/clocked zero    (l₁     , l₂) = ret (l₁ ++ l₂)
merge/clocked (suc k) ([]     , l₂) = ret l₂
merge/clocked (suc k) (x ∷ l₁ , l₂) =
  bind (F (list A)) (splitMid (x ∷ l₁) (s≤s z≤n)) λ (l₁₁ , pivot , l₁₂) →
    bind (F (list A)) (splitBy l₂ pivot) λ (l₂₁ , l₂₂) →
      bind (F (list A)) (merge/clocked k (l₁₁ , l₂₁) & merge/clocked k (l₁₂ , l₂₂)) λ (l₁' , l₂') →
        ret (l₁' ++ pivot ∷ l₂')

merge/clocked/correct : ∀ k l₁ l₂ → ⌈log₂ suc (length l₁) ⌉ Nat.≤ k →
  ◯ (∃ λ l → merge/clocked k (l₁ , l₂) ≡ ret l × (Sorted l₁ → Sorted l₂ → SortedOf (l₁ ++ l₂) l))
merge/clocked/correct zero    l₁       l₂ h-clock u with ⌈log₂n⌉≡0⇒n≤1 {suc (length l₁)} (N.n≤0⇒n≡0 h-clock)
merge/clocked/correct zero    []       l₂ h-clock u | s≤s z≤n = l₂ , refl , (λ sorted₁ sorted₂ → refl , sorted₂)
merge/clocked/correct (suc k) []       l₂ h-clock u = l₂ , refl , (λ sorted₁ sorted₂ → refl , sorted₂)
merge/clocked/correct (suc k) (x ∷ l₁) l₂ h-clock u =
  let (l₁₁ , pivot , l₁₂ , ≡ , h₁₁ , h₁₂ , ≡-↭) = splitMid/correct (x ∷ l₁) (s≤s z≤n) u in
  let (l₂₁ , l₂₂ , ≡' , h-sorted₂ , ≡-↭') = splitBy/correct l₂ pivot u in
  let (l₁' , ≡₁' , h-sorted₁') = merge/clocked/correct k l₁₁ l₂₁
                                  (let open ≤-Reasoning in
                                  begin
                                    ⌈log₂ suc (length l₁₁) ⌉
                                  ≤⟨ log₂-mono (s≤s h₁₁) ⟩
                                    ⌈log₂ ⌈ suc (length (x ∷ l₁)) /2⌉ ⌉
                                  ≤⟨ log₂-suc (suc (length (x ∷ l₁))) h-clock ⟩
                                    k
                                  ∎)
                                  u in
  let (l₂' , ≡₂' , h-sorted₂') = merge/clocked/correct k l₁₂ l₂₂
                                  (let open ≤-Reasoning in
                                  begin
                                    ⌈log₂ suc (length l₁₂) ⌉
                                  ≤⟨ log₂-mono (s≤s h₁₂) ⟩
                                    ⌈log₂ ⌈ suc (length (x ∷ l₁)) /2⌉ ⌉
                                  ≤⟨ log₂-suc (suc (length (x ∷ l₁))) h-clock ⟩
                                    k
                                  ∎)
                                  u in
  l₁' ++ pivot ∷ l₂' , (
    let open ≡-Reasoning in
    begin
      merge/clocked (suc k) (x ∷ l₁ , l₂)
    ≡⟨⟩
      (bind (F (list A)) (splitMid (x ∷ l₁) (s≤s z≤n)) λ (l₁₁ , pivot , l₁₂) →
        bind (F (list A)) (splitBy l₂ pivot) λ (l₂₁ , l₂₂) →
          bind (F (list A)) (merge/clocked k (l₁₁ , l₂₁) & merge/clocked k (l₁₂ , l₂₂)) λ (l₁' , l₂') →
            ret (l₁' ++ pivot ∷ l₂'))
    ≡⟨ Eq.cong (λ e → bind (F (list A)) e _) (≡) ⟩
      (bind (F (list A)) (splitBy l₂ pivot) λ (l₂₁ , l₂₂) →
        bind (F (list A)) (merge/clocked k (l₁₁ , l₂₁) & merge/clocked k (l₁₂ , l₂₂)) λ (l₁' , l₂') →
          ret (l₁' ++ pivot ∷ l₂'))
    ≡⟨ Eq.cong (λ e → bind (F (list A)) e _) (≡') ⟩
      (bind (F (list A)) (merge/clocked k (l₁₁ , l₂₁) & merge/clocked k (l₁₂ , l₂₂)) λ (l₁' , l₂') →
        ret (l₁' ++ pivot ∷ l₂'))
    ≡⟨ Eq.cong (λ e → bind (F (list A)) e _) (Eq.cong₂ _&_ ≡₁' ≡₂') ⟩
      ret (l₁' ++ pivot ∷ l₂')
    ∎
  ) ,
  λ sorted₁ sorted₂ →
    let (h₂₁ , h₂₂) = h-sorted₂ sorted₂ in
    let sorted₁ = Eq.subst Sorted ≡-↭  sorted₁
        sorted₂ = Eq.subst Sorted ≡-↭' sorted₂ in
    let (↭₁' , sorted₁') = h-sorted₁'          (++⁻ˡ l₁₁ sorted₁)  (++⁻ˡ l₂₁ sorted₂)
        (↭₂' , sorted₂') = h-sorted₂' (uncons₂ (++⁻ʳ l₁₁ sorted₁)) (++⁻ʳ l₂₁ sorted₂) in
    (
      let open PermutationReasoning in
      begin
        (x ∷ l₁) ++ l₂
      ≡⟨ Eq.cong₂ (_++_) ≡-↭ ≡-↭' ⟩
        (l₁₁ ++ pivot ∷ l₁₂) ++ (l₂₁ ++ l₂₂)
      ≡⟨ ++-assoc l₁₁ (pivot ∷ l₁₂) (l₂₁ ++ l₂₂) ⟩
        l₁₁ ++ (pivot ∷ l₁₂ ++ (l₂₁ ++ l₂₂))
      ↭⟨ ++⁺ˡ-↭ l₁₁ (++⁺ˡ-↭ (pivot ∷ l₁₂) (++-comm-↭ l₂₁ l₂₂)) ⟩
        l₁₁ ++ (pivot ∷ l₁₂ ++ (l₂₂ ++ l₂₁))
      ≡˘⟨ Eq.cong (l₁₁ ++_) (++-assoc (pivot ∷ l₁₂) l₂₂ l₂₁) ⟩
        l₁₁ ++ ((pivot ∷ l₁₂ ++ l₂₂) ++ l₂₁)
      ↭⟨ ++⁺ˡ-↭ l₁₁ (++-comm-↭ (pivot ∷ l₁₂ ++ l₂₂) l₂₁) ⟩
        l₁₁ ++ (l₂₁ ++ (pivot ∷ l₁₂ ++ l₂₂))
      ≡˘⟨ ++-assoc l₁₁ l₂₁ (pivot ∷ l₁₂ ++ l₂₂) ⟩
        (l₁₁ ++ l₂₁) ++ (pivot ∷ l₁₂ ++ l₂₂)
      ≡⟨⟩
        (l₁₁ ++ l₂₁) ++ pivot ∷ (l₁₂ ++ l₂₂)
      ↭⟨ ++⁺-↭ ↭₁' (prep pivot ↭₂') ⟩
        l₁' ++ pivot ∷ l₂'
      ∎
    ) ,
    join-sorted
      sorted₁'
      sorted₂'
      (All-resp-↭ ↭₁' (++⁺-All (split-sorted₁ l₁₁ (++⁻ˡ (l₁₁ ∷ʳ pivot) (Eq.subst Sorted (Eq.sym (++-assoc l₁₁ [ pivot ] l₁₂)) sorted₁))) h₂₁))
      (All-resp-↭ ↭₂' (++⁺-All (uncons₁ (++⁻ʳ l₁₁ sorted₁)) h₂₂))

merge/clocked/cost : cmp (Π nat λ _ → Π pair λ _ → cost)
merge/clocked/cost zero    (l₁     , l₂) = 𝟘
merge/clocked/cost (suc k) ([]     , l₂) = 𝟘
merge/clocked/cost (suc k) (x ∷ l₁ , l₂) =
  bind cost (splitMid (x ∷ l₁) (s≤s z≤n)) λ (l₁₁ , pivot , l₁₂) → splitMid/cost (x ∷ l₁) (s≤s z≤n) ⊕
    bind cost (splitBy l₂ pivot) λ (l₂₁ , l₂₂) → splitBy/cost/closed l₂ pivot ⊕
      bind cost (merge/clocked k (l₁₁ , l₂₁) & merge/clocked k (l₁₂ , l₂₂)) λ (l₁' , l₂') → (merge/clocked/cost k (l₁₁ , l₂₁) ⊗ merge/clocked/cost k (l₁₂ , l₂₂)) ⊕
        𝟘

merge/clocked/cost/closed : cmp (Π nat λ _ → Π pair λ _ → cost)
merge/clocked/cost/closed k (l₁ , l₂) = pred[2^ k ] * ⌈log₂ suc (length l₂) ⌉ , k * ⌈log₂ suc (length l₂) ⌉

merge/clocked/cost≤merge/clocked/cost/closed : ∀ k l₁ l₂ → ⌈log₂ suc (length l₁) ⌉ Nat.≤ k →
  ◯ (merge/clocked/cost k (l₁ , l₂) ≤ₚ merge/clocked/cost/closed k (l₁ , l₂))
merge/clocked/cost≤merge/clocked/cost/closed zero    l₁       l₂ h-clock u = z≤n , z≤n
merge/clocked/cost≤merge/clocked/cost/closed (suc k) []       l₂ h-clock u = z≤n , z≤n
merge/clocked/cost≤merge/clocked/cost/closed (suc k) (x ∷ l₁) l₂ h-clock u =
  let (l₁₁ , pivot , l₁₂ , ≡-splitMid , h₁₁ , h₁₂ , ≡-↭) = splitMid/correct (x ∷ l₁) (s≤s z≤n) u in
  let (l₂₁ , l₂₂ , ≡' , _ , ≡-↭') = splitBy/correct l₂ pivot u in
  let h₁ : ⌈log₂ suc (length l₁₁) ⌉ Nat.≤ k
      h₁ =
        let open ≤-Reasoning in
        begin
          ⌈log₂ suc (length l₁₁) ⌉
        ≤⟨ log₂-mono (s≤s h₁₁) ⟩
          ⌈log₂ ⌈ suc (length (x ∷ l₁)) /2⌉ ⌉
        ≤⟨ log₂-suc (suc (length (x ∷ l₁))) h-clock ⟩
          k
        ∎

      h₂ : ⌈log₂ suc (length l₁₂) ⌉ Nat.≤ k
      h₂ =
        let open ≤-Reasoning in
        begin
          ⌈log₂ suc (length l₁₂) ⌉
        ≤⟨ log₂-mono (s≤s h₁₂) ⟩
          ⌈log₂ ⌈ suc (length (x ∷ l₁)) /2⌉ ⌉
        ≤⟨ log₂-suc (suc (length (x ∷ l₁))) h-clock ⟩
          k
        ∎
  in
  let (l₁' , ≡₁' , _) = merge/clocked/correct k l₁₁ l₂₁ h₁ u in
  let (l₂' , ≡₂' , _) = merge/clocked/correct k l₁₂ l₂₂ h₂ u in
  let open ≤ₚ-Reasoning in
  begin
    (bind cost (splitMid (x ∷ l₁) (s≤s z≤n)) λ (l₁₁ , pivot , l₁₂) → splitMid/cost (x ∷ l₁) (s≤s z≤n) ⊕
      bind cost (splitBy l₂ pivot) λ (l₂₁ , l₂₂) → splitBy/cost/closed l₂ pivot ⊕
        bind cost (merge/clocked k (l₁₁ , l₂₁) & merge/clocked k (l₁₂ , l₂₂)) λ (l₁' , l₂') → (merge/clocked/cost k (l₁₁ , l₂₁) ⊗ merge/clocked/cost k (l₁₂ , l₂₂)) ⊕
          𝟘)
  ≡⟨ Eq.cong (λ e → bind cost e λ (l₁₁ , pivot , l₁₂) → splitMid/cost (x ∷ l₁) (s≤s z≤n) ⊕ _) ≡-splitMid ⟩
    (splitMid/cost (x ∷ l₁) (s≤s z≤n) ⊕
      bind cost (splitBy l₂ pivot) λ (l₂₁ , l₂₂) → splitBy/cost/closed l₂ pivot ⊕
        bind cost (merge/clocked k (l₁₁ , l₂₁) & merge/clocked k (l₁₂ , l₂₂)) λ (l₁' , l₂') → (merge/clocked/cost k (l₁₁ , l₂₁) ⊗ merge/clocked/cost k (l₁₂ , l₂₂)) ⊕
          𝟘)
  ≡⟨⟩
    (𝟘 ⊕
      bind cost (splitBy l₂ pivot) λ (l₂₁ , l₂₂) → splitBy/cost/closed l₂ pivot ⊕
        bind cost (merge/clocked k (l₁₁ , l₂₁) & merge/clocked k (l₁₂ , l₂₂)) λ (l₁' , l₂') → (merge/clocked/cost k (l₁₁ , l₂₁) ⊗ merge/clocked/cost k (l₁₂ , l₂₂)) ⊕
          𝟘)
  ≡⟨ ⊕-identityˡ _ ⟩
    (bind cost (splitBy l₂ pivot) λ (l₂₁ , l₂₂) → splitBy/cost/closed l₂ pivot ⊕
      bind cost (merge/clocked k (l₁₁ , l₂₁) & merge/clocked k (l₁₂ , l₂₂)) λ (l₁' , l₂') → (merge/clocked/cost k (l₁₁ , l₂₁) ⊗ merge/clocked/cost k (l₁₂ , l₂₂)) ⊕
        𝟘)
  ≡⟨
    Eq.cong
      (λ e →
        bind cost e λ (l₂₁ , l₂₂) → splitBy/cost/closed l₂ pivot ⊕
          bind cost (merge/clocked k (l₁₁ , l₂₁) & merge/clocked k (l₁₂ , l₂₂)) λ (l₁' , l₂') → (merge/clocked/cost k (l₁₁ , l₂₁) ⊗ merge/clocked/cost k (l₁₂ , l₂₂)) ⊕
            𝟘)
      ≡'
  ⟩
    (splitBy/cost/closed l₂ pivot ⊕
      bind cost (merge/clocked k (l₁₁ , l₂₁) & merge/clocked k (l₁₂ , l₂₂)) λ (l₁' , l₂') → (merge/clocked/cost k (l₁₁ , l₂₁) ⊗ merge/clocked/cost k (l₁₂ , l₂₂)) ⊕
        𝟘)
  ≡⟨
    Eq.cong₂
      (λ e₁ e₂ →
        splitBy/cost/closed l₂ pivot ⊕
          bind cost (e₁ & e₂) λ (l₁' , l₂') → (merge/clocked/cost k (l₁₁ , l₂₁) ⊗ merge/clocked/cost k (l₁₂ , l₂₂)) ⊕
            𝟘)
      ≡₁'
      ≡₂' ⟩
    splitBy/cost/closed l₂ pivot ⊕ ((merge/clocked/cost k (l₁₁ , l₂₁) ⊗ merge/clocked/cost k (l₁₂ , l₂₂)) ⊕ 𝟘)
  ≡⟨ Eq.cong (splitBy/cost/closed l₂ pivot ⊕_) (⊕-identityʳ _) ⟩
    splitBy/cost/closed l₂ pivot ⊕ (merge/clocked/cost k (l₁₁ , l₂₁) ⊗ merge/clocked/cost k (l₁₂ , l₂₂))
  ≤⟨
    ⊕-monoʳ-≤ (splitBy/cost/closed l₂ pivot) (
      ⊗-mono-≤
        (merge/clocked/cost≤merge/clocked/cost/closed k l₁₁ l₂₁ h₁ u)
        (merge/clocked/cost≤merge/clocked/cost/closed k l₁₂ l₂₂ h₂ u)
    )
  ⟩
    splitBy/cost/closed l₂ pivot ⊕ (merge/clocked/cost/closed k (l₁₁ , l₂₁) ⊗ merge/clocked/cost/closed k (l₁₂ , l₂₂))
  ≡⟨⟩
    (⌈log₂ suc (length l₂) ⌉ , ⌈log₂ suc (length l₂) ⌉) ⊕
      ((pred[2^ k ] * ⌈log₂ suc (length l₂₁) ⌉ , k * ⌈log₂ suc (length l₂₁) ⌉) ⊗
        (pred[2^ k ] * ⌈log₂ suc (length l₂₂) ⌉ , k * ⌈log₂ suc (length l₂₂) ⌉))
  ≤⟨
    ⊕-monoʳ-≤ (⌈log₂ suc (length l₂) ⌉ , ⌈log₂ suc (length l₂) ⌉) (
      let h-length : length l₂₁ + length l₂₂ ≡ length l₂
          h-length = Eq.sym (Eq.trans (Eq.cong length ≡-↭') (length-++ l₂₁))

          h₁ : ⌈log₂ suc (length l₂₁) ⌉ Nat.≤ ⌈log₂ suc (length l₂) ⌉
          h₁ = log₂-mono (s≤s (N.m+n≤o⇒m≤o (length l₂₁) (N.≤-reflexive h-length)))

          h₂ : ⌈log₂ suc (length l₂₂) ⌉ Nat.≤ ⌈log₂ suc (length l₂) ⌉
          h₂ = log₂-mono (s≤s (N.m+n≤o⇒n≤o (length l₂₁) (N.≤-reflexive h-length)))
      in
      ⊗-mono-≤
        (N.*-monoʳ-≤ pred[2^ k ] h₁ , N.*-monoʳ-≤ k h₁)
        (N.*-monoʳ-≤ pred[2^ k ] h₂ , N.*-monoʳ-≤ k h₂)
    )
  ⟩
    (⌈log₂ suc (length l₂) ⌉ , ⌈log₂ suc (length l₂) ⌉) ⊕
      ((pred[2^ k ] * ⌈log₂ suc (length l₂) ⌉ , k * ⌈log₂ suc (length l₂) ⌉) ⊗
        (pred[2^ k ] * ⌈log₂ suc (length l₂) ⌉ , k * ⌈log₂ suc (length l₂) ⌉))
  ≡⟨ Eq.cong₂ _,_ (arithmetic/work ⌈log₂ suc (length l₂) ⌉) (arithmetic/span ⌈log₂ suc (length l₂) ⌉) ⟩
    pred[2^ suc k ] * ⌈log₂ suc (length l₂) ⌉ , suc k * ⌈log₂ suc (length l₂) ⌉
  ≡⟨⟩
    merge/clocked/cost/closed (suc k) (x ∷ l₁ , l₂)
  ∎
    where
      arithmetic/work : ∀ n → n + (pred[2^ k ] * n + pred[2^ k ] * n) ≡ pred[2^ suc k ] * n
      arithmetic/work n =
        begin
          n + (pred[2^ k ] * n + pred[2^ k ] * n)
        ≡˘⟨ Eq.cong (n +_) (N.*-distribʳ-+ n (pred[2^ k ]) (pred[2^ k ])) ⟩
          n + (pred[2^ k ] + pred[2^ k ]) * n
        ≡⟨⟩
          suc (pred[2^ k ] + pred[2^ k ]) * n
        ≡⟨ Eq.cong (_* n) (pred[2^suc[n]] k) ⟩
          pred[2^ suc k ] * n
        ∎
          where open ≡-Reasoning

      arithmetic/span : ∀ n → n + (k * n ⊔ k * n) ≡ suc k * n
      arithmetic/span n =
        begin
          n + (k * n ⊔ k * n)
        ≡⟨ Eq.cong (n +_) (N.⊔-idem (k * n)) ⟩
          n + k * n
        ≡⟨⟩
          suc k * n
        ∎
          where open ≡-Reasoning

merge/clocked≤merge/clocked/cost : ∀ k l₁ l₂ → IsBounded (list A) (merge/clocked k (l₁ , l₂)) (merge/clocked/cost k (l₁ , l₂))
merge/clocked≤merge/clocked/cost zero    l₁       l₂ = bound/ret
merge/clocked≤merge/clocked/cost (suc k) []       l₂ = bound/ret
merge/clocked≤merge/clocked/cost (suc k) (x ∷ l₁) l₂ =
  bound/bind (splitMid/cost (x ∷ l₁) (s≤s z≤n)) _ (splitMid≤splitMid/cost (x ∷ l₁) (s≤s z≤n)) λ (l₁₁ , pivot , l₁₂) →
    bound/bind (splitBy/cost/closed l₂ pivot) _ (splitBy≤splitBy/cost/closed l₂ pivot) λ (l₂₁ , l₂₂) →
      bound/bind (merge/clocked/cost k (l₁₁ , l₂₁) ⊗ merge/clocked/cost k (l₁₂ , l₂₂)) _ (bound/par (merge/clocked≤merge/clocked/cost k l₁₁ l₂₁) (merge/clocked≤merge/clocked/cost k l₁₂ l₂₂)) λ (l₁' , l₂') →
        bound/ret

merge/clocked≤merge/clocked/cost/closed : ∀ k l₁ l₂ → ⌈log₂ suc (length l₁) ⌉ Nat.≤ k →
  IsBounded (list A) (merge/clocked k (l₁ , l₂)) (merge/clocked/cost/closed k (l₁ , l₂))
merge/clocked≤merge/clocked/cost/closed k l₁ l₂ h =
  bound/relax (merge/clocked/cost≤merge/clocked/cost/closed k l₁ l₂ h) (merge/clocked≤merge/clocked/cost k l₁ l₂)

merge : cmp (Π pair λ _ → F (list A))
merge (l₁ , l₂) = merge/clocked ⌈log₂ suc (length l₁) ⌉ (l₁ , l₂)

merge/correct : ∀ l₁ l₂ →
  ◯ (∃ λ l → merge (l₁ , l₂) ≡ ret l × (Sorted l₁ → Sorted l₂ → SortedOf (l₁ ++ l₂) l))
merge/correct l₁ l₂ = merge/clocked/correct ⌈log₂ suc (length l₁) ⌉ l₁ l₂ N.≤-refl

merge/cost : cmp (Π pair λ _ → cost)
merge/cost (l₁ , l₂) = merge/clocked/cost ⌈log₂ suc (length l₁) ⌉ (l₁ , l₂)

merge/cost/closed : cmp (Π pair λ _ → cost)
merge/cost/closed (l₁ , l₂) = merge/clocked/cost/closed ⌈log₂ suc (length l₁) ⌉ (l₁ , l₂)

merge≤merge/cost : ∀ l₁ l₂ → IsBounded (list A) (merge (l₁ , l₂)) (merge/cost (l₁ , l₂))
merge≤merge/cost l₁ l₂ = merge/clocked≤merge/clocked/cost ⌈log₂ suc (length l₁) ⌉ l₁ l₂

merge≤merge/cost/closed : ∀ l₁ l₂ → IsBounded (list A) (merge (l₁ , l₂)) (merge/cost/closed (l₁ , l₂))
merge≤merge/cost/closed l₁ l₂ = merge/clocked≤merge/clocked/cost/closed ⌈log₂ suc (length l₁) ⌉ l₁ l₂ N.≤-refl


open import Functional hiding (Domain)
import      Structure.Logic.Classical.NaturalDeduction
import      Structure.Logic.Classical.SetTheory.ZFC

module Structure.Logic.Classical.SetTheory.ZFC.Proofs {ℓₗ} {Formula} {ℓₘₗ} {Proof} {ℓₒ} {Domain} ⦃ classicLogic : _ ⦄ (_∈_ : Domain → Domain → Formula) ⦃ signature : _ ⦄ ⦃ axioms : _ ⦄ where
open Structure.Logic.Classical.NaturalDeduction.ClassicalLogic {ℓₗ} {Formula} {ℓₘₗ} {Proof} {ℓₒ} {Domain} (classicLogic)
open Structure.Logic.Classical.SetTheory.ZFC.Signature {ℓₗ} {Formula} {ℓₘₗ} {Proof} {ℓₒ} {Domain} ⦃ classicLogic ⦄ {_∈_} (signature)
open Structure.Logic.Classical.SetTheory.ZFC.ZF        {ℓₗ} {Formula} {ℓₘₗ} {Proof} {ℓₒ} {Domain} ⦃ classicLogic ⦄ {_∈_} ⦃ signature ⦄ (axioms)

open import Lang.Instance
import      Lvl
open import Structure.Logic.Classical.NaturalDeduction.Proofs            ⦃ classicLogic ⦄
open import Structure.Logic.Classical.SetTheory.SetBoundedQuantification ⦃ classicLogic ⦄ (_∈_)
open import Structure.Logic.Classical.SetTheory.Relation                 ⦃ classicLogic ⦄ (_∈_)
open import Structure.Logic.Classical.SetTheory                          ⦃ classicLogic ⦄ (_∈_)
open        Structure.Logic.Classical.SetTheory.ZFC                      ⦃ classicLogic ⦄ (_∈_)
open import Structure.Logic.Constructive.Functions(Domain)
open import Structure.Logic.Constructive.Functions.Properties ⦃ constructiveLogicSignature ⦄

open SetEquality ⦃ ... ⦄        hiding (extensional)
open SingletonSet ⦃ ... ⦄       hiding (singleton)
open FilterSet ⦃ ... ⦄          hiding (filter)
open PowerSet ⦃ ... ⦄           hiding (℘)
open SetUnionSet ⦃ ... ⦄        hiding (⋃)
open UnionSet ⦃ ... ⦄           hiding (_∪_)
open IntersectionSet ⦃ ... ⦄    hiding (_∩_)
open WithoutSet ⦃ ... ⦄         hiding (_∖_)
open SetIntersectionSet ⦃ ... ⦄ hiding (⋂)

-- All sets are either empty or non-empty.
postulate Empty-excluded-middle : ∀{s} → Proof(Empty(s) ∨ NonEmpty(s))

pair-membership : Proof(∀ₗ(a₁ ↦ ∀ₗ(a₂ ↦ (∀ₗ(x ↦ (x ∈ pair(a₁)(a₂)) ⟷ (x ≡ a₁)∨(x ≡ a₂))))))
pair-membership = pairing

postulate pair-membership-[≡ₛ] : Proof(∀ₗ(a₁ ↦ ∀ₗ(a₂ ↦ (∀ₗ(x ↦ (x ∈ pair(a₁)(a₂)) ⟷ (x ≡ₛ a₁)∨(x ≡ₛ a₂))))))
-- pair-membership-[≡ₛ] = pairing

instance
  setEqualityInstance : SetEquality
  setEqualityInstance = SetEquality.intro extensional

instance
  emptySetInstance : EmptySet
  emptySetInstance = EmptySet.intro ∅ empty

instance
  singletonSetInstance : SingletonSet
  singletonSetInstance = SingletonSet.intro singleton
    ([∀].intro (\{a} →
      ([∀].intro (\{x} →
        [↔].transitivity
          ([∀].elim([∀].elim([∀].elim(pair-membership-[≡ₛ]){a}){a}){x})
          ([↔].intro ([∨].redundancyₗ) ([∨].redundancyᵣ))
      ))
    ))

instance
  filterSetInstance : FilterSet
  filterSetInstance = FilterSet.intro filter comprehension

instance
  powerSetInstance : PowerSet
  powerSetInstance = PowerSet.intro ℘ power

instance
  setUnionSetInstance : SetUnionSet
  setUnionSetInstance = SetUnionSet.intro ⋃ union

instance
  unionSetInstance : UnionSet
  unionSetInstance = UnionSet.intro _∪_
    ([∀].intro (\{a} →
      ([∀].intro (\{b} →
        ([∀].intro (\{x} →
          ([∀].elim([∀].elim [⋃]-membership{pair(a)(b)}){x})
          ⦗ₗ [↔].transitivity ⦘
          ([↔]-with-[∃] (\{s} →
            ([↔]-with-[∧]ₗ ([∀].elim([∀].elim([∀].elim pair-membership{a}){b}){s}))
            ⦗ₗ [↔].transitivity ⦘
            ([∧][∨]-distributivityᵣ)
            ⦗ₗ [↔].transitivity ⦘
            [↔]-with-[∨] ([≡]-substitute-this-is-almost-trivial) ([≡]-substitute-this-is-almost-trivial)
          ))
          ⦗ₗ [↔].transitivity ⦘
          ([↔].intro ([∃]-redundancyₗ) ([∃]-redundancyᵣ))
        ))
      ))
    ))

instance
  intersectionSetInstance : IntersectionSet
  intersectionSetInstance = IntersectionSet.intro _∩_
    ([∀].intro (\{a} →
      ([∀].intro (\{b} →
        ([∀].elim(filter-membership){a})
      ))
    ))

instance
  withoutSetInstance : WithoutSet
  withoutSetInstance = WithoutSet.intro _∖_
    ([∀].intro (\{a} →
      ([∀].intro (\{b} →
        ([∀].elim(filter-membership){a})
      ))
    ))

instance
  setIntersectionSetInstance : SetIntersectionSet
  setIntersectionSetInstance = SetIntersectionSet.intro ⋂
    ([∀].intro (\{ss} →
      ([∀].intro (\{x} →
        ([↔].intro
          -- (⟵)-case
          (allssinssxins ↦
            ([↔].elimₗ
              ([∀].elim([∀].elim filter-membership{⋃(ss)}){x})
              ([∧].intro
                -- x ∈ ⋃(ss)
                ([∨].elim
                  -- Empty(ss) ⇒ _
                  (allyyninss ↦
                    proof -- TODO: But: Empty(ss) ⇒ (ss ≡ ∅) ⇒ ⋃(ss) ≡ ∅ ⇒ (x ∉ ⋃(ss)) ? Maybe use this argument further up instead to prove something like: (⋂(ss) ≡ ∅) ⇒ (x ∉ ∅)
                  )

                  -- NonEmpty(ss) ⇒ _
                  (existsyinss ↦
                    ([∃].elim
                      (\{y} → yinss ↦ (
                        ([↔].elimₗ([∀].elim([∀].elim([⋃]-membership){ss}){x}))
                        ([∃].intro{_}
                          {y}
                          ([∧].intro
                            -- y ∈ ss
                            (yinss)

                            -- x ∈ y
                            ([→].elim
                              ([∀].elim(allssinssxins){y})
                              (yinss)
                            )
                          )
                        )
                      ))
                      (existsyinss)
                    )
                  )
                  (Empty-excluded-middle{ss})
                )

                -- ∀(s∊ss). x∈s
                (allssinssxins)
              )
            )
          )

          -- (⟶)-case
          (xinintersectss ↦
            ([∀].intro (\{s} →
              ([→].intro (sinss ↦
                ([→].elim
                  ([∀].elim
                    ([∧].elimᵣ
                      ([↔].elimᵣ
                        ([∀].elim
                          ([∀].elim
                            filter-membership
                            {⋃(ss)}
                          )
                          {x}
                        )
                        (xinintersectss)
                      )
                    )
                    {s}
                  )
                  (sinss)
                )
              ))
            ))
          )
        )
      ))
    ))
    where postulate proof : ∀{a} → a

-- postulate any : ∀{l}{a : Set(l)} → a

-- TODO: Just used for reference. Remove these lines later
-- ⋂(a) = filter(⋃(ss)) (x ↦ ∀ₗ(a₂ ↦ (a₂ ∈ ss) ⟶ (x ∈ a₂)))
-- filter-membership : ∀{φ : Domain → Formula} → Proof(∀ₗ(s ↦ ∀ₗ(x ↦ ((x ∈ filter(s)(φ)) ⟷ ((x ∈ s) ∧ φ(x))))))
-- [⋃]-membership : Proof(∀ₗ(ss ↦ ∀ₗ(x ↦ (x ∈ ⋃(ss)) ⟷ ∃ₗ(s ↦ (s ∈ ss)∧(x ∈ s)))))

-- [⨯]-membership : Proof(∀ₗ(a ↦ ∀ₗ(b ↦ ∀ₗ(x ↦ (x ∈ (a ⨯ b)) ⟷ ∃ₛ(a)(x₁ ↦ ∃ₛ(b)(x₂ ↦ x ≡ (x₁ , x₂)))))))
-- [⨯]-membership =

-- [⋃][℘]-inverse : Proof(∀ₗ(s ↦ ⋃(℘(s)) ≡ s))

-- TODO: https://planetmath.org/SurjectionAndAxiomOfChoice


------------------------------------------------------------------------
-- The Agda standard library
--
-- Bounded vectors (inefficient implementation)
------------------------------------------------------------------------

-- Vectors of a specified maximum length.

module Data.Star.BoundedVec where

open import Data.Star
open import Data.Star.Nat
open import Data.Star.Decoration
open import Data.Star.Pointer
open import Data.Star.List using (List)
open import Data.Unit
open import Function
import Data.Maybe as Maybe
open import Relation.Binary
open import Relation.Binary.Consequences

------------------------------------------------------------------------
-- The type

-- Finite sets decorated with elements (note the use of suc).

BoundedVec : Set → ℕ → Set
BoundedVec a n = Any (λ _ → a) (λ _ → ⊤) (suc n)

[] : ∀ {a n} → BoundedVec a n
[] = this tt

infixr 5 _∷_

_∷_ : ∀ {a n} → a → BoundedVec a n → BoundedVec a (suc n)
_∷_ = that

------------------------------------------------------------------------
-- Increasing the bound

-- Note that this operation is linear in the length of the list.

↑ : ∀ {a n} → BoundedVec a n → BoundedVec a (suc n)
↑ {a} = gmap inc lift
  where
  inc = Maybe.map (map-NonEmpty suc)

  lift : Pointer (λ _ → a) (λ _ → ⊤) =[ inc ]⇒
         Pointer (λ _ → a) (λ _ → ⊤)
  lift (step x) = step x
  lift (done _) = done _

------------------------------------------------------------------------
-- Conversions

fromList : ∀ {a} → (xs : List a) → BoundedVec a (length xs)
fromList ε        = []
fromList (x ◅ xs) = x ∷ fromList xs

toList : ∀ {a n} → BoundedVec a n → List a
toList xs = gmap (const tt) decoration (init xs)


{-# OPTIONS --cubical --safe #-}
module Cubical.Data.List.Properties where

open import Agda.Builtin.List
open import Cubical.Core.Everything
open import Cubical.Foundations.HLevels
open import Cubical.Foundations.Prelude
open import Cubical.Data.Empty
open import Cubical.Data.Nat
open import Cubical.Data.Prod
open import Cubical.Data.Unit
open import Cubical.Relation.Nullary

open import Cubical.Data.List.Base

module _ {ℓ} {A : Type ℓ} where

  ++-unit-r : (xs : List A) → xs ++ [] ≡ xs
  ++-unit-r [] = refl
  ++-unit-r (x ∷ xs) = cong (_∷_ x) (++-unit-r xs)

  ++-assoc : (xs ys zs : List A) → (xs ++ ys) ++ zs ≡ xs ++ ys ++ zs
  ++-assoc [] ys zs = refl
  ++-assoc (x ∷ xs) ys zs = cong (_∷_ x) (++-assoc xs ys zs)

  rev-++ : (xs ys : List A) → rev (xs ++ ys) ≡ rev ys ++ rev xs
  rev-++ [] ys = sym (++-unit-r (rev ys))
  rev-++ (x ∷ xs) ys =
    cong (λ zs → zs ++ [ x ]) (rev-++ xs ys)
    ∙ ++-assoc (rev ys) (rev xs) [ x ]

  rev-rev : (xs : List A) → rev (rev xs) ≡ xs
  rev-rev [] = refl
  rev-rev (x ∷ xs) = rev-++ (rev xs) [ x ] ∙ cong (_∷_ x) (rev-rev xs)

-- Path space of list type
module ListPath {ℓ} {A : Type ℓ} where

  Cover : List A → List A → Type ℓ
  Cover [] [] = Lift Unit
  Cover [] (_ ∷ _) = Lift ⊥
  Cover (_ ∷ _) [] = Lift ⊥
  Cover (x ∷ xs) (y ∷ ys) = (x ≡ y) × Cover xs ys

  reflCode : ∀ xs → Cover xs xs
  reflCode [] = lift tt
  reflCode (_ ∷ xs) = refl , reflCode xs

  encode : ∀ xs ys → (p : xs ≡ ys) → Cover xs ys
  encode xs _ = J (λ ys _ → Cover xs ys) (reflCode xs)

  encodeRefl : ∀ xs → encode xs xs refl ≡ reflCode xs
  encodeRefl xs = JRefl (λ ys _ → Cover xs ys) (reflCode xs)

  decode : ∀ xs ys → Cover xs ys → xs ≡ ys
  decode [] [] _ = refl
  decode [] (_ ∷ _) (lift ())
  decode (x ∷ xs) [] (lift ())
  decode (x ∷ xs) (y ∷ ys) (p , c) = cong₂ _∷_ p (decode xs ys c)

  decodeRefl : ∀ xs → decode xs xs (reflCode xs) ≡ refl
  decodeRefl [] = refl
  decodeRefl (x ∷ xs) = cong (cong₂ _∷_ refl) (decodeRefl xs)

  decodeEncode : ∀ xs ys → (p : xs ≡ ys) → decode xs ys (encode xs ys p) ≡ p
  decodeEncode xs _ =
    J (λ ys p → decode xs ys (encode xs ys p) ≡ p)
      (cong (decode xs xs) (encodeRefl xs) ∙ decodeRefl xs)

  isOfHLevelCover : (n : ℕ) (p : isOfHLevel (suc (suc n)) A)
    (xs ys : List A) → isOfHLevel (suc n) (Cover xs ys)
  isOfHLevelCover n p [] [] =
    isOfHLevelLift (suc n)
      (subst (λ m → isOfHLevel m Unit) (+-comm n 1)
        (hLevelLift n isPropUnit))
  isOfHLevelCover n p [] (y ∷ ys) =
    isOfHLevelLift (suc n)
      (subst (λ m → isOfHLevel m ⊥) (+-comm n 1)
        (hLevelLift n isProp⊥))
  isOfHLevelCover n p (x ∷ xs) [] =
    isOfHLevelLift (suc n)
      (subst (λ m → isOfHLevel m ⊥) (+-comm n 1)
        (hLevelLift n isProp⊥))
  isOfHLevelCover n p (x ∷ xs) (y ∷ ys) =
    hLevelProd (suc n) (p x y) (isOfHLevelCover n p xs ys)

isOfHLevelList : ∀ {ℓ} (n : ℕ) {A : Type ℓ}
  → isOfHLevel (suc (suc n)) A → isOfHLevel (suc (suc n)) (List A)
isOfHLevelList n ofLevel xs ys =
  retractIsOfHLevel (suc n)
    (ListPath.encode xs ys)
    (ListPath.decode xs ys)
    (ListPath.decodeEncode xs ys)
    (ListPath.isOfHLevelCover n ofLevel xs ys)

private
  variable
    ℓ : Level
    A : Type ℓ

  caseList : ∀ {ℓ ℓ'} {A : Type ℓ} {B : Type ℓ'} → (n c : B) → List A → B
  caseList n _ []      = n
  caseList _ c (_ ∷ _) = c

  safe-head : A → List A → A
  safe-head x []      = x
  safe-head _ (x ∷ _) = x

  safe-tail : List A → List A
  safe-tail []       = []
  safe-tail (_ ∷ xs) = xs

cons-inj₁ : ∀ {x y : A} {xs ys} → x ∷ xs ≡ y ∷ ys → x ≡ y
cons-inj₁ {x = x} p = cong (safe-head x) p

cons-inj₂ : ∀ {x y : A} {xs ys} → x ∷ xs ≡ y ∷ ys → xs ≡ ys
cons-inj₂ = cong safe-tail

¬cons≡nil : ∀ {x : A} {xs} → ¬ (x ∷ xs ≡ [])
¬cons≡nil {A = A} p = lower (subst (caseList (Lift ⊥) (List A)) p [])

¬nil≡cons : ∀ {x : A} {xs} → ¬ ([] ≡ x ∷ xs)
¬nil≡cons {A = A} p = lower (subst (caseList (List A) (Lift ⊥)) p [])

¬snoc≡nil : ∀ {x : A} {xs} → ¬ (xs ∷ʳ x ≡ [])
¬snoc≡nil {xs = []} contra = ¬cons≡nil contra
¬snoc≡nil {xs = x ∷ xs} contra = ¬cons≡nil contra

¬nil≡snoc : ∀ {x : A} {xs} → ¬ ([] ≡ xs ∷ʳ x)
¬nil≡snoc contra = ¬snoc≡nil (sym contra)

cons≡rev-snoc : (x : A) → (xs : List A) → x ∷ rev xs ≡ rev (xs ∷ʳ x)
cons≡rev-snoc _ [] = refl
cons≡rev-snoc x (y ∷ ys) = λ i → cons≡rev-snoc x ys i ++ y ∷ []

nil≡nil-isContr : isContr (Path (List A) [] [])
nil≡nil-isContr = refl , ListPath.decodeEncode [] []

list≡nil-isProp : {xs : List A} → isProp (xs ≡ [])
list≡nil-isProp {xs = []} = hLevelSuc 0 _ nil≡nil-isContr
list≡nil-isProp {xs = x ∷ xs} = λ p _ → ⊥-elim (¬cons≡nil p)

discreteList : Discrete A → Discrete (List A)
discreteList eqA []       []       = yes refl
discreteList eqA []       (y ∷ ys) = no ¬nil≡cons
discreteList eqA (x ∷ xs) []       = no ¬cons≡nil
discreteList eqA (x ∷ xs) (y ∷ ys) with eqA x y | discreteList eqA xs ys
... | yes p | yes q = yes (λ i → p i ∷ q i)
... | yes _ | no ¬q = no (λ p → ¬q (cons-inj₂ p))
... | no ¬p | _     = no (λ q → ¬p (cons-inj₁ q))


module Prelude where

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

open import Agda.Primitive public
  using (Level ; _⊔_)
  renaming (lzero to ℓ₀)

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

_◎_ : ∀ {ℓ ℓ′ ℓ″} → {X : Set ℓ} {P : X → Set ℓ′} {Q : ∀ {x} → P x → Set ℓ″}
                  → (g : ∀ {x} → (y : P x) → Q y) (f : (x : X) → P x) (x : X)
                  → Q (f x)
(g ◎ f) x = g (f x)

const : ∀ {ℓ ℓ′} → {X : Set ℓ} {Y : Set ℓ′}
                 → X → Y → X
const x y = x

flip : ∀ {ℓ ℓ′ ℓ″} → {X : Set ℓ} {Y : Set ℓ′} {Z : X → Y → Set ℓ″}
                   → (f : (x : X) (y : Y) → Z x y) (y : Y) (x : X)
                   → Z x y
flip f y x = f x y

_∘_ : ∀ {ℓ ℓ′ ℓ″} → {X : Set ℓ} {Y : Set ℓ′} {Z : Set ℓ″}
                  → (g : Y → Z) (f : X → Y)
                  → X → Z
g ∘ f = g ◎ f

_⨾_ : ∀ {ℓ ℓ′ ℓ″} → {X : Set ℓ} {Y : Set ℓ′} {Z : Set ℓ″}
                  → (f : X → Y) (g : Y → Z)
                  → X → Z
_⨾_ = flip _∘_

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

open import Agda.Builtin.Equality public
  using (_≡_ ; refl)

_⁻¹≡ : ∀ {ℓ} → {X : Set ℓ} {x₁ x₂ : X}
             → x₁ ≡ x₂ → x₂ ≡ x₁
refl ⁻¹≡ = refl

_⦙≡_ : ∀ {ℓ} → {X : Set ℓ} {x₁ x₂ x₃ : X}
             → x₁ ≡ x₂ → x₂ ≡ x₃ → x₁ ≡ x₃
refl ⦙≡ refl = refl

record PER {ℓ}
           (X : Set ℓ)
           (_≈_ : X → X → Set ℓ)
         : Set ℓ where
  infix  9 _⁻¹
  infixr 4 _⦙_
  field
    _⁻¹ : ∀ {x₁ x₂} → x₁ ≈ x₂
                    → x₂ ≈ x₁

    _⦙_ : ∀ {x₁ x₂ x₃} → x₁ ≈ x₂ → x₂ ≈ x₃
                       → x₁ ≈ x₃

open PER {{…}} public

instance
  per≡ : ∀ {ℓ} {X : Set ℓ} → PER X _≡_
  per≡ =
    record
      { _⁻¹ = _⁻¹≡
      ; _⦙_ = _⦙≡_
      }

infixl 9 _&_
_&_ : ∀ {ℓ ℓ′} → {X : Set ℓ} {Y : Set ℓ′} {x₁ x₂ : X}
               → (f : X → Y) → x₁ ≡ x₂
               → f x₁ ≡ f x₂
f & refl = refl

infixl 8 _⊗_
_⊗_ : ∀ {ℓ ℓ′} → {X : Set ℓ} {Y : Set ℓ′} {f₁ f₂ : X → Y} {x₁ x₂ : X}
               → f₁ ≡ f₂ → x₁ ≡ x₂
               → f₁ x₁ ≡ f₂ x₂
refl ⊗ refl = refl

case_of_ : ∀ {ℓ ℓ′} → {X : Set ℓ} {Y : Set ℓ′}
                    → X → (X → Y) → Y
case x of f = f x

coe : ∀ {ℓ} → {X Y : Set ℓ}
            → X ≡ Y → X → Y
coe refl x = x

postulate
  fext! : ∀ {ℓ ℓ′} → {X : Set ℓ} {P : X → Set ℓ′} {f₁ f₂ : (x : X) → P x}
                   → ((x : X) → f₁ x ≡ f₂ x)
                   → f₁ ≡ f₂

  fext¡ : ∀ {ℓ ℓ′} → {X : Set ℓ} {P : X → Set ℓ′} {f₁ f₂ : {x : X} → P x}
                   → ({x : X} → f₁ {x} ≡ f₂ {x})
                   → (λ {x} → f₁ {x}) ≡ (λ {x} → f₂ {x})

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

open import Agda.Builtin.Unit public
  using (⊤ ; tt)

data ⊥ : Set where

elim⊥ : ∀ {ℓ} → {X : Set ℓ}
               → ⊥ → X
elim⊥ ()

¬_ : ∀ {ℓ} → Set ℓ → Set ℓ
¬ X = X → ⊥

Π : ∀ {ℓ ℓ′} → Set ℓ → Set ℓ′ → Set (ℓ ⊔ ℓ′)
Π X Y = X → Y

infixl 6 _,_
record Σ {ℓ ℓ′}
         (X : Set ℓ) (P : X → Set ℓ′)
       : Set (ℓ ⊔ ℓ′) where
  instance
    constructor _,_
  field
    proj₁ : X

    proj₂ : P proj₁

open Σ public

infixl 5 _⁏_
pattern _⁏_ x y = x , y

infixl 2 _×_
_×_ : ∀ {ℓ ℓ′} → Set ℓ → Set ℓ′ → Set (ℓ ⊔ ℓ′)
X × Y = Σ X (λ x → Y)

mapΣ : ∀ {ℓ ℓ′ ℓ″ ℓ‴} → {X : Set ℓ} {Y : Set ℓ′} {P : X → Set ℓ″} {Q : Y → Set ℓ‴}
                      → (f : X → Y) (g : ∀ {x} → P x → Q (f x)) → Σ X P
                      → Σ Y Q
mapΣ f g (x , y) = f x , g y

caseΣ : ∀ {ℓ ℓ′ ℓ″ ℓ‴} → {X : Set ℓ} {Y : Set ℓ′} {P : X → Set ℓ″} {Q : Y → Set ℓ‴}
                       → Σ X P → (f : X → Y) (g : ∀ {x} → P x → Q (f x))
                       → Σ Y Q
caseΣ p f g = mapΣ f g p

infixl 1 _⊎_
data _⊎_ {ℓ ℓ′}
         (X : Set ℓ) (Y : Set ℓ′)
       : Set (ℓ ⊔ ℓ′) where
  inj₁ : (x : X) → X ⊎ Y
  inj₂ : (y : Y) → X ⊎ Y

elim⊎ : ∀ {ℓ ℓ′ ℓ″} → {X : Set ℓ} {Y : Set ℓ′} {Z : Set ℓ″}
                    → X ⊎ Y → (X → Z) → (Y → Z)
                    → Z
elim⊎ (inj₁ x) f g = f x
elim⊎ (inj₂ y) f g = g y

map⊎ : ∀ {ℓ ℓ′ ℓ″ ℓ‴} → {X : Set ℓ} {Y : Set ℓ′} {Z₁ : Set ℓ″} {Z₂ : Set ℓ‴}
                      → (X → Z₁) → (Y → Z₂) → X ⊎ Y
                      → Z₁ ⊎ Z₂
map⊎ f g s = elim⊎ s (inj₁ ∘ f) (inj₂ ∘ g)

case⊎ : ∀ {ℓ ℓ′ ℓ″ ℓ‴} → {X : Set ℓ} {Y : Set ℓ′} {Z₁ : Set ℓ″} {Z₂ : Set ℓ‴}
                       → X ⊎ Y → (X → Z₁) → (Y → Z₂)
                       → Z₁ ⊎ Z₂
case⊎ s f g = map⊎ f g s

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

open import Agda.Builtin.Bool public
  using (Bool ; false ; true)

if_then_else_ : ∀ {ℓ} → {X : Set ℓ}
                      → Bool → X → X
                      → X
if_then_else_ true  t f = t
if_then_else_ false t f = f

not : Bool → Bool
not true  = false
not false = true

and : Bool → Bool → Bool
and true  b = b
and false b = false

or : Bool → Bool → Bool
or true  b = true
or false b = b

xor : Bool → Bool → Bool
xor true  b = not b
xor false b = b

data True : Bool → Set
  where
    instance
      yes : True true

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

open import Agda.Builtin.Nat public
  using (Nat ; zero ; suc)
open import Agda.Builtin.FromNat public
  using (Number ; fromNat)

instance
  numNat : Number Nat
  numNat =
    record
      { Constraint = λ n → ⊤
      ; fromNat    = λ n → n
      }

_>?_ : Nat → Nat → Bool
zero  >? k     = false
suc n >? zero  = true
suc n >? suc k = n >? k

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

data Fin : Nat → Set
  where
    zero : ∀ {n} → Fin (suc n)

    suc  : ∀ {n} → Fin n
                 → Fin (suc n)

Nat→Fin : ∀ {n} → (k : Nat) {{_ : True (n >? k)}}
                 → Fin n
Nat→Fin {n = zero}  k       {{()}}
Nat→Fin {n = suc n} zero    {{is-true}} = zero
Nat→Fin {n = suc n} (suc k) {{p}}       = suc (Nat→Fin k {{p}})

instance
  numFin : ∀ {n} → Number (Fin n)
  numFin {n} =
    record
      { Constraint = λ k → True (n >? k)
      ; fromNat    = Nat→Fin
      }

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


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

open import Fragment.Equational.Theory

module Fragment.Equational.Model.Base (Θ : Theory) where

open import Fragment.Equational.Model.Satisfaction {Σ Θ}
open import Fragment.Algebra.Algebra (Σ Θ) hiding (∥_∥/≈)
open import Fragment.Algebra.Free (Σ Θ)

open import Level using (Level; _⊔_; suc)
open import Function using (_∘_)
open import Data.Fin using (Fin)
open import Data.Nat using (ℕ)
open import Relation.Binary using (Setoid)

private
  variable
    a ℓ : Level

Models : Algebra {a} {ℓ} → Set (a ⊔ ℓ)
Models S = ∀ {n} → (eq : eqs Θ n) → S ⊨ (Θ ⟦ eq ⟧ₑ)

module _ (S : Setoid a ℓ) where

  record IsModel : Set (a ⊔ ℓ) where
    field
      isAlgebra : IsAlgebra S
      models    : Models (algebra S isAlgebra)

    open IsAlgebra isAlgebra public

record Model : Set (suc a ⊔ suc ℓ) where
  field
    ∥_∥/≈   : Setoid a ℓ
    isModel : IsModel ∥_∥/≈

  ∥_∥ₐ : Algebra
  ∥_∥ₐ = algebra ∥_∥/≈ (IsModel.isAlgebra isModel)

  ∥_∥ₐ-models : Models ∥_∥ₐ
  ∥_∥ₐ-models = IsModel.models isModel

  open Algebra (algebra ∥_∥/≈ (IsModel.isAlgebra isModel))
    hiding (∥_∥/≈) public

open Model public


open import Nat
open import Prelude
open import Hazelnut-core

-- the obvious small step dynamics for complete expressions.
module Hazelnut-complete-dynamics where
  value : (e : ė) (p : ecomplete e) (t : τ̇) (q : ∅ ⊢ e => t) → Set
  value ._ _ _ (SAsc _) = ⊥
  value ._ _ _ (SVar x) with x
  ... | ()
  value ._ _ _ (SAp _ _) = ⊥
  value ._ _ .num SNum = ⊤
  value ._ _ .num (SPlus _ _) = ⊥
  value .<||> () .<||> SEHole
  value ._ () .<||> (SFHole _)
  value ._ _ .<||> (SApHole _ _) = ⊥

  -- "substitute e1 for x in e2". note that this only works on well typed
  -- terms because of barendrecht's convention. that's a theorem we need to
  -- prove. on non well typed terms, this is not correct.
  [_/_]_ : ė → Nat → ė → ė
  [ e1 / x ] (e2 ·: y)  = ([ e1 / x ] e2) ·: y
  [ e1 / x ] X y with natEQ x y
  ... | Inl p           = e1
  ... | Inr _           = X y
  [ e1 / x ] ·λ y e2    = ·λ y ([ e1 / x ] e2)
  [ e1 / x ] N n        = N n
  [ e1 / x ] (e2 ·+ e3) = ([ e1 / x ] e2) ·+ ([ e1 / x ] e3)
  [ e1 / x ] <||>       = <||>
  [ e1 / x ] <| e2 |>   = <| [ e1 / x ] e2 |>
  [ e1 / x ] (e2 ∘ e3)  = ([ e1 / x ] e2) ∘ ([ e1 / x ] e3)


{-# OPTIONS --cubical --safe #-}
module Cubical.Structures.Pointed where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Equiv
open import Cubical.Foundations.Transport
open import Cubical.Foundations.Univalence
open import Cubical.Foundations.Path

open import Cubical.Foundations.Pointed.Base

open import Cubical.Foundations.SIP renaming (SNS-PathP to SNS)

private
  variable
    ℓ : Level

-- Pointed types with SNS

pointed-structure : Type ℓ → Type ℓ
pointed-structure X = X

pointed-iso : StrIso pointed-structure ℓ
pointed-iso A B f = equivFun f (pt A) ≡ pt B

pointed-is-SNS : SNS {ℓ} pointed-structure pointed-iso
pointed-is-SNS f = invEquiv (ua-ungluePath-Equiv f)

pointed-SIP : (A B : Pointed ℓ) → A ≃[ pointed-iso ] B ≃ (A ≡ B)
pointed-SIP = SIP pointed-structure pointed-iso pointed-is-SNS

pointed-sip : (A B : Pointed ℓ) → A ≃[ pointed-iso ] B → (A ≡ B)
pointed-sip A B = equivFun (pointed-SIP A B) -- ≡ λ (e , p) i → ua e i , ua-gluePath e p i


open import Agda.Primitive
open import Agda.Builtin.Bool
open import Agda.Builtin.Equality

infix 2 _↔_
record _↔_ {a} {b} (p : Set a) (q : Set b) : Set (a ⊔ b) where
  field
    l2r : p → q
    r2l : q → p

_&_ : Bool → Bool → Bool
true & true = true
_ & _ = false

[_] : Bool → Set
[ P ] = P ≡ true

record ∃ {A : Set} (P : A → Bool) : Set where
  field
    {witness} : A
    proof : [ P witness ]

postulate
  U : Set
  set : Set
  subset : set → set → Bool
  int : set → set → set
  mem : ∀ {A : Set} → A → set → Bool
  mapsF : set → set → Bool
  F : ∀ {A B : Set} → A → B → Bool
  same : ∀ {A B : Set} → A → B → Bool
  equal : set → set → Bool
  invF : set → set → set
  subsetMembershipLaw : ∀ {A} {B} → [ subset A B ] ↔ (∀ {M : Set} {x : M} → [ mem x A ] → [ mem x B ])
--  mapsFLaw : ∀ {A} {B} → [ mapsF A B ] ↔ ((∀ {M : Set} {x : M} → [ mem x A ] → ∃ λ (y : M) → mem y B & F x y)

{-
Problem #758
same as problem 757 but rewritten with only expressions of first-order logic
Given premises:
     (all A)(all B)((subset A B) <-> (all x)((mem x A) -> (mem x B)))    justification = 1.0
     (all A)(all B)(some intAB)(IsInt A B intAB)    justification = 1.0
     (all A)(all B)(all intAB)((IsInt A B intAB) <-> (all x)((mem x intAB) <-> ((mem x A) & (mem x B))))    justification = 1.0
     (all A)(all B)((mapsF A B) <-> ((all x)((mem x A) -> (some y)((mem y B) & (F x y))) & (all x)(all y)(all z)(((mem x A) & ((mem y A) & (mem z A))) -> (((F x y) & (F x z)) -> (same y z)))))    justification = 1.0
     (all A)(all x)(all y)((same x y) -> ((mem x A) -> (mem y A)))    justification = 1.0
     (all x)(same x x)    justification = 1.0
     (all x)(all y)((same x y) <-> (same y x))    justification = 1.0
     (all x)(all y)(all z)(((same x y) & (same y z)) -> (same x z))    justification = 1.0
     (all A)(all B)((equal A B) <-> ((subset A B) & (subset B A)))    justification = 1.0
     (all A)(all B)(some invFBA)(IsInvF B A invFBA)    justification = 1.0
     (all A)(all B)(all invFBA)((IsInvF B A invFBA) <-> (all x)((mem x invFBA) <-> ((mem x A) & (some y)((mem y B) & (F x y)))))    justification = 1.0
Ultimate epistemic interests:
     (all A)(all B)(all X)(all Y)(((mapsF A B) & ((subset X B) & (subset Y B))) -> (some intXY)((IsInt X Y intXY) & (some invFIntXYA)((IsInvF intXY A invFIntXYA) & (some invFXA)((IsInvF X A invFXA) & (some invFYA)((IsInvF Y A invFYA) & (some intInvFXAInvFYA)((IsInt invFXA invFYA intInvFXAInvFYA) & (equal invFIntXYA intInvFXAInvFYA)))))))    interest = 1.0
-}


{-
  Definitions for functions
-}
{-# OPTIONS --cubical --safe #-}
module Cubical.Foundations.Function where

open import Cubical.Core.Everything

open import Cubical.Foundations.Prelude

-- The identity function
idfun : ∀ {ℓ} → (A : Type ℓ) → A → A
idfun _ x = x

infixr 9 _∘_

_∘_ : ∀ {ℓ ℓ′ ℓ″} {A : Type ℓ} {B : A → Type ℓ′} {C : (a : A) → B a → Type ℓ″}
        (g : {a : A} → (b : B a) → C a b) → (f : (a : A) → B a) → (a : A) → C a (f a)
g ∘ f = λ x → g (f x)

∘-assoc : ∀ {ℓ ℓ′ ℓ″ ℓ‴} {A : Type ℓ} {B : A → Type ℓ′} {C : (a : A) → B a → Type ℓ″} {D : (a : A) (b : B a) → C a b → Type ℓ‴}
            (h : {a : A} {b : B a} → (c : C a b) → D a b c) (g : {a : A} → (b : B a) → C a b) (f : (a : A) → B a)
          → (h ∘ g) ∘ f ≡ h ∘ (g ∘ f)
∘-assoc h g f i x = h (g (f x))

∘-idˡ : ∀ {ℓ ℓ′} {A : Type ℓ} {B : A → Type ℓ′} (f : (a : A) → B a) → f ∘ idfun A ≡ f
∘-idˡ f i x = f x

∘-idʳ : ∀ {ℓ ℓ′} {A : Type ℓ} {B : A → Type ℓ′} (f : (a : A) → B a) → (λ {a} → idfun (B a)) ∘ f ≡ f
∘-idʳ f i x = f x

const : ∀ {ℓ ℓ′} {A : Type ℓ} {B : Type ℓ′} → A → B → A
const x = λ _ → x

case_of_ : ∀ {ℓ ℓ'} {A : Type ℓ} {B : A → Type ℓ'} → (x : A) → (∀ x → B x) → B x
case x of f = f x

case_return_of_ : ∀ {ℓ ℓ'} {A : Type ℓ} (x : A) (B : A → Type ℓ') → (∀ x → B x) → B x
case x return P of f = f x

uncurry
  : ∀{ℓ ℓ′ ℓ″} {A : Type ℓ} {B : A → Type ℓ′} {C : (a : A) → B a → Type ℓ″}
  → ((x : A) → (y : B x) → C x y)
  → (p : Σ A B) → C (fst p) (snd p)
uncurry f (x , y) = f x y

module _ {ℓ ℓ'} {A : Type ℓ} {B : Type ℓ'} where
  -- Notions of 'coherently constant' functions for low dimensions.
  -- These are the properties of functions necessary to e.g. eliminate
  -- from the propositional truncation.

  -- 2-Constant functions are coherently constant if B is a set.
  2-Constant : (A → B) → Type _
  2-Constant f = ∀ x y → f x ≡ f y

  2-Constant-isProp : isSet B → (f : A → B) → isProp (2-Constant f)
  2-Constant-isProp Bset f link1 link2 i x y j
    = Bset (f x) (f y) (link1 x y) (link2 x y) i j

  -- 3-Constant functions are coherently constant if B is a groupoid.
  record 3-Constant (f : A → B) : Type (ℓ-max ℓ ℓ') where
    field
      link : 2-Constant f
      coh₁ : ∀ x y z → Square refl (link x y) (link x z) (link y z)

    coh₂ : ∀ x y z → Square (link x y) (link x z) (link y z) refl
    coh₂ x y z i j
      = hcomp (λ k → λ
              { (j = i0) → link x y i
              ; (i = i0) → link x z (j ∧ k)
              ; (j = i1) → link x z (i ∨ k)
              ; (i = i1) → link y z j
              })
          (coh₁ x y z j i)

    link≡refl : ∀ x → refl ≡ link x x
    link≡refl x i j
      = hcomp (λ k → λ
              { (i = i0) → link x x (j ∧ ~ k)
              ; (i = i1) → link x x j
              ; (j = i0) → f x
              ; (j = i1) → link x x (~ i ∧ ~ k)
              })
          (coh₁ x x x (~ i) j)

    downleft : ∀ x y → Square refl (link x y) refl (link y x)
    downleft x y i j
      = hcomp (λ k → λ
              { (i = i0) → link x y j
              ; (i = i1) → link≡refl x (~ k) j
              ; (j = i0) → f x
              ; (j = i1) → link y x i
              })
          (coh₁ x y x i j)

    link≡symlink : ∀ x y → link x y ≡ sym (link y x)
    link≡symlink x y i j
      = hcomp (λ k → λ
              { (i = i0) → link x y j
              ; (i = i1) → link y x (~ j ∨ ~ k)
              ; (j = i0) → f x
              ; (j = i1) → link y x (i ∧ ~ k)
              })
          (downleft x y i j)


{-

Functions between structures S and T: X ↦ S X → T X

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

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Equiv
open import Cubical.Foundations.Function
open import Cubical.Foundations.Isomorphism
open import Cubical.Foundations.Path
open import Cubical.Foundations.SIP
open import Cubical.Foundations.Transport
open import Cubical.Foundations.Univalence

open import Cubical.Functions.FunExtEquiv

open import Cubical.Data.Nat
open import Cubical.Data.Vec

private
  variable
    ℓ ℓ₁ ℓ₁' ℓ₂ ℓ₂' : Level

-- General function structure

FunctionStructure : (S : Type ℓ → Type ℓ₁) (T : Type ℓ → Type ℓ₂)
  → Type ℓ → Type (ℓ-max ℓ₁ ℓ₂)
FunctionStructure S T X = S X → T X

FunctionEquivStr : {S : Type ℓ → Type ℓ₁} {T : Type ℓ → Type ℓ₂}
  → StrEquiv S ℓ₁' → StrEquiv T ℓ₂'
  → StrEquiv (FunctionStructure S T) (ℓ-max ℓ₁ (ℓ-max ℓ₁' ℓ₂'))
FunctionEquivStr {S = S} {T} ι₁ ι₂ (X , f) (Y , g) e =
  {s : S X} {t : S Y} → ι₁ (X , s) (Y , t) e → ι₂ (X , f s) (Y , g t) e

functionUnivalentStr : {S : Type ℓ → Type ℓ₁} {T : Type ℓ → Type ℓ₂}
  (ι₁ : StrEquiv S ℓ₁') (θ₁ : UnivalentStr S ι₁)
  (ι₂ : StrEquiv T ℓ₂') (θ₂ : UnivalentStr T ι₂)
  → UnivalentStr (FunctionStructure S T) (FunctionEquivStr ι₁ ι₂)
functionUnivalentStr ι₁ θ₁ ι₂ θ₂ e =
  compEquiv
    (equivImplicitΠCod (equivImplicitΠCod (equiv→ (θ₁ e) (θ₂ e))))
    funExtDepEquiv

functionEquivAction : {S : Type ℓ → Type ℓ₁} {T : Type ℓ → Type ℓ₂}
  → EquivAction S → EquivAction T
  → EquivAction (FunctionStructure S T)
functionEquivAction α₁ α₂ e = equiv→ (α₁ e) (α₂ e)

functionTransportStr : {S : Type ℓ → Type ℓ₁} {T : Type ℓ → Type ℓ₂}
  (α₁ : EquivAction S) (τ₁ : TransportStr α₁)
  (α₂ : EquivAction T) (τ₂ : TransportStr α₂)
  → TransportStr (functionEquivAction α₁ α₂)
functionTransportStr {S = S} α₁ τ₁ α₂ τ₂ e f =
  funExt λ t →
  cong (equivFun (α₂ e) ∘ f) (invTransportStr α₁ τ₁ e t)
  ∙ τ₂ e (f (subst⁻ S (ua e) t))

-- Definition of structured equivalence using an action in the domain

FunctionEquivStr+ : {S : Type ℓ → Type ℓ₁} {T : Type ℓ → Type ℓ₂}
  → EquivAction S → StrEquiv T ℓ₂'
  → StrEquiv (FunctionStructure S T) (ℓ-max ℓ₁ ℓ₂')
FunctionEquivStr+ {S = S} {T} α₁ ι₂ (X , f) (Y , g) e =
  (s : S X) → ι₂ (X , f s) (Y , g (equivFun (α₁ e) s)) e

functionUnivalentStr+ : {S : Type ℓ → Type ℓ₁} {T : Type ℓ → Type ℓ₂}
  (α₁ : EquivAction S) (τ₁ : TransportStr α₁)
  (ι₂ : StrEquiv T ℓ₂') (θ₂ : UnivalentStr T ι₂)
  → UnivalentStr (FunctionStructure S T) (FunctionEquivStr+ α₁ ι₂)
functionUnivalentStr+ {S = S} {T} α₁ τ₁ ι₂ θ₂ {X , f} {Y , g} e =
  compEquiv
    (compEquiv
      (equivΠCod λ s →
        compEquiv
          (θ₂ e)
          (pathToEquiv (cong (PathP (λ i → T (ua e i)) (f s) ∘ g) (τ₁ e s))))
      (invEquiv heteroHomotopy≃Homotopy))
    funExtDepEquiv


------------------------------------------------------------------------
-- Laws related to _∣_ and fail
------------------------------------------------------------------------

module TotalParserCombinators.Laws.AdditiveMonoid where

open import Algebra
open import Codata.Musical.Notation
import Data.List.Relation.Binary.BagAndSetEquality as Eq
open import Data.Product using (proj₁; proj₂)
open import Function

private
  module BagMonoid {k} {A : Set} =
    CommutativeMonoid (Eq.commutativeMonoid k A)

open import TotalParserCombinators.Derivative
open import TotalParserCombinators.Congruence
open import TotalParserCombinators.Parser

------------------------------------------------------------------------
-- _∣_ and fail form a commutative monoid

-- This monoid is idempotent if language equivalence is used.

commutative : ∀ {Tok R xs₁ xs₂}
              (p₁ : Parser Tok R xs₁) (p₂ : Parser Tok R xs₂) →
              p₁ ∣ p₂ ≅P p₂ ∣ p₁
commutative {xs₁ = xs₁} {xs₂} p₁ p₂ =
  BagMonoid.comm xs₁ xs₂ ∷ λ t → ♯ commutative (D t p₁) (D t p₂)

left-identity : ∀ {Tok R xs} (p : Parser Tok R xs) → fail ∣ p ≅P p
left-identity {xs = xs} p =
  proj₁ BagMonoid.identity xs ∷ λ t → ♯ left-identity (D t p)

right-identity : ∀ {Tok R xs} (p : Parser Tok R xs) → p ∣ fail ≅P p
right-identity {xs = xs} p =
  proj₂ BagMonoid.identity xs ∷ λ t → ♯ right-identity (D t p)

associative : ∀ {Tok R xs₁ xs₂ xs₃}
              (p₁ : Parser Tok R xs₁) (p₂ : Parser Tok R xs₂)
              (p₃ : Parser Tok R xs₃) →
              (p₁ ∣ p₂) ∣ p₃ ≅P p₁ ∣ (p₂ ∣ p₃)
associative {xs₁ = xs₁} p₁ p₂ p₃ =
  BagMonoid.assoc xs₁ _ _ ∷ λ t →
  ♯ associative (D t p₁) (D t p₂) (D t p₃)

-- Note that this law uses language equivalence, not parser
-- equivalence.

idempotent : ∀ {Tok R xs} (p : Parser Tok R xs) → p ∣ p ≈P p
idempotent {xs = xs} p =
  Eq.++-idempotent xs ∷ λ t → ♯ idempotent (D t p)

------------------------------------------------------------------------
-- A lemma which can be convenient when proving distributivity laws

swap : ∀ {Tok R xs₁ xs₂ xs₃ xs₄}
       (p₁ : Parser Tok R xs₁) (p₂ : Parser Tok R xs₂)
       (p₃ : Parser Tok R xs₃) (p₄ : Parser Tok R xs₄) →
       (p₁ ∣ p₂) ∣ (p₃ ∣ p₄) ≅P (p₁ ∣ p₃) ∣ (p₂ ∣ p₄)
swap p₁ p₂ p₃ p₄ =
  (p₁ ∣ p₂) ∣ (p₃ ∣ p₄)  ≅⟨ associative p₁ p₂ (p₃ ∣ p₄) ⟩
  p₁ ∣ (p₂ ∣ (p₃ ∣ p₄))  ≅⟨ (p₁ ∎) ∣ (
    p₂ ∣ (p₃ ∣ p₄)            ≅⟨ sym $ associative p₂ p₃ p₄ ⟩
    (p₂ ∣ p₃) ∣ p₄            ≅⟨ commutative p₂ p₃ ∣ (p₄ ∎) ⟩
    (p₃ ∣ p₂) ∣ p₄            ≅⟨ associative p₃ p₂ p₄ ⟩
    p₃ ∣ (p₂ ∣ p₄)            ∎) ⟩
  p₁ ∣ (p₃ ∣ (p₂ ∣ p₄))  ≅⟨ sym $ associative p₁ p₃ (p₂ ∣ p₄) ⟩
  (p₁ ∣ p₃) ∣ (p₂ ∣ p₄)  ∎


@0 F : @0 Set → Set
F A = λ { → A }


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

module Issue203 where

open import Common.Level

-- Should work but give unsolved metas (type of b)
data ↓ {a b} (A : Set a) : Set a where
  [_] : (x : A) → ↓ A

mutual -- avoid freezing

  -- Shouldn't instantiate the level of Σ to a
  data Σ {a b} (A : Set a) (B : A → Set b) : Set _ where
    _,_ : (x : A) (y : B x) → Σ A B

  instantiateToMax : ∀ {a b}(A : Set a)(B : A → Set b) → Set (a ⊔ b)
  instantiateToMax = Σ


module Truncation where

open import Cubical.Foundations.Prelude

private
  variable
    ℓ ℓ₁ : Level

data Susp (A : Type ℓ) : Type ℓ where
  north : Susp A
  south : Susp A
  merid : A → north ≡ south

SuspF : {A : Type ℓ} {B : Type ℓ₁} → (A → B) → Susp A → Susp B
SuspF f north = north
SuspF f south = south
SuspF f (merid a i) = merid (f a) i

data ℕ : Type where
  zero : ℕ
  suc : ℕ → ℕ

{-# BUILTIN NATURAL ℕ #-}

data ⊥ : Type where

S : ℕ → Type
S 0 = ⊥
S (suc n) = Susp (S n)

data ⊤ : Type where
  ⋆ : ⊤

D : ℕ → Type
D 0 = ⊤
D (suc n) = Susp (D n)

S→D : {n : ℕ} → S n → D n
S→D {suc n} = SuspF S→D

data ∥_∥_ (A : Type ℓ) (n : ℕ) : Type ℓ where
  ∣_∣ : A → ∥ A ∥ n
  hub : (f : S n → ∥ A ∥ n) (u : D n) → ∥ A ∥ n
  spoke : (f : S n → ∥ A ∥ n) (s : S n) → f s ≡ hub f (S→D s)

isOfHLevel : ℕ → Type ℓ → Type ℓ
isOfHLevel 0 A = A
isOfHLevel (suc n) A = (x y : A) → isOfHLevel n (x ≡ y)

sphereFill : (n : ℕ) (A : Type ℓ) (f : S n → A) → Type ℓ
sphereFill n A f = Σ (D n → A) (λ f' → (s : S n) → f s ≡ f' (S→D s))

isSphereFilled : ℕ → Type ℓ → Type ℓ
isSphereFilled n A = (f : S n → A) → sphereFill n A f

isSphereFilled∥∥ : (n : ℕ) (A : Type ℓ) → isSphereFilled n (∥ A ∥ n)
isSphereFilled∥∥ n A f = hub f , spoke f

isSphereFilledDesc : (n : ℕ) (A : Type ℓ)
  → isSphereFilled (suc n) A → (x y : A) → isSphereFilled n (x ≡ y)
isSphereFilledDesc n A h x y g = g' , r
  where
  f : S (suc n) → A
  f north = x
  f south = y
  f (merid u i) = g u i

  g' : D n → x ≡ y
  g' u i =
    hcomp
      (λ j →
        λ { (i = i0) → h f .snd north (~ j)
          ; (i = i1) → h f .snd south (~ j) })
      (h f .fst (merid u i))

  r : (s : S n) → g s ≡ g' (S→D s)
  r s i j =
    hcomp
      (λ k →
        λ { (i = i0) → g s j
          ; (j = i0) → h f .snd north (i ∧ ~ k)
          ; (j = i1) → h f .snd south (i ∧ ~ k) })
      (h f .snd (merid s j) i)

isSphereFilled→isOfHLevel : (n : ℕ) (A : Type ℓ)
  → isSphereFilled n A → isOfHLevel n A
isSphereFilled→isOfHLevel zero A h = h (λ ()) .fst ⋆
isSphereFilled→isOfHLevel (suc n) A h x y =
  isSphereFilled→isOfHLevel n (x ≡ y) (isSphereFilledDesc n A h x y)

isSphereFilledAsc : (n : ℕ) (A : Type ℓ)
  → ((x y : A) → isSphereFilled n (x ≡ y)) → isSphereFilled (suc n) A
isSphereFilledAsc n A h f = f' , r
  where
  g : S n → f north ≡ f south
  g s i = f (merid s i)

  f' : D (suc n) → A
  f' north = f north
  f' south = f south
  f' (merid u i) = h (f north) (f south) g .fst u i

  r : (s : S (suc n)) → f s ≡ f' (S→D s)
  r north = refl
  r south = refl
  r (merid s i) j = h (f north) (f south) g .snd s j i

isOfHLevel→isSphereFilled : (n : ℕ) (A : Type ℓ)
  → isOfHLevel n A → isSphereFilled n A
isOfHLevel→isSphereFilled 0 A h f = (λ _ → h) , λ ()
isOfHLevel→isSphereFilled (suc n) A h f =
  isSphereFilledAsc n A
    (λ x y → isOfHLevel→isSphereFilled n (x ≡ y) (h x y)) f

isOfHLevelTrunc : (n : ℕ) (A : Type ℓ) → isOfHLevel n (∥ A ∥ n)
isOfHLevelTrunc n A = isSphereFilled→isOfHLevel n (∥ A ∥ n) (isSphereFilled∥∥ n A)

rec : {n : ℕ} {A : Type ℓ} {B : Type ℓ₁}
  → isOfHLevel n B
  → (A → B) → ∥ A ∥ n → B
rec {n = n} {A = A} {B = B} hB g = helper
  where
  h : isSphereFilled n B
  h = isOfHLevel→isSphereFilled n B hB

  helper : ∥ A ∥ n → B
  helper ∣ x ∣ = g x
  helper (hub f u) = h (λ s → helper (f s)) .fst u
  helper (spoke f s i) = h (λ s → helper (f s)) .snd s i

sphereFillDep : (n : ℕ) (A : Type ℓ) (B : A → Type ℓ₁)
  (f₀' : D n → A)
  → ((s : S n) → B (f₀' (S→D s)))
  → Type _
sphereFillDep n A B f₀' f = Σ ((u : D n) → B (f₀' u)) (λ f' → (s : S n) → f s ≡ f' (S→D s))

isSphereFilledDep : ℕ → (A : Type ℓ) (B : A → Type ℓ₁) → Type _
isSphereFilledDep n A B =
  (f₀' : D n → A)
  (f : (s : S n) → B (f₀' (S→D s)))
  → sphereFillDep n A B f₀' f

isSphereFilledDepAsc : (n : ℕ) {A : Type ℓ} (B : A → Type ℓ₁)
  → ((x₀ y₀ : A) (x₁ : B x₀) (y₁ : B y₀) → isSphereFilledDep n (x₀ ≡ y₀) (λ p → PathP (λ i → B (p i)) x₁ y₁))
  → isSphereFilledDep (suc n) A B
isSphereFilledDepAsc n {A = A} B hB f₀' f = f' , r
  where
  g₀' : (u : D n) → f₀' north ≡ f₀' south
  g₀' u i = f₀' (merid u i)

  g : (s : S n)  → PathP (λ i → B (g₀' (S→D s) i)) (f north) (f south)
  g s i = f (merid s i)

  f' : (u : D (suc n)) → B (f₀' u)
  f' north = f north
  f' south = f south
  f' (merid u i) = hB (f₀' north) (f₀' south) (f north) (f south) g₀' g .fst u i

  r : (s : S (suc n)) → f s ≡ f' (S→D s)
  r north = refl
  r south = refl
  r (merid s i) j = hB (f₀' north) (f₀' south) (f north) (f south) g₀' g .snd s j i

isOfHLevel→isSphereFilledDep : (n : ℕ) {A : Type ℓ} (B : A → Type ℓ₁)
  → ((a : A) → isOfHLevel n (B a)) → isSphereFilledDep n A B
isOfHLevel→isSphereFilledDep 0 B hB f₀' f = (λ u → hB (f₀' u)) , λ ()
isOfHLevel→isSphereFilledDep (suc n) {A = A} B hB =
  isSphereFilledDepAsc n B
    (λ x₀ y₀ x₁ y₁ →
      isOfHLevel→isSphereFilledDep n {A = x₀ ≡ y₀} (λ p → PathP (λ i → B (p i)) x₁ y₁)
        (λ p → J (λ y₀ p → (y₁ : B y₀) → isOfHLevel n (PathP (λ i → B (p i)) x₁ y₁)) (hB x₀ x₁) p y₁))

elim : {n : ℕ} {A : Type ℓ} {B : ∥ A ∥ n → Type ℓ₁}
  (hB : (x : ∥ A ∥ n) → isOfHLevel n (B x))
  (g : (a : A) → B (∣ a ∣)) (x : ∥ A ∥ n) → B x
elim {n = n} {A = A} {B = B} hB g = helper
  where
  h : isSphereFilledDep n (∥ A ∥ n) B
  h = isOfHLevel→isSphereFilledDep n B hB

  helper : (x : ∥ A ∥ n) → B x
  helper ∣ a ∣ = g a
  helper (hub f u) = h (hub f) (λ s → subst B (spoke f s) (helper (f s))) .fst u
  helper (spoke f s i) =
    hcomp
      (λ j →
        λ { (i = i0) → helper (f s)
          ; (i = i1) →  h (hub f) (λ s → subst B (spoke f s) (helper (f s))) .snd s j })
      (subst-filler B (spoke f s) (helper (f s)) i)


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

-- The category of Cats is Monoidal

module Categories.Category.Monoidal.Instance.StrictCats where

open import Level
open import Data.Product using (Σ; _×_; _,_; proj₁; proj₂; uncurry)
open import Relation.Binary.PropositionalEquality as ≡
  using (_≡_; refl; cong₂; sym; module ≡-Reasoning; subst₂; cong)
open import Function using (_$_)
open import Data.Unit using (⊤; tt)

open import Categories.Category
open import Categories.Functor using (Functor; _∘F_) renaming (id to idF)
open import Categories.Category.Instance.StrictCats
open import Categories.Category.Instance.One using (One)
open import Categories.Category.Monoidal
open import Categories.Functor.Bifunctor
open import Categories.Functor.Construction.Constant
open import Categories.Functor.Equivalence
open import Categories.Category.Product
open import Categories.Category.Product.Properties
import Categories.Category.Cartesian as Cartesian
import Categories.Morphism.HeterogeneousIdentity as HId
import Categories.Morphism.HeterogeneousIdentity.Properties as HIdProps
import Categories.Morphism.Reasoning as MR
open import Categories.Object.Terminal
open import Categories.Utils.Product using (zipWith)
open import Categories.Utils.EqReasoning

-- (Strict) Cats is a (strict) Monoidal Category with Product as Bifunctor
module Product {o ℓ e : Level} where
  private
    C = Cats o ℓ e
    open Cartesian C
    open _≡F_

  Cats-has-all : BinaryProducts
  Cats-has-all = record { product = λ {A} {B} → record
    { A×B = Product A B
    ; π₁ = πˡ
    ; π₂ = πʳ
    ; ⟨_,_⟩ = _※_
    ; project₁ = record { eq₀ = λ _ → ≡.refl ; eq₁ = λ _ → MR.id-comm-sym A }
    ; project₂ = record { eq₀ = λ _ → ≡.refl ; eq₁ = λ _ → MR.id-comm-sym B }
    ; unique = λ {hA} {h} {i} {j} left right →
      let unique-eq₀ X = cong₂ _,_ (≡.sym $ eq₀ left X) (≡.sym $ eq₀ right X)
      in record
      { eq₀ = unique-eq₀
      ; eq₁ = λ {a} {b} f →
          let module A   = Category A
              module B   = Category B
              module C   = Category C
              module A×B = Category (Product A B)
              open A×B.HomReasoning
              open HId
              open HIdProps
              open Functor
              leq a = ≡.sym $ eq₀ left a
              req a = ≡.sym $ eq₀ right a
          in begin
                hid (Product A B) (unique-eq₀ b) A×B.∘ F₁ (i ※ j) f
              ≈˘⟨ A×B.∘-resp-≈ˡ (×-hid A B (leq b) (req b)) ⟩
                (hid A (leq b) A.∘ F₁ i f , hid B (req b) B.∘ F₁ j f)
              ≈⟨ eq₁⁻¹ left f , eq₁⁻¹ right f ⟩
                F₁ (πˡ C.∘ h) f A.∘ hid A (leq a) ,
                F₁ (πʳ C.∘ h) f B.∘ hid B (req a)
              ≈⟨ A×B.∘-resp-≈ʳ (×-hid A B (leq a) (req a)) ⟩
                (F₁ h f) A×B.∘ (hid (Product A B) (unique-eq₀ a))
              ∎
      }
    } }

  private
    unique-One : {l : Level} (x : Lift l ⊤) → lift tt ≡ x
    unique-One (lift tt) = refl

  One-⊤ : Terminal C
  One-⊤ = record
    { ⊤ = One
    ; ! = const (lift tt)
    ; !-unique = λ f → record { eq₀ = λ _ → unique-One _ ; eq₁ = λ _ → lift tt }
    }

  Cats-is : Cartesian
  Cats-is = record { terminal = One-⊤ ; products = Cats-has-all }

  private
    module Cart = Cartesian.Cartesian Cats-is

  Cats-Monoidal : Monoidal C
  Cats-Monoidal = Cart.monoidal