{-# OPTIONS --without-K #-}
module Preliminaries where

open import lib.Basics hiding (_⊔_)
open import lib.NType2

open import lib.types.Nat hiding (_+_)
open import lib.types.Pi
open import lib.types.Sigma hiding (×-comm)
open import lib.types.Unit
open import lib.types.TLevel

open import lib.types.Paths

-- Most of the contents of Chapter 2.1 are in the library, e.g.
-- natural numbers. We only do the following two adaptions here:

-- A readable notation for the join of universe levels.
infixr 8  _⊔_

_⊔_ : ULevel → ULevel → ULevel
_⊔_ = lmax

-- Addition operator adjustment.
_+_ : ℕ → ℕ → ℕ
a + b = b lib.types.Nat.+ a  -- n + 1 should mean S n (author preference)!

-- Chapter 2.2: We list the lemmata and other statements here.

-- Lemma 2.2.1
transport-is-comp : ∀ {i j} {X : Type i} {Y : Type j} → {x₁ x₂ : X}
  → (h k : X → Y) → (t : x₁ == x₂) → (p : h x₁ == k x₁)
  → (transport _ t p) == ! (ap h t) ∙ p ∙ ap k t
transport-is-comp h k idp p = ! (∙-unit-r _)

-- Lemma 2.2.2 is in the library:
-- lib.NType2.raise-level-<T

-- Lemma 2.2.3 is in the library as well:
-- lib.types.Sigma.Σ-level

-- ... and so is Definition 2.2.4:
-- lib.NType2._-Type_

-- Lemma 2.2.6 as well:
-- lib.types.Pi.Π-level

-- Lemma 2.2.7:
-- lib.NType2.has-level-is-prop

module _ {i j} {A : Type i} {B : A → Type j} where
  module _ (h : (a : A) → is-contr (B a)) where

    -- Lemma 2.2.8 (i)
    Σ₂-contr : Σ A B ≃ A
    Σ₂-contr = Σ₂-Unit ∘e equiv-Σ-snd (λ _ → contr-equiv-Unit (h _))

    -- Lemma 2.2.8 (ii)
    Π₂-contr : Π A B ≃ ⊤
    Π₂-contr = Π₂-Unit ∘e equiv-Π-r (λ _ → contr-equiv-Unit (h _))

  module _ (h : is-contr A) where

    -- Lemma 2.2.9 (i)
    Σ₁-contr : Σ A B ≃ B (fst h)
    Σ₁-contr = Σ₁-Unit ∘e equiv-Σ-fst _ (snd (contr-equiv-Unit h ⁻¹)) ⁻¹

    -- Lemma 2.2.9 (ii)
    Π₁-contr : Π A B ≃ B (fst h)
    Π₁-contr = Π₁-Unit ∘e equiv-Π-l _ (snd (contr-equiv-Unit h ⁻¹)) ⁻¹

-- Lemma 2.2.10 - we refer to the library again
-- lib.types.Sigma.Σ-level
-- and
-- lib.types.Sigma.×-level

-- Lemma 2.2.11
-- lib.Equivalences.equiv-ap

-- Lemma 2.2.12 and Remark 2.2.13
module TT-AC {i j k : ULevel} {A : Type i}
                          {B : A → Type j}
                          {C : (Σ A B) → Type k} where
  -- the two types:
  ONE = (a : A) → Σ (B a) λ b → C (a , b)
  TWO = Σ ((a : A) -> B a) λ g → (a : A) → C (a , g a)

  -- the two canonical functions:
  f : ONE → TWO
  f one = fst ∘ one , snd ∘ one

  g : TWO → ONE
  g two = λ a → (fst two) a , (snd two) a

  -- the compositions are indeed pointwise judgmentally
  -- the identity!
  f∘g : (two : TWO) → f (g two) == two
  f∘g two = idp

  g∘f : (one : ONE) → g (f one) == one
  g∘f one = idp

-- Lemma 2.2.14 is in the library:
-- lib.NType.pathto-is-contr
-- lib.NType.pathfrom-is-contr

-- This formalisation has a separated file for Pointed
-- types, called 'Pointed.agda', which contains
-- (among other things) Definition 2.2.15
-- and Lemma 2.2.17

-- Definition 2.2.19
LEM : ∀ {i} → Type (lsucc i)
LEM {i} = (X : Type i) → is-prop X → Coprod X (¬ X)

LEM∞ : ∀ {i} → Type (lsucc i)
LEM∞ {i} = (X : Type i) → Coprod X (¬ X)

-- The following are some auxiliary lemmata/definitions
-- (not numbered in the thesis)

{- The (function) exponentiation operator. For convenience, we
   choose to define it via postcomposition in the recursion step. -}
infix 10 _^_
_^_ : ∀ {i} {A : Set i} → (A → A) → ℕ → A → A
f ^ 0   = idf _
f ^ S n = (f ^ n) ∘ f

-- Logical equivalence: maps in both directions
_↔_ : ∀ {i j} → Type i → Type j → Type (i ⊔ j)
X ↔ Y = (X → Y) × (Y → X)

-- Composition of ↔
_◎_ : ∀ {i j k} {X : Type i} {Y : Type j} {Z : Type k} → (X ↔ Y) → (Y ↔ Z) → (X ↔ Z)
e₁ ◎ e₂ = fst e₂ ∘ fst e₁ , snd e₁ ∘ snd e₂

-- Subsection 2.3.3
module wtrunc where
  postulate
    -- Definition 2.3.2
    ∣∣_∣∣ : ∀ {i} → (X : Type i) → Type i
    tr-is-prop : ∀ {i} {X : Type i} → is-prop (∣∣ X ∣∣)
    ∣_∣ : ∀ {i} {X : Type i} → X → ∣∣ X ∣∣
    tr-rec : ∀ {i j} {X : Type i} {P : Type j} → (is-prop P) → (X → P) →   ∣∣ X ∣∣ → P

  -- Lemma 2.3.4
  -- the induction principle is derivable:
  module _ {i j : _} {X : Type i} {P : ∣∣ X ∣∣ → Type j} (h : (z : ∣∣ X ∣∣) → is-prop (P z)) (k : (x : X) → P ∣ x ∣) where

    total : Type (i ⊔ j)
    total = Σ ∣∣ X ∣∣ P

    jj : X → total
    jj x = ∣ x ∣ , k x

    total-prop : is-prop total
    total-prop = Σ-level tr-is-prop h

    total-map : ∣∣ X ∣∣ → total
    total-map = tr-rec total-prop jj

    tr-ind : (z : ∣∣ X ∣∣) → P z
    tr-ind z = transport P (prop-has-all-paths tr-is-prop _ _) (snd (total-map z))

  -- Remark 2.3.5
  -- further, the propositional β-rule is derivable:
  trunc-β : ∀ {i j} {X : Type i} {P : Type j} → (pp : is-prop P) → (f : X → P) → (x : X) → tr-rec pp f ∣ x ∣ == f x
  trunc-β pp f x = prop-has-all-paths pp _ _

  -- comment: Trunc is functorial
  trunc-functorial : ∀ {i} {j} {X : Type i} {Y : Type j} → (X → Y) → ∣∣ X ∣∣ → ∣∣ Y ∣∣
  trunc-functorial f = tr-rec tr-is-prop (∣_∣ ∘ f)

  -- Proposition 2.3.6
  impred : ∀ {i} {X : Type i} → ∣∣ X ∣∣ ↔ ((P : Type i) → is-prop P → (X → P) → P)
  impred {X = X} = (λ z P pp f → tr-rec pp f z) , λ h → h ∣∣ X ∣∣ tr-is-prop ∣_∣

  -- Proposition 2.3.6 (second part) - note that we use funext (in the form: Π preserves truncation level)
  impr-equiv : ∀ {i} {X : Type i} → is-equiv (fst (impred {X = X}))
  impr-equiv {i} {X} = is-eq (fst (impred {X = X})) (snd (impred {X = X}))
    (λ top → prop-has-all-paths (Π-level (λ P → Π-level (λ pp → (Π-level (λ _ → pp))))) _ _)
    (λ z → prop-has-all-paths tr-is-prop _ _)

-- The rest of the file contains various useful lemmata
-- and definitions that are NOT in the thesis (at least
-- not as numbered statements).

{- Since natural numbers and universe levels use
   different types, we require a translation operation.
   We will only make use of this in chapter 7: Higher
   Homotopies in a Hierarchy of Univalent Universes. -}
｢_｣ : ℕ → ULevel
｢ 0   ｣ = lzero
｢ S n ｣ = lsucc ｢ n ｣

-- A trivial, but useful lemma. The only thing we do is hiding the arguments.
prop-eq-triv : ∀ {i} {P : Type i} → {p₁ p₂ : P} → is-prop P → p₁ == p₂
prop-eq-triv h = prop-has-all-paths h _ _

-- A second such useful lemma
second-comp-triv : ∀ {i} {X : Type i} → {P : X → Type i} → ((x : X) → is-prop (P x)) → (a b : Σ X P) → (fst a == fst b) → a == b
second-comp-triv {P = P} h a b q = pair= q (from-transp P q (prop-eq-triv (h (fst b))))

-- the following is the function which the univalence
-- axiom postulates to be an equivalence
-- (we define it ourselves as we do not want to
-- implicitly import the whole univalence library)
path-to-equiv : ∀ {i} {X : Type i} {Y : Type i} → X == Y → X ≃ Y
path-to-equiv {X = X} idp = ide X

-- some rather silly lemmata

delete-idp : ∀ {i} {X : Type i} → {x₁ x₂ : X} → (p q : x₁ == x₂) → (p ∙ idp == q) ≃ (p == q)
delete-idp idp q = ide _

add-path : ∀ {i} {X : Type i} → {x₁ x₂ x₃ : X} → (p q : x₁ == x₂) → (r : x₂ == x₃) → (p == q) == (p ∙ r == q ∙ r)
add-path idp q idp = transport (λ q₁ → (idp == q₁) == (idp == q ∙ idp)) {x = q ∙ idp} {y = q} (∙-unit-r _) idp

reverse-paths : ∀ {i} {X : Type i} → {x₁ x₂ : X} → (p : x₂ == x₁) → (q : x₁ == x₂) → (! p == q) ≃ (p == ! q)
reverse-paths p idp =
  ! p == idp   ≃⟨ path-to-equiv (add-path _ _ _) ⟩
  ! p ∙ p == p ≃⟨ path-to-equiv (transport (λ p₁ → (! p ∙ p == p) == (p₁ == p)) (!-inv-l p) idp) ⟩
  idp == p     ≃⟨ !-equiv ⟩
  p == idp     ≃∎

switch-args : ∀ {i j k} {X : Type i} {Y : Type j} {Z : X → Y → Type k} → ((x : X) → (y : Y) → Z x y) ≃ ((y : Y) → (x : X) → Z x y)
switch-args = equiv f g h₁ h₂ where
  f = λ k y x → k x y
  g = λ i x y → i y x
  h₁ = λ _ → idp
  h₂ = λ _ → idp

-- another useful (but simple) lemma: if we have a proof of (x , y₁) == (x , y₂) and the type of x is a set, we get a proof of y₁ == y₂.
set-lemma : ∀ {i j} {X : Type i} → (is-set X) → {Y : X → Type j} → (x₀ : X) → (y₁ y₂ : Y x₀) → _==_ {A = Σ X Y} (x₀ , y₁) (x₀ , y₂) → y₁ == y₂
set-lemma {X = X} h {Y = Y} x₀ y₁ y₂ p =
  y₁ =⟨ idp ⟩
  transport Y idp        y₁ =⟨ transport {A = x₀ == x₀} (λ q → y₁ == transport Y q y₁)
                                 {x = idp} {y = ap fst p}
                                 (prop-has-all-paths (h x₀ x₀) _ _)
                                 idp ⟩
  transport Y (ap fst p) y₁ =⟨ snd-of-p ⟩
  y₂ ∎ where
    pairs : =Σ {B = Y} (x₀ , y₁) (x₀ , y₂)
    pairs = <– (=Σ-eqv _ _) p

    paov : y₁ == y₂ [ Y ↓ fst (pairs) ]
    paov = snd pairs

    snd-of-p : transport Y (ap fst p) y₁ == y₂
    snd-of-p = to-transp paov

×-comm : ∀ {i j} {A : Type i} {B : Type j} → (A × B) ≃ (B × A)
×-comm = equiv (λ {(a , b) → (b , a)})
               (λ {(b , a) → (a , b)})
               (λ _ → idp) (λ _ → idp)

Σ-comm-snd : ∀ {i j k} {A : Type i} {B : A → Type j} {C : A → Type k}
           → Σ (Σ A B) (λ ab → C (fst ab)) ≃ Σ (Σ A C) (λ ac → B (fst ac))
Σ-comm-snd {A = A} {B} {C} =
  Σ (Σ A B) (λ ab → C (fst ab))  ≃⟨ Σ-assoc ⟩
  Σ A (λ a → B a × C a)          ≃⟨ equiv-Σ-snd (λ _ → ×-comm) ⟩
  Σ A (λ a → C a × B a)          ≃⟨ Σ-assoc ⁻¹ ⟩
  Σ (Σ A C) (λ ac → B (fst ac))  ≃∎

flip : ∀ {i j k} {A : Type i} {B : Type j} {C : A → B → Type k}
       → ((a : A) (b : B) → C a b) → ((b : B) (a : A) → C a b)
flip = –> (curry-equiv ∘e equiv-Π-l _ (snd ×-comm) ∘e curry-equiv ⁻¹)

module _ {i j k} {A : Type i} {B : Type j} {C : A → B → Type k} where
  ↓-cst→app-equiv : {x x' : A} {p : x == x'} {u : (b : B) → C x b} {u' : (b : B) → C x' b}
                  → ((b : B) → u b == u' b [ (λ x → C x b) ↓ p ]) ≃ (u == u' [ (λ x → (b : B) → C x b) ↓ p ])
  ↓-cst→app-equiv {p = idp} = equiv λ= app= (! ∘ λ=-η) (λ= ∘ app=-β)

module _ {i j k} {A : Type i} {B : A → Type j} {C : A → Type k} where
  ↓-cst2-equiv : {x y : A} (p : x == y) {b : C x} {c : C y}
    (q : b == c [ C ↓ p ]) {u : B x} {v : B y}
    → (u == v [ B ↓ p ]) ≃ (u == v [ (λ xy → B (fst xy)) ↓ (pair= p q) ])
  ↓-cst2-equiv idp idp = ide _

module _ {i} {A B : Type i} (e : A ≃ B) {u : A} {v : B} where
  ↓-idf-ua-equiv : (–> e u == v) ≃ (u == v [ (λ x → x) ↓ (ua e) ])
  ↓-idf-ua-equiv = to-transp-equiv _ _ ⁻¹ ∘e (_ , pre∙-is-equiv (ap (λ z → z u) (ap coe (ap-idf (ua e)) ∙ ap –> (coe-equiv-β e))))

-- On propositions, equivalence coincides with logical equivalence.
module _ {i j} {A : Type i} {B : Type j} where
  prop-equiv' : (B → is-prop A) → (A → is-prop B) → (A → B) → (B → A) → A ≃ B
  prop-equiv' h k f g = equiv f g (λ b → prop-has-all-paths (k (g b)) _ _)
                                  (λ a → prop-has-all-paths (h (f a)) _ _)

  prop-equiv : is-prop A → is-prop B → (A → B) → (B → A) → A ≃ B
  prop-equiv h k f g = prop-equiv' (cst h) (cst k) f g

-- Equivalent types have equivalent truncatedness propositions.
equiv-level : ∀ {i j} {A : Type i} {B : Type j} {n : ℕ₋₂}
            → A ≃ B → has-level n A ≃ has-level n B
equiv-level u = prop-equiv has-level-is-prop
                           has-level-is-prop
                           (equiv-preserves-level u)
                           (equiv-preserves-level (u ⁻¹))

prop-equiv-inhab-to-contr : ∀ {i} {A : Type i} → is-prop A ≃ (A → is-contr A)
prop-equiv-inhab-to-contr = prop-equiv is-prop-is-prop
                                       (Π-level (λ _ → is-contr-is-prop))
                                       (flip inhab-prop-is-contr)
                                       inhab-to-contr-is-prop


module lib.libraryString where

open import Data.String
open import Data.Bool
open import Agda.Builtin.String using ( primStringEquality )
open import Data.String public using ()
                               renaming (toList to primStringToList;
                                        _++_  to _++Str_)

_==Str_ : String → String → Bool
_==Str_ = primStringEquality


record R : Set₁ where
  field
    A     : Set
    {B}   : Set
    {{C}} : Set

open R

r : R
r = {!!}
-- C-c C-c produced
-- A r = {!!}
-- B {r} = {!!}
-- C {{r}} = {!!}


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

module CombiningProofs.CommDisjunction where

open import Common.FOL.FOL

postulate
  A B : Set
  ∨-comm : A ∨ B → B ∨ A
{-# ATP prove ∨-comm #-}


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

open import Base
open import Homotopy.Connected

{-
  An example of using the overkilling covering space library.
-}

module Homotopy.Cover.ExamplePi1Circle where

  open import Homotopy.Truncation
  open import Homotopy.PathTruncation
  open import Spaces.Circle

  {-
      The 1st step: Show that the circle is connected.
  -}
  S¹-is-conn : is-connected ⟨0⟩ S¹
  S¹-is-conn = proj base ,
    τ-extend ⦃ λ _ → ≡-is-set $ π₀-is-set S¹ ⦄
      (S¹-rec (λ x → proj x ≡ proj base) refl
        (prop-has-all-paths (π₀-is-set S¹ _ _) _ _))

  open import Integers
  open import Homotopy.Pointed
  open import Homotopy.Cover.Def S¹
  open import Homotopy.Cover.HomotopyGroupSetIsomorphism (⋆[ S¹ , base ]) S¹-is-conn

  S¹-covering : covering
  S¹-covering = let fiber = S¹-rec-nondep Set ℤ (eq-to-path succ-equiv) in
    cov[ fiber , S¹-rec (is-set ◯ fiber) ℤ-is-set (prop-has-all-paths is-set-is-prop _ _) ]

  open covering S¹-covering

  {-
      The 2nd step : Show that S¹ is contractible.
  -}

  -- One step.
  trans-fiber-!loop : ∀ z → transport fiber (! loop) z ≡ pred z
  trans-fiber-!loop z =
    transport fiber (! loop) z
      ≡⟨ ! $ trans-ap (id _) fiber (! loop) z ⟩
    transport (id _) (ap fiber (! loop)) z
      ≡⟨ ap (λ x → transport (id _) x z) $ ap-opposite fiber loop ⟩
    transport (id _) (! (ap fiber loop)) z
      ≡⟨ ap (λ x → transport (id _) (! x) z) $ S¹-β-loop-nondep Set ℤ (eq-to-path _) ⟩
    transport (id _) (! (eq-to-path succ-equiv)) z
      ≡⟨ trans-id-!eq-to-path _ _ ⟩∎
    pred z
      ∎

  -- The end of this function.  This can save some type annotations.
  loop⁻ⁿ-end : Σ S¹ fiber
  loop⁻ⁿ-end = (base , O)

  -- Climbing up the stairs.
  loop⁻¹ : ∀ z → _≡_ {A = Σ S¹ fiber} (base , z) (base , pred z)
  loop⁻¹ z = Σ-eq (! loop) (trans-fiber-!loop z)

  -- Agda needs us to show the induction order explicitly,
  -- and so there are so many functions.
  loop⁻ⁿ : ∀ z → (base , z) ≡ loop⁻ⁿ-end
  loop⁻ⁿ-pos : ∀ n → (base , pos n) ≡ loop⁻ⁿ-end
  loop⁻ⁿ-neg : ∀ n → (base , neg n) ≡ loop⁻ⁿ-end

  loop⁻ⁿ O = refl
  loop⁻ⁿ (pos _) = loop⁻ⁿ-pos _
  loop⁻ⁿ (neg _) = loop⁻ⁿ-neg _
  loop⁻ⁿ-pos 0 = loop⁻¹ _
  loop⁻ⁿ-pos (S _) = loop⁻¹ _ ∘ loop⁻ⁿ-pos _
  loop⁻ⁿ-neg 0 = ! (loop⁻¹ _)
  loop⁻ⁿ-neg (S _) = ! (loop⁻¹ _) ∘ loop⁻ⁿ-neg _

  private
    -- These are specialized J rules that work for this development only.
    -- I am too lazy to generalize them.

    lemma₁ : ∀ {x₁ x₂} (q : x₁ ≡ x₂) (f : ∀ z → (x₁ , z) ≡ loop⁻ⁿ-end) (z : fiber x₂)
      → transport (λ s → ∀ z → (s , z) ≡ loop⁻ⁿ-end) q f z
      ≡ Σ-eq (! q) refl ∘ f (transport fiber (! q) z)
    lemma₁ refl f z = refl

    lemma₂ : ∀ {b₁} {b₂} (q : b₁ ≡ b₂) p
      → transport (λ z → (base , z) ≡ loop⁻ⁿ-end) (! q) p
      ≡ Σ-eq refl q ∘ p
    lemma₂ refl p = refl

    compose-Σ-eq : ∀ {a₁} {a₂} (p : a₁ ≡ a₂)
      {b₁ : fiber a₁} {b₂} (q : transport fiber p b₁ ≡ b₂)
      → Σ-eq {A = S¹} {P = fiber} p refl ∘ Σ-eq refl q ≡ Σ-eq p q
    compose-Σ-eq refl q = refl

    loop⁻¹-loop⁻ⁿ-pred : ∀ z → loop⁻¹ z ∘ loop⁻ⁿ (pred z) ≡ loop⁻ⁿ z
    loop⁻¹-loop⁻ⁿ-pred O = opposite-right-inverse (loop⁻¹ _)
    loop⁻¹-loop⁻ⁿ-pred (pos O) = refl-right-unit _
    loop⁻¹-loop⁻ⁿ-pred (pos (S _)) = refl
    loop⁻¹-loop⁻ⁿ-pred (neg _) =
      loop⁻¹ _ ∘ (! (loop⁻¹ _) ∘ loop⁻ⁿ-neg _)
        ≡⟨ ! $ concat-assoc (loop⁻¹ _) (! (loop⁻¹ _)) _ ⟩
      (loop⁻¹ _ ∘ ! (loop⁻¹ _)) ∘ loop⁻ⁿ-neg _
        ≡⟨ ap (λ x → x ∘ loop⁻ⁿ-neg _) $ opposite-right-inverse (loop⁻¹ _) ⟩∎
      loop⁻ⁿ-neg _
        ∎

  path : ∀ x z → (x , z) ≡ loop⁻ⁿ-end
  path = S¹-rec (λ s → ∀ z → (s , z) ≡ loop⁻ⁿ-end) loop⁻ⁿ $ funext λ z →
    transport (λ s → ∀ z → (s , z) ≡ loop⁻ⁿ-end) loop loop⁻ⁿ z
        ≡⟨ lemma₁ loop loop⁻ⁿ z ⟩
    Σ-eq (! loop) refl ∘ loop⁻ⁿ (transport fiber (! loop) z)
        ≡⟨ ap (λ x → Σ-eq (! loop) refl ∘ x) $ apd! loop⁻ⁿ (trans-fiber-!loop z) ⟩
    Σ-eq (! loop) refl ∘
      (transport (λ z → (base , z) ≡ loop⁻ⁿ-end) (! $ trans-fiber-!loop z) (loop⁻ⁿ (pred z)))
        ≡⟨ ap (λ x → Σ-eq (! loop) refl ∘ x) $ lemma₂ (trans-fiber-!loop z) (loop⁻ⁿ (pred z)) ⟩
    Σ-eq (! loop) refl ∘ (Σ-eq refl (trans-fiber-!loop z) ∘ loop⁻ⁿ (pred z))
        ≡⟨ ! $ concat-assoc (Σ-eq (! loop) refl) _ _ ⟩
    (Σ-eq (! loop) refl ∘ Σ-eq refl (trans-fiber-!loop z)) ∘ loop⁻ⁿ (pred z)
        ≡⟨ ap (λ x → x ∘ loop⁻ⁿ (pred z)) $ compose-Σ-eq (! loop) (trans-fiber-!loop z) ⟩
    loop⁻¹ z ∘ loop⁻ⁿ (pred z)
        ≡⟨ loop⁻¹-loop⁻ⁿ-pred z ⟩∎
    loop⁻ⁿ z
        ∎

  S¹-covering-is-universal : is-universal S¹-covering
  S¹-covering-is-universal = contr-is-connected ⟨1⟩ $ loop⁻ⁿ-end , uncurry path

  ℤ-π¹S¹-equiv : ℤ ≃ (base ≡₀ base)
  ℤ-π¹S¹-equiv = GiveMeAPoint.fiber-a≃fg S¹-covering S¹-covering-is-universal O


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

open import Algebra

module Data.FingerTree.Structures
  {r m}
  (ℳ : Monoid r m)
  where

open import Level using (_⊔_)
open import Data.Product
open import Relation.Unary

open import Data.FingerTree.Measures ℳ
open import Data.FingerTree.Reasoning ℳ

open Monoid ℳ renaming (Carrier to 𝓡)
open σ ⦃ ... ⦄
{-# DISPLAY σ.μ _ = μ #-}

data Digit {a} (Σ : Set a) : Set a where
  D₁ : Σ → Digit Σ
  D₂ : Σ → Σ → Digit Σ
  D₃ : Σ → Σ → Σ → Digit Σ
  D₄ : Σ → Σ → Σ → Σ → Digit Σ

instance
  σ-Digit : ∀ {a} {Σ : Set a} → ⦃ _ : σ Σ ⦄ → σ (Digit Σ)
  μ ⦃ σ-Digit ⦄ (D₁ x₁) = μ x₁
  μ ⦃ σ-Digit ⦄ (D₂ x₁ x₂) = μ x₁ ∙ μ x₂
  μ ⦃ σ-Digit ⦄ (D₃ x₁ x₂ x₃) = μ x₁ ∙ (μ x₂ ∙ μ x₃)
  μ ⦃ σ-Digit ⦄ (D₄ x₁ x₂ x₃ x₄) = μ x₁ ∙ (μ x₂ ∙ (μ x₃ ∙ μ x₄))

data Node {a} (Σ : Set a) : Set a where
  N₂ : Σ → Σ → Node Σ
  N₃ : Σ → Σ → Σ → Node Σ

instance
  σ-Node : ∀ {a} {Σ : Set a} → ⦃ _ : σ Σ ⦄ → σ (Node Σ)
  μ ⦃ σ-Node ⦄ (N₂ x₁ x₂) = μ x₁ ∙ μ x₂
  μ ⦃ σ-Node ⦄ (N₃ x₁ x₂ x₃) = μ x₁ ∙ (μ x₂ ∙ μ x₃)

mutual
  infixr 5 _&_&_
  record Deep {a} (Σ : Set a) ⦃ _ : σ Σ ⦄ : Set (r ⊔ a ⊔ m) where
    constructor _&_&_
    inductive
    field
      lbuff : Digit Σ
      tree  : Tree ⟪ Node Σ ⟫
      rbuff : Digit Σ

  data Tree {a} (Σ : Set a) ⦃ _ : σ Σ ⦄ : Set (r ⊔ a ⊔ m) where
    empty : Tree Σ
    single : Σ → Tree Σ
    deep : ⟪ Deep Σ ⟫  → Tree Σ

  μ-deep : ∀ {a} {Σ : Set a} ⦃ _ : σ Σ ⦄ → Deep Σ → 𝓡
  μ-deep (l & x & r) = μ l ∙ (μ-tree x ∙ μ r)

  μ-tree : ∀ {a} {Σ : Set a} ⦃ _ : σ Σ ⦄ → Tree Σ → 𝓡
  μ-tree empty = ε
  μ-tree (single x) = μ x
  μ-tree (deep xs) = xs .𝔐

  instance
    σ-Deep : ∀ {a} {Σ : Set a} → ⦃ _ : σ Σ ⦄ → σ (Deep Σ)
    μ ⦃ σ-Deep ⦄ = μ-deep

  instance
    σ-Tree : ∀ {a} {Σ : Set a} → ⦃ _ : σ Σ ⦄ → σ (Tree Σ)
    μ ⦃ σ-Tree ⦄ = μ-tree
open Deep

{-# DISPLAY μ-tree _ x = μ x #-}
{-# DISPLAY μ-deep _ x = μ x #-}

nodeToDigit : ∀ {a} {Σ : Set a} ⦃ _ : σ Σ ⦄ → (xs : Node Σ) →  μ⟨ Digit Σ ⟩≈ μ xs
nodeToDigit (N₂ x₁ x₂) = D₂ x₁ x₂ ⇑[ refl ]
nodeToDigit (N₃ x₁ x₂ x₃) = D₃ x₁ x₂ x₃ ⇑[ refl ]

digitToTree : ∀ {a} {Σ : Set a} ⦃ _ : σ Σ ⦄ → (xs : Digit Σ) → μ⟨ Tree Σ ⟩≈ μ xs
digitToTree (D₁ x₁) = single x₁ ⇑[ refl ]
digitToTree (D₂ x₁ x₂) = deep ⟪ D₁ x₁ & empty & D₁ x₂ ⇓⟫ ⇑[ μ x₁ ∙ (ε ∙ μ x₂) ↢ ℳ ↯ ]
digitToTree (D₃ x₁ x₂ x₃) = deep ⟪ D₂ x₁ x₂ & empty & D₁ x₃ ⇓⟫ ⇑[ μ (D₂ x₁ x₂) ∙ (ε ∙ μ x₃) ↢ ℳ ↯ ]
digitToTree (D₄ x₁ x₂ x₃ x₄) = deep ⟪ D₂ x₁ x₂ & empty & D₂ x₃ x₄ ⇓⟫ ⇑[ μ (D₂ x₁ x₂) ∙ (ε ∙ μ (D₂ x₃ x₄)) ↢ ℳ ↯ ]

open import Data.List using (List; _∷_; [])

nodeToList : ∀ {a} {Σ : Set a} ⦃ _ : σ Σ ⦄ → (xs : Node Σ) → μ⟨ List Σ ⟩≈ (μ xs)
nodeToList (N₂ x₁ x₂) = x₁ ∷ x₂ ∷ [] ⇑[ ℳ ↯ ]
nodeToList (N₃ x₁ x₂ x₃) = x₁ ∷ x₂ ∷ x₃ ∷ [] ⇑[ ℳ ↯ ]

digitToList : ∀ {a} {Σ : Set a} ⦃ _ : σ Σ ⦄ → (xs : Digit Σ) → μ⟨ List Σ ⟩≈ (μ xs)
digitToList (D₁ x₁) = x₁ ∷ [] ⇑[ ℳ ↯ ]
digitToList (D₂ x₁ x₂) = x₁ ∷ x₂ ∷ [] ⇑[ ℳ ↯ ]
digitToList (D₃ x₁ x₂ x₃) = x₁ ∷ x₂ ∷ x₃ ∷ [] ⇑[ ℳ ↯ ]
digitToList (D₄ x₁ x₂ x₃ x₄) = x₁ ∷ x₂ ∷ x₃ ∷ x₄ ∷ [] ⇑[ ℳ ↯ ]


open import Agda.Builtin.Equality using (_≡_)
open import Agda.Builtin.Sigma using (Σ; _,_)

postulate
  F    : Set → Set₁
  P    : (A : Set) → F A → Set
  easy : {A : Set₁} → A

A : Set₁
A = Σ Set λ B → Σ (F B) (P B)

f : (X Y : A) → X ≡ Y
f (C , x , p) (D , y , q) = proof
  module _ where
  abstract

    proof : (C , x , p) ≡ (D , y , q)
    proof = easy


open import Prelude hiding (id; Bool)

module Examples.Unification where

data TC : Set where
  tc-int : TC
  tc-bool : TC

_tc≟_ : (a b : TC) → Dec (a ≡ b)
tc-int tc≟ tc-int = yes refl
tc-int tc≟ tc-bool = no (λ ())
tc-bool tc≟ tc-int = no (λ ())
tc-bool tc≟ tc-bool = yes refl

open import Implicits.Oliveira.Types TC _tc≟_
open import Implicits.Oliveira.Terms TC _tc≟_
open import Implicits.Oliveira.Contexts TC _tc≟_
open import Implicits.Oliveira.WellTyped TC _tc≟_
open import Implicits.Oliveira.Substitutions TC _tc≟_
open import Implicits.Oliveira.Types.Unification TC _tc≟_
open import Implicits.Oliveira.Types.Unification.McBride TC _tc≟_ as McBride using ()
open import Data.Star as S
open import Data.Maybe

open import Level using () renaming (zero to level₀)
open import Data.Maybe using (monad; functor)
open import Category.Functor
open RawFunctor {level₀} functor

module M = MetaTypeMetaSubst
module T = MetaTypeTypeSubst

Bool : ∀ {n} → Type n
Bool = simpl (tc tc-bool)

Int : ∀ {n} → Type n
Int = simpl (tc tc-int)

module ex₂ where
  -- mgu test for simple 2 variable substitution

  a : MetaType (suc (suc zero)) (suc zero)
  a = open-meta $ open-meta $ to-meta $ (simpl ((simpl (tvar zero)) →' (simpl (simpl (tvar (suc zero)) →' simpl (tvar (suc (suc zero)))))))

  b : SimpleType (suc zero)
  b = Int →' (simpl (Int →' simpl (tvar zero)))

  s = mgu a b

  u = asub (proj₁ $ from-just s)

  unifies : a M./ u ≡ (simpl (to-smeta b))
  unifies = refl

module ex₃ where
  -- mgu test for simple 1 variable substitution
  -- (limited α)

  a : MetaType (suc zero) (suc zero)
  a = open-meta (to-meta (∀' (simpl ((simpl (tvar zero)) →' simpl (tvar (suc zero))))))

  b : SimpleType (suc zero)
  b = Int →' Int

  s : mgu a b ≡ nothing
  s = refl

module ex₄ where
  -- with ∀' in there somewhere

  a : MetaType (suc zero) (suc zero)
  a = simpl ((∀' (s-mvar zero)) →' (s-tc tc-int))

  -- won't unify with a because we'd need to instantiate s-mvar zero with
  -- a s-tvar that's not yet introduced
  b : SimpleType (suc zero)
  b = (∀' (simpl (tvar zero))) →' Int

  s : mgu a b ≡ nothing
  s = refl

module ex₅ where
  -- renaming example

  a : MetaType (suc (suc zero)) (suc zero)
  a = (s-mvar zero) ⇒ (s-mvar (suc zero))

  b : Type (suc zero)
  b = (simpl (tvar (zero))) ⇒ (simpl (tvar zero))

  s : is-just (McBride.mgu a b) ≡ true
  s = refl

open ex₅


{- NEW TRANSLATION STUFF: same thing but interpret source nat as ♭nat-}

open import Preliminaries
open import Source
open import Pilot

module Translation-New where

  mutual
    ⟨⟨_⟩⟩ : Tp → CTp
    ⟨⟨ unit ⟩⟩ = unit
    ⟨⟨ nat ⟩⟩ = nat
    ⟨⟨ susp A ⟩⟩ = || A ||
    ⟨⟨ A ->s B ⟩⟩ = ⟨⟨ A ⟩⟩ ->c || B ||
    ⟨⟨ A ×s B ⟩⟩ = ⟨⟨ A ⟩⟩ ×c ⟨⟨ B ⟩⟩
    ⟨⟨ list A ⟩⟩ = list ⟨⟨ A ⟩⟩
    ⟨⟨ bool ⟩⟩ = bool

    ||_|| : Tp → CTp
    || τ || = C ×c ⟨⟨ τ ⟩⟩

  ⟨⟨_⟩⟩c : Source.Ctx → Pilot.Ctx
  ⟨⟨ [] ⟩⟩c = []
  ⟨⟨ x :: Γ ⟩⟩c = ⟨⟨ x ⟩⟩ :: ⟨⟨ Γ ⟩⟩c

  interp-Cost : ∀{Γ} → Cost → Γ Pilot.|- C
  interp-Cost 0c = 0C
  interp-Cost 1c = 1C
  interp-Cost (m +c n) = plusC (interp-Cost m) (interp-Cost n)

  lookup : ∀{Γ τ} → τ Source.∈ Γ → ⟨⟨ τ ⟩⟩ Pilot.∈ ⟨⟨ Γ ⟩⟩c
  lookup i0 = i0
  lookup (iS x) = iS (lookup x)

  -- translation from source expressions to complexity expressions
  ||_||e : ∀{Γ τ} → Γ Source.|- τ → ⟨⟨ Γ ⟩⟩c Pilot.|- || τ ||
  || unit ||e = prod 0C unit
  || var x ||e = prod 0C (var (lookup x))
  || z ||e = prod 0C z
  || suc e ||e = prod (l-proj (|| e ||e)) (s (r-proj (|| e ||e)))
  || rec e e0 e1 ||e = (l-proj (|| e ||e)) +C (rec (r-proj || e ||e) (1C +C || e0 ||e) (1C +C || e1 ||e))
  || lam e ||e = prod 0C (lam || e ||e)
  || app e1 e2 ||e = prod (plusC (plusC (l-proj (|| e1 ||e)) (l-proj (|| e2 ||e))) (l-proj (app (r-proj (|| e1 ||e)) (r-proj (|| e2 ||e)))))
                          (r-proj (app (r-proj (|| e1 ||e)) (r-proj (|| e2 ||e))))
  || prod e1 e2 ||e = prod (plusC (l-proj (|| e1 ||e)) (l-proj (|| e2 ||e))) (prod (r-proj (|| e1 ||e)) (r-proj (|| e2 ||e)))
  || delay e ||e = prod 0C (|| e ||e)
  || force e ||e = prod (plusC (l-proj (|| e ||e)) (l-proj (r-proj || e ||e))) (r-proj (r-proj (|| e ||e)))
  || split e0 e1 ||e = prod (plusC (l-proj (|| e0 ||e)) (l-proj E1)) (r-proj E1)
    where E1 = (Pilot.subst || e1 ||e (Pilot.lem4 (l-proj (r-proj || e0 ||e)) (r-proj (r-proj || e0 ||e))))
  || nil ||e = prod 0C nil
  || e ::s e₁ ||e = prod (plusC (l-proj || e ||e) (l-proj || e₁ ||e)) ((r-proj || e ||e) ::c (r-proj || e₁ ||e))
  || listrec e e₁ e₂ ||e = l-proj || e ||e +C listrec (r-proj || e ||e) (1C +C || e₁ ||e) (1C +C || e₂ ||e)
  || true ||e = prod 0C true
  || false ||e = prod 0C false


-- Scenario:
--  * start with B only
--  * write 'f B = B'
--  * add constructor A
--  * want to deal with it first to preserve alphabetical ordering of clauses
--  * add 'f t = ?' *above* 'f B = B'

-- WAS: split t, get A and B
-- WANT: split t, get A only

data Type : Set where
  A B : Type

f : Type → Type
f t = {!!}
f B = B


------------------------------------------------------------------------
-- A type for values that should be erased at run-time
------------------------------------------------------------------------

-- This module contains some basic definitions with few dependencies
-- (in particular, not Function-universe) that do not rely on
-- equality. See Erased and other modules under Erased for more
-- definitions. The definitions below are reexported from Erased.

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

module Erased.Basics where

open import Prelude

private
  variable
    a p q : Level

-- Erased A is like A, but the values are (supposed to be) erased at
-- run-time.

record Erased (@0 A : Type a) : Type a where
  constructor [_]
  field
    @0 erased : A

open Erased public

-- A variant of [_] that does not take an erased argument.

[_]→ : {@0 A : Type a} → A → Erased A
[ x ]→ = [ x ]

-- A variant of [_]→.

[_∣_]→ : (@0 A : Type a) → A → Erased A
[_∣_]→ _ = [_]→

-- Erased preserves dependent functions.

map :
  {@0 A : Type a} {@0 P : A → Type p} →
  @0 ((x : A) → P x) → (x : Erased A) → Erased (P (erased x))
map f [ x ] = [ f x ]

-- A binary variant of map.

zip :
  {@0 A : Type a} {@0 P : A → Type p} {@0 Q : {x : A} → P x → Type q} →
  @0 ((x : A) (p : P x) → Q p) →
  (([ x ]) : Erased A) (([ p ]) : Erased (P x)) → Erased (Q p)
zip f [ x ] [ p ] = [ f x p ]


-- Andreas, 2014-06-16

data D A : Set where
  c : {x : A} → A → D A

f : ∀(A : Set) → D A → Set
f A (c a b) = D A

-- Expected error:
-- The constructor c expects 2 arguments (including hidden ones), but
-- has been given 3 (including hidden ones)
-- when checking that the pattern c a b has type D A


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

module Fragment.Setoid.Morphism where

open import Fragment.Setoid.Morphism.Base public
open import Fragment.Setoid.Morphism.Setoid public
open import Fragment.Setoid.Morphism.Properties public


------------------------------------------------------------------------
-- A general grammar and pretty-printer for binary operators of
-- various (not necessarily linearly ordered) precedences
------------------------------------------------------------------------

-- The code below uses a variant of the operator grammars described by
-- Ulf Norell and me in "Parsing Mixfix Operators". For simplicity the
-- code only handles binary infix operators.

{-# OPTIONS --guardedness #-}

module Examples.Precedence where

open import Codata.Musical.Notation
open import Data.Bool using (Bool; T)
import Data.Bool.Properties as Bool-prop
open import Data.Char as Char using (Char; _==_)
open import Data.Fin using (Fin; zero; suc; #_)
open import Data.Fin.Properties as Fin using () renaming (_≟_ to _≟F_)
open import Data.List as List
open import Data.List.Membership.Propositional
open import Data.List.NonEmpty as List⁺
import Data.List.Properties as List
open import Data.List.Relation.Unary.Any as Any
open import Data.Nat using (ℕ)
open import Data.Product as Prod
import Data.String as String
open import Data.Unit
import Data.Vec as Vec
open import Data.Vec.Membership.Propositional.Properties
open import Function using (id; _∘_; _∘′_)
open import Relation.Binary
open import Relation.Binary.PropositionalEquality as P using (_≡_)
open import Relation.Nullary
open import Relation.Nullary.Decidable as Decidable
open import Relation.Nullary.Product

open import Examples.Identifier
open import Grammar.Infinite as Grammar using (Grammar-for)
open import Pretty using (Pretty-printer-for)
open import Renderer
open import Utilities

------------------------------------------------------------------------
-- Binary operators

-- Associativities.

data Associativity : Set where
  -   -- Non-associative.
   ⇾  -- Right associative.
   ⇽  -- Left associative.
     : Associativity

-- Operator names.

is-operator-char : Char → Bool
is-operator-char t =
  List.any (_==_ t) (String.toList "+-*/.:^<>=!&|")

Operator-name : Set
Operator-name = List⁺ (∃ (T ∘ is-operator-char))

-- Operators (parametrised by their associativity).

record Operator (assoc : Associativity) : Set where
  constructor ⟪_⟫
  field name : Operator-name

-- Equality of operators can be decided.

_≟O_ : ∀ {assoc} → Decidable (_≡_ {A = Operator assoc})
⟪ n₁ ∷ ns₁ ⟫ ≟O ⟪ n₂ ∷ ns₂ ⟫ =
  Decidable.map′
    (P.cong ⟪_⟫ ∘ uncurry (P.cong₂ _∷_))
    (< P.cong List⁺.head , P.cong List⁺.tail > ∘′ P.cong Operator.name)
    ((n₁ ≟OC n₂)
       ×-dec
     List.≡-dec _≟OC_ ns₁ ns₂)
  where
  _≟OC_ : Decidable (_≡_ {A = ∃ (T ∘ is-operator-char)})
  (c₁ , _) ≟OC (c₂ , _) =
    Decidable.map′ lemma (P.cong proj₁) (c₁ Char.≟ c₂)
    where
    lemma : {p₁ p₂ : ∃ (T ∘ is-operator-char)} →
            proj₁ p₁ ≡ proj₁ p₂ → p₁ ≡ p₂
    lemma {p₁ = _ , _} {p₂ = ._ , _} P.refl =
      P.cong -,_ (Bool-prop.T-irrelevant _ _)

-- A grammar for a given operator name.

operator-name : Grammar-for Operator-name
operator-name n = list⁺ (tok-sat _) n
  where open Grammar

-- A pretty-printer for operator names.

operator-name-printer : Pretty-printer-for operator-name
operator-name-printer n = list⁺ tok-sat n
  where open Pretty

-- A grammar for a given operator.

operator : ∀ {assoc} → Grammar-for (Operator assoc)
operator op =
  Prod.map ⟪_⟫ (P.cong ⟪_⟫) <$> operator-name (Operator.name op)
  where open Grammar

-- A pretty-printer for operators.

operator-printer : ∀ {assoc} →
                   Pretty-printer-for (operator {assoc = assoc})
operator-printer op = <$> operator-name-printer (Operator.name op)
  where open Pretty

------------------------------------------------------------------------
-- Precedence graphs

-- Precedence graphs are represented by the number of precedence
-- levels, plus functions mapping node identifiers (precedences) to
-- node contents and successor precedences.

record Precedence-graph : Set where
  field

    -- The number of precedence levels.

    levels : ℕ

  -- Precedence levels.

  Precedence : Set
  Precedence = Fin levels

  field

    -- The precedence level's operators.

    ops : Precedence → (assoc : Associativity) → List (Operator assoc)

    -- The immediate successors of the precedence level.

    ↑ : Precedence → List Precedence

  -- All precedence levels.

  all-precedences : List Precedence
  all-precedences = Vec.toList (Vec.allFin levels)

  -- Every precedence level is a member of all-precedences.

  ∈-all-precedences : ∀ {p} → p ∈ all-precedences
  ∈-all-precedences {p} = ∈-toList⁺ (∈-allFin⁺ p)

  -- A membership test for precedences.

  _∈?_ : ∀ (p : Precedence) ps → Dec (p ∈ ps)
  p ∈? ps = Any.any? (_≟F_ p) ps

------------------------------------------------------------------------
-- Expressions

-- The code is parametrised by a precedence graph.

module Expr (g : Precedence-graph) where

  open Precedence-graph g

  -- Operators with a given precedence and associativity.

  Op : Precedence → Associativity → Set
  Op p assoc = ∃ λ op → op ∈ ops p assoc

  mutual

    -- Expressions.

    data Expr : Set where
      var : Identifier → Expr
      app : ∀ {p} → ∃ (App p) → Expr

    -- Binary operator applications where the operator has a given
    -- precedence and associativity.

    App : Precedence → Associativity → Set
    App p assoc = Expr × Op p assoc × Expr

  -- The following function can be convenient to use when constructing
  -- examples.

  _⟨_⟩_ :
    ∀ {assoc} → Expr → (op : Operator assoc) →
    {member : True (Fin.any? λ p →
                      Any.any? (_≟O_ op) (ops p assoc))} →
    Expr → Expr
  _⟨_⟩_ e₁ op {member} e₂ =
    app (_ , e₁ , (op , proj₂ (toWitness member)) , e₂)

  module _ where

    open Grammar

    mutual

      -- Expression grammar.

      expr : Grammar Expr
      expr = whitespace ⋆ ⊛> precs all-precedences <⊛ whitespace ⋆

      -- Grammar for a given list of precedence levels.

      precs : List Precedence → Grammar Expr
      precs ps = string′ "(" ⊛> ♯ expr <⊛ string′ ")"
               ∣ var <$> identifier
               ∣ precs′ ps

      precs′ : List Precedence → Grammar Expr
      precs′ []       = fail
      precs′ (p ∷ ps) = app <$> ♯ prec p
                      ∣ precs′ ps

      -- Grammar for a given precedence level.

      prec : (p : Precedence) → Grammar (∃ (App p))
      prec p = -,_ <$> non-assoc p
             ∣ -,_ <$> right⁺ p
             ∣ -,_ <$> left⁺ p

      -- Grammar for higher precedence levels.

      higher : Precedence → Grammar Expr
      higher p = precs (↑ p)

      -- Non-associative operators.

      non-assoc : (p : Precedence) → Grammar (App p -)
      non-assoc p = (λ e₁ op e₂ → e₁ , op , e₂) <$>
        higher p ⊛ operators (ops p -) ⊛ higher p

      -- Right-associative operators.

      right⁺ : (p : Precedence) → Grammar (App p ⇾)
      right⁺ p = (λ e₁ op e₂ → e₁ , op , e₂) <$>
        higher p ⊛ operators (ops p ⇾) ⊛ right⁺↑ p

      right⁺↑ : Precedence → Grammar Expr
      right⁺↑ p = (app ∘ -,_) <$> ♯ right⁺ p
                ∣ higher p

      -- Left-associative operators.

      left⁺ : (p : Precedence) → Grammar (App p ⇽)
      left⁺ p = (λ e₁ op e₂ → e₁ , op , e₂) <$>
        left⁺↑ p ⊛ operators (ops p ⇽) ⊛ higher p

      left⁺↑ : Precedence → Grammar Expr
      left⁺↑ p = (app ∘ -,_) <$> ♯ left⁺ p
               ∣ higher p

      -- An operator from a given list of operators.

      operators : ∀ {assoc} (os : List (Operator assoc)) →
                  Grammar (∃ λ op → op ∈ os)
      operators []         = fail
      operators (op ∷ ops) =    whitespace ⋆
                             ⊛> (Prod.map id here <$> operator op)
                             <⊛ whitespace ⋆
                           ∣ Prod.map id there <$> operators ops

  open Pretty

  mutual

    -- Pretty-printer. The produced layout could probably be improved,
    -- I have not tried very hard to make it pretty.

    expr-printer : Pretty-printer expr
    expr-printer e = nil-⋆ ⊛> precs-printer e <⊛ nil-⋆

    precs-printer : ∀ {ps} → Pretty-printer (precs ps)
    precs-printer e = group (precs-printer′ e)
      where
      precs-printer′ : ∀ {ps} → Pretty-printer (precs ps)
      precs-printer′ (var x) = left (right (<$> identifier-printer x))
      precs-printer′ {ps} (app {p = p} e)
        with p ∈? ps
      ... | yes p∈ps = right (precs′-printer p∈ps e)
      ... | no  _    =
        -- Incorrect precedence level: insert parentheses.
        left (left (text ⊛> nest 1 d <⊛ text))
        where
        d = nil-⋆                                       ⊛>
            right (precs′-printer ∈-all-precedences e) <⊛
            nil-⋆

    precs′-printer :
      ∀ {p ps} → p ∈ ps → (e : ∃ (App p)) → Doc (precs′ ps) (app e)
    precs′-printer (here P.refl) e = left  (<$> prec-printer e)
    precs′-printer (there p∈ps)  e = right (precs′-printer p∈ps e)

    prec-printer : ∀ {p} → Pretty-printer (prec p)
    prec-printer (- , e) = left (left (<$> non-assoc-printer e))
    prec-printer (⇾ , e) = left (right (<$> right⁺-printer e))
    prec-printer (⇽ , e) = right (<$> left⁺-printer e)

    non-assoc-printer : ∀ {p} → Pretty-printer (non-assoc p)
    non-assoc-printer (e₁ , op , e₂) =
      <$> higher-printer e₁ ⊛ operators-printer op ⊛ higher-printer e₂

    right⁺-printer : ∀ {p} → Pretty-printer (right⁺ p)
    right⁺-printer (e₁ , op , e₂) =
      <$> higher-printer e₁ ⊛ operators-printer op ⊛ right⁺↑-printer e₂

    right⁺↑-printer : ∀ {p} → Pretty-printer (right⁺↑ p)
    right⁺↑-printer {p₁} (app {p = p₂} (⇾ , e))
      with p₁ ≟F p₂ | higher-printer (app (⇾ , e))
    right⁺↑-printer (app (⇾ , e)) | yes P.refl | _ =
      -- Matching precedence and associativity.
      left (<$> right⁺-printer e)
    right⁺↑-printer (app (⇾ , e)) | no _ | d = right d
    right⁺↑-printer e = right (higher-printer e)

    left⁺-printer : ∀ {p} → Pretty-printer (left⁺ p)
    left⁺-printer (e₁ , op , e₂) =
      <$> left⁺↑-printer e₁ ⊛ operators-printer op ⊛ higher-printer e₂

    left⁺↑-printer : ∀ {p} → Pretty-printer (left⁺↑ p)
    left⁺↑-printer {p₁} (app {p = p₂} (⇽ , e))
      with p₁ ≟F p₂ | higher-printer (app (⇽ , e))
    left⁺↑-printer (app (⇽ , e)) | yes P.refl | _ =
      -- Matching precedence and associativity.
      left (<$> left⁺-printer e)
    left⁺↑-printer (app (⇽ , e)) | no _ | d = right d
    left⁺↑-printer e = right (higher-printer e)

    higher-printer : ∀ {p} → Pretty-printer (higher p)
    higher-printer e = nest 2 (precs-printer e)

    operators-printer : ∀ {assoc} {os : List (Operator assoc)} →
                        Pretty-printer (operators os)
    operators-printer {os = []}     (_  , ())
    operators-printer {os = ._ ∷ _} (op , here P.refl) =
      left (line⋆ tt-⊛> <$> operator-printer op <⊛ space)
    operators-printer {os =  _ ∷ _} (_  , there op∈os) =
      right (<$> operators-printer (_ , op∈os))

------------------------------------------------------------------------
-- An example

-- Some operators.

add : Operator ⇽
add = ⟪ str⁺ "+" ⟫

sub : Operator ⇽
sub = ⟪ str⁺ "-" ⟫

mul : Operator ⇽
mul = ⟪ str⁺ "*" ⟫

div : Operator ⇽
div = ⟪ str⁺ "/" ⟫

cons : Operator ⇾
cons = ⟪ str⁺ "<:" ⟫

snoc : Operator ⇽
snoc = ⟪ str⁺ ":>" ⟫

-- A precedence graph.

g : Precedence-graph
g = record { ops = ops; ↑ = ↑ }
  where
  ops : Fin 3 → (assoc : Associativity) → List (Operator assoc)
  ops zero             ⇽ = snoc ∷ []
  ops zero             ⇾ = cons ∷ []
  ops (suc zero)       ⇽ = add ∷ sub ∷ []
  ops (suc (suc zero)) ⇽ = mul ∷ div ∷ []
  ops _                _ = []

  ↑ : Fin 3 → List (Fin 3)
  ↑ zero          = # 1 ∷ # 2 ∷ []
  ↑ (suc zero)    = # 2 ∷ []
  ↑ (suc (suc p)) = []

open Precedence-graph g
open Expr g

-- An expression.

example : Expr
example =
  (((var (str⁺ "y") ⟨ add ⟩ var (str⁺ "k"))
      ⟨ cons ⟩
    (((var (str⁺ "i") ⟨ add ⟩ var (str⁺ "foo"))
        ⟨ add ⟩
      ((var (str⁺ "a")
          ⟨ div ⟩
        (var (str⁺ "b") ⟨ sub ⟩ var (str⁺ "c")))
         ⟨ mul ⟩
       var (str⁺ "c")))
       ⟨ cons ⟩
     (var (str⁺ "xs"))))
     ⟨ snoc ⟩
   (var (str⁺ "x")))
    ⟨ snoc ⟩
  (var (str⁺ "z") ⟨ mul ⟩ var (str⁺ "z"))

-- Some unit tests.

test₁ : render 80 (expr-printer example) ≡
        "(y + k <: i + foo + a / (b - c) * c <: xs) :> x :> z * z"
test₁ = P.refl

test₂ : render 50 (expr-printer example) ≡
        "(y + k <: i + foo + a / (b - c) * c <: xs)\n:> x\n:> z * z"
test₂ = P.refl

test₃ : render 40 (expr-printer example) ≡
        "(y + k\n   <: i + foo + a / (b - c) * c\n   <: xs)\n:> x\n:> z * z"
test₃ = P.refl

test₄ : render 30 (expr-printer example) ≡
        "(y + k\n   <: i\n     + foo\n     + a / (b - c) * c\n   <: xs)\n:> x\n:> z * z"
test₄ = P.refl

test₅ : render 20 (expr-printer example) ≡
        "(y + k\n   <: i\n     + foo\n     + a\n       / (b - c)\n       * c\n   <: xs)\n:> x\n:> z * z"
test₅ = P.refl

test₆ : render 6 (expr-printer example) ≡
        "(y + k\n   <: i\n     + foo\n     + a\n       / (b\n          - c)\n       * c\n   <: xs)\n:> x\n:> z\n  * z"
test₆ = P.refl

-- The rendering of "y + k" in the following test may seem strange: if
-- no newline had been inserted before +, then the total width of this
-- subexpression would have been smaller.
--
-- Wadler's pretty-printing algorithm is not always optimal for texts
-- that do not fit in the allotted width, if by "optimal" we mean
-- "with as little overflow as possible". To see what I mean, try
-- running the following Haskell code, where the functions are
-- implemented as in Wadler's paper:
--
--   pretty 1 (group (nest 20 (line <> text "x")))
--
-- The result is "\n                    x", which can be seen as much
-- worse than the alternative result " x". However, note that Wadler
-- uses a lexicographic definition of "better", in which
-- "\n                    x" is better than " x", because the first
-- line of "\n                    x" fits, but the first line of " x"
-- doesn't.

test₇ : render 5 (expr-printer example) ≡
        "(y\n     + k\n   <: i\n     + foo\n     + a\n       / (b\n          - c)\n       * c\n   <: xs)\n:> x\n:> z\n  * z"
test₇ = P.refl


module Data.Num.Redundant.Properties where

open import Data.Num.Bij
open import Data.Num.Redundant renaming (_+_ to _+R_)

open import Data.Nat renaming (_<_ to _<ℕ_)
open import Data.Nat.Etc
open import Data.Nat.Properties.Simple

open import Data.Sum
open import Data.List hiding ([_])
open import Relation.Nullary
open import Relation.Nullary.Negation using (contradiction; contraposition)
open import Relation.Binary
open import Relation.Binary.Core
open import Relation.Binary.PropositionalEquality as PropEq
    using (_≡_; _≢_; refl; cong; cong₂; trans; sym; inspect)
open PropEq.≡-Reasoning

--------------------------------------------------------------------------------
--  Digits
--------------------------------------------------------------------------------

⊕-comm : (a b : Digit) → a ⊕ b ≡ b ⊕ a
⊕-comm zero zero = refl
⊕-comm zero one = refl
⊕-comm zero two = refl
⊕-comm one zero = refl
⊕-comm one one = refl
⊕-comm one two = refl
⊕-comm two zero = refl
⊕-comm two one = refl
⊕-comm two two = refl

⊕-assoc : (a b c : Digit) → (a ⊕ b) ⊕ c ≡ a ⊕ (b ⊕ c)
⊕-assoc zero b c = refl
⊕-assoc one zero c = refl
⊕-assoc one one zero = refl
⊕-assoc one one one = refl
⊕-assoc one one two = refl
⊕-assoc one two zero = refl
⊕-assoc one two one = refl
⊕-assoc one two two = refl
⊕-assoc two zero c = refl
⊕-assoc two one zero = refl
⊕-assoc two one one = refl
⊕-assoc two one two = refl
⊕-assoc two two zero = refl
⊕-assoc two two one = refl
⊕-assoc two two two = refl

⊕-right-identity : (a : Digit) → a ⊕ zero ≡ a
⊕-right-identity zero = refl
⊕-right-identity one = refl
⊕-right-identity two = refl

⊙-comm : (a b : Digit) → a ⊙ b ≡ b ⊙ a
⊙-comm zero zero = refl
⊙-comm zero one = refl
⊙-comm zero two = refl
⊙-comm one zero = refl
⊙-comm one one = refl
⊙-comm one two = refl
⊙-comm two zero = refl
⊙-comm two one = refl
⊙-comm two two = refl

--------------------------------------------------------------------------------
--  Sequence of Digits
--------------------------------------------------------------------------------
{-
[x∷xs≡0⇒xs≡0] : (d : Digit) → (xs : Redundant) → [ d ∷ xs ] ≡ [ zero ∷ [] ] → [ xs ] ≡ [ zero ∷ [] ]
[x∷xs≡0⇒xs≡0] d    []          _ = refl
[x∷xs≡0⇒xs≡0] zero (zero ∷ xs) p = {! no-zero-divisor 2 (0 + 2 * [ xs ]) (λ ()) p  !}
[x∷xs≡0⇒xs≡0] zero (one  ∷ xs) p = {!   !}
[x∷xs≡0⇒xs≡0] zero (two  ∷ xs) p = {!   !}
-- no-zero-divisor 2 ([ x ] + 2 * [ xs ]) (λ ()) p
[x∷xs≡0⇒xs≡0] one  (x ∷ xs) p = contradiction p (λ ())
[x∷xs≡0⇒xs≡0] two  (x ∷ xs) p = contradiction p (λ ())

[>>xs]≡2*[xs] : (xs : Redundant) → [ >> xs ] ≡ *2 [ xs ]
[>>xs]≡2*[xs] xs = refl

[n>>>xs]≡2^n*[xs] : (n : ℕ) → (xs : Redundant) → [ n >>> xs ] ≡ 2 ^ n *Bij [ xs ]
[n>>>xs]≡2^n*[xs] zero    xs = sym (+-right-identity [ xs ])
[n>>>xs]≡2^n*[xs] (suc n) xs =
    begin
        [ n >>> (zero ∷ xs) ]
    ≡⟨ [n>>>xs]≡2^n*[xs] n (zero ∷ xs) ⟩
        2 ^ n * [ zero ∷ xs ]
    ≡⟨ sym (*-assoc (2 ^ n) 2 [ xs ]) ⟩
        2 ^ n * 2 * [ xs ]
    ≡⟨ cong (λ x → x * [ xs ]) (*-comm (2 ^ n) 2) ⟩
        2 * 2 ^ n * [ xs ]
    ∎

-- >> 0 ≈ 0
>>-zero : (xs : Redundant) → xs ≈ zero ∷ [] → >> xs ≈ zero ∷ []
>>-zero []       _           = eq refl
>>-zero (x ∷ xs) (eq x∷xs≈0) = eq (begin
        *2 [ x ∷ xs ]
    ≡⟨ cong (λ w → 2 * w) x∷xs≈0 ⟩
        2 * 0
    ≡⟨ *-right-zero 2 ⟩
        0
    ∎)

-- << 0 ≈ 0
<<-zero : (xs : Redundant) → xs ≈ zero ∷ [] → << xs ≈ zero ∷ []
<<-zero []       _           = eq refl
<<-zero (x ∷ xs) (eq x∷xs≡0) = eq ([x∷xs≡0⇒xs≡0] x xs x∷xs≡0)
-}
{-
>>>-zero : ∀ {n} (xs : Redundant) → {xs≈0 : xs ≈ zero ∷ []} → n >>> xs ≈ zero ∷ []
>>>-zero {n} xs {eq xs≡0} = eq (
    begin
        [ n >>> xs ]
    ≡⟨ [n>>>xs]≡2^n*[xs] n xs ⟩
        2 ^ n * [ xs ]
    ≡⟨ cong (λ x → 2 ^ n * x) xs≡0 ⟩
        2 ^ n * 0
    ≡⟨ *-right-zero (2 ^ n) ⟩
        0
    ∎)

<<<-zero : (n : ℕ) (xs : Redundant) → {xs≈0 : xs ≈ zero ∷ []} → n <<< xs ≈ zero ∷ []
<<<-zero zero    [] = eq refl
<<<-zero (suc n) [] = eq refl
<<<-zero zero    (x ∷ xs) {x∷xs≈0}    = x∷xs≈0
<<<-zero (suc n) (x ∷ xs) {eq x∷xs≡0} = <<<-zero n xs {eq ([x∷xs≡0⇒xs≡0] x xs x∷xs≡0)}
-}
--------------------------------------------------------------------------------
--  Properties of the relations on Redundant
--------------------------------------------------------------------------------

≈-Setoid : Setoid _ _
≈-Setoid = record
    {   Carrier = Redundant
    ;   _≈_ = _≈_
    ;   isEquivalence = record
        {   refl = ≈-refl
        ;   sym = ≈-sym
        ;   trans = ≈-trans
        }
    }
    where
        ≈-refl : Reflexive _≈_
        ≈-refl = eq refl

        ≈-sym : Symmetric _≈_
        ≈-sym (eq a≈b) = eq (sym a≈b)

        ≈-trans : Transitive _≈_
        ≈-trans (eq a≈b) (eq b≈c) = eq (trans a≈b b≈c)

private
    ≤-isDecTotalOrder = DecTotalOrder.isDecTotalOrder decTotalOrder
    ≤-isTotalOrder = IsDecTotalOrder.isTotalOrder ≤-isDecTotalOrder
    ≤-total = IsTotalOrder.total ≤-isTotalOrder
    ≤-isPartialOrder = IsTotalOrder.isPartialOrder ≤-isTotalOrder
    ≤-antisym =  IsPartialOrder.antisym ≤-isPartialOrder
    ≤-isPreorder = IsPartialOrder.isPreorder ≤-isPartialOrder
    ≤-isEquivalence = IsPreorder.isEquivalence ≤-isPreorder
    ≤-reflexive = IsPreorder.reflexive ≤-isPreorder
    ≤-trans = IsPreorder.trans ≤-isPreorder

≲-refl : _≈_ ⇒ _≲_
≲-refl (eq [x]≡[y]) = {!   !} -- le (≤-reflexive [x]≡[y])

≲-trans : Transitive _≲_
≲-trans [a]≤[b] [b]≤[c] = {!   !} -- le (≤-trans [a]≤[b] [b]≤[c])

≲-antisym : Antisymmetric _≈_ _≲_
≲-antisym [x]≤[y] [y]≤[x] = {!   !} -- eq (≤-antisym [x]≤[y] [y]≤[x])

≲-isPreorder : IsPreorder _ _
≲-isPreorder = record
    {   isEquivalence = Setoid.isEquivalence ≈-Setoid
    ;   reflexive     = ≲-refl
    ;   trans         = ≲-trans
    }

≲-isPartialOrder : IsPartialOrder _ _
≲-isPartialOrder =  record
    {   isPreorder = ≲-isPreorder
    ;   antisym = ≲-antisym
    }
{-
≲-total : Total _≲_
≲-total x y with ≤-total [ x ] [ y ]
≲-total x y | inj₁ [x]≤[y] = inj₁ ? -- (le [x]≤[y])
≲-total x y | inj₂ [y]≤[x] = inj₂ ? -- (le [y]≤[x])

≲-isTotalOrder : IsTotalOrder _ _
≲-isTotalOrder = record
    {   isPartialOrder = ≲-isPartialOrder
    ;   total = ≲-total
    }

≲-isDecTotalOrder : IsDecTotalOrder _ _
≲-isDecTotalOrder = record
    {   isTotalOrder = ≲-isTotalOrder
    ;   _≟_ = _≈?_
    ;   _≤?_ = _≲?_
    }

≲-decTotalOrder : DecTotalOrder _ _ _
≲-decTotalOrder = record
    {   Carrier = Redundant
    ;   _≈_ = _≈_
    ;   _≤_ = _≲_
    ;   isDecTotalOrder = ≲-isDecTotalOrder
    }

a≲a+1 : (a : Redundant) → a ≲ incr one a
a≲a+1 []       = le z≤n
a≲a+1 (x ∷ xs) = le {!   !}

<-asym : Asymmetric _<_
<-asym {[]}     {[]}     (le ())      (le [y]<[[]])
<-asym {[]}     {y ∷ ys} (le [x]<[y]) (le [y]<[[]]) = {!   !}
<-asym {x ∷ xs} {[]}     (le [x]<[y]) (le [y]<[x∷xs]) = {!   !}
<-asym {x ∷ xs} {y ∷ ys} (le [x]<[y]) (le [y]<[x∷xs]) = {!   !}

<-irr : Irreflexive _≈_ _<_ -- goal: ¬ (x < y)
<-irr {a} {b} (eq [a]≡[b]) (le [a]<[b]) = {!   !}

trichotomous : Trichotomous _≈_ _<_
trichotomous x y with x ≈? y
trichotomous x y | yes p = tri≈ {!   !} p {!   !}
trichotomous x y | no ¬p with incr one x ≲? y
trichotomous x y | no ¬p | yes q = tri< q ¬p {!   !}
trichotomous x y | no ¬p | no ¬q = tri> ¬q ¬p {!   !}

-}

{-
    begin
        {!   !}
    ≡⟨ {!   !} ⟩
        {!   !}
    ≡⟨ {!   !} ⟩
        {!   !}
    ≡⟨ {!   !} ⟩
        {!   !}
    ≡⟨ {!   !} ⟩
        {!   !}
    ∎
-}


------------------------------------------------------------------------
-- Progress of CBV reductions in Fω with interval kinds
------------------------------------------------------------------------

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

-- This module contains a variant of the "progress" theorem for Fω
-- with interval kinds.  Progress says roughly that well-typed terms
-- do not get stuck.  I.e. a well-typed term is either a value or it
-- can take a call-by-value (CBV) reduction step.  Together with the
-- subject reduction (aka "preservation") theorem from
-- FOmegaInt.Typing.Preservation, progress ensures type safety.  For
-- details, see e.g.
--
--  * B. C. Pierce, TAPL (2002), pp. 95.
--
--  * A. Wright and M. Felleisen, "A Syntactic Approach to Type
--    Soundness" (1994).

module FOmegaInt.Typing.Progress where

open import Data.Product using (_,_; ∃)
open import Data.Sum using (_⊎_; inj₁; inj₂)
open import Relation.Binary.PropositionalEquality using (_≡_; refl)
open import Relation.Nullary.Negation using (contradiction)

open import FOmegaInt.Syntax
open import FOmegaInt.Typing
open import FOmegaInt.Typing.Inversion
open import FOmegaInt.Reduction.Cbv

open Syntax
open TermCtx
open Substitution using (_[_])
open Typing

-- A canonical forms lemma for universal types: closed values of
-- universal type are type abstractions.
Π-can : ∀ {f k a} → Val f → [] ⊢Tm f ∈ Π k a → ∃ λ k′ →
        ∃ λ a′ → f ≡ Λ k′ a′
Π-can (Λ k a) (∈-∀-i k-kd a∈b)   = k , a , refl
Π-can (Λ k a) (∈-⇑ Λka∈b b<:Πkc) = k , a , refl
Π-can (ƛ a b) (∈-⇑ ƛab∈c c<:Πkd) with Tm∈-gen ƛab∈c
Π-can (ƛ a b) (∈-⇑ ƛab∈c c<:Πkd) | ∈-→-i a∈* b∈e a⇒e<:c =
  contradiction (<:-trans a⇒e<:c c<:Πkd) ⇒-≮:-Π

-- A canonical forms lemma for arrow types: closed values of arrow
-- type are term abstractions.
⇒-can : ∀ {f a b} → Val f → [] ⊢Tm f ∈ a ⇒ b → ∃ λ a′ → ∃ λ b′ → f ≡ ƛ a′ b′
⇒-can (Λ k a) (∈-⇑ Λka∈b b<:c⇒d) with Tm∈-gen Λka∈b
⇒-can (Λ k a) (∈-⇑ Λka∈b b<:c⇒d) | ∈-∀-i k-kd a∈e Πke<:b =
  contradiction (<:-trans Πke<:b b<:c⇒d) Π-≮:-⇒
⇒-can (ƛ a b) (∈-→-i a∈* b∈c c∈*) = a , b , refl
⇒-can (ƛ a b) (∈-⇑ ƛab∈c c<:d⇒e)  = a , b , refl

-- Progress: well-typed terms do not get stuck (under CBV reduction).
prog : ∀ {a b} → [] ⊢Tm a ∈ b → Val a ⊎ (∃ λ a′ → a →v a′)
prog (∈-var () _ _)
prog (∈-∀-i k-kd b∈c)    = inj₁ (Λ _ _)
prog (∈-→-i a∈* b∈c c∈*) = inj₁ (ƛ _ _)
prog (∈-∀-e a∈Πkc b∈k) with prog a∈Πkc
prog (∈-∀-e a∈Πkc b∈k) | inj₁ u with Π-can u a∈Πkc
...| k′ , a′ , refl = inj₂ (_ , cont-⊡ k′ a′ _)
prog (∈-∀-e a∈Πkc b∈k) | inj₂ (a′ , a→a′) = inj₂ (_ , a→a′ ⊡ _)
prog (∈-→-e a∈c⇒d b∈c) with prog a∈c⇒d
prog (∈-→-e a∈c⇒d b∈c) | inj₁ u with prog b∈c
prog (∈-→-e a∈c⇒d b∈c) | inj₁ u | inj₁ v with ⇒-can u a∈c⇒d
...| c′ , a′ , refl = inj₂ (_ , cont-· c′ a′ v)
prog (∈-→-e a∈c⇒d b∈c) | inj₁ u | inj₂ (b′ , b→b′) = inj₂ (_ , u ·₂ b→b′)
prog (∈-→-e a∈c⇒d b∈c) | inj₂ (a′ , a→a′) = inj₂ (_ , a→a′ ·₁ _)
prog (∈-⇑ a∈b b<:c)    = prog a∈b


{-# OPTIONS --no-positivity-check #-}

module Generics where

data Zero : Set where
data One  : Set where
  ∙ : One

data _+_ (A B : Set) : Set where
  inl : A -> A + B
  inr : B -> A + B

data _×_ (A : Set)(B : A -> Set) : Set where
  <_,_> : (x : A) -> B x -> A × B

data _==_ {A : Set}(x : A) : A -> Set where
  refl : x == x

data Shape (I : Set) : Set where
  ι : Shape I
  σ : Shape I -> Shape I
  δ : Shape I -> Shape I

data Tel {I : Set} : Shape I -> Set1 where
  empty	  : Tel ι
  non-rec : {s : Shape I}(A : Set) -> (A -> Tel s) -> Tel (σ s)
  rec	  : {s : Shape I}(H : Set) -> (H -> I) -> Tel s -> Tel (δ s)

Index : {I : Set}(E : Set){s : Shape I} -> Tel s -> Set
Index E  empty	      = E
Index E (non-rec A f) = (x : A) -> Index E (f x)
Index E (rec H i s)   = Index E s

data Con (I E : Set) : Set1 where
  con : {s : Shape I}(tel : Tel s) -> Index E tel -> Con I E

infixr 40 _|_

data OP (I E : Set) : Set1 where
  ∅   : OP I E
  _|_ : Con I E -> OP I E -> OP I E

Args-tel : {I : Set}(U : I -> Set){s : Shape I} -> Tel s -> Set
Args-tel U empty	 = One
Args-tel U (non-rec A s) = A × \a -> Args-tel U (s a)
Args-tel U (rec H i s)   = ((x : H) -> U (i x)) × \_ -> Args-tel U s

Args : {I E : Set}(U : I -> Set) -> OP I E -> Set
Args U ∅	       = Zero
Args U (con tel _ | γ) = Args-tel U tel + Args U γ

index-tel : {I E : Set}{s : Shape I}(U : I -> Set)(tel : Tel s) -> Index E tel -> Args-tel U tel -> E
index-tel U  empty	  i ∙		= i
index-tel U (non-rec A s) i < a , arg > = index-tel U (s a) (i a) arg
index-tel U (rec H di s)  i < d , arg > = index-tel U s i arg

index : {I E : Set}(U : I -> Set)(γ : OP I E) -> Args U γ -> E
index U ∅		()
index U (con tel i | _) (inl x) = index-tel U tel i x
index U (con _ _   | γ) (inr y) = index U γ y

OPr : Set -> Set1
OPr I = I -> OP I One

data Ur {I : Set}(γ : OPr I)(i : I) : Set where
  intror : Args (Ur γ) (γ i) -> Ur γ i

OPg : Set -> Set1
OPg I = OP I I

const-index : {I E : Set}{s : Shape I} -> E -> (tel : Tel s) -> Index E tel
const-index i  empty	   = i
const-index i (non-rec _ s)   = \a -> const-index i (s a)
const-index i (rec _ _ s) = const-index i s

ε-shape : {I : Set} -> Shape I -> Shape I
ε-shape  ι    = σ ι
ε-shape (σ s) = σ (ε-shape s)
ε-shape (δ s) = δ (ε-shape s)

ε-tel : {I : Set}{s : Shape I} -> I -> (tel : Tel s) -> Index I tel -> Tel (ε-shape s)
ε-tel i  empty		j = non-rec (j == i) \_ -> empty
ε-tel i (non-rec A arg) j = non-rec A \a -> ε-tel i (arg a) (j a)
ε-tel i (rec H di arg)  j = rec H di (ε-tel i arg j)

ε-con : {I : Set} -> I -> Con I I -> Con I One
ε-con j (con tel i) = con args' (const-index ∙ args')
  where
    args' = ε-tel j tel i

ε : {I : Set} -> OPg I -> OPr I
ε  ∅	  _ = ∅
ε (c | γ) j = ε-con j c | ε γ j

Ug : {I : Set} -> OPg I -> I -> Set
Ug γ = Ur (ε γ)

g→rArgs-tel : {I : Set}(U : I -> Set){s : Shape I}
	      (tel : Tel s)(i : Index I tel)(arg : Args-tel U tel) ->
	      Args-tel U (ε-tel (index-tel U tel i arg) tel i)
g→rArgs-tel U  empty	      i ∙	    = < refl , ∙ >
g→rArgs-tel U (non-rec A tel) i < a , arg > = < a , g→rArgs-tel U (tel a) (i a) arg >
g→rArgs-tel U (rec H di tel)  i < d , arg > = < d , g→rArgs-tel U tel i arg >

g→rArgs : {I : Set}(U : I -> Set)(γ : OPg I)(a : Args U γ) -> Args U (ε γ (index U γ a))
g→rArgs U ∅		  ()
g→rArgs U (con tel i | _) (inl arg) = inl (g→rArgs-tel U tel i arg)
g→rArgs U (con _   _ | γ) (inr arg) = inr (g→rArgs U γ arg)

introg : {I : Set}(γ : OPg I)(a : Args (Ug γ) γ) -> Ug γ (index (Ug γ) γ a)
introg γ a = intror (g→rArgs (Ug γ) γ a)

r→gArgs-tel : {I : Set}(U : I -> Set){s : Shape I}(tel : Tel s)(ind : Index I tel)
	      (i : I) -> Args-tel U (ε-tel i tel ind) -> Args-tel U tel
r→gArgs-tel U  empty	      ind i < p , ∙ >	= ∙
r→gArgs-tel U (non-rec A tel) ind i < a , arg > = < a , r→gArgs-tel U (tel a) (ind a) i arg >
r→gArgs-tel U (rec H di tel)  ind i < d , arg > = < d , r→gArgs-tel U tel ind i arg >

r→gArgs : {I : Set}(U : I -> Set)(γ : OPg I)(i : I)(a : Args U (ε γ i)) -> Args U γ
r→gArgs U  ∅		  _ ()
r→gArgs U (con tel ind | _) i (inl arg) = inl (r→gArgs-tel U tel ind i arg)
r→gArgs U (con _   _   | γ) i (inr arg) = inr (r→gArgs U γ i arg)

-- Elimination rules

IndArg-tel : {I : Set}(U : I -> Set){s : Shape I}(tel : Tel s) -> Args-tel U tel -> Set
IndArg-tel U  empty	     ∙		 = Zero
IndArg-tel U (non-rec A tel) < a , arg > = IndArg-tel U (tel a) arg
IndArg-tel U (rec H di tel)  < d , arg > = H + IndArg-tel U tel arg

IndArg : {I E : Set}(U : I -> Set)(γ : OP I E) -> Args U γ -> Set
IndArg U  ∅		 ()
IndArg U (con tel _ | _) (inl arg) = IndArg-tel U tel arg
IndArg U (con _   _ | γ) (inr arg) = IndArg U γ arg

-- Examples

nat : OPr One
nat = \i -> con empty ∙ | con (rec One (\_ -> ∙) empty) ∙ | ∅

N : Set
N = Ur nat ∙

z : N
z = intror (inl ∙)

s : N -> N
s n = intror (inr (inl < (\_ -> n) , ∙ >))


------------------------------------------------------------------------
-- Functional semantics and type soundness proof for an untyped
-- λ-calculus with constants
------------------------------------------------------------------------

module Lambda.Substitution.Functional where

open import Category.Monad.Partiality as Partiality using (_⊥; never)
open import Category.Monad.Partiality.All as All
  using (All; now; later)
open import Codata.Musical.Notation
open import Data.Maybe as Maybe using (Maybe)
open import Data.Maybe.Relation.Unary.Any as Maybe using (just)
open import Data.Vec using ([])
open import Relation.Binary.PropositionalEquality as P using (_≡_)
open import Relation.Nullary

open All.Alternative
private
  open module E {A : Set} = Partiality.Equality (_≡_ {A = A})
  open module R {A : Set} =
    Partiality.Reasoning (P.isEquivalence {A = A})

open import Lambda.Syntax
open WHNF
open import Lambda.Substitution
open import Lambda.Closure.Functional
  using (module PF; module Workaround)
open Workaround hiding (_>>=_)

------------------------------------------------------------------------
-- Semantics

infix 5 _∙_

-- Note that this definition gives us determinism "for free".

mutual

  ⟦_⟧′ : Tm 0 → Maybe (Value 0) ⊥P
  ⟦ con i ⟧′   = return (con i)
  ⟦ var () ⟧′
  ⟦ ƛ t ⟧′     = return (ƛ t)
  ⟦ t₁ · t₂ ⟧′ = ⟦ t₁ ⟧′ >>= λ v₁ →
                 ⟦ t₂ ⟧′ >>= λ v₂ →
                 v₁ ∙ v₂
    where open Workaround

  _∙_ : Value 0 → Value 0 → Maybe (Value 0) ⊥P
  con i ∙ v₂ = fail
  ƛ t₁  ∙ v₂ = later (♯ ⟦ t₁ / sub ⌜ v₂ ⌝ ⟧′)

⟦_⟧ : Tm 0 → Maybe (Value 0) ⊥
⟦ t ⟧ = ⟪ ⟦ t ⟧′ ⟫P

------------------------------------------------------------------------
-- Example

Ω-loops : ⟦ Ω ⟧ ≈ never
Ω-loops = later (♯ Ω-loops)

------------------------------------------------------------------------
-- Some lemmas

open PF hiding (_>>=_)

-- An abbreviation.

infix 5 _⟦·⟧_

_⟦·⟧_ : Maybe (Value 0) ⊥ → Maybe (Value 0) ⊥ → Maybe (Value 0) ⊥
v₁ ⟦·⟧ v₂ = v₁ >>= λ v₁ → v₂ >>= λ v₂ → ⟪ v₁ ∙ v₂ ⟫P
  where open PF

-- _⟦·⟧_ preserves equality.

_⟦·⟧-cong_ : ∀ {k v₁₁ v₁₂ v₂₁ v₂₂} →
             Rel k v₁₁ v₂₁ → Rel k v₁₂ v₂₂ →
             Rel k (v₁₁ ⟦·⟧ v₁₂) (v₂₁ ⟦·⟧ v₂₂)
v₁₁≈v₂₁ ⟦·⟧-cong v₁₂≈v₂₂ =
  v₁₁≈v₂₁ >>=-cong λ v₁ →
  v₁₂≈v₂₂ >>=-cong λ v₂ →
  ⟪ v₁ ∙ v₂ ⟫P ∎

-- The semantics of application is compositional (with respect to the
-- syntactic equality which is used).

·-comp : (t₁ t₂ : Tm 0) →
         ⟦ t₁ · t₂ ⟧ ≅ ⟦ t₁ ⟧ ⟦·⟧ ⟦ t₂ ⟧
·-comp t₁ t₂ =
  ⟦ t₁ · t₂ ⟧                                  ≅⟨ >>=-hom ⟦ t₁ ⟧′ _ ⟩

  PF._>>=_ ⟦ t₁ ⟧ (λ v₁ →
           ⟪ Workaround._>>=_ ⟦ t₂ ⟧′ (λ v₂ →
             v₁ ∙ v₂) ⟫P)                      ≅⟨ ((⟦ t₁ ⟧ ∎) >>=-cong λ _ →
                                                   >>=-hom ⟦ t₂ ⟧′ _) ⟩
  ⟦ t₁ ⟧ ⟦·⟧ ⟦ t₂ ⟧                            ∎

------------------------------------------------------------------------
-- Type soundness

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

WF-Value : Ty → Value 0 → Set
WF-Value σ v = [] ⊢ ⌜ v ⌝ ∈ σ

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

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

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

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

mutual

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

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

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


module Inductive.Examples.Empty where

open import Inductive
open import Tuple

open import Data.Fin
open import Data.Product
open import Data.List
open import Data.Vec

⊥ : Set
⊥ = Inductive []

contradiction : {A : Set} → ⊥ → A
contradiction = rec []


{-

Definition of the Klein bottle as a HIT

-}
{-# OPTIONS --cubical --safe #-}
module Cubical.HITs.KleinBottle.Properties where

open import Cubical.Core.Everything

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Equiv
open import Cubical.Foundations.Isomorphism
open import Cubical.Foundations.GroupoidLaws
open import Cubical.Foundations.HLevels
open import Cubical.Foundations.Transport
open import Cubical.Foundations.Univalence
open import Cubical.Data.Nat
open import Cubical.Data.Int public renaming (_+_ to _+Int_ ; +-assoc to +Int-assoc; +-comm to +Int-comm)
open import Cubical.Data.Prod
open import Cubical.Data.Sigma
open import Cubical.HITs.S1
open import Cubical.HITs.PropositionalTruncation

open import Cubical.HITs.KleinBottle.Base

loop1 : S¹ → KleinBottle
loop1 base = point
loop1 (loop i) = line1 i

invS¹Loop : S¹ → Set
invS¹Loop base = S¹
invS¹Loop (loop i) = invS¹Path i

loop1Inv : (s : S¹) → loop1 (inv s) ≡ loop1 s
loop1Inv base = line2
loop1Inv (loop i) = square i

twist : (s : S¹) → PathP (λ i → invS¹Path i) s (inv s)
twist s i = glue (λ {(i = i0) → s; (i = i1) → inv s}) (inv s)

twistBaseLoop : (s : S¹) → invS¹Loop s
twistBaseLoop base = base
twistBaseLoop (loop i) = twist base i

kleinBottle≃Σ : KleinBottle ≃ Σ S¹ invS¹Loop
kleinBottle≃Σ = isoToEquiv (iso fro to froTo toFro)
  where
  fro : KleinBottle → Σ S¹ invS¹Loop
  fro point = (base , base)
  fro (line1 i) = (base , loop i)
  fro (line2 j) = (loop (~ j) , twist base (~ j))
  fro (square i j) = (loop (~ j) , twist (loop i) (~ j))

  toLoopFiller : (j : I) → ua invS¹Equiv j → I → KleinBottle
  toLoopFiller j g l =
    hfill
      (λ l → λ
        { (j = i0) → loop1Inv g l
        ; (j = i1) → loop1 g
        })
      (inS (loop1 (unglue (j ∨ ~ j) g)))
      l

  to : Σ S¹ invS¹Loop → KleinBottle
  to (base , s) = loop1 s
  to (loop j , g) = toLoopFiller j g i1

  toFro : (a : KleinBottle) → to (fro a) ≡ a
  toFro point = refl
  toFro (line1 i) = refl
  toFro (line2 j) k = lUnit line2 (~ k) j
  toFro (square i j) k = lUnit (square i) (~ k) j

  froLoop1 : (s : S¹) → fro (loop1 s) ≡ (base , s)
  froLoop1 base = refl
  froLoop1 (loop i) = refl

  froLoop1Inv :
    PathP (λ k → (s : S¹) → froLoop1 (inv s) k ≡ froLoop1 s k)
      (λ s l → fro (loop1Inv s l))
      (λ s l → loop (~ l) , twist s (~ l))
  froLoop1Inv k base l = loop (~ l) , twist base (~ l)
  froLoop1Inv k (loop i) l = loop (~ l) , twist (loop i) (~ l)

  froTo : (a : Σ S¹ invS¹Loop) → fro (to a) ≡ a
  froTo (base , s) = froLoop1 s
  froTo (loop j , g) k =
    hcomp
      (λ l → λ
        { (j = i0) → froLoop1Inv k g l
        ; (j = i1) → froLoop1 g k
        ; (k = i0) → fro (toLoopFiller j g l)
        ; (k = i1) →
          ( loop (j ∨ ~ l)
          , glue
             (λ
               { (j = i0) (l = i1) → g
               ; (j = i1) → g
               ; (l = i0) → unglue (j ∨ ~ j) g
               })
             (unglue (j ∨ ~ j) g)
          )
        })
      (froLoop1 (unglue (j ∨ ~ j) g) k)

isGroupoidKleinBottle : isGroupoid KleinBottle
isGroupoidKleinBottle =
  transport (λ i → isGroupoid (ua kleinBottle≃Σ (~ i)))
    (isOfHLevelΣ 3 isGroupoidS¹
      (λ s →
        recPropTrunc
          (isPropIsOfHLevel 3 (invS¹Loop s))
          (λ p → subst (λ s → isGroupoid (invS¹Loop s)) p isGroupoidS¹)
          (isConnectedS¹ s)))

-- Transport across the following is too slow :(

ΩKlein≡Int² : Path KleinBottle point point ≡ Int × Int
ΩKlein≡Int² =
  Path KleinBottle point point
    ≡⟨ (λ i → basePath i ≡ basePath i) ⟩
  Path (Σ S¹ invS¹Loop) (base , base) (base , base)
    ≡⟨ sym (ua Σ≡) ⟩
  Σ ΩS¹ (λ p → PathP (λ j → invS¹Loop (p j)) base base)
    ≡⟨ (λ i → Σ ΩS¹ (λ p → PathP (λ j → invS¹Loop (p (j ∨ i))) (twistBaseLoop (p i)) base)) ⟩
  Σ ΩS¹ (λ _ → ΩS¹)
    ≡⟨ sym A×B≡A×ΣB ⟩
  ΩS¹ × ΩS¹
    ≡⟨ (λ i → ΩS¹≡Int i × ΩS¹≡Int i) ⟩
  Int × Int ∎
  where
  basePath : PathP (λ i → ua kleinBottle≃Σ i) point (base , base)
  basePath i = glue (λ {(i = i0) → point; (i = i1) → base , base}) (base , base)

-- We can at least define the winding function directly and get results on small examples

windingKlein : Path KleinBottle point point → Int × Int
windingKlein p = (z₀ , z₁)
  where
  step₀ : Path (Σ S¹ invS¹Loop) (base , base) (base , base)
  step₀ = (λ i → kleinBottle≃Σ .fst (p i))

  z₀ : Int
  z₀ = winding (λ i → kleinBottle≃Σ .fst (p i) .fst)

  z₁ : Int
  z₁ = winding
    (transport
      (λ i → PathP (λ j → invS¹Loop (step₀ (j ∨ i) .fst)) (twistBaseLoop (step₀ i .fst)) base)
      (cong snd step₀))

_ : windingKlein line1 ≡ (pos 0 , pos 1)
_ = refl

_ : windingKlein line2 ≡ (negsuc 0 , pos 0)
_ = refl

_ : windingKlein (line1 ∙ line2) ≡ (negsuc 0 , negsuc 0)
_ = refl

_ : windingKlein (line1 ∙ line2 ∙ line1) ≡ (negsuc 0 , pos 0)
_ = refl


open import Agda.Builtin.Coinduction
open import Agda.Builtin.IO
open import Agda.Builtin.Unit

data D : Set where
  c : ∞ D → D

d : D
d = c (♯ d)

postulate
  seq    : {A B : Set} → A → B → B
  return : {A : Set} → A → IO A

{-# COMPILE GHC return = \_   -> return #-}
{-# COMPILE GHC seq    = \_ _ -> seq    #-}

main : IO ⊤
main = seq d (return tt)


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

module Data.List.Relation.Unary where

open import Prelude
open import Data.List.Base
open import Data.Fin
open import Relation.Nullary
open import Data.Sum

private
  variable p : Level

module Inductive◇ where
 data ◇ {A : Type a} (P : A → Type p) : List A → Type (a ℓ⊔ p) where
   here   : ∀ {x xs} → P x      → ◇ P (x ∷ xs)
   there  : ∀ {x xs} → ◇ P xs   → ◇ P (x ∷ xs)

◇ : (P : A → Type p) → List A → Type _
◇ P xs = ∃[ i ] P (xs ! i)

◇! : (P : A → Type p) → List A → Type _
◇! P xs = isContr (◇ P xs)

module Exists {a} {A : Type a} {p} (P : A → Type p) where
  push : ∀ {x xs} → ◇ P xs → ◇ P (x ∷ xs)
  push (n , p) = fs n , p

  pull : ∀ {x xs} → ¬ P x → ◇ P (x ∷ xs) → ◇ P xs
  pull ¬Px (f0   , p) = ⊥-elim (¬Px p)
  pull ¬Px (fs n , p) = n , p

  uncons : ∀ {x xs} → ◇ P (x ∷ xs) → P x ⊎ ◇ P xs
  uncons (f0 , p) = inl p
  uncons (fs x , p) = inr (x , p)

  infixr 5 _++◇_ _◇++_
  _++◇_ : ∀ {xs} ys → ◇ P xs → ◇ P (ys ++ xs)
  [] ++◇ ys = ys
  (x ∷ xs) ++◇ ys = push (xs ++◇ ys)

  _◇++_ : ∀ xs → ◇ P xs → ∀ {ys} → ◇ P (xs ++ ys)
  _◇++_ (x ∷ xs) (f0  , ∃Pxs) = f0 , ∃Pxs
  _◇++_ (x ∷ xs) (fs n , ∃Pxs) = push (xs ◇++ (n , ∃Pxs))

  push! : ∀ {x xs} → ¬ P x → ◇! P xs → ◇! P (x ∷ xs)
  push! ¬Px x∈!xs .fst = push (x∈!xs .fst)
  push! ¬Px x∈!xs .snd (f0   , px) = ⊥-elim (¬Px px)
  push! ¬Px x∈!xs .snd (fs n  , y∈xs) i = push (x∈!xs .snd (n , y∈xs) i)

  pull! : ∀ {x xs} → ¬ P x → ◇! P (x ∷ xs) → ◇! P xs
  pull! ¬Px ((f0   , px    ) , uniq) = ⊥-elim (¬Px px)
  pull! ¬Px ((fs n  , x∈xs  ) , uniq) .fst = (n , x∈xs)
  pull! ¬Px ((fs n  , x∈xs  ) , uniq) .snd (m , x∈xs′) i =
    pull ¬Px (uniq (fs m , x∈xs′ ) i)

  here! : ∀ {x xs} → isContr (P x) → ¬ ◇ P xs → ◇! P (x ∷ xs)
  here! Px p∉xs .fst = f0 , Px .fst
  here! Px p∉xs .snd (f0  , p∈xs) i .fst = f0
  here! Px p∉xs .snd (f0  , p∈xs) i .snd = Px .snd p∈xs i
  here! Px p∉xs .snd (fs n , p∈xs) = ⊥-elim (p∉xs (n , p∈xs))

  module _ (P? : ∀ x → Dec (P x)) where
    open import Relation.Nullary.Decidable.Logic

    ◇? : ∀ xs → Dec (◇ P xs)
    ◇? [] = no λ ()
    ◇? (x ∷ xs) =  ⟦yes ⟦l f0 ,_ ,r push ⟧ ,no uncons ⟧ (P? x || ◇? xs)

◻ : (P : A → Type p) → List A → Type _
◻ P xs = ∀ i → P (xs ! i)

module Forall {a} {A : Type a} {p} (P : A → Type p) where
  push : ∀ {x xs} → P x → ◻ P xs → ◻ P (x ∷ xs)
  push Px Pxs f0 = Px
  push Px Pxs (fs n) = Pxs n

  uncons : ∀ {x xs} → ◻ P (x ∷ xs) → P x × ◻ P xs
  uncons Pxs = Pxs f0 , Pxs ∘ fs

  pull : ∀ {x xs} → ◻ P (x ∷ xs) → ◻ P xs
  pull = snd ∘ uncons

  _++◇_ : ∀ xs {ys} → ◻ P (xs ++ ys) → ◻ P ys
  [] ++◇ xs⊆P = xs⊆P
  (x ∷ xs) ++◇ xs⊆P = xs ++◇ (xs⊆P ∘ fs)

  _◇++_ : ∀ xs {ys} → ◻ P (xs ++ ys) → ◻ P xs
  ([] ◇++ xs⊆P) ()
  ((x ∷ xs) ◇++ xs⊆P) f0 = xs⊆P f0
  ((x ∷ xs) ◇++ xs⊆P) (fs n) = (xs ◇++ pull xs⊆P) n

  both : ∀ xs {ys} → ◻ P xs → ◻ P ys → ◻ P (xs ++ ys)
  both [] xs⊆P ys⊆P = ys⊆P
  both (x ∷ xs) xs⊆P ys⊆P f0 = xs⊆P f0
  both (x ∷ xs) xs⊆P ys⊆P (fs i) = both xs (pull xs⊆P) ys⊆P i

  empty : ◻ P []
  empty ()

  module _ where
    open import Relation.Nullary.Decidable.Logic
    ◻? : (∀ x → Dec (P x)) → ∀ xs → Dec (◻ P xs)
    ◻? P? [] = yes λ ()
    ◻? P? (x ∷ xs) =  ⟦yes uncurry push
                      ,no uncons
                      ⟧ (P? x && ◻? P? xs)

module Forall-NotExists {a} {A : Type a} {p} (P : A → Type p) where
  open import Relation.Nullary.Stable
  open import Data.Empty.Properties

  open Forall P
  ¬P = ¬_ ∘ P
  module ∃¬ = Exists ¬P

  ∀⇒¬∃¬ : ∀ xs → ◻ P xs → ¬ (◇ ¬P xs)
  ∀⇒¬∃¬ (x ∷ xs) xs⊆P (f0 , ∃¬P∈xs) = ∃¬P∈xs(xs⊆P f0)
  ∀⇒¬∃¬ (x ∷ xs) xs⊆P (fs n , ∃¬P∈xs) = ∀⇒¬∃¬ xs (xs⊆P ∘ fs) (n , ∃¬P∈xs)

  module _ (stable : ∀ {x} → Stable (P x)) where
    ¬∃¬⇒∀ : ∀ xs → ¬ (◇ ¬P xs) → ◻ P xs
    ¬∃¬⇒∀ (x ∷ xs) ¬∃¬P∈xs f0 = stable (¬∃¬P∈xs ∘ (f0 ,_))
    ¬∃¬⇒∀ (x ∷ xs) ¬∃¬P∈xs (fs n) = ¬∃¬⇒∀ xs (¬∃¬P∈xs ∘ ∃¬.push) n

    leftInv′ : ∀ (prop : ∀ {x} → isProp (P x)) xs → (x : ◻ P xs) → ¬∃¬⇒∀ xs (∀⇒¬∃¬ xs x) ≡ x
    leftInv′ prop [] x i ()
    leftInv′ prop (x ∷ xs) xs⊆P i f0 = prop (stable λ ¬p → ¬p (xs⊆P f0)) (xs⊆P f0) i
    leftInv′ prop (x ∷ xs) xs⊆P i (fs n) = leftInv′ prop xs (pull xs⊆P) i n

    ∀⇔¬∃¬ : ∀ (prop : ∀ {x} → isProp (P x)) xs → ◻ P xs ⇔ (¬ ◇ ¬P xs)
    ∀⇔¬∃¬ _ xs .fun = ∀⇒¬∃¬ xs
    ∀⇔¬∃¬ _ xs .inv = ¬∃¬⇒∀ xs
    ∀⇔¬∃¬ p xs .leftInv  = leftInv′ p xs
    ∀⇔¬∃¬ _ xs .rightInv x = isProp¬ _ _ x

module Exists-NotForall {a} {A : Type a} {p} (P : A → Type p) where
  open Exists P
  ¬P = ¬_ ∘ P
  module ∀¬ = Forall ¬P

  ∃⇒¬∀¬ : ∀ xs → ◇ P xs → ¬ ◻ ¬P xs
  ∃⇒¬∀¬ (x ∷ xs) (f0  , P∈xs) xs⊆P = xs⊆P f0 P∈xs
  ∃⇒¬∀¬ (x ∷ xs) (fs n , P∈xs) xs⊆P = ∃⇒¬∀¬ xs (n , P∈xs) (xs⊆P ∘ fs)

  module _ (P? : ∀ x → Dec (P x)) where
    ¬∀¬⇒∃ : ∀ xs → ¬ ◻ ¬P xs → ◇ P xs
    ¬∀¬⇒∃ [] ¬xs⊆¬P = ⊥-elim (¬xs⊆¬P λ ())
    ¬∀¬⇒∃ (x ∷ xs) ¬xs⊆¬P with P? x
    ¬∀¬⇒∃ (x ∷ xs) ¬xs⊆¬P | yes p = f0 , p
    ¬∀¬⇒∃ (x ∷ xs) ¬xs⊆¬P | no ¬p = push (¬∀¬⇒∃ xs (¬xs⊆¬P ∘ ∀¬.push ¬p))

module Congruence {p q} (P : A → Type p) (Q : B → Type q)
                  {f : A → B} (f↑ : ∀ {x} → P x → Q (f x)) where
  cong-◇ : ∀ xs → ◇ P xs → ◇ Q (map f xs)
  cong-◇ (x ∷ xs) (f0 , P∈xs) = f0 , f↑ P∈xs
  cong-◇ (x ∷ xs) (fs n , P∈xs) = Exists.push Q (cong-◇ xs (n , P∈xs))

◇-concat : ∀ (P : A → Type p) xs → ◇ (◇ P) xs → ◇ P (concat xs)
◇-concat P (x ∷ xs) (f0 , ps) = Exists._◇++_ P x ps
◇-concat P (x ∷ xs) (fs n , ps) = Exists._++◇_ P x (◇-concat P xs (n , ps))

◻-concat : ∀ (P : A → Type p) xs → ◻ (◻ P) xs → ◻ P (concat xs)
◻-concat P [] xs⊆P ()
◻-concat P (x ∷ xs) xs⊆P = Forall.both P x (xs⊆P f0) (◻-concat P xs (xs⊆P ∘ fs))

module Search {A : Type a} where
  data Result {p} (P : A → Type p) (xs : List A) : Bool → Type (a ℓ⊔ p) where
    all′ : ◻ P xs → Result P xs true
    except′ : ◇ (¬_ ∘ P) xs → Result P xs false

  record Found {p} (P : A → Type p) (xs : List A) : Type (a ℓ⊔ p) where
    field
      found? : Bool
      result : Result P xs found?
  open Found public

  pattern all    ps = record { found? = true ; result = all′ ps }
  pattern except ¬p = record { found? = false ; result = except′ ¬p }

  module _ {p} {P : A → Type p} (P? : ∀ x → Dec (P x)) where
    search : ∀ xs → Found P xs
    search [] = all λ ()
    search (x ∷ xs) = search′ x xs (P? x) (search xs)
      where
      search′ : ∀ x xs → Dec (P x) → Found P xs → Found P (x ∷ xs)
      search′ x xs Px Pxs .found? = Px .does and Pxs .found?
      search′ x xs (no ¬p) Pxs .result = except′ (f0 , ¬p)
      search′ x xs (yes p) (except ¬p) .result = except′ (Exists.push (¬_ ∘ P) ¬p)
      search′ x xs (yes p) (all ps) .result = all′ (Forall.push P p ps)


-- {-# OPTIONS -v interaction.case:10 -v tc.cover:40 #-}
module Issue635 where

record Pointed : Set₁ where
  field
    Carrier : Set
    empty : Carrier
    equal : Carrier → Carrier → Set

record PointedMorphism (M₁ M₂ : Pointed) : Set where
  constructor morph
  module M₁ = Pointed M₁
  module M₂ = Pointed M₂
  field
    f : M₁.Carrier → M₂.Carrier
    .identity : M₂.equal (f M₁.empty) M₂.empty

g : ∀ (M₁ M₂ : Pointed) → PointedMorphism M₁ M₂ → PointedMorphism M₁ M₂
g M₁ M₂ (morph f identity) = morph f identity

f : ∀ {M₁ M₂ : Pointed} → PointedMorphism M₁ M₂ → PointedMorphism M₁ M₂
f x = {!x!}

{- WAS:
case splitting on x in that hole produces this monstrosity:

f {.Splitting.recCon-NOT-PRINTED Carrier empty times equal} {.Splitting.recCon-NOT-PRINTED Carrier₁ empty₁ times₁ equal₁} (morph f identity) = ?
-}

-- Andreas, 2013-03-21
-- NOW: case splitting on x yields pattern (morph f identity)


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

open import HoTT
open import cw.CW
open import cw.FinCW
open import cw.FinBoundary
open import cohomology.ChainComplex
open import cohomology.Theory

module cw.cohomology.AxiomaticIsoCellular (OT : OrdinaryTheory lzero) where

  open OrdinaryTheory OT
  open import cw.cohomology.cellular.ChainComplex
  import cw.cohomology.reconstructed.cochain.Complex OT as RCC
  open import cw.cohomology.ReconstructedCohomologyGroups OT
  open import cw.cohomology.ReconstructedCochainsEquivCellularCochains OT

  axiomatic-iso-cellular : ∀ m {n} (⊙fin-skel : ⊙FinSkeleton n)
    →  C m ⊙⟦ ⊙⦉ ⊙fin-skel ⦊ ⟧
    ≃ᴳ cohomology-group
        (cochain-complex ⦉ ⊙FinSkeleton.skel ⊙fin-skel ⦊
          (FinSkeleton-has-cells-with-dec-eq (⊙FinSkeleton.skel ⊙fin-skel))
          (FinSkeleton-has-degrees-with-finite-support (⊙FinSkeleton.skel ⊙fin-skel))
          (C2-abgroup 0))
        m
  axiomatic-iso-cellular m ⊙fin-skel =
      C m ⊙⟦ ⊙⦉ ⊙fin-skel ⦊ ⟧
        ≃ᴳ⟨ reconstructed-cohomology-group m ⊙⦉ ⊙fin-skel ⦊
              (⊙FinSkeleton-has-cells-with-choice 0 ⊙fin-skel lzero) ⟩
      cohomology-group (RCC.cochain-complex ⊙⦉ ⊙fin-skel ⦊) m
        ≃ᴳ⟨ frc-iso-fcc ⊙fin-skel m ⟩
      cohomology-group
        (cochain-complex ⦉ ⊙FinSkeleton.skel ⊙fin-skel ⦊
          (FinSkeleton-has-cells-with-dec-eq (⊙FinSkeleton.skel ⊙fin-skel))
          (FinSkeleton-has-degrees-with-finite-support (⊙FinSkeleton.skel ⊙fin-skel))
          (C2-abgroup 0))
        m
        ≃ᴳ∎


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

module Erased-cubical.Cubical where

open import Agda.Builtin.Cubical.Path

data ∥_∥ (A : Set) : Set where
  ∣_∣     : A → ∥ A ∥
  trivial : (x y : ∥ A ∥) → x ≡ y

data D′ : Set where
  @0 c′ : D′


module ial where

open import ial-datatypes public
open import logic public
open import thms public
open import termination public
open import error public
open import io public


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

{-
  Now it only has specialized constructs and lemmas for π₀ (x ≡ y)

  Should be rewritten with something like Algebra.Groupoids
-}

open import Base

module Homotopy.PathTruncation where

open import HLevel
open import HLevelBis
open import Homotopy.Truncation

_≡₀_ : ∀ {i} {A : Set i} → A → A → Set i
_≡₀_ x y = π₀ (x ≡ y)

infix 8 _∘₀_  -- \o\0
_∘₀_ : ∀ {i} {A : Set i} {x y z : A} → x ≡₀ y → y ≡₀ z → x ≡₀ z
_∘₀_ =
  π₀-extend-nondep ⦃ →-is-set $ π₀-is-set _ ⦄ (λ p →
    π₀-extend-nondep ⦃ π₀-is-set _ ⦄ (λ q →
      proj $ p ∘ q))

!₀ : ∀ {i} {A : Set i} {x y : A} → x ≡₀ y → y ≡₀ x
!₀ = π₀-extend-nondep ⦃ π₀-is-set _ ⦄ (proj ◯ !)

refl₀ : ∀ {i} {A : Set i} {a : A} → a ≡₀ a
refl₀ = proj refl

ap₀ : ∀ {i j} {A : Set i} {B : Set j} {x y : A} (f : A → B)
  → x ≡₀ y → f x ≡₀ f y
ap₀ f = π₀-extend-nondep ⦃ π₀-is-set _ ⦄ (proj ◯ ap f)

module _ {i} {A : Set i} where

  refl₀-right-unit : ∀ {x y : A} (q : x ≡₀ y) → (q ∘₀ refl₀) ≡ q
  refl₀-right-unit {x = x} {y} = π₀-extend
    ⦃ λ _ →  ≡-is-set $ π₀-is-set (x ≡ y) ⦄
    (λ x → ap proj $ refl-right-unit x)

  refl₀-left-unit : ∀ {x y : A} (q : x ≡₀ y) → (refl₀ ∘₀ q) ≡ q
  refl₀-left-unit {x = x} {y} = π₀-extend
    ⦃ λ _ →  ≡-is-set $ π₀-is-set (x ≡ y) ⦄
    (λ _ → refl)

  concat₀-assoc : {x y z t : A} (p : x ≡₀ y) (q : y ≡₀ z) (r : z ≡₀ t)
    → (p ∘₀ q) ∘₀ r ≡ p ∘₀ (q ∘₀ r)
  concat₀-assoc =
    π₀-extend ⦃ λ _ → Π-is-set λ _ → Π-is-set λ _ → ≡-is-set $ π₀-is-set _ ⦄ (λ p →
      π₀-extend ⦃ λ _ → Π-is-set λ _ → ≡-is-set $ π₀-is-set _ ⦄ (λ q →
        π₀-extend ⦃ λ _ → ≡-is-set $ π₀-is-set _ ⦄ (λ r →
          ap proj $ concat-assoc p q r)))

  concat₀-ap₀ : ∀ {j} {B : Set j} (f : A → B) {x y z : A} (p : x ≡₀ y) (q : y ≡₀ z)
    → ap₀ f p ∘₀ ap₀ f q ≡ ap₀ f (p ∘₀ q)
  concat₀-ap₀ f =
    π₀-extend ⦃ λ _ → Π-is-set λ _ → ≡-is-set $ π₀-is-set _ ⦄ (λ p →
      π₀-extend ⦃ λ _ → ≡-is-set $ π₀-is-set _ ⦄ (λ q →
        ap proj $ concat-ap f p q))

  ap₀-compose : ∀ {j k} {B : Set j} {C : Set k} (g : B → C) (f : A → B)
    {x y : A} (p : x ≡₀ y) → ap₀ (g ◯ f) p ≡ ap₀ g (ap₀ f p)
  ap₀-compose f g =
    π₀-extend ⦃ λ _ → ≡-is-set $ π₀-is-set _ ⦄ (λ p →
      ap proj $ ap-compose f g p)

module _ {i} {A : Set i} where
  trans-id≡₀cst : {a b c : A} (p : b ≡ c) (q : b ≡₀ a)
    → transport (λ x → x ≡₀ a) p q ≡ proj (! p) ∘₀ q
  trans-id≡₀cst refl q = ! $ refl₀-left-unit q

  trans-cst≡₀id : {a b c : A} (p : b ≡ c) (q : a ≡₀ b)
    → transport (λ x → a ≡₀ x) p q ≡ q ∘₀ proj p
  trans-cst≡₀id refl q = ! $ refl₀-right-unit q

module _ {i} {A : Set i} where
  homotopy₀-naturality : ∀ {j} {B : Set j} (f g : A → B)
    (p : (x : A) → f x ≡₀ g x) {x y : A} (q : x ≡₀ y)
    → ap₀ f q ∘₀ p y ≡ p x ∘₀ ap₀ g q
  homotopy₀-naturality f g p {x} {y} q = π₀-extend
    ⦃ λ q → ≡-is-set {x = ap₀ f q ∘₀ p y} {y = p x ∘₀ ap₀ g q}
            $ π₀-is-set (f x ≡ g y) ⦄
    (lemma {x} {y}) q
    where
      lemma : ∀ {x y : A} (q : x ≡ y) → ap₀ f (proj q) ∘₀ p y ≡ p x ∘₀ ap₀ g (proj q)
      lemma refl =
        refl₀ ∘₀ p _
          ≡⟨ refl₀-left-unit (p _) ⟩
        p _
          ≡⟨ ! $ refl₀-right-unit _ ⟩∎
        p _ ∘₀ refl₀
          ∎

-- Loop space commutes with truncation in the sense that
-- τ n (Ω X) = Ω (τ (S n) X)
-- (actually, this is true more generally for paths spaces and we need this
-- level of generality to prove it)

module _ {i} {n : ℕ₋₂} {A : Set i} where

  private
    to : (x y : A) → (τ n (x ≡ y)) → ((proj {n = S n} x) ≡ (proj y))
    to x y = τ-extend-nondep ⦃ τ-is-truncated (S n) A _ _ ⦄ (ap proj)

    -- [truncated-path-space (proj x) (proj y)] is [τ n (x ≡ y)]
    truncated-path-space : (u v : τ (S n) A) → Type≤ n i
    truncated-path-space = τ-extend-nondep
                             ⦃ →-is-truncated (S n) (Type≤-is-truncated n _) ⦄
                             (λ x → τ-extend-nondep ⦃ Type≤-is-truncated n _ ⦄
                               (λ y → τ n (x ≡ y) , τ-is-truncated n _))

    -- We now extend [to] to the truncation of [A], and this is why we needed to
    -- first extend the return type of [to]
    to' : (u v : τ (S n) A) → (π₁ (truncated-path-space u v) → u ≡ v)
    to' = τ-extend ⦃ λ x → Π-is-truncated (S n) (λ a →
                             Π-is-truncated (S n) (λ b →
                               ≡-is-truncated (S n)
                                 (τ-is-truncated (S n) A)))⦄
            (λ x → τ-extend ⦃ λ t → Π-is-truncated (S n) (λ a →
                                      ≡-is-truncated (S n)
                                        (τ-is-truncated (S n) A))⦄
              (λ y → to x y))

    from'-refl : (u : τ (S n) A) → (π₁ (truncated-path-space u u))
    from'-refl = τ-extend ⦃ λ x → truncated-is-truncated-S n
                                    (π₂ (truncated-path-space x x))⦄
                   (λ x → proj refl)

    from' : (u v : τ (S n) A) → (u ≡ v → π₁ (truncated-path-space u v))
    from' u .u refl = from'-refl u

    from : (x y : A) → (proj {n = S n} x ≡ proj y → τ n (x ≡ y))
    from x y p = from' (proj x) (proj y) p

    from-to : (x y : A) (p : τ n (x ≡ y)) → from x y (to x y p) ≡ p
    from-to x y = τ-extend ⦃ λ _ → ≡-is-truncated n (τ-is-truncated n _)⦄
                    (from-to' x y) where

      from-to' : (x y : A) (p : x ≡ y) → from x y (to x y (proj p)) ≡ proj p
      from-to' x .x refl = refl

    to'-from' : (u v : τ (S n) A) (p : u ≡ v) → to' u v (from' u v p) ≡ p
    to'-from' x .x refl = to'-from'-refl x where
      to'-from'-refl : (u : τ (S n) A) → to' u u (from' u u refl) ≡ refl
      to'-from'-refl = τ-extend ⦃ λ _ → ≡-is-truncated (S n)
                                          (≡-is-truncated (S n)
                                            (τ-is-truncated (S n) A))⦄
                         (λ _ → refl)

    to-from : (x y : A) (p : proj {n = S n} x ≡ proj y) → to x y (from x y p) ≡ p
    to-from x y p = to'-from' (proj x) (proj y) p

  τ-path-equiv-path-τ-S : {x y : A} → τ n (x ≡ y) ≃ (proj {n = S n} x ≡ proj y)
  τ-path-equiv-path-τ-S {x} {y} =
    (to x y , iso-is-eq _ (from x y) (to-from x y) (from-to x y))

  module _ where
    open import Homotopy.Connected

    abstract
      connected-has-connected-paths : is-connected (S n) A → (p q : A) → is-connected n (p ≡ q)
      connected-has-connected-paths conn p q =
        equiv-types-truncated ⟨-2⟩ (τ-path-equiv-path-τ-S ⁻¹) (contr-is-prop conn (proj p) (proj q))

    connected-has-all-τ-paths : is-connected (S n) A → (p q : A) → τ n (p ≡ q)
    connected-has-all-τ-paths conn p q = π₁ $ connected-has-connected-paths conn p q


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

open import Level
open import Relation.Unary using (Pred)
open import Data.Product hiding (swap; curry)
open import Data.List
open import Data.List.Relation.Unary.All as All
open import Data.List.Relation.Unary.Any
open import Data.List.Membership.Propositional
open import Data.List.Prefix
open import Function as Fun using (case_of_)
open import Relation.Binary.PropositionalEquality
open ≡-Reasoning

import Experiments.Category as Cat

module Experiments.StrongMonad
  (Type : Set)
  (Val : Type → Cat.MP₀ (⊑-preorder {A = Type}))
  (funext : ∀ {a b} → Extensionality a b) where

open import Relation.Binary.PropositionalEquality.Extensionality funext

open Cat (⊑-preorder {A = Type})
open Product

World = List Type

Store : World → Set
Store Σ = All (λ a → Val a · Σ) Σ

import Relation.Binary.HeterogeneousEquality as H
module HR = H.≅-Reasoning

mcong : ∀ {Σₛ Σ Σ' ℓ}{P : MP ℓ}
        {μ : Store Σ}{μ' : Store Σ'}{p : Σ ⊒ Σₛ}{p' : Σ' ⊒ Σₛ}{q : P · Σ}{q' : P · Σ'} →
        Σ ≡ Σ' → p H.≅ p' → μ H.≅ μ' → q H.≅ q' → (Σ , p , μ , q) ≡ (Σ' , p' , μ' , q')
mcong refl H.refl H.refl H.refl = refl

-- The monad takes monotone predicates over worlds
-- to monotone functions over stores in these worlds.
M : ∀ {ℓ} → MP ℓ → MP ℓ
M P = mp (λ Σ → ∀ Σ₁ → (ext : Σ ⊑ Σ₁) → (μ : Store Σ₁) → ∃ λ Σ₂ → Σ₂ ⊒ Σ₁ × Store Σ₂ × P · Σ₂)
  record {
    monotone = λ w₀ f Σ w₁ μ → f Σ (⊑-trans w₀ w₁) μ ;
    monotone-refl = λ f → funext³ (λ Σ₁ _ μ → cong (λ u → f Σ₁ u μ) ⊑-trans-refl) ;
    monotone-trans = λ f w₀ w₁ → funext³ (λ Σ₁ w₂ μ → cong (λ u → f Σ₁ u μ) (sym ⊑-trans-assoc))
  }

-- η is the natural transformation between the identity functor and the functor M
η : ∀ {p}(P : MP p) → P ⇒ M P
η P =
  mk⇒
    (λ p Σ ext μ → Σ , ⊑-refl , μ , MP.monotone P ext p)
    (λ c~c' {p} → begin
      (λ z ext μ → z , ⊑-refl , μ , MP.monotone P ext (MP.monotone P c~c' p))
        ≡⟨ funext³ (λ z ext μ → cong (λ u → z , ⊑-refl , μ , u) (sym (MP.monotone-trans P p c~c' ext))) ⟩
      (λ z ext μ → z , ⊑-refl , μ , MP.monotone P (⊑-trans c~c' ext) p)
        ≡⟨ refl ⟩
      MP.monotone (M P) c~c' (λ z ext μ → z , ⊑-refl , μ , MP.monotone P ext p)
    ∎)

μ : ∀ {p}(P : MP p) → M (M P) ⇒ M P
μ P = mk⇒
  (λ pc Σ₁ ext μ →
    case pc Σ₁ ext μ of λ{
      (Σ₂ , ext₁ , μ₁ , f) →
        case f Σ₂ ⊑-refl μ₁ of λ{
          (Σ₃ , ext₂ , μ₂ , v) → Σ₃ , ⊑-trans ext₁ ext₂ , μ₂ , v
        }
    })
  (λ c~c' → refl)

fmap : ∀ {p q}{P : MP p}{Q : MP q} → (P ⇒ Q) → M P ⇒ M Q
fmap F = mk⇒
  (λ x Σ₁ ext μ → case x Σ₁ ext μ of λ{
    (Σ₂ , ext₁ , μ₁ , v) → Σ₂ , ext₁ , μ₁ , apply F v
  })
  (λ c~c' → refl)

bind : ∀ {p q}{P : MP p}(Q : MP q) → (P ⇒ M Q) → M P ⇒ M Q
bind Q F = μ Q ∘ fmap F

open Exponential (sym ⊑-trans-assoc) ⊑-trans-refl ⊑-trans-refl'

module Coherence where
  -- We prove that η is the component of a natural transformation between the functors
  -- 𝕀 and M where 𝕀 is the identity functor.
  η-natural : ∀ {p q}(P : MP p)(Q : MP q)(F : P ⇒ Q) → η Q ∘ F ⇒≡ (fmap F) ∘ η P
  η-natural P Q F p =
    begin
      apply (η Q ∘ F) p
        ≡⟨ refl ⟩
      apply (η Q) (apply F p)
        ≡⟨ refl ⟩
      (λ Σ ext μ → Σ , ⊑-refl , μ , MP.monotone Q ext (apply F p))
        ≡⟨ funext³ (λ Σ ext μ → cong (λ u → Σ , ⊑-refl , μ , u) (sym (monotone-comm F ext))) ⟩
      (λ Σ ext μ → Σ , ⊑-refl , μ , apply F (MP.monotone P ext p))
        ≡⟨ refl ⟩
      apply (fmap F) (λ Σ ext μ → Σ , ⊑-refl , μ , MP.monotone P ext p)
        ≡⟨ refl ⟩
      apply (fmap F) (apply (η P) p)
        ≡⟨ refl ⟩
      apply (fmap F ∘ η P) p
    ∎

  -- We prove that μ is the component of a natural transformation between
  -- the functors M² and M.
  μ-natural : ∀ {p q}(P : MP p)(Q : MP q)(F : P ⇒ Q) → μ Q ∘ (fmap (fmap F)) ⇒≡ (fmap F) ∘ μ P
  μ-natural P Q F = λ p → refl

  -- from these facts we can prove the monad laws
  left-id : ∀ {p}{P : MP p} → μ P ∘ fmap (η P) ⇒≡ id (M P)
  left-id {P = P} p = funext³
    λ Σ₁ ext μ₁ → mcong {P = P} refl (lem refl) H.refl (H.≡-to-≅ (MP.monotone-refl P _))
    where
      lem : ∀ {Σ Σ' Σ'' : World}{xs : Σ'' ⊒ Σ'}{ys : Σ'' ⊒ Σ} → Σ ≡ Σ' →  ⊑-trans xs ⊑-refl H.≅ ys
      lem {xs = xs}{ys} refl with ⊑-unique xs ys
      ... | refl = H.≡-to-≅ ⊑-trans-refl'

  right-id : ∀ {p}{P : MP p} → μ P ∘ (η (M P)) ⇒≡ id (M P)
  right-id {P = P} p = funext³ λ Σ₁ ext μ₁ →
    let f = (λ{(Σ₃ , ext₂ , μ₂ , v) → Σ₃ , ⊑-trans ⊑-refl ext₂ , μ₂ , v}) in
      trans
        (cong f (cong (λ u → p Σ₁ u μ₁) ⊑-trans-refl'))
        (mcong {P = P} refl (H.≡-to-≅ ⊑-trans-refl) H.refl H.refl )

  -- if we have a (M³ P) then it doesn't matter if we join
  -- the outer or inner ones first.
  assoc : ∀ {p}{P : MP p} → μ P ∘ (fmap (μ P)) ⇒≡ μ P ∘ μ (M P)
  assoc {P = P} p = funext³ λ Σ₁ ext μ → mcong {P = P} refl (H.≡-to-≅ ⊑-trans-assoc) H.refl H.refl

  -- fmap makes M a functor
  fmap-id : ∀ {ℓ}{P : MP ℓ} → fmap (id P) ⇒≡ id (M P)
  fmap-id = λ p → refl

  fmap-∘ : ∀ {ℓ₁ ℓ₂ ℓ₃}{P : MP ℓ₁}{Q : MP ℓ₂}{R : MP ℓ₃}(F : P ⇒ Q)(G : Q ⇒ R) →
           fmap (G ∘ F) ⇒≡ fmap G ∘ fmap F
  fmap-∘ F G = λ p → refl

module Strong where
  -- tensorial strength
  ts : ∀ {p q}(P : MP p)(Q : MP q) → P ⊗ M Q ⇒ M (P ⊗ Q)
  ts P Q = mk⇒
    (λ x Σ₁ ext μ →
      case (proj₂ x) Σ₁ ext μ of λ{
        (_ , ext₁ , μ₁ , v ) → _ , ext₁ , μ₁ , (MP.monotone P (⊑-trans ext ext₁) (proj₁ x)) , v
      }
    )
    (λ c~c' →
      funext³ λ Σ₁ ext μ₁ →
      mcong {P = (P ⊗ Q)} refl H.refl H.refl (
        H.cong₂ {A = P · _}{B = λ _ → Q · _} (λ u v → u , v)
          (H.≡-to-≅ (begin
            MP.monotone P (⊑-trans ext _) _
              ≡⟨ (MP.monotone-trans P _ _ _) ⟩
            MP.monotone P _ (MP.monotone P ext (MP.monotone P c~c' _))
              ≡⟨ cong (λ x → MP.monotone P _ x) (sym ((MP.monotone-trans P _ _ _))) ⟩
            MP.monotone P _ (MP.monotone P (⊑-trans c~c' ext) _)
              ≡⟨ sym ((MP.monotone-trans P _ _ _)) ⟩
            MP.monotone P (⊑-trans (⊑-trans c~c' ext) _) _
          ∎))
          H.refl
      ))

  ts' : ∀ {p q}(P : MP p)(Q : MP q) → M P ⊗ Q ⇒ M (P ⊗ Q)
  ts' P Q = fmap (swap Q P) ∘ ts Q P ∘ swap _ _

  diagram₁ : ∀ {ℓ}{P : MP ℓ} → fmap {P = ⊤ ⊗ P} (π₂ {P = ⊤}) ∘ ts ⊤ P ⇒≡ π₂ {P = ⊤}
  diagram₁ = λ p → refl

  diagram₂ : ∀ {ℓ₁ ℓ₂ ℓ₃}{A : MP ℓ₁}{B : MP ℓ₂}{C : MP ℓ₃} →
            fmap (comm A B C) ∘ ts (A ⊗ B) C ⇒≡ ts A (B ⊗ C) ∘ xmap (id A) (ts B C) ∘ comm A B (M C)
  diagram₂ = λ p → refl

  diagram₃ : ∀ {ℓ₁ ℓ₂}(A : MP ℓ₁)(B : MP ℓ₂) →
             η (A ⊗ B) ⇒≡ ts A B ∘ xmap (id A) (η B)
  diagram₃ A B (a , b) = funext³ λ Σ ext r → mcong {P = A ⊗ B} refl H.refl H.refl
    (H.≡-to-≅
      (cong₂ _,_
        (cong₂
          (λ ext a → MP.monotone A ext a)
          (trans (sym ⊑-trans-refl') (cong (λ r → ⊑-trans ext r) refl))
          refl
        )
        (cong (λ x → x) refl)))

  diagram₄ : ∀ {ℓ₁ ℓ₂}{A : MP ℓ₁}{B : MP ℓ₂} →
            ts A B ∘ xmap (id A) (μ B) ⇒≡ μ (A ⊗ B) ∘ fmap (ts A B) ∘ ts A (M B)
  diagram₄ {A = A}{B} p@(l , r) =
    funext³ λ Σ₁ ext μ' →
      mcong {P = A ⊗ B} refl H.refl H.refl (
        H.cong (Fun.flip _,_ _)
          (H.≡-to-≅ (
            trans
              (cong (λ u → MP.monotone A u l) ⊑-trans-assoc)
              (trans
                (MP.monotone-trans A l (⊑-trans ext _) _)
                (cong
                  (λ u → MP.monotone A u (MP.monotone A (⊑-trans _ _) l))
                  (sym ⊑-trans-refl))))))

  -- internal fmap
  fmap' : ∀ {p q}{P : MP p}{Q : MP q} → (Q ^ P) ⇒ (M Q) ^ (M P)
  fmap' {P = P}{Q} = curry (fmap ε ∘ ts (Q ^ P) P)

  -- internal bind
  bind' : ∀ {p q}{P : MP p}(Q : MP q) → (M P ⊗ (M Q ^ P)) ⇒ M Q
  bind' {P = P} Q =
    μ Q
    ∘ fmap (ε ∘ swap P (M Q ^ P))
    ∘ ts' P (M Q ^ P)


------------------------------------------------------------------------
-- Some theory of Erased, developed using Cubical Agda
------------------------------------------------------------------------

-- This module instantiates and reexports code from Erased.

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

import Equality.Path as P

module Erased.Cubical
  {e⁺} (eq : ∀ {a p} → P.Equality-with-paths a p e⁺) where

open P.Derived-definitions-and-properties eq

open import Prelude

open import Bijection equality-with-J using (_↔_)
import Bijection P.equality-with-J as PB
open import Equality.Path.Isomorphisms eq
open import Equivalence equality-with-J as Eq
  using (_≃_; Is-equivalence)
import Equivalence P.equality-with-J as PEq
import Erased.Basics as EB
import Erased.Level-1 P.equality-with-J as EP
import Erased.Level-1 equality-with-J as E
open import Function-universe equality-with-J

private
  variable
    a p : Level
    A   : Type a
    x y : A

------------------------------------------------------------------------
-- []-cong

-- Given an erased path from x to y there is a path from [ x ] to
-- [ y ].

[]-cong-Path :
  {@0 A : Type a} {@0 x y : A} →
  EB.Erased (x P.≡ y) → EB.[ x ] P.≡ EB.[ y ]
[]-cong-Path EB.[ eq ] = λ i → EB.[ eq i ]

-- []-cong-Path is an equivalence.

[]-cong-Path-equivalence :
  {@0 A : Type a} {@0 x y : A} →
  PEq.Is-equivalence ([]-cong-Path {x = x} {y = y})
[]-cong-Path-equivalence =
  PEq._≃_.is-equivalence $ PEq.↔⇒≃ (record
    { surjection = record
      { logical-equivalence = record
        { from = λ eq → EB.[ P.cong EB.erased eq ]
        }
      ; right-inverse-of = λ _ → P.refl
      }
    ; left-inverse-of = λ _ → P.refl
    })

-- A rearrangement lemma for []-cong-Path (which holds by definition).

[]-cong-Path-[refl] :
  {@0 A : Type a} {@0 x : A} →
  []-cong-Path EB.[ P.refl {x = x} ] P.≡ P.refl {x = EB.[ x ]}
[]-cong-Path-[refl] = P.refl

-- The []-cong axioms can be instantiated.

instance-of-[]-cong-axiomatisation-for-Path : EP.[]-cong-axiomatisation a
instance-of-[]-cong-axiomatisation-for-Path = λ where
  .EP.[]-cong-axiomatisation.[]-cong             → []-cong-Path
  .EP.[]-cong-axiomatisation.[]-cong-equivalence → []-cong-Path-equivalence
  .EP.[]-cong-axiomatisation.[]-cong-[refl]      → []-cong-Path-[refl]

-- Given an erased proof of equality of x and y one can show that
-- EB.[ x ] is equal to EB.[ y ].

[]-cong : {@0 A : Type a} {@0 x y : A} →
          EB.Erased (x ≡ y) → EB.[ x ] ≡ EB.[ y ]
[]-cong {x = x} {y = y} =
  EB.Erased (x ≡ y)      ↝⟨ (λ (EB.[ eq ]) → EB.[ _↔_.to ≡↔≡ eq ]) ⟩
  EB.Erased (x P.≡ y)    ↝⟨ []-cong-Path ⟩
  EB.[ x ] P.≡ EB.[ y ]  ↔⟨ inverse ≡↔≡ ⟩□
  EB.[ x ] ≡ EB.[ y ]    □

-- []-cong is an equivalence.

[]-cong-equivalence :
  {@0 A : Type a} {@0 x y : A} →
  Is-equivalence ([]-cong {x = x} {y = y})
[]-cong-equivalence {x = x} {y = y} = _≃_.is-equivalence (
  EB.Erased (x ≡ y)      ↔⟨ _≃_.from ↔≃↔ $
                            EP.[]-cong.Erased-cong-↔
                              instance-of-[]-cong-axiomatisation-for-Path
                              (_≃_.to ↔≃↔ ≡↔≡) ⟩
  EB.Erased (x P.≡ y)    ↝⟨ _↔_.from ≃↔≃ PEq.⟨ _ , []-cong-Path-equivalence ⟩ ⟩
  EB.[ x ] P.≡ EB.[ y ]  ↔⟨ inverse ≡↔≡ ⟩□
  EB.[ x ] ≡ EB.[ y ]    □)

-- A rearrangement lemma for []-cong.

[]-cong-[refl] :
  {@0 A : Type a} {@0 x : A} →
  []-cong EB.[ refl x ] ≡ refl EB.[ x ]
[]-cong-[refl] {x = x} =
  sym $ _↔_.to (from≡↔≡to Eq.⟨ _ , []-cong-equivalence ⟩) (
    EB.[ _↔_.from ≡↔≡ (P.cong EB.erased (_↔_.to ≡↔≡ (refl EB.[ x ]))) ]  ≡⟨ []-cong EB.[ sym cong≡cong ] ⟩
    EB.[ cong EB.erased (_↔_.from ≡↔≡ (_↔_.to ≡↔≡ (refl EB.[ x ]))) ]    ≡⟨ []-cong EB.[ cong (cong EB.erased) (_↔_.left-inverse-of ≡↔≡ _) ] ⟩
    EB.[ cong EB.erased (refl EB.[ x ]) ]                                ≡⟨ []-cong EB.[ cong-refl _ ] ⟩∎
    EB.[ refl x ]                                                        ∎)

-- The []-cong axioms can be instantiated.

instance-of-[]-cong-axiomatisation : E.[]-cong-axiomatisation a
instance-of-[]-cong-axiomatisation = λ where
  .E.[]-cong-axiomatisation.[]-cong             → []-cong
  .E.[]-cong-axiomatisation.[]-cong-equivalence → []-cong-equivalence
  .E.[]-cong-axiomatisation.[]-cong-[refl]      → []-cong-[refl]

-- Some reexported definitions.

open import Erased equality-with-J instance-of-[]-cong-axiomatisation
  public
  hiding ([]-cong; []-cong-equivalence; []-cong-[refl];
          Π-Erased≃Π0[]; Π-Erased≃Π0)

------------------------------------------------------------------------
-- Variants of some of the reexported definitions

private

  -- The lemma push-subst-[], which is reexported above, can be proved
  -- very easily when path equality is used.

  push-subst-[]-Path :
    {@0 P : A → Type p} {@0 p : P x} {x≡y : x P.≡ y} →
    P.subst (λ x → Erased (P x)) x≡y [ p ] ≡ [ P.subst P x≡y p ]
  push-subst-[]-Path = refl _

  -- Above a lemma H-level-Erased is reexported. That lemma is proved
  -- in a certain way. The following two lemmas are included to
  -- illustrate a somewhat different proof technique that works for
  -- individual h-levels (given by closed natural numbers).

  -- Is-proposition is closed under Erased.

  Is-proposition-Erased :
    {@0 A : Type a} →
    @0 Is-proposition A → Is-proposition (Erased A)
  Is-proposition-Erased {A = A} prop =
    _↔_.from (H-level↔H-level 1)
      (Is-proposition-Erased′
         (_↔_.to (H-level↔H-level 1) prop))
    where
    Is-proposition-Erased′ :
      @0 P.Is-proposition A → P.Is-proposition (Erased A)
    Is-proposition-Erased′ prop x y = λ i →
      [ prop (erased x) (erased y) i ]

  -- Is-set is closed under Erased.

  Is-set-Erased :
    {@0 A : Type a} →
    @0 Is-set A → Is-set (Erased A)
  Is-set-Erased {A = A} set =
    _↔_.from (H-level↔H-level 2)
      (Is-set-Erased′
         (_↔_.to (H-level↔H-level 2) set))
    where
    Is-set-Erased′ : @0 P.Is-set A → P.Is-set (Erased A)
    Is-set-Erased′ set p q = λ i j →
      [ set (P.cong erased p) (P.cong erased q) i j ]

------------------------------------------------------------------------
-- Some isomorphisms/equivalences

-- The following four results are inspired by a result in
-- Mishra-Linger's PhD thesis (see Section 5.4.1).

-- There is a bijection (with paths for equality, not _≡_) between
-- (x : Erased A) → P x and (@0 x : A) → P [ x ].

Π-Erased↔Π0[] :
  {@0 A : Type a} {@0 P : Erased A → Type p} →
  ((x : Erased A) → P x) PB.↔ ((@0 x : A) → P [ x ])
Π-Erased↔Π0[] = record
  { surjection = record
    { logical-equivalence = Π-Erased⇔Π0
    ; right-inverse-of = λ f _ → f
    }
  ; left-inverse-of = λ f _ → f
  }

-- There is an equivalence (with paths for equality, not _≡_) between
-- (x : Erased A) → P x and (@0 x : A) → P [ x ].
--
-- This is not proved by converting Π-Erased↔Π0[] to an equivalence,
-- because the type arguments of the conversion function in
-- Equivalence are not erased, and P can only be used in erased
-- contexts.
--
-- This is a strengthening of E.Π-Erased≃Π0[].

Π-Erased≃Π0[] :
  {@0 A : Type a} {@0 P : Erased A → Type p} →
  ((x : Erased A) → P x) PEq.≃ ((@0 x : A) → P [ x ])
Π-Erased≃Π0[] = record
  { to             = λ f x → f [ x ]
  ; is-equivalence =
        (λ f ([ x ]) → f x)
      , (λ f _ → f)
      , (λ f _ → f)
      , (λ f _ _ x → f [ x ])
  }

-- There is a bijection (with paths for equality, not _≡_) between
-- (x : Erased A) → P (erased x) and (@0 x : A) → P x.

Π-Erased↔Π0 :
  {@0 A : Type a} {@0 P : A → Type p} →
  ((x : Erased A) → P (erased x)) PB.↔ ((@0 x : A) → P x)
Π-Erased↔Π0 = Π-Erased↔Π0[]

-- There is an equivalence (with paths for equality, not _≡_) between
-- (x : Erased A) → P (erased x) and (@0 x : A) → P x.
--
-- This is a strengthening of E.Π-Erased≃Π0.

Π-Erased≃Π0 :
  {@0 A : Type a} {@0 P : A → Type p} →
  ((x : Erased A) → P (erased x)) PEq.≃ ((@0 x : A) → P x)
Π-Erased≃Π0 = Π-Erased≃Π0[]