open import Oscar.Prelude
open import Oscar.Class.Successor₀
open import Oscar.Class.Successor₁
open import Oscar.Class.Injectivity
open import Oscar.Class.Pure

module Oscar.Class.Thickandthin where

module _
  {x} {X : Ø x} {a} (A : X → Ø a) {b} (B : X → Ø b)
  where
  record [𝓣hin] : Ø₀ where
    no-eta-equality
    constructor ∁
  module _
    ⦃ _ : 𝓢uccessor₀ X ⦄
    where
    𝔱hin : ∀ (m : X) → A (⇑₀ m) → B m → Ø b
    𝔱hin m = λ _ _ → B (⇑₀ m)
    𝓽hin = ∀ {m : X} → A (⇑₀ m) → B m → B (⇑₀ m)
    record 𝓣hin ⦃ _ : [𝓣hin] ⦄ : Ø x ∙̂ a ∙̂ b where
      field
        thin : 𝓽hin
      instance `𝓘njection₂ : ∀ {m} → 𝓘njection₂ (𝔱hin m)
      `𝓘njection₂ = ∁ thin
open 𝓣hin ⦃ … ⦄ public

module _
  {x} {X : Ø x} {a} (A : X → Ø a) {b} (B : X → Ø b)
  where
  record [𝓣hick] : Ø₀ where
    no-eta-equality
    constructor ∁
  module _
    ⦃ _ : 𝓢uccessor₀ X ⦄
    where
    𝓽hick = ∀ {m} → A m → B (⇑₀ m) → B m
    record 𝓣hick ⦃ _ : [𝓣hick] ⦄ : Ø x ∙̂ a ∙̂ b where field thick : 𝓽hick
open 𝓣hick ⦃ … ⦄ public

module _
  {x} {X : Ø x}
  {a} (A : X → Ø a)
  {b} (B : X → Ø b)
  {ℓ} (_≈_ : ∀ {x} → B x → B x → Ø ℓ)
  where
  record [𝓣hick/thin=1] : Ø₀ where
    no-eta-equality
    constructor ∁
  module _
    ⦃ _ : 𝓢uccessor₀ X ⦄
    ⦃ _ : [𝓢uccessor₁] A ⦄
    ⦃ _ : 𝓢uccessor₁ A ⦄
    ⦃ _ : [𝓣hin] A B ⦄
    ⦃ _ : 𝓣hin A B ⦄
    ⦃ _ : [𝓣hick] A B ⦄
    ⦃ _ : 𝓣hick A B ⦄
    where
    𝓽hick/thin=1 = ∀ {m} (x : A m) (y : B m) → thick x (thin (⇑₁ x) y) ≈ y
    record 𝓣hick/thin=1 : Ø x ∙̂ a ∙̂ b ∙̂ ℓ where field thick/thin=1 : 𝓽hick/thin=1
open 𝓣hick/thin=1 ⦃ … ⦄ public

module _
  {x} {X : Ø x}
  {a} (A : X → Ø a)
  {b} (B : X → Ø b)
  {c} (C : Ø b → Ø c)
  where
  record [𝓒heck] : Ø₀ where
    no-eta-equality
    constructor ∁
  module _
    ⦃ _ : 𝓢uccessor₀ X ⦄
    where
    𝓬heck = ∀ {m} → A (⇑₀ m) → B (⇑₀ m) → C (B m)
    record 𝓒heck ⦃ _ : [𝓒heck] ⦄ : Ø x ∙̂ a ∙̂ b ∙̂ c where field check : 𝓬heck
open 𝓒heck ⦃ … ⦄ public

check[_] : ∀
  {x} {X : Ø x}
  {a} {A : X → Ø a}
  {b} {B : X → Ø b}
  {c} (C : Ø b → Ø c)
  ⦃ _ : [𝓒heck] A B C ⦄
  ⦃ _ : 𝓢uccessor₀ X ⦄
  ⦃ _ : 𝓒heck A B C ⦄
  → 𝓬heck A B C
check[ _ ] = check

module _
  {x} {X : Ø x}
  {a} (A : X → Ø a)
  {b} (B : X → Ø b)
  {c} (C : Ø b → Ø c)
  {ℓ} (_≈_ : ∀ {x} → C (B x) → C (B x) → Ø ℓ)
  where
  record [𝓒heck/thin=1] : Ø₀ where
    no-eta-equality
    constructor ∁
  module _
    ⦃ _ : 𝓢uccessor₀ X ⦄
    ⦃ _ : [𝓣hin] A B ⦄
    ⦃ _ : 𝓣hin A B ⦄
    ⦃ _ : [𝓒heck] A B C ⦄
    ⦃ _ : 𝓒heck A B C ⦄
    ⦃ _ : 𝓟ure C ⦄
    where
    𝓬heck/thin=1 = ∀ {n} (x : A (⇑₀ n)) (y : B n) → check x (thin x y) ≈ pure y
    record 𝓒heck/thin=1 ⦃ _ : [𝓒heck/thin=1] ⦄ : Ø x ∙̂ a ∙̂ b ∙̂ c ∙̂ ℓ where field check/thin=1 : 𝓬heck/thin=1
open 𝓒heck/thin=1 ⦃ … ⦄ public

check/thin=1[_] : ∀
  {x} {X : Ø x}
  {a} {A : X → Ø a}
  {b} {B : X → Ø b}
  {c} {C : Ø b → Ø c}
  {ℓ} (_≈_ : ∀ {x} → C (B x) → C (B x) → Ø ℓ)
  ⦃ _ : 𝓢uccessor₀ X ⦄
  ⦃ _ : [𝓣hin] A B ⦄
  ⦃ _ : 𝓣hin A B ⦄
  ⦃ _ : [𝓒heck] A B C ⦄
  ⦃ _ : 𝓒heck A B C ⦄
  ⦃ _ : 𝓟ure C ⦄
  ⦃ _ : [𝓒heck/thin=1] A B C _≈_ ⦄
  ⦃ _ : 𝓒heck/thin=1 A B C _≈_ ⦄
  → 𝓬heck/thin=1 A B C _≈_
check/thin=1[ _ ] = check/thin=1

record IsThickandthin
  {x a b c ℓb ℓc}
  {X : Ø x}
  (A : X → Ø a)
  (B : X → Ø b)
  (_≈B_ : ∀ {x} → B x → B x → Ø ℓb)
  (C : Ø b → Ø c)
  (_≈C_ : ∀ {x} → C (B x) → C (B x) → Ø ℓc)
  : Ø x ∙̂ a ∙̂ ↑̂ b ∙̂ ℓb ∙̂ c ∙̂ ℓc where
  constructor ∁
  field
    overlap ⦃ `𝓢uccessor₀ ⦄ : 𝓢uccessor₀ X
    overlap ⦃ `[𝓢uccessor₁] ⦄ : [𝓢uccessor₁] A
    overlap ⦃ `𝓢uccessor₁ ⦄ : 𝓢uccessor₁ A
    overlap ⦃ `[𝓣hick] ⦄ : [𝓣hick] A B
    overlap ⦃ `𝓣hick ⦄ : 𝓣hick A B
    overlap ⦃ `[𝓣hin] ⦄ : [𝓣hin] A B
    overlap ⦃ `𝓣hin ⦄ : 𝓣hin A B
    overlap ⦃ `[𝓘njectivity₂,₁] ⦄ : ∀ {m} → [𝓘njectivity₂,₁] (𝔱hin A B m) _≈B_ _≈B_
    overlap ⦃ `𝓘njectivity₂,₁ ⦄   : ∀ {m} → 𝓘njectivity₂,₁ (𝔱hin A B m) _≈B_ _≈B_
    overlap ⦃ `[𝓒heck] ⦄ : [𝓒heck] A B C
    overlap ⦃ `𝓒heck ⦄ : 𝓒heck A B C
    overlap ⦃ `[𝓣hick/thin=1] ⦄ : [𝓣hick/thin=1] A B _≈B_
    overlap ⦃ `𝓣hick/thin=1 ⦄ : 𝓣hick/thin=1 A B _≈B_
    overlap ⦃ `[𝓒heck/thin=1] ⦄ : [𝓒heck/thin=1] A B C _≈C_
    overlap ⦃ `𝓟ure ⦄ : 𝓟ure C
    overlap ⦃ `𝓒heck/thin=1 ⦄ : 𝓒heck/thin=1 A B C _≈C_

record Thickandthin x a b ℓb c ℓc : Ø ↑̂ (x ∙̂ a ∙̂ b ∙̂ ℓb ∙̂ c ∙̂ ℓc) where
  constructor ∁
  field
    {X} : Ø x
    A : X → Ø a
    B : X → Ø b
    _≈B_ : ∀ {x} → B x → B x → Ø ℓb
    C : Ø b → Ø c
    _≈C_ : ∀ {x} → C (B x) → C (B x) → Ø ℓc
    ⦃ `IsThickandthin ⦄ : IsThickandthin A B _≈B_ C _≈C_


open import Mockingbird.Forest using (Forest)

-- Aristocratic Birds
module Mockingbird.Problems.Chapter19 {ℓb ℓ} (forest : Forest {ℓb} {ℓ}) where

open import Data.Product using (_×_; _,_; ∃-syntax)
open import Function using (_$_)
open import Level using (_⊔_)
open import Data.Vec using ([]; _∷_)
open import Relation.Unary using (Pred; _∈_; _⊆_; _⊇_)

open Forest forest
open import Mockingbird.Forest.Birds forest
open import Mockingbird.Forest.Combination.Vec forest
open import Mockingbird.Forest.Combination.Vec.Properties forest
open import Mockingbird.Forest.Extensionality forest
import Mockingbird.Problems.Chapter11 forest as Chapter₁₁
import Mockingbird.Problems.Chapter12 forest as Chapter₁₂

problem₁″ : ⦃ _ : HasEagle ⦄ ⦃ _ : HasCardinalOnceRemoved ⦄ ⦃ _ : HasCardinalTwiceRemoved ⦄ ⦃ _ : HasWarbler ⦄ → HasJaybird
problem₁″ = record
  { J = C** ∙ (W ∙ (C* ∙ E))
  ; isJaybird = λ x y z w → begin
      C** ∙ (W ∙ (C* ∙ E)) ∙ x ∙ y ∙ z ∙ w  ≈⟨ isCardinalTwiceRemoved (W ∙ (C* ∙ E)) x y z w ⟩
      W ∙ (C* ∙ E) ∙ x ∙ y ∙ w ∙ z          ≈⟨ congʳ $ congʳ $ congʳ $ isWarbler (C* ∙ E) x ⟩
      C* ∙ E ∙ x ∙ x ∙ y ∙ w ∙ z            ≈⟨ congʳ $ congʳ $ isCardinalOnceRemoved E x x y ⟩
      E ∙ x ∙ y ∙ x ∙ w ∙ z                 ≈⟨ isEagle x y x w z ⟩
      x ∙ y ∙ (x ∙ w ∙ z)                   ∎
  }

problem₁′ : ⦃ _ : HasBluebird ⦄ ⦃ _ : HasCardinal ⦄ ⦃ _ : HasWarbler ⦄ → HasJaybird
problem₁′ = record
  { J = B ∙ (B ∙ C) ∙ (W ∙ (B ∙ C ∙ (B ∙ (B ∙ B ∙ B))))
  ; isJaybird = isJaybird ⦃ problem₁″ ⦄
  } where
  instance
    hasEagle = Chapter₁₁.problem₇
    hasCardinalOnceRemoved = Chapter₁₁.problem₃₁
    hasCardinalTwiceRemoved = Chapter₁₁.problem₃₅-C**

problem₁ : ⦃ _ : HasBluebird ⦄ ⦃ _ : HasThrush ⦄ ⦃ _ : HasMockingbird ⦄ → HasJaybird
problem₁ = problem₁′
  where
    instance
      hasCardinal = Chapter₁₁.problem₂₁′
      hasWarbler = Chapter₁₂.problem₇

problem₂ : ⦃ _ : HasJaybird ⦄ ⦃ _ : HasIdentity ⦄ → HasQuixoticBird
problem₂ = record
  { Q₁ = J ∙ I
  ; isQuixoticBird = λ x y z → begin
      J ∙ I ∙ x ∙ y ∙ z    ≈⟨ isJaybird I x y z ⟩
      I ∙ x ∙ (I ∙ z ∙ y)  ≈⟨ congʳ $ isIdentity x ⟩
      x ∙ (I ∙ z ∙ y)      ≈⟨ congˡ $ congʳ $ isIdentity z ⟩
      x ∙ (z ∙ y)          ∎
  }

problem₃ : ⦃ _ : HasQuixoticBird ⦄ ⦃ _ : HasIdentity ⦄ → HasThrush
problem₃ = record
  { T = Q₁ ∙ I
  ; isThrush = λ x y → begin
      Q₁ ∙ I ∙ x ∙ y  ≈⟨ isQuixoticBird I x y ⟩
      I ∙ (y ∙ x)     ≈⟨ isIdentity $ y ∙ x ⟩
      y ∙ x           ∎
  }

problem₄ : ⦃ _ : HasJaybird ⦄ ⦃ _ : HasThrush ⦄ → HasRobin
problem₄ = record
  { R = J ∙ T
  ; isRobin = λ x y z → begin
      J ∙ T ∙ x ∙ y ∙ z    ≈⟨ isJaybird T x y z ⟩
      T ∙ x ∙ (T ∙ z ∙ y)  ≈⟨ isThrush x $ T ∙ z ∙ y ⟩
      T ∙ z ∙ y ∙ x        ≈⟨ congʳ $ isThrush z y ⟩
      y ∙ z ∙ x            ∎
  }

problem₅-C* : ⦃ _ : HasCardinal ⦄ ⦃ _ : HasQuixoticBird ⦄ → HasCardinalOnceRemoved
problem₅-C* = record
  { C* = C ∙ (Q₁ ∙ C)
  ; isCardinalOnceRemoved = λ x y z w → begin
      C ∙ (Q₁ ∙ C) ∙ x ∙ y ∙ z ∙ w  ≈⟨ congʳ $ congʳ $ isCardinal (Q₁ ∙ C) x y ⟩
      Q₁ ∙ C ∙ y ∙ x ∙ z ∙ w        ≈⟨ congʳ $ congʳ $ isQuixoticBird C y x ⟩
      C ∙ (x ∙ y) ∙ z ∙ w           ≈⟨ isCardinal (x ∙ y) z w ⟩
      x ∙ y ∙ w ∙ z                 ∎
  }

problem₅ : ⦃ _ : HasRobin ⦄ ⦃ _ : HasQuixoticBird ⦄ → HasBluebird
problem₅ = record
  { B = C* ∙ Q₁
  ; isBluebird = λ x y z → begin
      C* ∙ Q₁ ∙ x ∙ y ∙ z  ≈⟨ isCardinalOnceRemoved Q₁ x y z ⟩
      Q₁ ∙ x ∙ z ∙ y       ≈⟨ isQuixoticBird x z y ⟩
      x ∙ (y ∙ z)          ∎
  } where
  instance
    hasCardinal = Chapter₁₁.problem₂₁
    hasCardinalOnceRemoved = problem₅-C*

problem₆ : ⦃ _ : HasJaybird ⦄ ⦃ _ : HasBluebird ⦄ ⦃ _ : HasThrush ⦄
  → ∃[ J₁ ] (∀ x y z w → J₁ ∙ x ∙ y ∙ z ∙ w ≈ y ∙ x ∙ (w ∙ x ∙ z))
problem₆ =
  ( B ∙ J ∙ T
  , λ x y z w → begin
      B ∙ J ∙ T ∙ x ∙ y ∙ z ∙ w    ≈⟨ (congʳ $ congʳ $ congʳ $ isBluebird J T x) ⟩
      J ∙ (T ∙ x) ∙ y ∙ z ∙ w      ≈⟨ isJaybird (T ∙ x) y z w ⟩
      T ∙ x ∙ y ∙ (T ∙ x ∙ w ∙ z)  ≈⟨ congʳ $ isThrush x y ⟩
      y ∙ x ∙ (T ∙ x ∙ w ∙ z)      ≈⟨ congˡ $ congʳ $ isThrush x w ⟩
      y ∙ x ∙ (w ∙ x ∙ z)          ∎
  )

problem₇ : ⦃ _ : HasCardinal ⦄ ⦃ _ : HasThrush ⦄
  → ∃[ J₁ ] (∀ x y z w → J₁ ∙ x ∙ y ∙ z ∙ w ≈ y ∙ x ∙ (w ∙ x ∙ z))
  → HasMockingbird
problem₇ (J₁ , isJ₁) = record
  { M = C ∙ (C ∙ (C ∙ J₁ ∙ T) ∙ T) ∙ T
  ; isMockingbird = λ x → begin
      C ∙ (C ∙ (C ∙ J₁ ∙ T) ∙ T) ∙ T ∙ x  ≈⟨ isCardinal _ T x ⟩
      C ∙ (C ∙ J₁ ∙ T) ∙ T ∙ x ∙ T        ≈⟨ congʳ $ isCardinal _ T x ⟩
      C ∙ J₁ ∙ T ∙ x ∙ T ∙ T              ≈⟨ congʳ $ congʳ $ isCardinal J₁ T x ⟩
      J₁ ∙ x ∙ T ∙ T ∙ T                  ≈⟨ isJ₁ x T T T ⟩
      T ∙ x ∙ (T ∙ x ∙ T)                 ≈⟨ isThrush x (T ∙ x ∙ T) ⟩
      T ∙ x ∙ T ∙ x                       ≈⟨ congʳ $ isThrush x T ⟩
      T ∙ x ∙ x                           ≈⟨ isThrush x x ⟩
      x ∙ x                               ∎
  }

module _  ⦃ _ : HasJaybird ⦄ ⦃ hasIdentity′ : HasIdentity ⦄ where
  private
    instance
      hasQuixoticBird = problem₂

  hasThrush : HasThrush
  hasThrush = problem₃

  private
    instance
      _ = hasThrush
      hasRobin = problem₄

  hasBluebird : HasBluebird
  hasBluebird = problem₅

  private
    instance
      _ = hasBluebird
      hasCardinal = Chapter₁₁.problem₂₁′

  hasMockingbird : HasMockingbird
  hasMockingbird = problem₇ problem₆

  hasIdentity : HasIdentity
  hasIdentity = hasIdentity′

-- Equality of predicates.
infix 4 _≐_
_≐_ : ∀ {a ℓ} {A : Set a} (P Q : Pred A ℓ) → Set (a ⊔ ℓ)
P ≐ Q = P ⊆ Q × Q ⊆ P

module _ ⦃ _ : Extensional ⦄
         ⦃ _ : HasBluebird ⦄ ⦃ _ : HasMockingbird ⦄ ⦃ _ : HasThrush ⦄
         ⦃ _ : HasIdentity ⦄ ⦃ _ : HasJaybird ⦄ where
  private
    ⟨B,M,T,I⟩ = ⟨ B ∷ M ∷ T ∷ I ∷ [] ⟩
    ⟨J,I⟩ = ⟨ J ∷ I ∷ [] ⟩

  module _ where
    private
      instance
        hasCardinal = Chapter₁₁.problem₂₁′
        hasWarbler = Chapter₁₂.problem₇

      b : B ∈ ⟨B,M,T,I⟩
      b = [ here refl ]

      m : M ∈ ⟨B,M,T,I⟩
      m = [ there (here refl) ]

      t : T ∈ ⟨B,M,T,I⟩
      t = [ there (there (here refl)) ]

      c : C ∈ ⟨B,M,T,I⟩
      c = b ⟨∙⟩ b ⟨∙⟩ t ⟨∙⟩ (b ⟨∙⟩ b ⟨∙⟩ t) ⟨∙⟩ (b ⟨∙⟩ b ⟨∙⟩ t)

      w : W ∈ ⟨B,M,T,I⟩
      w = b ⟨∙⟩ (t ⟨∙⟩ (b ⟨∙⟩ m ⟨∙⟩ (b ⟨∙⟩ b ⟨∙⟩ t))) ⟨∙⟩ (b ⟨∙⟩ b ⟨∙⟩ t)

    ⟨J,I⟩⊆⟨B,M,T,I⟩ : ⟨J,I⟩ ⊆ ⟨B,M,T,I⟩
    ⟨J,I⟩⊆⟨B,M,T,I⟩ [ here x≈J ] = subst′
      (trans x≈J $ ext′ $ ext′ $ ext′ $ ext′ $ trans
        (isJaybird _ _ _ _)
        (sym $ isJaybird ⦃ problem₁′ ⦄ _ _ _ _))
      (b ⟨∙⟩ (b ⟨∙⟩ c) ⟨∙⟩ (w ⟨∙⟩ (b ⟨∙⟩ c ⟨∙⟩ (b ⟨∙⟩ (b ⟨∙⟩ b ⟨∙⟩ b)))))
    ⟨J,I⟩⊆⟨B,M,T,I⟩ [ there (here x≈I) ] = [ there (there (there (here x≈I))) ]
    ⟨J,I⟩⊆⟨B,M,T,I⟩ (x∈⟨J,I⟩ ⟨∙⟩ y∈⟨J,I⟩ ∣ xy≈z) = ⟨J,I⟩⊆⟨B,M,T,I⟩ x∈⟨J,I⟩ ⟨∙⟩ ⟨J,I⟩⊆⟨B,M,T,I⟩ y∈⟨J,I⟩ ∣ xy≈z

  module _ where
    private
      instance
        hasQuixoticBird = problem₂
        hasRobin = problem₄
        hasCardinal = Chapter₁₁.problem₂₁
        hasCardinalOnceRemoved = problem₅-C*

      j : J ∈ ⟨J,I⟩
      j = [ here refl ]

      i : I ∈ ⟨J,I⟩
      i = [ there (here refl) ]

      q₁ : Q₁ ∈ ⟨J,I⟩
      q₁ = j ⟨∙⟩ i

      t : T ∈ ⟨J,I⟩
      t = subst′ (ext′ (ext′ (trans (isThrush _ _) (sym (isThrush ⦃ problem₃ ⦄ _ _))))) $
        j ⟨∙⟩ i ⟨∙⟩ i

      r : R ∈ ⟨J,I⟩
      r = j ⟨∙⟩ t

      c : C ∈ ⟨J,I⟩
      c = r ⟨∙⟩ r ⟨∙⟩ r

      c* : C* ∈ ⟨J,I⟩
      c* = c ⟨∙⟩ (q₁ ⟨∙⟩ c)

      b : B ∈ ⟨J,I⟩
      b = subst′ (ext′ (ext′ (ext′ (trans (isBluebird _ _ _) (sym (isBluebird ⦃ problem₅ ⦄ _ _ _)))))) $
        c* ⟨∙⟩ q₁

      m : M ∈ ⟨J,I⟩
      m = subst′ (ext′ (trans (isMockingbird _) (sym (isMockingbird ⦃ problem₇ problem₆ ⦄ _)))) $
        c ⟨∙⟩ (c ⟨∙⟩ (c ⟨∙⟩ (b ⟨∙⟩ j ⟨∙⟩ t) ⟨∙⟩ t) ⟨∙⟩ t) ⟨∙⟩ t

    ⟨J,I⟩⊇⟨B,M,T,I⟩ : ⟨J,I⟩ ⊇ ⟨B,M,T,I⟩
    ⟨J,I⟩⊇⟨B,M,T,I⟩ [ here x≈B ] = subst′ x≈B b
    ⟨J,I⟩⊇⟨B,M,T,I⟩ [ there (here x≈M) ] = subst′ x≈M m
    ⟨J,I⟩⊇⟨B,M,T,I⟩ [ there (there (here x≈T)) ] = subst′ x≈T t
    ⟨J,I⟩⊇⟨B,M,T,I⟩ [ there (there (there (here x≈I))) ] = [ there (here x≈I) ]
    ⟨J,I⟩⊇⟨B,M,T,I⟩ (x∈⟨B,M,T,I⟩ ⟨∙⟩ y∈⟨B,M,T,I⟩ ∣ xy≈z) = ⟨J,I⟩⊇⟨B,M,T,I⟩ x∈⟨B,M,T,I⟩ ⟨∙⟩ ⟨J,I⟩⊇⟨B,M,T,I⟩ y∈⟨B,M,T,I⟩ ∣ xy≈z

  ⟨J,I⟩≐⟨B,M,T,I⟩ : ⟨ J ∷ I ∷ [] ⟩ ≐ ⟨ B ∷ M ∷ T ∷ I ∷ [] ⟩
  ⟨J,I⟩≐⟨B,M,T,I⟩ = (⟨J,I⟩⊆⟨B,M,T,I⟩ , ⟨J,I⟩⊇⟨B,M,T,I⟩)


module nodcap.Base where

open import Data.Nat as ℕ using (ℕ; suc; zero)
open import Data.Pos as ℕ⁺ using (ℕ⁺; suc; _+_)
open import Data.List as L using (List; []; _∷_; _++_)
open import Data.List.Any using (Any; here; there)
open import Data.List.Any.Membership.Propositional using (_∈_; _∼[_]_; bag)
open import Data.Product using (_×_; _,_; uncurry; map)
open import Data.Sum using (_⊎_; inj₁; inj₂)
open import Function using (id; _$_)
open import Relation.Binary.PropositionalEquality as P using (_≡_)

-- Types.

data Type : Set where
  𝟏 : Type
  ⊥ : Type
  𝟎 : Type
  ⊤ : Type
  _⊗_ : (A B : Type) → Type
  _⅋_ : (A B : Type) → Type
  _⊕_ : (A B : Type) → Type
  _&_ : (A B : Type) → Type
  ![_]_ : (n : ℕ⁺) (A : Type) → Type
  ?[_]_ : (n : ℕ⁺) (A : Type) → Type

-- Duality.

_^ : Type → Type
𝟏 ^ = ⊥
⊥ ^ = 𝟏
𝟎 ^ = ⊤
⊤ ^ = 𝟎
(A ⊗ B) ^ = (A ^) ⅋ (B ^)
(A ⅋ B) ^ = (A ^) ⊗ (B ^)
(A ⊕ B) ^ = (A ^) & (B ^)
(A & B) ^ = (A ^) ⊕ (B ^)
(![ n ] A) ^ = ?[ n ] (A ^)
(?[ n ] A) ^ = ![ n ] (A ^)

^-inv : (A : Type) → A ^ ^ ≡ A
^-inv 𝟏 = P.refl
^-inv ⊥ = P.refl
^-inv 𝟎 = P.refl
^-inv ⊤ = P.refl
^-inv (A ⊗ B) = P.cong₂ _⊗_ (^-inv A) (^-inv B)
^-inv (A ⅋ B) = P.cong₂ _⅋_ (^-inv A) (^-inv B)
^-inv (A ⊕ B) = P.cong₂ _⊕_ (^-inv A) (^-inv B)
^-inv (A & B) = P.cong₂ _&_ (^-inv A) (^-inv B)
^-inv (![ n ] A) = P.cong ![ n ]_ (^-inv A)
^-inv (?[ n ] A) = P.cong ?[ n ]_ (^-inv A)

-- Lollipop.

_⊸_ : (A B : Type) → Type
A ⊸ B = (A ^) ⅋ B

-- Polarity.

data Pos : (A : Type) → Set where
  𝟎 : Pos 𝟎
  𝟏 : Pos 𝟏
  _⊗_ : (A B : Type) → Pos (A ⊗ B)
  _⊕_ : (A B : Type) → Pos (A ⊕ B)
  ![_]_ : (n : ℕ⁺) (A : Type) → Pos (![ n ] A)

data Neg : (A : Type) → Set where
  ⊥ : Neg ⊥
  ⊤ : Neg ⊤
  _⅋_ : (A B : Type) → Neg (A ⅋ B)
  _&_ : (A B : Type) → Neg (A & B)
  ?[_]_ : (n : ℕ⁺) (A : Type) → Neg (?[ n ] A)

pol? : (A : Type) → Pos A ⊎ Neg A
pol? 𝟏 = inj₁ 𝟏
pol? ⊥ = inj₂ ⊥
pol? 𝟎 = inj₁ 𝟎
pol? ⊤ = inj₂ ⊤
pol? (A ⊗ B) = inj₁ (A ⊗ B)
pol? (A ⅋ B) = inj₂ (A ⅋ B)
pol? (A ⊕ B) = inj₁ (A ⊕ B)
pol? (A & B) = inj₂ (A & B)
pol? (![ n ] A) = inj₁ (![ n ] A)
pol? (?[ n ] A) = inj₂ (?[ n ] A)

^-posneg : {A : Type} (P : Pos A) → Neg (A ^)
^-posneg 𝟎 = ⊤
^-posneg 𝟏 = ⊥
^-posneg (A ⊗ B) = (A ^) ⅋ (B ^)
^-posneg (A ⊕ B) = (A ^) & (B ^)
^-posneg (![ n ] A) = ?[ n ] (A ^)

^-negpos : {A : Type} (N : Neg A) → Pos (A ^)
^-negpos ⊥ = 𝟏
^-negpos ⊤ = 𝟎
^-negpos (A ⅋ B) = (A ^) ⊗ (B ^)
^-negpos (A & B) = (A ^) ⊕ (B ^)
^-negpos (?[ n ] A) = ![ n ] (A ^)

-- Environments.

Environment : Set
Environment = List Type

-- Injectivity.

private
  infix 10 _≈_

  _≈_ : Type → Type → Set
  A ≈ B = A ≡ B

⊗-inj : {A B C D : Type} → A ⊗ B ≈ C ⊗ D → A ≈ C × B ≈ D
⊗-inj P.refl = P.refl , P.refl

⅋-inj : {A B C D : Type} → A ⅋ B ≈ C ⅋ D → A ≈ C × B ≈ D
⅋-inj P.refl = P.refl , P.refl

⊕-inj : {A B C D : Type} → A ⊕ B ≈ C ⊕ D → A ≈ C × B ≈ D
⊕-inj P.refl = P.refl , P.refl

&-inj : {A B C D : Type} → A & B ≈ C & D → A ≈ C × B ≈ D
&-inj P.refl = P.refl , P.refl

!-inj : {A B : Type} {m n : ℕ⁺} → ![ m ] A ≈ ![ n ] B → m ≡ n × A ≈ B
!-inj P.refl = P.refl , P.refl

?-inj : {A B : Type} {m n : ℕ⁺} → ?[ m ] A ≈ ?[ n ] B → m ≡ n × A ≈ B
?-inj P.refl = P.refl , P.refl

-- This is one of those proofs for which I wish Agda had tactics.

^-inj : {A B : Type} → A ^ ≈ B ^ → A ≈ B
^-inj {A = 𝟏}        {B = 𝟏}         p = P.refl
^-inj {A = 𝟏}        {B = ⊥}         ()
^-inj {A = 𝟏}        {B = 𝟎}         ()
^-inj {A = 𝟏}        {B = ⊤}         ()
^-inj {A = 𝟏}        {B = C ⊗ D}     ()
^-inj {A = 𝟏}        {B = C ⅋ D}     ()
^-inj {A = 𝟏}        {B = C ⊕ D}     ()
^-inj {A = 𝟏}        {B = C & D}     ()
^-inj {A = 𝟏}        {B = ![ n ] C}  ()
^-inj {A = 𝟏}        {B = ?[ n ] C}  ()
^-inj {A = ⊥}        {B = 𝟏}         ()
^-inj {A = ⊥}        {B = ⊥}         p = P.refl
^-inj {A = ⊥}        {B = 𝟎}         ()
^-inj {A = ⊥}        {B = ⊤}         ()
^-inj {A = ⊥}        {B = C ⊗ D}     ()
^-inj {A = ⊥}        {B = C ⅋ D}     ()
^-inj {A = ⊥}        {B = C ⊕ D}     ()
^-inj {A = ⊥}        {B = C & D}     ()
^-inj {A = ⊥}        {B = ![ n ] C}  ()
^-inj {A = ⊥}        {B = ?[ n ] C}  ()
^-inj {A = 𝟎}        {B = 𝟏}         ()
^-inj {A = 𝟎}        {B = ⊥}         ()
^-inj {A = 𝟎}        {B = 𝟎}         p = P.refl
^-inj {A = 𝟎}        {B = ⊤}         ()
^-inj {A = 𝟎}        {B = C ⊗ D}     ()
^-inj {A = 𝟎}        {B = C ⅋ D}     ()
^-inj {A = 𝟎}        {B = C ⊕ D}     ()
^-inj {A = 𝟎}        {B = C & D}     ()
^-inj {A = 𝟎}        {B = ![ n ] C}  ()
^-inj {A = 𝟎}        {B = ?[ n ] C}  ()
^-inj {A = ⊤}        {B = 𝟏}         ()
^-inj {A = ⊤}        {B = ⊥}         ()
^-inj {A = ⊤}        {B = 𝟎}         ()
^-inj {A = ⊤}        {B = ⊤}         p = P.refl
^-inj {A = ⊤}        {B = C ⊗ D}     ()
^-inj {A = ⊤}        {B = C ⅋ D}     ()
^-inj {A = ⊤}        {B = C ⊕ D}     ()
^-inj {A = ⊤}        {B = C & D}     ()
^-inj {A = ⊤}        {B = ![ n ] C}  ()
^-inj {A = ⊤}        {B = ?[ n ] C}  ()
^-inj {A = A ⊗ B}    {B = 𝟏}         ()
^-inj {A = A ⊗ B}    {B = ⊥}         ()
^-inj {A = A ⊗ B}    {B = 𝟎}         ()
^-inj {A = A ⊗ B}    {B = ⊤}         ()
^-inj {A = A ⊗ B}    {B = C ⊗ D}     p = uncurry (P.cong₂ _⊗_) (map ^-inj ^-inj (⅋-inj p))
^-inj {A = A ⊗ B}    {B = C ⅋ D}     ()
^-inj {A = A ⊗ B}    {B = C ⊕ D}     ()
^-inj {A = A ⊗ B}    {B = C & D}     ()
^-inj {A = A ⊗ B}    {B = ![ n ] C}  ()
^-inj {A = A ⊗ B}    {B = ?[ n ] C}  ()
^-inj {A = A ⅋ B}    {B = 𝟏}         ()
^-inj {A = A ⅋ B}    {B = ⊥}         ()
^-inj {A = A ⅋ B}    {B = 𝟎}         ()
^-inj {A = A ⅋ B}    {B = ⊤}         ()
^-inj {A = A ⅋ B}    {B = C ⊗ D}     ()
^-inj {A = A ⅋ B}    {B = C ⅋ D}     p = uncurry (P.cong₂ _⅋_) (map ^-inj ^-inj (⊗-inj p))
^-inj {A = A ⅋ B}    {B = C ⊕ D}     ()
^-inj {A = A ⅋ B}    {B = C & D}     ()
^-inj {A = A ⅋ B}    {B = ![ n ] C}  ()
^-inj {A = A ⅋ B}    {B = ?[ n ] C}  ()
^-inj {A = A ⊕ B}    {B = 𝟏}         ()
^-inj {A = A ⊕ B}    {B = ⊥}         ()
^-inj {A = A ⊕ B}    {B = 𝟎}         ()
^-inj {A = A ⊕ B}    {B = ⊤}         ()
^-inj {A = A ⊕ B}    {B = C ⊗ D}     ()
^-inj {A = A ⊕ B}    {B = C ⅋ D}     ()
^-inj {A = A ⊕ B}    {B = C ⊕ D}     p = uncurry (P.cong₂ _⊕_) (map ^-inj ^-inj (&-inj p))
^-inj {A = A ⊕ B}    {B = C & D}     ()
^-inj {A = A ⊕ B}    {B = ![ n ] C}  ()
^-inj {A = A ⊕ B}    {B = ?[ n ] C}  ()
^-inj {A = A & B}    {B = 𝟏}         ()
^-inj {A = A & B}    {B = ⊥}         ()
^-inj {A = A & B}    {B = 𝟎}         ()
^-inj {A = A & B}    {B = ⊤}         ()
^-inj {A = A & B}    {B = C ⊗ D}     ()
^-inj {A = A & B}    {B = C ⅋ D}     ()
^-inj {A = A & B}    {B = C ⊕ D}     ()
^-inj {A = A & B}    {B = C & D}     p = uncurry (P.cong₂ _&_) (map ^-inj ^-inj (⊕-inj p))
^-inj {A = A & B}    {B = ![ n ] C}  ()
^-inj {A = A & B}    {B = ?[ n ] C}  ()
^-inj {A = ![ m ] A} {B = 𝟏}         ()
^-inj {A = ![ m ] A} {B = ⊥}         ()
^-inj {A = ![ m ] A} {B = 𝟎}         ()
^-inj {A = ![ m ] A} {B = ⊤}         ()
^-inj {A = ![ m ] A} {B = C ⊗ D}     ()
^-inj {A = ![ m ] A} {B = C ⅋ D}     ()
^-inj {A = ![ m ] A} {B = C ⊕ D}     ()
^-inj {A = ![ m ] A} {B = C & D}     ()
^-inj {A = ![ m ] A} {B = ![ n ] C}  p = uncurry (P.cong₂ ![_]_) (map id ^-inj (?-inj p))
^-inj {A = ![ m ] A} {B = ?[ n ] C}  ()
^-inj {A = ?[ m ] A} {B = 𝟏}         ()
^-inj {A = ?[ m ] A} {B = ⊥}         ()
^-inj {A = ?[ m ] A} {B = 𝟎}         ()
^-inj {A = ?[ m ] A} {B = ⊤}         ()
^-inj {A = ?[ m ] A} {B = C ⊗ D}     ()
^-inj {A = ?[ m ] A} {B = C ⅋ D}     ()
^-inj {A = ?[ m ] A} {B = C ⊕ D}     ()
^-inj {A = ?[ m ] A} {B = C & D}     ()
^-inj {A = ?[ m ] A} {B = ![ n ] C}  ()
^-inj {A = ?[ m ] A} {B = ?[ n ] C}  p = uncurry (P.cong₂ ?[_]_) (map id ^-inj (!-inj p))


{-# OPTIONS --safe #-}

module Definition.Typed.Consequences.NeTypeEq where

open import Definition.Untyped
open import Definition.Typed
open import Definition.Typed.Properties
open import Definition.Typed.Weakening
open import Definition.Typed.Consequences.Syntactic
open import Definition.Typed.Consequences.Injectivity
open import Definition.Typed.Consequences.Substitution

open import Tools.Product
import Tools.PropositionalEquality as PE

-- to be moved in Untyped

typelevel-injectivity : ∀ {r r' l l'} → [ r , l ] PE.≡ [ r' , l' ] → r PE.≡ r' × l PE.≡ l'
typelevel-injectivity PE.refl = PE.refl , PE.refl

-- Helper function for the same variable instance of a context have equal types.
varTypeEq′ : ∀ {n R rR T rT Γ} → n ∷ R ^ rR ∈ Γ → n ∷ T ^ rT ∈ Γ → R PE.≡ T × rR PE.≡ rT
varTypeEq′ here here = PE.refl , PE.refl
varTypeEq′ (there n∷R) (there n∷T) with varTypeEq′ n∷R n∷T
... | PE.refl , PE.refl = PE.refl , PE.refl

-- The same variable instance of a context have equal types.
varTypeEq : ∀ {x A B rA rB Γ} → Γ ⊢ A ^ rA → Γ ⊢ B ^ rB
          → x ∷ A ^ rA ∈ Γ
          → x ∷ B ^ rB ∈ Γ
          → Γ ⊢ A ≡ B ^ rA × rA PE.≡ rB
varTypeEq A B x∷A x∷B with varTypeEq′ x∷A x∷B
... | PE.refl , PE.refl = refl A , PE.refl

-- The same neutral term have equal types.
-- to use this with different relevances rA rB we need unicity of relevance for types
neTypeEq : ∀ {t A B rA lA lA' Γ} → Neutral t → Γ ⊢ t ∷ A ^ [ rA , lA ] → Γ ⊢ t ∷ B ^ [ rA , lA' ] →
  lA PE.≡ lA' × Γ ⊢ A ≡ B ^ [ rA , lA ]
neTypeEq (var x) (var x₁ x₂) (var x₃ x₄) =
  let V , e = varTypeEq (syntacticTerm (var x₃ x₂)) (syntacticTerm (var x₃ x₄)) x₂ x₄
      _ , el = typelevel-injectivity e
  in el , V
neTypeEq (∘ₙ neT) (t∷A ∘ⱼ t∷A₁) (t∷B ∘ⱼ t∷B₁) with neTypeEq neT t∷A t∷B
... | e , q = let _ , _ , _ , elG , w = injectivity q
              in PE.cong _ elG , substTypeEq w (genRefl t∷A₁)
neTypeEq (natrecₙ neT) (natrecⱼ x t∷A t∷A₁ t∷A₂) (natrecⱼ x₁ t∷B t∷B₁ t∷B₂) =
  PE.refl , refl (substType x₁ t∷B₂)
neTypeEq Emptyrecₙ (Emptyrecⱼ x t∷A) (Emptyrecⱼ x₁ t∷B) =
  PE.refl , refl x₁
neTypeEq (Idₙ X) (Idⱼ Y Y₁ Y₂) (Idⱼ Z Z₁ Z₂) =
  let e , q = neTypeEq X Y Z
      el = next-inj e
  in e , PE.subst (λ l → _ ⊢ _ ≡ SProp l ^ _) el (refl (Ugenⱼ (wfTerm Y) ) )
neTypeEq (Idℕₙ X) (Idⱼ Y Y₁ Y₂) (Idⱼ Z Z₁ Z₂) =
  let e , q = neTypeEq X Y₁ Z₁
      el = ιinj e
  in PE.cong next el , PE.subst (λ l → _ ⊢ _ ≡ SProp l ^ _) el (refl (Ugenⱼ (wfTerm Y) ) )
neTypeEq (Idℕ0ₙ X) (Idⱼ Y Y₁ Y₂) (Idⱼ Z Z₁ Z₂) =
  let e , q = neTypeEq X Y₂ Z₂
      el = ιinj e
  in PE.cong next el , PE.subst (λ l → _ ⊢ _ ≡ SProp l ^ _) el (refl (Ugenⱼ (wfTerm Y) ) )
neTypeEq (IdℕSₙ X) (Idⱼ Y Y₁ Y₂) (Idⱼ Z Z₁ Z₂) =
  let e , q = neTypeEq X Y₂ Z₂
      el = ιinj e
  in PE.cong next el , PE.subst (λ l → _ ⊢ _ ≡ SProp l ^ _) el (refl (Ugenⱼ (wfTerm Y) ) )
neTypeEq (IdUₙ X) (Idⱼ Y Y₁ Y₂) (Idⱼ Z Z₁ Z₂) =
  let e , q = neTypeEq X Y₁ Z₁
      el = ιinj e
  in PE.cong next el , PE.subst (λ l → _ ⊢ _ ≡ SProp l ^ _) el (refl (Ugenⱼ (wfTerm Y) ) )
neTypeEq (IdUℕₙ X) (Idⱼ Y Y₁ Y₂) (Idⱼ Z Z₁ Z₂) =
  let e , q = neTypeEq X Y₂ Z₂
      el = ιinj e
  in PE.cong next el , PE.subst (λ l → _ ⊢ _ ≡ SProp l ^ _) el (refl (Ugenⱼ (wfTerm Y) ) )
neTypeEq (IdUΠₙ X) (Idⱼ Y Y₁ Y₂) (Idⱼ Z Z₁ Z₂) =
  let e , q = neTypeEq X Y₂ Z₂
      el = ιinj e
  in PE.cong next el , PE.subst (λ l → _ ⊢ _ ≡ SProp l ^ _) el (refl (Ugenⱼ (wfTerm Y) ) )
neTypeEq X (castⱼ Y Y₁ Y₂ Y₃)  (castⱼ Z Z₁ Z₂ Z₃) = PE.refl , refl (univ Y₁)
neTypeEq x (conv t∷A x₁) t∷B =
  let e , q = neTypeEq x t∷A t∷B
  in e , trans (sym x₁) q
neTypeEq x t∷A (conv t∷B x₃) =
  let e , q = neTypeEq x t∷A t∷B
  in e , trans q (PE.subst (λ l → _ ⊢ _ ≡ _ ^ [ _ , l ]) (PE.sym e) x₃)

natTypeEq : ∀ {A rA lA Γ} → Γ ⊢ ℕ ∷ A ^ [ rA , lA ] → rA PE.≡ ! × lA PE.≡ ι ¹ × Γ ⊢ A ≡ U ⁰ ^ [ ! , ι ¹ ]
natTypeEq (ℕⱼ x) = PE.refl , PE.refl , refl (univ (univ 0<1 x))
natTypeEq (conv X x) = let eqrA , eqlA , eqAU = natTypeEq X in eqrA , eqlA ,
  trans (sym (PE.subst (λ l → _ ⊢ _ ≡ _ ^ [ _ , l ] ) eqlA (PE.subst (λ r → _ ⊢ _ ≡ _ ^ [ r , _ ]) eqrA x))) eqAU

emptyTypeEq : ∀ {A rA lA Γ l} → Γ ⊢ Empty l ∷ A ^ [ rA , lA ] →
  rA PE.≡ ! × lA PE.≡ next l × Γ ⊢ A ≡ SProp l ^ [ ! , next l ]
emptyTypeEq (Emptyⱼ x) = PE.refl , PE.refl , refl (Ugenⱼ x)
emptyTypeEq (conv X x) = let eqrA , eqlA , eqAU = emptyTypeEq X in eqrA , eqlA ,
 trans (sym (PE.subst (λ l → _ ⊢ _ ≡ _ ^ [ _ , l ] ) eqlA (PE.subst (λ r → _ ⊢ _ ≡ _ ^ [ r , _ ]) eqrA x))) eqAU


-- Andreas, 2017-10-04, issue #2752, report and test case by nad
--
-- Problem was: instance does not distribute into mutual blocks.

open import Agda.Builtin.List
open import Agda.Builtin.Size

mutual

  data Rose (i : Size) (A : Set) : Set where
    node : List (Rose′ i A) → Rose i A

  data Rose′ (i : Size) (A : Set) : Set where
    delay : {j : Size< i} → Rose j A → Rose′ i A

record Map (F : Set → Set) : Set₁ where
  field
    map : {A B : Set} → (A → B) → F A → F B

open Map ⦃ … ⦄ public

instance

  Map-List : Map List
  Map.map Map-List = λ where
    f []       → []
    f (x ∷ xs) → f x ∷ map f xs

instance

  mutual

    Map-Rose : ∀ {i} → Map (Rose i)
    Map.map Map-Rose f (node xs) = node (map (map f) xs)

    Map-Rose′ : ∀ {i} → Map (Rose′ i)
    Map.map Map-Rose′ f (delay t) = delay (map f t)

-- Was: unresolved instance arguments.

-- Should succeed.


------------------------------------------------------------------------
-- Recognisers built on top of the parsers
------------------------------------------------------------------------

-- Note that these recognisers are different from the ones in
-- TotalRecognisers.LeftRecursion: these allow the use of fewer sharps.
-- (Compare the examples in TotalRecognisers.LeftRecursion.Expression
-- and TotalParserCombinators.Recogniser.Expression.)

module TotalParserCombinators.Recogniser where

open import Category.Monad
open import Codata.Musical.Notation
open import Data.Bool
open import Data.List as List
import Data.List.Categorical
open import Data.Maybe
open import Data.Unit
open import Level

open RawMonadPlus {f = zero} Data.List.Categorical.monadPlus
  using () renaming (_⊛_ to _⊛′_)

open import TotalParserCombinators.Parser as Parser
  using (Parser; flatten); open Parser.Parser
import TotalParserCombinators.Lib as Lib

------------------------------------------------------------------------
-- Helper function

infixl 4 _·′_

_·′_ : (mb₁ mb₂ : Maybe (List ⊤)) → List ⊤
mb₁ ·′ nothing = []
mb₁ ·′ just b₂ = List.map _ (flatten mb₁) ⊛′ b₂

------------------------------------------------------------------------
-- Recognisers

infixl 50 _·_
infixl  5 _∣_

-- Recognisers.

mutual

  -- The index is non-empty if the corresponding language contains the
  -- empty string (is nullable).

  data P (Tok : Set) : List ⊤ → Set₁ where
    -- Parsers can be turned into recognisers.
    lift  : ∀ {R n} (p : Parser Tok R n) → P Tok (List.map _ n)

    -- Symmetric choice.
    _∣_   : ∀ {n₁ n₂}
            (p₁ : P Tok n₁) (p₂ : P Tok n₂) → P Tok (n₁ ++ n₂)

    -- Sequencing.
    _·_   : ∀ {n₁ n₂}
            (p₁ : ∞⟨ n₂ ⟩P Tok (flatten n₁))
            (p₂ : ∞⟨ n₁ ⟩P Tok (flatten n₂)) →
            P Tok (n₁ ·′ n₂)

  -- Delayed if the index is /nothing/.

  ∞⟨_⟩P : Maybe (List ⊤) → Set → List ⊤ → Set₁
  ∞⟨ nothing ⟩P Tok n = ∞ (P Tok n)
  ∞⟨ just _  ⟩P Tok n =    P Tok n

------------------------------------------------------------------------
-- Helper function related to ∞⟨_⟩P

-- Is the argument parser forced? If the result is just something,
-- then it is.

forced? : ∀ {Tok m n} → ∞⟨ m ⟩P Tok n → Maybe (List ⊤)
forced? {m = m} _ = m

------------------------------------------------------------------------
-- The semantics of the recognisers is defined by translation

⟦_⟧ : ∀ {Tok n} (p : P Tok n) → Parser Tok ⊤ n
⟦ lift p ⟧  = _ <$> p
⟦ p₁ ∣ p₂ ⟧ = ⟦ p₁ ⟧ ∣ ⟦ p₂ ⟧
⟦ p₁ · p₂ ⟧ with forced? p₁ | forced? p₂
... | just xs | nothing =    _ <$> ⟦   p₁ ⟧  ⊛ ♯ ⟦ ♭ p₂ ⟧
... | just xs | just ys =    _ <$> ⟦   p₁ ⟧  ⊛   ⟦   p₂ ⟧
... | nothing | nothing = ♯ (_ <$> ⟦ ♭ p₁ ⟧) ⊛ ♯ ⟦ ♭ p₂ ⟧
... | nothing | just ys = ♯ (_ <$> ⟦ ♭ p₁ ⟧) ⊛   ⟦   p₂ ⟧


module empty where

open import level

----------------------------------------------------------------------
-- datatypes
----------------------------------------------------------------------

data ⊥ {ℓ : Level} : Set ℓ where

----------------------------------------------------------------------
-- syntax
----------------------------------------------------------------------

----------------------------------------------------------------------
-- theorems
----------------------------------------------------------------------
⊥-elim : ∀{ℓ} → ⊥ {ℓ} → ∀{ℓ'}{P : Set ℓ'} → P
⊥-elim ()


------------------------------------------------------------------------
-- The Agda standard library
--
-- An irrelevant version of ⊥-elim
------------------------------------------------------------------------

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

module Data.Empty.Irrelevant where

open import Data.Empty hiding (⊥-elim)

⊥-elim : ∀ {w} {Whatever : Set w} → .⊥ → Whatever
⊥-elim ()


-- Andreas, 2016-07-17 issue 2101

-- It should be possible to place a single function with a where block
-- inside `abstract`.

-- This will work if type signatures inside a where-block
-- are considered private, since in private type signatures,
-- abstract definitions are transparent.
-- (Unlike in public type signatures.)

record Wrap (A : Set) : Set where
  field unwrap : A

postulate
  P : ∀{A : Set} → A → Set

module AbstractPrivate (A : Set) where
  abstract
    B : Set
    B = Wrap A

    postulate
      b : B

    private -- this no longer (since #418) make abstract defs transparent in type signatures
      postulate
        test : P (Wrap.unwrap b) -- should no longer succeed


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

open import Numbers.Naturals.Semiring
open import Numbers.Naturals.Order
open import Sets.FinSet.Definition
open import LogicalFormulae
open import Numbers.Naturals.WithK
open import Sets.FinSet.Lemmas

module Sets.FinSetWithK where

private
  sgEq : {l m : _} {L : Set l} → {pr : L → Set m} → {a b : Sg L pr} → (underlying a ≡ underlying b) → ({c : L} → (r s : pr c) → r ≡ s) → (a ≡ b)
  sgEq {l} {m} {L} {prop} {(a , b1)} {(.a , b)} refl pr2 with pr2 {a} b b1
  sgEq {l} {m} {L} {prop} {(a , b1)} {(.a , .b1)} refl pr2 | refl = refl

finNotEqualsRefl : {n : ℕ} {a b : FinSet (succ n)} → (p1 p2 : FinNotEquals a b) → p1 ≡ p2
finNotEqualsRefl {.1} {.fzero} {.(fsucc fzero)} (fne2 .fzero .(fsucc fzero) (inl (refl ,, refl))) (fne2 .fzero .(fsucc fzero) (inl (refl ,, refl))) = refl
finNotEqualsRefl {.1} {.fzero} {.(fsucc fzero)} (fne2 .fzero .(fsucc fzero) (inl (refl ,, refl))) (fne2 .fzero .(fsucc fzero) (inr (() ,, snd)))
finNotEqualsRefl {.1} {.(fsucc fzero)} {.fzero} (fne2 .(fsucc fzero) .fzero (inr (refl ,, refl))) (fne2 .(fsucc fzero) .fzero (inl (() ,, snd)))
finNotEqualsRefl {.1} {.(fsucc fzero)} {.fzero} (fne2 .(fsucc fzero) .fzero (inr (refl ,, refl))) (fne2 .(fsucc fzero) .fzero (inr (refl ,, refl))) = refl
finNotEqualsRefl {.(succ (succ _))} {.fzero} {.(fsucc a)} (fneN .fzero .(fsucc a) (inl (inl (refl ,, (a , refl))))) (fneN .fzero .(fsucc a) (inl (inl (refl ,, (.a , refl))))) = refl
finNotEqualsRefl {.(succ (succ _))} {.fzero} {.(fsucc a)} (fneN .fzero .(fsucc a) (inl (inl (refl ,, (a , refl))))) (fneN .fzero .(fsucc a) (inl (inr ((a₁ , ()) ,, snd))))
finNotEqualsRefl {.(succ (succ _))} {.fzero} {.(fsucc a)} (fneN .fzero .(fsucc a) (inl (inl (refl ,, (a , refl))))) (fneN .fzero .(fsucc a) (inr ((fst ,, snd) , b))) = exFalso q
  where
    p : fzero ≡ fsucc fst
    p = _&_&_.one b
    q : False
    q with p
    ... | ()
finNotEqualsRefl {.(succ (succ _))} {.(fsucc a)} {.fzero} (fneN .(fsucc a) .fzero (inl (inr ((a , refl) ,, refl)))) (fneN .(fsucc a) .fzero (inl (inl (() ,, snd))))
finNotEqualsRefl {.(succ (succ _))} {.(fsucc a)} {.fzero} (fneN .(fsucc a) .fzero (inl (inr ((a , refl) ,, refl)))) (fneN .(fsucc a) .fzero (inl (inr ((.a , refl) ,, refl)))) = refl
finNotEqualsRefl {.(succ (succ _))} {.(fsucc a)} {.fzero} (fneN .(fsucc a) .fzero (inl (inr ((a , refl) ,, refl)))) (fneN .(fsucc a) .fzero (inr ((fst ,, snd) , b))) = exFalso q
  where
    p : fzero ≡ fsucc snd
    p = _&_&_.two b
    q : False
    q with p
    ... | ()
finNotEqualsRefl {.(succ (succ _))} {a} {b} (fneN a b (inr (record { fst = fst ; snd = snd₁ } , snd))) (fneN .a .b (inl (inl (fst1 ,, snd₂)))) = exFalso q
  where
    p : fzero ≡ fsucc fst
    p = transitivity (equalityCommutative fst1) (_&_&_.one snd)
    q : False
    q with p
    ... | ()
finNotEqualsRefl {.(succ (succ _))} {a} {b} (fneN a b (inr (record { fst = fst ; snd = snd1 } , snd))) (fneN .a .b (inl (inr (fst₁ ,, snd2)))) = exFalso q
  where
    p : fzero ≡ fsucc snd1
    p = transitivity (equalityCommutative snd2) (_&_&_.two snd)
    q : False
    q with p
    ... | ()
finNotEqualsRefl {.(succ (succ _))} {.fzero} {b} (fneN fzero b (inr (record { fst = fst ; snd = snd₁ } , snd))) (fneN .fzero .b (inr ((fst1 ,, snd₂) , b1))) = exFalso q
  where
    p : fzero ≡ fsucc fst1
    p = _&_&_.one b1
    q : False
    q with p
    ... | ()
finNotEqualsRefl {.(succ (succ _))} {.(fsucc a)} {.fzero} (fneN (fsucc a) fzero (inr (record { fst = fst ; snd = snd₁ } , snd))) (fneN .(fsucc a) .fzero (inr ((fst₁ ,, snd2) , b1))) = exFalso q
  where
    p : fzero ≡ fsucc snd2
    p = _&_&_.two b1
    q : False
    q with p
    ... | ()
finNotEqualsRefl {.(succ (succ _))} {.(fsucc a)} {.(fsucc b)} (fneN (fsucc a) (fsucc b) (inr (record { fst = fst ; snd = snd1 } , snd))) (fneN .(fsucc a) .(fsucc b) (inr ((fst1 ,, snd2) , b1))) = ans
  where
    t : a ≡ fst1
    t = fsuccInjective (_&_&_.one b1)
    t' : a ≡ fst
    t' = fsuccInjective (_&_&_.one snd)
    u : b ≡ snd1
    u = fsuccInjective (_&_&_.two snd)
    u' : b ≡ snd2
    u' = fsuccInjective (_&_&_.two b1)
    equality : {c : FinSet (succ (succ _)) && FinSet (succ (succ _))} → (r1 s : (fsucc a ≡ fsucc (_&&_.fst c)) & (fsucc b ≡ fsucc (_&&_.snd c)) & FinNotEquals (_&&_.fst c) (_&&_.snd c)) → r1 ≡ s
    equality record { one = refl ; two = refl ; three = q } record { one = refl ; two = refl ; three = q' } = applyEquality (λ t → record { one = refl ; two = refl ; three = t }) (finNotEqualsRefl q q')
    r : (fst ,, snd1) ≡ (fst1 ,, snd2)
    r rewrite equalityCommutative t | equalityCommutative t' | equalityCommutative u | equalityCommutative u' = refl
    ans : fneN (fsucc a) (fsucc b) (inr ((fst ,, snd1) , snd)) ≡ fneN (fsucc a) (fsucc b) (inr ((fst1 ,, snd2) , b1))
    ans = applyEquality (λ t → fneN (fsucc a) (fsucc b) (inr t)) (sgEq r equality)


{-# OPTIONS --copatterns #-}

record U : Set where
  coinductive
  field out : U

u : {A : Set} → U
u = {!!}

record Wrap (A : Set) : Set where
  field
    wrapped : A

wrap : ∀{A}{a : A} → Wrap A
wrap = {!!}


-- Andreas, 2013-03-15 issue reported by Nisse

-- {-# OPTIONS -v tc.proj:40 -v tc.conv.elim:40 #-}
-- {-# OPTIONS -v tc.inj.check:45 #-}
-- {-# OPTIONS -v tc.proj.like:45 #-}

module Issue821 where

import Common.Level

data D (A : Set) : Set where
  c : D A → D A

-- f is projection like, but could also be injective!?
f : (A : Set) → D A → D A
f A (c x) = x

postulate
  A : Set
  P : D A → Set
  x : D A
  p : P x
  Q : P (f A x) → Set

Foo : Set₁
Foo = Q p

-- WAS:
-- An internal error has occurred. Please report this as a bug.
-- Location of the error: src/full/Agda/TypeChecking/Conversion.hs:466

-- Reason was that f is projection-like so the test x =?= f A x
-- actually becomes x =?= x .f with unequal spine shapes (empty vs. non-empty).
-- Agda thought this was impossible.

-- Expected error:
-- x != (f A x) of type (D A)
-- when checking that the expression p has type P (f A x)

-- Projection-likeness of f will turn this into:
-- x != (f _ x) of type (D A)


-- Axiomatic embedding of guarded recursion in Agda
module guarded-recursion.embedding where

open import guarded-recursion.prelude
  renaming (O to zero; S to suc)
open Coe

module M
    (▹_ : ∀ {a} → Type_ a → Type_ a)

    (▸ : ∀ {a} → ▹ (Type_ a) → Type_ a)

    (next : ∀ {a} {A : Type_ a} → A → ▹ A)

    (▸-rule : ∀ {a} {A : Type_ a} → ▸ (next A) ≡ ▹ A)

    (fix      : ∀ {a} {A : Type_ a} → (▹ A → A) → A)
    (fix-rule : ∀ {a} {A : Type_ a} {f : ▹ A → A} → fix f ≡ f (next (fix f)))

    (_⊛′_ : ∀ {a b} {A : Type_ a} {B : Type_ b} → ▹ (A → B) → ▹ A → ▹ B)
    (_⊛_ : ∀ {a b} {A : Type_ a} {B : A → Type_ b}
           → ▹ ((x : A) → B x) → (x : ▹ A) → ▸ (next B ⊛′ x))

    (fix-uniq : ∀ {a} {A : Type_ a} (u : A) f → u ≡ f (next u) → u ≡ fix f)

    (next⊛next : ∀ {a b} {A : Type_ a} {B : Type_ b} (f : A → B) (x : A)
                 → next f ⊛′ next x ≡ next (f x))

    where

    roll▸ : ∀ {a} {A : Type_ a} → ▹ A → ▸ (next A)
    roll▸ = coe! ▸-rule

    un▸ : ∀ {a} {A : Type_ a} → ▸ (next A) → ▹ A
    un▸ = coe ▸-rule

    ▹Fix : ∀ {a} → Type_ a → Type_ a
    ▹Fix X = (▹ X → X) → X

    ▹Endo : ∀ {a} → Type_ a → Type_ a
    ▹Endo X = ▹ X → X

    μ : ∀ {a} → Fix (Type_ a)
    μ F = fix (F ∘ ▸)

    un : ∀ {a f} → fix {A = Type_ a} f → f (next (fix f))
    un = coe fix-rule

    unμ : ∀ {a} f → μ {a} f → f (▹ μ f)
    unμ {a} f x rewrite ! (▸-rule {A = μ f}) = un x

    roll : ∀ {a f} → f (next (fix f)) → fix {A = Type_ a} f
    roll = coe! fix-rule

    μ-rule : ∀ {a} f → μ {a} f ≡ f (▹ μ f)
    μ-rule f = fix-rule ∙ ap f (▸-rule {A = μ f})

    rollμ : ∀ {a} f → f (▹ μ f) → μ {a} f
    rollμ f = coe! (μ-rule f)

    un₁ : ∀ {a b} {A : Type_ a} {f x} → fix {A = A → Type_ b} f x → f (next (fix f)) x
    un₁ = coe₁ fix-rule

    roll₁ : ∀ {a b} {A : Type_ a} {f x} → f (next (fix f)) x → fix {A = A → Type_ b} f x
    roll₁ = coe₁! fix-rule

    un₂ : ∀ {a b} {A : Type_ a} {B : Type_ b} {c f x y} → fix {A = A → B → Type_ c} f x y → f (next (fix f)) x y
    un₂ = coe₂ fix-rule

    roll₂ : ∀ {a b} {A : Type_ a} {B : Type_ b} {c f x y} → f (next (fix f)) x y → fix {A = A → B → Type_ c} f x y
    roll₂ = coe₂! fix-rule

    map▹ : ∀ {a b} {A : Type_ a} {B : Type_ b} → (A → B) → ▹ A → ▹ B
    map▹ f ▹x = next f ⊛′ ▹x

    {-
    alternatively
    _⊛′′_ : ∀ {a b} {A : Type_ a} {B : A → Type_ b} → ▹ ((x : A) → B x) → (x : A) → ▹ (B x)
    ▹f ⊛′′ x = map▹ (λ f → f x) ▹f
    -}

    {-
    alternatively
    _$_ : ∀ {a b} {A : Type_ a} (B : A → Type_ b) → ▹ A → ▹ (Type_ b)
    f $ ▹x = map▹ f ▹x
    -}

    ▹^ : ∀ {a} → ℕ → Type_ a → Type_ a
    ▹^ zero    A = A
    ▹^ (suc n) A = ▹ ▹^ n A

    next^ : ∀ {a} {A : Type_ a} n → A → ▹^ n A
    next^ zero    x = x
    next^ (suc n) x = next (next^ n x)

    map▹^ : ∀ {a b} {A : Type_ a} {B : Type_ b} n → (A → B) → ▹^ n A → ▹^ n B
    map▹^ zero    f = f
    map▹^ (suc n) f = map▹ (map▹^ n f)

    module SimpleStream where
      F : Type → Type → Type
      F A X = A × X

      S : Type → Type
      S A = μ (F A)

    μ₁F' : ∀ {a} {A : Type_ a} → ((A → ▹ Type) → A → Type) → (▹(A → Type) → A → Type)
    μ₁F' F self = F (λ x → (self ⊛′ next x))

    μ₁F : ∀ {a} {A : Type_ a} → ((A → Type) → A → Type) → (▹(A → Type) → A → Type)
    μ₁F F self = F (λ x → ▸ (self ⊛′ next x))

    μ₁ : ∀ {a} {A : Type_ a} → ((A → Type) → A → Type) → A → Type
    μ₁ F = fix (μ₁F F)

    module μId where
        μid : Type
        μid = μ id

        μid-rule : μid ≡ ▹ μid
        μid-rule = fix-rule ∙ ▸-rule {A = μ id}

        ω : μid
        ω = fix (rollμ id)

    module CoNat where
        Coℕ : Type
        Coℕ = μ Maybe

        rollNat : Maybe (▹ Coℕ) → Coℕ
        rollNat = rollμ Maybe

        ze : Coℕ
        ze = rollNat nothing

        su : ▹ Coℕ → Coℕ
        su x = rollNat (just x)

        su′ : Coℕ → Coℕ
        su′ = su ∘ next

        ω : Coℕ
        ω = fix su

    module Neg where
        {- data X : Type where
             rollX : Fix X
                   : (X → X) → X
           -}
        X : Type
        X = μ Endo

        rollX : Endo (▹ X) → X
           -- : (▹ X → ▹ X) → X
        rollX = rollμ Endo

        rollX′ : ▹(Endo X) → X
            -- : ▹(X → X) → X
        rollX′ = rollX ∘ _⊛′_

        unX : X → Endo (▹ X)
        unX = unμ Endo

        -- δ = λ x → x x
        δ : X → ▹ X
        δ = λ x → (unX x) (next x)

    module Neg' where
        {- data X : Type where
             c : Fix X
               : ((X → X) → X) → X
           -}
        X : Type
        X = μ Fix

        rollX : Fix (▹ X) → X
        rollX = rollμ Fix

        unX : X → Fix (▹ X)
        unX = unμ Fix

    module μ₁Id where
        -- μ₁id = ▹∘▹∘…∘▹
        -- μ₁id A = ▹ (▹ … (▹ A))
        μ₁id : Type → Type
        μ₁id = μ₁ id

        betterfix₁ : ∀ {a} {A : Type_ a} {x : A} (F : Endo (A → Type)) → (▹ μ₁ F x → μ₁F F (next (μ₁ F)) x) → μ₁ F x
        betterfix₁ {a} {A} {x} F f = fix helper
          where helper : _ → _
                helper self = roll₁ (f self)

        ▹ω-inh' : ∀ {A : Type} {x : A} (F : Endo (A → Type)) → (▸ (next (μ₁ F) ⊛′ next x) → μ₁F F (next (μ₁ F)) x) → μ₁ F x
        ▹ω-inh' {A} {x} F f = fix helper
          where helper : _ → _
                helper self = roll₁ (f (coe! (ap ▸ (next⊛next (μ₁ F) x)) (roll▸ self)))

        ▹ω-inh : ∀ {A} → μ₁id A
        -- ▹ω-inh {A} = fix λ self → roll₁ (coe! (ap ▸ (next⊛next μ₁id A)) (roll▸ self))
        ▹ω-inh {A} = betterfix₁ id (λ self → coe! (ap ▸ (next⊛next μ₁id A)) (roll▸ self))

        -- ▹ω-inh {A} = fix λ self → {!!} -- (coe! (ap ▸ (next⊛next μ₁idω A)) (roll▸ self))

    fix2 : ∀ {a} {A : Type_ a} → (▹ A → A) → A
    fix2 f = fix (f ∘ next ∘ f)

    fix≡fix2 : ∀ {a} {A : Type_ a} (f : ▹ A → A) → fix f ≡ fix2 f
    fix≡fix2 f = fix-uniq (fix f) (f ∘ next ∘ f) (fix-rule ∙ ap (f ∘ next) fix-rule)

    module Streams where
        F : Type → Type → Type
        F A X = A × X

        -- S : Type → Type
        -- S A = μ (F A)

        F^ : ℕ → Type → Type → Type
        F^ n A X = A × ▹^ n X

        S^ : ℕ → Type → Type
        S^ n A = μ (F^ n A)

        S : Type → Type
        S = S^ 0

        S₂ = S^ 1

        unS : ∀ {A} → S A → F A (▹ S A)
        unS = unμ (F _)

        rollS : ∀ {A} → F A (▹ S A) → S A
        rollS = rollμ (F _)

        unS^ : ∀ {A} n → S^ n A → F^ n A (▹ S^ n A)
        unS^ n = unμ (F^ n _)

        rollS^ : ∀ {A} n → F^ n A (▹ S^ n A) → S^ n A
        rollS^ n = rollμ (F^ n _)

        hd : ∀ {A} → S A → A
        hd = fst ∘ unS

        tl : ∀ {A} → S A → ▹ S A
        tl = snd ∘ unS

        cons : ∀ {A} n → A → ▹^ n (▹ (S^ n A)) → S^ n A
        cons n x xs = rollS^ n (x , xs)

        infixr 4 _∷_
        _∷_ : ∀ {A} → A → ▹ (S A) → S A
        _∷_ = cons 0

        infixr 4 _∷₂_
        _∷₂_ : ∀ {A} → A → ▹^ 2 (S₂ A) → S₂ A
        x ∷₂ xs = roll (x , map▹ roll▸ xs)

        repeatS : ∀ {A} → A → S A
        repeatS x = fix λ x… → x ∷ x…

        module MapS {A B : Type} (f : A → B) where
            mapSf : ▹(S A → S B) → S A → S B
            mapSf self s = f (hd s) ∷ self ⊛′ tl s

            mapS : S A → S B
            mapS = fix mapSf

            mapS2f : ▹(S A → S B) → S A → S B
            mapS2f self s = f (hd s) ∷ map▹ (λ s' → f (hd s') ∷ self ⊛′ tl s') (tl s)

            mapS2f' : ▹(S A → S B) → S A → S B
            mapS2f' self = mapSf (next (mapSf self))

            mapS2f≡mapS2f' : mapS2f ≡ mapS2f'
            mapS2f≡mapS2f' = idp

            mapS2 : S A → S B
            mapS2 = fix mapS2f

            mapS2' : S A → S B
            mapS2' = fix mapS2f'

            mapS2≡mapS2' : mapS2 ≡ mapS2'
            mapS2≡mapS2' = idp

            mapS2'' : S A → S B
            mapS2'' = fix2 mapSf

            mapS2≡mapS2'' : mapS2 ≡ mapS2''
            mapS2≡mapS2'' = idp

            mapS≡mapS2 : mapS ≡ mapS2
            mapS≡mapS2 = fix≡fix2 mapSf

        open MapS

        group2 : S ℕ → ▹ S₂ ℕ²
        group2 = fix λ self s → map▹ (λ tls → (hd s , hd tls) ∷₂ self ⊛′ tl tls) (tl s)

        ‼ : ∀ {A} → (n : ℕ) → S A → ▹^ n A
        ‼ zero    = hd
        ‼ (suc n) = map▹ (‼ n) ∘ tl

        toFun : ∀ {A} → S A → (n : ℕ) → ▹^ n A
        toFun s n = ‼ n s

        fromFun : ∀ {A} → (ℕ → A) → S A
        fromFun {A} = fix λ self (f : ℕ → A) → f 0 ∷ self ⊛′ next (f ∘ suc)

        nats : S ℕ
        nats = fix λ self → 0 ∷ map▹ (mapS suc) self

        nats2 : S ℕ
        nats2 = fix λ self → 0 ∷ map▹ (mapS2 suc) self

        nats≡nats2 : nats ≡ nats2
        nats≡nats2 rewrite mapS≡mapS2 suc = idp

        arrow : ▹ ℕ
        arrow = ‼ 1 nats

        module Sim
            {A : Type}
            (ℛ : A → A → Type)
            (ℛ-refl : Reflexive ℛ)
          where
            ≈F : ▹(S A × S A → Type) → S A × S A → Type
            ≈F X (xs , ys) = ℛ (hd xs) (hd ys) × ▸ ((map▹ curry X ⊛′ (tl xs)) ⊛′ tl ys)

            _≈_ : S A × S A → Type
            _≈_ = fix ≈F

            ≈-tail : ∀ {xs ys : S A} → _≈_ (xs , ys) → ▸ ((map▹ curry (next _≈_) ⊛′ tl xs) ⊛′ tl ys)
            ≈-tail pf = snd (un₁ pf)

            {- Does not work yet
            ≈-refl : Reflexive (curry _≈_)
            ≈-refl {x} = (fix λ pf x → roll₁ {f = ≈F} (ℛ-refl , helper pf x)) x
              where helper' : _ → _ → _
                    helper' pf x = map▹ (λ f → f x) pf
                    helper : _ → _ → _
                    helper pf x = let r = helper' pf x in {!roll▸ r!}
            -}

    module DelayedStreams where
        data F (A : Type) (X : Type) : Type where
          done  : F A X
          skip  : X → F A X
          yield : A → X → F A X

        mapF : ∀ {A B X Y} → (A → B) → (X → Y) → F A X → F B Y
        mapF f g done = done
        mapF f g (skip x) = skip (g x)
        mapF f g (yield a x) = yield (f a) (g x)

        S : Type → Type
        S A = μ (F A)

        unS : ∀ {A} → S A → F A (▹ S A)
        unS = mapF id un▸ ∘ un

        rollS : ∀ {A} → F A (▹ S A) → S A
        rollS = roll ∘ mapF id roll▸

        unfoldS : ∀ {A X} → (X → F A (▹ X)) → X → S A
        unfoldS coalg = fix λ self x → rollS (mapF id (λ x′ → self ⊛′ x′) (coalg x))

        repeatS : ∀ {A} → A → S A
        repeatS x = fix λ self → rollS (yield x self)

        neverS : ∀ {A} → S A
        neverS = fix λ self → rollS (skip self)

        -- Co-algebra style...
        mapS : ∀ {A B} → (A → B) → S A → S B
        mapS {A} {B} f = unfoldS (mapF f id ∘ unS)

        filterF : ∀ {A X} → (A → 𝟚) → F A X → F A X
        filterF f done         = done
        filterF f (skip xs)    = skip xs
        filterF f (yield x xs) = if f x then yield x xs
                                        else skip xs

        filterS : ∀ {A} → (A → 𝟚) → S A → S A
        filterS f = unfoldS (filterF f ∘ unS)

module FuelBased where
    fix : ∀ {a} {A : Type_ a} → ℕ → (A → A) → A
    fix zero    f = STUCK where postulate STUCK : _
    fix (suc n) f = f (fix n f)

    fix-rule : ∀ {a} {A : Type_ a} (n : ℕ) {f : A → A} → fix n f ≡ f (fix n f)
    fix-rule zero        = ThisIsUnsafeButPlease.trustMe
    fix-rule (suc n) {f} = ap f (fix-rule n)

    fix-uniq : ∀ {a} {A : Type_ a} (n : ℕ) (u : A) f → u ≡ f u → u ≡ fix n f
    fix-uniq zero    u f pf = ThisIsUnsafeButPlease.trustMe
    fix-uniq (suc n) u f pf = pf ∙ ap f (fix-uniq n u f pf)

    module I (n : ℕ) = M id id id idp (fix n) (fix-rule n) id id
                         (fix-uniq n) (λ _ _ → idp)

module HiddenFix {a} {A : Type_ a} (f : A → A) where
    -- This definition is not intended to termination-check.
    -- Use with care it's really easy to make the type-checker loop.
    {-# TERMINATING #-}
    fix : Hidden A
    fix = hide f (reveal fix)

    fix-rule : reveal fix ≡ f (reveal fix)
    fix-rule = idp {a} {A} {reveal fix}

    -- This definition is not intended to termination-check.
    -- Use with care it's really easy to make the type-checker loop.
    {-# TERMINATING #-}
    fix-uniq : (u : A) → u ≡ f u → u ≡ reveal fix
    fix-uniq u pf = pf ∙ ap f (fix-uniq u pf) ∙ ! fix-rule

module Test where
  open HiddenFix
  open M id id id idp (reveal ∘ fix) (λ {_} {_} {f} → fix-rule f) id id
                 (λ {_} {_} u f → fix-uniq f u) (λ _ _ → idp) public
  open Streams
  two : map▹ hd (tl nats) ≡ 1
  two = idp

-- -}
-- -}
-- -}


open import OutsideIn.Prelude
open import OutsideIn.X
module OutsideIn.Inference.ConstraintGen(x : X) where
  import OutsideIn.Constraints as C
  import OutsideIn.TypeSchema as TS
  import OutsideIn.Expressions as E
  import OutsideIn.Environments as V
  open X(x) renaming (funType to _⟶_; appType to _··_)
  open C(x)
  open TS(x)
  open E(x)
  open V(x)
  open import Data.Vec

  private module PlusN-m n        = Monad (PlusN-is-monad {n})
          module PlusN-f n        = Functor (Monad.is-functor (PlusN-is-monad {n}))
          module TypeSchema-f {n} = Functor (type-schema-is-functor {n})
          module Type-f           = Functor (type-is-functor)
          module QC-f             = Functor (qconstraint-is-functor)
          module Exp-f₁ {tv} {r}  = Functor (expression-is-functor₁ {tv} {r})
          module Exp-f₂ {ev} {r}  = Functor (expression-is-functor₂ {ev} {r})
          module Constraint-f {s} = Functor (constraint-is-functor {s})
          module Vec-f {n}        = Functor (vec-is-functor {n})
          open Monad (type-is-monad) using () renaming (unit to TVar)

  private

    upindex : {X : Set → Set}{tv : Set} → ⦃ is-functor : Functor X ⦄ → X tv → X (Ⓢ tv)
    upindex ⦃ is-functor ⦄ e = suc <$> e
      where open Functor (is-functor)

    _↑c : {tv : Set}{s : Strata} → (Constraint tv s) → (Constraint (Ⓢ tv) s)
    _↑c {s = s} = upindex ⦃ constraint-is-functor {s} ⦄

    _↑e : {ev tv : Set}{r : Shape} → (Expression ev tv r) → (Expression ev (Ⓢ tv) r)
    _↑e = upindex ⦃ expression-is-functor₂ ⦄

    _↑a : {ev tv : Set}{r : Shape} → (Alternatives ev tv r) → (Alternatives ev (Ⓢ tv) r)
    _↑a = upindex ⦃ alternatives-is-functor₂ ⦄

    _↑t : {tv : Set} → (Type tv) → (Type (Ⓢ tv))
    _↑t = upindex ⦃ type-is-functor ⦄

    _↑q : {tv : Set} → (QConstraint tv) → (QConstraint (Ⓢ tv))
    _↑q = upindex ⦃ qconstraint-is-functor ⦄

    infixr 7 _↑e
    infixr 7 _↑c
    infixr 7 _↑t
    infixr 7 _↑a

    applyAll : ∀{tv}(n : ℕ) → Type tv → Type (tv ⨁ n)
    applyAll zero x = x
    applyAll (suc n) x = applyAll n ((x ↑t) ·· (TVar zero))

    funType : ∀{tv}{n} → Vec (Type tv) n → Type tv → Type tv
    funType [] t = t
    funType (x ∷ xs) t = x ⟶ (funType xs t)

    upType : ∀ {n}{tv} → Type tv → Type (tv ⨁ n)
    upType {n} t = Type-f.map (Monad.unit (PlusN-is-monad {n})) t
    upGamma : ∀ {n}{ev}{tv} → Environment ev tv → Environment ev (tv ⨁ n)
    upGamma {n} Γ = TypeSchema-f.map (Monad.unit (PlusN-is-monad {n})) ∘ Γ
    upExp : ∀ {n}{ev}{tv}{r} → Expression ev tv r → Expression ev (tv ⨁ n) r
    upExp {n} e = Exp-f₂.map (Monad.unit (PlusN-is-monad {n})) e
    upAlts : ∀ {n}{ev}{tv}{r} → Alternatives ev tv r → Alternatives ev (tv ⨁ n) r
    upAlts {n} e = Functor.map alternatives-is-functor₂ (Monad.unit (PlusN-is-monad {n})) e

  mutual

    syntax alternativeConstraintGen Γ α₀ α₁ alt C = Γ ►′ alt ∶ α₀ ⟶ α₁ ↝ C
    data alternativeConstraintGen {ev : Set}{tv : Set}(Γ : Environment ev tv)(α₀ α₁ : Type tv) :
                                   {r : Shape} → Alternative ev tv r → Constraint tv Extended → Set where
      Simple : ∀ {r}{n}{v : Name ev (Datacon n)}{e : Expression _ _ r}{a}{τs}{T}{C}
             → let δ = TVar zero
            in Γ v ≡ DC∀ a · τs ⟶ T
             → addAll (Vec-f.map (_↑t) τs) (upGamma {a} Γ ↑Γ) ► (upExp {a} e ↑e) ∶ δ ↝ C
             → Γ ►′ v →′ e ∶ α₀ ⟶ α₁ ↝ Ⅎ′ a · (Ⅎ δ ∼′ (upType {a} α₁ ↑t) ∧′ C) ∧′ applyAll a (TVar T) ∼′ upType {a} α₀
      GADT : ∀ {r}{n}{v : Name ev (Datacon n)}{e : Expression _ _ r}{a}{b}{Q}{τs}{T}{C}
           → let δ = TVar zero
          in Γ v ≡ DC∀′ a , b · Q ⇒ τs ⟶ T
           →   addAll (Vec-f.map (_↑t) τs) (upGamma {b} (upGamma {a} Γ) ↑Γ)
             ► (upExp {b} (upExp {a} e) ↑e) ∶ δ ↝ C
           → Γ ►′ v →′ e ∶ α₀ ⟶ α₁ ↝ Ⅎ′ a · Ⅎ′ b · (Imp′ Q (Ⅎ (C ∧′ δ ∼′ (upType {b} (upType {a} α₁) ↑t))))
                                                  ∧′ upType {b} (upType {a} α₀) ∼′ Type-f.map (PlusN-m.unit b) (applyAll a (TVar T))

    syntax alternativesConstraintGen Γ α₀ α₁ alts C = Γ ►► alts ∶ α₀ ⟶ α₁ ↝ C
    data alternativesConstraintGen {ev : Set}{tv : Set}(Γ : Environment ev tv)(α₀ α₁ : Type tv) :
                                   {r : Shape} → Alternatives ev tv r → Constraint tv Extended → Set where
      NoAlternative : Γ ►► esac ∶ α₀ ⟶ α₁ ↝ ε′
      AnAlternative : ∀ {r₁ r₂}{a : Alternative _ _ r₁}{as : Alternatives _ _ r₂}{C₁}{C₂}
                    → Γ ►′ a      ∶ α₀ ⟶ α₁ ↝ C₁
                    → Γ ►► as     ∶ α₀ ⟶ α₁ ↝ C₂
                    → Γ ►► a ∣ as ∶ α₀ ⟶ α₁ ↝ C₂

    syntax constraintGen a c b d = a ► b ∶ c ↝ d
    data constraintGen {ev : Set}{tv : Set}
                       (Γ : Environment ev tv)(τ : Type tv) : {r : Shape} →
                       Expression ev tv r → Constraint tv Extended → Set where
      VarCon₁ : ∀ {v}{n}{q}{t}
              → Γ (N v) ≡ ∀′ n · q ⇒ t
              → Γ ► Var (N v) ∶ τ ↝ Ⅎ′ n · QC q ∧′ upType {n} τ ∼′ t
      VarCon₂ : ∀ {n}{d}{a}{τs : Vec _ n}{k}
              → Γ (DC d) ≡ DC∀ a · τs ⟶ k
              → Γ ► Var (DC d) ∶ τ ↝ Ⅎ′ a · upType {a} τ ∼′ funType τs (applyAll a (TVar k))
      VarCon₃ : ∀ {n}{d}{a}{b}{Q}{τs : Vec _ n}{k}
              → Γ (DC d) ≡ DC∀′ a , b · Q ⇒ τs ⟶ k
              → Γ ► Var (DC d) ∶ τ ↝ Ⅎ′ a · Ⅎ′ b ·
                                       QC Q ∧′ upType {b} (upType {a} τ) ∼′ funType τs (upType {b} (applyAll a (TVar k)))
      App     : ∀ {r₁}{r₂}{e₁ : Expression _ _ r₁}{e₂ : Expression _ _ r₂}{C₁}{C₂}
              → let α₀ = TVar zero
                    α₁ = TVar (suc zero)
                    α₂ = TVar (suc (suc zero))
                 in upGamma {3} Γ ► upExp {3} e₁ ∶ α₀ ↝ C₁
                  → upGamma {3} Γ ► upExp {3} e₂ ∶ α₁ ↝ C₂
                  → Γ ► e₁ · e₂ ∶ τ ↝ Ⅎ Ⅎ Ⅎ C₁ ∧′ C₂ ∧′ α₀ ∼′ (α₁ ⟶ α₂) ∧′ upType {3} τ ∼′ α₂
      Abs :  ∀ {r}{e : Expression _ _ r}{C}
              → let α₀ = TVar zero
                    α₁ = TVar (suc zero)
                 in ⟨ ∀′ 0 · ε ⇒ α₀ ⟩, upGamma {2} Γ ► upExp {2} e ∶ α₁ ↝ C
                  → Γ ► λ′ e ∶ τ ↝ Ⅎ Ⅎ C ∧′ upType {2} τ ∼′ (α₀ ⟶ α₁)
      Let : ∀{r₁}{r₂}{x : Expression _ _ r₁}{y : Expression _ _ r₂}{C₁}{C₂}
          → let α₀ = TVar zero
                α₁ = TVar (suc zero)
             in                    upGamma {2} Γ ► upExp {2} x ∶ α₀ ↝ C₁
              → ⟨ ∀′ 0 · ε ⇒ α₀ ⟩, upGamma {2} Γ ► upExp {2} y ∶ α₁ ↝ C₂
              → Γ ► let₁ x in′ y ∶ τ ↝ Ⅎ Ⅎ C₁ ∧′ C₂ ∧′ upType {2} τ ∼′ α₁
      LetA : ∀{r₁}{r₂}{x : Expression _ _ r₁}{y : Expression _ _ r₂}{t}{C₁}{C₂}
           → let α₀ = TVar zero
                 α₁ = TVar (suc zero)
              in                    upGamma {2} Γ ► upExp {2} x ∶ α₀ ↝ C₁
               → ⟨ ∀′ 0 · ε ⇒ α₀ ⟩, upGamma {2} Γ ► upExp {2} y ∶ α₁ ↝ C₂
               → Γ ► let₂ x ∷ t in′ y ∶ τ ↝ Ⅎ Ⅎ C₁ ∧′ C₂ ∧′ upType {2} τ ∼′ α₁ ∧′ upType {2} t ∼′ α₀
      GLetA : ∀{n}{r₁}{r₂}{x : Expression _ _ r₁}{y : Expression _ _ r₂}{Q}{t}{C}{C₂}
           → let α₀ = upType {n} (TVar zero)
                 α₁ = upType {n} (TVar (suc zero))
                 up2 = PlusN-f.map n (PlusN-m.unit 2)
              in                     upGamma {n} (upGamma {2} Γ) ► Exp-f₂.map up2 x ∶ α₀ ↝ C
               → upGamma {n} (upGamma {2} (⟨ ∀′ n · Q ⇒ t ⟩, Γ)) ► upExp {n} (upExp {2} y) ∶ α₁ ↝ C₂
               → Γ ► let₃ n · x ∷ Q ⇒ t in′ y ∶ τ ↝ Ⅎ Ⅎ Ⅎ′ n · Imp′ (QC-f.map up2 Q)  (C ∧′ α₀ ∼′ Type-f.map up2 t)
                                                            ∧′ C₂ ∧′ upType {n} (upType {2} τ) ∼′ α₁
      Case : ∀{r₁}{r₂}{x : Expression _ _ r₁}{alts : Alternatives _ _ r₂}{C₁}{C₂}
           → let α₀ = TVar zero
                 α₁ = TVar (suc zero)
              in upGamma {2} Γ ► upExp {2} x ∶ α₀ ↝ C₁
               → upGamma {2} Γ ►► upAlts {2} alts ∶ α₀ ⟶ α₁ ↝ C₂
               → Γ ► case x of alts ∶ τ ↝ Ⅎ Ⅎ C₁ ∧′ C₂

  genConstraint : {ev : Set}{tv : Set}{r : Shape}
                  (Γ : Environment ev tv)(e : Expression ev tv r)(τ : Type tv) → ∃ (λ C → Γ ► e ∶ τ ↝ C)
  genConstraintAlternative : {ev : Set}{tv : Set}{r : Shape} (Γ : Environment ev tv)(a : Alternative ev tv r)(α₀ α₁ : Type tv)
                           → ∃ (λ C → Γ ►′ a ∶ α₀ ⟶ α₁ ↝ C)
  genConstraintAlternative Γ (n →′ e) α₀ α₁ with Γ n | inspect Γ n
  ... | DC∀ a · τs ⟶ k | iC p with genConstraint (addAll (Vec-f.map _↑t τs) (upGamma {a} Γ ↑Γ)) (upExp {a} e ↑e) (TVar zero)
  ...                          | C , p₂ = _ , Simple p p₂
  genConstraintAlternative Γ (n →′ e) α₀ α₁
      | DC∀′ a , b · Q ⇒ τs ⟶ k | iC p with genConstraint (addAll (Vec-f.map _↑t τs) (upGamma {b} (upGamma {a} Γ) ↑Γ))
                                                           (upExp {b} (upExp {a} e) ↑e)
                                                           (TVar zero)
  ...                                   | C , p₂ = _ , GADT p p₂
  genConstraintAlternatives : {ev : Set}{tv : Set}{r : Shape} (Γ : Environment ev tv)(a : Alternatives ev tv r)(α₀ α₁ : Type tv)
                            → ∃ (λ C → Γ ►► a ∶ α₀ ⟶ α₁ ↝ C)
  genConstraintAlternatives Γ esac α₀ α₁ = _ , NoAlternative
  genConstraintAlternatives Γ (a ∣ as) α₀ α₁ with genConstraintAlternative Γ a α₀ α₁ | genConstraintAlternatives Γ as α₀ α₁
  ... | C₁ , p₁ | C₂ , p₂ = _ , AnAlternative p₁ p₂
  genConstraint  Γ (Var (N v)) τ with Γ (N v) | inspect Γ (N v)
  ... | ∀′ n · q ⇒ t | iC prf = _ , VarCon₁ prf
  genConstraint  Γ (Var (DC d)) τ with Γ (DC d) | inspect Γ (DC d)
  ... | DC∀  a · τs ⟶ k         | iC prf = _ , VarCon₂ prf
  ... | DC∀′ a , b · q ⇒ τs ⟶ k | iC prf = _ , VarCon₃ prf
  genConstraint Γ (e₁ · e₂) τ with genConstraint (upGamma {3} Γ) (upExp {3} e₁) (TVar zero)
                                 | genConstraint (upGamma {3} Γ) (upExp {3} e₂) (TVar (suc zero))
  ... | C₁ , p₁ | C₂ , p₂ = _ , App p₁ p₂
  genConstraint Γ (λ′ e′) τ with genConstraint (⟨ ∀′ 0 · ε ⇒ TVar zero ⟩, upGamma {2} Γ) (upExp {2} e′) (TVar (suc zero))
  ... | C , p = _ , Abs p
  genConstraint  Γ (let₁ x in′ y) τ with genConstraint (upGamma {2} Γ) (upExp {2} x) (TVar zero)
                                       | genConstraint (⟨ ∀′ 0 · ε ⇒ TVar zero ⟩, upGamma {2} Γ) (upExp {2} y) (TVar (suc zero))
  ... | C₁ , p₁ | C₂ , p₂ = _ , Let p₁ p₂
  genConstraint Γ (let₂ x ∷ t in′ y) τ with genConstraint (upGamma {2} Γ) (upExp {2} x) (TVar zero)
                                       | genConstraint (⟨ ∀′ 0 · ε ⇒ TVar zero ⟩, upGamma {2} Γ) (upExp {2} y) (TVar (suc zero))
  ... | C₁ , p₁ | C₂ , p₂ = _ , LetA p₁ p₂
  genConstraint Γ (let₃ n · x ∷ Q ⇒ t in′ y) τ with genConstraint (upGamma {n} (upGamma {2} Γ))
                                                                  (Exp-f₂.map (PlusN-f.map n (PlusN-m.unit 2)) x)
                                                                  (upType {n} (TVar zero))
                                                  | genConstraint (upGamma {n} (upGamma {2} (⟨ ∀′ n · Q ⇒ t ⟩, Γ)))
                                                                  (upExp {n} (upExp {2} y))
                                                                  (upType {n} (TVar (suc zero)))
  ... | C₁ , p₁ | C₂ , p₂ = _ , GLetA p₁ p₂
  genConstraint Γ (case x of alts) τ with genConstraint (upGamma {2} Γ) (upExp {2} x) (TVar zero)
                                        | genConstraintAlternatives (upGamma {2} Γ) (upAlts {2} alts) (TVar zero) (TVar (suc zero))
  ... | C₁ , p₁ | C₂ , p₂ = _ , Case p₁ p₂


-- Andreas, 2016-03-28, Issue 1920
-- Improve error message when user puts where clause in hole.

infix 3 _∎

postulate
  A : Set
  begin : A
  _∎ : A → A

works : A
works = begin
  ∎
  where b = begin

test : A
test = {!begin
  ∎
  where b = begin
!}


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

open import lib.Basics
open import lib.types.Empty
open import lib.types.Sigma
open import lib.types.Paths

module lib.types.Pi where

instance
  Π-level : ∀ {i j} {A : Type i} {B : A → Type j} {n : ℕ₋₂}
    → ((x : A) → has-level n (B x)) → has-level n (Π A B)
  Π-level {n = ⟨-2⟩} p = has-level-in ((λ x → contr-center (p x)) , lemma)
    where abstract lemma = λ f → λ= (λ x → contr-path (p x) (f x))
  Π-level {n = S n} p = has-level-in lemma where
    abstract
      lemma = λ f g →
        equiv-preserves-level λ=-equiv {{Π-level (λ x → has-level-apply (p x) (f x) (g x))}}

  Πi-level : ∀ {i j} {A : Type i} {B : A → Type j} {n : ℕ₋₂}
    → ((x : A) → has-level n (B x)) → has-level n ({x : A} → B x)
  Πi-level {A = A} {B} p = equiv-preserves-level e {{Π-level p}}  where

    e : Π A B ≃ ({x : A} → B x)
    fst e f {x} = f x
    is-equiv.g (snd e) f x = f
    is-equiv.f-g (snd e) _ = idp
    is-equiv.g-f (snd e) _ = idp
    is-equiv.adj (snd e) _ = idp

{- Equivalences in a Π-type -}
Π-emap-l : ∀ {i j k} {A : Type i} {B : Type j} (P : B → Type k)
            → (e : A ≃ B) → Π A (P ∘ –> e) ≃ Π B P
Π-emap-l {A = A} {B = B} P e = equiv f g f-g g-f where
  f : Π A (P ∘ –> e) → Π B P
  f u b = transport P (<–-inv-r e b) (u (<– e b))

  g : Π B P → Π A (P ∘ –> e)
  g v a = v (–> e a)

  abstract
    f-g : ∀ v → f (g v) == v
    f-g v = λ= λ b → to-transp (apd v (<–-inv-r e b))

    g-f : ∀ u → g (f u) == u
    g-f u = λ= λ a → to-transp $ transport (λ p → u _ == _ [ P ↓ p ])
                                           (<–-inv-adj e a)
                                           (↓-ap-in P (–> e)
                                                      (apd u $ <–-inv-l e a))

Π-emap-r : ∀ {i j k} {A : Type i} {B : A → Type j} {C : A → Type k}
  → (∀ x → B x ≃ C x) → Π A B ≃ Π A C
Π-emap-r {A = A} {B = B} {C = C} k = equiv f g f-g g-f
  where f : Π A B → Π A C
        f c x = –> (k x) (c x)

        g : Π A C → Π A B
        g d x = <– (k x) (d x)

        abstract
          f-g : ∀ d → f (g d) == d
          f-g d = λ= (λ x →  <–-inv-r (k x) (d x))

          g-f : ∀ c → g (f c) == c
          g-f c = λ= (λ x → <–-inv-l (k x) (c x))

{-
favonia: This part is not used.

module _ {i₀ i₁ j₀ j₁} {A₀ : Type i₀} {A₁ : Type i₁}
         {B₀ : A₀ → Type j₀} {B₁ : A₁ → Type j₁} where
  Π-emap : (u : A₀ ≃ A₁) (v : ∀ a → B₀ (<– u a) ≃ B₁ a) → Π A₀ B₀ ≃ Π A₁ B₁
  Π-emap u v = Π A₀ B₀           ≃⟨ Π-emap-l _ (u ⁻¹) ⁻¹ ⟩
               Π A₁ (B₀ ∘ <– u)  ≃⟨ Π-emap-r v ⟩
               Π A₁ B₁           ≃∎

  Π-emap' : (u : A₀ ≃ A₁) (v : ∀ a → B₀ a ≃ B₁ (–> u a)) → Π A₀ B₀ ≃ Π A₁ B₁
  Π-emap' u v = Π A₀ B₀           ≃⟨ Π-emap-r v ⟩
                Π A₀ (B₁ ∘ –> u)  ≃⟨ Π-emap-l _ u ⟩
                Π A₁ B₁           ≃∎
-}

{- Coversions between functions with implicit and explicit arguments -}

expose-equiv : ∀ {i j} {A : Type i} {B : A → Type j}
  → ({x : A} → B x) ≃ ((x : A) → B x)
expose-equiv = (λ f a → f {a}) , is-eq
  _
  (λ f {a} → f a)
  (λ _ → idp)
  (λ _ → idp)

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

  ↓-Π-in : {x x' : A} {p : x == x'} {u : Π (B x) (C x)} {u' : Π (B x') (C x')}
    → ({t : B x} {t' : B x'} (q : t == t' [ B ↓ p ])
        → u t == u' t' [ uncurry C ↓ pair= p q ])
    → (u == u' [ (λ x → Π (B x) (C x)) ↓ p ])
  ↓-Π-in {p = idp} f = λ= (λ x → f (idp {a = x}))

  ↓-Π-out : {x x' : A} {p : x == x'} {u : Π (B x) (C x)} {u' : Π (B x') (C x')}
    → (u == u' [ (λ x → Π (B x) (C x)) ↓ p ])
    → ({t : B x} {t' : B x'} (q : t == t' [ B ↓ p ])
        → u t == u' t' [ uncurry C ↓ pair= p q ])
  ↓-Π-out {p = idp} q idp = app= q _

  ↓-Π-β : {x x' : A} {p : x == x'} {u : Π (B x) (C x)} {u' : Π (B x') (C x')}
    → (f : {t : B x} {t' : B x'} (q : t == t' [ B ↓ p ])
            → u t == u' t' [ uncurry C ↓ pair= p q ])
    → {t : B x} {t' : B x'} (q : t == t' [ B ↓ p ])
    → ↓-Π-out (↓-Π-in f) q == f q
  ↓-Π-β {p = idp} f idp = app=-β (λ x → f (idp {a = x})) _

  ↓-Π-η : {x x' : A} {p : x == x'} {u : Π (B x) (C x)} {u' : Π (B x') (C x')}
    → (q : (u == u' [ (λ x → Π (B x) (C x)) ↓ p ]))
    → ↓-Π-in (↓-Π-out q) == q
  ↓-Π-η {p = idp} q = ! (λ=-η q)

  ↓-Π-equiv : {x x' : A} {p : x == x'} {u : Π (B x) (C x)} {u' : Π (B x') (C x')}
    → ({t : B x} {t' : B x'} (q : t == t' [ B ↓ p ])
        → u t == u' t' [ uncurry C ↓ pair= p q ])
    ≃ (u == u' [ (λ x → Π (B x) (C x)) ↓ p ])
  ↓-Π-equiv {p = idp} = equiv ↓-Π-in ↓-Π-out ↓-Π-η
    (λ u → <– (ap-equiv expose-equiv _ _)
      (λ= (λ t → <– (ap-equiv expose-equiv _ _)
        (λ= (λ t' → λ= (↓-Π-β u))))))

{- Dependent paths in a Π-type where the codomain is not dependent on anything

Right now, this is defined in terms of the previous one. Maybe it’s a good idea,
maybe not.
-}
module _ {i j k} {A : Type i} {B : A → Type j} {C : Type k} {x x' : A}
  {p : x == x'} {u : B x → C} {u' : B x' → C} where

  ↓-app→cst-in :
    ({t : B x} {t' : B x'} (q : t == t' [ B ↓ p ])
      → u t == u' t')
    → (u == u' [ (λ x → B x → C) ↓ p ])
  ↓-app→cst-in f = ↓-Π-in (λ q → ↓-cst-in (f q))

  ↓-app→cst-out :
    (u == u' [ (λ x → B x → C) ↓ p ])
    → ({t : B x} {t' : B x'} (q : t == t' [ B ↓ p ])
        → u t == u' t')
  ↓-app→cst-out r q = ↓-cst-out (↓-Π-out r q)

  ↓-app→cst-β :
    (f : ({t : B x} {t' : B x'} (q : t == t' [ B ↓ p ])
           → u t == u' t'))
    → {t : B x} {t' : B x'} (q : t == t' [ B ↓ p ])
    → ↓-app→cst-out (↓-app→cst-in f) q == f q
  ↓-app→cst-β f q =
    ↓-app→cst-out (↓-app→cst-in f) q
             =⟨ idp ⟩
    ↓-cst-out (↓-Π-out (↓-Π-in (λ qq → ↓-cst-in (f qq))) q)
             =⟨ ↓-Π-β (λ qq → ↓-cst-in (f qq)) q |in-ctx
                      ↓-cst-out ⟩
    ↓-cst-out (↓-cst-in {p = pair= p q} (f q))
             =⟨ ↓-cst-β (pair= p q) (f q) ⟩
    f q =∎

{- favonia: these lemmas are not used anywhere

{- Similar to above, with domain being the identity function. -}
{- These lemmas were in homotopy.FunctionOver and in different conventions. -}

module _ {i j} {A B : Type i} {C : Type j}
  {u : A → C} {v : B → C} where

  ↓-idf→cst-in : ∀ (p : A == B)
    → u == v ∘ coe p
    → u == v [ (λ x → x → C) ↓ p ]
  ↓-idf→cst-in idp q = q

  ↓-idf→cst-ua-in : ∀ (e : A ≃ B)
    → u == v ∘ –> e
    → u == v [ (λ x → x → C) ↓ ua e ]
  ↓-idf→cst-ua-in e q = ↓-idf→cst-in (ua e) (q ∙ ap (v ∘_) (λ= λ a → ! (coe-β e a)))

  ↓-idf→cst-in' : ∀ (p : A == B)
    → u ∘ coe! p == v
    → u == v [ (λ x → x → C) ↓ p ]
  ↓-idf→cst-in' idp q = q

  ↓-idf→cst-ua-in' : ∀ (e : A ≃ B)
    → u ∘ <– e == v
    → u == v [ (λ x → x → C) ↓ ua e ]
  ↓-idf→cst-ua-in' e q = ↓-idf→cst-in' (ua e) (ap (u ∘_) (λ= λ a → coe!-β e a) ∙ q)

module _ {i j} {A B : Type i} {C : Type j}
  {u : C → A} {v : C → B} where

  ↓-cst→idf-in : ∀ (p : A == B)
    → coe p ∘ u == v
    → u == v [ (λ x → C → x) ↓ p ]
  ↓-cst→idf-in idp q = q

  ↓-cst→idf-ua-in : ∀ (e : A ≃ B)
    → –> e ∘ u == v
    → u == v [ (λ x → C → x) ↓ ua e ]
  ↓-cst→idf-ua-in e q = ↓-cst→idf-in (ua e) (ap (_∘ u) (λ= λ a → coe-β e a) ∙ q)

  ↓-cst→idf-in' : ∀ (p : A == B)
    → u == coe! p ∘ v
    → u == v [ (λ x → C → x) ↓ p ]
  ↓-cst→idf-in' idp q = q

  ↓-cst→idf-ua-in' : ∀ (e : A ≃ B)
    → u == <– e ∘ v
    → u == v [ (λ x → C → x) ↓ ua e ]
  ↓-cst→idf-ua-in' e q = ↓-cst→idf-in' (ua e) (q ∙ ap (_∘ v) (λ= λ a → ! (coe!-β e a)))
-}

{- Dependent paths in an arrow type -}
module _ {i j k} {A : Type i} {B : A → Type j} {C : A → Type k}
  {x x' : A} {p : x == x'} {u : B x → C x} {u' : B x' → C x'} where

  ↓-→-in :
    ({t : B x} {t' : B x'} (q : t == t' [ B ↓ p ])
      → u t == u' t' [ C ↓ p ])
    → (u == u' [ (λ x → B x → C x) ↓ p ])
  ↓-→-in f = ↓-Π-in (λ q → ↓-cst2-in p q (f q))

  ↓-→-out :
    (u == u' [ (λ x → B x → C x) ↓ p ])
    → ({t : B x} {t' : B x'} (q : t == t' [ B ↓ p ])
      → u t == u' t' [ C ↓ p ])
  ↓-→-out r q = ↓-cst2-out p q (↓-Π-out r q)

{- Transport form of dependent path in an arrow type -}
module _ {i j k} {A : Type i} {B : A → Type j} {C : A → Type k} where

  ↓-→-from-transp : {x x' : A} {p : x == x'}
    {u : B x → C x} {u' : B x' → C x'}
    → transport C p ∘ u == u' ∘ transport B p
    → u == u' [ (λ x → B x → C x) ↓ p ]
  ↓-→-from-transp {p = idp} q = q

  ↓-→-to-transp : {x x' : A} {p : x == x'}
    {u : B x → C x} {u' : B x' → C x'}
    → u == u' [ (λ x → B x → C x) ↓ p ]
    → transport C p ∘ u == u' ∘ transport B p
  ↓-→-to-transp {p = idp} q = q

-- Dependent paths in a Π-type where the domain is constant
module _ {i j k} {A : Type i} {B : Type j} {C : A → B → Type k} where

  ↓-Π-cst-app-in : {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-in {p = idp} f = λ= f

  ↓-Π-cst-app-out : {x x' : A} {p : x == x'}
    {u : (b : B) → C x b} {u' : (b : B) → C x' b}
    → (u == u' [ (λ x → (b : B) → C x b) ↓ p ])
    → ((b : B) → u b == u' b [ (λ x → C x b) ↓ p ])
  ↓-Π-cst-app-out {p = idp} q = app= q

split-ap2 : ∀ {i j k} {A : Type i} {B : A → Type j} {C : Type k} (f : Σ A B → C)
  {x y : A} (p : x == y)
  {u : B x} {v : B y} (q : u == v [ B ↓ p ])
  → ap f (pair= p q) == ↓-app→cst-out (apd (curry f) p) q
split-ap2 f idp idp = idp

{-
Interaction of [apd] with function composition.
The basic idea is that [apd (g ∘ f) p == apd g (apd f p)] but the version here
is well-typed. Note that we assume a propositional equality [r] between
[apd f p] and [q].
-}
apd-∘ : ∀ {i j k} {A : Type i} {B : A → Type j} {C : (a : A) → B a → Type k}
  (g : {a : A} → Π (B a) (C a)) (f : Π A B) {x y : A} (p : x == y)
  {q : f x == f y [ B ↓ p ]} (r : apd f p == q)
  → apd (g ∘ f) p == ↓-apd-out C r (apd↓ g q)
apd-∘ g f idp idp = idp

{- When [g] is nondependent, it’s much simpler -}
apd-∘' : ∀ {i j k} {A : Type i} {B : A → Type j} {C : A → Type k}
  (g : {a : A} → B a → C a) (f : Π A B) {x y : A} (p : x == y)
  → apd (g ∘ f) p == ap↓ g (apd f p)
apd-∘' g f idp = idp

∘'-apd : ∀ {i j k} {A : Type i} {B : A → Type j} {C : A → Type k}
  (g : {a : A} → B a → C a) (f : Π A B) {x y : A} (p : x == y)
  → ap↓ g (apd f p) == apd (g ∘ f) p
∘'-apd g f idp = idp

{- And when [f] is nondependent, it’s also a bit simpler -}
apd-∘'' : ∀ {i j k} {A : Type i} {B : Type j} {C : (b : B) → Type k}
  (g : Π B C) (f : A → B) {x y : A} (p : x == y)
  {q : f x == f y} (r : ap f p == q)
  → apd (g ∘ f) p == ↓-ap-out= C f p r (apd g q) --(apd↓ g q)
apd-∘'' g f idp idp = idp

{- 2-dimensional coherence conditions -}

-- lhs :
--   ∀ {i j k} {A : Type i} {B : A → Type j} {C : A → Type k} {f g : Π A B}
--   {x y : A} {p : x == y} {u : f x == g x} {v : f y == g y}
--   (k : (u ◃ apd g p) == (apd f p ▹ v))
--   (h : {a : A} → B a → C a)
--   → ap h u ◃ apd (h ∘ g) p == ap↓ h (u ◃ apd g p)

-- rhs :
--   ∀ {i j k} {A : Type i} {B : A → Type j} {C : A → Type k} {f g : Π A B}
--   {x y : A} {p : x == y} {u : f x == g x} {v : f y == g y}
--   (k : (u ◃ apd g p) == (apd f p ▹ v))
--   (h : {a : A} → B a → C a)
--   → ap↓ h (apd f p ▹ v) == apd (h ∘ f) p ▹ ap h v

-- ap↓-↓-=-in :
--   ∀ {i j k} {A : Type i} {B : A → Type j} {C : A → Type k} {f g : Π A B}
--   {x y : A} {p : x == y} {u : f x == g x} {v : f y == g y}
--   (k : (u ◃ apd g p) == (apd f p ▹ v))
--   (h : {a : A} → B a → C a)
--   → ap↓ (λ {a} → ap (h {a = a})) (↓-=-in {p = p} {u = u} {v = v} k)
--   == ↓-=-in (lhs {f = f} {g = g} k h ∙ ap (ap↓ (λ {a} → h {a = a})) k
--                                      ∙ rhs {f = f} {g = g} k h)

{-
Commutation of [ap↓ (ap h)] and [↓-swap!]. This is "just" J, but it’s not as
easy as it seems.
-}

-- module Ap↓-swap! {i j k ℓ} {A : Type i} {B : Type j} {C : Type k}
--   {D : Type ℓ} (h : C → D) (f : A → C) (g : B → C)
--   {a a' : A} {p : a == a'} {b b' : B} {q : b == b'}
--   (r : f a == g b') (s : f a' == g b)
--   (t : r == s ∙ ap g q  [ (λ x → f x == g b') ↓ p ])
--   where

--   lhs : ap h (ap f p ∙' s) == ap (h ∘ f) p ∙' ap h s
--   lhs = ap-∙' h (ap f p) s ∙ (ap (λ u → u ∙' ap h s) (∘-ap h f p))

--   rhs : ap h (s ∙ ap g q) == ap h s ∙ ap (h ∘ g) q
--   rhs = ap-∙ h s (ap g q) ∙ (ap (λ u → ap h s ∙ u) (∘-ap h g q))

--   β : ap↓ (ap h) (↓-swap! f g r s t) ==
--               lhs ◃ ↓-swap! (h ∘ f) (h ∘ g) (ap h r) (ap h s) (ap↓ (ap h) t ▹ rhs)
--   β with a | a' | p | b | b' | q | r | s | t
--   β | a | .a | idp | b | .b | idp | r | s | t = coh r s t  where

--     T : {x x' : C} (r s : x == x') (t : r == s ∙ idp) → Type _
--     T r s t =
--       ap (ap h) (∙'-unit-l s ∙ ! (∙-unit-r s) ∙ ! t) ==
--       (ap-∙' h idp s ∙ idp)
--       ∙
--       (∙'-unit-l (ap h s) ∙
--       ! (∙-unit-r (ap h s)) ∙
--       !
--       (ap (ap h) t ∙'
--         (ap-∙ h s idp ∙ idp)))

--     coh' : {x x' : C} {r s : x == x'} (t : r == s) → T r s (t ∙ ! (∙-unit-r s))
--     coh' {r = idp} {s = .idp} idp = idp

--     coh : {x x' : C} (r s : x == x') (t : r == s ∙ idp) → T r s t
--     coh r s t = transport (λ t → T r s t) (coh2 t (∙-unit-r s)) (coh' (t ∙ ∙-unit-r s))  where

--       coh2 : ∀ {i} {A : Type i} {x y z : A} (p : x == y) (q : y == z) → (p ∙ q) ∙ ! q == p
--       coh2 idp idp = idp

-- module _ {i j k} {A : Type i} {B B' : Type j} {C : Type k} (f : A → C) (g' : B' → B) (g : B → C) where

--   abc : {a a' : A} {p : a == a'} {c c' : B'} {q' : c == c'} {q : g' c == g' c'}
--     (r : f a == g (g' c')) (s : f a' == g (g' c))
--     (t : q == ap g' q')
--     (α : r == s ∙ ap g q [ (λ x → f x == g (g' c')) ↓ p ])
--     → {!(↓-swap! f g r s α ▹ ?) ∙'2ᵈ ?!} == ↓-swap! f (g ∘ g') {p = p} {q = q'} r s (α ▹ ap (λ u → s ∙ u) (ap (ap g) t ∙ ∘-ap g g' q'))
--   abc = {!!}

{- Functoriality of application and function extensionality -}

∙-app= : ∀ {i j} {A : Type i} {B : A → Type j} {f g h : Π A B}
  (α : f == g) (β : g == h)
  → α ∙ β == λ= (λ x → app= α x ∙ app= β x)
∙-app= idp β = λ=-η β

∙-λ= : ∀ {i j} {A : Type i} {B : A → Type j} {f g h : Π A B}
  (α : f ∼ g) (β : g ∼ h)
  → λ= α ∙ λ= β == λ= (λ x → α x ∙ β x)
∙-λ= α β = ∙-app= (λ= α) (λ= β)
  ∙ ap λ= (λ= (λ x → ap (λ w → w ∙ app= (λ= β) x) (app=-β α x)
                   ∙ ap (λ w → α x ∙ w) (app=-β β x)))


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

open import Base
open import Homotopy.PushoutDef
open import Homotopy.VanKampen.Guide

module Homotopy.VanKampen.SplitCode {i} (d : pushout-diag i)
  (l : legend i (pushout-diag.C d)) (a₁ : pushout-diag.A d) where

  open pushout-diag d
  open legend l

  open import Homotopy.Truncation
  open import Homotopy.PathTruncation

  -- Definition.
  module _ where
    private
      data #code-a (a₂ : A) : Set i
      data #code-b (b₂ : B) : Set i

      data #code-a a₂ where
        #a : a₁ ≡₀ a₂ → #code-a a₂
        #ba : ∀ n → #code-b (g $ loc n) → f (loc n) ≡₀ a₂ → #code-a a₂
      data #code-b b₂ where
        #ab : ∀ n → #code-a (f $ loc n) → g (loc n) ≡₀ b₂ → #code-b b₂

    code-b : B → Set i
    code-b = #code-b

    code-a : A → Set i
    code-a = #code-a

    postulate -- HIT
      code-a-is-set : ∀ a → is-set (code-a a)
      code-b-is-set : ∀ b → is-set (code-b b)

    a : ∀ {a₂} → a₁ ≡₀ a₂ → code-a a₂
    a = #a

    infixl 6 a
    syntax a co = ⟧a co

    ba : ∀ {a₂} n → code-b (g $ loc n) → f (loc n) ≡₀ a₂ → code-a a₂
    ba = #ba

    infixl 6 ba
    syntax ba n co p = co b⟦ n ⟧a p

    ab : ∀ {b₂} n → code-a (f $ loc n) → g (loc n) ≡₀ b₂ → code-b b₂
    ab = #ab

    infixl 6 ab
    syntax ab n co p = co a⟦ n ⟧b p

    postulate -- HIT
      code-a-refl-refl : ∀ n (co : code-a (f $ loc n))
        → co a⟦ n ⟧b refl₀ b⟦ n ⟧a refl₀ ≡ co
      code-b-refl-refl : ∀ n (co : code-b (g $ loc n))
        → co b⟦ n ⟧a refl₀ a⟦ n ⟧b refl₀ ≡ co
      -- The other diriction is fine.
      -- There's no canonical choice between two, I think.
      code-ab-swap : ∀ n₁ co n₂ (r : loc n₁ ≡₀ loc n₂)
        → co a⟦ n₁ ⟧b ap₀ g r b⟦ n₂ ⟧a refl₀
        ≡ co a⟦ n₁ ⟧b refl₀ b⟦ n₁ ⟧a ap₀ f r

    -- Dependent recursor.
    code-rec : ∀ {j}
      (P-a : ∀ {a₂} → code-a a₂ → Set j) ⦃ _ : ∀ {a₂} co → is-set $ P-a {a₂} co ⦄
      (P-b : ∀ {b₂} → code-b b₂ → Set j) ⦃ _ : ∀ {b₂} co → is-set $ P-b {b₂} co ⦄
      (h₀-a : ∀ {a₂} (p : _ ≡₀ a₂) → P-a (a p))
      (h₀-ba : ∀ {a₂} n {co} (_ : P-b co) (p : _ ≡₀ a₂)
        → P-a (co b⟦ n ⟧a p))
      (h₀-ab : ∀ {b₂} n {co} (_ : P-a co) (p : _ ≡₀ b₂)
        → P-b (co a⟦ n ⟧b p))
      (h₁-a-rr : ∀ n {co} (pco : P-a co) →
        transport (P-a {f $ loc n}) (code-a-refl-refl n co)
          (h₀-ba n (h₀-ab n pco $ refl₀) $ refl₀)
        ≡ pco)
      (h₁-b-rr : ∀ n {co} (pco : P-b co) →
        transport (P-b {g $ loc n}) (code-b-refl-refl n co)
          (h₀-ab n (h₀-ba n pco $ refl₀) $ refl₀)
        ≡ pco)
      (h₁-ab-s : ∀ n₁ {co} (pco : P-a co) n₂ r →
        transport (P-a {f $ loc n₂}) (code-ab-swap n₁ co n₂ r)
          (h₀-ba n₂ (h₀-ab n₁ pco $ ap₀ g r) $ refl₀)
        ≡ (h₀-ba n₁ (h₀-ab n₁ pco $ refl₀) $ ap₀ f r))
      → (∀ {a₂} (co : code-a a₂) → P-a co)
      × (∀ {b₂} (co : code-b b₂) → P-b co)
    code-rec P-a P-b h₀-a h₀-ba h₀-ab _ _ _ = elim-a , elim-b
      where
        elim-a : ∀ {a₂} (co : code-a a₂) → P-a co
        elim-b : ∀ {b₂} (co : code-b b₂) → P-b co
        elim-a (#a       p) = h₀-a                p
        elim-a (#ba n co p) = h₀-ba n (elim-b co) p
        elim-b (#ab n co p) = h₀-ab n (elim-a co) p

    -- This is actually "partially dependent".
    -- P-a and P-b are indexed by the end points.
    -- This is fine because they are fixed in
    -- all transports in 1-cells.
    code-rec-nondep : ∀ {j}
      (P-a : A → Set j) ⦃ _ : ∀ a → is-set $ P-a a ⦄
      (P-b : B → Set j) ⦃ _ : ∀ b → is-set $ P-b b ⦄
      (h₀-a : ∀ {a₂} (p : a₁ ≡₀ a₂) → P-a a₂)
      (h₀-ba : ∀ {a₂} n {co : code-b (g $ loc n)} → P-b (g $ loc n)
        → f (loc n) ≡₀ a₂ → P-a a₂)
      (h₀-ab : ∀ {b₂} n {co : code-a (f $ loc n)} → P-a (f $ loc n)
        → g (loc n) ≡₀ b₂ → P-b b₂)
      (h₁-a-rr : ∀ n {co} (pco : P-a (f $ loc n))
        → h₀-ba n {co a⟦ n ⟧b refl₀} (h₀-ab n {co} pco $ refl₀) refl₀ ≡ pco)
      (h₁-b-rr : ∀ n {co} (pco : P-b (g $ loc n))
        → h₀-ab n {co b⟦ n ⟧a refl₀} (h₀-ba n {co} pco $ refl₀) refl₀ ≡ pco)
      (h₁-ab-s : ∀ n₁ {co : code-a $ f $ loc n₁} (pco : P-a $ f $ loc n₁) n₂ (r : loc n₁ ≡₀ loc n₂) →
          h₀-ba n₂ {co a⟦ n₁ ⟧b ap₀ g r} (h₀-ab n₁ {co} pco $ ap₀ g r) refl₀
        ≡ h₀-ba n₁ {co a⟦ n₁ ⟧b refl₀} (h₀-ab n₁ {co} pco $ refl₀) (ap₀ f r))
      → (∀ {a₂} (co : code-a a₂) → P-a a₂)
      × (∀ {b₂} (co : code-b b₂) → P-b b₂)
    code-rec-nondep P-a P-b h₀-a h₀-ba h₀-ab _ _ _ = elim-a , elim-b
      where
        elim-a : ∀ {a₂} (co : code-a a₂) → P-a a₂
        elim-b : ∀ {b₂} (co : code-b b₂) → P-b b₂
        elim-a (#a       p) = h₀-a                     p
        elim-a (#ba c co p) = h₀-ba c {co} (elim-b co) p
        elim-b (#ab c co p) = h₀-ab c {co} (elim-a co) p

  module _ where
    trans-a : ∀ {y z} (q : y ≡ z) (p : a₁ ≡₀ y)
      → transport code-a q (⟧a p) ≡ ⟧a (p ∘₀ proj q)
    trans-a refl p = ap a (! (refl₀-right-unit p))

    trans-ba : ∀ {y z} (q : y ≡ z) n co (p : f (loc n) ≡₀ y)
      → transport code-a q (co b⟦ n ⟧a p) ≡ co b⟦ n ⟧a p ∘₀ proj q
    trans-ba refl n co p = ap (ba n co) (! (refl₀-right-unit p))

    trans-ab : ∀ {y b} (q : y ≡ b) n co (p : g (loc n) ≡₀ y)
      → transport code-b q (co a⟦ n ⟧b p) ≡ co a⟦ n ⟧b p ∘₀ proj q
    trans-ab refl n co p = ap (ab n co) (! (refl₀-right-unit p))

  module _ where
    -- all-paths
    abstract
      code-has-all-cells₂-a : ∀ {a} {x y : code-a a} (p q : x ≡ y) → p ≡ q
      code-has-all-cells₂-a = prop-has-all-paths $ code-a-is-set _ _ _

      code-has-all-cells₂-b : ∀ {b} {x y : code-b b} (p q : x ≡ y) → p ≡ q
      code-has-all-cells₂-b = prop-has-all-paths $ code-b-is-set _ _ _

    code-a-rec : ∀ {j}
      (P-a : ∀ {a₂} → code-a a₂ → Set j) ⦃ _ : ∀ {a₂} co → is-set $ P-a {a₂} co ⦄
      (h₀-a : ∀ {a₂} (p : _ ≡₀ a₂) → P-a (⟧a p))
      (h₀-ba : ∀ {a₂} n co (p : _ ≡₀ a₂)
        → P-a (co b⟦ n ⟧a p))
      (h₁-a-rr : ∀ n {co} (pco : P-a co) →
        transport (P-a {f $ loc n}) (code-a-refl-refl n co)
          (h₀-ba n (co a⟦ n ⟧b refl₀) $ refl₀)
        ≡ pco)
      → (∀ {a₂} (co : code-a a₂) → P-a co)
    code-a-rec {j} P-a ⦃ P-a-is-set ⦄ h₀-a h₀-ba h₁-a-rr = π₁ $ code-rec
      P-a ⦃ P-a-is-set ⦄
      (λ _ → unit) ⦃ λ _ → unit-is-set ⦄
      h₀-a
      (λ n {co} _ p → h₀-ba n co p)
      (λ _ _ _ → tt)
      h₁-a-rr
      (λ _ _ → prop-has-all-paths unit-is-prop _ _)
      -- FIXME This proof is too ugly.
      (λ n₁ {co} (pco : P-a co) n₂ r →
        transport (P-a {f $ loc n₂}) (code-ab-swap n₁ co n₂ r)
          (h₀-ba n₂ (co a⟦ n₁ ⟧b ap₀ g r) $ refl₀)
            ≡⟨ ! $ h₁-a-rr n₂ _ ⟩
        transport (P-a {f $ loc n₂}) (code-a-refl-refl n₂ _)
          (h₀-ba n₂ (_ a⟦ n₂ ⟧b refl₀) $ refl₀)
            ≡⟨ ap (λ x → transport (P-a {f $ loc n₂}) (code-a-refl-refl n₂ _)
                $ h₀-ba n₂ (_ a⟦ n₂ ⟧b refl₀) $ refl₀) $ code-ab-swap n₁ co n₂ r ⟩
        transport (P-a {f $ loc n₂}) (code-a-refl-refl n₂ _)
          (h₀-ba n₂ (_ a⟦ n₂ ⟧b refl₀) $ refl₀)
            ≡⟨ h₁-a-rr n₂ _ ⟩∎
        h₀-ba n₁ (co a⟦ n₁ ⟧b refl₀) (ap₀ f r)
            ∎)

    code-b-rec : ∀ {j}
      (P-b : ∀ {b₂} → code-b b₂ → Set j) ⦃ _ : ∀ {b₂} co → is-set $ P-b {b₂} co ⦄
      (h₀-ab : ∀ {b₂} n co (p : _ ≡₀ b₂)
        → P-b (co a⟦ n ⟧b p))
      (h₁-b-rr : ∀ n {co} (pco : P-b co) →
        transport (P-b {g $ loc n}) (code-b-refl-refl n co)
          (h₀-ab n (co b⟦ n ⟧a refl₀) $ refl₀)
        ≡ pco)
      → (∀ {b₂} (co : code-b b₂) → P-b co)
    code-b-rec {j} P-b ⦃ P-b-is-set ⦄ h₀-ab h₁-b-rr = π₂ $ code-rec
      (λ _ → unit) ⦃ λ _ → unit-is-set ⦄
      P-b ⦃ P-b-is-set ⦄
      (λ _ → tt)
      (λ _ _ _ → tt)
      (λ n {co} _ p → h₀-ab n co p)
      (λ _ _ → prop-has-all-paths unit-is-prop _ _)
      h₁-b-rr
      (λ _ _ _ _ → prop-has-all-paths unit-is-prop _ _)

  -- Derived 1-cells.
  module _ where
    abstract
      code-ba-swap : ∀ n₁ co n₂ (r : loc n₁ ≡₀ loc n₂)
        → co b⟦ n₁ ⟧a ap₀ f r a⟦ n₂ ⟧b refl₀
        ≡ co b⟦ n₁ ⟧a refl₀ a⟦ n₁ ⟧b ap₀ g r
      code-ba-swap n₁ co n₂ r =
        co                                   b⟦ n₁ ⟧a ap₀ f r a⟦ n₂ ⟧b refl₀
          ≡⟨ ap (λ x → x b⟦ n₁ ⟧a ap₀ f r a⟦ n₂ ⟧b refl₀) $ ! $ code-b-refl-refl n₁ co ⟩
        co b⟦ n₁ ⟧a refl₀ a⟦ n₁ ⟧b refl₀ b⟦ n₁ ⟧a ap₀ f r a⟦ n₂ ⟧b refl₀
          ≡⟨ ap (λ x → x a⟦ n₂ ⟧b refl₀) $ ! $ code-ab-swap n₁ (co b⟦ n₁ ⟧a refl₀) n₂ r ⟩
        co b⟦ n₁ ⟧a refl₀ a⟦ n₁ ⟧b ap₀ g r b⟦ n₂ ⟧a refl₀ a⟦ n₂ ⟧b refl₀
          ≡⟨ code-b-refl-refl n₂ $ co b⟦ n₁ ⟧a refl₀ a⟦ n₁ ⟧b ap₀ g r ⟩∎
        co b⟦ n₁ ⟧a refl₀ a⟦ n₁ ⟧b ap₀ g r
          ∎

    abstract
      -- Old (provable) rules.
      code-a-merge : ∀ {a₂} n p₁ (p₂ : _ ≡₀ a₂)
        → ⟧a p₁ a⟦ n ⟧b refl₀ b⟦ n ⟧a p₂
        ≡ ⟧a p₁            ∘₀           p₂
      code-a-merge {a₂} n p₁ = π₀-extend
        ⦃ λ _ → ≡-is-set $ code-a-is-set a₂ ⦄
        ( λ p₂ →
            ⟧a p₁ a⟦ n ⟧b refl₀ b⟦ n ⟧a proj p₂
              ≡⟨ ! $ trans-ba p₂ n (⟧a p₁ a⟦ n ⟧b refl₀) refl₀ ⟩
            transport code-a p₂ (⟧a p₁ a⟦ n ⟧b refl₀ b⟦ n ⟧a refl₀)
              ≡⟨ ap (transport code-a p₂) $ code-a-refl-refl n (⟧a p₁) ⟩
            transport code-a p₂ (⟧a p₁)
              ≡⟨ trans-a p₂ p₁ ⟩∎
            ⟧a p₁ ∘₀ proj p₂
              ∎)

    abstract
      code-ab-merge : ∀ {b₂} n₁ co n₂ p₁ (p₂ : _ ≡₀ b₂)
        → co a⟦ n₁ ⟧b p₁ b⟦ n₂ ⟧a refl₀ a⟦ n₂ ⟧b p₂
        ≡ co a⟦ n₁ ⟧b p₁             ∘₀            p₂
      code-ab-merge {b₂} n₁ co n₂ p₁ = π₀-extend
        ⦃ λ _ → ≡-is-set $ code-b-is-set b₂ ⦄
        ( λ p₂ →
            co a⟦ n₁ ⟧b p₁ b⟦ n₂ ⟧a refl₀ a⟦ n₂ ⟧b proj p₂
              ≡⟨ ! $ trans-ab p₂ n₂ (co a⟦ n₁ ⟧b p₁ b⟦ n₂ ⟧a refl₀) refl₀ ⟩
            transport code-b p₂ (co a⟦ n₁ ⟧b p₁ b⟦ n₂ ⟧a refl₀ a⟦ n₂ ⟧b refl₀)
              ≡⟨ ap (transport code-b p₂) $ code-b-refl-refl n₂ (co a⟦ n₁ ⟧b p₁) ⟩
            transport code-b p₂ (co a⟦ n₁ ⟧b p₁)
              ≡⟨ trans-ab p₂ n₁ co p₁ ⟩∎
            co a⟦ n₁ ⟧b p₁ ∘₀ proj p₂
              ∎)

    abstract
      code-ba-merge : ∀ {a₂} n₁ co n₂ p₁ (p₂ : _ ≡₀ a₂)
        → co b⟦ n₁ ⟧a p₁ a⟦ n₂ ⟧b refl₀ b⟦ n₂ ⟧a p₂
        ≡ co b⟦ n₁ ⟧a p₁             ∘₀            p₂
      code-ba-merge {a₂} n₁ co n₂ p₁ = π₀-extend
        ⦃ λ _ → ≡-is-set $ code-a-is-set a₂ ⦄
        ( λ p₂ →
            co b⟦ n₁ ⟧a p₁ a⟦ n₂ ⟧b refl₀ b⟦ n₂ ⟧a proj p₂
              ≡⟨ ! $ trans-ba p₂ n₂ (co b⟦ n₁ ⟧a p₁ a⟦ n₂ ⟧b refl₀) refl₀ ⟩
            transport code-a p₂ (co b⟦ n₁ ⟧a p₁ a⟦ n₂ ⟧b refl₀ b⟦ n₂ ⟧a refl₀)
              ≡⟨ ap (transport code-a p₂) $ code-a-refl-refl n₂ (co b⟦ n₁ ⟧a p₁) ⟩
            transport code-a p₂ (co b⟦ n₁ ⟧a p₁)
              ≡⟨ trans-ba p₂ n₁ co p₁ ⟩∎
            co b⟦ n₁ ⟧a p₁ ∘₀ proj p₂
              ∎)

    abstract
      code-a-shift : ∀ {b₂} n₁ p₁ n₂ (r : loc n₁ ≡₀ loc n₂) (p₂ : _ ≡₀ b₂)
        → ⟧a p₁ ∘₀ ap₀ f r a⟦ n₂ ⟧b            p₂
        ≡ ⟧a p₁            a⟦ n₁ ⟧b ap₀ g r ∘₀ p₂
      code-a-shift n₁ p₁ n₂ r p₂ =
        ⟧a p₁             ∘₀            ap₀ f r a⟦ n₂ ⟧b p₂
          ≡⟨ ap (λ x → x a⟦ n₂ ⟧b p₂) $ ! $ code-a-merge n₁ p₁ (ap₀ f r) ⟩
        ⟧a p₁ a⟦ n₁ ⟧b refl₀ b⟦ n₁ ⟧a ap₀ f r a⟦ n₂ ⟧b p₂
          ≡⟨ ap (λ x → x a⟦ n₂ ⟧b p₂) $ ! $ code-ab-swap n₁ (⟧a p₁) n₂ r ⟩
        ⟧a p₁ a⟦ n₁ ⟧b ap₀ g r b⟦ n₂ ⟧a refl₀ a⟦ n₂ ⟧b p₂
          ≡⟨ code-ab-merge n₁ (⟧a p₁) n₂ (ap₀ g r) p₂ ⟩∎
        ⟧a p₁ a⟦ n₁ ⟧b ap₀ g r             ∘₀            p₂
          ∎

    abstract
      code-ba-shift : ∀ {b₂} n₁ co n₂ p₁ n₃ (r : loc n₂ ≡₀ loc n₃) (p₂ : _ ≡₀ b₂)
        → co b⟦ n₁ ⟧a p₁ ∘₀ ap₀ f r a⟦ n₃ ⟧b            p₂
        ≡ co b⟦ n₁ ⟧a p₁            a⟦ n₂ ⟧b ap₀ g r ∘₀ p₂
      code-ba-shift n₁ co n₂ p₁ n₃ r p₂ =
        co b⟦ n₁ ⟧a p₁             ∘₀            ap₀ f r a⟦ n₃ ⟧b p₂
          ≡⟨ ap (λ x → x a⟦ n₃ ⟧b p₂) $ ! $ code-ba-merge n₁ co n₂ p₁ (ap₀ f r) ⟩
        co b⟦ n₁ ⟧a p₁ a⟦ n₂ ⟧b refl₀ b⟦ n₂ ⟧a ap₀ f r a⟦ n₃ ⟧b p₂
          ≡⟨ ap (λ x → x a⟦ n₃ ⟧b p₂) $ ! $ code-ab-swap n₂ (co b⟦ n₁ ⟧a p₁) n₃ r ⟩
        co b⟦ n₁ ⟧a p₁ a⟦ n₂ ⟧b ap₀ g r b⟦ n₃ ⟧a refl₀ a⟦ n₃ ⟧b p₂
          ≡⟨ code-ab-merge n₂ (co b⟦ n₁ ⟧a p₁) n₃ (ap₀ g r) p₂ ⟩∎
        co b⟦ n₁ ⟧a p₁ a⟦ n₂ ⟧b ap₀ g r             ∘₀            p₂
          ∎

    abstract
      code-ab-shift : ∀ {a₂} n₁ co n₂ p₁ n₃ (r : loc n₂ ≡₀ loc n₃) (p₂ : _ ≡₀ a₂)
        → co a⟦ n₁ ⟧b p₁ ∘₀ ap₀ g r b⟦ n₃ ⟧a            p₂
        ≡ co a⟦ n₁ ⟧b p₁            b⟦ n₂ ⟧a ap₀ f r ∘₀ p₂
      code-ab-shift n₁ co n₂ p₁ n₃ r p₂ =
        co a⟦ n₁ ⟧b p₁             ∘₀            ap₀ g r b⟦ n₃ ⟧a p₂
          ≡⟨ ap (λ x → x b⟦ n₃ ⟧a p₂) $ ! $ code-ab-merge n₁ co n₂ p₁ (ap₀ g r) ⟩
        co a⟦ n₁ ⟧b p₁ b⟦ n₂ ⟧a refl₀ a⟦ n₂ ⟧b ap₀ g r b⟦ n₃ ⟧a p₂
          ≡⟨ ap (λ x → x b⟦ n₃ ⟧a p₂) $ ! $ code-ba-swap n₂ (co a⟦ n₁ ⟧b p₁) n₃ r ⟩
        co a⟦ n₁ ⟧b p₁ b⟦ n₂ ⟧a ap₀ f r a⟦ n₃ ⟧b refl₀ b⟦ n₃ ⟧a p₂
          ≡⟨ code-ba-merge n₂ (co a⟦ n₁ ⟧b p₁) n₃ (ap₀ f r) p₂ ⟩∎
        co a⟦ n₁ ⟧b p₁ b⟦ n₂ ⟧a ap₀ f r             ∘₀            p₂
          ∎

  -- Definition of code
  module _ where
    P : Set i
    P = pushout d

    -- Basic conversion
    a⇒b : ∀ n → code-a (f $ loc n) → code-b (g $ loc n)
    a⇒b n co = co a⟦ n ⟧b refl₀

    b⇒a : ∀ n → code-b (g $ loc n) → code-a (f $ loc n)
    b⇒a n co = co b⟦ n ⟧a refl₀

    private
      -- The head of the code
      code-glue-eq-loc : ∀ n → code-a (f $ loc n) ≃ code-b (g $ loc n)
      code-glue-eq-loc n = a⇒b n ,
        iso-is-eq (a⇒b n) (b⇒a n) (code-b-refl-refl n) (code-a-refl-refl n)

    abstract
      trans-code-a-r : ∀ n₁ n₂ (r : loc n₁ ≡ loc n₂) (co : code-a $ f $ loc n₁)
        → transport (code-a ◯ f) r co ≡ co a⟦ n₁ ⟧b refl₀ b⟦ n₁ ⟧a proj (ap f r)
      trans-code-a-r n₁ n₂ r co =
        transport (code-a ◯ f) r co
          ≡⟨ ! $ trans-ap code-a f r co ⟩
        transport code-a (ap f r) co
          ≡⟨ ap (transport code-a $ ap f r) $ ! $ code-a-refl-refl n₁ co ⟩
        transport code-a (ap f r) (co a⟦ n₁ ⟧b refl₀ b⟦ n₁ ⟧a refl₀)
          ≡⟨ trans-ba (ap f r) n₁ _ refl₀ ⟩∎
        co a⟦ n₁ ⟧b refl₀ b⟦ n₁ ⟧a proj (ap f r)
          ∎

    abstract
      trans-code-b-r : ∀ n₁ n₂ (r : loc n₁ ≡ loc n₂) (co : code-b $ g $ loc n₁)
        → transport (code-b ◯ g) r co ≡ co b⟦ n₁ ⟧a refl₀ a⟦ n₁ ⟧b proj (ap g r)
      trans-code-b-r n₁ n₂ r co =
        transport (code-b ◯ g) r co
          ≡⟨ ! $ trans-ap code-b g r co ⟩
        transport code-b (ap g r) co
          ≡⟨ ap (transport code-b $ ap g r) $ ! $ code-b-refl-refl n₁ co ⟩
        transport code-b (ap g r) (co b⟦ n₁ ⟧a refl₀ a⟦ n₁ ⟧b refl₀)
          ≡⟨ trans-ab (ap g r) n₁ _ refl₀ ⟩∎
        co b⟦ n₁ ⟧a refl₀ a⟦ n₁ ⟧b proj (ap g r)
          ∎

    private
      abstract
        code-glue-eq-route : ∀ n₁ n₂ r
          → transport (λ c → code-a (f c) ≃ code-b (g c)) r (code-glue-eq-loc n₁)
          ≡ code-glue-eq-loc n₂
        code-glue-eq-route n₁ n₂ r = equiv-eq $ funext λ co →
          π₁ (transport (λ c → code-a (f c) ≃ code-b (g c)) r (code-glue-eq-loc n₁)) co
              ≡⟨ ap (λ x → x co) $ app-trans
                (λ c →  code-a (f c) ≃ code-b (g c))
                (λ c → code-a (f c) → code-b (g c))
                (λ _ → π₁) r (code-glue-eq-loc n₁) ⟩
          transport (λ c → code-a (f c) → code-b (g c)) r (a⇒b n₁) co
              ≡⟨ trans-→ (code-a ◯ f) (code-b ◯ g) r (a⇒b n₁) co ⟩
          transport (code-b ◯ g) r (a⇒b n₁ $ transport (code-a ◯ f) (! r) co)
              ≡⟨ ap (transport (code-b ◯ g) r ◯ a⇒b n₁) $ trans-code-a-r _ _ (! r) co ⟩
          transport (code-b ◯ g) r (co a⟦ n₂ ⟧b refl₀ b⟦ n₂ ⟧a proj (ap f $ ! r) a⟦ n₁ ⟧b refl₀)
              ≡⟨ ap (λ x → transport (code-b ◯ g) r $ x a⟦ n₁ ⟧b refl₀) $ ! $ code-ab-swap _ co _ (proj $ ! r) ⟩
          transport (code-b ◯ g) r (co a⟦ n₂ ⟧b proj (ap g $ ! r) b⟦ n₁ ⟧a refl₀ a⟦ n₁ ⟧b refl₀)
              ≡⟨ ap (transport (code-b ◯ g) r) $ code-b-refl-refl n₁ _ ⟩
          transport (code-b ◯ g) r (co a⟦ n₂ ⟧b proj (ap g $ ! r))
              ≡⟨ trans-code-b-r _ _ r _ ⟩
          co a⟦ n₂ ⟧b proj (ap g $ ! r) b⟦ n₁ ⟧a refl₀ a⟦ n₁ ⟧b proj (ap g r)
              ≡⟨ code-ab-merge n₂ co n₁ _ _ ⟩
          co a⟦ n₂ ⟧b proj (ap g (! r) ∘ ap g r)
              ≡⟨ ap (λ x → co a⟦ n₂ ⟧b proj x) $ concat-ap g (! r) r ⟩
          co a⟦ n₂ ⟧b proj (ap g $ ! r ∘ r)
              ≡⟨ ap (λ x → co a⟦ n₂ ⟧b proj (ap g x)) $ opposite-left-inverse r ⟩∎
          a⇒b n₂ co
              ∎

    private
      code-glue-eq : ∀ c → code-a (f c) ≃ code-b (g c)
      code-glue-eq = visit-fiber-rec l
        (λ c → code-a (f c) ≃ code-b (g c))
        ⦃ λ _ → ≃-is-set (code-a-is-set _) (code-b-is-set _) ⦄
        code-glue-eq-loc
        code-glue-eq-route

    -- The data type!
    code : P → Set i
    code = pushout-rec-nondep (Set i) code-a code-b (eq-to-path ◯ code-glue-eq)

    -- Useful lemma
    abstract
      trans-code-glue-loc : ∀ n₂ co → transport code (glue $ loc n₂) co ≡ a⇒b n₂ co
      trans-code-glue-loc n₂ co =
        transport code (glue $ loc n₂) co
          ≡⟨ ! $ trans-ap (λ X → X) code (glue $ loc n₂) co ⟩
        transport (λ X → X) (ap code $ glue $ loc n₂) co
          ≡⟨ ap (λ x → transport (λ X → X) x co)
              $ pushout-β-glue-nondep (Set i) code-a code-b (eq-to-path ◯ code-glue-eq) (loc n₂) ⟩
        transport (λ X → X) (eq-to-path $ code-glue-eq $ loc n₂) co
          ≡⟨ ap (λ x → transport (λ X → X) (eq-to-path x) co)
                $ visit-fiber-β-loc l
                    (λ c → code-a (f c) ≃ code-b (g c))
                    ⦃ λ _ → ≃-is-set (code-a-is-set _) (code-b-is-set _) ⦄
                    code-glue-eq-loc
                    code-glue-eq-route
                    n₂ ⟩
        transport (λ X → X) (eq-to-path $ code-glue-eq-loc n₂) co
          ≡⟨ trans-id-eq-to-path (code-glue-eq-loc n₂) co ⟩∎
        a⇒b n₂ co
          ∎

    abstract
      trans-code-!glue-loc : ∀ n₂ co → transport code (! $ glue $ loc n₂) co ≡ b⇒a n₂ co
      trans-code-!glue-loc n₂ co = move!-transp-right code (glue $ loc n₂) co (b⇒a n₂ co) $ ! $
        transport code (glue $ loc n₂) (b⇒a n₂ co)
          ≡⟨ trans-code-glue-loc n₂ (b⇒a n₂ co) ⟩
        a⇒b n₂ (b⇒a n₂ co)
          ≡⟨ code-b-refl-refl n₂ co ⟩∎
        co
          ∎

    -- Truncation level
    abstract
      code-is-set : ∀ p → is-set $ code p
      code-is-set = pushout-rec
        (λ p → is-set $ code p)
        code-a-is-set
        code-b-is-set
        (λ _ → prop-has-all-paths is-set-is-prop _ _)


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

module Axiom.LEM where
  open import Basics
  open import Flat
  open import lib.Basics

  postulate LEM : {@♭ i : ULevel} (@♭ P : PropT i) → Dec (P holds)


{-# OPTIONS --allow-unsolved-metas #-}
-- {-# OPTIONS -v tc.record.eta:20 -v tc.eta:100  -v tc.constr:50 #-}

-- Andreas, 2013-05-15 reported by nomeata

module Issue846 where

open import Issue846.Imports

opt-is-opt2 : ∀ n s → n mod 7 ≡ 1' → winner n s opt ≡ false
opt-is-opt2 0 s ()
opt-is-opt2 (suc n) s eq =
  let (pick k 1≤k k≤6) = s (suc n)
  in
    cong not (opt-is-opt (suc n ∸ k) s (lem-sub-p n k eq {!1≤k!} {!!} ))

-- The problem here was that the first hole was solved by
-- 'nonEmpty' by the instance finder,
-- which is called since the first hole is an unused argument.
-- 'nonEmpty' of course does not fit, but the instance finder
-- did not see it and produced constraints.
-- The eta-contractor broke on something ill-typed.

-- Now, the instance finder is a bit smarter due to
-- improved equality checking for dependent function types.
-- Unequal domains now do not block comparison of
-- codomains, only block the domain type.


------------------------------------------------------------------------------
-- A looping (error) combinator
------------------------------------------------------------------------------

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

module LTC-PCF.Loop where

open import LTC-PCF.Base

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

error : D
error = fix (λ f → f)


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

module Music where

open import Data.Nat     using (ℕ; zero; suc; _+_; _*_; _≤_; _≤?_)
open import Data.Integer using (ℤ; +_)
open import Data.List    using (List; foldr; []; _∷_; reverse; sum; map)
open import Data.Product using (_×_; _,_)
open import Data.Sum     using (_⊎_; inj₁; inj₂)
open import Data.Vec     using (Vec; []; _∷_; replicate; concat; zipWith; toList; _++_; foldr₁; take; drop) renaming (map to vmap)
open import Function     using (_∘_)

open import Data.Nat.Properties using (<⇒≤)
open import Relation.Nullary    using (yes; no)

open import Relation.Binary.PropositionalEquality using (sym; subst)

open import Nat
open import Note
open import Pitch
open import Interval

-- A point in the music grid, which can either be a tone,
-- a continuation of a previous tone, or a rest.
data Point : Set where
  tone : Pitch → Point
  hold : Pitch → Point
  rest : Point

data Melody (n : ℕ) : Set where
  melody : Vec Point n → Melody n

unmelody : {n : ℕ} → Melody n → Vec Point n
unmelody (melody ps) = ps

infixr 5 _m++_
_m++_ : {m n : ℕ} → Melody m → Melody n → Melody (m + n)
melody a m++ melody b = melody (a ++ b)

note→melody : (n : Note) → Melody (noteDuration n)
note→melody (tone zero    p) = melody []
note→melody (tone (suc d) p) = melody (tone p ∷ replicate (hold p))
note→melody (rest _)         = melody (replicate rest)

notes→melody : (ns : List Note) → Melody (sum (map noteDuration ns))
notes→melody []       = melody []
notes→melody (n ∷ ns) = note→melody n m++ notes→melody ns

pitches→melody : {n : ℕ} → (d : Duration) → (ps : Vec Pitch n) → Melody (n * d)
pitches→melody d ps = melody (concat (vmap (unmelody ∘ note→melody ∘ tone d) ps))

-- Assumes melody is well-formed in that a held note has the
-- same pitch as the note before it.
-- Does not consolidate rests.
melody→notes : {n : ℕ} → Melody n → List Note
melody→notes (melody m) = (reverse ∘ mn 0 ∘ reverse ∘ toList) m
  where mn : ℕ → List Point → List Note -- c is the number of held points
        mn c []            = []
        mn c (tone p ∷ ps) = tone (suc c) p ∷ mn 0 ps
        mn c (hold _ ∷ ps) = mn (suc c) ps
        mn c (rest ∷ ps)   = rest 1 ∷ mn 0 ps

transposePoint : ℤ → Point → Point
transposePoint k (tone p) = tone (transposePitch k p)
transposePoint k (hold p) = hold (transposePitch k p)
transposePoint k rest     = rest

transposeMelody : {n : ℕ} → ℤ → Melody n → Melody n
transposeMelody k = melody ∘ vmap (transposePoint k) ∘ unmelody

data Chord (n : ℕ) : Set where
  chord : Vec Point n → Chord n

unchord : {n : ℕ} → Chord n → Vec Point n
unchord (chord ps) = ps

-- We represent music as a v × d grid where v is the number of voices and d is the duration.
-- The primary representation is as parallel melodies (counterpoint).
data Counterpoint (v : ℕ) (d : ℕ): Set where
  cp : Vec (Melody d) v → Counterpoint v d

uncp : {v d : ℕ} → Counterpoint v d → Vec (Melody d) v
uncp (cp m) = m

-- An alternative representation of music is as a series of chords (harmonic progression).
data Harmony (v : ℕ) (d : ℕ): Set where
  harmony : Vec (Chord v) d → Harmony v d

unharmony : {v d : ℕ} → Harmony v d → Vec (Chord v) d
unharmony (harmony h) = h

pitches→harmony : {n : ℕ} (d : Duration) → (ps : Vec Pitch n) → Harmony n d
pitches→harmony zero    ps = harmony []
pitches→harmony (suc d) ps = harmony (chord (vmap tone ps) ∷ replicate (chord (vmap hold ps)))

pitchPair→Harmony : (d : Duration) → PitchPair → Harmony 2 d
pitchPair→Harmony d (p , q) = pitches→harmony d (p ∷ q ∷ [])

pitchInterval→Harmony : (d : Duration) → PitchInterval → Harmony 2 d
pitchInterval→Harmony d = pitchPair→Harmony d ∘ pitchIntervalToPitchPair

{-
pitchIntervalsToCounterpoint : PitchInterval → Counterpoint
pitchIntervalsToCounterpoint = pitchPairToCounterpoint ∘ pitchIntervalToPitchPair
-}

addEmptyVoice : {v d : ℕ} → Harmony v d → Harmony (suc v) d
addEmptyVoice (harmony h) = harmony (vmap (chord ∘ (rest ∷_) ∘ unchord) h)

infixl 5 _+H+_
_+H+_ : {v d d' : ℕ} → Harmony v d → Harmony v d' → Harmony v (d + d')
h +H+ h' = harmony (unharmony h ++ unharmony h')

foldIntoHarmony : {k n : ℕ} (ds : Vec Duration (suc k)) → (pss : Vec (Vec Pitch n) (suc k)) → Harmony n (foldr₁ _+_ ds)
foldIntoHarmony (d ∷ [])      (ps ∷ [])        = pitches→harmony d ps
foldIntoHarmony (d ∷ d' ∷ ds) (ps ∷ ps' ∷ pss) = (pitches→harmony d ps) +H+ (foldIntoHarmony (d' ∷ ds) (ps' ∷ pss))

-- matrix transposition
mtranspose : {A : Set}{m n : ℕ} → Vec (Vec A n) m → Vec (Vec A m) n
mtranspose []         = replicate []
mtranspose (xs ∷ xss) = zipWith _∷_ xs (mtranspose xss)

counterpoint→harmony : {v d : ℕ} → Counterpoint v d → Harmony v d
counterpoint→harmony = harmony ∘ vmap chord ∘ mtranspose ∘ vmap unmelody ∘ uncp

harmony→counterpoint : {v d : ℕ} → Harmony v d → Counterpoint v d
harmony→counterpoint = cp ∘ vmap melody ∘ mtranspose ∘ vmap unchord ∘ unharmony

-- Fix length of a melody, either truncating or padding with rests
fixLength : {m : ℕ} → (n : ℕ) → Melody m → Melody n
fixLength {m} n (melody ns) with <-∨-≥ n m
... | inj₁ n<m = melody (take n (subst (Vec Point) (sym (m+n-m=n n m {<⇒≤ n<m})) ns))
... | inj₂ m≤n = melody (subst (Vec Point) (m+n-m=n m n) (ns ++ replicate {n = n - m ⟨ m≤n ⟩} rest))

holdToTone : Point → Point
holdToTone (tone p) = tone p
holdToTone (hold p) = tone p
holdToTone rest     = rest

firstHoldToTone : {n : ℕ} → Melody n → Melody n
firstHoldToTone (melody [])       = melody []
firstHoldToTone (melody (x ∷ xs)) = melody (holdToTone x ∷ xs)

-- Drop points, but convert any held tones to tones.
dropPoints : {n : ℕ} → (m : ℕ) → Melody (m + n) → Melody n
dropPoints m = firstHoldToTone ∘ melody ∘ drop m ∘ unmelody