{-

A Cubical proof of Blakers-Massey Theorem (KANG Rongji, Oct. 2021)

Based on the previous type-theoretic proof described in
  Kuen-Bang Hou (Favonia), Eric Finster, Dan Licata, Peter LeFanu Lumsdaine,
  "A Mechanization of the Blakers–Massey Connectivity Theorem in Homotopy Type Theory"
  (https://arxiv.org/abs/1605.03227)

Also the HoTT-Agda formalization by Favonia:
  (https://github.com/HoTT/HoTT-Agda/blob/master/theorems/homotopy/BlakersMassey.agda)

Using cubes explicitly as much as possible.

-}
{-# OPTIONS  --safe #-}
module Cubical.Homotopy.BlakersMassey where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.GroupoidLaws
open import Cubical.Foundations.Transport
open import Cubical.Foundations.HLevels

open import Cubical.Foundations.Equiv
open import Cubical.Foundations.Isomorphism
open import Cubical.Foundations.Univalence

open import Cubical.Data.Nat hiding (elim)
open import Cubical.Data.Sigma

open import Cubical.HITs.Truncation renaming (hLevelTrunc to Trunc)

open import Cubical.Homotopy.Connected
open import Cubical.Homotopy.WedgeConnectivity

module BlakersMassey {ℓ₁ ℓ₂ ℓ₃ : Level}
  (X : Type ℓ₁)(Y : Type ℓ₂)(Q : X → Y → Type ℓ₃)
  {m : HLevel} (leftConn  : (x : X) → isConnected (1 + m) (Σ[ y ∈ Y ] Q x y))
  {n : HLevel} (rightConn : (y : Y) → isConnected (1 + n) (Σ[ x ∈ X ] Q x y))
  where

  ℓ : Level
  ℓ = ℓ-max (ℓ-max ℓ₁ ℓ₂) ℓ₃

  leftFiber  : X → Type (ℓ-max ℓ₂ ℓ₃)
  leftFiber x  = Σ[ y ∈ Y ] Q x y

  rightFiber : Y → Type (ℓ-max ℓ₁ ℓ₃)
  rightFiber y = Σ[ x ∈ X ] Q x y

  {- An alternative formulation of pushout with fewer parameters -}

  data Pushout : Type ℓ
    where
      inl : X → Pushout
      inr : Y → Pushout
      push : {x : X}{y : Y} → Q x y → inl x ≡ inr y

  {- Some preliminary definitions for convenience -}

  fiberSquare :
      {x₀ x₁ : X}{y₀ : Y}{p : Pushout}(q₀₀ : Q x₀ y₀)(q₁₀ : Q x₁ y₀)
    → inl x₁ ≡ p → inl x₀ ≡ p → Type ℓ
  fiberSquare q₀₀ q₁₀ r' r = PathP (λ i → push q₀₀ (~ i) ≡ r' i) (sym (push q₁₀)) r

  fiberSquarePush :
      {x₀ x₁ : X}{y₀ y₁ : Y}(q₀₀ : Q x₀ y₀)(q₁₀ : Q x₁ y₀)(q₁₁ : Q x₁ y₁)
    → inl x₀ ≡ inr y₁ → Type ℓ
  fiberSquarePush q₀₀ q₁₀ q₁₁ = fiberSquare q₀₀ q₁₀ (push q₁₁)

  fiber' : {x₀ : X}{y₀ : Y}(q₀₀ : Q x₀ y₀){x₁ : X}{p : Pushout} → inl x₁ ≡ p → inl x₀ ≡ p → Type ℓ
  fiber' {y₀ = y₀} q₀₀ {x₁ = x₁} r' r = Σ[ q₁₀ ∈ Q x₁ y₀ ] fiberSquare q₀₀ q₁₀ r' r

  fiber'Push : {x₀ x₁ : X}{y₀ y₁ : Y}(q₀₀ : Q x₀ y₀)(q₁₁ : Q x₁ y₁) → inl x₀ ≡ inr y₁ → Type ℓ
  fiber'Push q₀₀ q₁₁ = fiber' q₀₀ (push q₁₁)

  leftCodeExtended :
      {x₀ : X}{y₀ : Y}(q₀₀ : Q x₀ y₀)
    → (x₁ : X){p : Pushout} → inl x₁ ≡ p → inl x₀ ≡ p → Type ℓ
  leftCodeExtended {y₀ = y₀} q₀₀ x₁ r' r = Trunc (m + n) (fiber' q₀₀ r' r)

  rightCode : {x₀ : X}(y : Y) → inl x₀ ≡ inr y → Type ℓ
  rightCode y r = Trunc (m + n) (fiber push r)

  {- Bunch of coherence data that will be used to construct Code -}

  {- Definitions of fiber→ -}

  module _
    {x₁ : X}{y₀ : Y}(q₁₀ : Q x₁ y₀) where

    {- (x₀ , q₀₀) = (x₁ , q₁₀) -}
    module _
      {y₁ : Y}(q₁₁ : Q x₁ y₁)
      (r : inl x₁ ≡ inr y₁)
      (p : fiberSquarePush q₁₀ q₁₀ q₁₁ r) where

      fiber→[q₀₀=q₁₀]-filler : (i j k : I) → Pushout
      fiber→[q₀₀=q₁₀]-filler i j k' =
        hfill (λ k → λ { (i = i0) → push q₁₁ (j ∧ k)
                       ; (i = i1) → p k j
                       ; (j = i0) → push q₁₀ (i ∧ ~ k)
                       ; (j = i1) → push q₁₁ k })
              (inS (push q₁₀ (i ∧ ~ j))) k'

      fiber→[q₀₀=q₁₀] : fiber push r
      fiber→[q₀₀=q₁₀] .fst = q₁₁
      fiber→[q₀₀=q₁₀] .snd i j = fiber→[q₀₀=q₁₀]-filler i j i1

      ∣fiber→[q₀₀=q₁₀]∣ : rightCode _ r
      ∣fiber→[q₀₀=q₁₀]∣ = ∣ fiber→[q₀₀=q₁₀] ∣ₕ

    {- (y₁ , q₁₁) = (y₀ , q₁₀) -}
    module _
      {x₀ : X}(q₀₀ : Q x₀ y₀)
      (r : inl x₀ ≡ inr y₀)
      (p : fiberSquarePush q₀₀ q₁₀ q₁₀ r) where

      fiber→[q₁₁=q₁₀]-filler : (i j k : I) → Pushout
      fiber→[q₁₁=q₁₀]-filler i j k' =
        hfill (λ k → λ { (i = i0) → push q₀₀ (j ∨ ~ k)
                       ; (i = i1) → p k j
                       ; (j = i0) → push q₀₀ (~ k)
                       ; (j = i1) → push q₁₀ (~ i ∨ k) })
              (inS (push q₁₀ (~ i ∨ ~ j))) k'

      fiber→[q₁₁=q₁₀] : fiber push r
      fiber→[q₁₁=q₁₀] .fst = q₀₀
      fiber→[q₁₁=q₁₀] .snd i j = fiber→[q₁₁=q₁₀]-filler i j i1

      ∣fiber→[q₁₁=q₁₀]∣ : rightCode _ r
      ∣fiber→[q₁₁=q₁₀]∣ = ∣ fiber→[q₁₁=q₁₀] ∣ₕ

    {- q₀₀ = q₁₁ = q₁₀ -}
    fiber→[q₀₀=q₁₀=q₁₁]-filler :
        (r : inl x₁ ≡ inr y₀)
      → (p : fiberSquarePush q₁₀ q₁₀ q₁₀ r)
      → (i j k l : I) → Pushout
    fiber→[q₀₀=q₁₀=q₁₁]-filler r p i j k l' =
      hfill (λ l → λ { (i = i0) → fiber→[q₀₀=q₁₀]-filler q₁₀ r p j k l
                     ; (i = i1) → fiber→[q₁₁=q₁₀]-filler q₁₀ r p j k l
                     ; (j = i0) → push q₁₀ ((i ∨ (k ∧ l)) ∧ (k ∨ (i ∧ ~ l)))
                     ; (j = i1) → p l k
                     ; (k = i0) → push q₁₀ ((i ∨ j) ∧ ~ l)
                     ; (k = i1) → push q₁₀ ((i ∧ ~ j) ∨ l) })
            (inS (push q₁₀ ((i ∨ (~ k ∧ j)) ∧ (~ k ∨ (i ∧ ~ j))))) l'

    fiber→[q₀₀=q₁₀=q₁₁] : fiber→[q₀₀=q₁₀] q₁₀ ≡ fiber→[q₁₁=q₁₀] q₁₀
    fiber→[q₀₀=q₁₀=q₁₁] i r p .fst = q₁₀
    fiber→[q₀₀=q₁₀=q₁₁] i r p .snd j k = fiber→[q₀₀=q₁₀=q₁₁]-filler r p i j k i1

    ∣fiber→[q₀₀=q₁₀=q₁₁]∣ : ∣fiber→[q₀₀=q₁₀]∣ q₁₀ ≡ ∣fiber→[q₁₁=q₁₀]∣ q₁₀
    ∣fiber→[q₀₀=q₁₀=q₁₁]∣ i r p = ∣ fiber→[q₀₀=q₁₀=q₁₁] i r p ∣ₕ

  {- Definitions of fiber← -}

  module _
    {x₀ : X}{y₁ : Y}(q₀₁ : Q x₀ y₁) where

    {- (x₁ , q₁₁) = (x₀ , q₀₁) -}
    module _
      {y₀ : Y}(q₀₀ : Q x₀ y₀)
      (r : inl x₀ ≡ inr y₁)
      (p : push q₀₁ ≡ r) where

      fiber←[q₁₁=q₀₁]-filler : (i j k : I) → Pushout
      fiber←[q₁₁=q₀₁]-filler i j k' =
        hfill (λ k → λ { (i = i0) → push q₀₀ (~ j ∧ k)
                       ; (i = i1) → p k j
                       ; (j = i0) → push q₀₀ (~ i ∧ k)
                       ; (j = i1) → push q₀₁ i })
              (inS (push q₀₁ (i ∧ j))) k'

      fiber←[q₁₁=q₀₁] : fiber'Push  q₀₀ q₀₁ r
      fiber←[q₁₁=q₀₁] .fst = q₀₀
      fiber←[q₁₁=q₀₁] .snd i j = fiber←[q₁₁=q₀₁]-filler i j i1

      ∣fiber←[q₁₁=q₀₁]∣ : leftCodeExtended q₀₀ _ (push q₀₁) r
      ∣fiber←[q₁₁=q₀₁]∣ = ∣ fiber←[q₁₁=q₀₁] ∣ₕ

    {- (y₀ , q₀₀) = (y₁ , q₀₁) -}
    module _
      {x₁ : X}(q₁₁ : Q x₁ y₁)
      (r : inl x₀ ≡ inr y₁)
      (p : push q₀₁ ≡ r) where

      fiber←[q₀₀=q₀₁]-filler : (i j k : I) → Pushout
      fiber←[q₀₀=q₀₁]-filler i j k' =
        hfill (λ k → λ { (i = i0) → push q₁₁ (~ j ∨ ~ k)
                       ; (i = i1) → p k j
                       ; (j = i0) → push q₀₁ (~ i)
                       ; (j = i1) → push q₁₁ (i ∨ ~ k) })
              (inS (push q₀₁ (~ i ∨ j))) k'

      fiber←[q₀₀=q₀₁] : fiber'Push q₀₁ q₁₁ r
      fiber←[q₀₀=q₀₁] .fst = q₁₁
      fiber←[q₀₀=q₀₁] .snd i j = fiber←[q₀₀=q₀₁]-filler i j i1

      ∣fiber←[q₀₀=q₀₁]∣ : leftCodeExtended q₀₁ _ (push q₁₁) r
      ∣fiber←[q₀₀=q₀₁]∣ = ∣ fiber←[q₀₀=q₀₁] ∣ₕ

    {- q₀₀ = q₀₁ = q₁₁ -}
    fiber←[q₀₀=q₀₁=q₁₁]-filler :
        (r : inl x₀ ≡ inr y₁)
      → (p : push q₀₁ ≡ r)
      → (i j k l : I) → Pushout
    fiber←[q₀₀=q₀₁=q₁₁]-filler r p i j k l' =
      hfill (λ l → λ { (i = i0) → fiber←[q₁₁=q₀₁]-filler q₀₁ r p j k l
                     ; (i = i1) → fiber←[q₀₀=q₀₁]-filler q₀₁ r p j k l
                     ; (j = i0) → push q₀₁ ((i ∨ (~ k ∧ l)) ∧ (~ k ∨ (i ∧ ~ l)))
                     ; (j = i1) → p l k
                     ; (k = i0) → push q₀₁ ((i ∨ l) ∧ ~ j)
                     ; (k = i1) → push q₀₁ ((i ∧ ~ l) ∨ j) })
            (inS (push q₀₁ ((i ∨ (k ∧ j)) ∧ (k ∨ (i ∧ ~ j))))) l'

    fiber←[q₀₀=q₀₁=q₁₁] : fiber←[q₁₁=q₀₁] q₀₁ ≡ fiber←[q₀₀=q₀₁] q₀₁
    fiber←[q₀₀=q₀₁=q₁₁] i r p .fst = q₀₁
    fiber←[q₀₀=q₀₁=q₁₁] i r p .snd j k = fiber←[q₀₀=q₀₁=q₁₁]-filler r p i j k i1

    ∣fiber←[q₀₀=q₀₁=q₁₁]∣ : ∣fiber←[q₁₁=q₀₁]∣ q₀₁ ≡ ∣fiber←[q₀₀=q₀₁]∣ q₀₁
    ∣fiber←[q₀₀=q₀₁=q₁₁]∣ i r p = ∣ fiber←[q₀₀=q₀₁=q₁₁] i r p ∣ₕ

  {- Definitions of fiber→← -}

  module _
    {x₁ : X}{y₀ : Y}(q₁₀ : Q x₁ y₀) where

    {- (x₀ , q₀₀) = (x₁ , q₁₀) -}
    module _
      {y₁ : Y}(q₁₁ : Q x₁ y₁)
      (r : inl x₁ ≡ inr y₁)
      (p : fiberSquarePush q₁₀ q₁₀ q₁₁ r) where

      fiber→←[q₀₀=q₁₀]-filler : (i j k l : I) → Pushout
      fiber→←[q₀₀=q₁₀]-filler i j k l' =
        let p' = fiber→[q₀₀=q₁₀] q₁₀ q₁₁ r p .snd in
        hfill (λ l → λ { (i = i0) → fiber←[q₁₁=q₀₁]-filler q₁₁ q₁₀ r p' j k l
                       ; (i = i1) → fiber→[q₀₀=q₁₀]-filler q₁₀ q₁₁ r p l k j
                       ; (j = i0) → push q₁₀ (~ k ∧ l)
                       ; (j = i1) → p' l k
                       ; (k = i0) → push q₁₀ (~ j ∧ l)
                       ; (k = i1) → push q₁₁ j })
              (inS (push q₁₁ (j ∧ k))) l'

      fiber→←[q₀₀=q₁₀] : fiber←[q₁₁=q₀₁] q₁₁ q₁₀ r (fiber→[q₀₀=q₁₀] q₁₀ q₁₁ r p .snd) .snd ≡ p
      fiber→←[q₀₀=q₁₀] i j k = fiber→←[q₀₀=q₁₀]-filler i j k i1

    {- (y₁ , q₁₁) = (y₀ , q₁₀) -}
    module _
      {x₀ : X}(q₀₀ : Q x₀ y₀)
      (r : inl x₀ ≡ inr y₀)
      (p : fiberSquarePush q₀₀ q₁₀ q₁₀ r) where

      fiber→←[q₁₁=q₁₀]-filler : (i j k l : I) → Pushout
      fiber→←[q₁₁=q₁₀]-filler i j k l' =
        let p' = fiber→[q₁₁=q₁₀] q₁₀ q₀₀ r p .snd in
        hfill (λ l → λ { (i = i0) → fiber←[q₀₀=q₀₁]-filler q₀₀ q₁₀ r p' j k l
                       ; (i = i1) → fiber→[q₁₁=q₁₀]-filler q₁₀ q₀₀ r p l k j
                       ; (j = i0) → push q₁₀ (~ k ∨ ~ l)
                       ; (j = i1) → p' l k
                       ; (k = i0) → push q₀₀ (~ j)
                       ; (k = i1) → push q₁₀ (j ∨ ~ l) })
              (inS (push q₀₀ (~ j ∨ k))) l'

      fiber→←[q₁₁=q₁₀] : fiber←[q₀₀=q₀₁] q₀₀ q₁₀ r (fiber→[q₁₁=q₁₀] q₁₀ q₀₀ r p .snd) .snd ≡ p
      fiber→←[q₁₁=q₁₀] i j k = fiber→←[q₁₁=q₁₀]-filler i j k i1

    {- q₀₀ = q₁₀ = q₁₁ -}
    fiber→←hypercube :
        (r : inl x₁ ≡ inr y₀)
      → (p : fiberSquarePush q₁₀ q₁₀ q₁₀ r)
      → PathP (λ i → fiber←[q₀₀=q₀₁=q₁₁] q₁₀ i r (fiber→[q₀₀=q₁₀=q₁₁] q₁₀ i r p .snd) .snd ≡ p)
              (fiber→←[q₀₀=q₁₀] q₁₀ r p) (fiber→←[q₁₁=q₁₀] q₁₀ r p)
    fiber→←hypercube r p i j u v =
      hcomp (λ l → λ { (i = i0) → fiber→←[q₀₀=q₁₀]-filler q₁₀ r p j u v l
                     ; (i = i1) → fiber→←[q₁₁=q₁₀]-filler q₁₀ r p j u v l
                     ; (j = i0) → fiber←[q₀₀=q₀₁=q₁₁]-filler q₁₀ r (fiber→[q₀₀=q₁₀=q₁₁] q₁₀ i r p .snd) i u v l
                     ; (j = i1) → fiber→[q₀₀=q₁₀=q₁₁]-filler q₁₀ r p i l v u
                     ; (u = i0) → push q₁₀ ((i ∨ (~ v ∧ l)) ∧ (~ v ∨ (i ∧ ~ l)))
                     ; (u = i1) → fiber→[q₀₀=q₁₀=q₁₁] q₁₀ i r p .snd l v
                     ; (v = i0) → push q₁₀ ((i ∨ l) ∧ ~ u)
                     ; (v = i1) → push q₁₀ ((i ∧ ~ l) ∨ u) })
            (push q₁₀ ((i ∨ (v ∧ u)) ∧ (v ∨ (i ∧ ~ u))))

  {- Definitions of fiber←→ -}

  module _
    {x₀ : X}{y₁ : Y}(q₀₁ : Q x₀ y₁) where

    {- (x₁ , q₁₁) = (x₀ , q₀₁) -}
    module _
      {y₀ : Y}(q₀₀ : Q x₀ y₀)
      (r : inl x₀ ≡ inr y₁)
      (p : push q₀₁ ≡ r) where

      fiber←→[q₁₁=q₀₁]-filler : (i j k l : I) → Pushout
      fiber←→[q₁₁=q₀₁]-filler i j k l' =
        let p' = fiber←[q₁₁=q₀₁] q₀₁ q₀₀ r p .snd in
        hfill (λ l → λ { (i = i0) → fiber→[q₀₀=q₁₀]-filler q₀₀ q₀₁ r p' j k l
                       ; (i = i1) → fiber←[q₁₁=q₀₁]-filler q₀₁ q₀₀ r p l k j
                       ; (j = i0) → push q₀₁ (k ∧ l)
                       ; (j = i1) → p' l k
                       ; (k = i0) → push q₀₀ (j ∧ ~ l)
                       ; (k = i1) → push q₀₁ l })
              (inS (push q₀₀ (j ∧ ~ k))) l'

      fiber←→[q₁₁=q₀₁] : fiber→[q₀₀=q₁₀] q₀₀ q₀₁ r (fiber←[q₁₁=q₀₁] q₀₁ q₀₀ r p .snd) .snd ≡ p
      fiber←→[q₁₁=q₀₁] i j k = fiber←→[q₁₁=q₀₁]-filler i j k i1

    {- (y₀ , q₀₀) = (y₁ , q₀₁) -}
    module _
      {x₁ : X}(q₁₁ : Q x₁ y₁)
      (r : inl x₀ ≡ inr y₁)
      (p : push q₀₁ ≡ r) where

      fiber←→[q₀₀=q₀₁]-filler : (i j k l : I) → Pushout
      fiber←→[q₀₀=q₀₁]-filler i j k l' =
        let p' = fiber←[q₀₀=q₀₁] q₀₁ q₁₁ r p .snd in
        hfill (λ l → λ { (i = i0) → fiber→[q₁₁=q₁₀]-filler q₁₁ q₀₁ r p' j k l
                       ; (i = i1) → fiber←[q₀₀=q₀₁]-filler q₀₁ q₁₁ r p l k j
                       ; (j = i0) → push q₀₁ (k ∨ ~ l)
                       ; (j = i1) → p' l k
                       ; (k = i0) → push q₀₁ (~ l)
                       ; (k = i1) → push q₁₁ (~ j ∨ l) })
              (inS (push q₁₁ (~ j ∨ ~ k))) l'

      fiber←→[q₀₀=q₀₁] : fiber→[q₁₁=q₁₀] q₁₁ q₀₁ r (fiber←[q₀₀=q₀₁] q₀₁ q₁₁ r p .snd) .snd ≡ p
      fiber←→[q₀₀=q₀₁] i j k = fiber←→[q₀₀=q₀₁]-filler i j k i1

    {- q₀₀ = q₀₁ = q₁₁ -}
    fiber←→hypercube :
        (r : inl x₀ ≡ inr y₁)
      → (p : push q₀₁ ≡ r)
      → PathP (λ i → fiber→[q₀₀=q₁₀=q₁₁] q₀₁ i r (fiber←[q₀₀=q₀₁=q₁₁] q₀₁ i r p .snd) .snd ≡ p)
              (fiber←→[q₁₁=q₀₁] q₀₁ r p) (fiber←→[q₀₀=q₀₁] q₀₁ r p)
    fiber←→hypercube r p i j u v =
      hcomp (λ l → λ { (i = i0) → fiber←→[q₁₁=q₀₁]-filler q₀₁ r p j u v l
                     ; (i = i1) → fiber←→[q₀₀=q₀₁]-filler q₀₁ r p j u v l
                     ; (j = i0) → fiber→[q₀₀=q₁₀=q₁₁]-filler q₀₁ r (fiber←[q₀₀=q₀₁=q₁₁] q₀₁ i r p .snd) i u v l
                     ; (j = i1) → fiber←[q₀₀=q₀₁=q₁₁]-filler q₀₁ r p i l v u
                     ; (u = i0) → push q₀₁ ((i ∨ (v ∧ l)) ∧ (v ∨ (i ∧ ~ l)))
                     ; (u = i1) → fiber←[q₀₀=q₀₁=q₁₁] q₀₁ i r p .snd l v
                     ; (v = i0) → push q₀₁ ((i ∨ u) ∧ ~ l)
                     ; (v = i1) → push q₀₁ ((i ∧ ~ u) ∨ l) })
           (push q₀₁ ((i ∨ (~ v ∧ u)) ∧ (~ v ∨ (i ∧ ~ u))))

  module Fiber→
    {x₁ : X}{y₀ : Y}(q₁₀ : Q x₁ y₀) =
    WedgeConnectivity m n
      (leftFiber  x₁ , (y₀ , q₁₀)) (leftConn  x₁)
      (rightFiber y₀ , (x₁ , q₁₀)) (rightConn y₀)
      (λ (y₁ , q₁₁) (x₀ , q₀₀) →
        (((r : inl x₀ ≡ inr y₁) → fiberSquarePush q₀₀ q₁₀ q₁₁ r → rightCode _ r)
        , isOfHLevelΠ2 _ (λ x y → isOfHLevelTrunc _)))
      (λ (y₁ , q₁₁) → ∣fiber→[q₀₀=q₁₀]∣ q₁₀ q₁₁)
      (λ (x₀ , q₀₀) → ∣fiber→[q₁₁=q₁₀]∣ q₁₀ q₀₀)
      (∣fiber→[q₀₀=q₁₀=q₁₁]∣ q₁₀)

  fiber→ :
      {x₁ : X}{y₀ : Y}(q₁₀ : Q x₁ y₀)
    → {x₀ : X}(q₀₀ : Q x₀ y₀) → {y₁ : Y}(q₁₁ : Q x₁ y₁)
    → (r : inl x₀ ≡ inr y₁)
    → fiberSquarePush q₀₀ q₁₀ q₁₁ r → rightCode _ r
  fiber→ q₁₀ q₀₀ q₁₁ = Fiber→.extension q₁₀ (_ , q₁₁) (_ , q₀₀)

  module Fiber←
    {x₀ : X}{y₁ : Y}(q₀₁ : Q x₀ y₁) =
    WedgeConnectivity m n
      (leftFiber  x₀ , (y₁ , q₀₁)) (leftConn  x₀)
      (rightFiber y₁ , (x₀ , q₀₁)) (rightConn y₁)
      (λ (y₀ , q₀₀) (x₁ , q₁₁) →
        (((r : inl x₀ ≡ inr y₁) → push q₀₁ ≡ r → leftCodeExtended q₀₀ _ (push q₁₁) r)
        , isOfHLevelΠ2 _ (λ x y → isOfHLevelTrunc _)))
      (λ (y₀ , q₀₀) → ∣fiber←[q₁₁=q₀₁]∣ q₀₁ q₀₀)
      (λ (x₁ , q₁₁) → ∣fiber←[q₀₀=q₀₁]∣ q₀₁ q₁₁)
      (∣fiber←[q₀₀=q₀₁=q₁₁]∣ q₀₁)

  fiber← :
      {x₀ : X}{y₁ : Y}(q₀₁ : Q x₀ y₁)
    → {y₀ : Y}(q₀₀ : Q x₀ y₀) → {x₁ : X}(q₁₁ : Q x₁ y₁)
    → (r : inl x₀ ≡ inr y₁)
    → push q₀₁ ≡ r → leftCodeExtended q₀₀ _ (push q₁₁) r
  fiber← q₀₁ q₀₀ q₁₁ = Fiber←.extension q₀₁ (_ , q₀₀) (_ , q₁₁)

  module _
    {x₀ x₁ : X}{y₀ y₁ : Y}
    (q₀₀ : Q x₀ y₀)(q₁₁ : Q x₁ y₁)
    (r : inl x₀ ≡ inr y₁) where

    left→rightCodeExtended : leftCodeExtended q₀₀ _ (push q₁₁) r → rightCode _ r
    left→rightCodeExtended =
      rec (isOfHLevelTrunc _) (λ (q₁₀ , p) → fiber→ q₁₀ q₀₀ q₁₁ r p)

    right→leftCodeExtended : rightCode _ r → leftCodeExtended q₀₀ _ (push q₁₁) r
    right→leftCodeExtended =
      rec (isOfHLevelTrunc _) (λ (q₀₁ , p) → fiber← q₀₁ q₀₀ q₁₁ r p)

  {- Definition of one-side homotopy -}

  module _
    {x₁ : X}{y₀ : Y}(q₁₀ : Q x₁ y₀) where

    {- (x₀ , q₀₀) = (x₁ , q₁₀) -}
    module _
      {y₁ : Y}(q₁₁ : Q x₁ y₁)
      (r : inl x₁ ≡ inr y₁)
      (p : fiberSquarePush q₁₀ q₁₀ q₁₁ r) where

      ∣fiber→←[q₀₀=q₁₀]∣ : right→leftCodeExtended q₁₀ q₁₁ r (fiber→ q₁₀ q₁₀ q₁₁ r p) ≡ ∣ q₁₀ , p ∣ₕ
      ∣fiber→←[q₀₀=q₁₀]∣ =
          (λ i → right→leftCodeExtended q₁₀ q₁₁ r (Fiber→.left q₁₀ (_ , q₁₁) i r p))
        ∙ recUniq {n = m + n} _ _ _
        ∙ (λ i → Fiber←.left q₁₁ (_ , q₁₀) i r (fiber→[q₀₀=q₁₀] q₁₀ q₁₁ r p .snd))
        ∙ (λ i → ∣ q₁₀ , fiber→←[q₀₀=q₁₀] q₁₀ q₁₁ r p i ∣ₕ)

    {- (y₁ , q₁₁) = (y₀ , q₁₀) -}
    module _
      {x₀ : X}(q₀₀ : Q x₀ y₀)
      (r : inl x₀ ≡ inr y₀)
      (p : fiberSquarePush q₀₀ q₁₀ q₁₀ r) where

      ∣fiber→←[q₁₁=q₁₀]∣ : right→leftCodeExtended q₀₀ q₁₀ r (fiber→ q₁₀ q₀₀ q₁₀ r p) ≡ ∣ q₁₀ , p ∣ₕ
      ∣fiber→←[q₁₁=q₁₀]∣ =
          (λ i → right→leftCodeExtended q₀₀ q₁₀ r (Fiber→.right q₁₀ (_ , q₀₀) i r p))
        ∙ recUniq {n = m + n} _ _ _
        ∙ (λ i → Fiber←.right q₀₀ (_ , q₁₀) i r (fiber→[q₁₁=q₁₀] q₁₀ q₀₀ r p .snd))
        ∙ (λ i → ∣ q₁₀ , fiber→←[q₁₁=q₁₀] q₁₀ q₀₀ r p i ∣ₕ)

    {- q₀₀ = q₁₁ = q₁₀ -}
    module _
      (r : inl x₁ ≡ inr y₀)
      (p : fiberSquarePush q₁₀ q₁₀ q₁₀ r) where

      path→←Square =
           (λ i j → right→leftCodeExtended q₁₀ q₁₀ r (Fiber→.homSquare q₁₀ i j r p))
        ∙₂ (λ i → recUniq {n = m + n} _ _ _)
        ∙₂ (λ i j → Fiber←.homSquare q₁₀ i j r (fiber→[q₀₀=q₁₀=q₁₁] q₁₀ i r p .snd))
        ∙₂ (λ i j → ∣ (q₁₀ , fiber→←hypercube q₁₀ r p i j) ∣ₕ)

    ∣fiber→←[q₀₀=q₁₀=q₁₁]∣ : ∣fiber→←[q₀₀=q₁₀]∣ q₁₀ ≡ ∣fiber→←[q₁₁=q₁₀]∣ q₁₀
    ∣fiber→←[q₀₀=q₁₀=q₁₁]∣ i r p = path→←Square r p i

  fiber→← :
      {x₁ : X}{y₀ : Y}(q₁₀ : Q x₁ y₀)
    → {x₀ : X}(q₀₀ : Q x₀ y₀) → {y₁ : Y}(q₁₁ : Q x₁ y₁)
    → (r : inl x₀ ≡ inr y₁)
    → (p : fiberSquarePush q₀₀ q₁₀ q₁₁ r)
    → right→leftCodeExtended q₀₀ q₁₁ r (fiber→ q₁₀ q₀₀ q₁₁ r p) ≡ ∣ q₁₀ , p ∣ₕ
  fiber→← {x₁ = x₁} {y₀ = y₀} q₁₀ q₀₀' q₁₁' =
    WedgeConnectivity.extension m n
      (leftFiber  x₁ , (y₀ , q₁₀)) (leftConn  x₁)
      (rightFiber y₀ , (x₁ , q₁₀)) (rightConn y₀)
      (λ (y₁ , q₁₁) (x₀ , q₀₀) →
        ((  (r : inl x₀ ≡ inr y₁) → (p : fiberSquarePush q₀₀ q₁₀ q₁₁ r)
          → right→leftCodeExtended q₀₀ q₁₁ r (fiber→ q₁₀ q₀₀ q₁₁ r p) ≡ ∣ q₁₀ , p ∣ₕ )
        , isOfHLevelΠ2 _ (λ x y → isOfHLevelTruncPath)))
      (λ (y₁ , q₁₁) → ∣fiber→←[q₀₀=q₁₀]∣ q₁₀ q₁₁)
      (λ (x₀ , q₀₀) → ∣fiber→←[q₁₁=q₁₀]∣ q₁₀ q₀₀)
      (∣fiber→←[q₀₀=q₁₀=q₁₁]∣ q₁₀)
      (_ , q₁₁') (_ , q₀₀')

  {- Definition of the other side homotopy -}

  module _
    {x₀ : X}{y₁ : Y}(q₀₁ : Q x₀ y₁) where

    {- (x₁ , q₁₁) = (x₀ , q₀₁) -}
    module _
      {y₀ : Y}(q₀₀ : Q x₀ y₀)
      (r : inl x₀ ≡ inr y₁)
      (p : push q₀₁ ≡ r) where

      ∣fiber←→[q₁₁=q₀₁]∣ : left→rightCodeExtended q₀₀ q₀₁ r (fiber← q₀₁ q₀₀ q₀₁ r p) ≡ ∣ q₀₁ , p ∣ₕ
      ∣fiber←→[q₁₁=q₀₁]∣ =
          (λ i → left→rightCodeExtended q₀₀ q₀₁ r (Fiber←.left q₀₁ (_ , q₀₀) i r p))
        ∙ recUniq {n = m + n} _ _ _
        ∙ (λ i → Fiber→.left q₀₀ (_ , q₀₁) i r (fiber←[q₁₁=q₀₁] q₀₁ q₀₀ r p .snd))
        ∙ (λ i → ∣ q₀₁ , fiber←→[q₁₁=q₀₁] q₀₁ q₀₀ r p i ∣ₕ)

    {- (y₀ , q₀₀) = (y₁ , q₀₁) -}
    module _
      {x₁ : X}(q₁₁ : Q x₁ y₁)
      (r : inl x₀ ≡ inr y₁)
      (p : push q₀₁ ≡ r) where

      ∣fiber←→[q₀₀=q₀₁]∣ : left→rightCodeExtended q₀₁ q₁₁ r (fiber← q₀₁ q₀₁ q₁₁ r p) ≡ ∣ q₀₁ , p ∣ₕ
      ∣fiber←→[q₀₀=q₀₁]∣  =
          (λ i → left→rightCodeExtended q₀₁ q₁₁ r (Fiber←.right q₀₁ (_ , q₁₁) i r p))
        ∙ recUniq {n = m + n} _ _ _
        ∙ (λ i → Fiber→.right q₁₁ (_ , q₀₁) i r (fiber←[q₀₀=q₀₁] q₀₁ q₁₁ r p .snd))
        ∙ (λ i → ∣ q₀₁ , fiber←→[q₀₀=q₀₁] q₀₁ q₁₁ r p i ∣ₕ)

    {- q₀₀ = q₀₁ = q₁₁ -}
    module _
      (r : inl x₀ ≡ inr y₁)
      (p : push q₀₁ ≡ r) where

      path←→Square =
           (λ i j → left→rightCodeExtended q₀₁ q₀₁ r (Fiber←.homSquare q₀₁ i j r p))
        ∙₂ (λ i → recUniq {n = m + n} _ _ _)
        ∙₂ (λ i j → Fiber→.homSquare q₀₁ i j r (fiber←[q₀₀=q₀₁=q₁₁] q₀₁ i r p .snd))
        ∙₂ (λ i j → ∣ q₀₁ , fiber←→hypercube q₀₁ r p i j ∣ₕ)

    ∣fiber←→[q₀₀=q₀₁=q₁₁]∣ : ∣fiber←→[q₁₁=q₀₁]∣ q₀₁ ≡ ∣fiber←→[q₀₀=q₀₁]∣ q₀₁
    ∣fiber←→[q₀₀=q₀₁=q₁₁]∣ i r p = path←→Square r p i

  fiber←→ :
      {x₀ : X}{y₁ : Y}(q₀₁ : Q x₀ y₁)
    → {y₀ : Y}(q₀₀ : Q x₀ y₀) → {x₁ : X}(q₁₁ : Q x₁ y₁)
    → (r : inl x₀ ≡ inr y₁)
    → (p : push q₀₁ ≡ r)
    → left→rightCodeExtended q₀₀ q₁₁ r (fiber← q₀₁ q₀₀ q₁₁ r p) ≡ ∣ q₀₁ , p ∣ₕ
  fiber←→ {x₀ = x₀} {y₁ = y₁} q₀₁ q₀₀' q₁₁' =
    WedgeConnectivity.extension m n
      (leftFiber  x₀ , (y₁ , q₀₁)) (leftConn  x₀)
      (rightFiber y₁ , (x₀ , q₀₁)) (rightConn y₁)
      (λ (y₀ , q₀₀) (x₁ , q₁₁) →
        ((  (r : inl x₀ ≡ inr y₁) → (p : push q₀₁ ≡ r)
          → left→rightCodeExtended q₀₀ q₁₁ r (fiber← q₀₁ q₀₀ q₁₁ r p) ≡ ∣ q₀₁ , p ∣ₕ )
        , isOfHLevelΠ2 _ (λ x y → isOfHLevelTruncPath)))
      (λ (y₀ , q₀₀) → ∣fiber←→[q₁₁=q₀₁]∣ q₀₁ q₀₀)
      (λ (x₁ , q₁₁) → ∣fiber←→[q₀₀=q₀₁]∣ q₀₁ q₁₁)
      (∣fiber←→[q₀₀=q₀₁=q₁₁]∣ q₀₁)
      (_ , q₀₀') (_ , q₁₁')

  module _
    {x₀ x₁ : X}{y₀ y₁ : Y}
    (q₀₀ : Q x₀ y₀)(q₁₁ : Q x₁ y₁)
    (r : inl x₀ ≡ inr y₁) where

    left→right→leftCodeExtended :
        (a : leftCodeExtended q₀₀ _ (push q₁₁) r)
      → right→leftCodeExtended q₀₀ q₁₁ r (left→rightCodeExtended q₀₀ q₁₁ r a) ≡ a
    left→right→leftCodeExtended a =
      sym (∘rec _ _ _ (right→leftCodeExtended q₀₀ q₁₁ r) a) ∙
      (λ i → recId _ (λ (q₁₀ , p) → fiber→← q₁₀ q₀₀ q₁₁ r p) i a)

    right→left→rightCodeExtended :
        (a : rightCode _ r)
      → left→rightCodeExtended q₀₀ q₁₁ r (right→leftCodeExtended q₀₀ q₁₁ r a) ≡ a
    right→left→rightCodeExtended a =
      sym (∘rec _ _ _ (left→rightCodeExtended q₀₀ q₁₁ r) a) ∙
      (λ i → recId _ (λ (q₀₁ , p) → fiber←→ q₀₁ q₀₀ q₁₁ r p) i a)

    left≃rightCodeExtended : leftCodeExtended q₀₀ _ (push q₁₁) r ≃ rightCode y₁ r
    left≃rightCodeExtended =
      isoToEquiv (iso (left→rightCodeExtended _ _ _) (right→leftCodeExtended _ _ _)
                       right→left→rightCodeExtended left→right→leftCodeExtended)

  {- Definition and properties of Code -}

  module _ (x₀ : X)(y₀ : Y)(q₀₀ : Q x₀ y₀) where

    leftCode' : (x : X){p : Pushout} → inl x ≡ p → inl x₀ ≡ p → Type ℓ
    leftCode' x r' = leftCodeExtended q₀₀ x r'

    leftCode : (x : X) → inl x₀ ≡ inl x → Type ℓ
    leftCode x = leftCode' x refl

    fiberPath : {x : X}{y : Y} → (q : Q x y) → leftCode' x (push q) ≡ rightCode y
    fiberPath q i r = ua (left≃rightCodeExtended q₀₀ q r) i

    pushCode :
        {x : X}{y : Y} → (q : Q x y)
      → PathP (λ i → inl x₀ ≡ push q i → Type ℓ) (leftCode x) (rightCode y)
    pushCode q i =
      hcomp (λ j → λ { (i = i0) → leftCode _
                     ; (i = i1) → fiberPath q j })
            (leftCode' _ (λ j → push q (i ∧ j)))

    Code : (p : Pushout) → inl x₀ ≡ p → Type ℓ
    Code (inl x) = leftCode  x
    Code (inr y) = rightCode y
    Code (push q i) = pushCode q i

    {- Transportation rule of pushCode -}

    transpLeftCode : (y : Y) → (q : Q x₀ y) → (q' : leftCodeExtended q₀₀ _ refl refl) → leftCode' _ (push q) (push q)
    transpLeftCode y q q' =
      transport (λ i → leftCode' _ (λ j → push q (i ∧ j)) (λ j → push q (i ∧ j))) q'

    transpPushCodeβ' :
        (y : Y) → (q : Q x₀ y) → (q' : leftCodeExtended q₀₀ _ refl refl)
      → transport (λ i → pushCode q i (λ j → push q (i ∧ j))) q' ≡ left→rightCodeExtended _ _ _ (transpLeftCode y q q')
    transpPushCodeβ' y q q' i = transportRefl (left→rightCodeExtended _ _ _ (transpLeftCode y q (transportRefl q' i))) i

    module _
      {p : Pushout}(r : inl x₀ ≡ p) where

      fiber-filler : I → Type ℓ
      fiber-filler i = fiber' q₀₀ (λ j → r (i ∧ j)) (λ j → r (i ∧ j))

      module _
        (q : fiberSquare q₀₀ q₀₀ refl refl) where

        transpLeftCode-filler : (i j k : I) → Pushout
        transpLeftCode-filler i j k' =
          hfill (λ k → λ { (i = i0) → push q₀₀ (~ j)
                         ; (i = i1) → r (j ∧ k)
                         ; (j = i0) → push q₀₀ (~ i)
                         ; (j = i1) → r (i ∧ k) })
                (inS (q i j)) k'

    transpLeftCodeβ' :
        {p : Pushout} → (r : inl x₀ ≡ p) → (q : fiberSquare q₀₀ q₀₀ refl refl)
      → transport (λ i → fiber-filler r i) (q₀₀ , q) ≡ (q₀₀ , λ i j → transpLeftCode-filler r q i j i1)
    transpLeftCodeβ' r q =
      J (λ p r → transport (λ i → fiber-filler r i) (q₀₀ , q) ≡ (q₀₀ , λ i j → transpLeftCode-filler r q i j i1))
        (transportRefl _ ∙ (λ k → (q₀₀ , λ i j → transpLeftCode-filler refl q i j k))) r

    transpLeftCodeβ :
        (y : Y) → (q : Q x₀ y) → (q' : fiberSquare q₀₀ q₀₀ refl refl)
      → transpLeftCode y q ∣ q₀₀ , q' ∣ₕ ≡ ∣ q₀₀ , (λ i j → transpLeftCode-filler (push q) q' i j i1) ∣ₕ
    transpLeftCodeβ y q q' = transportTrunc _ ∙ (λ i → ∣ transpLeftCodeβ' _ q' i ∣ₕ)

    transpPushCodeβ :
        (y : Y) → (q : Q x₀ y) → (q' : fiberSquare q₀₀ q₀₀ refl refl)
      →   transport (λ i → pushCode q i (λ j → push q (i ∧ j))) ∣ q₀₀ , q' ∣ₕ
        ≡ ∣fiber→[q₀₀=q₁₀]∣ q₀₀ q (push q) (λ i j → transpLeftCode-filler (push q) q' i j i1)
    transpPushCodeβ y q q' =
        transpPushCodeβ' _ _ _
      ∙ (λ i → left→rightCodeExtended _ _ _ (transpLeftCodeβ _ _ q' i))
      ∙ recUniq {n = m + n} _ _ _
      ∙ (λ i' → Fiber→.left q₀₀ (_ , q) i' (push q) (λ i j → transpLeftCode-filler (push q) q' i j i1))

    {- The contractibility of Code -}

    centerCode : {p : Pushout} → (r : inl x₀ ≡ p) → Code p r
    centerCode r =
      transport (λ i → Code _ (λ j → r (i ∧ j))) ∣ q₀₀ , (λ i j → push q₀₀ (~ i ∧ ~ j)) ∣ₕ

    module _
      (y : Y)(q : Q x₀ y) where

      transp-filler : (i j k : I) → Pushout
      transp-filler = transpLeftCode-filler (push q) (λ i' j' → push q₀₀ (~ i' ∧ ~ j'))

      transp-square : fiberSquare q₀₀ q₀₀ (push q) (push q)
      transp-square i j = transp-filler i j i1

      contractionCodeRefl' :
        fiber→[q₀₀=q₁₀] q₀₀ q (push q) transp-square .snd ≡ refl
      contractionCodeRefl' i j k =
        hcomp (λ l → λ { (i = i0) → fiber→[q₀₀=q₁₀]-filler q₀₀ q (push q) transp-square j k l
                       ; (i = i1) → transp-square (~ j ∨ l) k
                       ; (j = i0) → push q (k ∧ (i ∨ l))
                       ; (j = i1) → transp-square l k
                       ; (k = i0) → push q₀₀ (j ∧ ~ l)
                       ; (k = i1) → push q ((i ∧ ~ j) ∨ l) })
              (transp-filler (~ j) k i)

      contractionCodeRefl : centerCode (push q) ≡ ∣ q , refl ∣ₕ
      contractionCodeRefl = transpPushCodeβ _ _ _ ∙ (λ i → ∣ q , contractionCodeRefl' i ∣ₕ)

    module _
      (y : Y)(r : inl x₀ ≡ inr y) where

      contractionCode' : (a : fiber push r) → centerCode r ≡ ∣ a ∣ₕ
      contractionCode' (q , p') = J (λ r' p → centerCode r' ≡ ∣ q , p ∣ₕ) (contractionCodeRefl _ q) p'

      contractionCode : (a : Code _ r) → centerCode r ≡ a
      contractionCode = elim (λ _ → isOfHLevelTruncPath) contractionCode'

      isContrCode : isContr (Code _ r)
      isContrCode = centerCode r , contractionCode

  excision-helper :
      (x : X) → Trunc (1 + m) (Σ[ y₀ ∈ Y ] Q x y₀)
    → (y : Y) → (r : inl x ≡ inr y) → isContr (Trunc (m + n) (fiber push r))
  excision-helper x y' y r = rec (isProp→isOfHLevelSuc m isPropIsContr) (λ (y₀ , q₀₀) → isContrCode x y₀ q₀₀ y r ) y'

  {- The Main Result : Blakers-Massey Homotopy Excision Theorem -}
  Excision : (x : X)(y : Y) → isConnectedFun (m + n) (push {x = x} {y = y})
  Excision x y = excision-helper x (leftConn x .fst) y


module _ where

record Semiring (A : Set) : Set where
  infixl 6 _+_
  field _+_ : A → A → A

open Semiring {{...}} public

infix 4 _≡_

postulate
  Nat Bool  : Set
  _≡_   : Nat → Nat → Set
  refl  : ∀ {x} → x ≡ x
  to    : ∀ {x} (y : Nat) → x ≡ y
  trans : {x y z : Nat} → x ≡ y → y ≡ z → x ≡ z

  instance _ : Semiring Nat
           _ : Semiring Bool

bad : (a b c : Nat) → a + b ≡ c + a
bad a b c =
  trans (to (a + c)) refl

-- Should complain about a != c when checking refl, not a missing instance Semiring Nat.


import Structure.Logic.Classical.NaturalDeduction

module Structure.Logic.Classical.NaturalDeduction.Proofs {ℓₗ} {Formula} {ℓₘₗ} {Proof} {ℓₒ} {Domain} ⦃ classicLogic : _ ⦄ where
open Structure.Logic.Classical.NaturalDeduction.ClassicalLogic {ℓₗ} {Formula} {ℓₘₗ} {Proof} {ℓₒ} {Domain} (classicLogic)

open import Functional hiding (Domain)

-- TODO: Move the ones which are constructive

[↔]-with-[∧]ₗ : ∀{a₁ a₂ b} → Proof(a₁ ⟷ a₂) → Proof((a₁ ∧ b) ⟷ (a₂ ∧ b))
[↔]-with-[∧]ₗ (proof) =
  ([↔].intro
    (a₂b ↦ [∧].intro (([↔].elimₗ proof) ([∧].elimₗ a₂b)) ([∧].elimᵣ a₂b))
    (a₁b ↦ [∧].intro (([↔].elimᵣ proof) ([∧].elimₗ a₁b)) ([∧].elimᵣ a₁b))
  )

[↔]-with-[∧]ᵣ : ∀{a b₁ b₂} → Proof(b₁ ⟷ b₂) → Proof((a ∧ b₁) ⟷ (a ∧ b₂))
[↔]-with-[∧]ᵣ (proof) =
  ([↔].intro
    (ab₂ ↦ [∧].intro ([∧].elimₗ ab₂) (([↔].elimₗ proof) ([∧].elimᵣ ab₂)))
    (ab₁ ↦ [∧].intro ([∧].elimₗ ab₁) (([↔].elimᵣ proof) ([∧].elimᵣ ab₁)))
  )

[↔]-with-[∧] : ∀{a₁ a₂ b₁ b₂} → Proof(a₁ ⟷ a₂) → Proof(b₁ ⟷ b₂) → Proof((a₁ ∧ b₁) ⟷ (a₂ ∧ b₂))
[↔]-with-[∧] (a₁a₂) (b₁b₂) =
  ([↔].intro
    (a₂b₂ ↦ [∧].intro (([↔].elimₗ a₁a₂) ([∧].elimₗ a₂b₂)) (([↔].elimₗ b₁b₂) ([∧].elimᵣ a₂b₂)))
    (a₁b₁ ↦ [∧].intro (([↔].elimᵣ a₁a₂) ([∧].elimₗ a₁b₁)) (([↔].elimᵣ b₁b₂) ([∧].elimᵣ a₁b₁)))
  )

[↔]-with-[∨]ₗ : ∀{a₁ a₂ b} → Proof(a₁ ⟷ a₂) → Proof((a₁ ∨ b) ⟷ (a₂ ∨ b))
[↔]-with-[∨]ₗ (proof) =
  ([↔].intro
    ([∨].elim([∨].introₗ ∘ ([↔].elimₗ proof)) [∨].introᵣ)
    ([∨].elim([∨].introₗ ∘ ([↔].elimᵣ proof)) [∨].introᵣ)
  )

[↔]-with-[∨]ᵣ : ∀{a b₁ b₂} → Proof(b₁ ⟷ b₂) → Proof((a ∨ b₁) ⟷ (a ∨ b₂))
[↔]-with-[∨]ᵣ (proof) =
  ([↔].intro
    ([∨].elim [∨].introₗ ([∨].introᵣ ∘ ([↔].elimₗ proof)))
    ([∨].elim [∨].introₗ ([∨].introᵣ ∘ ([↔].elimᵣ proof)))
  )

[↔]-with-[∨] : ∀{a₁ a₂ b₁ b₂} → Proof(a₁ ⟷ a₂) → Proof(b₁ ⟷ b₂) → Proof((a₁ ∨ b₁) ⟷ (a₂ ∨ b₂))
[↔]-with-[∨] (a₁a₂) (b₁b₂) =
  ([↔].intro
    ([∨].elim ([∨].introₗ ∘ ([↔].elimₗ a₁a₂)) ([∨].introᵣ ∘ ([↔].elimₗ b₁b₂)))
    ([∨].elim ([∨].introₗ ∘ ([↔].elimᵣ a₁a₂)) ([∨].introᵣ ∘ ([↔].elimᵣ b₁b₂)))
  )

[↔]-with-[∀] : ∀{f g} → (∀{x} → Proof(f(x) ⟷ g(x))) → Proof((∀ₗ f) ⟷ (∀ₗ g))
[↔]-with-[∀] (proof) =
  ([↔].intro
    (allg ↦ [∀].intro(\{x} → [↔].elimₗ (proof{x}) ([∀].elim(allg){x})))
    (allf ↦ [∀].intro(\{x} → [↔].elimᵣ (proof{x}) ([∀].elim(allf){x})))
  )

[↔]-with-[∃] : ∀{f g} → (∀{x} → Proof(f(x) ⟷ g(x))) → Proof((∃ₗ f) ⟷ (∃ₗ g))
[↔]-with-[∃] (proof) =
  ([↔].intro
    ([∃].elim(\{x} → gx ↦ [∃].intro{_}{x}([↔].elimₗ (proof{x}) (gx))))
    ([∃].elim(\{x} → fx ↦ [∃].intro{_}{x}([↔].elimᵣ (proof{x}) (fx))))
  )

-- [→]-with-[∀] : ∀{p f g} → (∀{x} → Proof(f(x) ⟶ g(x))) → Proof((∀ₗ f) ⟶ (∀ₗ g))
-- [→]-with-[∀] (proof) =

-- [→]-with-[∀] : ∀{p f g} → (∀{x} → Proof(f(x) ⟶ g(x))) → Proof(∀ₗ(x ↦ p(x) ⟶ f(x))) → Proof(∀ₗ(x ↦ p(x) ⟶ g(x)))
-- [→]-with-[∀] (proof) =

[∨][∧]-distributivityₗ : ∀{a b c} → Proof((a ∨ (b ∧ c)) ⟷ (a ∨ b)∧(a ∨ c))
[∨][∧]-distributivityₗ =
  ([↔].intro
    (a∨b∧a∨c ↦
      ([∨].elim
        (a ↦ [∨].introₗ a)
        (b ↦
          ([∨].elim
            (a ↦ [∨].introₗ a)
            (c ↦ [∨].introᵣ([∧].intro b c))
            ([∧].elimᵣ a∨b∧a∨c)
          )
        )
        ([∧].elimₗ a∨b∧a∨c)
      )
    )

    (a∨b∧c ↦
      ([∨].elim
        (a   ↦ [∧].intro([∨].introₗ a)([∨].introₗ a))
        (b∧c ↦ [∧].intro([∨].introᵣ([∧].elimₗ b∧c))([∨].introᵣ([∧].elimᵣ b∧c)))
        (a∨b∧c)
      )
    )
  )

[∨][∧]-distributivityᵣ : ∀{a b c} → Proof(((a ∧ b) ∨ c) ⟷ (a ∨ c)∧(b ∨ c))
[∨][∧]-distributivityᵣ =
  ([↔].intro
    (a∨c∧b∨c ↦
      ([∨].elim
        (a ↦
          ([∨].elim
            (b ↦ [∨].introₗ([∧].intro a b))
            (c ↦ [∨].introᵣ c)
            ([∧].elimᵣ a∨c∧b∨c)
          )
        )
        (c ↦ [∨].introᵣ c)
        ([∧].elimₗ a∨c∧b∨c)
      )
    )

    (a∧b∨c ↦
      ([∨].elim
        (a∧b ↦ [∧].intro([∨].introₗ([∧].elimₗ a∧b))([∨].introₗ([∧].elimᵣ a∧b)))
        (c   ↦ [∧].intro([∨].introᵣ c)([∨].introᵣ c))
        (a∧b∨c)
      )
    )
  )

[∧][∨]-distributivityₗ : ∀{a b c} → Proof((a ∧ (b ∨ c)) ⟷ (a ∧ b)∨(a ∧ c))
[∧][∨]-distributivityₗ =
  ([↔].intro
    (a∧b∨a∧c ↦
      ([∨].elim
        (a∧b ↦ [∧].intro([∧].elimₗ a∧b)([∨].introₗ([∧].elimᵣ a∧b)))
        (a∧c ↦ [∧].intro([∧].elimₗ a∧c)([∨].introᵣ([∧].elimᵣ a∧c)))
        (a∧b∨a∧c)
      )
    )

    (a∧b∨c ↦
      ([∨].elim
        (b ↦ [∨].introₗ([∧].intro([∧].elimₗ a∧b∨c)(b)))
        (c ↦ [∨].introᵣ([∧].intro([∧].elimₗ a∧b∨c)(c)))
        ([∧].elimᵣ a∧b∨c)
      )
    )
  )

[∧][∨]-distributivityᵣ : ∀{a b c} → Proof(((a ∨ b) ∧ c) ⟷ (a ∧ c)∨(b ∧ c))
[∧][∨]-distributivityᵣ =
  ([↔].intro
    (a∧c∨b∧c ↦
      ([∨].elim
        (a∧c ↦ [∧].intro([∨].introₗ([∧].elimₗ a∧c))([∧].elimᵣ a∧c))
        (b∧c ↦ [∧].intro([∨].introᵣ([∧].elimₗ b∧c))([∧].elimᵣ b∧c))
        (a∧c∨b∧c)
      )
    )

    (a∨b∧c ↦
      ([∨].elim
        (a ↦ [∨].introₗ([∧].intro(a)([∧].elimᵣ a∨b∧c)))
        (b ↦ [∨].introᵣ([∧].intro(b)([∧].elimᵣ a∨b∧c)))
        ([∧].elimₗ a∨b∧c)
      )
    )
  )

postulate [≡]-substitute-this-is-almost-trivial : ∀{φ : Domain → Formula}{a b} → Proof(((a ≡ b) ∧ φ(a)) ⟷ φ(b))

postulate [→][∧]-distributivityₗ : ∀{X Y Z} → Proof((X ⟶ (Y ∧ Z)) ⟷ ((X ⟶ Y) ∧ (X ⟶ Z)))

postulate [∀]-unrelatedₗ-[→] : ∀{P : Domain → Formula}{Q : Formula} → Proof(∀ₗ(x ↦ (P(x) ⟶ Q)) ⟷ (∃ₗ(x ↦ P(x)) ⟶ Q))

postulate [∀]-unrelatedᵣ-[→] : ∀{P : Formula}{Q : Domain → Formula} → Proof(∀ₗ(x ↦ (P ⟶ Q(x))) ⟷ (P ⟶ ∀ₗ(x ↦ Q(x))))

postulate [∃]-unrelatedₗ-[→] : ∀{P : Domain → Formula}{Q : Formula} → Proof(∃ₗ(x ↦ (P(x) ⟶ Q)) ⟷ (∀ₗ(x ↦ P(x)) ⟶ Q))

postulate [∃]-unrelatedᵣ-[→] : ∀{P : Formula}{Q : Domain → Formula} → Proof(∃ₗ(x ↦ (P ⟶ Q(x))) ⟷ (P ⟶ ∃ₗ(x ↦ Q(x))))

-- TODO: Is equivalence unprovable? I think so
Unique-unrelatedᵣ-[→]ᵣ : ∀{P : Formula}{Q : Domain → Formula} → Proof(Unique(x ↦ (P ⟶ Q(x))) ⟶ (P ⟶ Unique(x ↦ Q(x))))
Unique-unrelatedᵣ-[→]ᵣ {P}{Q} =
  [→].intro(uniquepq ↦ [→].intro(p ↦ [∀].intro(\{x} → [∀].intro(\{y} → [→].intro(qxqy ↦
    ([→].elim
      ([∀].elim([∀].elim uniquepq{x}){y})
      (([↔].elimᵣ [→][∧]-distributivityₗ) ([→].intro(p ↦ qxqy)))
    )
  )))))
  -- Proving these equivalent:
  -- ∀ₗ(x ↦ ∀ₗ(y ↦ (P ⟶ Q(x)) ∧ (P ⟶ Q(y)) ⟶ (x ≡ y))
  -- P ⟶ ∀ₗ(x ↦ ∀ₗ(y ↦ Q(x) ∧ Q(y) ⟶ (x ≡ y))
    -- test : Proof(∀ₗ(x ↦ ∀ₗ(y ↦ (P ⟶ Q(x)) ∧ (P ⟶ Q(y)) ⟶ (x ≡ y))) ⟷ ∀ₗ(x ↦ ∀ₗ(y ↦ (P ⟶ Q(x) ∧ Q(y)) ⟶ (x ≡ y))))
    -- test = ([↔]-with-[∀] ([↔]-with-[∀] ([→][∧]-distributivityₗ)))

-- TODO: Is left provable? Above left seems unprovable
[∃!]-unrelatedᵣ-[→]ᵣ : ∀{P : Formula}{Q : Domain → Formula} → Proof(∃ₗ!(x ↦ (P ⟶ Q(x))) ⟶ (P ⟶ ∃ₗ!(x ↦ Q(x))))
[∃!]-unrelatedᵣ-[→]ᵣ {P}{Q} =
  ([→].intro(proof ↦
    ([↔].elimₗ [→][∧]-distributivityₗ)
    ([∧].intro
      (([↔].elimᵣ [∃]-unrelatedᵣ-[→])    ([∧].elimₗ proof))
      (([→].elim Unique-unrelatedᵣ-[→]ᵣ) ([∧].elimᵣ proof))
    )
  ))

-- TODO: I think this is similar to the skolemization process of going from ∀∃ to ∃function∀
[∃]-fn-witness : ∀{P : Domain → Domain → Formula} → ⦃ _ : Proof(∀ₗ(x ↦ ∃ₗ(y ↦ P(x)(y)))) ⦄ → Domain → Domain
[∃]-fn-witness{P} ⦃ proof ⦄ (x) = [∃]-witness ⦃ [∀].elim(proof){x} ⦄

[∃]-fn-proof : ∀{P : Domain → Domain → Formula} → ⦃ p : Proof(∀ₗ(x ↦ ∃ₗ(y ↦ P(x)(y)))) ⦄ → Proof(∀ₗ(x ↦ P(x)([∃]-fn-witness{P} ⦃ p ⦄ (x))))
[∃]-fn-proof{P} ⦃ proof ⦄ =
  ([∀].intro(\{x} →
    [∃]-proof {P(x)} ⦃ [∀].elim proof{x} ⦄
  ))

[∃!]-fn-witness : ∀{P : Domain → Domain → Formula} → ⦃ _ : Proof(∀ₗ(x ↦ ∃ₗ!(y ↦ P(x)(y)))) ⦄ → Domain → Domain
[∃!]-fn-witness{P} ⦃ proof ⦄ (x) = [∃!]-witness ⦃ [∀].elim(proof){x} ⦄

{-
[∃!]-fn-proof : ∀{P : Domain → Domain → Formula} → ⦃ p : Proof(∀ₗ(x ↦ ∃ₗ!(y ↦ P(x)(y)))) ⦄ → Proof(∀ₗ(x ↦ P(x)([∃!]-fn-witness{P} ⦃ p ⦄ (x))))
[∃!]-fn-proof{P} ⦃ proof ⦄ =
  ([∀].intro(\{x} →
    [∃!]-proof {P(x)} ⦃ [∀].elim proof{x} ⦄
  ))
-}

[∃!]-fn-proof : ∀{P : Domain → Domain → Formula} → ⦃ p : Proof(∀ₗ(x ↦ ∃ₗ!(y ↦ P(x)(y)))) ⦄ → ∀{x} → Proof(P(x)([∃!]-fn-witness{P} ⦃ p ⦄ (x)))
[∃!]-fn-proof{P} ⦃ proof ⦄ {x} =
  [∃!]-proof {P(x)} ⦃ [∀].elim proof{x} ⦄

postulate [∃!]-fn-unique : ∀{P : Domain → Domain → Formula} → ⦃ p : Proof(∀ₗ(x ↦ ∃ₗ!(y ↦ P(x)(y)))) ⦄ → ∀{x} → Proof(∀ₗ(y ↦ P(x)(y) ⟶ (y ≡ [∃!]-fn-witness{P} ⦃ p ⦄ (x))))


------------------------------------------------------------------------
-- The Agda standard library
--
-- Indexed applicative functors
------------------------------------------------------------------------

-- Note that currently the applicative functor laws are not included
-- here.

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

module Category.Applicative.Indexed where

open import Category.Functor using (RawFunctor)
open import Data.Product using (_×_; _,_)
open import Function
open import Level
open import Relation.Binary.PropositionalEquality as P using (_≡_)

IFun : ∀ {i} → Set i → (ℓ : Level) → Set _
IFun I ℓ = I → I → Set ℓ → Set ℓ

------------------------------------------------------------------------
-- Type, and usual combinators

record RawIApplicative {i f} {I : Set i} (F : IFun I f) :
                       Set (i ⊔ suc f) where
  infixl 4 _⊛_ _<⊛_ _⊛>_
  infix  4 _⊗_

  field
    pure : ∀ {i A} → A → F i i A
    _⊛_  : ∀ {i j k A B} → F i j (A → B) → F j k A → F i k B

  rawFunctor : ∀ {i j} → RawFunctor (F i j)
  rawFunctor = record
    { _<$>_ = λ g x → pure g ⊛ x
    }

  private
    open module RF {i j : I} =
           RawFunctor (rawFunctor {i = i} {j = j})
           public

  _<⊛_ : ∀ {i j k A B} → F i j A → F j k B → F i k A
  x <⊛ y = const <$> x ⊛ y

  _⊛>_ : ∀ {i j k A B} → F i j A → F j k B → F i k B
  x ⊛> y = flip const <$> x ⊛ y

  _⊗_ : ∀ {i j k A B} → F i j A → F j k B → F i k (A × B)
  x ⊗ y = (_,_) <$> x ⊛ y

  zipWith : ∀ {i j k A B C} → (A → B → C) → F i j A → F j k B → F i k C
  zipWith f x y = f <$> x ⊛ y

  zip : ∀ {i j k A B} → F i j A → F j k B → F i k (A × B)
  zip = zipWith _,_

------------------------------------------------------------------------
-- Applicative with a zero

record RawIApplicativeZero
       {i f} {I : Set i} (F : IFun I f) :
       Set (i ⊔ suc f) where
  field
    applicative : RawIApplicative F
    ∅           : ∀ {i j A} → F i j A

  open RawIApplicative applicative public

------------------------------------------------------------------------
-- Alternative functors: `F i j A` is a monoid

record RawIAlternative
       {i f} {I : Set i} (F : IFun I f) :
       Set (i ⊔ suc f) where
  infixr 3 _∣_
  field
    applicativeZero : RawIApplicativeZero F
    _∣_             : ∀ {i j A} → F i j A → F i j A → F i j A

  open RawIApplicativeZero applicativeZero public

------------------------------------------------------------------------
-- Applicative functor morphisms, specialised to propositional
-- equality.

record Morphism {i f} {I : Set i} {F₁ F₂ : IFun I f}
                (A₁ : RawIApplicative F₁)
                (A₂ : RawIApplicative F₂) : Set (i ⊔ suc f) where
  module A₁ = RawIApplicative A₁
  module A₂ = RawIApplicative A₂
  field
    op      : ∀ {i j X} → F₁ i j X → F₂ i j X
    op-pure : ∀ {i X} (x : X) → op (A₁.pure {i = i} x) ≡ A₂.pure x
    op-⊛    : ∀ {i j k X Y} (f : F₁ i j (X → Y)) (x : F₁ j k X) →
              op (f A₁.⊛ x) ≡ (op f A₂.⊛ op x)

  op-<$> : ∀ {i j X Y} (f : X → Y) (x : F₁ i j X) →
           op (f A₁.<$> x) ≡ (f A₂.<$> op x)
  op-<$> f x = begin
    op (A₁._⊛_ (A₁.pure f) x)       ≡⟨ op-⊛ _ _ ⟩
    A₂._⊛_ (op (A₁.pure f)) (op x)  ≡⟨ P.cong₂ A₂._⊛_ (op-pure _) P.refl ⟩
    A₂._⊛_ (A₂.pure f) (op x)       ∎
    where open P.≡-Reasoning


-- A Simple selection of modules with some renamings to
-- make my (your) life easier when starting a new agda module.
--
-- This includes standard functionality to work on:
--  1. Functions,
--  2. Naturals,
--  3. Products and Coproducts (projections and injections are p1, p2, i1, i2).
--  4. Finite Types (zero and suc are fz and fs)
--  5. Lists
--  6. Booleans and PropositionalEquality
--  7. Decidable Predicates
--
module Prelude where

  open import Data.Unit.NonEta
    using (Unit; unit)
    public

  open import Data.Empty
    using (⊥; ⊥-elim)
    public

  open import Function
    using (_∘_; _$_; flip; id; const; _on_)
    public

  open import Data.Nat
    using (ℕ; suc; zero; _+_; _*_; _∸_)
    renaming (_≟_ to _≟-ℕ_; _≤?_ to _≤?-ℕ_)
    public

  open import Data.Fin
    using (Fin; fromℕ; fromℕ≤; toℕ)
    renaming (zero to fz; suc to fs)
    public

  open import Data.Fin.Properties
    using ()
    renaming (_≟_ to _≟-Fin_)
    public

  open import Data.List
    using (List; _∷_; []; map; _++_; zip; filter;
           all; any; concat; foldr; reverse; length)
    public

  open import Data.Product
    using (∃; Σ; _×_; _,_; uncurry; curry)
    renaming (proj₁ to p1; proj₂ to p2
           ; <_,_> to split)
    public

  open import Data.Sum
    using (_⊎_; [_,_]′)
    renaming (inj₁ to i1; inj₂ to i2
           ; [_,_] to either)
    public

  open import Data.Bool
    using (Bool; true; false; if_then_else_; not)
    renaming (_∧_ to _and_; _∨_ to _or_)
    public

  open import Relation.Nullary
    using (Dec; yes; no; ¬_)
    public

  open import Relation.Binary.PropositionalEquality
    using (_≡_; refl; sym; trans; cong; cong₂; subst)
    public

  open import Data.Maybe
    using (Maybe; just; nothing)
    renaming (maybe′ to maybe)
    public

  dec-elim : ∀{a b}{A : Set a}{B : Set b}
           → (A → B) → (¬ A → B) → Dec A → B
  dec-elim f g (yes p) = f p
  dec-elim f g (no  p) = g p

  dec2set : ∀{a}{A : Set a} → Dec A → Set
  dec2set (yes _) = Unit
  dec2set (no  _) = ⊥

  isTrue : ∀{a}{A : Set a} → Dec A → Bool
  isTrue (yes _) = true
  isTrue _       = false

  takeWhile : ∀{a}{A : Set a} → (A → Bool) → List A → List A
  takeWhile _ [] = []
  takeWhile f (x ∷ xs) with f x
  ...| true = x ∷ takeWhile f xs
  ...| _    = takeWhile f xs

  -- Some minor boilerplate to solve equality problem...
  record Eq (A : Set) : Set where
    constructor eq
    field cmp : (x y : A) → Dec (x ≡ y)

  open Eq {{...}}

  record Enum (A : Set) : Set where
    constructor enum
    field
      toEnum   : A → Maybe ℕ
      fromEnum : ℕ → Maybe A

  open Enum {{...}}

  instance
    eq-ℕ : Eq ℕ
    eq-ℕ = eq _≟-ℕ_

    enum-ℕ : Enum ℕ
    enum-ℕ = enum just just

    eq-Fin : ∀{n} → Eq (Fin n)
    eq-Fin = eq _≟-Fin_

    enum-Fin : ∀{n} → Enum (Fin n)
    enum-Fin {n} = enum (λ x → just (toℕ x)) fromℕ-partial
      where
        fromℕ-partial : ℕ → Maybe (Fin n)
        fromℕ-partial m with suc m ≤?-ℕ n
        ...| yes prf = just (fromℕ≤ {m} {n} prf)
        ...| no  _   = nothing

    eq-⊥ : Eq ⊥
    eq-⊥ = eq (λ x → ⊥-elim x)

    enum-⊥ : Enum ⊥
    enum-⊥ = enum ⊥-elim (const nothing)

    eq-Maybe : ∀{A} ⦃ eqA : Eq A ⦄ → Eq (Maybe A)
    eq-Maybe = eq decide
      where
        just-inj : ∀{a}{A : Set a}{x y : A}
                 → _≡_ {a} {Maybe A} (just x) (just y) → x ≡ y
        just-inj refl = refl

        decide : {A : Set} ⦃ eqA : Eq A ⦄
               → (x y : Maybe A) → Dec (x ≡ y)
        decide nothing nothing   = yes refl
        decide nothing (just _)  = no (λ ())
        decide (just _) nothing  = no (λ ())
        decide ⦃ eq f ⦄ (just x) (just y) with f x y
        ...| yes x≡y = yes (cong just x≡y)
        ...| no  x≢y = no (x≢y ∘ just-inj)

    enum-Maybe : ∀{A} ⦃ enA : Enum A ⦄ → Enum (Maybe A)
    enum-Maybe ⦃ enum aℕ ℕa ⦄ = enum (maybe aℕ nothing) (just ∘ ℕa)

    eq-List : {A : Set}{{eq : Eq A}} → Eq (List A)
    eq-List {A} {{eq _≟_}} = eq decide
      where
        open import Data.List.Properties
          renaming (∷-injective to ∷-inj)

        decide : (a b : List A) → Dec (a ≡ b)
        decide [] (_ ∷ _) = no (λ ())
        decide (_ ∷ _) [] = no (λ ())
        decide []   []    = yes refl
        decide (a ∷ as) (b ∷ bs)
          with a ≟ b | decide as bs
        ...| yes a≡b | yes as≡bs
          rewrite a≡b = yes (cong (_∷_ b) as≡bs)
        ...| no  a≢b | yes as≡bs = no (a≢b ∘ p1 ∘ ∷-inj)
        ...| yes a≡b | no  as≢bs = no (as≢bs ∘ p2 ∘ ∷-inj)
        ...| no  a≢b | no  as≢bs = no (a≢b ∘ p1 ∘ ∷-inj)


module Scratch.FinDecEq1 where

open import Data.Bool.Base hiding (_≤_)
open import Data.Product
open import Data.Sum
open import Level renaming (suc to lsuc; _⊔_ to _⊔ℓ_; zero to lzero)

open import Relation.Nullary
open import Relation.Nullary.Decidable

open import Relation.Unary using (Decidable)
open import Relation.Binary hiding (Decidable)

open import Function.Base
-- open import Function.Bijection hiding (_∘_)
-- open import Function.Equality hiding (≡-setoid; _∘_)

open import Data.Nat.Base hiding (_≤_)
open import Data.Fin renaming (zero to fzero; suc to fsuc)
open import Data.Fin.Properties hiding (to-from)
-- see http://firsov.ee/finset/finset.pdf

open import Data.List.Base renaming (tabulate to tab;
                                     lookup to nth;
                                     filter to lfilter;
                                     allFin to allF)
open import Data.List.Properties
open import Data.List.Relation.Unary.Any
-- open import Data.List.Membership.Propositional renaming (_∈_ to _∈ℓ_)
-- open import Data.List.Membership.Propositional.Properties
open import Data.List.Relation.Unary.Any as Any -- hiding (tail)
open import Data.List.Relation.Unary.Any.Properties hiding (tabulate⁺)
open import Data.List.Relation.Unary.All as All hiding (tabulate)
open import Data.List.Relation.Unary.AllPairs as AllPairs
open import Data.List.Relation.Unary.AllPairs.Properties renaming (map⁺ to ap-map⁺)

-- :-( can't use Vector because it doesn't have a filter
-- open import Data.Vec.Functional as Coll
-- open import Data.Vec.Functional.Relation.Unary.Any
--   renaming (here to here'; there to there')

open import Relation.Binary.PropositionalEquality as Eq
open Eq.≡-Reasoning

open import Scratch.Data.List.Relation.Helpers
open import Scratch.Subset

-- record StronglyFiniteSetoid (n : ℕ) : Set (lsuc (c ⊔ℓ ℓ)) where
--   field
--     S : Setoid c ℓ
--     χ : Bijection (≡-setoid n) S
--
--   open Setoid S
--   open Bijection χ
--   open Π to renaming (_⟨$⟩_ to to')
--   open Π from renaming (_⟨$⟩_ to from')
--
--   ι : Fin n → Carrier
--   ι x = to' x
--
--   ρ : Carrier → Fin n
--   ρ y = from' y

  -- TODO: pullback of ω where ω ≤ _≈_ (see orbital relation)
  -- /Users/amantini/dev/agda/agda-stdlib/README/Data/Interleaving.agda
  -- if ω is decidable then the pullback is a FinDecEq

open import Data.Vec hiding (length)
                     renaming (lookup to vlookup)
open import Data.Vec.Properties
-- open import Data.Vec.Relation.Unary.Any
open import Data.Fin.Subset
open import Data.Fin.Subset.Properties

lmap = Data.List.Base.map
syntax lmap (λ x → B) L = ⟦ B ∣ x ∈ℓ L ⟧

fsuc∈ : ∀ {n} → { p : Subset n} → {x : Fin n} → {s : Side} → (x ∈ p) → (fsuc x) ∈ (s Data.Vec.∷ p)
fsuc∈ here = there here
fsuc∈ (there x∈p) = there (fsuc∈ x∈p)

fst₊ : ∀ {n} → (s : Subset n) → Nonempty s → Σ (Fin n) (λ x → ( x ∈ s × (∀ {y} → (y ∈ s) → x ≤ y )))
fst₊ {suc n} (inside ∷ rest) ne = ( fzero , here , λ _ → z≤n )
fst₊ {suc n} (outside ∷ rest) ne with (∃-toSum ne)
... | inj₂ b = let w = drop-there (proj₂ b)
                   z = (proj₁ b , w)
                   ( a , bb , c ) = (fst₊ rest z)
               in (fsuc a , fsuc∈ bb , λ { (there y∈s) → s≤s (c y∈s) } )

fst₋ : ∀ {n} → (s : Subset n) → Nonempty s → Fin n
fst₋ s ne = proj₁ (fst₊ s ne)

fst₋unique : ∀ {n} → ∀ (s t : Subset n) → (ns : Nonempty s) → (nt : Nonempty t) →
             s ≡ t → (fst₋ s ns) ≡ (fst₋ t nt)

fst₋unique s t ns nt s≡t = let fs , fs∈s , fs≤ = (fst₊ s ns)
                               ft , ft∈t , ft≤ = (fst₊ t nt)
                               ft∈s : ft ∈ s
                               ft∈s = subst _ (sym s≡t) ft∈t
                               fs∈t : fs ∈ t
                               fs∈t = subst _ s≡t fs∈s
                           in ≤-antisym (fs≤ ft∈s) (ft≤ fs∈t)

open import Data.Unit hiding (_≟_; ⊤)
-- TODO: see src/Data/List/Membership/Setoid.agda
--       see src/Relation/Nullary/Decidable.agda

≡→T : ∀ {b : Bool} → b ≡ true → T b
≡→T refl  =  tt

record FinDecEq {a} (n : ℕ) : Set (lsuc a) where
  field
    _ω_ : Rel (Fin n) a
    isDecEq : IsDecEquivalence _ω_

  std : DecSetoid _ _
  std = record { Carrier = (Fin n) ;
                _≈_ = _ω_ ;
                isDecEquivalence = isDecEq }

  open DecSetoid std
    renaming (_≟_ to _ω?_ ;
              refl to r ;
              sym to s ;
              trans to t ;
              Carrier to F;
              setoid to std')
    public

  import Data.List.Membership.Propositional
  module MP = Data.List.Membership.Propositional {A = F}
  open MP renaming (_∈_ to _∈ℓ_)
  -- open import Data.List.Membership.Propositional renaming (_∈_ to _∈ℓ_)
  open import Data.List.Membership.Propositional.Properties

  [_]ω : (Fin n) → Subset n
  [ o ]ω = tabulate (does ∘ (_ω? o))
  -- TODO: use src/Data/List/Membership/Setoid.agda
  --       and src/Data/Fin/Subset/Properties.agda

  ω⇒∈ : ∀ {x y} → x ω y → x ∈ [ y ]ω
  ω⇒∈ {x} {y} xωy = let lkp = begin vlookup [ y ]ω x ≡⟨ lookup∘tabulate _ x ⟩
                               does (x ω? y) ≡⟨ dec-true (x ω? y) xωy ⟩
                               true ∎
               in lookup⇒[]= x [ y ]ω lkp

  -- in particular classes are not empty
  o∈[o]ω : ∀ { o : Fin n } → o ∈ [ o ]ω
  o∈[o]ω = ω⇒∈ r

  -- and actually equal

  -- conversely
  ∈⇒ω : ∀ {x y} → x ∈ [ y ]ω → x ω y
  ∈⇒ω {x} {y} x∈[y] = let w = begin true ≡˘⟨ []=⇒lookup x∈[y] ⟩
                              vlookup [ y ]ω x ≡⟨ lookup∘tabulate _ x ⟩
                              does (x ω? y) ≡˘⟨ isYes≗does _ ⟩
                              isYes (x ω? y) ∎
                          r : True (x ω? y)
                          r = ≡→T (sym w)
                        in toWitness r

  ω⇒⊆ : ∀ {x y} → x ω y → [ x ]ω ⊆ [ y ]ω
  ω⇒⊆ {x} {y} xωy {s} s∈[x] = ω⇒∈ (t (∈⇒ω s∈[x]) xωy )

  ω⇒≡ : ∀ {x y} → x ω y → [ x ]ω ≡ [ y ]ω
  ω⇒≡ {x} {y} xωy = ⊆-antisym (ω⇒⊆ xωy) (ω⇒⊆ (s xωy))

  -- canonical choice - TODO
  c : F → F
  c f = fst₋ {n} [ f ]ω ( f , o∈[o]ω )

  --
  cx∈[x] : ∀ (x : Fin n) → (c x) ∈ [ x ]ω
  cx∈[x] x = proj₁ (proj₂ (fst₊ [ x ]ω ( x , o∈[o]ω )))

  xωcx : ∀ (x : F) → x ω (c x)
  xωcx x = s (∈⇒ω (cx∈[x] x))
  --
  c⇒ω : ∀ {x y} → c x ≡ c y → x ω y
  c⇒ω {x} {y} cx≡cy = let P = λ q → q ∈ [ y ]ω
                          w : (c x) ∈ [ y ]ω
                          w = subst P (sym cx≡cy) (cx∈[x] y)
                      in t (xωcx x) (∈⇒ω w)
  --
  ω⇒c : ∀ {x y} → x ω y → c x ≡ c y
  ω⇒c {x} {y} xωy = fst₋unique _ _ _ _ (ω⇒≡ xωy)

  c-idempt : (x : F) → c (c x) ≡ c x
  c-idempt x = ω⇒c {c x} {x} (s (xωcx x))

  ω-disj : ∀ {x y} → ¬ (x ω y) → Empty ([ x ]ω ∩ [ y ]ω)
  ω-disj {x} {y} ¬xωy f∈∩ = let f , [x]∩[y] = f∈∩
                                l , r = x∈p∩q⁻ _ _ [x]∩[y]
                                fωx : f ω x
                                fωx = ∈⇒ω l
                                fωy = ∈⇒ω r
                            in ¬xωy (t (s fωx) fωy)

  ω-Disj : ∀ {x y} → ¬ (x ω y) → Disj [ x ]ω [ y ]ω
  ω-Disj ¬xωy = Empty-unique (ω-disj ¬xωy)

  -- canonical representative
  cr : (i : F) → Set
  cr i = i ≡ (c i)

  -- c' : (i : F) → cr i × i ω (c i)
  -- _≟_
  cr? : Decidable cr
  cr? = λ i → i ≟ (c i)

  cr-disj : ∀ {x y} → (cr x) → (cr y) → x ≢ y → ¬ (x ω y)
  cr-disj {x} {y} crx cry x≢y xωy = let x≡y = begin x ≡⟨ crx ⟩
                                                c x ≡⟨ ω⇒c xωy ⟩
                                                c y ≡˘⟨ cry ⟩
                                                y ∎
                                    in x≢y x≡y

  Tr : List F
  Tr = (lfilter cr? (allF n))

  -- ∈-filter⁻ : ∀ {v xs} → v ∈ filter P? xs → v ∈ xs × P v

  -- C : List (Subset n)
  -- C = ⟦ [ x ]ω ∣ x ∈ℓ Tr ⟧

  --  ap x≢y allF
  --  ap ¬ x ω y Tr
  --  ap Disj (map [_] Tr)

  ap1 : AllPairs _≢_ (allF n)
  ap1 = tabulate⁺ id
  ap2 : AllPairs (λ x y → ¬ x ω y) Tr
  ap2 = filter⁺⁺ cr? cr-disj ap1

  ap3 : AllPairs Disj ⟦ [ x ]ω ∣ x ∈ℓ Tr ⟧
  ap3 = ap-map⁺ (AllPairs.map ω-Disj ap2)

  C-cover' : ∀ (x : F) → (∃ λ k → cr k × x ω k)
  C-cover' x = (c x) , sym (c-idempt x) , xωcx x

  C-cover : ∀ (x : F) → Any (x ∈_) ⟦ [ x ]ω ∣ x ∈ℓ Tr ⟧
  C-cover x = let (k , crk , xωk) = C-cover' x
                  k∈ℓallF : k ∈ℓ allF n
                  k∈ℓallF = ∈-allFin {n} k
                  k∈ℓTr : k ∈ℓ Tr
                  k∈ℓTr = ∈-filter⁺ cr? k∈ℓallF crk
                  a : Any (x ω_) Tr
                  a = lose k∈ℓTr xωk
                  b : Any ((x ∈_) ∘ [_]ω) Tr
                  b = Any.map ω⇒∈ a
              -- map⁺ : Any (P ∘ f) xs → Any P (List.map f xs)
              in map⁺ b

  --
  []ω-cover : ⊤ ≡ ⋃ ⟦ [ x ]ω ∣ x ∈ℓ Tr ⟧
  []ω-cover = cover-⊤ ⟦ [ x ]ω ∣ x ∈ℓ Tr ⟧ C-cover

  -- Cardinality : n ≡ Data.List.Base.sum ⟦ ∣ [ x ]ω ∣ ∣ x ∈ℓ Tr ⟧
  -- Cardinality =
  --   let c = ∣⋃ᵢpᵢ∣≡Σᵢ∣pᵢ∣ ⟦ [ x ]ω ∣ x ∈ℓ Tr ⟧ ap3
  --       in begin
  --           n ≡˘⟨ ∣⊤∣≡n n ⟩
  --           ∣ ⊤ {n} ∣ ≡⟨ cong ∣_∣ []ω-cover ⟩
  --           ∣ ⋃ ⟦ [ x ]ω ∣ x ∈ℓ Tr ⟧ ∣ ≡⟨ c ⟩
  --           -- cong List.sum (map-compose λ t → ∣ [ t ]ω ∣ ) refl
  --           Data.List.Base.sum (lmap ∣_∣ ⟦ [ x ]ω ∣ x ∈ℓ Tr ⟧) ≡˘⟨ ? ⟩
  --           Data.List.Base.sum ⟦ ∣ [ x ]ω ∣ ∣ x ∈ℓ Tr ⟧ ∎


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

open import Boolean.Definition
open import Sets.FinSet.Definition
open import LogicalFormulae
open import Groups.Abelian.Definition
open import Groups.Vector
open import Groups.Definition
open import Groups.Abelian.Definition
open import Numbers.Integers.Integers
open import Setoids.Setoids
open import Sets.EquivalenceRelations
open import Modules.Definition
open import Groups.Cyclic.Definition
open import Groups.Cyclic.DefinitionLemmas
open import Rings.Polynomial.Multiplication
open import Rings.Polynomial.Ring
open import Rings.Definition
open import Rings.Lemmas
open import Groups.Polynomials.Definition
open import Numbers.Naturals.Semiring
open import Vectors
open import Modules.Span
open import Numbers.Integers.Definition
open import Numbers.Integers.Addition
open import Rings.IntegralDomains.Definition
open import Numbers.Naturals.Order
open import Numbers.Modulo.Definition
open import Numbers.Modulo.Group

module Modules.Examples where

abGrpModule : {a b : _} {A : Set a} {S : Setoid {a} {b} A} {_+_ : A → A → A} {G' : Group S _+_} (G : AbelianGroup G') → Module ℤRing G (λ x i → elementPower G' i x)
Module.dotWellDefined (abGrpModule {S = S} {G' = G'} G) {m} {n} {g} {h} m=n g=h = transitive (elementPowerWellDefinedG G' g h g=h {m}) (elementPowerWellDefinedZ' G' m n m=n {h})
  where
    open Setoid S
    open Equivalence eq
Module.dotDistributesLeft (abGrpModule {G' = G'} G) {n} {x} {y} = elementPowerHomAbelian G' (AbelianGroup.commutative G) x y n
Module.dotDistributesRight (abGrpModule {S = S} {G' = G'} G) {r} {s} {x} = symmetric (elementPowerCollapse G' x r s)
  where
    open Equivalence (Setoid.eq S)
Module.dotAssociative (abGrpModule {G' = G'} G) {r} {s} {x} = elementPowerMultiplies G' r s x
Module.dotIdentity (abGrpModule {G' = G'} G) = Group.identRight G'

zAndZ : Module ℤRing ℤAbGrp _*Z_
Module.dotWellDefined zAndZ refl refl = refl
Module.dotDistributesLeft zAndZ = Ring.*DistributesOver+ ℤRing
Module.dotDistributesRight zAndZ {x} {y} {z} = Ring.*DistributesOver+' ℤRing {x} {y} {z}
Module.dotAssociative zAndZ {x} {y} {z} = equalityCommutative (Ring.*Associative ℤRing {x} {y} {z})
Module.dotIdentity zAndZ = Ring.identIsIdent ℤRing

twoOrAnother : ℤ → Bool → ℤ
twoOrAnother _ BoolTrue = nonneg 2
twoOrAnother n BoolFalse = n

23Spans : Spans zAndZ (twoOrAnother (nonneg 3))
23Spans m = 2 , (((BoolTrue ,- (BoolFalse ,- [])) ,, (Group.inverse ℤGroup m ,- (m ,- []))) , t m)
  where
    open Group ℤGroup
    open Ring ℤRing
    t : (m : ℤ) → inverse m *Z nonneg 2 +Z (m *Z nonneg 3 +Z nonneg 0) ≡ m
    t m rewrite identRight {m *Z nonneg 3} | *DistributesOver+ {m} {nonneg 2} {nonneg 1} | +Associative {inverse m *Z nonneg 2} {m *Z nonneg 2} {m *Z nonneg 1} = transitivity (transitivity (+WellDefined {inverse m *Z nonneg 2 +Z m *Z nonneg 2} {m *Z nonneg 1} {nonneg 0} {_} (transitivity (equalityCommutative (*DistributesOver+' {inverse m} {m} {nonneg 2})) (*WellDefined (invLeft {m}) refl)) refl) *Commutative) identIsIdent

evenNotOdd : (i : ℤ) → nonneg 0 ≡ i *Z nonneg 2 +Z nonneg 1 → False
evenNotOdd (nonneg x) pr rewrite equalityCommutative (+Zinherits (x *N 2) 1) = evenNotOdd' x (nonnegInjective pr)
  where
    evenNotOdd' : (i : ℕ) → 0 ≡ i *N 2 +N 1 → False
    evenNotOdd' zero ()
    evenNotOdd' (succ i) ()
evenNotOdd (negSucc zero) ()
evenNotOdd (negSucc (succ zero)) ()
evenNotOdd (negSucc (succ (succ x))) ()

2NotSpan : Spans zAndZ {_} {True} (λ _ → nonneg 2) → False
2NotSpan f with f (nonneg 1)
2NotSpan f | n , (trues , b) = bad (_&&_.fst trues) (_&&_.snd trues) (nonneg 0) b
  where
    open Group ℤGroup
    open Ring ℤRing
    bad : {n : ℕ} → (t : Vec True n) (u : Vec ℤ n) (i : ℤ) → dot zAndZ (vecMap (λ _ → nonneg 2) t) u ≡ ((i *Z nonneg 2) +Z nonneg 1) → False
    bad [] [] i x = evenNotOdd i x
    bad (record {} ,- t) (u ,- us) i x = bad t us (i +Z inverse u) (transitivity (+WellDefined (equalityCommutative (invLeft {u *Z nonneg 2})) refl) (transitivity (equalityCommutative (+Associative {inverse (u *Z nonneg 2)} {u *Z nonneg 2})) (transitivity (+WellDefined (refl {x = inverse (u *Z nonneg 2)}) x) (transitivity (+Associative {inverse (u *Z nonneg 2)} {i *Z nonneg 2}) (+WellDefined {inverse (u *Z nonneg 2) +Z i *Z nonneg 2} {_} {(i +Z inverse u) *Z nonneg 2} (transitivity (transitivity (groupIsAbelian {inverse (u *Z nonneg 2)}) (applyEquality (i *Z nonneg 2 +Z_) (equalityCommutative (ringMinusExtracts' ℤRing)))) (equalityCommutative (*DistributesOver+' {i} {inverse u} {nonneg 2}))) (refl {x = nonneg 1}))))))

3NotSpan : Spans zAndZ {_} {True} (λ _ → nonneg 3) → False
3NotSpan f with f (nonneg 1)
... | n , ((trues ,, coeffs) , b) = bad trues coeffs (nonneg 0) b
  where
    open Group ℤGroup
    open Ring ℤRing
    bad : {n : ℕ} → (t : Vec True n) (u : Vec ℤ n) (i : ℤ) → dot zAndZ (vecMap (λ _ → nonneg 3) t) u ≡ ((i *Z nonneg 3) +Z nonneg 1) → False
    bad [] [] (nonneg zero) ()
    bad [] [] (nonneg (succ i)) ()
    bad [] [] (negSucc zero) ()
    bad [] [] (negSucc (succ i)) ()
    bad (record {} ,- ts) (u ,- us) i x = bad ts us (i +Z inverse u) (transitivity (+WellDefined (equalityCommutative (invLeft {u *Z nonneg 3})) (refl {x = dot zAndZ (vecMap (λ _ → nonneg 3) ts) us})) (transitivity (equalityCommutative (+Associative {inverse (u *Z nonneg 3)} {u *Z nonneg 3})) (transitivity (+WellDefined (equalityCommutative (ringMinusExtracts' ℤRing {u} {nonneg 3})) x) (transitivity (+Associative {inverse u *Z nonneg 3} {i *Z nonneg 3} {nonneg 1}) (+WellDefined (transitivity {x = (inverse u *Z nonneg 3 +Z i *Z nonneg 3)} (equalityCommutative (*DistributesOver+' {inverse u} {i})) (*WellDefined (groupIsAbelian {inverse u} {i}) (refl {x = nonneg 3}))) (refl {x = nonneg 1}))))))

nothingNotSpan : Spans zAndZ {_} {False} (λ ()) → False
nothingNotSpan f with f (nonneg 1)
nothingNotSpan f | zero , (([] ,, []) , ())
nothingNotSpan f | succ n , (((() ,- fst) ,, snd) , b)

1Basis : Basis zAndZ {_} {True} (λ _ → nonneg 1)
_&&_.fst 1Basis m = 1 , (((record {} ,- []) ,, (m ,- [])) , transitivity (Group.+WellDefined ℤGroup (transitivity (Ring.*Commutative ℤRing {m}) (Ring.identIsIdent ℤRing)) refl) (Group.identRight ℤGroup))
_&&_.snd 1Basis {zero} r x [] x₁ = record {}
_&&_.snd 1Basis {succ zero} (record {} ,- []) x (b ,- []) pr = equalityCommutative (transitivity (equalityCommutative (transitivity (Group.+WellDefined ℤGroup (transitivity (Ring.*Commutative ℤRing {b}) (Ring.identIsIdent ℤRing)) refl) (Group.identRight ℤGroup))) pr) ,, record {}
_&&_.snd 1Basis {succ (succ n)} (record {} ,- (record {} ,- r)) x b pr with x {0} {1} (succIsPositive _) (succPreservesInequality (succIsPositive _)) refl
_&&_.snd 1Basis {succ (succ n)} (record {} ,- (record {} ,- r)) x b pr | ()

2Independent : Independent zAndZ {_} {True} (λ _ → nonneg 2)
2Independent {zero} r x [] x₁ = record {}
2Independent {succ zero} (record {} ,- []) x (coeff ,- []) pr rewrite Group.identRight ℤGroup {coeff *Z nonneg 2} = equalityCommutative (IntegralDomain.intDom ℤIntDom (transitivity (Ring.*Commutative ℤRing) pr) λ ()) ,, record {}
2Independent {succ (succ n)} (record {} ,- (record {} ,- rest)) pr b x = exFalso (naughtE t)
  where
    t : 0 ≡ 1
    t = pr {0} {1} (succIsPositive (succ n)) (succPreservesInequality (succIsPositive n)) refl

2AndExtraNotIndependent : (n : ℤ) → Independent zAndZ (twoOrAnother n) → False
2AndExtraNotIndependent n indep = exFalso (naughtE (nonnegInjective ohNo))
  where
    r : {a b : ℕ} → (a<n : a <N 2) → (b<n : b <N 2) → vecIndex (BoolTrue ,- (BoolFalse ,- [])) a a<n ≡ vecIndex (BoolTrue ,- (BoolFalse ,- [])) b b<n → a ≡ b
    r {zero} {zero} a<n b<n x = refl
    r {zero} {succ (succ b)} a<n (le (succ zero) ()) x
    r {zero} {succ (succ b)} a<n (le (succ (succ y)) ()) x
    r {succ zero} {succ zero} a<n b<n x = refl
    r {succ zero} {succ (succ b)} a<n (le (succ zero) ()) x
    r {succ zero} {succ (succ b)} a<n (le (succ (succ i)) ()) x
    r {succ (succ a)} {b} (le (succ zero) ()) b<n x
    r {succ (succ a)} {b} (le (succ (succ i)) ()) b<n x
    s : dot zAndZ (vecMap (twoOrAnother n) (BoolTrue ,- (BoolFalse ,- []))) (Group.inverse ℤGroup n ,- (nonneg 2 ,- [])) ≡ nonneg 0
    s rewrite Group.identRight ℤGroup {nonneg 2 *Z n} | Ring.*Commutative ℤRing {nonneg 2} {n} | equalityCommutative (Ring.*DistributesOver+' ℤRing {additiveInverse n} {n} {nonneg 2}) | Group.invLeft ℤGroup {n} = refl
    t : _=V_ zAndZ (Ring.additiveGroup ℤRing) (nonneg 0 ,- (nonneg 0 ,- [])) (Group.inverse ℤGroup n ,- (nonneg 2 ,- []))
    t = indep (BoolTrue ,- (BoolFalse ,- [])) r (Group.inverse ℤGroup n ,- (nonneg 2 ,- [])) s

    ohNo : nonneg 0 ≡ nonneg 2
    ohNo with t
    ohNo | ()

oneLengthAlwaysInj : {a b : ℕ} → (a<n : a <N 1) → (b<n : b <N 1) → a ≡ b
oneLengthAlwaysInj {zero} {zero} a<n b<n = refl
oneLengthAlwaysInj {zero} {succ b} a<n (le zero ())
oneLengthAlwaysInj {zero} {succ b} a<n (le (succ x) ())
oneLengthAlwaysInj {succ a} {b} (le zero ()) b<n
oneLengthAlwaysInj {succ a} {b} (le (succ x) ()) b<n

noBasisExample : Independent (abGrpModule (ℤnAbGroup 5 (le 4 refl))) (λ (t : True) → record { x = 1 ; xLess = le 3 refl }) → False
noBasisExample ind with ind (record {} ,- []) (λ a<n b<n _ → oneLengthAlwaysInj a<n b<n) (nonneg 5 ,- []) refl
noBasisExample ind | ()


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

module Issue166NotSized where

postulate
  Size : Set
  ↑_   : Size → Size
  ∞    : Size

-- {-# BUILTIN SIZE    Size #-}
-- {-# BUILTIN SIZESUC ↑_   #-}
-- {-# BUILTIN SIZEINF ∞    #-}

data ⊥ : Set where

module M (A : Set) where

  data SizedNat : {i : Size} → Set where
    zero : {i : Size} → SizedNat {↑ i}
    suc  : {i : Size} → SizedNat {i} → SizedNat {↑ i}

open M ⊥


-- Andreas, 2016-02-02 postpone type checking of extended lambda
-- See also issue 480 and 1159

open import Common.Maybe
open import Common.String

record ⊤ : Set where

record IOInterface : Set₁ where
  field  Command   :  Set
         Response  :  (m : Command) → Set
open IOInterface

data IO I A : Set where
  act'     :  (c : Command I) (f : Response I c → IO I A)  → IO I A
  return   :  (a : A)                                      → IO I A

-- Alias of constructor which is a function
act :  ∀{I A} (c : Command I) (f : Response I c → IO I A) → IO I A
act c f    =  act' c f

data C : Set where
  getLine   :  C
  putStrLn  :  String → C

R : C → Set
R  getLine      =  Maybe String
R (putStrLn s)  =  ⊤

I : IOInterface
Command   I  =  C
Response  I  =  R

works : IO I ⊤
works = act'  getLine        λ{ nothing → return _ ; (just line) →
        act (putStrLn line)  λ _ →
        return _            }

test : IO I ⊤
test = act  getLine         λ{ nothing → return _ ; (just line) →
       act (putStrLn line)  λ _ →
       return _            }

-- Test with do-notation

_>>=_ : ∀ {A B} → IO I A → (A → IO I B) → IO I B
act' c f >>= k = act' c λ x → f x >>= k
return a >>= k = k a

_>>_ : ∀ {A B} → IO I A → IO I B → IO I B
m >> m' = m >>= λ _ → m'

getLineIO : IO I (Maybe String)
getLineIO = act' getLine return

putStrLnIO : String → IO I ⊤
putStrLnIO s = act' (putStrLn s) return

works' : IO I ⊤
works' = do
  just line ← getLineIO where nothing → return _
  putStrLnIO line
  return _