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

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.HLevels
open import Cubical.Foundations.Isomorphism
open import Cubical.Foundations.Equiv
open import Cubical.Foundations.Path
open import Cubical.Foundations.Pointed
open import Cubical.Foundations.Pointed.Homogeneous
open import Cubical.Foundations.GroupoidLaws

open import Cubical.Data.Bool
open import Cubical.Data.Sigma

open import Cubical.HITs.Join
open import Cubical.HITs.Susp.Base
open import Cubical.Homotopy.Loopspace

private
  variable
    ℓ : Level

open Iso

Susp-iso-joinBool : ∀ {ℓ} {A : Type ℓ} → Iso (Susp A) (join A Bool)
fun Susp-iso-joinBool north = inr true
fun Susp-iso-joinBool south = inr false
fun Susp-iso-joinBool (merid a i) = (sym (push a true) ∙ push a false) i
inv Susp-iso-joinBool (inr true ) = north
inv Susp-iso-joinBool (inr false) = south
inv Susp-iso-joinBool (inl _) = north
inv Susp-iso-joinBool (push a true  i) = north
inv Susp-iso-joinBool (push a false i) = merid a i
rightInv Susp-iso-joinBool (inr true ) = refl
rightInv Susp-iso-joinBool (inr false) = refl
rightInv Susp-iso-joinBool (inl a) = sym (push a true)
rightInv Susp-iso-joinBool (push a true  i) j = push a true (i ∨ ~ j)
rightInv Susp-iso-joinBool (push a false i) j
  = hcomp (λ k → λ { (i = i0) → push a true (~ j)
                   ; (i = i1) → push a false k
                   ; (j = i1) → push a false (i ∧ k) })
          (push a true (~ i ∧ ~ j))
leftInv Susp-iso-joinBool north = refl
leftInv Susp-iso-joinBool south = refl
leftInv (Susp-iso-joinBool {A = A}) (merid a i) j
  = hcomp (λ k → λ { (i = i0) → transp (λ _ → Susp A) (k ∨ j) north
                   ; (i = i1) → transp (λ _ → Susp A) (k ∨ j) (merid a k)
                   ; (j = i1) → merid a (i ∧ k) })
          (transp (λ _ → Susp A) j north)

Susp≃joinBool : ∀ {ℓ} {A : Type ℓ} → Susp A ≃ join A Bool
Susp≃joinBool = isoToEquiv Susp-iso-joinBool

Susp≡joinBool : ∀ {ℓ} {A : Type ℓ} → Susp A ≡ join A Bool
Susp≡joinBool = isoToPath Susp-iso-joinBool

congSuspIso : ∀ {ℓ} {A B : Type ℓ} → Iso A B → Iso (Susp A) (Susp B)
fun (congSuspIso is) = suspFun (fun is)
inv (congSuspIso is) = suspFun (inv is)
rightInv (congSuspIso is) north = refl
rightInv (congSuspIso is) south = refl
rightInv (congSuspIso is) (merid a i) j = merid (rightInv is a j) i
leftInv (congSuspIso is) north = refl
leftInv (congSuspIso is) south = refl
leftInv (congSuspIso is) (merid a i) j = merid (leftInv is a j) i

congSuspEquiv : ∀ {ℓ} {A B : Type ℓ} → A ≃ B → Susp A ≃ Susp B
congSuspEquiv {ℓ} {A} {B} h = isoToEquiv (congSuspIso (equivToIso h))

suspToPropElim : ∀ {ℓ ℓ'} {A : Type ℓ} {B : Susp A → Type ℓ'} (a : A)
                 → ((x : Susp A) → isProp (B x))
                 → B north
                 → (x : Susp A) → B x
suspToPropElim a isProp Bnorth north = Bnorth
suspToPropElim {B = B} a isProp Bnorth south = subst B (merid a) Bnorth
suspToPropElim {B = B} a isProp Bnorth (merid a₁ i) =
  isOfHLevel→isOfHLevelDep 1 isProp Bnorth (subst B (merid a) Bnorth) (merid a₁) i

suspToPropElim2 : ∀ {ℓ ℓ'} {A : Type ℓ} {B : Susp A → Susp A → Type ℓ'} (a : A)
                 → ((x y : Susp A) → isProp (B x y))
                 → B north north
                 → (x y : Susp A) → B x y
suspToPropElim2 _ _ Bnorth north north = Bnorth
suspToPropElim2 {B = B} a _ Bnorth north south = subst (B north) (merid a) Bnorth
suspToPropElim2 {B = B} a isprop Bnorth north (merid x i) =
  isProp→PathP (λ i → isprop north (merid x i))
               Bnorth (subst (B north) (merid a) Bnorth) i
suspToPropElim2 {B = B} a _ Bnorth south north = subst (λ x → B x north) (merid a) Bnorth
suspToPropElim2 {B = B} a _ Bnorth south south = subst (λ x → B x x) (merid a) Bnorth
suspToPropElim2 {B = B} a isprop Bnorth south (merid x i) =
  isProp→PathP (λ i → isprop south (merid x i))
               (subst (λ x → B x north) (merid a) Bnorth)
               (subst (λ x → B x x) (merid a) Bnorth) i
suspToPropElim2 {B = B} a isprop Bnorth (merid x i) north =
  isProp→PathP (λ i → isprop (merid x i) north)
               Bnorth (subst (λ x → B x north) (merid a) Bnorth) i
suspToPropElim2 {B = B} a isprop Bnorth (merid x i) south =
  isProp→PathP (λ i → isprop (merid x i) south)
               (subst (B north) (merid a) Bnorth)
               (subst (λ x → B x x) (merid a) Bnorth) i
suspToPropElim2 {B = B} a isprop Bnorth (merid x i) (merid y j) =
  isSet→SquareP (λ i j → isOfHLevelSuc 1 (isprop _ _))
     (isProp→PathP (λ i₁ → isprop north (merid y i₁)) Bnorth
                   (subst (B north) (merid a) Bnorth))
     (isProp→PathP (λ i₁ → isprop south (merid y i₁))
                   (subst (λ x₁ → B x₁ north) (merid a) Bnorth)
                   (subst (λ x₁ → B x₁ x₁) (merid a) Bnorth))
     (isProp→PathP (λ i₁ → isprop (merid x i₁) north) Bnorth
                   (subst (λ x₁ → B x₁ north) (merid a) Bnorth))
     (isProp→PathP (λ i₁ → isprop (merid x i₁) south)
                   (subst (B north) (merid a) Bnorth)
                   (subst (λ x₁ → B x₁ x₁) (merid a) Bnorth)) i j
{- Clever proof:
suspToPropElim2 a isProp Bnorth =
  suspToPropElim a (λ x → isOfHLevelΠ 1 λ y → isProp x y)
                   (suspToPropElim a (λ x → isProp north x) Bnorth)
-}

funSpaceSuspIso : ∀ {ℓ ℓ'} {A : Type ℓ} {B : Type ℓ'}
                   → Iso (Σ[ x ∈ B ] Σ[ y ∈ B ] (A → x ≡ y)) (Susp A → B)
Iso.fun funSpaceSuspIso (x , y , f) north = x
Iso.fun funSpaceSuspIso (x , y , f) south = y
Iso.fun funSpaceSuspIso (x , y , f) (merid a i) = f a i
Iso.inv funSpaceSuspIso f = (f north) , (f south , (λ x → cong f (merid x)))
Iso.rightInv funSpaceSuspIso f = funExt λ {north → refl
                                             ; south → refl
                                             ; (merid a i) → refl}
Iso.leftInv funSpaceSuspIso _ = refl

toSusp : (A : Pointed ℓ) → typ A → typ (Ω (Susp∙ (typ A)))
toSusp A x = merid x ∙ merid (pt A) ⁻¹

toSuspPointed : (A : Pointed ℓ) → A →∙ Ω (Susp∙ (typ A))
fst (toSuspPointed A) = toSusp A
snd (toSuspPointed A) = rCancel (merid (pt A))

module _ {ℓ ℓ' : Level} {A : Pointed ℓ} {B : Pointed ℓ'} where
  fromSusp→toΩ : Susp∙ (typ A) →∙ B → (A →∙ Ω B)
  fst (fromSusp→toΩ f) x = sym (snd f) ∙∙ cong (fst f) (toSusp A x) ∙∙ snd f
  snd (fromSusp→toΩ f) =
    cong (sym (snd f) ∙∙_∙∙ (snd f))
          (cong (cong (fst f))
           (rCancel (merid (pt A))))
       ∙ ∙∙lCancel (snd f)

  toΩ→fromSusp : A →∙ Ω B → Susp∙ (typ A) →∙ B
  fst (toΩ→fromSusp f) north = pt B
  fst (toΩ→fromSusp f) south = pt B
  fst (toΩ→fromSusp f) (merid a i) = fst f a i
  snd (toΩ→fromSusp f) = refl

  ΩSuspAdjointIso : Iso (A →∙ Ω B) (Susp∙ (typ A) →∙ B)
  fun ΩSuspAdjointIso = toΩ→fromSusp
  inv ΩSuspAdjointIso = fromSusp→toΩ
  rightInv ΩSuspAdjointIso f =
    ΣPathP (funExt
      (λ { north → sym (snd f)
         ; south → sym (snd f) ∙ cong (fst f) (merid (pt A))
         ; (merid a i) j →
           hcomp (λ k → λ { (i = i0) → snd f (~ j ∧ k)
                           ; (i = i1) → compPath-filler'
                                          (sym (snd f))
                                          (cong (fst f) (merid (pt A))) k j
                           ; (j = i1) → fst f (merid a i)})
                 (fst f (compPath-filler (merid a) (sym (merid (pt A))) (~ j) i))})
         , λ i j → snd f (~ i ∨ j))
  leftInv ΩSuspAdjointIso f =
    →∙Homogeneous≡ (isHomogeneousPath _ _)
      (funExt λ x → sym (rUnit _)
             ∙ cong-∙ (fst (toΩ→fromSusp f)) (merid x) (sym (merid (pt A)))
             ∙ cong (fst f x ∙_) (cong sym (snd f))
             ∙ sym (rUnit _))

  IsoΩFunSuspFun : Iso (typ (Ω (A →∙ B ∙))) (Susp∙ (typ A) →∙ B)
  IsoΩFunSuspFun = compIso (ΩfunExtIso A B) ΩSuspAdjointIso

-- inversion
invSusp : ∀ {ℓ} {A : Type ℓ} → Susp A → Susp A
invSusp north = south
invSusp south = north
invSusp (merid a i) = merid a (~ i)

invSusp² : ∀ {ℓ} {A : Type ℓ} (x : Susp A) → invSusp (invSusp x) ≡ x
invSusp² north = refl
invSusp² south = refl
invSusp² (merid a i) = refl

invSuspIso : ∀ {ℓ} {A : Type ℓ} → Iso (Susp A) (Susp A)
fun invSuspIso = invSusp
inv invSuspIso = invSusp
rightInv invSuspIso = invSusp²
leftInv invSuspIso = invSusp²

-- Explicit definition of the iso
-- join (Susp A) B ≃ Susp (join A B)
-- for pointed types A and B. This is useful for obtaining a ``nice'' iso
-- join Sⁿ Sᵐ ≃ Sⁿ⁺ᵐ⁺¹
module _ {A B : Pointed ℓ} where

  private -- some useful fillers
    rinv-filler : (b : typ B) → I → I → I → join (Susp (typ A)) (typ B)
    rinv-filler b i j k =
      hfill (λ k → λ {(i = i0) → push south b (~ k)
                     ; (i = i1) → push north b (~ k ∨ j)
                     ; (j = i0) → push (merid (pt A) (~ i)) b (~ k)
                     ; (j = i1) → push south b (~ k ∨ i)})
            (inS (inr b))
            k

    suspJoin→joinSuspFiller :
      I → I → I → (a : typ A) (b : typ B) → join (Susp (typ A)) (typ B)
    suspJoin→joinSuspFiller i j k a b =
      hfill (λ k → λ {(i = i0) → push north b (~ k)
                     ; (i = i1) → push south b (~ k)
                     ; (j = i0) → push (merid a i) b (~ k)
                     ; (j = i1) → push (merid (pt A) i) b (~ k)})
            (inS (inr b))
            k

    joinSuspFiller :
      I → I → I → (a : typ A) (b : typ B) → Susp (join (typ A) (typ B))
    joinSuspFiller i j k a b =
      hfill (λ k → λ {(i = i0) → merid (push a b (~ k)) j
                     ; (i = i1) → north
                     ; (j = i0) → north
                     ; (j = i1) → merid (push (pt A) b (~ k)) (~ i)})
            (inS (merid (inr b) (~ i ∧ j)))
            k

  suspJoin→joinSusp : Susp (join (typ A) (typ B)) → join (Susp (typ A)) (typ B)
  suspJoin→joinSusp north = inl north
  suspJoin→joinSusp south = inl south
  suspJoin→joinSusp (merid (inl x) i) = inl ((merid x) i)
  suspJoin→joinSusp  (merid (inr x) i) = inl (merid (pt A) i)
  suspJoin→joinSusp  (merid (push a b j) i) = suspJoin→joinSuspFiller i j i1 a b

  joinSusp→suspJoin : join (Susp (typ A)) (typ B) → Susp (join (typ A) (typ B))
  joinSusp→suspJoin (inl north) = north
  joinSusp→suspJoin (inl south) = south
  joinSusp→suspJoin (inl (merid a i)) = merid (inl a) i
  joinSusp→suspJoin (inr x) = north
  joinSusp→suspJoin (push north b i) = north
  joinSusp→suspJoin (push south b i) = merid (inl (pt A)) (~ i)
  joinSusp→suspJoin (push (merid a j) b i) = joinSuspFiller i j i1 a b

  suspJoin→joinSusp→suspJoin : (x : Susp (join (typ A) (typ B)))
    → joinSusp→suspJoin (suspJoin→joinSusp x) ≡ x
  suspJoin→joinSusp→suspJoin north = refl
  suspJoin→joinSusp→suspJoin south = refl
  suspJoin→joinSusp→suspJoin (merid (inl x) i) = refl
  suspJoin→joinSusp→suspJoin (merid (inr x) i) j = merid (push (pt A) x j) i
  suspJoin→joinSusp→suspJoin (merid (push a b j) i) k =
    hcomp (λ r → λ {(i = i0) → north
                   ; (i = i1) → merid (push (snd A) b (k ∧ (~ r ∨ j))) r
                   ; (j = i0) → joinSuspFiller (~ r) i (~ k ∨ r) a b
                   ; (j = i1) → joinSuspFiller (~ r) i (~ k) (pt A) b
                   ; (k = i0) → joinSusp→suspJoin (suspJoin→joinSuspFiller i j r a b)
                   ; (k = i1) → k=i1 i j r})
          north
     where
     k=i1 :
       Cube
         (λ j r → north)
         (λ j r → merid (push (snd A) b (~ r ∨ j)) r)
         (λ i r → joinSuspFiller (~ r) i r a b)
         (λ i r → merid (inr b) (r ∧ i))
         refl
         λ i j → merid (push a b j) i
     k=i1 i j r =
       hcomp (λ k → λ {(i = i0) → north
                      ; (i = i1) → merid (push (snd A) b (~ r ∨ ~ k ∨ j)) r
                      ; (j = i0) → joinSuspFiller (~ r) i (r ∧ k) a b
                      ; (j = i1) → merid (inr b) (r ∧ i)
                      ; (r = i0) → north
                      ; (r = i1) → merid (push a b (~ k ∨ j)) i})
             (merid (inr b) (i ∧ r))

  joinSusp→suspJoin→joinSusp : (x : join (Susp (typ A)) (typ B))
    → suspJoin→joinSusp (joinSusp→suspJoin x) ≡ x
  joinSusp→suspJoin→joinSusp (inl north) = refl
  joinSusp→suspJoin→joinSusp (inl south) = refl
  joinSusp→suspJoin→joinSusp (inl (merid a i)) = refl
  joinSusp→suspJoin→joinSusp (inr x) = push north x
  joinSusp→suspJoin→joinSusp (push north b i) j = push north b (j ∧ i)
  joinSusp→suspJoin→joinSusp (push south b i) j = rinv-filler b i j i1
  joinSusp→suspJoin→joinSusp (push (merid a j) b i) k =
    hcomp (λ r → λ { (j = i0) → push north b (k ∧ i)
                     ; (j = i1) → lem i k r
                     ; (i = i0) → suspJoin→joinSuspFiller j (~ r ∧ ~ k) i1 a b
                     ; (i = i1) → push north b k
                     ; (k = i0) → suspJoin→joinSusp (joinSuspFiller i j r a b)
                     ; (k = i1) → push (merid a j) b i})
          (hcomp (λ r → λ { (j = i0) → push north b (~ r ∨ (k ∧ i))
                     ; (j = i1) → rinv-filler b i k r
                     ; (i = i0) → suspJoin→joinSuspFiller j (~ k) r a b
                     ; (i = i1) → push north b (~ r ∨ k)
                     ; (k = i0) → push (merid (snd A) (~ i ∧ j)) b (~ r)
                     ; (k = i1) → push (merid a j) b (~ r ∨ i)})
                 (inr b))
    where
    lem : Cube (λ k r → inl south)
               (λ k r → push north b k)
               (λ i r → suspJoin→joinSuspFiller (~ i) r i1 (pt A) b)
               (λ i r → push south b i)
               (λ i k → rinv-filler b i k i1)
               λ i k → rinv-filler b i k i1
    lem i k r =
      hcomp (λ j → λ { (r = i0) → rinv-filler b i k j
                     ; (r = i1) → rinv-filler b i k j
                     ; (i = i0) → push south b (~ j)
                     ; (i = i1) → push north b (k ∨ ~ j)
                     ; (k = i0) → suspJoin→joinSuspFiller (~ i) r j (pt A) b
                     ; (k = i1) → push south b (i ∨ ~ j)})
                 (inr b)

  Iso-joinSusp-suspJoin :
    Iso (join (Susp (typ A)) (typ B)) (Susp (join (typ A) (typ B)))
  Iso.fun Iso-joinSusp-suspJoin = joinSusp→suspJoin
  Iso.inv Iso-joinSusp-suspJoin = suspJoin→joinSusp
  Iso.rightInv Iso-joinSusp-suspJoin = suspJoin→joinSusp→suspJoin
  Iso.leftInv Iso-joinSusp-suspJoin = joinSusp→suspJoin→joinSusp

-- interaction between invSusp and toSusp
toSusp-invSusp : (A : Pointed ℓ) (x : Susp (typ A))
  → toSusp (Susp∙ (typ A)) (invSusp x) ≡ sym (toSusp (Susp∙ (typ A)) x)
toSusp-invSusp A north =
  cong (toSusp (Susp∙ (typ A))) (sym (merid (snd A)))
                  ∙∙ rCancel (merid north)
                  ∙∙ cong sym (sym (rCancel (merid north)))
toSusp-invSusp A south =
     rCancel (merid north)
   ∙∙ cong sym (sym (rCancel (merid north)))
   ∙∙ cong sym (cong (toSusp (Susp∙ (typ A))) (merid (pt A)))
toSusp-invSusp A (merid a i) j =
  lem (toSusp (Susp∙ (typ A)) north) (toSusp (Susp∙ (typ A)) south)
         (sym (rCancel (merid north)))
         (cong (toSusp (Susp∙ (typ A))) ((merid (pt A))))
         (cong (toSusp (Susp∙ (typ A))) (merid a)) (~ j) i
  where
  lem : {A : Type ℓ} {x : A} (p q : x ≡ x) (l : refl ≡ p)
        (coh r : p ≡ q)
      → PathP (λ i → (cong sym (sym l) ∙∙ l ∙∙ coh) i
                     ≡ (cong sym (sym coh) ∙∙ cong sym (sym l) ∙∙ l) i)
               (cong sym r)
               (sym r)
  lem p q =
    J (λ p l → (coh r : p ≡ q)
            → PathP (λ i → (cong sym (sym l) ∙∙ l ∙∙ coh) i
                           ≡ (cong sym (sym coh) ∙∙ cong sym (sym l) ∙∙ l) i)
                     (cong sym r)
                     (sym r))
       (J (λ q coh → (r : refl ≡ q)
                   → PathP (λ i → (refl ∙ coh) i
                           ≡ (cong sym (sym coh) ∙∙ refl ∙∙ refl) i)
                     (cong sym r)
                     (sym r))
          λ r → flipSquare (sym (rUnit refl)
                ◁ (flipSquare (sym (sym≡cong-sym r))
                ▷ rUnit refl)))


------------------------------------------------------------------------------
-- An inductive predicate for representing functions
------------------------------------------------------------------------------

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

module FOT.FOTC.Data.Fun where

open import FOTC.Base

------------------------------------------------------------------------------
-- 2012-03-13. I don't see how we can distinguish between data
-- elements and functions in FOTC. The following inductive predicate
-- is true for any element d : D.
data Fun : D → Set where
  fun : (f : D) → Fun f

-- But using a λ-abstraction we could make a distinguish:
postulate lam : (D → D) → D  -- LTC-PCF λ-abstraction.

data Fun₁ : D → Set where
  fun₁ : (f : D → D) → Fun₁ (lam f)


-- Andreas, 2016-11-02, issue #2285
-- double check for record types

record Big : _ where
  field any : ∀{a} → Set a


------------------------------------------------------------------------
-- Definitions of "free in" and "closed", along with some properties
------------------------------------------------------------------------

open import Atom

module Free-variables (atoms : χ-atoms) where

open import Dec
open import Equality.Propositional.Cubical
open import Logical-equivalence using (_⇔_)
open import Prelude hiding (const; swap)

open import Bag-equivalence equality-with-J as B using (_∈_)
open import Bijection equality-with-J as Bijection using (_↔_)
import Erased.Cubical equality-with-paths as E
open import Equivalence equality-with-J as Eq using (_≃_)
open import Finite-subset.Listed equality-with-paths as S
  using (Finite-subset-of)
open import Function-universe equality-with-J as F hiding (id; _∘_)
open import H-level equality-with-J
open import H-level.Closure equality-with-J
open import H-level.Truncation.Propositional equality-with-paths as T
  using (∥_∥)
open import List equality-with-J using (_++_; foldr)

open import Chi           atoms
open import Propositional atoms
open import Substitution  atoms
open import Values        atoms

open χ-atoms atoms

private
  variable
    A             : Type
    bs            : List Br
    c c′          : Const
    e e₁ e₂ e′ e″ : Exp
    es            : List Exp
    x y           : Var
    xs xs′        : A

private

  -- Two variants of V._≟_.

  _≟V₁_ : (x y : Var) → Dec T.∥ x ≡ y ∥
  _≟V₁_ = T.decidable→decidable-∥∥ V._≟_

  _≟V₂_ : (x y : Var) → E.Dec-Erased T.∥ x ≡ y ∥
  x ≟V₂ y = E.Dec→Dec-Erased (x ≟V₁ y)

------------------------------------------------------------------------
-- Definitions

-- Free variables.

infix 4 _∈FV_

data _∈FV_ (x : Var) : Exp → Type where
  apply-left  : ∀ {e₁ e₂} → x ∈FV e₁ → x ∈FV apply e₁ e₂
  apply-right : ∀ {e₁ e₂} → x ∈FV e₂ → x ∈FV apply e₁ e₂
  lambda      : ∀ {y e} → x ≢ y → x ∈FV e → x ∈FV lambda y e
  case-head   : ∀ {e bs} → x ∈FV e → x ∈FV case e bs
  case-body   : ∀ {e bs c xs e′} →
                x ∈FV e′ → branch c xs e′ ∈ bs → ¬ x ∈ xs →
                x ∈FV case e bs
  rec         : ∀ {y e} → x ≢ y → x ∈FV e → x ∈FV rec y e
  var         : ∀ {y} → x ≡ y → x ∈FV var y
  const       : ∀ {c es e} → x ∈FV e → e ∈ es → x ∈FV const c es

-- Closed, except that the given variables may occur.

Closed′ : List Var → Exp → Type
Closed′ xs e = ∀ x → ¬ x ∈ xs → ¬ x ∈FV e

-- The property of being closed.

Closed : Exp → Type
Closed = Closed′ []

-- Closed expressions.

Closed-exp : Type
Closed-exp = ∃ Closed

------------------------------------------------------------------------
-- Inversion lemmas for _∈_

∈apply : (x ∈FV apply e₁ e₂) ≃ (x ∈FV e₁ ⊎ x ∈FV e₂)
∈apply = Eq.↔→≃
  (λ { (apply-left  x∈) → inj₁ x∈
     ; (apply-right x∈) → inj₂ x∈
     })
  [ apply-left , apply-right ]
  [ (λ _ → refl) , (λ _ → refl) ]
  (λ { (apply-left  _) → refl
     ; (apply-right _) → refl
     })

∈lambda : (x ∈FV lambda y e) ≃ (x ≢ y × x ∈FV e)
∈lambda = Eq.↔→≃
  (λ { (lambda x≢y x∈e) → x≢y , x∈e })
  (uncurry lambda)
  (λ _ → refl)
  (λ { (lambda _ _) → refl })

∈case :
  (x ∈FV case e bs) ≃
  (x ∈FV e ⊎
   ∃ λ c → ∃ λ xs → ∃ λ e′ → x ∈FV e′ × branch c xs e′ ∈ bs × ¬ x ∈ xs)
∈case = Eq.↔→≃
  (λ { (case-head x∈)       → inj₁ x∈
     ; (case-body x∈ b∈ x∉) → inj₂ (_ , _ , _ , x∈ , b∈ , x∉)
     })
  [ case-head , (λ (_ , _ , _ , x∈ , b∈ , x∉) → case-body x∈ b∈ x∉) ]
  [ (λ _ → refl) , (λ _ → refl) ]
  (λ { (case-head _)     → refl
     ; (case-body _ _ _) → refl
     })

∈rec : (x ∈FV rec y e) ≃ (x ≢ y × x ∈FV e)
∈rec = Eq.↔→≃
  (λ { (rec x≢y x∈e) → x≢y , x∈e })
  (uncurry rec)
  (λ _ → refl)
  (λ { (rec _ _) → refl })

∈var : (x ∈FV var y) ≃ (x ≡ y)
∈var = Eq.↔→≃
  (λ { (var x≡y) → x≡y })
  var
  (λ _ → refl)
  (λ { (var _) → refl })

∈const : (x ∈FV const c es) ≃ (∃ λ e → x ∈FV e × e ∈ es)
∈const = Eq.↔→≃
  (λ { (const ∈e ∈es) → _ , ∈e , ∈es })
  (λ (_ , ∈e , ∈es) → const ∈e ∈es)
  (λ _ → refl)
  (λ { (const _ _) → refl })

------------------------------------------------------------------------
-- Characterisation lemmas for Closed′

Closed′-apply≃ :
  Closed′ xs (apply e₁ e₂) ≃ (Closed′ xs e₁ × Closed′ xs e₂)
Closed′-apply≃ {xs = xs} {e₁ = e₁} {e₂ = e₂} =
  Closed′ xs (apply e₁ e₂)                                       ↔⟨⟩
  (∀ x → ¬ x ∈ xs → ¬ x ∈FV apply e₁ e₂)                         ↝⟨ (∀-cong ext λ _ → ∀-cong ext λ _ → ¬-cong ext ∈apply) ⟩
  (∀ x → ¬ x ∈ xs → ¬ (x ∈FV e₁ ⊎ x ∈FV e₂))                     ↝⟨ (∀-cong ext λ _ → ∀-cong ext λ _ → ¬⊎↔¬×¬ ext) ⟩
  (∀ x → ¬ x ∈ xs → (¬ x ∈FV e₁ × ¬ x ∈FV e₂))                   ↔⟨ (∀-cong ext λ _ → ΠΣ-comm) ⟩
  (∀ x → (¬ x ∈ xs → ¬ x ∈FV e₁) × (¬ x ∈ xs → ¬ x ∈FV e₂))      ↔⟨ ΠΣ-comm ⟩
  (∀ x → ¬ x ∈ xs → ¬ x ∈FV e₁) × (∀ x → ¬ x ∈ xs → ¬ x ∈FV e₂)  ↔⟨⟩
  Closed′ xs e₁ × Closed′ xs e₂                                  □

Closed′-lambda≃ :
  Closed′ xs (lambda x e) ≃ Closed′ (x ∷ xs) e
Closed′-lambda≃ {xs = xs} {x = x} {e = e} =
  Closed′ xs (lambda x e)                 ↔⟨⟩
  (∀ y → ¬ y ∈ xs → ¬ y ∈FV lambda x e)   ↝⟨ (∀-cong ext λ _ → ∀-cong ext λ _ → ¬-cong ext ∈lambda) ⟩
  (∀ y → ¬ y ∈ xs → ¬ (y ≢ x × y ∈FV e))  ↔⟨ (∀-cong ext λ _ → ∀-cong ext λ _ → currying) ⟩
  (∀ y → ¬ y ∈ xs → y ≢ x → ¬ y ∈FV e)    ↔⟨ (∀-cong ext λ _ → Π-comm) ⟩
  (∀ y → y ≢ x → ¬ y ∈ xs → ¬ y ∈FV e)    ↔⟨ (∀-cong ext λ _ → inverse currying) ⟩
  (∀ y → y ≢ x × ¬ y ∈ xs → ¬ y ∈FV e)    ↝⟨ (∀-cong ext λ _ → →-cong₁ {k₁ = equivalence} ext $ inverse $ ¬⊎↔¬×¬ ext) ⟩
  (∀ y → ¬ (y ≡ x ⊎ y ∈ xs) → ¬ y ∈FV e)  ↔⟨⟩
  Closed′ (x ∷ xs) e                      □

Closed′-rec≃ :
  Closed′ xs (rec x e) ≃ Closed′ (x ∷ xs) e
Closed′-rec≃ {xs = xs} {x = x} {e = e} =
  Closed′ xs (rec x e)                    ↔⟨⟩
  (∀ y → ¬ y ∈ xs → ¬ y ∈FV rec x e)      ↝⟨ (∀-cong ext λ _ → ∀-cong ext λ _ → ¬-cong ext ∈rec) ⟩
  (∀ y → ¬ y ∈ xs → ¬ (y ≢ x × y ∈FV e))  ↔⟨ (∀-cong ext λ _ → ∀-cong ext λ _ → currying) ⟩
  (∀ y → ¬ y ∈ xs → y ≢ x → ¬ y ∈FV e)    ↔⟨ (∀-cong ext λ _ → Π-comm) ⟩
  (∀ y → y ≢ x → ¬ y ∈ xs → ¬ y ∈FV e)    ↔⟨ (∀-cong ext λ _ → inverse currying) ⟩
  (∀ y → y ≢ x × ¬ y ∈ xs → ¬ y ∈FV e)    ↝⟨ (∀-cong ext λ _ → →-cong₁ {k₁ = equivalence} ext $ inverse $ ¬⊎↔¬×¬ ext) ⟩
  (∀ y → ¬ (y ≡ x ⊎ y ∈ xs) → ¬ y ∈FV e)  ↔⟨⟩
  Closed′ (x ∷ xs) e                      □

Closed′-case≃ :
  Closed′ xs (case e bs) ≃
  (Closed′ xs e ×
   ∀ {c ys e} → branch c ys e ∈ bs → Closed′ (ys ++ xs) e)
Closed′-case≃ {xs = xs} {e = e} {bs = bs} =
  Closed′ xs (case e bs)                                                ↔⟨⟩

  (∀ x → ¬ x ∈ xs → ¬ x ∈FV case e bs)                                  ↝⟨ (∀-cong ext λ _ → ∀-cong ext λ _ → ¬-cong ext ∈case) ⟩

  (∀ x → ¬ x ∈ xs →
   ¬ (x ∈FV e ⊎
      ∃ λ c → ∃ λ ys → ∃ λ e′ →
        x ∈FV e′ × branch c ys e′ ∈ bs × ¬ x ∈ ys))                     ↝⟨ (∀-cong ext λ _ → ∀-cong ext λ _ → ¬⊎↔¬×¬ ext) ⟩

  (∀ x → ¬ x ∈ xs →
   ¬ x ∈FV e ×
   ¬ ∃ λ c → ∃ λ ys → ∃ λ e′ →
       x ∈FV e′ × branch c ys e′ ∈ bs × ¬ x ∈ ys)                       ↔⟨ ΠΣ-comm F.∘
                                                                           (∀-cong ext λ _ → ΠΣ-comm) ⟩
  (∀ x → ¬ x ∈ xs → ¬ x ∈FV e) ×
  (∀ x → ¬ x ∈ xs →
   ¬ ∃ λ c → ∃ λ ys → ∃ λ e′ →
       x ∈FV e′ × branch c ys e′ ∈ bs × ¬ x ∈ ys)                       ↝⟨ ∃-cong lemma ⟩

  (∀ x → ¬ x ∈ xs → ¬ x ∈FV e) ×
  (∀ {c ys e} → branch c ys e ∈ bs → ∀ x → ¬ x ∈ ys ++ xs → ¬ x ∈FV e)  ↔⟨⟩

  Closed′ xs e ×
  (∀ {c ys e} → branch c ys e ∈ bs → Closed′ (ys ++ xs) e)              □
  where
  lemma = λ hyp →
    (∀ x → ¬ x ∈ xs →
     ¬ ∃ λ c → ∃ λ ys → ∃ λ e →
         x ∈FV e × branch c ys e ∈ bs × ¬ x ∈ ys)  ↔⟨ (∀-cong ext λ _ → ∀-cong ext λ _ →
                                                       (∀-cong ext λ _ →
                                                        (∀-cong ext λ _ →
                                                         (∀-cong ext λ _ →
                                                          currying F.∘
                                                          Π-comm F.∘
                                                          currying) F.∘
                                                         currying) F.∘
                                                        currying) F.∘
                                                       currying) ⟩
    (∀ x → ¬ x ∈ xs → ∀ c ys e →
     branch c ys e ∈ bs → ¬ x ∈ ys → ¬ x ∈FV e)    ↔⟨ (∀-cong ext λ _ →
                                                       (∀-cong ext λ _ →
                                                        (∀-cong ext λ _ →
                                                         (∀-cong ext λ _ →
                                                          (∀-cong ext λ _ →
                                                           inverse currying) F.∘
                                                          currying) F.∘
                                                         Π-comm) F.∘
                                                        Π-comm) F.∘
                                                       Π-comm) F.∘
                                                      Π-comm F.∘
                                                      inverse currying ⟩
    (∀ c ys e → branch c ys e ∈ bs →
     ∀ x → ¬ x ∈ xs × ¬ x ∈ ys → ¬ x ∈FV e)        ↝⟨ (∀-cong ext λ _ → ∀-cong ext λ _ → ∀-cong ext λ _ →
                                                       ∀-cong ext λ _ → ∀-cong ext λ _ → →-cong₁ ext $ inverse $
                                                       ¬⊎↔¬×¬ {k = equivalence} ext) ⟩
    (∀ c ys e → branch c ys e ∈ bs →
     ∀ x → ¬ (x ∈ xs ⊎ x ∈ ys) → ¬ x ∈FV e)        ↝⟨ (∀-cong ext λ _ → ∀-cong ext λ _ → ∀-cong ext λ _ →
                                                       ∀-cong ext λ _ → ∀-cong ext λ _ → →-cong₁ ext $ ¬-cong ext
                                                       ⊎-comm) ⟩
    (∀ c ys e → branch c ys e ∈ bs →
     ∀ x → ¬ (x ∈ ys ⊎ x ∈ xs) → ¬ x ∈FV e)        ↝⟨ (∀-cong ext λ _ → ∀-cong ext λ _ → ∀-cong ext λ _ →
                                                       ∀-cong ext λ _ → ∀-cong ext λ _ → →-cong₁ ext $ ¬-cong ext $ inverse $
                                                       B.Any-++ _ _ _) ⟩
    (∀ c ys e → branch c ys e ∈ bs →
     ∀ x → ¬ x ∈ ys ++ xs → ¬ x ∈FV e)             ↔⟨ inverse $
                                                      (∀-cong ext λ _ →
                                                       (∀-cong ext λ _ → Bijection.implicit-Π↔Π) F.∘
                                                       Bijection.implicit-Π↔Π) F.∘
                                                      Bijection.implicit-Π↔Π ⟩□
    (∀ {c ys e} → branch c ys e ∈ bs →
     ∀ x → ¬ x ∈ ys ++ xs → ¬ x ∈FV e)             □

Closed′-const≃ :
  Closed′ xs (const c es) ≃ (∀ e → e ∈ es → Closed′ xs e)
Closed′-const≃ {xs = xs} {c = c} {es = es} =
  Closed′ xs (const c es)                        ↔⟨⟩
  (∀ x → ¬ x ∈ xs → ¬ x ∈FV const c es)          ↝⟨ (∀-cong ext λ _ → ∀-cong ext λ _ → ¬-cong ext ∈const) ⟩
  (∀ x → ¬ x ∈ xs → ¬ ∃ λ e → x ∈FV e × e ∈ es)  ↔⟨ currying F.∘
                                                    (∀-cong ext λ _ →
                                                     currying) F.∘
                                                    Π-comm F.∘
                                                    (∀-cong ext λ _ →
                                                     inverse currying F.∘
                                                     (∀-cong ext λ _ →
                                                      Π-comm F.∘
                                                      currying) F.∘
                                                     currying) F.∘
                                                    inverse currying ⟩
  (∀ e → e ∈ es → ∀ x → ¬ x ∈ xs → ¬ x ∈FV e)    ↔⟨⟩
  (∀ e → e ∈ es → Closed′ xs e)                  □

Closed′-var≃ : Closed′ xs (var x) ≃ ∥ x ∈ xs ∥
Closed′-var≃ {xs = xs} {x = x} =
  Closed′ xs (var x)                ↔⟨⟩
  (∀ y → ¬ y ∈ xs → ¬ y ∈FV var x)  ↝⟨ (∀-cong ext λ _ → ∀-cong ext λ _ → ¬-cong ext ∈var) ⟩
  (∀ y → ¬ y ∈ xs → ¬ y ≡ x)        ↝⟨ (∀-cong ext λ _ → →-cong₁ ext $ inverse T.¬∥∥↔¬) ⟩
  (∀ y → ¬ ∥ y ∈ xs ∥ → ¬ y ≡ x)    ↝⟨ (∀-cong ext λ _ → inverse $
                                        →≃¬→¬
                                          (λ _ _ → T.truncation-is-proposition)
                                          (λ _ → Dec-map
                                                   (from-equivalence $ inverse S.∥∈∥≃∈-from-List)
                                                   (S.member? _≟V₁_ _ _))
                                          ext) ⟩
  (∀ y → y ≡ x → ∥ y ∈ xs ∥)        ↝⟨ (∀-cong ext λ _ → →-cong₁ ext ≡-comm) ⟩
  (∀ y → x ≡ y → ∥ y ∈ xs ∥)        ↝⟨ inverse $ ∀-intro _ ext ⟩□
  ∥ x ∈ xs ∥                        □

------------------------------------------------------------------------
-- Some properties

-- Closed is propositional.

Closed-propositional : ∀ {e} → Is-proposition (Closed e)
Closed-propositional =
  Π-closure ext 1 λ _ →
  Π-closure ext 1 λ _ →
  ¬-propositional ext

-- Closed-exp is a set.

Closed-exp-set : Is-set Closed-exp
Closed-exp-set =
  Σ-closure 2 Exp-set (λ _ → mono₁ 1 Closed-propositional)

-- Two closed expressions are equal if the underlying expressions are
-- equal.

closed-equal-if-expressions-equal :
  {e₁ e₂ : Closed-exp} → proj₁ e₁ ≡ proj₁ e₂ → e₁ ≡ e₂
closed-equal-if-expressions-equal eq =
  Σ-≡,≡→≡ eq (Closed-propositional _ _)

-- Constructor applications are closed.

mutual

  const→closed : ∀ {e} → Constructor-application e → Closed e
  const→closed (const c cs) x x∉[] (const x∈e e∈es) =
    consts→closed cs e∈es x x∉[] x∈e

  consts→closed : ∀ {e es} →
                  Constructor-applications es → e ∈ es → Closed e
  consts→closed []       ()
  consts→closed (c ∷ cs) (inj₁ refl) = const→closed c
  consts→closed (c ∷ cs) (inj₂ e∈es) = consts→closed cs e∈es

-- Closed e implies Closed′ xs e, for any xs.

Closed→Closed′ : ∀ {xs e} → Closed e → Closed′ xs e
Closed→Closed′ cl x _ = cl x (λ ())

-- If a variable is free in e [ x ← e′ ], then it is either free in e,
-- or it is distinct from x and free in e′.

mutual

  subst-∈FV : ∀ x e {x′ e′} →
              x′ ∈FV e [ x ← e′ ] → x′ ∈FV e × x′ ≢ x ⊎ x′ ∈FV e′
  subst-∈FV x (apply e₁ e₂) (apply-left  p)        = ⊎-map (Σ-map apply-left  id) id (subst-∈FV x e₁ p)
  subst-∈FV x (apply e₁ e₂) (apply-right p)        = ⊎-map (Σ-map apply-right id) id (subst-∈FV x e₂ p)
  subst-∈FV x (lambda y e)  (lambda x′≢y p)        with x V.≟ y
  subst-∈FV x (lambda y e)  (lambda x′≢y p)        | yes x≡y = inj₁ (lambda x′≢y p , x′≢y ∘ flip trans x≡y)
  subst-∈FV x (lambda y e)  (lambda x′≢y p)        | no  _   = ⊎-map (Σ-map (lambda x′≢y) id) id (subst-∈FV x e p)
  subst-∈FV x (case e bs)   (case-head p)          = ⊎-map (Σ-map case-head id) id (subst-∈FV x e p)
  subst-∈FV x (case e bs)   (case-body p ps x′∉xs) = ⊎-map (Σ-map (λ (p : ∃ λ _ → ∃ λ _ → ∃ λ _ → _ × _ × _) →
                                                                     let _ , _ , _ , ps , p , ∉ = p in
                                                                     case-body p ps ∉)
                                                                  id)
                                                           id
                                                           (subst-∈FV-B⋆ bs p ps x′∉xs)
  subst-∈FV x (rec y e)     p                      with x V.≟ y
  subst-∈FV x (rec y e)     (rec x′≢y p)           | yes x≡y = inj₁ (rec x′≢y p , x′≢y ∘ flip trans x≡y)
  subst-∈FV x (rec y e)     (rec x′≢y p)           | no  x≢y = ⊎-map (Σ-map (rec x′≢y) id) id (subst-∈FV x e p)
  subst-∈FV x (var y)       p                      with x V.≟ y
  subst-∈FV x (var y)       p                      | yes x≡y = inj₂ p
  subst-∈FV x (var y)       (var x′≡y)             | no  x≢y = inj₁ (var x′≡y , x≢y ∘ flip trans x′≡y ∘ sym)
  subst-∈FV x (const c es)  (const p ps)           = ⊎-map (Σ-map (λ { (_ , ps , p) → const p ps }) id) id
                                                           (subst-∈FV-⋆ es p ps)

  subst-∈FV-⋆ : ∀ {x x′ e e′} es →
                x′ ∈FV e → e ∈ es [ x ← e′ ]⋆ →
                (∃ λ e → e ∈ es × x′ ∈FV e) × x′ ≢ x ⊎ x′ ∈FV e′
  subst-∈FV-⋆ []       p ()
  subst-∈FV-⋆ (e ∷ es) p (inj₁ refl) = ⊎-map (Σ-map (λ p → _ , inj₁ refl , p) id) id (subst-∈FV _ e p)
  subst-∈FV-⋆ (e ∷ es) p (inj₂ q)    = ⊎-map (Σ-map (Σ-map id (Σ-map inj₂ id)) id) id (subst-∈FV-⋆ es p q)

  subst-∈FV-B⋆ : ∀ {x x′ e e′ c xs} bs →
                 x′ ∈FV e → branch c xs e ∈ bs [ x ← e′ ]B⋆ → ¬ x′ ∈ xs →
                 (∃ λ c → ∃ λ xs → ∃ λ e →
                    branch c xs e ∈ bs × x′ ∈FV e × ¬ x′ ∈ xs) × x′ ≢ x
                   ⊎
                 x′ ∈FV e′
  subst-∈FV-B⋆     []                   p ()
  subst-∈FV-B⋆ {x} (branch c xs e ∷ bs) p (inj₁ eq)   q with V.member x xs
  subst-∈FV-B⋆ {x} (branch c xs e ∷ bs) p (inj₁ refl) q | yes x∈xs = inj₁ ((c , xs , e , inj₁ refl , p , q) , λ x′≡x →
                                                                       q (subst (_∈ _) (sym x′≡x) x∈xs))
  subst-∈FV-B⋆ {x} (branch c xs e ∷ bs) p (inj₁ refl) q | no  x∉xs = ⊎-map (Σ-map (λ p → _ , _ , _ , inj₁ refl , p , q) id)
                                                                           id
                                                                           (subst-∈FV _ e p)
  subst-∈FV-B⋆     (b             ∷ bs) p (inj₂ ps)   q =
    ⊎-map (Σ-map (Σ-map _ (Σ-map _ (Σ-map _ (Σ-map inj₂ id)))) id) id
      (subst-∈FV-B⋆ bs p ps q)

------------------------------------------------------------------------
-- Various closure properties (or similar properties) for Closed′

Closed′-closed-under-apply :
  ∀ {xs e₁ e₂} →
  Closed′ xs e₁ → Closed′ xs e₂ → Closed′ xs (apply e₁ e₂)
Closed′-closed-under-apply = curry $ _≃_.from Closed′-apply≃

Closed′-closed-under-lambda :
  ∀ {x xs e} →
  Closed′ (x ∷ xs) e → Closed′ xs (lambda x e)
Closed′-closed-under-lambda = _≃_.from Closed′-lambda≃

Closed′-closed-under-rec :
  ∀ {x xs e} →
  Closed′ (x ∷ xs) e → Closed′ xs (rec x e)
Closed′-closed-under-rec = _≃_.from Closed′-rec≃

Closed′-closed-under-case :
  ∀ {xs e bs} →
  Closed′ xs e →
  (∀ {c ys e} → branch c ys e ∈ bs → Closed′ (ys ++ xs) e) →
  Closed′ xs (case e bs)
Closed′-closed-under-case = curry $ _≃_.from Closed′-case≃

Closed′-closed-under-const :
  ∀ {xs c es} →
  (∀ e → e ∈ es → Closed′ xs e) →
  Closed′ xs (const c es)
Closed′-closed-under-const = _≃_.from Closed′-const≃

Closed′-closed-under-var : ∀ {x xs} → x ∈ xs → Closed′ xs (var x)
Closed′-closed-under-var = _≃_.from Closed′-var≃ ∘ T.∣_∣

Closed′-closed-under-subst :
  ∀ {x xs e e′} →
  Closed′ (x ∷ xs) e →
  Closed′ xs e′ →
  Closed′ xs (e [ x ← e′ ])
Closed′-closed-under-subst cl-e cl-e′ y y∉xs =
  [ uncurry (λ y∈e y≢x → cl-e y [ y≢x , y∉xs ] y∈e)
  , cl-e′ y y∉xs
  ] ∘ subst-∈FV _ _

------------------------------------------------------------------------
-- Computing free or fresh variables

-- One can construct a finite set containing exactly the free
-- variables in a term.

mutual

  free :
    (e : Exp) →
    ∃ λ (fs : Finite-subset-of Var) → ∀ x → (x S.∈ fs) ⇔ (x ∈FV e)
  free (apply e₁ e₂) =
    Σ-zip S._∪_
      (λ {fs₁ fs₂} hyp₁ hyp₂ x →
         x S.∈ fs₁ S.∪ fs₂          ↔⟨ S.∈∪≃ ⟩
         x S.∈ fs₁ T.∥⊎∥ x S.∈ fs₂  ↝⟨ T.Dec→∥∥⇔ (Dec-⊎ (S.member? _≟V₁_ _ _)
                                                        (S.member? _≟V₁_ _ _)) ⟩
         x S.∈ fs₁ ⊎ x S.∈ fs₂      ↝⟨ hyp₁ x ⊎-cong hyp₂ x ⟩
         x ∈FV e₁ ⊎ x ∈FV e₂        ↔⟨ inverse ∈apply ⟩□
         x ∈FV apply e₁ e₂          □)
      (free e₁) (free e₂)
  free (lambda x e) =
    Σ-map (S.delete _≟V₂_ x)
      (λ {fs} hyp y →
         y S.∈ S.delete _≟V₂_ x fs  ↔⟨ S.∈delete≃ _≟V₂_ ⟩
         y ≢ x × y S.∈ fs           ↝⟨ (∃-cong λ _ → hyp y) ⟩
         y ≢ x × y ∈FV e            ↔⟨ inverse ∈lambda ⟩□
         y ∈FV lambda x e           □)
      (free e)
  free (case e bs) =
    Σ-zip S._∪_
      (λ {fs₁ fs₂} hyp₁ hyp₂ x →
         x S.∈ fs₁ S.∪ fs₂                              ↔⟨ S.∈∪≃ ⟩

         x S.∈ fs₁ T.∥⊎∥ x S.∈ fs₂                      ↝⟨ T.Dec→∥∥⇔ (Dec-⊎ (S.member? _≟V₁_ _ _)
                                                                            (S.member? _≟V₁_ _ _)) ⟩

         x S.∈ fs₁ ⊎ x S.∈ fs₂                          ↝⟨ hyp₁ x ⊎-cong hyp₂ x ⟩

         (x ∈FV e ⊎
          ∃ λ c → ∃ λ xs → ∃ λ e′ →
            x ∈FV e′ × branch c xs e′ ∈ bs × ¬ x ∈ xs)  ↔⟨ inverse ∈case ⟩□

         x ∈FV case e bs                                □)
      (free e) (free-B⋆ bs)
  free (rec x e) =
    Σ-map (S.delete _≟V₂_ x)
      (λ {fs} hyp y →
         y S.∈ S.delete _≟V₂_ x fs  ↔⟨ S.∈delete≃ _≟V₂_ ⟩
         y ≢ x × y S.∈ fs           ↝⟨ (∃-cong λ _ → hyp y) ⟩
         y ≢ x × y ∈FV e            ↔⟨ inverse ∈rec ⟩□
         y ∈FV rec x e              □)
      (free e)
  free (var x) =
      S.singleton x
    , λ y →
        y S.∈ S.singleton x  ↔⟨ S.∈singleton≃ ⟩
        T.∥ y ≡ x ∥          ↔⟨ T.∥∥↔ V.Name-set ⟩
        y ≡ x                ↔⟨ inverse ∈var ⟩□
        y ∈FV var x          □
  free (const c es) =
    Σ-map id
      (λ {fs} hyp x →
         x S.∈ fs                    ↝⟨ hyp x ⟩
         (∃ λ e → x ∈FV e × e ∈ es)  ↔⟨ inverse ∈const ⟩□
         x ∈FV const c es            □)
      (free-⋆ es)

  free-⋆ :
    (es : List Exp) →
    ∃ λ (fs : Finite-subset-of Var) →
      ∀ x → (x S.∈ fs) ⇔ (∃ λ e → x ∈FV e × e ∈ es)
  free-⋆ [] =
      S.[]
    , λ x →
        x S.∈ S.[]                  ↔⟨ S.∈[]≃ ⟩
        ⊥                           ↔⟨ inverse ×-right-zero ⟩
        Exp × ⊥₀                    ↔⟨ (∃-cong λ _ → inverse ×-right-zero) ⟩
        (∃ λ e → x ∈FV e × ⊥)       ↔⟨⟩
        (∃ λ e → x ∈FV e × e ∈ [])  □
  free-⋆ (e ∷ es) =
    Σ-zip S._∪_
      (λ {fs₁ fs₂} hyp₁ hyp₂ x →
         x S.∈ fs₁ S.∪ fs₂                                            ↔⟨ S.∈∪≃ ⟩
         x S.∈ fs₁ T.∥⊎∥ x S.∈ fs₂                                    ↝⟨ T.Dec→∥∥⇔ (Dec-⊎ (S.member? _≟V₁_ _ _)
                                                                                (S.member? _≟V₁_ _ _)) ⟩
         x S.∈ fs₁ ⊎ x S.∈ fs₂                                        ↝⟨ hyp₁ x ⊎-cong hyp₂ x ⟩
         x ∈FV e ⊎ (∃ λ e′ → x ∈FV e′ × e′ ∈ es)                      ↔⟨ inverse $
                                                                         (drop-⊤-right λ _ → _⇔_.to contractible⇔↔⊤ $
                                                                          singleton-contractible _)
                                                                           ⊎-cong
                                                                         F.id ⟩
         x ∈FV e × (∃ λ e′ → e′ ≡ e) ⊎ (∃ λ e′ → x ∈FV e′ × e′ ∈ es)  ↔⟨ ∃-comm ⊎-cong F.id ⟩
         (∃ λ e′ → x ∈FV e × e′ ≡ e) ⊎ (∃ λ e′ → x ∈FV e′ × e′ ∈ es)  ↔⟨ inverse ∃-⊎-distrib-left ⟩
         (∃ λ e′ → (x ∈FV e × e′ ≡ e) ⊎ (x ∈FV e′ × e′ ∈ es))         ↔⟨ (∃-cong λ _ →
                                                                          (×-cong₁ λ e′≡e → ≡⇒↝ equivalence $ cong (_ ∈FV_) $ sym
                                                                           e′≡e)
                                                                            ⊎-cong
                                                                          F.id) ⟩
         (∃ λ e′ → (x ∈FV e′ × e′ ≡ e) ⊎ (x ∈FV e′ × e′ ∈ es))        ↔⟨ (∃-cong λ _ → inverse ×-⊎-distrib-left) ⟩
         (∃ λ e′ → x ∈FV e′ × (e′ ≡ e ⊎ e′ ∈ es))                     ↔⟨⟩
         (∃ λ e′ → x ∈FV e′ × e′ ∈ e ∷ es)                            □)
      (free e) (free-⋆ es)

  free-B :
    (b : Br) →
    ∃ λ (fs : Finite-subset-of Var) →
      ∀ x →
      (x S.∈ fs) ⇔
      (∃ λ c → ∃ λ xs → ∃ λ e →
         x ∈FV e × branch c xs e ≡ b × ¬ x ∈ xs)
  free-B (branch c xs e) =
    Σ-map (λ fs → S.minus _≟V₂_ fs (S.from-List xs))
      (λ {fs} hyp x →
         x S.∈ S.minus _≟V₂_ fs (S.from-List xs)                       ↔⟨ S.∈minus≃ ⟩

         x S.∈ fs × x S.∉ S.from-List xs                               ↔⟨ (∃-cong λ _ → ¬-cong ext $ inverse
                                                                           S.∥∈∥≃∈-from-List) ⟩

         x S.∈ fs × ¬ T.∥ x ∈ xs ∥                                     ↔⟨ (∃-cong λ _ → T.¬∥∥↔¬) ⟩

         x S.∈ fs × ¬ x ∈ xs                                           ↝⟨ hyp x ×-cong F.id ⟩

         x ∈FV e × ¬ x ∈ xs                                            ↔⟨ (inverse $ drop-⊤-right λ _ →
                                                                           ×-left-identity F.∘ ×-left-identity) ⟩

         (x ∈FV e × ¬ x ∈ xs) × ⊤ × ⊤ × ⊤                              ↔⟨ (∃-cong λ _ → inverse $
                                                                           (_⇔_.to contractible⇔↔⊤ $ singleton-contractible _)
                                                                             ×-cong
                                                                           (_⇔_.to contractible⇔↔⊤ $ singleton-contractible _)
                                                                             ×-cong
                                                                           (_⇔_.to contractible⇔↔⊤ $ singleton-contractible _)) ⟩
         (x ∈FV e × ¬ x ∈ xs) ×
         (∃ λ c′ → c′ ≡ c) × (∃ λ xs′ → xs′ ≡ xs) × (∃ λ e′ → e′ ≡ e)  ↔⟨ (∃-cong λ _ →
                                                                           (∃-cong λ _ →
                                                                            (∃-cong λ _ →
                                                                             ∃-comm F.∘
                                                                             (∃-cong λ _ → ∃-comm)) F.∘
                                                                            ∃-comm F.∘
                                                                            (∃-cong λ _ → inverse Σ-assoc)) F.∘
                                                                           inverse Σ-assoc) ⟩
         (x ∈FV e × ¬ x ∈ xs) ×
         (∃ λ c′ → ∃ λ xs′ → ∃ λ e′ → c′ ≡ c × xs′ ≡ xs × e′ ≡ e)      ↔⟨ (∃-cong λ _ → ∃-cong λ _ → ∃-comm) F.∘
                                                                          (∃-cong λ _ → ∃-comm) F.∘
                                                                          ∃-comm ⟩
         (∃ λ c′ → ∃ λ xs′ → ∃ λ e′ →
            (x ∈FV e × ¬ x ∈ xs) × (c′ ≡ c × xs′ ≡ xs × e′ ≡ e))       ↔⟨ (∃-cong λ _ → ∃-cong λ _ → ∃-cong λ _ →
                                                                           (∃-cong λ _ → ×-comm) F.∘
                                                                           inverse Σ-assoc) ⟩
         (∃ λ c′ → ∃ λ xs′ → ∃ λ e′ →
            x ∈FV e × (c′ ≡ c × xs′ ≡ xs × e′ ≡ e) × ¬ x ∈ xs)         ↝⟨ (∃-cong λ _ → ∃-cong λ _ → ∃-cong λ _ → ∃-cong λ _ →
                                                                           ∃-cong λ (_ , xs′≡xs , _) → ≡⇒↝ _ $ cong (¬_ ∘ (_ ∈_)) $ sym
                                                                           xs′≡xs) ⟩
         (∃ λ c′ → ∃ λ xs′ → ∃ λ e′ →
            x ∈FV e × (c′ ≡ c × xs′ ≡ xs × e′ ≡ e) × ¬ x ∈ xs′)        ↝⟨ (∃-cong λ _ → ∃-cong λ _ → ∃-cong λ _ →
                                                                           ×-cong₁ λ ((_ , _ , e′≡e) , _) → ≡⇒↝ _ $ cong (_ ∈FV_) $ sym
                                                                           e′≡e) ⟩
         (∃ λ c′ → ∃ λ xs′ → ∃ λ e′ →
            x ∈FV e′ × (c′ ≡ c × xs′ ≡ xs × e′ ≡ e) × ¬ x ∈ xs′)       ↝⟨ (∃-cong λ _ → ∃-cong λ _ → ∃-cong λ _ → ∃-cong λ _ → ×-cong₁ λ _ →
                                                                           lemma) ⟩□
         (∃ λ c′ → ∃ λ xs′ → ∃ λ e′ →
            x ∈FV e′ × branch c′ xs′ e′ ≡ branch c xs e × ¬ x ∈ xs′)   □)
      (free e)
    where
    lemma :
      c′ ≡ c × xs′ ≡ xs × e′ ≡ e ⇔ branch c′ xs′ e′ ≡ branch c xs e
    lemma ._⇔_.to (c′≡c , xs′≡xs , e′≡e) =
      cong₂ (uncurry branch) (cong₂ _,_ c′≡c xs′≡xs) e′≡e
    lemma ._⇔_.from eq =
        cong (λ { (branch c _ _)  → c  }) eq
      , cong (λ { (branch _ xs _) → xs }) eq
      , cong (λ { (branch _ _ e)  → e  }) eq

  free-B⋆ :
    (bs : List Br) →
    ∃ λ (fs : Finite-subset-of Var) →
      ∀ x →
      (x S.∈ fs) ⇔
      (∃ λ c → ∃ λ xs → ∃ λ e →
         x ∈FV e × branch c xs e ∈ bs × ¬ x ∈ xs)
  free-B⋆ [] =
      S.[]
    , λ x →
        x S.∈ S.[]                                         ↔⟨ S.∈[]≃ ⟩

        ⊥                                                  ↔⟨ (inverse $
                                                               ×-right-zero {ℓ₁ = lzero} F.∘
                                                               ∃-cong λ _ →
                                                               ×-right-zero {ℓ₁ = lzero} F.∘
                                                               ∃-cong λ _ →
                                                               ×-right-zero {ℓ₁ = lzero} F.∘
                                                               ∃-cong λ _ →
                                                               ×-right-zero {ℓ₁ = lzero} F.∘
                                                               ∃-cong λ _ →
                                                               ×-left-zero) ⟩
        Const × (∃ λ xs → ∃ λ e → x ∈FV e × ⊥ × ¬ x ∈ xs)  ↔⟨⟩

        (∃ λ c → ∃ λ xs → ∃ λ e →
           x ∈FV e × branch c xs e ∈ [] × ¬ x ∈ xs)        □
  free-B⋆ (b ∷ bs) =
    Σ-zip S._∪_
      (λ {fs₁ fs₂} hyp₁ hyp₂ x →
         x S.∈ fs₁ S.∪ fs₂                                ↔⟨ S.∈∪≃ ⟩

         x S.∈ fs₁ T.∥⊎∥ x S.∈ fs₂                        ↝⟨ T.Dec→∥∥⇔ (Dec-⊎ (S.member? _≟V₁_ _ _)
                                                                              (S.member? _≟V₁_ _ _)) ⟩

         x S.∈ fs₁ ⊎ x S.∈ fs₂                            ↝⟨ hyp₁ x ⊎-cong hyp₂ x ⟩

         (∃ λ c → ∃ λ xs → ∃ λ e →
            x ∈FV e × branch c xs e ≡ b × ¬ x ∈ xs) ⊎
         (∃ λ c → ∃ λ xs → ∃ λ e →
            x ∈FV e × branch c xs e ∈ bs × ¬ x ∈ xs)      ↔⟨ (inverse $
                                                              ∃-⊎-distrib-left F.∘
                                                              ∃-cong λ _ →
                                                              ∃-⊎-distrib-left F.∘
                                                              ∃-cong λ _ →
                                                              ∃-⊎-distrib-left F.∘
                                                              ∃-cong λ _ →
                                                              ∃-⊎-distrib-left F.∘
                                                              ∃-cong λ _ →
                                                              ∃-⊎-distrib-right) ⟩
         (∃ λ c → ∃ λ xs → ∃ λ e →
            x ∈FV e ×
            (branch c xs e ≡ b ⊎ branch c xs e ∈ bs) ×
            ¬ x ∈ xs)                                     ↔⟨⟩

         (∃ λ c → ∃ λ xs → ∃ λ e →
            x ∈FV e × branch c xs e ∈ b ∷ bs × ¬ x ∈ xs)  □)
      (free-B b) (free-B⋆ bs)

-- It is possible to find a variable that is neither free in a given
-- expression, nor a member of a given finite set.

fresh′ :
  (xs : Finite-subset-of Var) (e : Exp) →
  ∃ λ (x : Var) → ¬ x ∈FV e × x S.∉ xs
fresh′ xs e =
  Σ-map id
    (λ {x} →
       x S.∉ proj₁ (free e) S.∪ xs              ↔⟨ ¬-cong ext S.∈∪≃ ⟩
       ¬ (x S.∈ proj₁ (free e) T.∥⊎∥ x S.∈ xs)  ↔⟨ T.¬∥∥↔¬ ⟩
       ¬ (x S.∈ proj₁ (free e) ⊎ x S.∈ xs)      ↝⟨ ¬⊎↔¬×¬ _ ⟩
       x S.∉ proj₁ (free e) × x S.∉ xs          ↔⟨ ¬-cong-⇔ ext (proj₂ (free e) x) ×-cong F.id ⟩□
       ¬ x ∈FV e × x S.∉ xs                     □)
    (V.fresh (proj₁ (free e) S.∪ xs))

-- It is possible to find a variable that is not free in a given
-- expression.

fresh : (e : Exp) → ∃ λ (x : Var) → ¬ x ∈FV e
fresh e = Σ-map id proj₁ (fresh′ S.[] e)

-- If two expressions have the same free variables (ignoring any
-- variables in xs), then fresh′ xs returns the same fresh variable
-- for both expressions.

fresh′-unique :
  (∀ x → x S.∉ xs → x ∈FV e₁ ⇔ x ∈FV e₂) →
  proj₁ (fresh′ xs e₁) ≡ proj₁ (fresh′ xs e₂)
fresh′-unique {xs = xs} {e₁ = e₁} {e₂ = e₂} same =
  proj₁ (V.fresh (proj₁ (free e₁) S.∪ xs))  ≡⟨ (cong (proj₁ ∘ V.fresh) $
                                                _≃_.from S.extensionality λ x →
      x S.∈ proj₁ (free e₁) S.∪ xs                ↝⟨ lemma x e₁ ⟩
      x S.∉ xs × x ∈FV e₁ T.∥⊎∥ x S.∈ xs          ↝⟨ ∃-cong (same x) T.∥⊎∥-cong F.id ⟩
      x S.∉ xs × x ∈FV e₂ T.∥⊎∥ x S.∈ xs          ↝⟨ inverse $ lemma x e₂ ⟩□
      x S.∈ proj₁ (free e₂) S.∪ xs                □) ⟩∎

  proj₁ (V.fresh (proj₁ (free e₂) S.∪ xs))  ∎
  where
  lemma : ∀ _ _ → _ ⇔ _
  lemma x e =
    x S.∈ proj₁ (free e) S.∪ xs          ↔⟨ S.∈∪≃ ⟩
    x S.∈ proj₁ (free e) T.∥⊎∥ x S.∈ xs  ↝⟨ proj₂ (free e) x T.∥⊎∥-cong F.id ⟩
    x ∈FV e T.∥⊎∥ x S.∈ xs               ↔⟨ T.∥⊎∥≃¬×∥⊎∥ $ T.Dec→Dec-∥∥ $ S.member? _≟V₁_ x xs ⟩□
    x S.∉ xs × x ∈FV e T.∥⊎∥ x S.∈ xs    □

-- If two expressions have the same free variables, then fresh returns
-- the same fresh variable for both expressions.

fresh-unique :
  (∀ x → x ∈FV e₁ ⇔ x ∈FV e₂) →
  proj₁ (fresh e₁) ≡ proj₁ (fresh e₂)
fresh-unique same = fresh′-unique (λ x _ → same x)

------------------------------------------------------------------------
-- Decision procedures

-- These decision procedures could presumably be implemented using
-- free.

-- The free variable relation, _∈FV_, is decidable.

mutual

  _∈?_ : ∀ x e → Dec (x ∈FV e)
  x ∈? apply e₁ e₂ with x ∈? e₁
  x ∈? apply e₁ e₂ | yes x∈e₁ = yes (apply-left x∈e₁)
  x ∈? apply e₁ e₂ | no x∉e₁  = ⊎-map apply-right
                                      (λ x∉e₂ → λ { (apply-left  x∈e₁) → x∉e₁ x∈e₁
                                                  ; (apply-right x∈e₂) → x∉e₂ x∈e₂
                                                  })
                                      (x ∈? e₂)
  x ∈? lambda y e  with x V.≟ y
  x ∈? lambda y e  | yes x≡y = no (λ { (lambda x≢y _) → x≢y x≡y })
  x ∈? lambda y e  | no  x≢y = ⊎-map (lambda x≢y)
                                     (λ x∉e → λ { (lambda _ x∈e) → x∉e x∈e })
                                     (x ∈? e)
  x ∈? rec y e     with x V.≟ y
  x ∈? rec y e     | yes x≡y = no (λ { (rec x≢y _) → x≢y x≡y })
  x ∈? rec y e     | no  x≢y = ⊎-map (rec x≢y)
                                     (λ x∉e → λ { (rec _ x∈e) → x∉e x∈e })
                                     (x ∈? e)
  x ∈? var y       with x V.≟ y
  x ∈? var y       | yes x≡y = yes (var x≡y)
  x ∈? var y       | no  x≢y = no (λ { (var x≡y) → x≢y x≡y })
  x ∈? const c es  = ⊎-map (λ { (_ , e∈es , x∈e) → const x∈e e∈es })
                           (λ x∉es → λ { (const x∈e e∈es) →
                                         x∉es (_ , e∈es , x∈e) })
                           (x ∈?-⋆ es)
  x ∈? case e bs   with x ∈? e
  x ∈? case e bs   | yes x∈e = yes (case-head x∈e)
  x ∈? case e bs   | no  x∉e = ⊎-map (λ { (_ , _ , _ , xs→e∈bs , x∈e , x∉xs) →
                                            case-body x∈e xs→e∈bs x∉xs })
                                     (λ x∉bs → λ { (case-head x∈e)              → x∉e x∈e
                                                 ; (case-body x∈e xs→e∈bs x∉xs) →
                                                     x∉bs (_ , _ , _ , xs→e∈bs , x∈e , x∉xs)
                                                 })
                                     (x ∈?-B⋆ bs)

  _∈?-⋆_ : ∀ x es → Dec (∃ λ e → e ∈ es × x ∈FV e)
  x ∈?-⋆ []       = no (λ { (_ , () , _) })
  x ∈?-⋆ (e ∷ es) with x ∈? e
  x ∈?-⋆ (e ∷ es) | yes x∈e = yes (_ , inj₁ refl , x∈e)
  x ∈?-⋆ (e ∷ es) | no  x∉e =
    ⊎-map (Σ-map id (Σ-map inj₂ id))
          (λ x∉es → λ { (_ , inj₁ refl , x∈e) → x∉e x∈e
                      ; (_ , inj₂ e∈es , x∈e) → x∉es (_ , e∈es , x∈e)
                      })
          (x ∈?-⋆ es)

  _∈?-B⋆_ :
    ∀ x bs →
    Dec (∃ λ c → ∃ λ xs → ∃ λ e →
           branch c xs e ∈ bs × x ∈FV e × ¬ x ∈ xs)
  x ∈?-B⋆ []                   = no λ { (_ , _ , _ , () , _) }

  x ∈?-B⋆ (branch c xs e ∷ bs) with x ∈?-B⋆ bs
  x ∈?-B⋆ (branch c xs e ∷ bs) | yes x∈bs =
    yes (Σ-map id (Σ-map id (Σ-map id (Σ-map inj₂ id))) x∈bs)

  x ∈?-B⋆ (branch c xs e ∷ bs) | no  x∉bs with V.member x xs
  x ∈?-B⋆ (branch c xs e ∷ bs) | no  x∉bs | yes x∈xs =
    no (λ { (_ , _ , _ , inj₁ refl , _   , x∉xs) → x∉xs x∈xs
          ; (_ , _ , _ , inj₂ e∈es , x∈e , x∉xs) →
              x∉bs (_ , _ , _ , e∈es , x∈e , x∉xs)
          })

  x ∈?-B⋆ (branch c xs e ∷ bs) | no  x∉bs | no  x∉xs =
    ⊎-map (λ x∈e → _ , _ , _ , inj₁ refl , x∈e , x∉xs)
          (λ x∉e → λ { (_ , _ , _ , inj₁ refl , x∈e , _)    → x∉e x∈e
                     ; (_ , _ , _ , inj₂ e∈es , x∈e , x∉xs) →
                         x∉bs (_ , _ , _ , e∈es , x∈e , x∉xs)
                     })
          (x ∈? e)

-- The Closed′ relation is decidable.

mutual

  closed′? : ∀ e xs → Dec (Closed′ xs e)
  closed′? (apply e₁ e₂) xs with closed′? e₁ xs
  closed′? (apply e₁ e₂) xs | no ¬cl₁ = no (¬cl₁ ∘ (λ cl₁ x x∉xs → cl₁ x x∉xs ∘ apply-left))
  closed′? (apply e₁ e₂) xs | yes cl₁ = ⊎-map (Closed′-closed-under-apply cl₁)
                                              (_∘ (λ cl₂ x x∉xs → cl₂ x x∉xs ∘ apply-right))
                                              (closed′? e₂ xs)
  closed′? (lambda x e)  xs = ⊎-map Closed′-closed-under-lambda
                                    (λ ¬cl cl → ¬cl (λ y y∉x∷xs y∈e → cl y (y∉x∷xs ∘ inj₂)
                                                                           (lambda (y∉x∷xs ∘ inj₁) y∈e)))
                                    (closed′? e (x ∷ xs))
  closed′? (rec x e)     xs = ⊎-map Closed′-closed-under-rec
                                    (λ ¬cl cl → ¬cl (λ y y∉x∷xs y∈e → cl y (y∉x∷xs ∘ inj₂)
                                                                           (rec (y∉x∷xs ∘ inj₁) y∈e)))
                                    (closed′? e (x ∷ xs))
  closed′? (var x)       xs = ⊎-map Closed′-closed-under-var
                                    (λ x∉xs cl → cl x x∉xs (var refl))
                                    (V.member x xs)
  closed′? (const c es)  xs = ⊎-map Closed′-closed-under-const
                                    (λ ¬cl cl → ¬cl (λ _ e∈es x x∉xs x∈e →
                                                       cl x x∉xs (const x∈e e∈es)))
                                    (closed′?-⋆ es xs)
  closed′? (case e bs)   xs with closed′? e xs
  closed′? (case e bs)   xs | no  ¬cl-e = no (λ cl → ¬cl-e (λ x x∉xs →
                                                              cl x x∉xs ∘ case-head))
  closed′? (case e bs)   xs | yes cl-e  =
    ⊎-map (Closed′-closed-under-case cl-e)
          (λ ¬cl-bs cl → ¬cl-bs (λ b∈bs x x∉ys++xs x∈e →
             let ¬[x∈ys⊎x∈xs] = x∉ys++xs ∘ _↔_.from (B.Any-++ _ _ _) in
             cl x (¬[x∈ys⊎x∈xs] ∘ inj₂)
               (case-body x∈e b∈bs (¬[x∈ys⊎x∈xs] ∘ inj₁))))
          (closed′?-B⋆ bs xs)

  closed′?-⋆ : ∀ es xs → Dec (∀ e → e ∈ es → Closed′ xs e)
  closed′?-⋆ []       xs = yes (λ _ ())
  closed′?-⋆ (e ∷ es) xs with closed′? e xs
  closed′?-⋆ (e ∷ es) xs | no  ¬cl-e = no (λ cl →
                                             ¬cl-e (cl _ (inj₁ refl)))
  closed′?-⋆ (e ∷ es) xs | yes cl-e  =
    ⊎-map (λ cl-es e → [ (λ e′≡e x x∉xs → subst (λ e → ¬ x ∈FV e)
                                                (sym e′≡e)
                                                (cl-e x x∉xs))
                       , cl-es e
                       ])
          (λ ¬cl-es cl → ¬cl-es (λ e → cl e ∘ inj₂))
          (closed′?-⋆ es xs)

  closed′?-B⋆ :
    ∀ bs xs →
    Dec (∀ {c ys e} → branch c ys e ∈ bs → Closed′ (ys ++ xs) e)
  closed′?-B⋆ []                   xs = yes (λ ())

  closed′?-B⋆ (branch c ys e ∷ bs) xs with closed′?-B⋆ bs xs
  closed′?-B⋆ (branch c ys e ∷ bs) xs | no  ¬cl-bs =
    no (λ cl → ¬cl-bs (cl ∘ inj₂))

  closed′?-B⋆ (branch c ys e ∷ bs) xs | yes cl-bs  =
    ⊎-map (λ cl-e {c′} {ys′} {e′} →
             [ (λ b′≡b x x∉ys++xs′ x∈e′ →
                  cl-e x (subst (λ ys → ¬ x ∈ ys ++ xs) (ys-lemma b′≡b)
                                x∉ys++xs′)
                         (subst (x ∈FV_) (e-lemma b′≡b) x∈e′))
             , cl-bs
             ])
          (λ ¬cl-e cl → ¬cl-e (cl (inj₁ refl)))
          (closed′? e (ys ++ xs))
    where
    e-lemma :
      ∀ {c ys e c′ ys′ e′} →
      branch c ys e ≡ branch c′ ys′ e′ → e ≡ e′
    e-lemma refl = refl

    ys-lemma :
      ∀ {c ys e c′ ys′ e′} →
      branch c ys e ≡ branch c′ ys′ e′ → ys ≡ ys′
    ys-lemma refl = refl

-- The Closed relation is decidable.

closed? : ∀ e → Dec (Closed e)
closed? e = closed′? e []

------------------------------------------------------------------------
-- Substituting something for a variable that is not free

-- If x is not free in e, then nothing happens when a term is
-- substituted for x in e.

mutual

  subst-∉ : ∀ x e {e′} → ¬ x ∈FV e → e [ x ← e′ ] ≡ e
  subst-∉ x (apply e₁ e₂) x∉ = cong₂ apply (subst-∉ x e₁ (x∉ ∘ apply-left))
                                           (subst-∉ x e₂ (x∉ ∘ apply-right))
  subst-∉ x (lambda y e)  x∉ with x V.≟ y
  subst-∉ x (lambda y e)  x∉ | yes _   = refl
  subst-∉ x (lambda y e)  x∉ | no  x≢y = cong (lambda y) (subst-∉ x e (x∉ ∘ lambda x≢y))
  subst-∉ x (case e bs)   x∉ = cong₂ case (subst-∉ x e (x∉ ∘ case-head))
                                          (subst-∉-B⋆ x bs _ (λ { (_ , _ , _ , ∈bs , x∈ , x∉xs) →
                                                                  x∉ (case-body x∈ ∈bs x∉xs) }))
  subst-∉ x (rec y e)     x∉ with x V.≟ y
  subst-∉ x (rec y e)     x∉ | yes _   = refl
  subst-∉ x (rec y e)     x∉ | no  x≢y = cong (rec y) (subst-∉ x e (x∉ ∘ rec x≢y))
  subst-∉ x (var y)       x∉ with x V.≟ y
  subst-∉ x (var y)       x∉ | yes x≡y = ⊥-elim (x∉ (var x≡y))
  subst-∉ x (var y)       x∉ | no  _   = refl
  subst-∉ x (const c es)  x∉ = cong (const c) (subst-∉-⋆ x es
                                                 (x∉ ∘ (λ { (_ , ps , p) → const p ps })))

  subst-∉-⋆ :
    ∀ x es {e′} →
    ¬ (∃ λ e → e ∈ es × x ∈FV e) →
    es [ x ← e′ ]⋆ ≡ es
  subst-∉-⋆ x []       x∉ = refl
  subst-∉-⋆ x (e ∷ es) x∉ = cong₂ _∷_ (subst-∉ x e (λ x∈ → x∉ (_ , inj₁ refl , x∈)))
                                      (subst-∉-⋆ x es (x∉ ∘ Σ-map id (Σ-map inj₂ id)))

  subst-∉-B⋆ :
    ∀ x bs e′ →
    ¬ (∃ λ c → ∃ λ xs → ∃ λ e →
         branch c xs e ∈ bs × x ∈FV e × ¬ x ∈ xs) →
    bs [ x ← e′ ]B⋆ ≡ bs
  subst-∉-B⋆ x []                   _ x∉ = refl
  subst-∉-B⋆ x (branch c xs e ∷ bs) _ x∉
    with V.member x xs
       | subst-∉-B⋆ x bs _
           (x∉ ∘ Σ-map id (Σ-map id (Σ-map id (Σ-map inj₂ id))))
  ... | yes x∈xs | eq = cong₂ _∷_ refl eq
  ... | no  x∉xs | eq = cong₂ (λ e bs → branch c xs e ∷ bs)
                              (subst-∉ x e λ x∈e →
                                 x∉ (_ , _ , _ , inj₁ refl , x∈e , x∉xs))
                              eq

-- If e is closed, then nothing happens when a term is substituted for
-- x in e.

subst-closed : ∀ x e′ {e} → Closed e → e [ x ← e′ ] ≡ e
subst-closed _ _ c = subst-∉ _ _ (c _ (λ ()))

-- An n-ary variant of the previous lemma.

substs-closed :
  ∀ e → Closed e → ∀ ps →
  foldr (λ ye → _[ proj₁ ye ← proj₂ ye ]) e ps ≡ e
substs-closed e cl []              = refl
substs-closed e cl ((y , e′) ∷ ps) =
  foldr (λ { (y , e) → _[ y ← e ] }) e ps [ y ← e′ ]  ≡⟨ cong _[ y ← e′ ] (substs-closed e cl ps) ⟩
  e [ y ← e′ ]                                        ≡⟨ subst-closed _ _ cl ⟩∎
  e                                                   ∎

------------------------------------------------------------------------
-- Evaluation and free variables

-- If a value contains a free variable, then every term that evaluates
-- to this value also contains the given free variable.

mutual

  ⇓-does-not-introduce-variables :
    ∀ {x v e} → e ⇓ v → x ∈FV v → x ∈FV e
  ⇓-does-not-introduce-variables lambda     q                = q
  ⇓-does-not-introduce-variables (const ps) (const x∈v v∈vs)
    with ⇓⋆-does-not-introduce-variables ps (_ , v∈vs , x∈v)
  ... | _ , e∈es , x∈e = const x∈e e∈es
  ⇓-does-not-introduce-variables (apply {e = e} p₁ p₂ p₃) q
    with subst-∈FV _ e (⇓-does-not-introduce-variables p₃ q)
  ... | inj₂ x∈v₂         = apply-right
                              (⇓-does-not-introduce-variables p₂ x∈v₂)
  ... | inj₁ (x∈e , x≢x′) = apply-left
                              (⇓-does-not-introduce-variables p₁
                                 (lambda x≢x′ x∈e))
  ⇓-does-not-introduce-variables (rec {e = e} p) q
    with subst-∈FV _ e (⇓-does-not-introduce-variables p q)
  ... | inj₂ x∈rec        = x∈rec
  ... | inj₁ (x∈e , x≢x′) = rec x≢x′ x∈e
  ⇓-does-not-introduce-variables {x} {w}
    (case {e = e} {bs = bs} {c = c} {es = es} {xs = xs} {e′ = e′} {e″ = e″} p₁ p₂ p₃ p₄) =

    x ∈FV w                                                   ↝⟨ ⇓-does-not-introduce-variables p₄ ⟩
    x ∈FV e″                                                  ↝⟨ lemma₁ p₃ ⟩
    (x ∈FV e′ × ¬ x ∈ xs) ⊎ ∃ (λ e″₁ → e″₁ ∈ es × x ∈FV e″₁)  ↝⟨ ⊎-map id (λ { (_ , ps , p) → const p ps }) ⟩
    (x ∈FV e′ × ¬ x ∈ xs) ⊎ x ∈FV const c es                  ↝⟨ ⊎-map (λ p → lemma₂ p₂ , p) (⇓-does-not-introduce-variables p₁) ⟩
    (branch c xs e′ ∈ bs × x ∈FV e′ × ¬ x ∈ xs) ⊎ x ∈FV e     ↝⟨ [ (λ { (ps , p , q) → case-body p ps q }) , case-head ] ⟩
    x ∈FV case e bs                                           □

    where
    lemma₁ : ∀ {e e′ x xs es} →
             e [ xs ← es ]↦ e′ → x ∈FV e′ →
             (x ∈FV e × ¬ x ∈ xs) ⊎ ∃ λ e″ → e″ ∈ es × x ∈FV e″
    lemma₁ {e′ = e′} {x} [] =
      x ∈FV e′                 ↝⟨ (λ p → inj₁ (p , (λ ()))) ⟩□
      x ∈FV e′ × ¬ x ∈ [] ⊎ _  □
    lemma₁ {e} {x = x}
           (∷_ {x = y} {xs = ys} {e′ = e′} {es′ = es′} {e″ = e″} p) =

      x ∈FV e″ [ y ← e′ ]                                           ↝⟨ subst-∈FV _ _ ⟩

      x ∈FV e″ × x ≢ y ⊎ x ∈FV e′                                   ↝⟨ ⊎-map (Σ-map (lemma₁ p) id) id ⟩

      (x ∈FV e × ¬ x ∈ ys ⊎ ∃ λ e‴ → e‴ ∈ es′ × x ∈FV e‴) × x ≢ y
        ⊎
      x ∈FV e′                                                      ↝⟨ [ uncurry (λ p x≢y → ⊎-map (Σ-map id (λ x∉ys → [ x≢y , x∉ys ]))
                                                                                (Σ-map id (Σ-map inj₂ id))
                                                                                p)
                                                                       , (λ p → inj₂ (_ , inj₁ refl , p))
                                                                       ] ⟩□
      x ∈FV e × ¬ x ∈ y ∷ ys ⊎ (∃ λ e″ → e″ ∈ e′ ∷ es′ × x ∈FV e″)  □

    lemma₂ : ∀ {c bs xs e} → Lookup c bs xs e → branch c xs e ∈ bs
    lemma₂ here        = inj₁ refl
    lemma₂ (there _ p) = inj₂ (lemma₂ p)

  ⇓⋆-does-not-introduce-variables :
    ∀ {x es vs} →
    es ⇓⋆ vs →
    (∃ λ v → v ∈ vs × x ∈FV v) →
    (∃ λ e → e ∈ es × x ∈FV e)
  ⇓⋆-does-not-introduce-variables [] = id
  ⇓⋆-does-not-introduce-variables (p ∷ ps) (v , inj₁ refl , q) =
    _ , inj₁ refl , ⇓-does-not-introduce-variables p q
  ⇓⋆-does-not-introduce-variables (p ∷ ps) (v , inj₂ v∈   , q) =
    Σ-map id (Σ-map inj₂ id)
      (⇓⋆-does-not-introduce-variables ps (v , v∈ , q))

-- A closed term's value is closed.

closed⇓closed : ∀ {e v xs} → e ⇓ v → Closed′ xs e → Closed′ xs v
closed⇓closed {e} {v} {xs} p q x x∉xs =
  x ∈FV v  ↝⟨ ⇓-does-not-introduce-variables p ⟩
  x ∈FV e  ↝⟨ q x x∉xs ⟩□
  ⊥        □

------------------------------------------------------------------------
-- More properties

-- A constructor for closed expressions.

apply-cl : Closed-exp → Closed-exp → Closed-exp
apply-cl (e₁ , cl-e₁) (e₂ , cl-e₂) =
    apply e₁ e₂
  , (Closed′-closed-under-apply
       (Closed→Closed′ cl-e₁)
       (Closed→Closed′ cl-e₂))

-- A certain "swapping" lemma does not hold.

no-swapping :
  ¬ (∀ x y e e′ e″ →
     x ≢ y →
     Closed e′ →
     Closed (e″ [ x ← e′ ]) →
     e [ x ← e′ ] [ y ← e″ [ x ← e′ ] ] ≡ e [ y ← e″ ] [ x ← e′ ])
no-swapping hyp = distinct (hyp x′ y′ e₁′ e₂′ e₃′ x≢y cl₁ cl₂)
  where
  x′ = V.name 0
  y′ = V.name 1

  e₁′ : Exp
  e₁′ = lambda x′ (var y′)

  e₂′ : Exp
  e₂′ = const (C.name 0) []

  e₃′ : Exp
  e₃′ = var x′

  x≢y : x′ ≢ y′
  x≢y = V.distinct-codes→distinct-names (λ ())

  cl₁ : Closed e₂′
  cl₁ = from-⊎ (closed? e₂′)

  cl₂ : Closed (e₃′ [ x′ ← e₂′ ])
  cl₂ with x′ V.≟ x′
  ... | no  x≢x = ⊥-elim (x≢x refl)
  ... | yes _   = cl₁

  lhs : e₁′ [ x′ ← e₂′ ] [ y′ ← e₃′ [ x′ ← e₂′ ] ] ≡ lambda x′ e₂′
  lhs with x′ V.≟ x′
  ... | no  x≢x = ⊥-elim (x≢x refl)
  ... | yes _   with y′ V.≟ x′
  ...   | yes y≡x = ⊥-elim (x≢y (sym y≡x))
  ...   | no  _   with y′ V.≟ y′
  ...     | no  y≢y = ⊥-elim (y≢y refl)
  ...     | yes _   = refl

  rhs : e₁′ [ y′ ← e₃′ ] [ x′ ← e₂′ ] ≡ lambda x′ (var x′)
  rhs with y′ V.≟ x′
  ... | yes y≡x = ⊥-elim (x≢y (sym y≡x))
  ... | no  _   with y′ V.≟ y′
  ...   | no  y≢y = ⊥-elim (y≢y refl)
  ...   | yes _   with x′ V.≟ x′
  ...     | no  x≢x = ⊥-elim (x≢x refl)
  ...     | yes _   = refl

  distinct : e₁′ [ x′ ← e₂′ ] [ y′ ← e₃′ [ x′ ← e₂′ ] ] ≢
             e₁′ [ y′ ← e₃′ ] [ x′ ← e₂′ ]
  distinct rewrite lhs | rhs = λ ()

-- Another swapping lemma does hold.

module _
  (x≢y  : x ≢ y)
  (x∉e″ : ¬ x ∈FV e″)
  (y∉e′ : ¬ y ∈FV e′)
  where

  mutual

    swap : ∀ e → e [ x ← e′ ] [ y ← e″ ] ≡ e [ y ← e″ ] [ x ← e′ ]
    swap (apply e₁ e₂) = cong₂ apply (swap e₁) (swap e₂)

    swap (lambda z e) with x V.≟ z | y V.≟ z
    … | yes _ | yes _ = refl
    … | yes _ | no  _ = refl
    … | no  _ | yes _ = refl
    … | no  _ | no  _ = cong (lambda z) (swap e)

    swap (case e bs) = cong₂ case (swap e) (swap-B⋆ bs)

    swap (rec z e) with x V.≟ z | y V.≟ z
    … | yes _ | yes _ = refl
    … | yes _ | no  _ = refl
    … | no  _ | yes _ = refl
    … | no  _ | no  _ = cong (rec z) (swap e)

    swap (var z) with x V.≟ z | y V.≟ z
    … | yes x≡z | yes y≡z =
      ⊥-elim $ x≢y (trans x≡z (sym y≡z))

    … | yes x≡z | no _ =
      e′ [ y ← e″ ]     ≡⟨ subst-∉ _ _ y∉e′ ⟩
      e′                ≡⟨ sym $ var-step-≡ x≡z ⟩∎
      var z [ x ← e′ ]  ∎

    … | no _ | yes y≡z =
      var z [ y ← e″ ]  ≡⟨ var-step-≡ y≡z ⟩
      e″                ≡⟨ sym $ subst-∉ _ _ x∉e″ ⟩∎
      e″ [ x ← e′ ]     ∎

    … | no x≢z | no y≢z =
      var z [ y ← e″ ]  ≡⟨ var-step-≢ y≢z ⟩
      var z             ≡⟨ sym $ var-step-≢ x≢z ⟩∎
      var z [ x ← e′ ]  ∎

    swap (const c es) = cong (const c) (swap-⋆ es)

    swap-B :
      ∀ b → b [ x ← e′ ]B [ y ← e″ ]B ≡ b [ y ← e″ ]B [ x ← e′ ]B
    swap-B (branch c zs e) with V.member x zs | V.member y zs
    … | yes x∈zs | yes y∈zs =
      branch c zs e [ y ← e″ ]B  ≡⟨ branch-step-∈ y∈zs ⟩
      branch c zs e              ≡⟨ sym $ branch-step-∈ x∈zs ⟩∎
      branch c zs e [ x ← e′ ]B  ∎

    … | yes x∈zs | no y∉zs =
      branch c zs e [ y ← e″ ]B               ≡⟨ branch-step-∉ y∉zs ⟩
      branch c zs (e [ y ← e″ ])              ≡⟨ sym $ branch-step-∈ x∈zs ⟩∎
      branch c zs (e [ y ← e″ ]) [ x ← e′ ]B  ∎

    … | no x∉zs | yes y∈zs =
      branch c zs (e [ x ← e′ ]) [ y ← e″ ]B  ≡⟨ branch-step-∈ y∈zs ⟩
      branch c zs (e [ x ← e′ ])              ≡⟨ sym $ branch-step-∉ x∉zs ⟩∎
      branch c zs e [ x ← e′ ]B               ∎

    … | no x∉zs | no y∉zs =
      branch c zs (e [ x ← e′ ]) [ y ← e″ ]B  ≡⟨ branch-step-∉ y∉zs ⟩
      branch c zs (e [ x ← e′ ] [ y ← e″ ])   ≡⟨ cong (branch c zs) (swap e) ⟩
      branch c zs (e [ y ← e″ ] [ x ← e′ ])   ≡⟨ sym $ branch-step-∉ x∉zs ⟩∎
      branch c zs (e [ y ← e″ ]) [ x ← e′ ]B  ∎

    swap-⋆ :
      ∀ es → es [ x ← e′ ]⋆ [ y ← e″ ]⋆ ≡ es [ y ← e″ ]⋆ [ x ← e′ ]⋆
    swap-⋆ []       = refl
    swap-⋆ (e ∷ es) = cong₂ _∷_ (swap e) (swap-⋆ es)

    swap-B⋆ :
      ∀ bs → bs [ x ← e′ ]B⋆ [ y ← e″ ]B⋆ ≡ bs [ y ← e″ ]B⋆ [ x ← e′ ]B⋆
    swap-B⋆ []       = refl
    swap-B⋆ (b ∷ bs) = cong₂ _∷_ (swap-B b) (swap-B⋆ bs)


module plfa-exercises.Practice2 where

-- Trying exercises:
-- 5.2 pp 340
-- 5.7 pp 386
-- 6.1 pp 423

import Relation.Binary.PropositionalEquality as Eq
open Eq using (_≡_; refl; subst)
open import Data.Nat using (ℕ; zero; suc; _+_; _*_)
open import Relation.Nullary using (¬_)
open import Data.Product using (_×_; proj₁; ∃-syntax) renaming (_,_ to ⟨_,_⟩)
open import Data.Sum using (_⊎_; inj₁; inj₂)
--open import plfa.part1.Isomorphism using (_≃_; extensionality)

∀-elim : ∀ {A : Set} {B : A → Set} → (L : ∀ (x : A) → B x) → (M : A) → B M
∀-elim l m = l m

--totype : ℕ → Set
--totype 0 = ℕ
--totype 1 = 4 ≡ 2 + 2
--totype _ = ℕ

-- λ noidea → ∀-elim {ℕ} {totype} noidea 4

------- Preliminary proofs -------
modus-tollens : ∀ {A B : Set}
  → (A → B)
  -------------
  → (¬ B → ¬ A)
modus-tollens a→b = λ{¬b → λ{a → ¬b (a→b a)}}
----------------------------------

postulate
  dne : ∀ {A : Set} → ¬ ¬ A → A

--data Σ (A : Set) (B : A → Set) : Set where
--  ⟨_,_⟩ : (x : A) → B x → Σ A B
--
--Σ-syntax = Σ
--infix 2 Σ-syntax
--syntax Σ-syntax A (λ x → B) = Σ[ x ∈ A ] B
--
--∃ : ∀ {A : Set} (B : A → Set) → Set
--∃ {A} B = Σ A B
--
--∃-syntax = ∃
--syntax ∃-syntax (λ x → B) = ∃[ x ] B

--⟨,⟩-syntax : ∀ {A : Set} {B : A → Set} (x : A) → B x → Σ A B
--⟨,⟩-syntax = ⟨_,_⟩
----⟨,⟩-syntax = Σ.⟨_,_⟩
--syntax ⟨,⟩-syntax x p = the-proof-for x is p

--∃-elim : ∀ {A : Set} {B : A → Set} {C : Set}
--  → (∀ x → B x → C)
--  → ∃[ x ] B x
--    ---------------
--  → C
--∃-elim f ⟨ x , y ⟩ = f x y

record _⇔_ (A B : Set) : Set where
  field
    to   : A → B
    from : B → A

---------------------- Athena book exercises ----------------------

exercise531 : ∀ {A : Set} {R : A → A → Set}
            → (∀ (x y : A) → R x y)
            → (∀ (x : A) → R x x)
exercise531 R x = R x x

exercise532 : ∀ {A : Set} (x : A) → ∃[ y ] (x ≡ y)
exercise532 e = ⟨ e , refl ⟩

exercise533 : ∀ {A : Set} {P Q S : A → Set}
            → (∀ {x} → (P x ⊎ Q x) → S x)
            → (∃[ y ] (Q y))
            -------------------------
            → (∃[ y ] (S y))
exercise533 Px⊎Qx→Sx ⟨ y , qy ⟩ =
  let
    -- P x ⊎ Q x
    py⊎qy = inj₂ qy
  in ⟨ y , Px⊎Qx→Sx py⊎qy ⟩

exercise534 : ∀ {A : Set} {P Q S : A → Set}
            → (∃[ y ] (P y × Q y))
            → (∀ {y} → P y → S y)
            -------------------------
            → (∃[ y ] (S y × Q y))
exercise534 ⟨ y , ⟨ py , qy ⟩ ⟩ py→sy = ⟨ y , ⟨ py→sy py , qy ⟩ ⟩

exercise535 : ∀ {A : Set} {P Q : A → Set}
            → (¬ ∃[ x ] (Q x))
            → (∀ {x} → P x → Q x)
            -------------------------
            → (¬ ∃[ x ] (P x))
exercise535 ¬∃x-qx ∀x→px→qx = λ{ ∃x-px@(⟨ x , px ⟩) → ¬∃x-qx ⟨ x , ∀x→px→qx px ⟩ }

exercise536 : ∀ {A : Set} {P Q S : A → Set}
            → (∀ {y} → P y → Q y)
            → (∃[ y ] (S y × ¬ Q y))
            ------------------------
            → (∃[ y ] (S y × ¬ P y))
exercise536 ∀y→py→qy ⟨ y , ⟨ sy , ¬qy ⟩ ⟩ = ⟨ y , ⟨ sy , modus-tollens ∀y→py→qy ¬qy ⟩ ⟩

exercise537 : ∀ {A : Set} {P Q : A → Set} {R : A → A → Set}
            → (∀ {x} → R x x → P x)
            → (∃[ x ] (P x) → ¬ ∃[ x ] (Q x))
            -------------------------------
            → ((∀ {x} → Q x) → ¬ ∃[ x ] (R x x))
exercise537 ∀x→rxx→px ∃x-px→¬∃x-qx ∀x→qx = λ{∃x-rxx@(⟨ x , rxx ⟩) → ∃x-px→¬∃x-qx ⟨ x , ∀x→rxx→px rxx ⟩ ⟨ x , ∀x→qx {x} ⟩ }

exercise538 : ∀ {A : Set} {P Q : A → Set}
            → (∃[ x ] (P x ⊎ Q x)) ⇔ (∃[ x ] (P x) ⊎ ∃[ x ] (Q x))
exercise538 = record { to = to ; from = from }
  where
  to : ∀ {A : Set} {P Q : A → Set}
     → ∃[ x ] (P x ⊎ Q x)
     -----------------------------
     → ∃[ x ] (P x) ⊎ ∃[ x ] (Q x)
  to ⟨ x , (inj₁ px) ⟩ = inj₁ ⟨ x , px ⟩
  to ⟨ x , (inj₂ qx) ⟩ = inj₂ ⟨ x , qx ⟩

  from : ∀ {A : Set} {P Q : A → Set}
       → ∃[ x ] (P x) ⊎ ∃[ x ] (Q x)
       -----------------------------
       → ∃[ x ] (P x ⊎ Q x)
  from (inj₁ ⟨ x , px ⟩) = ⟨ x , inj₁ px ⟩
  from (inj₂ ⟨ x , qx ⟩) = ⟨ x , inj₂ qx ⟩

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

exercise571 : ∀ {A : Set} {P Q : A → Set}
            → (∀ {x} → P x ⇔ Q x)
            → (∀ {x} → P x) ⇔ (∀ {x} → Q x)
exercise571 px⇔qx =
  record
  { to   = λ{px → (_⇔_.to   px⇔qx) px}
  ; from = λ{qx → (_⇔_.from px⇔qx) qx}
  }
--exercise571 ∀x→px⇔qx =
--  record
--  { to   = λ{∀x→px →  (_⇔_.to   (∀x→px⇔qx {x})) (∀x→px {x})}
--  ; from = λ{∀x→qx →  (_⇔_.from (∀x→px⇔qx {x})) (∀x→qx {x})}
--  }

exercise572 : ∀ {A : Set} {B : Set} {Q S : B → Set} {R T : B → B → Set}
            → (∃[ y ] (R y y × A))
            → (∃[ y ] (Q y × T y y))
            → (∀ y → A × Q y → ¬ S y)
            → (∃[ y ] (¬ S y × T y y))
exercise572 ⟨ _ , ⟨ _ , a ⟩ ⟩ ⟨ y , ⟨ qy , tyy ⟩ ⟩ ∀y→a×qy→¬sy = ⟨ y , ⟨ ∀y→a×qy→¬sy y ⟨ a , qy ⟩ , tyy ⟩ ⟩

-- This is fucking false!!!
--postulate
--  existence : {A : Set} {P : A → Set}
--            → (∀ x → P x)
--            ----------------
--            → (∃[ x ] (P x))

-- This cannot be proved! Take the empty set as an example. For any function
-- and relation the ∀'s are trivially true, but there is no element that
-- actually fulfills the function or the relation
--exercise574 : ∀ {A : Set} {F : A → A} {R : A → A → Set}
--            → (∀ x → R x x)
--            → (∀ x → F x ≡ F (F x))
--            -----------------------
--            → (∃[ y ] (R y (F y)))
--exercise574 ∀x→rxx ∀x→fx≡ffx = ⟨ ? , ? ⟩

exercise574 : ∀ {F : ℕ → ℕ} {R : ℕ → ℕ → Set}
            → (∀ x → R x x)
            → (∀ x → F x ≡ F (F x))
            -----------------------
            → (∃[ y ] (R y (F y)))
exercise574 {f} {r} ∀x→rxx ∀x→fx≡ffx =
  let y    = f 0
      y≡fy = ∀x→fx≡ffx 0          -- F 0 ≡ F (F 0)     =>  y ≡ F y
      ryy  = ∀x→rxx y             -- R (F 0) (F 0)     =>  R y y
      ryfy = subst (r y) y≡fy ryy -- R (F 0) (F (F 0)) =>  R y (F y)
  in ⟨ y , ryfy ⟩

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

exercise61a : ∀ {A B : Set}
            → (B ⊎ (A → B))
            → A
            ---------------
            → B
exercise61a (inj₁ b)   _ = b
exercise61a (inj₂ a→b) a = a→b a

exercise61b : ∀ {A B C : Set}
            → (¬ B → ¬ C)
            → ((A × B) ⊎ ¬ ¬ C)
            -------------------
            → B
exercise61b ¬b→¬c (inj₁ ⟨ a , b ⟩) = b
exercise61b ¬b→¬c (inj₂ ¬¬c) = dne ((modus-tollens ¬b→¬c) ¬¬c)

¬¬ : ∀ {A : Set}
   → A
   → ¬ ¬ A
¬¬ a = λ{¬a → ¬a a}

-- What is the difference between: ∀ x → P x → ∀ y → R y → L  and  (∀ x → P x) → (∀ y → R y) → L

---- Can the following be proved without Double Negation Elimination (dne)?
--lemma₁ : ∀ {A B : Set}
--       → (¬ B → ¬ A)
--       → A
--       -------------------
--       → B
--lemma₁ = ?
--
--lemma₂ : ∀ {A B : Set}
--       → (¬ B → ¬ A)
--       → ¬ ¬ A
--       -------------------
--       → B
--lemma₂ = ?
--
---- `lemma₁` seems not to imply `dne` but it can't be proven without it.
----
---- The answer is NO (for the second one)! Because from it we can prove `dne`!
---- `dne` cannot be proved in vanila Agda.
--dne₁ : ∀ {A : Set} → ¬ ¬ A → A
--dne₁ ¬¬a = lemma₁ ? ?
--
--dne₂ : ∀ {A : Set} → ¬ ¬ A → A
--dne₂ ¬¬a = lemma₂ (λ{x → x}) ¬¬a


module Basic.SmallStep where

import Data.Bool as Bool using (not)
open import Data.Bool hiding (not; if_then_else_)
open import Data.Empty
open import Data.Fin using (Fin; suc; zero; #_)
open import Data.Nat
open import Data.Nat.Properties.Simple
open import Data.Vec
open import Function
open import Relation.Binary.PropositionalEquality
open import Relation.Nullary
open import Data.Unit hiding (_≤?_)
open import Data.Product
open import Data.Maybe
import Level as L

open import Basic.AST
open import Utils.Decidable
open import Utils.NatOrdLemmas

{-
Small-step semantics for While; see chapter 2.2 of the book.

The book uses the notational convenience of omitting the state on the right hand side
of the transition if there is no such state. We must define the same shorthand explicitly.

Since the book seems to do it, I also decided to index derivation sequences by their length.
This means also more cases for notatitonal shorthands. Otherwise, the definitions follow the book
faithfully.

Here I omit some commentary, since most of the things follow the same pattern as with big-step
semantics. However, I also include some lemmas specific to small-step semantics, which are
also included in the book.
-}

infixr 5 _∷_
mutual

  -- Notational shorthands for derivation sequences:

  -- Sequences with specified number of steps:
  ⟨_,_⟩_⟶_ : ∀ {n} → St n → State n → ℕ → State n → Set
  ⟨_,_⟩_⟶_ S s k s' = ⟨ S , s ⟩ k ⟶[ nothing , s' ]

  ⟨_,_⟩_⟶⟨_,_⟩ : ∀ {n} → St n → State n → ℕ → St n → State n → Set
  ⟨_,_⟩_⟶⟨_,_⟩ S s k S' s' = ⟨ S , s ⟩ k ⟶[ just S' , s' ]

  -- Sequences with unspecified number of steps:
  ⟨_,_⟩⟶*⟨_,_⟩ : ∀ {n} → St n → State n → St n → State n → Set
  ⟨_,_⟩⟶*⟨_,_⟩ S s S' s' = ∃ λ n → ⟨ S , s ⟩ n ⟶[ just S' , s' ]

  ⟨_,_⟩⟶*_ : ∀ {n} → St n → State n → State n → Set
  ⟨_,_⟩⟶*_ S s s' = ∃ λ n → ⟨ S , s ⟩ n ⟶[ nothing , s' ]

  -- Single-step transitions:
  ⟨_,_⟩⟶_ : ∀ {n} → St n → State n → State n → Set
  ⟨_,_⟩⟶_ S s s' = ⟨ S , s ⟩⟶[ nothing , s' ]

  ⟨_,_⟩⟶⟨_,_⟩ : ∀ {n} → St n → State n → St n → State n → Set
  ⟨_,_⟩⟶⟨_,_⟩ S s S' s' = ⟨ S , s ⟩⟶[ just S' , s' ]

  data ⟨_,_⟩⟶[_,_] {n : ℕ} : St n → State n → Maybe (St n) → State n → Set where

    ass :
                    ∀ {x a s}
      → --------------------------------------
        ⟨ x := a , s ⟩⟶ ( s [ x ]≔ ⟦ a ⟧ᵉ s )

    skip :
             ∀ {s}
      → ----------------
        ⟨ skip , s ⟩⟶ s

    _◄ :
                 ∀ {s s' S₁ S₂ S₁'} →
              ⟨ S₁ , s ⟩⟶⟨ S₁' , s' ⟩
      → --------------------------------------
        ⟨ (S₁ , S₂) , s ⟩⟶⟨ (S₁' , S₂) , s' ⟩

    _∙ :
              ∀ {s s' S₁ S₂} →
               ⟨ S₁ , s ⟩⟶ s'
      → ------------------------------
        ⟨ (S₁ , S₂) , s ⟩⟶⟨ S₂ , s' ⟩

    if-true :
             ∀ {b s S₁ S₂}  →  T (⟦ b ⟧ᵉ s)
      → ---------------------------------------
        ⟨ if b then S₁ else S₂ , s ⟩⟶⟨ S₁ , s ⟩

    if-false :
             ∀ {b s S₁ S₂}  →  F (⟦ b ⟧ᵉ s)
      → ---------------------------------------
        ⟨ if b then S₁ else S₂ , s ⟩⟶⟨ S₂ , s ⟩

    while :
                                   ∀ {b s S}
      → ----------------------------------------------------------------------
        ⟨ while b do S , s ⟩⟶⟨ (if b then (S , while b do S) else skip) , s ⟩

  -- Derivation sequences
  data ⟨_,_⟩_⟶[_,_] {n : ℕ} : St n → State n → ℕ → Maybe (St n) → State n → Set where

    pause  :
               ∀ {s S}
      → -----------------------
        ⟨ S , s ⟩ 0 ⟶⟨ S , s ⟩

    _stop :
          ∀ {s s' S} →
         ⟨ S , s ⟩⟶ s'
      → -----------------
        ⟨ S , s ⟩ 1 ⟶ s'

    _∷_ :
                       ∀ {k s₁ s₂ s₃ S₁ S₂ S₃} →
        ⟨ S₁ , s₁ ⟩⟶⟨ S₂ , s₂ ⟩  →  ⟨ S₂ , s₂ ⟩ k ⟶[ S₃ , s₃ ]
      → --------------------------------------------------------
                    ⟨ S₁ , s₁ ⟩ suc k ⟶[ S₃ , s₃ ]

-- Example program derivation (very slow to check!)
private
  prog : St 3
  prog =
    # 2 := lit 0 ,
    while lte (var (# 1)) (var (# 0)) do
      ( # 2 := add (var (# 2)) (lit 1) ,
        # 0 := sub (var (# 0)) (var (# 1)) )

  -- -- Uncomment if you dare
  -- prog-deriv :
  --   ∀ {z} → ⟨ prog , 17 ∷ 5 ∷ z ∷ [] ⟩ _ ⟶ (2 ∷ 5 ∷ 3 ∷ [])
  -- prog-deriv =
  --   ass ∙ ∷
  --     while ∷ if-true tt ∷ ass ∙ ◄ ∷ ass ∙ ∷
  --     while ∷ if-true tt ∷ ass ∙ ◄ ∷ ass ∙ ∷
  --     while ∷ if-true tt ∷ ass ∙ ◄ ∷ ass ∙ ∷
  --     while ∷ if-false tt ∷ skip stop

-- Divergence

_divergesOnₛ_ : ∀ {n} → St n → State n → Set
prog divergesOnₛ s = ∀ {n s'} → ¬ ⟨ prog , s ⟩ n ⟶ s'

Divergentₛ : ∀ {n} → St n → Set
Divergentₛ prog = ∀ {s} → prog divergesOnₛ s

private
  inf-loopₛ : ∀ {n} → Divergentₛ {n} (while tt do skip)
  inf-loopₛ (() stop)
  inf-loopₛ (while ∷ (() stop))
  inf-loopₛ (while ∷ (if-true tt ∷ (() stop)))
  inf-loopₛ (while ∷ (if-true tt ∷ ((() ◄) ∷ p)))
  inf-loopₛ (while ∷ (if-true tt ∷ ((skip ∙) ∷ p))) = inf-loopₛ p
  inf-loopₛ (while ∷ (if-false () ∷ p))

deterministicₛ :
  ∀ {n}{S : St n}{S' S'' s s' s''}
  → ⟨ S , s ⟩⟶[ S' , s' ] → ⟨ S , s ⟩⟶[ S'' , s'' ]
  → S' ≡ S'' × s' ≡ s''
deterministicₛ {n} = go where
  go : ∀ {S : St n}{S' S'' s s' s''}
      → ⟨ S , s ⟩⟶[ S' , s' ] → ⟨ S , s ⟩⟶[ S'' , s'' ]
      → S' ≡ S'' × s' ≡ s''
  go ass ass = refl , refl
  go skip skip = refl , refl
  go (p1 ◄) (p2 ◄) with go p1 p2
  ... | refl , refl = refl , refl
  go (p1 ◄) (p2 ∙) with go p1 p2
  ... | () , _
  go (p1 ∙) (p2 ◄) with go p1 p2
  ... | () , _
  go (p1 ∙) (p2 ∙) with go p1 p2
  ... | refl , refl = refl , refl
  go (if-true x) (if-true x₁) = refl , refl
  go (if-true x) (if-false x₁) rewrite T→≡true x = ⊥-elim x₁
  go (if-false x) (if-true x₁) rewrite T→≡true x₁ = ⊥-elim x
  go (if-false x) (if-false x₁) = refl , refl
  go while while = refl , refl

{-
Lemma 2.19 of the book: if we have a derivation over the composition of statements,
then there exists two derivations over the substatements, such that their lenghts
add up to the length of the original derivation.
-}

seq-split :
  ∀ {n k S₁ S₂}{s₁ s₃ : State n}
  → ⟨ (S₁ , S₂) , s₁ ⟩ k ⟶ s₃
  → Σ (State n × ℕ × ℕ) λ {(s₂ , k₁ , k₂)
  → ⟨ S₁ , s₁ ⟩ k₁ ⟶ s₂
  × ⟨ S₂ , s₂ ⟩ k₂ ⟶ s₃
  × k₁ + k₂ ≡ k}
seq-split (() stop)
seq-split (x ◄ ∷ p) with seq-split p
... | _ , p1 , p2 , prf = _ , x ∷ p1 , p2 , cong suc prf
seq-split (x ∙ ∷ p) = _ , x stop , p , refl

{-
Exercise 2.20.
-}
ex2-20 :
  ∃ λ n → ∃₂ λ (s s' : State n) → ∃₂ λ A B →
  ⟨ (A , B) , s ⟩⟶*⟨ B , s' ⟩ × ¬ ⟨ A , s ⟩⟶* s'
ex2-20 = 1 , (0 ∷ []) , (2 ∷ []) , A , (while b do A) , Deriv , ¬Deriv
  where
  A = zero := add (lit 1) (var zero)
  b = lt (var zero) (lit 2)
  Deriv = , ass ∙ ∷ while ∷ if-true tt ∷ ass ∙ ∷ pause
  ¬Deriv : ¬ ⟨ A , 0 ∷ [] ⟩⟶* (2 ∷ [])
  ¬Deriv (._ , () stop)
  ¬Deriv (._ , () ∷ proj₂)

{-
The converse of seq-split: two derivations can be appended to a single derivation
over the composition of the programs.
-}
append :
  ∀ {n k₁ k₂}{s s' s'' : State n}{A B}
  → ⟨ A , s ⟩ k₁ ⟶ s'
  → ⟨ B , s' ⟩ k₂ ⟶ s''
  → ⟨ (A , B) , s ⟩ (k₁ + k₂) ⟶ s''
append (x stop) p2 = (x ∙) ∷ p2
append (x ∷ p1) p2 = (x ◄) ∷ append p1 p2

-- Correctness of factorial (exactly the same proof as with big-step semantics)
private

  ⟦fac⟧ : ℕ → ℕ
  ⟦fac⟧ zero    = 1
  ⟦fac⟧ (suc n) = suc n * ⟦fac⟧ n

  fac-loop : St 3
  fac-loop =
    while lt (var (# 1)) (var (# 0)) do
      ( # 1 := add (lit 1) (var (# 1)) ,
        # 2 := mul (var (# 1)) (var (# 2)) )

  fac : St 3
  fac =
    # 1 := lit 0 ,
    # 2 := lit 1 ,
    fac-loop

  fac-loop-ok :
    ∀ d i → ⟨ fac-loop , d + i ∷ i ∷ ⟦fac⟧ i ∷ [] ⟩⟶* (d + i ∷ d + i ∷ ⟦fac⟧ (d + i) ∷ [])
  fac-loop-ok zero i =
    , while ∷ if-false (¬A→FalseA $ a≮a i) ∷ skip stop
  fac-loop-ok (suc d) i with fac-loop-ok d (suc i)
  ... | _ , next rewrite +-suc d i =
    , while ∷ if-true (A→TrueA $ a<sb+a i d) ∷ ass ∙ ◄ ∷ ass ∙ ∷ next

  fac-ok :
    ∀ n {i lim} → ⟨ fac , n ∷ i ∷ lim ∷ [] ⟩⟶* (n ∷ n ∷ ⟦fac⟧ n ∷ [])
  fac-ok n with fac-loop-ok n 0
  ... | _ , loop-ok rewrite +-comm n 0 = , ass ∙ ∷ ass ∙ ∷ loop-ok


{-# OPTIONS --safe #-}

module Cubical.Homotopy.Loopspace where

open import Cubical.Core.Everything

open import Cubical.Data.Nat

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Pointed
open import Cubical.Foundations.HLevels
open import Cubical.Foundations.GroupoidLaws
open import Cubical.HITs.SetTruncation
open import Cubical.HITs.Truncation hiding (elim2) renaming (rec to trRec)
open import Cubical.Foundations.Isomorphism
open import Cubical.Foundations.Transport
open import Cubical.Foundations.Equiv.HalfAdjoint
open import Cubical.Foundations.Function
open import Cubical.Foundations.Path
open import Cubical.Foundations.Equiv.HalfAdjoint
open import Cubical.Foundations.Equiv
open import Cubical.Functions.Morphism
open import Cubical.Data.Sigma
open Iso

{- loop space of a pointed type -}
Ω : {ℓ : Level} → Pointed ℓ → Pointed ℓ
Ω (_ , a) = ((a ≡ a) , refl)

{- n-fold loop space of a pointed type -}
Ω^_ : ∀ {ℓ} → ℕ → Pointed ℓ → Pointed ℓ
(Ω^ 0) p = p
(Ω^ (suc n)) p = Ω ((Ω^ n) p)

{- loop space map -}
Ω→ : ∀ {ℓ ℓ'} {A : Pointed ℓ} {B : Pointed ℓ'}
      → (A →∙ B) → (Ω A →∙ Ω B)
fst (Ω→ {A = A} {B = B} (f , p)) q = sym p ∙∙ cong f q ∙∙ p
snd (Ω→ {A = A} {B = B} (f , p)) = ∙∙lCancel p

Ω^→ : ∀ {ℓ ℓ'} {A : Pointed ℓ} {B : Pointed ℓ'} (n : ℕ)
  → (A →∙ B) → ((Ω^ n) A →∙ (Ω^ n) B)
Ω^→ zero f = f
Ω^→ (suc n) f = Ω→ (Ω^→ n f)

{- loop space map functoriality (missing pointedness proof) -}
Ω→∘ : ∀ {ℓ ℓ' ℓ''} {A : Pointed ℓ} {B : Pointed ℓ'} {C : Pointed ℓ''}
  (g : B →∙ C) (f : A →∙ B)
  → ∀ p → Ω→ (g ∘∙ f) .fst p ≡ (Ω→ g ∘∙ Ω→ f) .fst p
Ω→∘ g f p k i =
  hcomp
    (λ j → λ
      { (i = i0) → compPath-filler' (cong (g .fst) (f .snd)) (g .snd) (~ k) j
      ; (i = i1) → compPath-filler' (cong (g .fst) (f .snd)) (g .snd) (~ k) j
      })
    (g .fst (doubleCompPath-filler (sym (f .snd)) (cong (f .fst) p) (f .snd) k i))

{- Ω→ is a homomorphism -}
Ω→pres∙ : ∀ {ℓ ℓ'} {A : Pointed ℓ} {B : Pointed ℓ'} (f : A →∙ B)
        → (p q : typ (Ω A))
        → fst (Ω→ f) (p ∙ q) ≡ fst (Ω→ f) p ∙ fst (Ω→ f) q
Ω→pres∙ f p q i j =
  hcomp
    (λ k → λ
       { (i = i1) →
          (doubleCompPath-filler
            (sym (snd f)) (cong (fst f) p) (snd f) k
         ∙ doubleCompPath-filler
            (sym (snd f)) (cong (fst f) q) (snd f) k) j
       ; (j = i0) → snd f k
       ; (j = i1) → snd f k})
    (cong-∙ (fst f) p q i j)

isEquivΩ→ : ∀ {ℓ ℓ'} {A : Pointed ℓ} {B : Pointed ℓ'}
           → (f : (A →∙ B))
           → isEquiv (fst f) → isEquiv (Ω→ f .fst)
isEquivΩ→ {B = (B , b)} =
  uncurry λ f →
    J (λ b y → isEquiv f
             → isEquiv (λ q → (λ i → y (~ i)) ∙∙ (λ i → f (q i)) ∙∙ y))
      λ eqf → subst isEquiv (funExt (rUnit ∘ cong f))
                     (isoToIsEquiv (congIso (equivToIso (f , eqf))))

ΩfunExtIso : ∀ {ℓ ℓ'} (A : Pointed ℓ) (B : Pointed ℓ')
  → Iso (typ (Ω (A →∙ B ∙))) (A →∙ Ω B)
fst (fun (ΩfunExtIso A B) p) x = funExt⁻ (cong fst p) x
snd (fun (ΩfunExtIso A B) p) i j = snd (p j) i
fst (inv (ΩfunExtIso A B) (f , p) i) x = f x i
snd (inv (ΩfunExtIso A B) (f , p) i) j = p j i
rightInv (ΩfunExtIso A B) _ = refl
leftInv (ΩfunExtIso A B) _ = refl

{- Commutativity of loop spaces -}
isComm∙ : ∀ {ℓ} (A : Pointed ℓ) → Type ℓ
isComm∙ A = (p q : typ (Ω A)) → p ∙ q ≡ q ∙ p

private
  mainPath : ∀ {ℓ} {A : Pointed ℓ} (n : ℕ) → (α β : typ ((Ω^ (2 + n)) A))
           → (λ i → α i ∙ refl) ∙ (λ i → refl ∙ β i)
            ≡ (λ i → refl ∙ β i) ∙ (λ i → α i ∙ refl)
  mainPath n α β i = (λ j → α (j ∧ ~ i) ∙ β (j ∧ i)) ∙ λ j → α (~ i ∨ j) ∙ β (i ∨ j)

EH-filler : ∀ {ℓ} {A : Pointed ℓ} (n : ℕ) → typ ((Ω^ (2 + n)) A)
  → typ ((Ω^ (2 + n)) A) → I → I → I → _
EH-filler {A = A} n α β i j z =
  hfill (λ k → λ { (i = i0) → ((cong (λ x → rUnit x (~ k)) α)
                                ∙ cong (λ x → lUnit x (~ k)) β) j
                  ; (i = i1) → ((cong (λ x → lUnit x (~ k)) β)
                                ∙ cong (λ x → rUnit x (~ k)) α) j
                  ; (j = i0) → rUnit refl (~ k)
                  ; (j = i1) → rUnit refl (~ k)})
        (inS (mainPath n α β i j)) z

{- Eckmann-Hilton -}
EH : ∀ {ℓ} {A : Pointed ℓ} (n : ℕ) → isComm∙ ((Ω^ (suc n)) A)
EH {A = A} n α β i j = EH-filler n α β i j i1

{- Lemmas for the syllepsis : EH α β ≡ (EH β α) ⁻¹ -}

EH-refl-refl : ∀ {ℓ} {A : Pointed ℓ} (n : ℕ)
             → EH {A = A} n refl refl ≡ refl
EH-refl-refl {A = A} n k i j =
  hcomp (λ r → λ { (k = i1) → (refl ∙ (λ _ → basep)) j
                  ; (j = i0) → rUnit basep (~ r ∧ ~ k)
                  ; (j = i1) → rUnit basep (~ r ∧ ~ k)
                  ; (i = i0) → (refl ∙ (λ _ → lUnit basep (~ r ∧ ~ k))) j
                  ; (i = i1) → (refl ∙ (λ _ → lUnit basep (~ r ∧ ~ k))) j})
        (((cong (λ x → rUnit x (~ k)) (λ _ → basep))
         ∙ cong (λ x → lUnit x (~ k)) (λ _ → basep)) j)
  where
  basep = snd (Ω ((Ω^ n) A))

{- Generalisations of EH α β when α or β is refl -}
EH-gen-l : ∀ {ℓ} {A : Pointed ℓ} (n : ℕ) → {x y : typ ((Ω^ (suc n)) A)} (α : x ≡ y)
       → α ∙ refl ≡ refl ∙ α
EH-gen-l {ℓ = ℓ} {A = A} n {x = x} {y = y} α i j z =
  hcomp (λ k → λ { (i = i0) → ((cong (λ x → rUnit x (~ k)) α) ∙ refl) j z
                  ; (i = i1) → (refl ∙ cong (λ x → rUnit x (~ k)) α) j z
                  ; (j = i0) → rUnit (refl {x = x z}) (~ k) z
                  ; (j = i1) → rUnit (refl {x = y z}) (~ k) z
                  ; (z = i0) → x i1
                  ; (z = i1) → y i1})
        (((λ j → α (j ∧ ~ i) ∙ refl) ∙ λ j → α (~ i ∨ j) ∙ refl) j z)

EH-gen-r : ∀ {ℓ} {A : Pointed ℓ} (n : ℕ) → {x y : typ ((Ω^ (suc n)) A)} (β : x ≡ y)
        → refl ∙ β ≡ β ∙ refl
EH-gen-r {A = A} n {x = x} {y = y} β i j z =
  hcomp (λ k → λ { (i = i0) → (refl ∙ cong (λ x → lUnit x (~ k)) β) j z
                  ; (i = i1) → ((cong (λ x → lUnit x (~ k)) β) ∙ refl) j z
                  ; (j = i0) → lUnit (λ k → x (k ∧ z)) (~ k) z
                  ; (j = i1) → lUnit (λ k → y (k ∧ z)) (~ k) z
                  ; (z = i0) → x i1
                  ; (z = i1) → y i1})
        (((λ j → refl ∙ β (j ∧ i)) ∙ λ j → refl ∙ β (i ∨ j)) j z)

{- characterisations of EH α β when α or β is refl  -}
EH-α-refl : ∀ {ℓ} {A : Pointed ℓ} (n : ℕ)
             → (α : typ ((Ω^ (2 + n)) A))
             → EH n α refl ≡ sym (rUnit α) ∙ lUnit α
EH-α-refl {A = A} n α i j k =
  hcomp (λ r → λ { (i = i0) → EH-gen-l n (λ i → α (i ∧ r)) j k
                  ; (i = i1) → (sym (rUnit λ i → α (i ∧ r)) ∙ lUnit λ i → α (i ∧ r)) j k
                  ; (j = i0) → ((λ i → α (i ∧ r)) ∙ refl) k
                  ; (j = i1) → (refl ∙ (λ i → α (i ∧ r))) k
                  ; (k = i0) → refl
                  ; (k = i1) → α r})
        ((EH-refl-refl n ∙ sym (lCancel (rUnit refl))) i j k)

EH-refl-β : ∀ {ℓ} {A : Pointed ℓ} (n : ℕ)
             → (β : typ ((Ω^ (2 + n)) A))
             → EH n refl β ≡ sym (lUnit β) ∙ rUnit β
EH-refl-β {A = A} n β i j k =
  hcomp (λ r → λ { (i = i0) → EH-gen-r n (λ i → β (i ∧ r)) j k
                  ; (i = i1) → (sym (lUnit λ i → β (i ∧ r)) ∙ rUnit λ i → β (i ∧ r)) j k
                  ; (j = i0) → (refl ∙ (λ i → β (i ∧ r))) k
                  ; (j = i1) → ((λ i → β (i ∧ r)) ∙ refl) k
                  ; (k = i0) → refl
                  ; (k = i1) → β r})
        ((EH-refl-refl n ∙ sym (lCancel (rUnit refl))) i j k)

syllepsis : ∀ {ℓ} {A : Pointed ℓ} (n : ℕ) (α β : typ ((Ω^ 3) A))
         → EH 0 α β ≡ sym (EH 0 β α)
syllepsis {A = A} n α β k i j =
  hcomp (λ r → λ { (i = i0) → i=i0 r j k
                  ; (i = i1) → i=i1 r j k
                  ; (j = i0) → j-filler r j k
                  ; (j = i1) → j-filler r j k
                  ; (k = i0) → EH-filler 1 α β i j r
                  ; (k = i1) → EH-filler 1 β α (~ i) j r})
        (btm-filler (~ k) i j)
  where
  guy = snd (Ω (Ω A))

  btm-filler : I → I → I → typ (Ω (Ω A))
  btm-filler j i k =
    hcomp (λ r
      → λ {(j = i0) → mainPath 1 β α (~ i) k
          ; (j = i1) → mainPath 1 α β i k
          ; (i = i0) → (cong (λ x → EH-α-refl 0 x r (~ j)) α
                       ∙ cong (λ x → EH-refl-β 0 x r (~ j)) β) k
          ; (i = i1) → (cong (λ x → EH-refl-β 0 x r (~ j)) β
                       ∙ cong (λ x → EH-α-refl 0 x r (~ j)) α) k
          ; (k = i0) → EH-α-refl 0 guy r (~ j)
          ; (k = i1) → EH-α-refl 0 guy r (~ j)})
      (((λ l → EH 0 (α (l ∧ ~ i)) (β (l ∧ i)) (~ j))
       ∙ λ l → EH 0 (α (l ∨ ~ i)) (β (l ∨ i)) (~ j)) k)

  link : I → I → I → _
  link z i j =
    hfill (λ k → λ { (i = i1) → refl
                    ; (j = i0) → rUnit refl (~ i)
                    ; (j = i1) → lUnit guy (~ i ∧ k)})
          (inS (rUnit refl (~ i ∧ ~ j))) z

  i=i1 : I → I → I → typ (Ω (Ω A))
  i=i1 r j k =
    hcomp (λ i → λ { (r = i0) → (cong (λ x → compPath-filler (sym (lUnit x)) (rUnit x) i k) β
                                ∙ cong (λ x → compPath-filler (sym (rUnit x)) (lUnit x) i k) α) j
                    ; (r = i1) → (β ∙ α) j
                    ; (k = i0) → (cong (λ x → lUnit x (~ r)) β ∙
                                   cong (λ x → rUnit x (~ r)) α) j
                    ; (k = i1) → (cong (λ x → rUnit x (~ r ∧ i)) β ∙
                                   cong (λ x → lUnit x (~ r ∧ i)) α) j
                    ; (j = i0) → link i r k
                    ; (j = i1) → link i r k})
          (((cong (λ x → lUnit x (~ r ∧ ~ k)) β
           ∙ cong (λ x → rUnit x (~ r ∧ ~ k)) α)) j)

  i=i0 : I → I → I → typ (Ω (Ω A))
  i=i0 r j k =
    hcomp (λ i → λ { (r = i0) → (cong (λ x → compPath-filler (sym (rUnit x)) (lUnit x) i k) α
                                ∙ cong (λ x → compPath-filler (sym (lUnit x)) (rUnit x) i k) β) j
                    ; (r = i1) → (α ∙ β) j
                    ; (k = i0) → (cong (λ x → rUnit x (~ r)) α ∙
                                   cong (λ x → lUnit x (~ r)) β) j
                    ; (k = i1) → (cong (λ x → lUnit x (~ r ∧ i)) α ∙
                                   cong (λ x → rUnit x (~ r ∧ i)) β) j
                    ; (j = i0) → link i r k
                    ; (j = i1) → link i r k})
          ((cong (λ x → rUnit x (~ r ∧ ~ k)) α
           ∙ cong (λ x → lUnit x (~ r ∧ ~ k)) β) j)

  j-filler : I → I → I → typ (Ω (Ω A))
  j-filler r i k =
    hcomp (λ j → λ { (i = i0) → link j r k
                    ; (i = i1) → link j r k
                    ; (r = i0) → compPath-filler (sym (rUnit guy))
                                                  (lUnit guy) j k
                    ; (r = i1) → refl
                    ; (k = i0) → rUnit guy (~ r)
                    ; (k = i1) → rUnit guy (j ∧ ~ r)})
          (rUnit guy (~ r ∧ ~ k))

------ Ωⁿ⁺¹ A ≃ Ωⁿ(Ω A) ------
flipΩPath : {ℓ : Level} {A : Pointed ℓ} (n : ℕ)
                → ((Ω^ (suc n)) A) ≡ (Ω^ n) (Ω A)
flipΩPath {A = A} zero = refl
flipΩPath {A = A} (suc n) = cong Ω (flipΩPath {A = A} n)

flipΩIso : {ℓ : Level} {A : Pointed ℓ} (n : ℕ)
              → Iso (fst ((Ω^ (suc n)) A)) (fst ((Ω^ n) (Ω A)))
flipΩIso {A = A} n = pathToIso (cong fst (flipΩPath n))

flipΩIso⁻pres· : {ℓ : Level} {A : Pointed ℓ} (n : ℕ)
                      → (f g : fst ((Ω^ (suc n)) (Ω A)))
                      → inv (flipΩIso (suc n)) (f ∙ g)
                      ≡ (inv (flipΩIso (suc n)) f)
                      ∙ (inv (flipΩIso (suc n)) g)
flipΩIso⁻pres· {A = A} n f g i =
    transp (λ j → flipΩPath {A = A} n (~ i ∧ ~ j) .snd
                 ≡ flipΩPath n (~ i ∧ ~ j) .snd) i
                  (transp (λ j → flipΩPath {A = A} n (~ i ∨ ~ j) .snd
                 ≡ flipΩPath n (~ i ∨ ~ j) .snd) (~ i) f
                 ∙ transp (λ j → flipΩPath {A = A} n (~ i ∨ ~ j) .snd
                 ≡ flipΩPath n (~ i ∨ ~ j) .snd) (~ i) g)

flipΩIsopres· : {ℓ : Level} {A : Pointed ℓ} (n : ℕ)
                      → (f g : fst (Ω ((Ω^ (suc n)) A)))
                      → fun (flipΩIso (suc n)) (f ∙ g)
                      ≡ (fun (flipΩIso (suc n)) f)
                      ∙ (fun (flipΩIso (suc n)) g)
flipΩIsopres· n =
  morphLemmas.isMorphInv _∙_ _∙_
    (inv (flipΩIso (suc n)))
    (flipΩIso⁻pres· n)
    (fun (flipΩIso (suc n)))
    (Iso.leftInv (flipΩIso (suc n)))
    (Iso.rightInv (flipΩIso (suc n)))

flipΩrefl : ∀ {ℓ} {A : Pointed ℓ} (n : ℕ)
  → fun (flipΩIso {A = A} (suc n)) refl ≡ refl
flipΩrefl {A = A} n j =
  transp (λ i₁ → fst (Ω (flipΩPath {A = A} n ((i₁ ∨ j)))))
         j (snd (Ω (flipΩPath n j)))

---- Misc. ----

isCommA→isCommTrunc : ∀ {ℓ} {A : Pointed ℓ} (n : ℕ) → isComm∙ A
                    → isOfHLevel (suc n) (typ A)
                    → isComm∙ (∥ typ A ∥ (suc n) , ∣ pt A ∣)
isCommA→isCommTrunc {A = (A , a)} n comm hlev p q =
    ((λ i j → (leftInv (truncIdempotentIso (suc n) hlev) ((p ∙ q) j) (~ i)))
 ∙∙ (λ i → cong {B = λ _ → ∥ A ∥ (suc n) } (λ x → ∣ x ∣)
                 (cong (trRec hlev (λ x → x)) (p ∙ q)))
 ∙∙ (λ i → cong {B = λ _ → ∥ A ∥ (suc n) } (λ x → ∣ x ∣)
                 (congFunct {A = ∥ A ∥ (suc n)} {B = A} (trRec hlev (λ x → x)) p q i)))
 ∙ ((λ i → cong {B = λ _ → ∥ A ∥ (suc n) } (λ x → ∣ x ∣)
                 (comm (cong (trRec hlev (λ x → x)) p) (cong (trRec hlev (λ x → x)) q) i))
 ∙∙ (λ i → cong {B = λ _ → ∥ A ∥ (suc n) } (λ x → ∣ x ∣)
                 (congFunct {A = ∥ A ∥ (suc n)} {B = A} (trRec hlev (λ x → x)) q p (~ i)))
 ∙∙ (λ i j → (leftInv (truncIdempotentIso (suc n) hlev) ((q ∙ p) j) i)))

ptdIso→comm : ∀ {ℓ ℓ'} {A : Pointed ℓ} {B : Type ℓ'} (e : Iso (typ A) B)
  → isComm∙ A → isComm∙ (B , fun e (pt A))
ptdIso→comm {A = (A , a)} {B = B} e comm p q =
       sym (rightInv (congIso e) (p ∙ q))
    ∙∙ (cong (fun (congIso e)) ((invCongFunct e p q)
                            ∙∙ (comm (inv (congIso e) p) (inv (congIso e) q))
                            ∙∙ (sym (invCongFunct e q p))))
    ∙∙ rightInv (congIso e) (q ∙ p)

{- Homotopy group version -}
π-comp : ∀ {ℓ} {A : Pointed ℓ} (n : ℕ) → ∥ typ ((Ω^ (suc n)) A) ∥₂
      → ∥ typ ((Ω^ (suc n)) A) ∥₂ → ∥ typ ((Ω^ (suc n)) A) ∥₂
π-comp n = elim2 (λ _ _ → isSetSetTrunc) λ p q → ∣ p ∙ q ∣₂

EH-π : ∀ {ℓ} {A : Pointed ℓ} (n : ℕ) (p q : ∥ typ ((Ω^ (2 + n)) A) ∥₂)
               → π-comp (1 + n) p q ≡ π-comp (1 + n) q p
EH-π  n = elim2 (λ x y → isOfHLevelPath 2 isSetSetTrunc _ _)
                             λ p q → cong ∣_∣₂ (EH n p q)


-- Andreas, Bentfest 2016-04-28 Marsstrand
-- Issue 1944: also resolve overloaded projections in checking position

module _ (A : Set) (a : A) where

record R B : Set where
  field f : B
open R

record S B : Set where
  field f : B
open S

test : ∀{A : Set} → A → A
test = f
-- Expected error:
-- Cannot resolve overloaded projection f because first visible
-- argument is not of record type
-- when checking that the expression f has type .A → .A


-- Andreas, 2016-01-13, highlighting of import directives
-- {-# OPTIONS -v highlighting.names:100 -v scope.decl:70 -v tc.decl:10 #-}

module _ where

import Common.Product as Prod hiding (proj₁) -- proj₁ should be highlighted as field

open Prod using (_×_)                        -- _×_ should be highlighted as record type

module M (A : Set) = Prod
  using (_,_)                                -- highlighted as constructor
  renaming (proj₂ to snd)                    -- highlighted as projections