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

open import Functions.Definition
open import Functions.Lemmas
open import LogicalFormulae
open import Numbers.Naturals.Definition
open import Numbers.Naturals.Order
open import Sets.FinSet.Definition

module Sets.FinSet.Lemmas where

fneSymmetric : {n : ℕ} → {a b : FinSet (succ n)} → FinNotEquals a b → FinNotEquals b a
fneSymmetric {.1} {.a1} {.b1} (fne2 a1 b1 (inl x)) = fne2 b1 a1 (inr x)
fneSymmetric {.1} {.a1} {.b1} (fne2 a1 b1 (inr x)) = fne2 b1 a1 (inl x)
fneSymmetric {.(succ (succ _))} {.fzero} {b} (fneN .fzero b (inl (inl (refl ,, snd)))) = fneN b fzero (inl (inr (snd ,, refl)))
fneSymmetric {.(succ (succ _))} {a} {.fzero} (fneN a .fzero (inl (inr (fst ,, refl)))) = fneN fzero a (inl (inl (refl ,, fst)))
fneSymmetric {.(succ (succ _))} {a} {b} (fneN a b (inr ((fst ,, snd) , record { one = o ; two = p ; three = q }))) = fneN b a (inr ((snd ,, fst) , record { one = p ; two = o ; three = fneSymmetric q }))

private
  underlyingProof : {l m : _} {L : Set l} {pr : L → Set m} → (a : Sg L pr) → pr (underlying a)
  underlyingProof (a , b) = b

finSetNotEquals : {n : ℕ} → {a b : FinSet (succ n)} → (a ≡ b → False) → FinNotEquals {n} a b
finSetNotEquals {zero} {fzero} {fzero} pr = exFalso (pr refl)
finSetNotEquals {zero} {fzero} {fsucc ()} pr
finSetNotEquals {zero} {fsucc ()} {b} pr
finSetNotEquals {succ zero} {fzero} {fzero} pr = exFalso (pr refl)
finSetNotEquals {succ zero} {fzero} {fsucc fzero} pr = fne2 fzero (fsucc fzero) (inl (refl ,, refl))
finSetNotEquals {succ zero} {fzero} {fsucc (fsucc ())} pr
finSetNotEquals {succ zero} {fsucc fzero} {fzero} pr = fne2 (fsucc fzero) fzero (inr (refl ,, refl))
finSetNotEquals {succ zero} {fsucc fzero} {fsucc fzero} pr = exFalso (pr refl)
finSetNotEquals {succ zero} {fsucc fzero} {fsucc (fsucc ())} pr
finSetNotEquals {succ zero} {fsucc (fsucc ())}
finSetNotEquals {succ (succ n)} {fzero} {fzero} pr = exFalso (pr refl)
finSetNotEquals {succ (succ n)} {fzero} {fsucc b} pr = fneN fzero (fsucc b) (inl (inl (refl ,, (b , refl))))
finSetNotEquals {succ (succ n)} {fsucc a} {fzero} pr = fneN (fsucc a) fzero (inl (inr ((a , refl) ,, refl)))
finSetNotEquals {succ (succ n)} {fsucc a} {fsucc b} pr = fneN (fsucc a) (fsucc b) (inr ans)
  where
    q : a ≡ b → False
    q refl = pr refl
    t : FinNotEquals {succ n} a b
    t = finSetNotEquals {succ n} {a} {b} q
    ans : Sg (FinSet (succ (succ n)) && FinSet (succ (succ n))) (λ x → (fsucc a ≡ fsucc (_&&_.fst x)) & fsucc b ≡ fsucc (_&&_.snd x) & FinNotEquals (_&&_.fst x) (_&&_.snd x))
    ans with t
    ans | fne2 .fzero .(fsucc fzero) (inl (refl ,, refl)) = (a ,, b) , record { one = refl ; two = refl ; three = fne2 fzero (fsucc fzero) (inl (refl ,, refl)) }
    ans | fne2 .(fsucc fzero) .fzero (inr (refl ,, refl)) = (a ,, b) , record { one = refl ; two = refl ; three = fne2 (fsucc fzero) fzero (inr (refl ,, refl)) }
    ans | fneN a b _ = (a ,, b) , record { one = refl ; two = refl ; three = t }

fzeroNotFsucc : {n : ℕ} → {a : _} → fzero ≡ fsucc {succ n} a → False
fzeroNotFsucc ()

finSetNotEqualsSame : {n : ℕ} → {a : FinSet (succ n)} → FinNotEquals a a → False
finSetNotEqualsSame {.1} {fzero} (fne2 .fzero .fzero (inl (fst ,, ())))
finSetNotEqualsSame {.1} {fzero} (fne2 .fzero .fzero (inr (fst ,, ())))
finSetNotEqualsSame {.(succ (succ _))} {fzero} (fneN .fzero .fzero (inl (inl (refl ,, (a , ())))))
finSetNotEqualsSame {.(succ (succ _))} {fzero} (fneN .fzero .fzero (inl (inr ((a , ()) ,, refl))))
finSetNotEqualsSame {.(succ (succ _))} {fzero} (fneN .fzero .fzero (inr ((fst ,, snd) , record { one = () ; two = p ; three = q })))
finSetNotEqualsSame {.1} {fsucc a} (fne2 .(fsucc a) .(fsucc a) (inl (() ,, snd)))
finSetNotEqualsSame {.1} {fsucc a} (fne2 .(fsucc a) .(fsucc a) (inr (() ,, snd)))
finSetNotEqualsSame {.(succ (succ _))} {fsucc a} (fneN .(fsucc a) .(fsucc a) (inl (inl (() ,, snd))))
finSetNotEqualsSame {.(succ (succ _))} {fsucc a} (fneN .(fsucc a) .(fsucc a) (inl (inr (fst ,, ()))))
finSetNotEqualsSame {.(succ (succ _))} {fsucc a} (fneN .(fsucc a) .(fsucc a) (inr ((.a ,, .a) , record { one = refl ; two = refl ; three = q }))) = finSetNotEqualsSame q

finNotEqualsFsucc : {n : ℕ} → {a b : FinSet (succ n)} → FinNotEquals (fsucc a) (fsucc b) → FinNotEquals a b
finNotEqualsFsucc {.0} {a} {b} (fne2 .(fsucc a) .(fsucc b) (inl (() ,, snd)))
finNotEqualsFsucc {.0} {a} {b} (fne2 .(fsucc a) .(fsucc b) (inr (() ,, snd)))
finNotEqualsFsucc {n} {a} {b} (fneN .(fsucc a) .(fsucc b) (inl (inl (() ,, snd))))
finNotEqualsFsucc {n} {a} {b} (fneN .(fsucc a) .(fsucc b) (inl (inr (fst ,, ()))))
finNotEqualsFsucc {n} {a} {b} (fneN .(fsucc a) .(fsucc b) (inr ((fst ,, snd) , prf))) = identityOfIndiscernablesRight FinNotEquals ans (equalityCommutative b=snd)
  where
    a=fst : a ≡ fst
    a=fst = fsuccInjective (_&_&_.one prf)
    b=snd : b ≡ snd
    b=snd = fsuccInjective (_&_&_.two prf)
    ans : FinNotEquals a snd
    ans = identityOfIndiscernablesLeft FinNotEquals (_&_&_.three prf) (equalityCommutative a=fst)

finSetNotEquals' : {n : ℕ} → {a b : FinSet (succ n)} → FinNotEquals a b → (a ≡ b → False)
finSetNotEquals' {n} {a} {.a} fne refl = finSetNotEqualsSame fne

finset0Empty : FinSet zero → False
finset0Empty ()

finset1OnlyOne : (a b : FinSet 1) → a ≡ b
finset1OnlyOne fzero fzero = refl
finset1OnlyOne fzero (fsucc ())
finset1OnlyOne (fsucc ()) b

intoSmaller : {n m : ℕ} → .(n <N m) → (FinSet n → FinSet m)
intoSmaller {zero} {m} n<m = t
  where
    t : FinSet 0 → FinSet m
    t ()
intoSmaller {succ n} {zero} ()
intoSmaller {succ n} {succ m} n<m with intoSmaller (canRemoveSuccFrom<N n<m)
intoSmaller {succ n} {succ m} n<m | prev = t
  where
    t : FinSet (succ n) → FinSet (succ m)
    t fzero = fzero
    t (fsucc arg) = fsucc (prev arg)

intoSmallerInj : {n m : ℕ} → (n<m : n <N m) → Injection (intoSmaller n<m)
intoSmallerInj {zero} {zero} (le x ())
intoSmallerInj {zero} {succ m} n<m = inj
  where
    t : FinSet 0 → FinSet (succ m)
    t ()
    inj : {x y : FinSet zero} → intoSmaller (succIsPositive m) x ≡ intoSmaller (succIsPositive m) y → x ≡ y
    inj {()} {y}
intoSmallerInj {succ n} {zero} ()
intoSmallerInj {succ n} {succ m} n<m with intoSmallerInj (canRemoveSuccFrom<N n<m)
intoSmallerInj {succ n} {succ m} n<m | prevInj = inj
  where
    inj : Injection (intoSmaller n<m)
    inj {fzero} {fzero} pr = refl
    inj {fzero} {fsucc y} ()
    inj {fsucc x} {fzero} ()
    inj {fsucc x} {fsucc y} pr = applyEquality fsucc (prevInj (fsuccInjective pr))

toNat : {n : ℕ} → (a : FinSet n) → ℕ
toNat {.(succ _)} fzero = 0
toNat {.(succ _)} (fsucc a) = succ (toNat a)

toNatSmaller : {n : ℕ} → (a : FinSet n) → toNat a <N n
toNatSmaller {zero} ()
toNatSmaller {succ n} fzero = succIsPositive n
toNatSmaller {succ n} (fsucc a) = succPreservesInequality (toNatSmaller a)

ofNat : {n : ℕ} → (m : ℕ) → .(m <N n) → FinSet n
ofNat {zero} zero ()
ofNat {succ n} zero m<n = fzero
ofNat {zero} (succ m) ()
ofNat {succ n} (succ m) m<n = fsucc (ofNat {n} m (canRemoveSuccFrom<N m<n))

ofNatInjective : {n : ℕ} → (x y : ℕ) → .(pr : x <N n) → .(pr2 : y <N n) → ofNat x pr ≡ ofNat y pr2 → x ≡ y
ofNatInjective {zero} zero zero () y<n pr
ofNatInjective {zero} zero (succ y) () y<n pr
ofNatInjective {zero} (succ x) zero x<n () pr
ofNatInjective {zero} (succ x) (succ y) () y<n pr
ofNatInjective {succ n} zero zero x<n y<n pr = refl
ofNatInjective {succ n} zero (succ y) x<n y<n ()
ofNatInjective {succ n} (succ x) zero x<n y<n ()
ofNatInjective {succ n} (succ x) (succ y) x<n y<n pr = applyEquality succ (ofNatInjective x y (canRemoveSuccFrom<N x<n) (canRemoveSuccFrom<N y<n) (fsuccInjective pr))

toNatInjective : {n : ℕ} → (x y : FinSet n) → toNat x ≡ toNat y → x ≡ y
toNatInjective fzero fzero pr = refl
toNatInjective (fsucc x) (fsucc y) pr = applyEquality fsucc (toNatInjective x y (succInjective pr))

toNatOfNat : {n : ℕ} → (a : ℕ) → (a<n : a <N n) → toNat (ofNat a a<n) ≡ a
toNatOfNat {zero} zero (le x ())
toNatOfNat {zero} (succ a) (le x ())
toNatOfNat {succ n} zero a<n = refl
toNatOfNat {succ n} (succ a) a<n = applyEquality succ (toNatOfNat a (canRemoveSuccFrom<N a<n))

intoSmallerLemm : {n m : ℕ} → {n<m : n <N (succ m)} → {m<sm : m <N succ m} → (b : FinSet n) → intoSmaller n<m b ≡ ofNat m m<sm → False
intoSmallerLemm {.(succ _)} {m} {n<m} fzero pr with intoSmaller (canRemoveSuccFrom<N n<m)
intoSmallerLemm {.(succ _)} {zero} {n<m} fzero refl | bl = zeroNeverGreater (canRemoveSuccFrom<N n<m)
intoSmallerLemm {.(succ _)} {succ m} {n<m} fzero () | bl
intoSmallerLemm {.(succ _)} {m} {n<m} (fsucc b) pr with inspect (intoSmaller (canRemoveSuccFrom<N n<m))
intoSmallerLemm {.(succ _)} {zero} {n<m} (fsucc b) pr | bl with≡ _ = zeroNeverGreater (canRemoveSuccFrom<N n<m)
intoSmallerLemm {.(succ _)} {succ m} {n<m} {m<sm} (fsucc b) pr | bl with≡ p = intoSmallerLemm {n<m = canRemoveSuccFrom<N n<m} {m<sm = canRemoveSuccFrom<N m<sm} b (fsuccInjective pr)

intoSmallerNotSurj : {n m : ℕ} → {n<m : n <N m} → Surjection (intoSmaller n<m) → False
intoSmallerNotSurj {n} {zero} {le x ()} property
intoSmallerNotSurj {zero} {succ zero} {n<m} property with property fzero
... | () , _
intoSmallerNotSurj {succ n} {succ zero} {n<m} property = zeroNeverGreater (canRemoveSuccFrom<N n<m)
intoSmallerNotSurj {0} {succ (succ m)} {n<m} property with property fzero
... | () , _
intoSmallerNotSurj {succ n} {succ (succ m)} {n<m} property = problem
  where
    notHit : FinSet (succ (succ m))
    notHit = ofNat (succ m) (le zero refl)
    hitting : Sg (FinSet (succ n)) (λ i → intoSmaller n<m i ≡ notHit)
    hitting = property notHit
    problem : False
    problem with hitting
    ... | a , pr = intoSmallerLemm {succ n} {succ m} {n<m} {le 0 refl} a pr

finsetDecidableEquality : {n : ℕ} → (x y : FinSet n) → (x ≡ y) || ((x ≡ y) → False)
finsetDecidableEquality fzero fzero = inl refl
finsetDecidableEquality fzero (fsucc y) = inr λ ()
finsetDecidableEquality (fsucc x) fzero = inr λ ()
finsetDecidableEquality (fsucc x) (fsucc y) with finsetDecidableEquality x y
finsetDecidableEquality (fsucc x) (fsucc y) | inl pr rewrite pr = inl refl
finsetDecidableEquality (fsucc x) (fsucc y) | inr pr = inr (λ f → pr (fsuccInjective f))

subInjection : {n : ℕ} → {f : FinSet (succ (succ n)) → FinSet (succ (succ n))} → Injection f → (FinSet (succ n) → FinSet (succ n))
subInjection {n} {f} inj x with inspect (f (fsucc x))
subInjection {f = f} inj x | fzero with≡ _ with inspect (f fzero)
subInjection {f = f} inj x | fzero with≡ pr | fzero with≡ pr2 = exFalso (fzeroNotFsucc (inj (transitivity pr2 (equalityCommutative pr))))
subInjection {f = f} inj x | fzero with≡ _ | fsucc bl with≡ _ = bl
subInjection {f = f} inj x | fsucc bl with≡ _ = bl

subInjIsInjective : {n : ℕ} → {f : FinSet (succ (succ n)) → FinSet (succ (succ n))} → (inj : Injection f) → Injection (subInjection inj)
subInjIsInjective {f = f} inj {x} {y} pr with inspect (f (fsucc x))
subInjIsInjective {f = f} inj {x} {y} pr | fzero with≡ _ with inspect (f (fzero))
subInjIsInjective {f = f} inj {x} {y} pr | fzero with≡ pr1 | fzero with≡ pr2 = exFalso (fzeroNotFsucc (inj (transitivity pr2 (equalityCommutative pr1))))
subInjIsInjective {f = f} inj {x} {y} pr | fzero with≡ pr1 | fsucc bl with≡ _ with inspect (f (fsucc y))
subInjIsInjective {f = f} inj {x} {y} pr | fzero with≡ pr1 | fsucc bl with≡ _ | fzero with≡ x₁ with inspect (f (fzero))
subInjIsInjective {f = f} inj {x} {y} pr | fzero with≡ pr1 | fsucc bl with≡ _ | fzero with≡ x1 | fzero with≡ x2 = exFalso (fzeroNotFsucc (inj (transitivity x2 (equalityCommutative x1))))
subInjIsInjective {f = f} inj {x} {y} refl | fzero with≡ pr1 | fsucc .bl2 with≡ _ | fzero with≡ x1 | fsucc bl2 with≡ _ = fsuccInjective (inj (transitivity pr1 (equalityCommutative x1)))
subInjIsInjective {f = f} inj {x} {y} refl | fzero with≡ pr1 | fsucc .bl2 with≡ pr2 | fsucc bl2 with≡ pr3 = exFalso (fzeroNotFsucc (inj (transitivity pr2 (equalityCommutative pr3))))
subInjIsInjective {f = f} inj {x} {y} pr | fsucc bl with≡ _ with inspect (f (fsucc y))
subInjIsInjective {f = f} inj {x} {y} pr | fsucc bl with≡ _ | fzero with≡ x₁ with inspect (f fzero)
subInjIsInjective {f = f} inj {x} {y} pr | fsucc bl with≡ _ | fzero with≡ x1 | fzero with≡ x2 = exFalso (fzeroNotFsucc (inj (transitivity x2 (equalityCommutative x1))))
subInjIsInjective {f = f} inj {x} {y} refl | fsucc .bl2 with≡ x1 | fzero with≡ x₁ | fsucc bl2 with≡ x2 = exFalso (fzeroNotFsucc (inj (transitivity x2 (equalityCommutative x1))))
subInjIsInjective {f = f} inj {x} {y} refl | fsucc .y1 with≡ pr1 | fsucc y1 with≡ pr2 = fsuccInjective (inj (transitivity pr1 (equalityCommutative pr2)))

onepointBij : (f : FinSet 1 → FinSet 1) → Bijection f
Bijection.inj (onepointBij f) {x} {y} _ = finset1OnlyOne x y
Bijection.surj (onepointBij f) fzero with inspect (f fzero)
... | fzero with≡ pr = fzero , pr
... | fsucc () with≡ _
Bijection.surj (onepointBij f) (fsucc ())

nopointBij : (f : FinSet 0 → FinSet 0) → Bijection f
Bijection.inj (nopointBij f) {()}
Bijection.surj (nopointBij f) ()

private
  flip : {n : ℕ} → (f : FinSet (succ n) → FinSet (succ n)) → FinSet (succ n) → FinSet (succ n)
  flip {n} f fzero = f fzero
  flip {n} f (fsucc a) with inspect (f fzero)
  flip {n} f (fsucc a) | fzero with≡ x = fsucc a
  flip {n} f (fsucc a) | fsucc y with≡ x with finsetDecidableEquality a y
  flip {n} f (fsucc a) | fsucc y with≡ x | inl a=y = fzero
  flip {n} f (fsucc a) | fsucc y with≡ x | inr a!=y = fsucc a

  flipSwapsF0 : {n : ℕ} → {f : FinSet (succ n) → FinSet (succ n)} → (flip f (f fzero)) ≡ fzero
  flipSwapsF0 {zero} {f} with inspect (f fzero)
  flipSwapsF0 {zero} {f} | fzero with≡ x rewrite x = x
  flipSwapsF0 {zero} {f} | fsucc () with≡ x
  flipSwapsF0 {succ n} {f = f} with inspect (f fzero)
  flipSwapsF0 {succ n} {f = f} | fzero with≡ pr rewrite pr = pr
  flipSwapsF0 {succ n} {f = f} | fsucc b with≡ pr rewrite pr = ans
    where
      ans : flip f (fsucc b) ≡ fzero
      ans with inspect (f fzero)
      ans | fzero with≡ x = exFalso (fzeroNotFsucc (transitivity (equalityCommutative x) pr))
      ans | fsucc y with≡ x with finsetDecidableEquality b y
      ans | fsucc y with≡ x | inl b=y = refl
      ans | fsucc y with≡ x | inr b!=y = exFalso (b!=y (fsuccInjective (transitivity (equalityCommutative pr) x)))

  flipSwapsZero : {n : ℕ} → {f : FinSet (succ n) → FinSet (succ n)} → (flip f fzero) ≡ f fzero
  flipSwapsZero {n} {f} = refl

  flipMaintainsEverythingElse : {n : ℕ} → {f : FinSet (succ n) → FinSet (succ n)} → (x : FinSet n) → ((fsucc x ≡ f fzero) → False) → flip f (fsucc x) ≡ fsucc x
  flipMaintainsEverythingElse {n} {f} x x!=f0 with inspect (f fzero)
  flipMaintainsEverythingElse {n} {f} x x!=f0 | fzero with≡ pr = refl
  flipMaintainsEverythingElse {n} {f} x x!=f0 | fsucc bl with≡ pr with finsetDecidableEquality x bl
  flipMaintainsEverythingElse {n} {f} x x!=f0 | fsucc bl with≡ pr | inl x=bl = exFalso (x!=f0 (transitivity (applyEquality fsucc x=bl) (equalityCommutative pr)))
  flipMaintainsEverythingElse {n} {f} x x!=f0 | fsucc bl with≡ pr | inr x!=bl = refl

  bijFlip : {n : ℕ} → {f : FinSet (succ n) → FinSet (succ n)} → Bijection (flip f)
  bijFlip {zero} {f} = onepointBij (flip f)
  Bijection.inj (bijFlip {succ n} {f}) {fzero} {fzero} flx=fly = refl
  Bijection.inj (bijFlip {succ n} {f}) {fzero} {fsucc y} flx=fly with inspect (f fzero)
  Bijection.inj (bijFlip {succ n} {f}) {fzero} {fsucc y} flx=fly | fzero with≡ x rewrite x = exFalso (fzeroNotFsucc flx=fly)
  Bijection.inj (bijFlip {succ n} {f}) {fzero} {fsucc y} flx=fly | fsucc f0 with≡ x with finsetDecidableEquality y f0
  Bijection.inj (bijFlip {succ n} {f}) {fzero} {fsucc y} flx=fly | fsucc f0 with≡ x | inl x₁ = exFalso (fzeroNotFsucc (transitivity (equalityCommutative flx=fly) x))
  Bijection.inj (bijFlip {succ n} {f}) {fzero} {fsucc y} flx=fly | fsucc f0 with≡ x | inr pr = exFalso (pr (fsuccInjective (transitivity (equalityCommutative flx=fly) x)))
  Bijection.inj (bijFlip {succ n} {f}) {fsucc x} {fzero} flx=fly with inspect (f fzero)
  Bijection.inj (bijFlip {succ n} {f}) {fsucc x} {fzero} flx=fly | fzero with≡ pr = transitivity flx=fly pr
  Bijection.inj (bijFlip {succ n} {f}) {fsucc x} {fzero} flx=fly | fsucc f0 with≡ x₁ with finsetDecidableEquality x f0
  Bijection.inj (bijFlip {succ n} {f}) {fsucc x} {fzero} flx=fly | fsucc f0 with≡ pr | inl x₂ = exFalso (fzeroNotFsucc (transitivity flx=fly pr))
  Bijection.inj (bijFlip {succ n} {f}) {fsucc x} {fzero} flx=fly | fsucc f0 with≡ x1 | inr x!=f0 = exFalso (x!=f0 (fsuccInjective (transitivity flx=fly x1)))
  Bijection.inj (bijFlip {succ n} {f}) {fsucc x} {fsucc y} flx=fly with inspect (f fzero)
  Bijection.inj (bijFlip {succ n} {f}) {fsucc x} {fsucc y} flx=fly | fzero with≡ x₁ = flx=fly
  Bijection.inj (bijFlip {succ n} {f}) {fsucc x} {fsucc y} flx=fly | fsucc f0 with≡ x₁ with finsetDecidableEquality y f0
  Bijection.inj (bijFlip {succ n} {f}) {fsucc x} {fsucc y} flx=fly | fsucc f0 with≡ x₁ | inl y=f0 with finsetDecidableEquality x f0
  Bijection.inj (bijFlip {succ n} {f}) {fsucc x} {fsucc y} flx=fly | fsucc f0 with≡ x₁ | inl y=f0 | inl x=f0 = applyEquality fsucc (transitivity x=f0 (equalityCommutative y=f0))
  Bijection.inj (bijFlip {succ n} {f}) {fsucc x} {fsucc y} () | fsucc f0 with≡ x₁ | inl y=f0 | inr x!=f0
  Bijection.inj (bijFlip {succ n} {f}) {fsucc x} {fsucc y} flx=fly | fsucc f0 with≡ x₁ | inr y!=f0 with finsetDecidableEquality x f0
  Bijection.inj (bijFlip {succ n} {f}) {fsucc x} {fsucc y} () | fsucc f0 with≡ x₁ | inr y!=f0 | inl x=f0
  Bijection.inj (bijFlip {succ n} {f}) {fsucc x} {fsucc y} flx=fly | fsucc f0 with≡ x₁ | inr y!=f0 | inr x!=f0 = flx=fly
  Bijection.surj (bijFlip {succ n} {f}) fzero = f fzero , flipSwapsF0 {f = f}
  Bijection.surj (bijFlip {succ n} {f}) (fsucc b) with inspect (f fzero)
  Bijection.surj (bijFlip {succ n} {f}) (fsucc b) | fzero with≡ x = fsucc b , flipMaintainsEverythingElse {f = f} b λ pr → fzeroNotFsucc (transitivity (equalityCommutative x) (equalityCommutative pr))
  Bijection.surj (bijFlip {succ n} {f}) (fsucc b) | fsucc y with≡ x with finsetDecidableEquality y b
  Bijection.surj (bijFlip {succ n} {f}) (fsucc b) | fsucc y with≡ x | inl y=b = fzero , transitivity x (applyEquality fsucc y=b)
  Bijection.surj (bijFlip {succ n} {f}) (fsucc b) | fsucc y with≡ x | inr y!=b = fsucc b , flipMaintainsEverythingElse {f = f} b λ pr → y!=b (fsuccInjective (transitivity (equalityCommutative x) (equalityCommutative pr)))

injectionIsBijectionFinset : {n : ℕ} → {f : FinSet n → FinSet n} → Injection f → Bijection f
injectionIsBijectionFinset {zero} {f} inj = record { inj = inj ; surj = λ () }
injectionIsBijectionFinset {succ zero} {f} inj = record { inj = inj ; surj = ans }
  where
    ans : (b : FinSet (succ zero)) → Sg (FinSet (succ zero)) (λ a → f a ≡ b)
    ans fzero with inspect (f fzero)
    ans fzero | fzero with≡ x = fzero , x
    ans fzero | fsucc () with≡ x
    ans (fsucc ())
injectionIsBijectionFinset {succ (succ n)} {f} inj with injectionIsBijectionFinset {succ n} (subInjIsInjective inj)
... | sb = ans
  where
    subSurj : Surjection (subInjection inj)
    subSurj = Bijection.surj sb

    tweakedF : FinSet (succ (succ n)) → FinSet (succ (succ n))
    tweakedF fzero = fzero
    tweakedF (fsucc x) = fsucc (subInjection inj x)

    tweakedBij : Bijection tweakedF
    Bijection.inj tweakedBij {fzero} {fzero} f'x=f'y = refl
    Bijection.inj tweakedBij {fzero} {fsucc y} ()
    Bijection.inj tweakedBij {fsucc x} {fzero} ()
    Bijection.inj tweakedBij {fsucc x} {fsucc y} f'x=f'y = applyEquality fsucc ((subInjIsInjective inj) (fsuccInjective f'x=f'y))
    Bijection.surj tweakedBij fzero = fzero , refl
    Bijection.surj tweakedBij (fsucc b) with subSurj b
    ... | ans , prop = fsucc ans , applyEquality fsucc prop

    compBij : Bijection (λ i → flip f (tweakedF i))
    compBij = bijectionComp tweakedBij bijFlip

    undoTweakMakesF : {x : FinSet (succ (succ n))} → flip f (tweakedF x) ≡ f x
    undoTweakMakesF {fzero} = refl
    undoTweakMakesF {fsucc x} with inspect (f fzero)
    undoTweakMakesF {fsucc x} | fzero with≡ x₁ with inspect (f (fsucc x))
    undoTweakMakesF {fsucc x} | fzero with≡ x₁ | fzero with≡ x₂ with inspect (f fzero)
    undoTweakMakesF {fsucc x} | fzero with≡ x₁ | fzero with≡ x2 | fzero with≡ x3 = exFalso (fzeroNotFsucc (inj (transitivity x3 (equalityCommutative x2))))
    undoTweakMakesF {fsucc x} | fzero with≡ x1 | fzero with≡ x2 | fsucc y with≡ x3 = exFalso (fzeroNotFsucc (inj (transitivity x1 (equalityCommutative x2))))
    undoTweakMakesF {fsucc x} | fzero with≡ x1 | fsucc y with≡ x2 = equalityCommutative x2
    undoTweakMakesF {fsucc x} | fsucc y with≡ x₁ with inspect (f (fsucc x))
    undoTweakMakesF {fsucc x} | fsucc y with≡ x₁ | fzero with≡ x₂ with inspect (f fzero)
    undoTweakMakesF {fsucc x} | fsucc y with≡ x₁ | fzero with≡ x2 | fzero with≡ x3 = exFalso (fzeroNotFsucc (inj (transitivity x3 (equalityCommutative x2))))
    undoTweakMakesF {fsucc x} | fsucc y with≡ x₁ | fzero with≡ x₂ | fsucc pr with≡ x₃ with finsetDecidableEquality pr y
    undoTweakMakesF {fsucc x} | fsucc y with≡ x₁ | fzero with≡ x2 | fsucc pr with≡ x₃ | inl x₄ = equalityCommutative x2
    undoTweakMakesF {fsucc x} | fsucc y with≡ x1 | fzero with≡ x₂ | fsucc pr with≡ x3 | inr pr!=y = exFalso (pr!=y (fsuccInjective (transitivity (equalityCommutative x3) x1)))
    undoTweakMakesF {fsucc x} | fsucc y with≡ x₁ | fsucc thi with≡ x₂ with finsetDecidableEquality thi y
    undoTweakMakesF {fsucc x} | fsucc .thi with≡ x1 | fsucc thi with≡ x2 | inl refl = exFalso false
      where
        p : f fzero ≡ f (fsucc x)
        p = transitivity x1 (equalityCommutative x2)
        q : fzero ≡ fsucc x
        q = inj p
        false : False
        false = fzeroNotFsucc q
    undoTweakMakesF {fsucc x} | fsucc y with≡ x₁ | fsucc thi with≡ x2 | inr thi!=y = equalityCommutative x2

    ans : Bijection f
    ans = bijectionPreservedUnderExtensionalEq compBij undoTweakMakesF

pigeonhole : {n m : ℕ} → (m <N n) → {f : FinSet n → FinSet m} → Injection f → False
pigeonhole {zero} {zero} () {f} property
pigeonhole {zero} {succ m} () {f} property
pigeonhole {succ n} {zero} m<n {f} property = finset0Empty (f fzero)
pigeonhole {succ zero} {succ m} m<n {f} property with canRemoveSuccFrom<N m<n
pigeonhole {succ zero} {succ m} m<n {f} property | le x ()
pigeonhole {succ (succ n)} {succ zero} m<n {f} property = fzeroNotFsucc (property (transitivity f0 (equalityCommutative f1)))
  where
    f0 : f (fzero) ≡ fzero
    f0 with inspect (f fzero)
    ... | fzero with≡ x = x
    ... | fsucc () with≡ _
    f1 : f (fsucc fzero) ≡ fzero
    f1 with inspect (f (fsucc fzero))
    ... | fzero with≡ x = x
    ... | fsucc () with≡ _
pigeonhole {succ (succ n)} {succ (succ m)} m<n {f} injF = intoSmallerNotSurj {_}{_} {m<n} surj
  where
    inj : Injection ((intoSmaller m<n) ∘ f)
    inj = injComp injF (intoSmallerInj m<n)
    bij : Bijection ((intoSmaller m<n) ∘ f)
    bij = injectionIsBijectionFinset inj
    surj : Surjection (intoSmaller m<n)
    surj = compSurjLeftSurj (Bijection.surj bij)

--surjectionIsBijectionFinset : {n : ℕ} → {f : FinSet n → FinSet n} → Surjection f → Bijection f
--surjectionIsBijectionFinset {zero} {f} surj = nopointBij f
--surjectionIsBijectionFinset {succ zero} {f} surj = onepointBij f
--surjectionIsBijectionFinset {succ (succ n)} {f} record { property = property } = {!!}

ofNatToNat : {n : ℕ} → (a : FinSet n) → ofNat (toNat a) (toNatSmaller a) ≡ a
ofNatToNat {zero} ()
ofNatToNat {succ n} fzero = refl
ofNatToNat {succ n} (fsucc a) = applyEquality fsucc (ofNatToNat a)


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

open import lib.Base
open import lib.Function
open import lib.PathFunctor
open import lib.PathGroupoid

open import lib.path-seq.Concat

module lib.path-seq.Split {i} {A : Type i} where

point-from-start : (n : ℕ) {a a' : A} (s : a =-= a') → A
point-from-start O {a} s = a
point-from-start (S n) {a = a} [] = a
point-from-start (S n) (p ◃∙ s) = point-from-start n s

drop : (n : ℕ) {a a' : A} (s : a =-= a') → point-from-start n s =-= a'
drop 0 s = s
drop (S n) [] = []
drop (S n) (p ◃∙ s) = drop n s

tail : {a a' : A} (s : a =-= a') → point-from-start 1 s =-= a'
tail = drop 1

private
  last1 : {a a' : A} (s : a =-= a') → A
  last1 {a = a} [] = a
  last1 {a = a} (p ◃∙ []) = a
  last1 (p ◃∙ s@(_ ◃∙ _)) = last1 s

  strip : {a a' : A} (s : a =-= a') → a =-= last1 s
  strip [] = []
  strip (p ◃∙ []) = []
  strip (p ◃∙ s@(_ ◃∙ _)) = p ◃∙ strip s

  point-from-end : (n : ℕ) {a a' : A} (s : a =-= a') → A
  point-from-end O {a} {a'} s = a'
  point-from-end (S n) s = point-from-end n (strip s)

!- : (n : ℕ) {a a' : A} (s : a =-= a') → a =-= point-from-end n s
!- O s = s
!- (S n) s = !- n (strip s)

take : (n : ℕ) {a a' : A} (s : a =-= a') → a =-= point-from-start n s
take O s = []
take (S n) [] = []
take (S n) (p ◃∙ s) = p ◃∙ take n s

private
  take-drop-split' : {a a' : A} (n : ℕ) (s : a =-= a')
    → s == take n s ∙∙ drop n s
  take-drop-split' O s = idp
  take-drop-split' (S n) [] = idp
  take-drop-split' (S n) (p ◃∙ s) = ap (λ v → p ◃∙ v) (take-drop-split' n s)

abstract
  take-drop-split : {a a' : A} (n : ℕ) (s : a =-= a')
    → ↯ s ◃∎ =ₛ ↯ (take n s) ◃∙ ↯ (drop n s) ◃∎
  take-drop-split n s = =ₛ-in $
    ↯ s
      =⟨ ap ↯ (take-drop-split' n s) ⟩
    ↯ (take n s ∙∙ drop n s)
      =⟨ ↯-∙∙ (take n s) (drop n s) ⟩
    ↯ (take n s) ∙ ↯ (drop n s) =∎

private
  split : {a a' : A} (s : a =-= a')
    → Σ A (λ a'' → Σ (a =-= a'') (λ _ → a'' == a'))
  split {a = a} [] = (a , ([] , idp))
  split {a = a} (p ◃∙ []) = (a , ([] , p))
  split (p ◃∙ s@(_ ◃∙ _)) =
    let (a'' , (t , q)) = split s
    in (a'' , (p ◃∙ t) , q)

  point-from-end' : (n : ℕ) {a a' : A} (s : a =-= a') → A
  point-from-end' n {a = a} [] = a
  point-from-end' O (p ◃∙ s) = point-from-end' O s
  point-from-end' (S n) (p ◃∙ s) = point-from-end' n (fst (snd (split (p ◃∙ s))))

#- : (n : ℕ) {a a' : A} (s : a =-= a') → point-from-end' n s =-= a'
#- n [] = []
#- O (p ◃∙ s) = #- O s
#- (S n) (p ◃∙ s) = let (a' , (t , q)) = split (p ◃∙ s) in #- n t ∙▹ q

infix 120 _!0 _!1 _!2 _!3 _!4 _!5
_!0 = !- 0
_!1 = !- 1
_!2 = !- 2
_!3 = !- 3
_!4 = !- 4
_!5 = !- 5

0! = drop 0
1! = drop 1
2! = drop 2
3! = drop 3
4! = drop 4
5! = drop 5

infix 120 _#0 _#1 _#2 _#3 _#4 _#5
_#0 = #- 0
_#1 = #- 1
_#2 = #- 2
_#3 = #- 3
_#4 = #- 4
_#5 = #- 5

0# = take 0
1# = take 1
2# = take 2
3# = take 3
4# = take 4
5# = take 5


{-# OPTIONS --without-K --safe #-}
module Cats.Category.Fun.Facts where

open import Cats.Category.Fun.Facts.Iso public using
  ( ≈→≅ ; ≅→≈ )
open import Cats.Category.Fun.Facts.Limit public using
  ( complete )
open import Cats.Category.Fun.Facts.Product public using
  ( hasBinaryProducts ; hasFiniteProducts )
open import Cats.Category.Fun.Facts.Terminal public using
  ( hasTerminal )


module Automaton.Pushdown where


module Bughunting2 where

data Nat : Set where zero : Nat -- Comment which gets eaten
                     suc  : Nat -> Nat --Comment which is preserved

plus  :
 Nat ->  Nat -> Nat

plus2 : Nat -> Nat -> Nat
plus2 = plus

plus zero  m = m
plus m n = {!   !}


-- Andreas, 2017-07-28, issue #883
-- Was fixed by making rewrite not go through abstract syntax.

open import Agda.Builtin.Equality

test : (A : Set) → (a : A) → A
test A a rewrite refl {x = a} = a

-- WAS:
-- Setω !=< Level of type Setω
-- when checking that the type
-- (A : Set) (a w : A) →
-- _≡_ {_6 A w} {_A_9 A w} (_x_10 A w) (_x_10 A w) → A
-- of the generated with function is well-formed

-- Should succeed.


module ConstructorsInstance where

record UnitRC : Set where
  instance
    constructor tt

data UnitD : Set where
  instance
    tt : UnitD

postulate
  fRC : {{_ : UnitRC}} → Set
  fD  : {{_ : UnitD}}  → Set

tryRC : Set
tryRC = fRC

tryD : Set
tryD = fD

data D : Set where
  a : D
  instance
    b : D
  c : D

postulate
  g : {{_ : D}} → Set

-- This should work because instance search will choose [b]
try2 : Set
try2 = g


{-

This file contains:

- Properties of set truncations

-}
{-# OPTIONS --cubical --no-import-sorts --safe #-}
module Cubical.HITs.SetTruncation.Properties where

open import Cubical.HITs.SetTruncation.Base

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Function
open import Cubical.Foundations.Isomorphism
open import Cubical.Foundations.Equiv
open import Cubical.Foundations.HLevels
open import Cubical.Foundations.Univalence
open import Cubical.Data.Sigma

private
  variable
    ℓ ℓ' : Level
    A B C D : Type ℓ

rec : isSet B → (A → B) → ∥ A ∥₂ → B
rec Bset f ∣ x ∣₂ = f x
rec Bset f (squash₂ x y p q i j) =
  Bset _ _ (cong (rec Bset f) p) (cong (rec Bset f) q) i j

rec2 : isSet C → (A → B → C) → ∥ A ∥₂ → ∥ B ∥₂ → C
rec2 Cset f ∣ x ∣₂ ∣ y ∣₂ = f x y
rec2 Cset f ∣ x ∣₂ (squash₂ y z p q i j) =
  Cset _ _ (cong (rec2 Cset f ∣ x ∣₂) p) (cong (rec2 Cset f ∣ x ∣₂) q) i j
rec2 Cset f (squash₂ x y p q i j) z =
  Cset _ _ (cong (λ a → rec2 Cset f a z) p) (cong (λ a → rec2 Cset f a z) q) i j

-- Old version:
-- rec2 Cset f = rec (isSetΠ λ _ → Cset) λ x → rec Cset (f x)

-- lemma 6.9.1 in HoTT book
elim : {B : ∥ A ∥₂ → Type ℓ}
       (Bset : (x : ∥ A ∥₂) → isSet (B x))
       (f : (a : A) → B (∣ a ∣₂))
       (x : ∥ A ∥₂) → B x
elim Bset f ∣ a ∣₂ = f a
elim Bset f (squash₂ x y p q i j) =
  isOfHLevel→isOfHLevelDep 2 Bset _ _
    (cong (elim Bset f) p) (cong (elim Bset f) q) (squash₂ x y p q) i j

elim2 : {C : ∥ A ∥₂ → ∥ B ∥₂ → Type ℓ}
        (Cset : ((x : ∥ A ∥₂) (y : ∥ B ∥₂) → isSet (C x y)))
        (f : (a : A) (b : B) → C ∣ a ∣₂ ∣ b ∣₂)
        (x : ∥ A ∥₂) (y : ∥ B ∥₂) → C x y
elim2 Cset f ∣ x ∣₂ ∣ y ∣₂ = f x y
elim2 Cset f ∣ x ∣₂ (squash₂ y z p q i j) =
  isOfHLevel→isOfHLevelDep 2 (λ a → Cset ∣ x ∣₂ a) _ _
     (cong (elim2 Cset f ∣ x ∣₂) p) (cong (elim2 Cset f ∣ x ∣₂) q) (squash₂ y z p q) i j
elim2 Cset f (squash₂ x y p q i j) z =
  isOfHLevel→isOfHLevelDep 2 (λ a → Cset a z) _ _
    (cong (λ a → elim2 Cset f a z) p) (cong (λ a → elim2 Cset f a z) q) (squash₂ x y p q) i j

-- Old version:
-- elim2 Cset f = elim (λ _ → isSetΠ (λ _ → Cset _ _))
--                     (λ a → elim (λ _ → Cset _ _) (f a))

-- TODO: generalize
elim3 : {B : (x y z : ∥ A ∥₂) → Type ℓ}
        (Bset : ((x y z : ∥ A ∥₂) → isSet (B x y z)))
        (g : (a b c : A) → B ∣ a ∣₂ ∣ b ∣₂ ∣ c ∣₂)
        (x y z : ∥ A ∥₂) → B x y z
elim3 Bset g = elim2 (λ _ _ → isSetΠ (λ _ → Bset _ _ _))
                     (λ a b → elim (λ _ → Bset _ _ _) (g a b))

map : (A → B) → ∥ A ∥₂ → ∥ B ∥₂
map f = rec squash₂ λ x → ∣ f x ∣₂

setTruncUniversal : isSet B → (∥ A ∥₂ → B) ≃ (A → B)
setTruncUniversal {B = B} Bset =
  isoToEquiv (iso (λ h x → h ∣ x ∣₂) (rec Bset) (λ _ → refl) rinv)
  where
  rinv : (f : ∥ A ∥₂ → B) → rec Bset (λ x → f ∣ x ∣₂) ≡ f
  rinv f i x =
    elim (λ x → isProp→isSet (Bset (rec Bset (λ x → f ∣ x ∣₂) x) (f x)))
         (λ _ → refl) x i

setTruncIsSet : isSet ∥ A ∥₂
setTruncIsSet a b p q = squash₂ a b p q

setTruncIdempotent≃ : isSet A → ∥ A ∥₂ ≃ A
setTruncIdempotent≃ {A = A} hA = isoToEquiv f
  where
  f : Iso ∥ A ∥₂ A
  Iso.fun f = rec hA (idfun A)
  Iso.inv f x = ∣ x ∣₂
  Iso.rightInv f _ = refl
  Iso.leftInv f = elim (λ _ → isSet→isGroupoid setTruncIsSet _ _) (λ _ → refl)

setTruncIdempotent : isSet A → ∥ A ∥₂ ≡ A
setTruncIdempotent hA = ua (setTruncIdempotent≃ hA)

isContr→isContrSetTrunc : isContr A → isContr (∥ A ∥₂)
isContr→isContrSetTrunc contr = ∣ fst contr ∣₂
                                , elim (λ _ → isOfHLevelPath 2 (setTruncIsSet) _ _)
                                       λ a → cong ∣_∣₂ (snd contr a)

setTruncIso : Iso A B → Iso ∥ A ∥₂ ∥ B ∥₂
Iso.fun (setTruncIso is) = rec setTruncIsSet (λ x → ∣ Iso.fun is x ∣₂)
Iso.inv (setTruncIso is) = rec setTruncIsSet (λ x → ∣ Iso.inv is x ∣₂)
Iso.rightInv (setTruncIso is) =
  elim (λ _ → isOfHLevelPath 2 setTruncIsSet _ _)
        λ a → cong ∣_∣₂ (Iso.rightInv is a)
Iso.leftInv (setTruncIso is) =
  elim (λ _ → isOfHLevelPath 2 setTruncIsSet _ _)
        λ a → cong ∣_∣₂ (Iso.leftInv is a)

setSigmaIso : {B : A → Type ℓ} → Iso ∥ Σ A B ∥₂ ∥ Σ A (λ x → ∥ B x ∥₂) ∥₂
setSigmaIso {A = A} {B = B} = iso fun funinv sect retr
  where
  {- writing it out explicitly to avoid yellow highlighting -}
  fun : ∥ Σ A B ∥₂ → ∥ Σ A (λ x → ∥ B x ∥₂) ∥₂
  fun = rec setTruncIsSet λ {(a , p) → ∣ a , ∣ p ∣₂ ∣₂}
  funinv : ∥ Σ A (λ x → ∥ B x ∥₂) ∥₂ → ∥ Σ A B ∥₂
  funinv = rec setTruncIsSet (λ {(a , p) → rec setTruncIsSet (λ p → ∣ a , p ∣₂) p})
  sect : section fun funinv
  sect = elim (λ _ → isOfHLevelPath 2 setTruncIsSet _ _)
              λ { (a , p) → elim {B = λ p → fun (funinv ∣ a , p ∣₂) ≡ ∣ a , p ∣₂}
              (λ p → isOfHLevelPath 2 setTruncIsSet _ _) (λ _ → refl) p }
  retr : retract fun funinv
  retr = elim (λ _ → isOfHLevelPath 2 setTruncIsSet _ _)
              λ { _ → refl }

sigmaElim : {B : ∥ A ∥₂ → Type ℓ} {C : Σ ∥ A ∥₂ B  → Type ℓ'}
            (Bset : (x : Σ ∥ A ∥₂ B) → isSet (C x))
            (g : (a : A) (b : B ∣ a ∣₂) → C (∣ a ∣₂ , b))
            (x : Σ ∥ A ∥₂ B) → C x
sigmaElim {B = B} {C = C} set g (x , y) =
  elim {B = λ x → (y : B x) → C (x , y)} (λ _ → isSetΠ λ _ → set _) g x y

sigmaProdElim : {C : ∥ A ∥₂ × ∥ B ∥₂ → Type ℓ} {D : Σ (∥ A ∥₂ × ∥ B ∥₂) C  → Type ℓ'}
                (Bset : (x : Σ (∥ A ∥₂ × ∥ B ∥₂) C) → isSet (D x))
                (g : (a : A) (b : B) (c : C (∣ a ∣₂ , ∣ b ∣₂)) → D ((∣ a ∣₂ , ∣ b ∣₂) , c))
                (x : Σ (∥ A ∥₂ × ∥ B ∥₂) C) → D x
sigmaProdElim {B = B} {C = C} {D = D} set g ((x , y) , c) =
  elim {B = λ x → (y : ∥ B ∥₂) (c : C (x , y)) → D ((x , y) , c)}
       (λ _ → isSetΠ λ _ → isSetΠ λ _ → set _)
       (λ x → elim (λ _ → isSetΠ λ _ → set _) (g x))
       x y c

prodElim : {C : ∥ A ∥₂ × ∥ B ∥₂ → Type ℓ}
         → ((x : ∥ A ∥₂ × ∥ B ∥₂) → isSet (C x))
         → ((a : A) (b : B) → C (∣ a ∣₂ , ∣ b ∣₂))
         → (x : ∥ A ∥₂ × ∥ B ∥₂) → C x
prodElim setC f (a , b) = elim2 (λ x y → setC (x , y)) f a b

prodRec : {C : Type ℓ} → isSet C → (A → B → C) → ∥ A ∥₂ × ∥ B ∥₂ → C
prodRec setC f (a , b) = rec2 setC f a b

prodElim2 : {E : (∥ A ∥₂ × ∥ B ∥₂) → (∥ C ∥₂ × ∥ D ∥₂) → Type ℓ}
         → ((x : ∥ A ∥₂ × ∥ B ∥₂) (y : ∥ C ∥₂ × ∥ D ∥₂) → isSet (E x y))
         → ((a : A) (b : B) (c : C) (d : D) → E (∣ a ∣₂ , ∣ b ∣₂) (∣ c ∣₂ , ∣ d ∣₂))
         → ((x : ∥ A ∥₂ × ∥ B ∥₂) (y : ∥ C ∥₂ × ∥ D ∥₂) → (E x y))
prodElim2 isset f = prodElim (λ _ → isSetΠ λ _ → isset _ _)
                             λ a b → prodElim (λ _ → isset _ _)
                                     λ c d → f a b c d

setTruncOfProdIso :  Iso ∥ A × B ∥₂ (∥ A ∥₂ × ∥ B ∥₂)
Iso.fun setTruncOfProdIso = rec (isSet× setTruncIsSet setTruncIsSet) λ { (a , b) → ∣ a ∣₂ , ∣ b ∣₂ }
Iso.inv setTruncOfProdIso = prodRec setTruncIsSet λ a b → ∣ a , b ∣₂
Iso.rightInv setTruncOfProdIso =
  prodElim (λ _ → isOfHLevelPath 2 (isSet× setTruncIsSet setTruncIsSet) _ _) λ _ _ → refl
Iso.leftInv setTruncOfProdIso =
  elim (λ _ → isOfHLevelPath 2 setTruncIsSet _ _) λ {(a , b) → refl}

IsoSetTruncateSndΣ : {A : Type ℓ} {B : A → Type ℓ'} → Iso ∥ Σ A B ∥₂ ∥ Σ A (λ x → ∥ B x ∥₂) ∥₂
Iso.fun IsoSetTruncateSndΣ = map λ a → (fst a) , ∣ snd a ∣₂
Iso.inv IsoSetTruncateSndΣ = rec setTruncIsSet (uncurry λ x → map λ b → x , b)
Iso.rightInv IsoSetTruncateSndΣ =
  elim (λ _ → isOfHLevelPath 2 setTruncIsSet _ _)
        (uncurry λ a → elim (λ _ → isOfHLevelPath 2 setTruncIsSet _ _)
        λ _ → refl)
Iso.leftInv IsoSetTruncateSndΣ =
  elim (λ _ → isOfHLevelPath 2 setTruncIsSet _ _)
         λ _ → refl


------------------------------------------------------------------------
-- Simple queues, implemented in the usual way using two lists
-- (following Hood and Melville)
------------------------------------------------------------------------

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

open import Equality

module Queue.Simple {c⁺} (eq : ∀ {a p} → Equality-with-J a p c⁺) where

open Derived-definitions-and-properties eq

open import Prelude

open import Bijection eq using (_↔_)
open import Equality.Decision-procedures eq
open import List eq as L hiding (map)
open import Surjection eq using (_↠_)

private
  variable
    a     : Level
    A B   : Type a
    x     : A
    f     : A → B
    xs ys : List A

------------------------------------------------------------------------
-- Invariant

-- The queue invariant: if the first list is empty, then the second
-- list is empty.

Invariant : {A : Type a} → List A → List A → Type a
Invariant (_ ∷ _) _       = ↑ _ ⊤
Invariant []      []      = ↑ _ ⊤
Invariant []      (_ ∷ _) = ⊥

-- The invariant is propositional.

Invariant-propositional : Is-proposition (Invariant xs ys)
Invariant-propositional {xs = []}    {ys = []} _ _ = refl _
Invariant-propositional {xs = _ ∷ _}           _ _ = refl _

-- Some lemmas related to the invariant.

-[] : Invariant xs []
-[] {xs = []}    = _
-[] {xs = _ ∷ _} = _

map-map : Invariant xs ys → Invariant (L.map f xs) (L.map f ys)
map-map {xs = _ ∷ _}           _ = _
map-map {xs = []}    {ys = []} _ = _

------------------------------------------------------------------------
-- Queues

-- Queues.
--
-- Note that the invariant is erased.

record Queue (A : Type a) : Type a where
  constructor ⟨_,_⟩
  field
    front rear     : List A
    @0 {invariant} : Invariant front rear

open Queue public

-- A variant of ⟨_,_⟩ with three explicit arguments.

pattern ⟨_,_⟩[_] f r i =
  record { front     = f
         ; rear      = r
         ; invariant = i
         }

------------------------------------------------------------------------
-- Conversion functions

-- Converts queues to lists.

to-List : Queue A → List A
to-List q = front q ++ reverse (rear q)

-- Converts lists to queues.

from-List : List A → Queue A
from-List xs = ⟨ xs , [] ⟩[ -[] ]

-- The function from-List is a right inverse of to-List.

to-List-from-List : to-List (from-List xs) ≡ xs
to-List-from-List {xs = xs} =
  xs ++ []  ≡⟨ ++-right-identity _ ⟩∎
  xs        ∎

-- If the carrier type is inhabited, then the function from-List is
-- not, in general, a left inverse of to-List.

¬-from-List-to-List :
  A → ¬ ((q : Queue A) → from-List (to-List q) ≡ q)
¬-from-List-to-List {A = A} x hyp = not-equal equal
  where
  counter-example : Queue A
  counter-example = ⟨ x ∷ [] , x ∷ [] ⟩

  not-equal : from-List (to-List counter-example) ≢ counter-example
  not-equal eq = List.[]≢∷ (cong rear eq)

  equal : from-List (to-List counter-example) ≡ counter-example
  equal = hyp counter-example

------------------------------------------------------------------------
-- The representation is not unique

-- If the carrier type is inhabited, then two queues representing the
-- same list are not necessarily equal.

representation-not-unique :
  A → ¬ ({q₁ q₂ : Queue A} → to-List q₁ ≡ to-List q₂ → q₁ ≡ q₂)
representation-not-unique x hyp =
  ¬-from-List-to-List x λ q → hyp (
    to-List (from-List (to-List q))  ≡⟨ to-List-from-List ⟩∎
    to-List q                        ∎)

-- If the carrier type is inhabited, then the type
-- ∃ λ (q : Queue A) → to-List q ≡ xs is not, in general, a
-- proposition.

¬-Σ-Queue-propositional :
  A →
  ¬ ({xs : List A} →
     Is-proposition (∃ λ (q : Queue A) → to-List q ≡ xs))
¬-Σ-Queue-propositional x hyp =
  representation-not-unique x λ {q₁ q₂} eq →
  cong proj₁ (
    q₁ , eq      ≡⟨ hyp _ _ ⟩∎
    q₂ , refl _  ∎)

------------------------------------------------------------------------
-- Queue operations

-- Enqueues an element.

enqueue : A → Queue A → Queue A
enqueue x ⟨ []            , rear ⟩ = ⟨ x ∷ [] , rear     ⟩
enqueue x ⟨ front@(_ ∷ _) , rear ⟩ = ⟨ front  , x ∷ rear ⟩

to-List-enqueue : ∀ q → to-List (enqueue x q) ≡ to-List q ++ x ∷ []
to-List-enqueue         ⟨ []            , []   ⟩ = refl _
to-List-enqueue {x = x} ⟨ front@(_ ∷ _) , rear ⟩ =
  front ++ reverse (x ∷ rear)        ≡⟨ cong (front ++_) $ reverse-∷ rear ⟩
  front ++ reverse rear ++ x ∷ []    ≡⟨ ++-associative front _ _ ⟩∎
  (front ++ reverse rear) ++ x ∷ []  ∎

-- Dequeues an element, if possible.

dequeue : Queue A → Maybe (A × Queue A)
dequeue ⟨ [] , [] ⟩ = nothing

dequeue ⟨ x ∷ [] , rear ⟩ =
  just (x , ⟨ reverse rear , [] ⟩[ -[] ])

dequeue ⟨ x ∷ front@(_ ∷ _) , rear ⟩ =
  just (x , ⟨ front , rear ⟩)

to-List-dequeue :
  {A : Type a} (q : Queue A) →
  ⊎-map id (Σ-map id to-List) (dequeue q) ≡
  _↔_.to List↔Maybe[×List] (to-List q)
to-List-dequeue ⟨ [] , [] ⟩ = refl _

to-List-dequeue ⟨ x ∷ [] , rear ⟩ = cong (just ∘ (x ,_)) (
  reverse rear ++ []  ≡⟨ ++-right-identity _ ⟩∎
  reverse rear        ∎)

to-List-dequeue ⟨ _ ∷ _ ∷ _ , _ ⟩ = refl _

-- The "inverse" of the dequeue operation.

dequeue⁻¹ : Maybe (A × Queue A) → Queue A
dequeue⁻¹ nothing                       = ⟨ [] , [] ⟩
dequeue⁻¹ (just (x , ⟨ front , rear ⟩)) = ⟨ x ∷ front , rear ⟩

to-List-dequeue⁻¹ :
  (x : Maybe (A × Queue A)) →
  to-List (dequeue⁻¹ x) ≡
  _↔_.from List↔Maybe[×List] (⊎-map id (Σ-map id to-List) x)
to-List-dequeue⁻¹ nothing  = refl _
to-List-dequeue⁻¹ (just _) = refl _

-- A map function.

map : (A → B) → Queue A → Queue B
map f ⟨ front , rear ⟩[ inv ] =
  ⟨ L.map f front , L.map f rear ⟩[ map-map inv ]

to-List-map : ∀ q → to-List (map f q) ≡ L.map f (to-List q)
to-List-map {f = f} ⟨ front , rear ⟩ =
  L.map f front ++ reverse (L.map f rear)  ≡⟨ cong (L.map f front ++_) $ sym $ map-reverse rear ⟩
  L.map f front ++ L.map f (reverse rear)  ≡⟨ sym $ map-++ _ front _ ⟩∎
  L.map f (front ++ reverse rear)          ∎


module Sigma.Subst.Properties where

open import Data.Nat using (ℕ; _+_; zero; suc)
open import Data.Fin using (Fin; zero; suc)

open import Sigma.Subst.Core
open import Sigma.Renaming.Base

open import Function using (_∘_)

open import Data.Product using (∃₂; _×_) renaming ( _,_ to ⟨_,_⟩ )

open import Relation.Binary.PropositionalEquality as Eq
  using (_≡_; refl; sym; trans; cong; cong₂; cong-app)
open Eq.≡-Reasoning

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

-- We require a restricted form of functional extensionality
-- to prove whether to subsitutions are equivalent

postulate
  extensionality : ∀ { T U : Set } { f g : T → U }
    → (∀ (x : T) → f x ≡ g x)
    → f ≡ g

-- ------------------------------------------------------------------------
-- Expansion law
-- ------------------------------------------------------------------------

expansion : ∀ { T } ( σ₁ σ₂ : Sub T 0 )
  → σ₁ ≡ σ₂
expansion σ₁ σ₂ = extensionality λ ()

-- ------------------------------------------------------------------------
-- ∷-laws
-- ------------------------------------------------------------------------
-- Also known as the Interaction laws

∷-cong : ∀ { n } { T } { x₁ x₂ : T } { σ₁ σ₂ : Sub T n }
  → x₁ ≡ x₂
  → σ₁ ≡ σ₂
  -- ----------------
  → x₁ ∷ σ₁ ≡ x₂ ∷ σ₂
∷-cong x₁≡x₂ σ₁≡σ₂ = cong₂ (_∷_) x₁≡x₂ σ₁≡σ₂

∷-head : ∀ { n } { T } { x : T } { σ : Sub T n }
  → head (x ∷ σ) ≡ x
∷-head = refl

∷-tail : ∀ { n } { T } { x : T } { σ : Sub T n }
  → tail (x ∷ σ) ≡ σ
∷-tail = refl

∷-uncons : ∀ { n } { T } { x : T } { σ : Sub T n }
  → uncons (x ∷ σ) ≡ ⟨ x , σ ⟩
∷-uncons = refl

∷-head-tail-id : ∀ { n } { T } ( σ : Sub T (1 + n) )
  → head σ ∷ tail σ ≡ σ
∷-head-tail-id σ = extensionality lemma
  where
    lemma : ∀ x → (head σ ∷ tail σ) x ≡ σ x
    lemma zero = refl
    lemma (suc x) = refl

∷-id-η : ∀ { n } → ( zero ∷ ↑ ) ≡ id { n = 1 + n }
∷-id-η = ∷-head-tail-id id

∷-∘-distrib : ∀ { n } { T U } { x : T } ( σ : Sub T n ) ( f : T → U )
  → f ∘ ( x ∷ σ ) ≡ f x ∷ f ∘ σ
∷-∘-distrib { x = x } σ f = extensionality lemma
  where
    lemma : ∀ y → (f ∘ (x ∷ σ)) y ≡ ( f x ∷ (f ∘ σ) ) y
    lemma zero = refl
    lemma (suc y) = refl

∃-split : ∀ { n } { T } ( σ₁ : Sub T (1 + n) )
  → ∃₂ λ ( x : T ) ( σ₂ : Sub T n ) → σ₁ ≡ x ∷ σ₂
∃-split σ = ⟨ head σ , ⟨ tail σ , sym (∷-head-tail-id σ) ⟩ ⟩

-- TODO: Prove these.
-- x₁ ≡ head (x₁ ∷ σ₁) ::-head
--    ≡ head (x₂ ∷ σ₂) cong
--    ≡ x₂             ::-head

postulate
  ∷-injectiveˡ : ∀ { n } { T } ( x₁ x₂ : T ) ( σ₁ σ₂ : Sub T n )
    → x₁ ∷ σ₁ ≡ x₁ ∷ σ₂ → x₁ ≡ x₂

  ∷-injectiveʳ : ∀ { n } { T } ( x₁ x₂ : T ) ( σ₁ σ₂ : Sub T n )
    → x₁ ∷ σ₁ ≡ x₁ ∷ σ₂ → σ₁ ≡ σ₂

∷-injective : ∀ { n } { T } ( x₁ x₂ : T ) ( σ₁ σ₂ : Sub T n )
  → x₁ ∷ σ₁ ≡ x₁ ∷ σ₂ → (x₁ ≡ x₂) × (σ₁ ≡ σ₂)
∷-injective x₁ x₂ σ₁ σ₂ x₁∷σ₁≡x₁∷σ₂ = ⟨ (∷-injectiveˡ x₁ x₂ σ₁ σ₂ x₁∷σ₁≡x₁∷σ₂) , (∷-injectiveʳ x₁ x₂ σ₁ σ₂ x₁∷σ₁≡x₁∷σ₂) ⟩

-- ------------------------------------------------------------------------
-- Coincidence laws
-- ------------------------------------------------------------------------
-- Equivalences between uni and multi-variate primitives

++-∷ : ∀ { n } { T } (x : T) (σ : Sub T n)
  → x ∷ σ ≡ [ x ] ++ σ
++-∷ x σ = refl

-- ------------------------------------------------------------------------
-- Multi-variate interaction laws
-- ------------------------------------------------------------------------

++-cong : ∀ { m n } { T } {σ₁¹ σ₁² : Sub T m} {σ₂¹ σ₂² : Sub T n}
  → σ₁¹ ≡ σ₁²
  → σ₂¹ ≡ σ₂²
  -- -----------------------
  → σ₁¹ ++ σ₂¹ ≡ σ₁² ++ σ₂²
++-cong refl refl = refl

-- TODO: ++-injective
-- TODO: ++-≥ and ++-<

∷-drop : ∀ { m n } { T } (x : T) (σ : Sub T (m + n))
  → drop (suc m) (x ∷ σ) ≡ drop m σ
∷-drop x σ = extensionality (lemma x σ)
  where
    lemma : ∀ { m n } { T } (x : T) (σ : Sub T (m + n))
      → ∀ y → drop (suc m) (x ∷ σ) y ≡ drop m σ y
    lemma {zero} x σ y = refl
    lemma {suc m} x σ y = refl

++-drop : ∀ { m n : ℕ } { T } (σ₁ : Sub T m) (σ₂ : Sub T n)
  → drop m (σ₁ ++ σ₂) ≡ σ₂
++-drop σ₁ σ₂ = extensionality (lemma σ₁ σ₂)
  where
    lemma : ∀ { m n } { T } (σ₁ : Sub T m) (σ₂ : Sub T n)
      → ∀ x → drop m (σ₁ ++ σ₂) x ≡ σ₂ x
    lemma {zero} σ₁ σ₂ x = refl
    lemma {suc m} σ₁ σ₂ x = lemma (σ₁ ∘ ↑) σ₂ x

∷-take : ∀ { m n } { T } (x : T) (σ : Sub T (m + n))
  → take (suc m) (x ∷ σ) ≡ x ∷ take m σ
∷-take x σ = extensionality (lemma x σ)
  where
    lemma : ∀ { m n } { T } (x : T) (σ : Sub T (m + n))
      → ∀ y → take (suc m) (x ∷ σ) y ≡ (x ∷ take m σ) y
    lemma x σ zero = refl
    lemma x σ (suc y) = refl

++-take : ∀ { m n } { T } (σ₁ : Sub T m) (σ₂ : Sub T n)
  → take m (σ₁ ++ σ₂) ≡ σ₁
++-take σ₁ σ₂ = extensionality (lemma σ₁ σ₂)
  where
    lemma : ∀ { m n } { T } (σ₁ : Sub T m) (σ₂ : Sub T n)
      → ∀ x → take m (σ₁ ++ σ₂) x ≡ σ₁ x
    lemma σ₁ σ₂ zero = refl
    lemma σ₁ σ₂ (suc x) = lemma (σ₁ ∘ ↑) σ₂ x

++-take-drop-id : ∀ m { n } { T } (σ : Sub T (m + n))
  → take m σ ++ drop m σ ≡ σ
++-take-drop-id m σ = extensionality (lemma m σ)
  where
    lemma : ∀ m { n } { T } (σ : Sub T (m + n))
      → ∀ x → (take m σ ++ drop m σ) x ≡ σ x
    lemma zero σ x = refl
    lemma (suc m) σ zero = refl
    lemma (suc m) σ (suc x) = lemma m (σ ∘ ↑) x

∃-splitAt : ∀ m { n } { T } ( σ : Sub T (m + n) )
  → ∃₂ λ ( σ₁ : Sub T m ) ( σ₂ : Sub T n ) → σ ≡ σ₁ ++ σ₂
∃-splitAt m σ = ⟨ take m σ , ⟨ drop m σ , sym (++-take-drop-id m σ) ⟩ ⟩

take-∘-distrib : ∀ m { n } { T U } (σ : Sub T (m + n)) (f : T → U)
  → take m (f ∘ σ) ≡ f ∘ (take m σ)
take-∘-distrib m σ f = extensionality (lemma m σ f)
  where
    lemma : ∀ m { n } { T U } (σ : Sub T (m + n)) (f : T → U)
      → ∀ x → take m (f ∘ σ) x ≡ (f ∘ (take m σ)) x
    lemma .(suc _) σ f zero = refl
    lemma .(suc _) σ f (suc x) = refl

drop-∘-distrib : ∀ m { n } { T U } (σ : Sub T (m + n)) (f : T → U)
  → drop m (f ∘ σ) ≡ f ∘ (drop m σ)
drop-∘-distrib m σ f = extensionality (lemma m σ f)
  where
    lemma : ∀ m { n } { T U } (σ : Sub T (m + n)) (f : T → U)
      → ∀ x → drop m (f ∘ σ) x ≡ (f ∘ (drop m σ)) x
    lemma zero σ f x = refl
    lemma (suc m) σ f x = refl

++-∘-distrib : ∀ { m n } { T U } (σ₁ : Sub T m) (σ₂ : Sub T n) (f : T → U)
  → f ∘ ( σ₁ ++ σ₂ ) ≡ (f ∘ σ₁) ++ (f ∘ σ₂)
++-∘-distrib { m } σ₁ σ₂ f =
  let σ = σ₁ ++ σ₂ in
  begin
    f ∘ σ
  ≡⟨ sym (++-take-drop-id m (f ∘ σ)) ⟩
    take m (f ∘ σ) ++ drop m (f ∘ σ)
  ≡⟨ cong₂ _++_ (take-∘-distrib m σ f) (drop-∘-distrib m σ f) ⟩
    f ∘ (take m σ) ++ f ∘ (drop m σ)
  ≡⟨ cong₂ (λ σ₁ σ₂ → f ∘ σ₁ ++ f ∘ σ₂) (++-take σ₁ σ₂) (++-drop σ₁ σ₂) ⟩
    (f ∘ σ₁) ++ (f ∘ σ₂)
  ∎

-- ------------------------------------------------------------------------
-- Sub↔Vec
-- ------------------------------------------------------------------------
-- TODO


module Library where

open import Function using (id; _∘_; _$_) public
open import Relation.Binary.HeterogeneousEquality public
open ≅-Reasoning renaming (begin_ to proof_) public
open import Data.Product renaming (proj₁ to fst; proj₂ to snd) public
open import Data.Empty public using (⊥; ⊥-elim)
open import Data.Unit public using (⊤)
open import Data.Nat public using (ℕ; zero; suc; _+_; module ℕ)
open import Data.Nat.Properties.Simple public
open import Data.Fin public using (Fin; zero; suc; raise)
                            renaming (_+_ to _F+_; fromℕ to fromNat)
open import Level public renaming (suc to lsuc; zero to lzero) hiding (lift)

-- needed for setoids
congid : ∀{a}{A : Set a}{a a' : A}(p : a ≅ a') → cong id p ≅ p
congid refl = refl

congcomp : ∀{a b c}{A : Set a}{B : Set b}{C : Set c}
           {a a' : A}(f : B → C)(g : A → B)(p : a ≅ a') →
            cong (f ∘ g) p ≅ cong f (cong g p)
congcomp f g refl = refl

-- should be replaced by dcong
cong' : ∀{a b}{A A' : Set a} → A ≅ A' →
        {B : A → Set b}{B' : A' → Set b} → B ≅ B' →
        {f : ∀ a → B a}{f' : ∀ a → B' a} → f ≅ f' →
        {a : A}{a' : A'} → a ≅ a' → f a ≅ f' a'
cong' refl refl refl refl = refl

-- should be replaced by dicong
icong' : ∀{a b}{A A' : Set a} → A ≅ A' →
         {B : A → Set b}{B' : A' → Set b} → B ≅ B' →
         {f : ∀ {a} → B a}{f' : ∀ {a} → B' a} →
         (λ {a} → f {a}) ≅ (λ {a} → f' {a}) →
         {a : A}{a' : A'} → a ≅ a' → f {a} ≅ f' {a'}
icong' refl refl refl refl = refl

fcong : ∀{a b}{A : Set a}{B : A → Set b}{f f' : (x : A) → B x}
        (a : A) → f ≅ f' → f a ≅ f' a
fcong a refl = refl

dcong : ∀{a b}{A A' : Set a}{B : A → Set b}{B' : A' → Set b}
        {f : (a : A) → B a}{f' : (a : A') → B' a}{a : A}{a' : A'} →
        a ≅ a' → B ≅ B' → f ≅ f' → f a ≅ f' a'
dcong refl refl refl = refl

dicong : ∀{a b}{A A' : Set a}{B : A → Set b}{B' : A' → Set b}
         {f : ∀ {a} → B a}{f' : ∀ {a} → B' a} → {a : A}{a' : A'} →
         a ≅ a' →  B ≅ B' →
         (λ {a} → f {a}) ≅ (λ {a} → f' {a}) →
         f {a} ≅ f' {a'}
dicong refl refl refl = refl

ifcong : ∀{a b}{A : Set a}{B : A → Set b}{f f' : {x : A} → B x}(a : A) →
         _≅_ {_}{ {x : A} → B x} f { {x : A} → B x} f' → f {a} ≅ f' {a}
ifcong a refl = refl

cong₃ : ∀{a b c d}{A : Set a}{B : A → Set b}
        {C : ∀ x → B x → Set c }{D : ∀ x y → C x y → Set d}
        (f : ∀ x y z → D x y z)
        {a a' : A} → a ≅ a' →
        {b : B a}{b' : B a'} → b ≅ b' →
        {c : C a b}{c' : C a' b'} → c ≅ c' →
        f a b c ≅ f a' b' c'
cong₃ f refl refl refl = refl

ir : ∀{a}{A B : Set a}{x : A}{y : B}(p q : x ≅ y) → p ≅ q
ir refl refl = refl

stripsubst : ∀{a c}{A : Set a}(C : A → Set c) →
             {a : A} → (c : C a) →
             {b : A} → (p : a ≅ b) →
             subst C p c ≅ c
stripsubst C c refl = refl

postulate ext : ∀{a b}{A : Set a}{B B' : A → Set b}
                {f : ∀ a → B a}{g : ∀ a → B' a} →
                (∀ a → f a ≅ g a) → f ≅ g

postulate dext : ∀{a b}{A A' : Set a}{B : A → Set b}{B' : A' → Set b}
                 {f : ∀ a → B a}{g : ∀ a → B' a} →
                (∀ {a a'} → a ≅ a' → f a ≅ g a') → f ≅ g

-- this could just be derived from ext

postulate iext : ∀{a b}{A : Set a}{B B' : A → Set b}
                 {f : ∀ {a} → B a}{g : ∀{a} → B' a} →
                 (∀ a → f {a} ≅ g {a}) →
                 _≅_ {_}{ {a : A} → B a} f { {a : A} → B' a} g

postulate diext : ∀{a b}{A A' : Set a}{B : A → Set b}{B' : A' → Set b}
                  {f : ∀ {a} → B a}{f' : ∀{a'} → B' a'} →
                  (∀{a a'} → a ≅ a' → f {a} ≅ f' {a'}) →
                  _≅_ {_}{ {a : A} → B a} f { {a' : A'} → B' a'} f'

hir : ∀{a}{A A' A'' A''' : Set a}{a : A}{a' : A'}{a'' : A''}{a''' : A'''}
           {p : a ≅ a'}{q : a'' ≅ a'''} → a ≅ a'' → p ≅ q
hir {p = refl} {q = refl} refl = refl

hir' : ∀{a}{A A' A'' A''' : Set a}{a : A}{a' : A'}{a'' : A''}{a''' : A'''}
           {p : a ≅ a'}{q : a'' ≅ a'''} → a' ≅ a''' → p ≅ q
hir' {p = refl} {q = refl} refl = refl


open import Data.Product using ( _,_ )
open import Web.Semantic.DL.ABox using ( ε )
open import Web.Semantic.DL.Category.Object using ( Object ; _,_ )
open import Web.Semantic.DL.Signature using ( Signature )
open import Web.Semantic.DL.TBox using ( TBox )
open import Web.Semantic.Util using ( False ; False∈Fin )

module Web.Semantic.DL.Category.Unit {Σ : Signature} where

I : ∀ {S T : TBox Σ} → Object S T
I = (False , False∈Fin , ε)


module Syntax where

open import Stack public

-- Abstract symbols, or atoms.

abstract
  Atom : Set
  Atom = Nat

-- Types, or propositions in constructive modal logic S4.

infixl 9 _⩕_
infixl 8 _⩖_
infixr 7 _⇒_
data Type : Set where
  α_   : Atom → Type
  _⇒_ : Type → Type → Type
  □_   : Type → Type
  _⩕_  : Type → Type → Type
  ⫪   : Type
  ⫫   : Type
  _⩖_  : Type → Type → Type

⫬_ : Type → Type
⫬ A = A ⇒ ⫫

-- Contexts, or stack pairs of types.

Context : Set
Context = Stack² Type Type

-- Derivations, or syntactic entailment.

infix 3 _⊢_
data _⊢_ : Context → Type → Set where
  var   : ∀ {A Γ Δ}     → A ∈ Γ → Γ ⁏ Δ ⊢ A
  mvar  : ∀ {A Γ Δ}     → A ∈ Δ → Γ ⁏ Δ ⊢ A
  lam   : ∀ {A B Γ Δ}   → Γ , A ⁏ Δ ⊢ B → Γ ⁏ Δ ⊢ A ⇒ B
  app   : ∀ {A B Γ Δ}   → Γ ⁏ Δ ⊢ A ⇒ B → Γ ⁏ Δ ⊢ A → Γ ⁏ Δ ⊢ B
  box   : ∀ {A Γ Δ}     → ∅ ⁏ Δ ⊢ A → Γ ⁏ Δ ⊢ □ A
  unbox : ∀ {A C Γ Δ}   → Γ ⁏ Δ ⊢ □ A → Γ ⁏ Δ , A ⊢ C → Γ ⁏ Δ ⊢ C
  pair  : ∀ {A B Γ Δ}   → Γ ⁏ Δ ⊢ A → Γ ⁏ Δ ⊢ B → Γ ⁏ Δ ⊢ A ⩕ B
  fst   : ∀ {A B Γ Δ}   → Γ ⁏ Δ ⊢ A ⩕ B → Γ ⁏ Δ ⊢ A
  snd   : ∀ {A B Γ Δ}   → Γ ⁏ Δ ⊢ A ⩕ B → Γ ⁏ Δ ⊢ B
  unit  : ∀ {Γ Δ}       → Γ ⁏ Δ ⊢ ⫪
  boom  : ∀ {C Γ Δ}     → Γ ⁏ Δ ⊢ ⫫ → Γ ⁏ Δ ⊢ C
  left  : ∀ {A B Γ Δ}   → Γ ⁏ Δ ⊢ A → Γ ⁏ Δ ⊢ A ⩖ B
  right : ∀ {A B Γ Δ}   → Γ ⁏ Δ ⊢ B → Γ ⁏ Δ ⊢ A ⩖ B
  case  : ∀ {A B C Γ Δ} → Γ ⁏ Δ ⊢ A ⩖ B → Γ , A ⁏ Δ ⊢ C → Γ , B ⁏ Δ ⊢ C → Γ ⁏ Δ ⊢ C

-- Shorthand for variables.

v₀ : ∀ {Γ Δ A} → Γ , A ⁏ Δ ⊢ A
v₀ = var i₀

v₁ : ∀ {Γ Δ A B} → Γ , A , B ⁏ Δ ⊢ A
v₁ = var i₁

v₂ : ∀ {Γ Δ A B C} → Γ , A , B , C ⁏ Δ ⊢ A
v₂ = var i₂

mv₀ : ∀ {Γ Δ A} → Γ ⁏ Δ , A ⊢ A
mv₀ = mvar i₀

mv₁ : ∀ {Γ Δ A B} → Γ ⁏ Δ , A , B ⊢ A
mv₁ = mvar i₁

mv₂ : ∀ {Γ Δ A B C} → Γ ⁏ Δ , A , B , C ⊢ A
mv₂ = mvar i₂

-- Stacks of derivations, or simultaneous syntactic entailment.

infix 3 _⊢⋆_
_⊢⋆_ : Context → Stack Type → Set
Γ ⁏ Δ ⊢⋆ ∅     = ⊤
Γ ⁏ Δ ⊢⋆ Ξ , A = Γ ⁏ Δ ⊢⋆ Ξ ∧ Γ ⁏ Δ ⊢ A

-- Monotonicity of syntactic entailment with respect to context inclusion.

mono⊢ : ∀ {Γ Γ′ Δ Δ′ A} → Γ ⁏ Δ ⊆² Γ′ ⁏ Δ′ → Γ ⁏ Δ ⊢ A → Γ′ ⁏ Δ′ ⊢ A
mono⊢ (η , ρ) (var i)      = var (mono∈ η i)
mono⊢ (η , ρ) (mvar i)     = mvar (mono∈ ρ i)
mono⊢ (η , ρ) (lam d)      = lam (mono⊢ (keep η , ρ) d)
mono⊢ ψ       (app d e)    = app (mono⊢ ψ d) (mono⊢ ψ e)
mono⊢ (η , ρ) (box d)      = box (mono⊢ (bot , ρ) d)
mono⊢ (η , ρ) (unbox d e)  = unbox (mono⊢ (η , ρ) d) (mono⊢ (η , keep ρ) e)
mono⊢ ψ       (pair d e)   = pair (mono⊢ ψ d) (mono⊢ ψ e)
mono⊢ ψ       (fst d)      = fst (mono⊢ ψ d)
mono⊢ ψ       (snd d)      = snd (mono⊢ ψ d)
mono⊢ ψ       unit         = unit
mono⊢ ψ       (boom d)     = boom (mono⊢ ψ d)
mono⊢ ψ       (left d)     = left (mono⊢ ψ d)
mono⊢ ψ       (right d)    = right (mono⊢ ψ d)
mono⊢ (η , ρ) (case d e f) = case (mono⊢ (η , ρ) d) (mono⊢ (keep η , ρ) e)
                                                      (mono⊢ (keep η , ρ) f)

mono⊢⋆ : ∀ {Ξ Γ Γ′ Δ Δ′} → Γ ⁏ Δ ⊆² Γ′ ⁏ Δ′ → Γ ⁏ Δ ⊢⋆ Ξ → Γ′ ⁏ Δ′ ⊢⋆ Ξ
mono⊢⋆ {∅}     ψ ∙       = ∙
mono⊢⋆ {Ξ , A} ψ (ξ , d) = mono⊢⋆ ψ ξ , mono⊢ ψ d

-- Reflexivity of simultaneous syntactic entailment.

refl⊢⋆ : ∀ {Γ Δ} → Γ ⁏ Δ ⊢⋆ Γ
refl⊢⋆ {∅}     = ∙
refl⊢⋆ {Γ , A} = mono⊢⋆ (weak⊆ , refl⊆) refl⊢⋆ , v₀

mrefl⊢⋆ : ∀ {Δ Γ} → Γ ⁏ Δ ⊢⋆ Δ
mrefl⊢⋆ {∅}     = ∙
mrefl⊢⋆ {Δ , A} = mono⊢⋆ (refl⊆ , weak⊆) mrefl⊢⋆ , mv₀

-- Grafting of derivation trees, or simultaneous substitution, or cut.

graft∈ : ∀ {Ξ Γ Δ C} → Γ ⁏ Δ ⊢⋆ Ξ → C ∈ Ξ → Γ ⁏ Δ ⊢ C
graft∈ (ξ , d) top     = d
graft∈ (ξ , d) (pop i) = graft∈ ξ i

graft⊢ : ∀ {Γ Γ′ Δ Δ′ C} → Γ′ ⁏ Δ′ ⊢⋆ Γ → ∅ ⁏ Δ′ ⊢⋆ Δ → Γ ⁏ Δ ⊢ C → Γ′ ⁏ Δ′ ⊢ C
graft⊢ σ τ (var i)      = graft∈ σ i
graft⊢ σ τ (mvar i)     = mono⊢ (bot , refl⊆) (graft∈ τ i)
graft⊢ σ τ (lam d)      = lam (graft⊢ (mono⊢⋆ (weak⊆ , refl⊆) σ , v₀) τ d)
graft⊢ σ τ (app d e)    = app (graft⊢ σ τ d) (graft⊢ σ τ e)
graft⊢ σ τ (box d)      = box (graft⊢ ∙ τ d)
graft⊢ σ τ (unbox d e)  = unbox (graft⊢ σ τ d) (graft⊢ (mono⊢⋆ (refl⊆ , weak⊆) σ)
                                                          (mono⊢⋆ (refl⊆ , weak⊆) τ , mv₀) e)
graft⊢ σ τ (pair d e)   = pair (graft⊢ σ τ d) (graft⊢ σ τ e)
graft⊢ σ τ (fst d)      = fst (graft⊢ σ τ d)
graft⊢ σ τ (snd d)      = snd (graft⊢ σ τ d)
graft⊢ σ τ unit         = unit
graft⊢ σ τ (boom d)     = boom (graft⊢ σ τ d)
graft⊢ σ τ (left d)     = left (graft⊢ σ τ d)
graft⊢ σ τ (right d)    = right (graft⊢ σ τ d)
graft⊢ σ τ (case d e f) = case (graft⊢ σ τ d) (graft⊢ (mono⊢⋆ (weak⊆ , refl⊆) σ , v₀) τ e)
                                                (graft⊢ (mono⊢⋆ (weak⊆ , refl⊆) σ , v₀) τ f)

-- Derivations, or syntactic entailment, in normal form.

mutual
  infix 3 _⊢ⁿᶠ_
  data _⊢ⁿᶠ_ : Context → Type → Set where
    lamⁿᶠ   : ∀ {A B Γ Δ}   → Γ , A ⁏ Δ ⊢ⁿᶠ B → Γ ⁏ Δ ⊢ⁿᶠ A ⇒ B
    boxⁿᶠ   : ∀ {A Γ Δ}     → ∅ ⁏ Δ ⊢ A → Γ ⁏ Δ ⊢ⁿᶠ □ A
    pairⁿᶠ  : ∀ {A B Γ Δ}   → Γ ⁏ Δ ⊢ⁿᶠ A → Γ ⁏ Δ ⊢ⁿᶠ B → Γ ⁏ Δ ⊢ⁿᶠ A ⩕ B
    unitⁿᶠ  : ∀ {Γ Δ}       → Γ ⁏ Δ ⊢ⁿᶠ ⫪
    leftⁿᶠ  : ∀ {A B Γ Δ}   → Γ ⁏ Δ ⊢ⁿᶠ A → Γ ⁏ Δ ⊢ⁿᶠ A ⩖ B
    rightⁿᶠ : ∀ {A B Γ Δ}   → Γ ⁏ Δ ⊢ⁿᶠ B → Γ ⁏ Δ ⊢ⁿᶠ A ⩖ B
    neⁿᶠ    : ∀ {A Γ Δ}     → Γ ⁏ Δ ⊢ⁿᵉ A → Γ ⁏ Δ ⊢ⁿᶠ A

  infix 3 _⊢ⁿᵉ_
  data _⊢ⁿᵉ_ : Context → Type → Set where
    varⁿᵉ   : ∀ {A Γ Δ}     → A ∈ Γ → Γ ⁏ Δ ⊢ⁿᵉ A
    mvarⁿᵉ  : ∀ {A Γ Δ}     → A ∈ Δ → Γ ⁏ Δ ⊢ⁿᵉ A
    appⁿᵉ   : ∀ {A B Γ Δ}   → Γ ⁏ Δ ⊢ⁿᵉ A ⇒ B → Γ ⁏ Δ ⊢ⁿᶠ A → Γ ⁏ Δ ⊢ⁿᵉ B
    unboxⁿᵉ : ∀ {A C Γ Δ}   → Γ ⁏ Δ ⊢ⁿᵉ □ A → Γ ⁏ Δ , A ⊢ⁿᶠ C → Γ ⁏ Δ ⊢ⁿᵉ C
    fstⁿᵉ   : ∀ {A B Γ Δ}   → Γ ⁏ Δ ⊢ⁿᵉ A ⩕ B → Γ ⁏ Δ ⊢ⁿᵉ A
    sndⁿᵉ   : ∀ {A B Γ Δ}   → Γ ⁏ Δ ⊢ⁿᵉ A ⩕ B → Γ ⁏ Δ ⊢ⁿᵉ B
    boomⁿᵉ  : ∀ {C Γ Δ}     → Γ ⁏ Δ ⊢ⁿᵉ ⫫ → Γ ⁏ Δ ⊢ⁿᵉ C
    caseⁿᵉ  : ∀ {A B C Γ Δ} → Γ ⁏ Δ ⊢ⁿᵉ A ⩖ B → Γ , A ⁏ Δ ⊢ⁿᶠ C → Γ , B ⁏ Δ ⊢ⁿᶠ C → Γ ⁏ Δ ⊢ⁿᵉ C

-- Shorthand for variables.

v₀ⁿᵉ : ∀ {Γ Δ A} → Γ , A ⁏ Δ ⊢ⁿᵉ A
v₀ⁿᵉ = varⁿᵉ top

mv₀ⁿᵉ : ∀ {Γ Δ A} → Γ ⁏ Δ , A ⊢ⁿᵉ A
mv₀ⁿᵉ = mvarⁿᵉ top

-- Stacks of derivations, or simultaneous syntactic entailment, in normal form.

infix 3 _⊢⋆ⁿᵉ_
_⊢⋆ⁿᵉ_ : Context → Stack Type → Set
Γ ⁏ Δ ⊢⋆ⁿᵉ ∅     = ⊤
Γ ⁏ Δ ⊢⋆ⁿᵉ Ξ , A = Γ ⁏ Δ ⊢⋆ⁿᵉ Ξ ∧ Γ ⁏ Δ ⊢ⁿᵉ A

-- Translation from normal form to arbitrary form.

mutual
  nf→af : ∀ {Γ Δ A} → Γ ⁏ Δ ⊢ⁿᶠ A → Γ ⁏ Δ ⊢ A
  nf→af (neⁿᶠ d)       = ne→af d
  nf→af (lamⁿᶠ d)      = lam (nf→af d)
  nf→af (boxⁿᶠ d)      = box d
  nf→af (pairⁿᶠ d e)   = pair (nf→af d) (nf→af e)
  nf→af unitⁿᶠ         = unit
  nf→af (leftⁿᶠ d)     = left (nf→af d)
  nf→af (rightⁿᶠ d)    = right (nf→af d)

  ne→af : ∀ {Γ Δ A} → Γ ⁏ Δ ⊢ⁿᵉ A → Γ ⁏ Δ ⊢ A
  ne→af (varⁿᵉ i)      = var i
  ne→af (mvarⁿᵉ i)     = mvar i
  ne→af (appⁿᵉ d e)    = app (ne→af d) (nf→af e)
  ne→af (unboxⁿᵉ d e)  = unbox (ne→af d) (nf→af e)
  ne→af (fstⁿᵉ d)      = fst (ne→af d)
  ne→af (sndⁿᵉ d)      = snd (ne→af d)
  ne→af (boomⁿᵉ d)     = boom (ne→af d)
  ne→af (caseⁿᵉ d e f) = case (ne→af d) (nf→af e) (nf→af f)

-- Monotonicity of syntactic entailment with respect to context inclusion, in normal form.

mutual
  mono⊢ⁿᶠ : ∀ {Γ Γ′ Δ Δ′ A} → Γ ⁏ Δ ⊆² Γ′ ⁏ Δ′ → Γ ⁏ Δ ⊢ⁿᶠ A → Γ′ ⁏ Δ′ ⊢ⁿᶠ A
  mono⊢ⁿᶠ (η , ρ) (lamⁿᶠ d)      = lamⁿᶠ (mono⊢ⁿᶠ (keep η , ρ) d)
  mono⊢ⁿᶠ (η , ρ) (boxⁿᶠ d)      = boxⁿᶠ (mono⊢ (bot , ρ) d)
  mono⊢ⁿᶠ ψ       (pairⁿᶠ d e)   = pairⁿᶠ (mono⊢ⁿᶠ ψ d) (mono⊢ⁿᶠ ψ e)
  mono⊢ⁿᶠ ψ       unitⁿᶠ         = unitⁿᶠ
  mono⊢ⁿᶠ ψ       (leftⁿᶠ d)     = leftⁿᶠ (mono⊢ⁿᶠ ψ d)
  mono⊢ⁿᶠ ψ       (rightⁿᶠ d)    = rightⁿᶠ (mono⊢ⁿᶠ ψ d)
  mono⊢ⁿᶠ ψ       (neⁿᶠ d)       = neⁿᶠ (mono⊢ⁿᵉ ψ d)

  mono⊢ⁿᵉ : ∀ {Γ Γ′ Δ Δ′ A} → Γ ⁏ Δ ⊆² Γ′ ⁏ Δ′ → Γ ⁏ Δ ⊢ⁿᵉ A → Γ′ ⁏ Δ′ ⊢ⁿᵉ A
  mono⊢ⁿᵉ (η , ρ) (varⁿᵉ i)      = varⁿᵉ (mono∈ η i)
  mono⊢ⁿᵉ (η , ρ) (mvarⁿᵉ i)     = mvarⁿᵉ (mono∈ ρ i)
  mono⊢ⁿᵉ ψ       (appⁿᵉ d e)    = appⁿᵉ (mono⊢ⁿᵉ ψ d) (mono⊢ⁿᶠ ψ e)
  mono⊢ⁿᵉ (η , ρ) (unboxⁿᵉ d e)  = unboxⁿᵉ (mono⊢ⁿᵉ (η , ρ) d) (mono⊢ⁿᶠ (η , keep ρ) e)
  mono⊢ⁿᵉ ψ       (fstⁿᵉ d)      = fstⁿᵉ (mono⊢ⁿᵉ ψ d)
  mono⊢ⁿᵉ ψ       (sndⁿᵉ d)      = sndⁿᵉ (mono⊢ⁿᵉ ψ d)
  mono⊢ⁿᵉ ψ       (boomⁿᵉ d)     = boomⁿᵉ (mono⊢ⁿᵉ ψ d)
  mono⊢ⁿᵉ (η , ρ) (caseⁿᵉ d e f) = caseⁿᵉ (mono⊢ⁿᵉ (η , ρ) d) (mono⊢ⁿᶠ (keep η , ρ) e)
                                                                (mono⊢ⁿᶠ (keep η , ρ) f)

mono⊢⋆ⁿᵉ : ∀ {Ξ Γ Γ′ Δ Δ′} → Γ ⁏ Δ ⊆² Γ′ ⁏ Δ′ → Γ ⁏ Δ ⊢⋆ⁿᵉ Ξ → Γ′ ⁏ Δ′ ⊢⋆ⁿᵉ Ξ
mono⊢⋆ⁿᵉ {∅}     ψ ∙       = ∙
mono⊢⋆ⁿᵉ {Ξ , A} ψ (ξ , d) = mono⊢⋆ⁿᵉ ψ ξ , mono⊢ⁿᵉ ψ d

-- Reflexivity of simultaneous syntactic entailment, in normal form.

refl⊢⋆ⁿᵉ : ∀ {Γ Δ} → Γ ⁏ Δ ⊢⋆ⁿᵉ Γ
refl⊢⋆ⁿᵉ {∅}     = ∙
refl⊢⋆ⁿᵉ {Γ , A} = mono⊢⋆ⁿᵉ (weak⊆ , refl⊆) refl⊢⋆ⁿᵉ , v₀ⁿᵉ

mrefl⊢⋆ⁿᵉ : ∀ {Δ Γ} → Γ ⁏ Δ ⊢⋆ⁿᵉ Δ
mrefl⊢⋆ⁿᵉ {∅}     = ∙
mrefl⊢⋆ⁿᵉ {Δ , A} = mono⊢⋆ⁿᵉ (refl⊆ , weak⊆) mrefl⊢⋆ⁿᵉ , mv₀ⁿᵉ


postulate
  P : (A : Set) → A → Set
  X : Set
  x : X

P' : (A : Set) → _

R : Set
R = P' _ x

P' = P


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

open import Categories.Category
open import Categories.Category.Monoidal
open import Categories.Category.Monoidal.Closed

module Categories.Category.Monoidal.Closed.IsClosed.Pentagon
  {o ℓ e} {C : Category o ℓ e} {M : Monoidal C} (Cl : Closed M) where

open import Data.Product using (Σ; _,_)
open import Function using (_$_) renaming (_∘_ to _∙_)
open import Function.Equality as Π using (Π)

open import Categories.Category.Product
open import Categories.Category.Monoidal.Properties M
open import Categories.Morphism C
open import Categories.Morphism.Properties C
open import Categories.Morphism.Reasoning C
open import Categories.Functor renaming (id to idF)
open import Categories.Functor.Bifunctor
open import Categories.Functor.Bifunctor.Properties
open import Categories.NaturalTransformation hiding (id)
open import Categories.NaturalTransformation.Dinatural hiding (_∘ʳ_)
open import Categories.NaturalTransformation.NaturalIsomorphism as NI hiding (refl)
import Categories.Category.Closed as Cls

open Closed Cl

private
  module C = Category C
  open Category C
  open Commutation
  module ℱ = Functor
  module ⊗ = Functor ⊗
  α⇒ = associator.from
  α⇐ = associator.to
  λ⇒ = unitorˡ.from
  λ⇐ = unitorˡ.to
  ρ⇒ = unitorʳ.from
  ρ⇐ = unitorʳ.to

open HomReasoning
open Π.Π
open adjoint renaming (unit to η; counit to ε; Ladjunct to 𝕃; Ladjunct-comm′ to 𝕃-comm′;
 Ladjunct-resp-≈ to 𝕃-resp-≈)

open import Categories.Category.Monoidal.Closed.IsClosed.Identity Cl
open import Categories.Category.Monoidal.Closed.IsClosed.L Cl

-- some intermediate steps as lemmas

private
-- ⊗.F₀ (⊗.F₀ ([-,-].F₀ (u , v) , [-,-].F₀ (x , u)) , x) ⇒ v
  inner : {x : Obj} (v u : Obj) → ((Functor.F₀ [ u ,-] v) ⊗₀ (Functor.F₀ [ x ,-] u) ) ⊗₀ x ⇒ v
  inner {x} v u = ε.η v ∘ id ⊗₁ ε.η {x} u ∘ α⇒

  VU-UY⇒VY-VU : {U V X Y : Obj} → inner {X} V U ∘ (id ⊗₁ 𝕃 (inner U Y) ∘ α⇒) ⊗₁ id ≈
                          inner V Y ∘ (𝕃 (inner V U) ⊗₁ id) ⊗₁ id
  VU-UY⇒VY-VU {U} {V} {X} {Y} = begin
    inner V U ∘ (id ⊗₁ 𝕃 (inner U Y) ∘ α⇒) ⊗₁ id                        ≈⟨ pushʳ $ ℱ.homomorphism (-⊗ X) ⟩
    (inner V U ∘ (id ⊗₁ 𝕃 (inner U Y)) ⊗₁ id) ∘ α⇒ ⊗₁ id                ≈⟨ pull-last assoc-commute-from ⟩∘⟨refl ⟩
    (ε.η V ∘ id ⊗₁ ε.η U ∘ id ⊗₁ 𝕃 (inner U Y) ⊗₁ id ∘ α⇒) ∘ α⇒ ⊗₁ id   ≈⟨ (∘-resp-≈ʳ $ pullˡ $ ⟺ (ℱ.homomorphism ([ U , V ]₀ ⊗-))) ⟩∘⟨refl ⟩
    (ε.η V ∘ id ⊗₁ (ε.η U ∘ 𝕃 (inner U Y) ⊗₁ id) ∘ α⇒) ∘ α⇒ ⊗₁ id       ≈⟨ ∘-resp-≈ˡ (⟺ assoc) ○ assoc ⟩
    (ε.η V ∘ id ⊗₁ (ε.η U ∘ 𝕃 (inner U Y) ⊗₁ id)) ∘ (α⇒ ∘ α⇒ ⊗₁ id)     ≈⟨ ∘-resp-≈ˡ $ ∘-resp-≈ʳ $ ℱ.F-resp-≈ ([ U , V ]₀ ⊗-) (RLadjunct≈id ○ ⟺ assoc) ⟩
    (ε.η V ∘ id ⊗₁ ((ε.η U ∘ id ⊗₁ ε.η Y) ∘ α⇒)) ∘ (α⇒ ∘ α⇒ ⊗₁ id)      ≈⟨ ∘-resp-≈ˡ $ ∘-resp-≈ʳ $ ℱ.homomorphism ([ U , V ]₀ ⊗-) ⟩
    (ε.η V ∘ id ⊗₁ (ε.η U ∘ id ⊗₁ ε.η Y) ∘ id ⊗₁ α⇒) ∘ (α⇒ ∘ α⇒ ⊗₁ id)  ≈⟨ pull-last refl ⟩
    ε.η V ∘ id ⊗₁ (ε.η U ∘ id ⊗₁ ε.η Y) ∘ (id ⊗₁ α⇒ ∘ α⇒ ∘ α⇒ ⊗₁ id)    ≈⟨ refl⟩∘⟨ ∘-resp-≈ (ℱ.homomorphism ([ U , V ]₀ ⊗-)) pentagon ⟩
    ε.η V ∘ (id ⊗₁ ε.η U ∘ id ⊗₁ (id ⊗₁ ε.η Y)) ∘ (α⇒ ∘ α⇒)             ≈⟨ ⟺ assoc ○ ⟺ assoc ⟩
    ((ε.η V ∘ id ⊗₁ ε.η U ∘ id ⊗₁ (id ⊗₁ ε.η Y)) ∘ α⇒) ∘ α⇒             ≈⟨ pull-last (⟺ assoc-commute-from) ⟩∘⟨refl ⟩
    (ε.η V ∘ id ⊗₁ ε.η U ∘ α⇒ ∘ (id ⊗₁ id) ⊗₁ ε.η Y) ∘ α⇒                ≈⟨ assoc ○ ∘-resp-≈ʳ (∘-resp-≈ˡ (⟺ assoc)) ○ ⟺ (center refl) ⟩
    (ε.η V ∘ id ⊗₁ ε.η U ∘ α⇒) ∘ (id ⊗₁ id) ⊗₁ ε.η Y ∘ α⇒                ≈⟨ ∘-resp-≈ʳ $ ∘-resp-≈ˡ $ ⊗.F-resp-≈ (⊗.identity , refl) ⟩
    (ε.η V ∘ id ⊗₁ ε.η U ∘ α⇒) ∘ id ⊗₁ ε.η Y ∘ α⇒                        ≈˘⟨ center⁻¹ RLadjunct≈id refl ⟩
    ε.η V ∘ (𝕃 (ε.η V ∘ id ⊗₁ ε.η U ∘ α⇒) ⊗₁ id ∘ id ⊗₁ ε.η Y) ∘ α⇒      ≈⟨ ∘-resp-≈ʳ $ pushˡ (⟺ [ ⊗ ]-commute) ⟩
    ε.η V ∘ id ⊗₁ ε.η Y ∘ 𝕃 (inner V U) ⊗₁ id ∘ α⇒                       ≈˘⟨ refl⟩∘⟨ refl⟩∘⟨ ⊗.F-resp-≈ (refl , ⊗.identity) ⟩∘⟨refl ⟩
    ε.η V ∘ id ⊗₁ ε.η Y ∘ 𝕃 (inner V U) ⊗₁ (id ⊗₁ id) ∘ α⇒               ≈˘⟨ pull-last assoc-commute-from ⟩
    (inner V Y) ∘ (𝕃 (inner V U) ⊗₁ id) ⊗₁ id                             ∎

  expand-[-,-] : {U V X Y : Obj} →
      (ε.η [ X , V ]₀ ∘ id ⊗₁ ε.η [ X , U ]₀ ∘ α⇒) ∘ (L X U V ⊗₁ L X Y U) ⊗₁ id ≈
      𝕃 (ε.η V ∘ id ⊗₁ ε.η Y ∘ α⇒) ∘ 𝕃 (ε.η V ∘ id ⊗₁ ε.η U ∘ α⇒) ⊗₁ id
  expand-[-,-] {U} {V} {X} {Y} = begin
    (inner XV XU) ∘ (L X U V ⊗₁ L X Y U) ⊗₁ id                        ≈⟨ pull-last assoc-commute-from ⟩
    ε.η XV ∘ id ⊗₁ ε.η XU ∘ L X U V ⊗₁ L X Y U ⊗₁ id ∘ α⇒             ≈⟨ refl⟩∘⟨ pullˡ (⟺ ⊗.homomorphism ○ ⊗.F-resp-≈ (identityˡ , refl)) ⟩
    ε.η XV ∘ L X U V ⊗₁ (ε.η XU ∘ L X Y U ⊗₁ id) ∘ α⇒                 ≈⟨ refl⟩∘⟨ [ ⊗ ]-decompose₁ ⟩∘⟨refl ⟩
    ε.η XV ∘ (L X U V ⊗₁ id ∘ id ⊗₁ (ε.η XU ∘ L X Y U ⊗₁ id)) ∘ α⇒    ≈⟨ center⁻¹ RLadjunct≈id (∘-resp-≈ˡ (ℱ.F-resp-≈ ([ U , V ]₀ ⊗-) RLadjunct≈id)) ⟩
    𝕃 (inner V U) ∘ (id ⊗₁ 𝕃 (inner U Y) ∘ α⇒)                         ≈˘⟨ 𝕃-comm′ ⟩
    𝕃 (inner V U ∘ (id ⊗₁ 𝕃 (inner U Y) ∘ α⇒) ⊗₁ id)                   ≈⟨ 𝕃-resp-≈ VU-UY⇒VY-VU ⟩
    𝕃 (inner V Y ∘ (𝕃 (inner V U) ⊗₁ id) ⊗₁ id)                        ≈⟨ 𝕃-comm′ ⟩
    𝕃 (inner V Y) ∘ 𝕃 (inner V U) ⊗₁ id ∎
    where
    XV = [ X , V ]₀
    XU = [ X , U ]₀
    UV = [ U , V ]₀

pentagon′ : {U V X Y : Obj} →
            [ [ U , V ]₀ ⇒ [ [ Y , U ]₀ , [ [ X , Y ]₀ , [ X , V ]₀ ]₀ ]₀ ]⟨
             L X U V                            ⇒⟨ [ [ X , U ]₀ , [ X , V ]₀ ]₀ ⟩
             L [ X , Y ]₀ [ X , U ]₀ [ X , V ]₀ ⇒⟨ [ [ [ X , Y ]₀ , [ X , U ]₀ ]₀ , [ [ X , Y ]₀ , [ X , V ]₀ ]₀ ]₀ ⟩
             [ L X Y U , id ]₁
           ≈ L Y U V                            ⇒⟨ [ [ Y , U ]₀ , [ Y , V ]₀ ]₀ ⟩
             [ id , L X Y V ]₁
           ⟩
pentagon′ {U} {V} {X} {Y} = begin
  [ L X Y U , id ]₁ ∘ L [ X , Y ]₀ XU XV ∘ L X U V                               ≈˘⟨ refl ⟩∘⟨ 𝕃-comm′ ⟩
  [ L X Y U , id ]₁ ∘ 𝕃 (𝕃 (ε.η XV ∘ id ⊗₁ ε.η XU ∘ α⇒) ∘ L X U V ⊗₁ id)        ≈˘⟨ pushˡ [ [-,-] ]-commute ⟩
  ([ id , 𝕃 (inner XV XU) ∘ L X U V ⊗₁ id ]₁ ∘ [ L X Y U , id ]₁) ∘ η.η UV       ≈˘⟨ pushʳ (mate.commute₁ (L X Y U)) ⟩
  [ id , 𝕃 (inner XV XU) ∘ L X U V ⊗₁ id ]₁ ∘ [ id , id ⊗₁ L X Y U ]₁ ∘ η.η UV   ≈˘⟨ pushˡ (ℱ.homomorphism [ [ Y , U ]₀ ,-]) ⟩
  𝕃 ((𝕃 (inner XV XU) ∘ L X U V ⊗₁ id) ∘ id ⊗₁ L X Y U)                          ≈˘⟨ 𝕃-resp-≈ $ pushʳ [ ⊗ ]-decompose₁ ⟩
  𝕃 (𝕃 (inner XV XU) ∘ L X U V ⊗₁ L X Y U)                                       ≈˘⟨ 𝕃-resp-≈ $ 𝕃-comm′ ⟩
  𝕃 (𝕃 $ (inner XV XU) ∘ (L X U V ⊗₁ L X Y U) ⊗₁ id)                             ≈⟨ 𝕃-resp-≈ $ 𝕃-resp-≈ $ expand-[-,-] ⟩
  𝕃 (𝕃 $ 𝕃 (inner V Y) ∘ 𝕃 (inner V U) ⊗₁ id)                                    ≈⟨ 𝕃-resp-≈ 𝕃-comm′ ⟩
  𝕃 (L X Y V ∘ 𝕃 (inner V U))                                                     ≈⟨ pushˡ (ℱ.homomorphism [ [ Y , U ]₀ ,-]) ⟩
  [ id , L X Y V ]₁ ∘ L Y U V                                                     ∎
  where
  XV = [ X , V ]₀
  XU = [ X , U ]₀
  UV = [ U , V ]₀


{-# OPTIONS --safe --experimental-lossy-unification #-}
module Cubical.Algebra.Polynomials.Multivariate.Equiv.Comp-Poly where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Isomorphism

open import Cubical.Data.Nat renaming (_+_ to _+n_; _·_ to _·n_)
open import Cubical.Data.Vec
open import Cubical.Data.Sigma

open import Cubical.Algebra.Ring
open import Cubical.Algebra.CommRing

open import Cubical.Algebra.Polynomials.Univariate.Base

open import Cubical.Algebra.Polynomials.Multivariate.Base
open import Cubical.Algebra.Polynomials.Multivariate.Properties
open import Cubical.Algebra.CommRing.Instances.MultivariatePoly

private variable
  ℓ ℓ' : Level

module Comp-Poly-nm (A' : CommRing ℓ) (n m : ℕ) where
  private
    A = fst A'
  open CommRingStr (snd A')

  module Mr  = Nth-Poly-structure A' m
  module N+Mr = Nth-Poly-structure A' (n +n m)
  module N∘Mr  = Nth-Poly-structure (PolyCommRing A' m) n

-----------------------------------------------------------------------------
-- direct sens

  N∘M→N+M-b : (v : Vec ℕ n) → Poly A' m → Poly A' (n +n m)
  N∘M→N+M-b v = Poly-Rec-Set.f A' m (Poly A' (n +n m)) trunc
                0P
                (λ v' a → base (v ++ v') a)
                _Poly+_
                Poly+-assoc
                Poly+-Rid
                Poly+-comm
                (λ v' → base-0P (v ++ v'))
                (λ v' a b → base-Poly+ (v ++ v') a b)

  N∘M→N+M : Poly (PolyCommRing A' m) n → Poly A' (n +n m)
  N∘M→N+M = Poly-Rec-Set.f (PolyCommRing A' m) n (Poly A' (n +n m)) trunc
           0P
           N∘M→N+M-b
           _Poly+_
           Poly+-assoc
           Poly+-Rid
           Poly+-comm
           (λ _ → refl)
           (λ v a b → refl)

-- -----------------------------------------------------------------------------
-- -- Converse sens

  N+M→N∘M : Poly A' (n +n m) → Poly (PolyCommRing A' m) n
  N+M→N∘M = Poly-Rec-Set.f A' (n +n m) (Poly (PolyCommRing A' m) n) trunc
            0P
            (λ v a → let v , v'  = sep-vec n m v in
                      base v (base v' a))
            _Poly+_
            Poly+-assoc
            Poly+-Rid
            Poly+-comm
            (λ v → (cong (base (fst (sep-vec n m v))) (base-0P (snd (sep-vec n m v)))) ∙ (base-0P (fst (sep-vec n m v))))
            λ v a b → base-Poly+ (fst (sep-vec n m v)) (base (snd (sep-vec n m v)) a) (base (snd (sep-vec n m v)) b)
                       ∙ cong (base (fst (sep-vec n m v))) (base-Poly+ (snd (sep-vec n m v)) a b)

-----------------------------------------------------------------------------
-- Section

  e-sect : (P : Poly A' (n +n m)) → N∘M→N+M (N+M→N∘M P) ≡ P
  e-sect = Poly-Ind-Prop.f A' (n +n m)
           (λ P → N∘M→N+M (N+M→N∘M P) ≡ P)
           (λ _ → trunc _ _)
           refl
           (λ v a → cong (λ X → base X a) (sep-vec-id n m v))
           (λ {U V} ind-U ind-V → cong₂ _Poly+_ ind-U ind-V)

-----------------------------------------------------------------------------
-- Retraction

  e-retr : (P : Poly (PolyCommRing A' m) n) → N+M→N∘M (N∘M→N+M P) ≡ P
  e-retr = Poly-Ind-Prop.f (PolyCommRing A' m) n
           (λ P → N+M→N∘M (N∘M→N+M P) ≡ P)
           (λ _ → trunc _ _)
           refl
           (λ v → Poly-Ind-Prop.f A' m
                   (λ P → N+M→N∘M (N∘M→N+M (base v P)) ≡ base v P)
                   (λ _ → trunc _ _)
                   (sym (base-0P v))
                   (λ v' a → cong₂ base (sep-vec-fst n m v v') (cong (λ X → base X a) (sep-vec-snd n m v v')))
                   (λ {U V} ind-U ind-V → (cong₂ _Poly+_ ind-U ind-V) ∙ (base-Poly+ v U V)))
           (λ {U V} ind-U ind-V → cong₂ _Poly+_ ind-U ind-V )

-----------------------------------------------------------------------------
-- Morphism of ring

  map-0P : N∘M→N+M (0P) ≡ 0P
  map-0P = refl

  N∘M→N+M-gmorph : (P Q : Poly (PolyCommRing A' m) n) → N∘M→N+M ( P Poly+ Q) ≡ N∘M→N+M P Poly+ N∘M→N+M Q
  N∘M→N+M-gmorph = λ P Q → refl

  map-1P : N∘M→N+M (N∘Mr.1P) ≡ N+Mr.1P
  map-1P = cong (λ X → base X 1r) (rep-concat n m 0 )

  N∘M→N+M-rmorph : (P Q : Poly (PolyCommRing A' m) n) → N∘M→N+M ( P N∘Mr.Poly* Q) ≡ N∘M→N+M P N+Mr.Poly* N∘M→N+M Q
  N∘M→N+M-rmorph =
    -- Ind P
    Poly-Ind-Prop.f (PolyCommRing A' m) n
    (λ P → (Q : Poly (PolyCommRing A' m) n) → N∘M→N+M (P N∘Mr.Poly* Q) ≡ (N∘M→N+M P N+Mr.Poly* N∘M→N+M Q))
    (λ P p q i Q j → trunc _ _ (p Q) (q Q) i j)
    (λ Q → refl)
    (λ v → -- Ind Base P
           Poly-Ind-Prop.f A' m
           (λ P → (Q : Poly (PolyCommRing A' m) n) → N∘M→N+M (base v P N∘Mr.Poly* Q) ≡ (N∘M→N+M (base v P) N+Mr.Poly* N∘M→N+M Q))
           (λ P p q i Q j → trunc _ _ (p Q) (q Q) i j)
           (λ Q → cong (λ X → N∘M→N+M (X N∘Mr.Poly* Q)) (base-0P v))
           (λ v' a → -- Ind Q
                      Poly-Ind-Prop.f (PolyCommRing A' m) n
                      (λ Q → N∘M→N+M (base v (base v' a) N∘Mr.Poly* Q) ≡ (N∘M→N+M (base v (base v' a)) N+Mr.Poly* N∘M→N+M Q))
                      (λ _ → trunc _ _)
                      (sym (N+Mr.0PRightAnnihilatesPoly (N∘M→N+M (base v (base v' a)))))
                      (λ w → -- Ind base Q
                              Poly-Ind-Prop.f A' m
                              _
                              (λ _ → trunc _ _)
                              (sym (N+Mr.0PRightAnnihilatesPoly (N∘M→N+M (base v (base v' a)))))
                              (λ w' b → cong (λ X → base X (a · b)) (+n-vec-concat n m v w v' w'))
                              λ {U V} ind-U ind-V → cong (λ X → N∘M→N+M (base v (base v' a) N∘Mr.Poly* X)) (sym (base-Poly+ w U V))
                                                     ∙ cong₂ (_Poly+_ ) ind-U ind-V
                                                     ∙ sym (cong (λ X → N∘M→N+M (base v (base v' a)) N+Mr.Poly* N∘M→N+M X) (base-Poly+ w U V)) )
                              -- End Ind base Q
                      λ {U V} ind-U ind-V → cong₂ _Poly+_ ind-U ind-V)
                      -- End Ind Q
           λ {U V} ind-U ind-V Q → cong (λ X → N∘M→N+M (X N∘Mr.Poly* Q)) (sym (base-Poly+ v U V))
                                    ∙ cong₂ _Poly+_ (ind-U Q) (ind-V Q)
                                    ∙ sym (cong (λ X → (N∘M→N+M X) N+Mr.Poly* (N∘M→N+M Q)) (sym (base-Poly+ v U V)) ))
           -- End Ind base P
     λ {U V} ind-U ind-V Q → cong₂ _Poly+_ (ind-U Q) (ind-V Q)
     -- End Ind P

-----------------------------------------------------------------------------
-- Ring Equivalence

module _ (A' : CommRing ℓ) (n m : ℕ) where

  open Comp-Poly-nm A' n m

  CRE-PolyN∘M-PolyN+M : CommRingEquiv (PolyCommRing (PolyCommRing A' m) n) (PolyCommRing A' (n +n m))
  fst CRE-PolyN∘M-PolyN+M = isoToEquiv is
    where
    is : Iso _ _
    Iso.fun is = N∘M→N+M
    Iso.inv is = N+M→N∘M
    Iso.rightInv is = e-sect
    Iso.leftInv is = e-retr

  snd CRE-PolyN∘M-PolyN+M = makeIsRingHom map-1P N∘M→N+M-gmorph N∘M→N+M-rmorph


-- Andreas, 2019-05-03, issue #3742, reported by nad
--
-- Regression introduced in 2.5.2:
--
-- getConstInfo applied to abstract constructor D.c
-- in metaOccurs check throws funny "not in scope" error for D.c

record Σ (A : Set) (B : A → Set₁) : Set₁ where

mutual

  abstract

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

  F : Set → Set₁
  F A = Σ _ λ (_ : D A) → Set

-- Should succeed.


------------------------------------------------------------------------------
-- Properties for the equality on streams
------------------------------------------------------------------------------

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

module FOTC.Data.Stream.Equality.PropertiesATP where

open import FOTC.Base
open import FOTC.Base.List
open import FOTC.Data.Stream.Type
open import FOTC.Relation.Binary.Bisimilarity.PropertiesATP
open import FOTC.Relation.Binary.Bisimilarity.Type

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

postulate stream-≡→≈ : ∀ {xs ys} → Stream xs → Stream ys → xs ≡ ys → xs ≈ ys
{-# ATP prove stream-≡→≈ ≈-refl #-}

-- See Issue https://github.com/asr/apia/issues/81 .
≈→Stream₁A : D → Set
≈→Stream₁A ws = ∃[ zs ] ws ≈ zs
{-# ATP definition ≈→Stream₁A #-}

≈→Stream₁ : ∀ {xs ys} → xs ≈ ys → Stream xs
≈→Stream₁ {xs} {ys} h = Stream-coind ≈→Stream₁A h' (ys , h)
  where
  postulate h' : ∀ {xs} → ≈→Stream₁A xs →
                 ∃[ x' ] ∃[ xs' ] xs ≡ x' ∷ xs' ∧ ≈→Stream₁A xs'
  {-# ATP prove h' #-}

-- See Issue https://github.com/asr/apia/issues/81 .
≈→Stream₂A : D → Set
≈→Stream₂A zs = ∃[ ws ] ws ≈ zs
{-# ATP definition ≈→Stream₂A #-}

≈→Stream₂ : ∀ {xs ys} → xs ≈ ys → Stream ys
≈→Stream₂ {xs} {ys} h = Stream-coind ≈→Stream₂A h' (xs , h)
  where
  postulate h' : ∀ {ys} → ≈→Stream₂A ys →
                 ∃[ y' ] ∃[ ys' ] ys ≡ y' ∷ ys' ∧ ≈→Stream₂A ys'
  {-# ATP prove h' #-}

≈→Stream : ∀ {xs ys} → xs ≈ ys → Stream xs ∧ Stream ys
≈→Stream {xs} {ys} h = ≈→Stream₁ h , ≈→Stream₂ h


{-# OPTIONS --rewriting #-}

open import Common.Nat
open import Common.Equality

postulate _↦_ : ∀ {a} {A : Set a} → A → A → Set

{-# BUILTIN REWRITE _↦_ #-}

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

postulate rew₁ : (f : Nat → Nat → Nat) → P (λ (x y z : Nat) → f z x) ↦ P f

{-# REWRITE rew₁ #-}

f : Nat → Nat → Nat → Nat
f x _ z = x + z

test : P f ≡ P (λ x z → z + x)
test = refl

postulate rew₂ : (f : Nat → Nat) → P (λ (x y : Nat) → f y) ↦ P f

{-# REWRITE rew₂ #-}

g : Nat → Nat → Nat
g x y = y

test₂ : P g ≡ P (λ (y : Nat) → y)
test₂ = refl

h : Nat → Nat → Nat → Nat
h x y z = x

test₃ : P h ≡ P (λ (z : Nat) → z)
test₃ = refl


module Class.Show where

open import Data.String using (String)

record Show {a} (A : Set a) : Set a where
  field
    show : A -> String

open Show {{...}} public


open import Mockingbird.Forest using (Forest)

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

open import Data.Product using (_×_; _,_; proj₁; proj₂; ∃-syntax)
open import Data.Unit using (⊤; tt)
open import Function using (_$_)

import Mockingbird.Problems.Chapter09 forest as Chapter₉

open Forest forest

module Parentheses where
  private
    variable
      u v w x y z A A₁ A₂ B : Bird

  -- A variant of _∙_ that is not parsed as a right-associative operator, to
  -- make sure that the parentheses in the right-hand side of the exercises
  -- below are fully restored.
  infix 6 _∙′_
  _∙′_ = _∙_

  exercise-a : x ∙ y ∙ (z ∙ w ∙ y) ∙ v ≈ ((x ∙′ y) ∙′ ((z ∙′ w) ∙′ y)) ∙′ v
  exercise-a = refl

  exercise-b : (x ∙ y ∙ z) ∙ (w ∙ v ∙ x) ≈ ((x ∙′ y) ∙′ z) ∙′ ((w ∙′ v) ∙′ x)
  exercise-b = refl

  exercise-c : x ∙ y ∙ (z ∙ w ∙ v) ∙ (x ∙ z) ≈ ((x ∙′ y) ∙′ ((z ∙′ w) ∙′ v)) ∙′ (x ∙′ z)
  exercise-c = refl

  exercise-d : x ∙ y ∙ (z ∙ w ∙ v) ∙ x ∙ z ≈ (((x ∙′ y) ∙′ ((z ∙′ w) ∙′ v)) ∙′ x) ∙′ z
  exercise-d = refl

  exercise-e : x ∙ (y ∙ (z ∙ w ∙ v)) ∙ x ∙ z ≈ ((x ∙′ (y ∙′ ((z ∙′ w) ∙′ v))) ∙′ x) ∙′ z
  exercise-e = refl

  exercise-f : x ∙ y ∙ z ∙ (A ∙ B) ≈ (x ∙ y ∙ z) ∙ (A ∙ B)
  exercise-f = refl

  exercise-g : A₁ ≈ A₂ → B ∙ A₁ ≈ B ∙ A₂ × A₁ ∙ B ≈ A₂ ∙ B
  exercise-g A₁≈A₂ = (congˡ A₁≈A₂ , congʳ A₁≈A₂)

  exercise-h : x ∙ y ≈ z → x ∙ y ∙ w ≈ z ∙ w
  exercise-h {x} {y} {z} {w} xy≈z = begin
    x ∙ y ∙ w      ≈⟨⟩
    (x ∙′ y) ∙′ w  ≈⟨ congʳ xy≈z ⟩
    z ∙ w          ∎

  -- The other part of exercise h, wxy ≈ wz, does not follow in general.

open import Mockingbird.Forest.Birds forest

problem₁ : ⦃ _ : HasBluebird ⦄ → HasComposition
problem₁ = record
  { _∘_ = λ C D → B ∙ C ∙ D
  ; isComposition = λ C D x → begin
      B ∙ C ∙ D ∙ x  ≈⟨ isBluebird C D x ⟩
      C ∙ (D ∙ x)    ∎
  }

private
  instance
    hasComposition : ⦃ HasBluebird ⦄ → HasComposition
    hasComposition = problem₁

module _ ⦃ _ : HasBluebird ⦄ ⦃ _ : HasMockingbird ⦄ where
  problem₂ : ∀ x → ∃[ y ] x IsFondOf y
  problem₂ x =
    let (_ , isFond) = Chapter₉.problem₁ x

        shorten : M ∙ (B ∙ x ∙ M) ≈ B ∙ x ∙ M ∙ (B ∙ x ∙ M)
        shorten = isMockingbird (B ∙ x ∙ M)

    in (M ∙ (B ∙ x ∙ M) , trans (congˡ shorten) (trans isFond (sym shorten)))

  problem₃ : ∃[ x ] IsEgocentric x
  problem₃ =
    let (_ , isEgocentric) = Chapter₉.problem₂
    in (B ∙ M ∙ M ∙ (B ∙ M ∙ M) , isEgocentric)

module _ ⦃ _ : HasBluebird ⦄ ⦃ _ : HasMockingbird ⦄ ⦃ _ : HasKestrel ⦄ where
  problem₄ : ∃[ x ] IsHopelesslyEgocentric x
  problem₄ =
    let (_ , isHopelesslyEgocentric) = Chapter₉.problem₉
    in (B ∙ K ∙ M ∙ (B ∙ K ∙ M) , isHopelesslyEgocentric)

module _ ⦃ _ : HasBluebird ⦄ where
  problem₅ : HasDove
  problem₅ = record
    { D = B ∙ B
    ; isDove = λ x y z w → begin
        B ∙ B ∙ x ∙ y ∙ z ∙ w  ≈⟨ congʳ $ congʳ $ isBluebird B x y ⟩
        B ∙ (x ∙ y) ∙ z ∙ w    ≈⟨ isBluebird (x ∙ y) z w ⟩
        x ∙ y ∙ (z ∙ w)        ∎
    }

  private instance hasDove = problem₅

  problem₆ : HasBlackbird
  problem₆ = record
    { B₁ = B ∙ B ∙ B
    ; isBlackbird = λ x y z w → begin
        B ∙ B ∙ B ∙ x ∙ y ∙ z ∙ w  ≈⟨ congʳ $ congʳ $ congʳ (isBluebird B B x) ⟩
        B ∙ (B ∙ x) ∙ y ∙ z ∙ w    ≈⟨ congʳ (isBluebird (B ∙ x) y z) ⟩
        B ∙ x ∙ (y ∙ z) ∙ w        ≈⟨ isBluebird x (y ∙ z) w ⟩
        x ∙ (y ∙ z ∙ w)            ∎
    }

  private instance hasBlackbird = problem₆

  problem₇ : HasEagle
  problem₇ = record
    { E = B ∙ B₁
    ; isEagle = λ x y z w v → begin
        B ∙ B₁ ∙ x ∙ y ∙ z ∙ w ∙ v  ≈⟨ congʳ $ congʳ $ congʳ $ isBluebird B₁ x y ⟩
        B₁ ∙ (x ∙ y) ∙ z ∙ w ∙ v    ≈⟨ isBlackbird (x ∙ y) z w v ⟩
        x ∙ y ∙ (z ∙ w ∙ v)         ∎
    }

  private instance hasEagle = problem₇

  problem₈ : HasBunting
  problem₈ = record
    { B₂ = B ∙ B ∙ B₁
    ; isBunting = λ x y z w v → begin
        B ∙ B ∙ B₁ ∙ x ∙ y ∙ z ∙ w ∙ v  ≈⟨ congʳ $ congʳ $ congʳ $ congʳ $ isBluebird B B₁ x ⟩
        B ∙ (B₁ ∙ x) ∙ y ∙ z ∙ w ∙ v    ≈⟨ congʳ $ congʳ $ isBluebird (B₁ ∙ x) y z ⟩
        B₁ ∙ x ∙ (y ∙ z) ∙ w ∙ v        ≈⟨ isBlackbird x (y ∙ z) w v ⟩
        x ∙ (y ∙ z ∙ w ∙ v)             ∎
    }

  private instance hasBunting = problem₈

  problem₉ : HasDickcissel
  problem₉ = record
    { D₁ = B ∙ D
    ; isDickcissel = λ x y z w v → begin
        B ∙ D ∙ x ∙ y ∙ z ∙ w ∙ v  ≈⟨ congʳ $ congʳ $ congʳ $ isBluebird D x y ⟩
        D ∙ (x ∙ y) ∙ z ∙ w ∙ v    ≈⟨ isDove (x ∙ y) z w v ⟩
        x ∙ y ∙ z ∙ (w ∙ v)        ∎
    }

  private instance hasDickcissel = problem₉

  problem₁₀ : HasBecard
  problem₁₀ = record
    { B₃ = B ∙ D ∙ B
    ; isBecard = λ x y z w → begin
        B ∙ D ∙ B ∙ x ∙ y ∙ z ∙ w  ≈⟨ congʳ $ congʳ $ congʳ $ isBluebird D B x ⟩
        D ∙ (B ∙ x) ∙ y ∙ z ∙ w    ≈⟨ isDove (B ∙ x) y z w ⟩
        B ∙ x ∙ y ∙ (z ∙ w)        ≈⟨ isBluebird x y (z ∙ w) ⟩
        x ∙ (y ∙ (z ∙ w))          ∎
    }

  private instance hasBecard = problem₁₀

  problem₁₁ : HasDovekie
  problem₁₁ = record
    { D₂ = D ∙ D
    ; isDovekie = λ x y z w v → begin
        D ∙ D ∙ x ∙ y ∙ z ∙ w ∙ v  ≈⟨ congʳ $ congʳ $ isDove D x y z ⟩
        D ∙ x ∙ (y ∙ z) ∙ w ∙ v    ≈⟨ isDove x (y ∙ z) w v ⟩
        x ∙ (y ∙ z) ∙ (w ∙ v)      ∎
    }

  private instance hasDovekie = problem₁₁

  problem₁₂ : HasBaldEagle
  problem₁₂ = record
    { Ê = E ∙ E
    ; isBaldEagle = λ x y₁ y₂ y₃ z₁ z₂ z₃ → begin
        E ∙ E ∙ x ∙ y₁ ∙ y₂ ∙ y₃ ∙ z₁ ∙ z₂ ∙ z₃  ≈⟨ congʳ $ congʳ $ congʳ $ isEagle E x y₁ y₂ y₃ ⟩
        E ∙ x ∙ (y₁ ∙ y₂ ∙ y₃) ∙ z₁ ∙ z₂ ∙ z₃    ≈⟨ isEagle x (y₁ ∙ y₂ ∙ y₃) z₁ z₂ z₃ ⟩
        x ∙ (y₁ ∙ y₂ ∙ y₃) ∙ (z₁ ∙ z₂ ∙ z₃)      ∎
    }

  private instance hasBaldEagle = problem₁₂

problem₁₄ : ⦃ _ : HasWarbler ⦄ ⦃ _ : HasIdentity ⦄ → HasMockingbird
problem₁₄ = record
  { M = W ∙ I
  ; isMockingbird = λ x → begin
      W ∙ I ∙ x  ≈⟨ isWarbler I x ⟩
      I ∙ x ∙ x  ≈⟨ congʳ $ isIdentity x ⟩
      x ∙ x      ∎
  }

problem₁₅ : ⦃ _ : HasWarbler ⦄ ⦃ _ : HasKestrel ⦄ → HasIdentity
problem₁₅ = record
  { I = W ∙ K
  ; isIdentity = λ x → begin
      W ∙ K ∙ x  ≈⟨ isWarbler K x ⟩
      K ∙ x ∙ x  ≈⟨ isKestrel x x ⟩
      x          ∎
  }

problem₁₃ : ⦃ _ : HasWarbler ⦄ ⦃ _ : HasKestrel ⦄ → HasMockingbird
problem₁₃ = problem₁₄
  where instance _ = problem₁₅

problem₁₆ : ⦃ _ : HasCardinal ⦄ ⦃ _ : HasKestrel ⦄ → HasIdentity
problem₁₆ = record
  { I = C ∙ K ∙ K
  ; isIdentity = λ x → begin
      C ∙ K ∙ K ∙ x  ≈⟨ isCardinal K K x ⟩
      K ∙ x ∙ K      ≈⟨ isKestrel x K ⟩
      x              ∎
  }

problem₁₇ : ⦃ _ : HasCardinal ⦄ ⦃ _ : HasIdentity ⦄ → HasThrush
problem₁₇ = record
  { T = C ∙ I
  ; isThrush = λ x y → begin
      C ∙ I ∙ x ∙ y  ≈⟨ isCardinal I x y ⟩
      I ∙ y ∙ x      ≈⟨ congʳ $ isIdentity y ⟩
      y ∙ x          ∎
  }

problem₁₈ : ⦃ _ : HasThrush ⦄ → (∀ x → IsNormal x) → ∃[ A ] (∀ x → Commute A x)
problem₁₈ isNormal =
  let (A , isFond) = isNormal T

      commute : ∀ x → Commute A x
      commute x = begin
        A ∙ x      ≈˘⟨ (congʳ $ isFond) ⟩
        T ∙ A ∙ x  ≈⟨ isThrush A x ⟩
        x ∙ A      ∎

  in (A , commute)

problem₁₉ : ⦃ _ : HasBluebird ⦄ ⦃ _ : HasThrush ⦄ ⦃ _ : HasMockingbird ⦄ → ∃[ x ] (∀ y → Commute x y)
problem₁₉ = problem₁₈ problem₂

problem₂₀ : ⦃ _ : HasBluebird ⦄ ⦃ _ : HasThrush ⦄ → HasRobin
problem₂₀ = record
  { R = B ∙ B ∙ T
  ; isRobin = λ x y z → begin
      B ∙ B ∙ T ∙ x ∙ y ∙ z  ≈⟨ congʳ $ congʳ $ isBluebird B T x ⟩
      B ∙ (T ∙ x) ∙ y ∙ z    ≈⟨ isBluebird (T ∙ x) y z ⟩
      T ∙ x ∙ (y ∙ z)        ≈⟨ isThrush x (y ∙ z) ⟩
      (y ∙ z) ∙ x            ≈⟨⟩
      y ∙ z ∙ x              ∎
  }

problem₂₁ : ⦃ _ : HasRobin ⦄ → HasCardinal
problem₂₁ = record
  { C = R ∙ R ∙ R
  ; isCardinal = λ x y z → begin
      R ∙ R ∙ R ∙ x ∙ y ∙ z  ≈⟨ congʳ $ congʳ $ isRobin R R x ⟩
      R ∙ x ∙ R ∙ y ∙ z      ≈⟨ congʳ $ isRobin x R y ⟩
      R ∙ y ∙ x ∙ z          ≈⟨ isRobin y x z ⟩
      x ∙ z ∙ y              ∎
  }

problem₂₁′ : ⦃ _ : HasBluebird ⦄ ⦃ _ : HasThrush ⦄ → HasCardinal
problem₂₁′ = problem₂₁ ⦃ problem₂₀ ⦄

problem₂₁-bonus : ⦃ _ : HasBluebird ⦄ ⦃ _ : HasThrush ⦄ → HasCardinal
problem₂₁-bonus = record
  { C = B ∙ (T ∙ (B ∙ B ∙ T)) ∙ (B ∙ B ∙ T)
  ; isCardinal = λ x y z → begin
      B ∙ (T ∙ (B ∙ B ∙ T)) ∙ (B ∙ B ∙ T) ∙ x ∙ y ∙ z    ≈˘⟨ congʳ $ congʳ $ congʳ $ congʳ $ isBluebird B T (B ∙ B ∙ T) ⟩
      B ∙ B ∙ T ∙ (B ∙ B ∙ T) ∙ (B ∙ B ∙ T) ∙ x ∙ y ∙ z  ≈⟨ isCardinal x y z ⟩
      x ∙ z ∙ y                                          ∎
  } where instance hasCardinal = problem₂₁′

module _ ⦃ _ : HasBluebird ⦄ ⦃ _ : HasThrush ⦄ where
  private
    instance hasRobin = problem₂₀
    instance hasCardinal = problem₂₁′

  problem₂₂-a : ∀ x → C ∙ x ≈ R ∙ x ∙ R
  problem₂₂-a x = begin
    C ∙ x          ≈⟨⟩
    R ∙ R ∙ R ∙ x  ≈⟨ isRobin R R x ⟩
    R ∙ x ∙ R      ∎

  problem₂₂-b : ∀ x → C ∙ x ≈ B ∙ (T ∙ x) ∙ R
  problem₂₂-b x = begin
    C ∙ x              ≈⟨ problem₂₂-a x ⟩
    R ∙ x ∙ R          ≈⟨⟩
    B ∙ B ∙ T ∙ x ∙ R  ≈⟨ congʳ $ isBluebird B T x ⟩
    B ∙ (T ∙ x) ∙ R    ∎

problem₂₃ : ⦃ _ : HasCardinal ⦄ → HasRobin
problem₂₃ = record
  { R = C ∙ C
  ; isRobin = λ x y z → begin
      C ∙ C ∙ x ∙ y ∙ z  ≈⟨ congʳ $ isCardinal C x y ⟩
      C ∙ y ∙ x ∙ z      ≈⟨ isCardinal y x z ⟩
      y ∙ z ∙ x          ∎
  }

problem₂₄ : ⦃ _ : HasBluebird ⦄ ⦃ _ : HasRobin ⦄ ⦃ _ : HasCardinal ⦄ → HasFinch
problem₂₄ = record
  { F = B ∙ C ∙ R
  ; isFinch = λ x y z → begin
      B ∙ C ∙ R ∙ x ∙ y ∙ z  ≈⟨ congʳ $ congʳ $ isBluebird C R x ⟩
      C ∙ (R ∙ x) ∙ y ∙ z    ≈⟨ isCardinal (R ∙ x) y z ⟩
      R ∙ x ∙ z ∙ y          ≈⟨ isRobin x z y ⟩
      z ∙ y ∙ x              ∎
  }

problem₂₅ : ⦃ _ : HasThrush ⦄ ⦃ _ : HasEagle ⦄ → HasFinch
problem₂₅ = record
  { F = E ∙ T ∙ T ∙ E ∙ T
  ; isFinch = λ x y z → begin
      E ∙ T ∙ T ∙ E ∙ T ∙ x ∙ y ∙ z  ≈⟨ congʳ $ congʳ $ isEagle T T E T x ⟩
      T ∙ T ∙ (E ∙ T ∙ x) ∙ y ∙ z    ≈⟨ congʳ $ congʳ $ isThrush T (E ∙ T ∙ x) ⟩
      E ∙ T ∙ x ∙ T ∙ y ∙ z          ≈⟨ isEagle T x T y z ⟩
      T ∙ x ∙ (T ∙ y ∙ z)            ≈⟨ isThrush x (T ∙ y ∙ z) ⟩
      T ∙ y ∙ z ∙ x                  ≈⟨ congʳ $ isThrush y z ⟩
      z ∙ y ∙ x                      ∎
  }

problem₂₆ : ⦃ _ : HasBluebird ⦄ ⦃ _ : HasThrush ⦄ → HasFinch
problem₂₆ = record
  { F = short
  ; isFinch = shortIsFinch
  }
  where
    instance
      hasRobin = problem₂₀
      hasCardinal = problem₂₁-bonus
      hasEagle = problem₇

    long : Bird
    long = (B ∙ (B ∙ (T ∙ (B ∙ B ∙ T)) ∙ (B ∙ B ∙ T)) ∙ (B ∙ B ∙ T))

    longIsFinch : IsFinch long
    longIsFinch = HasFinch.isFinch problem₂₄

    short : Bird
    short = B ∙ (T ∙ T) ∙ (B ∙ (B ∙ B ∙ B) ∙ T)

    short≈ETTET : short ≈ E ∙ T ∙ T ∙ E ∙ T
    short≈ETTET = begin
      short                                            ≈⟨⟩
      B ∙ (T ∙ T) ∙ (B ∙ (B ∙ B ∙ B) ∙ T)              ≈˘⟨ isBluebird (B ∙ (T ∙ T)) (B ∙ (B ∙ B ∙ B)) T ⟩
      B ∙ (B ∙ (T ∙ T)) ∙ (B ∙ (B ∙ B ∙ B)) ∙ T        ≈˘⟨ congʳ $ congʳ $ isBluebird B B (T ∙ T) ⟩
      B ∙ B ∙ B ∙ (T ∙ T) ∙ (B ∙ (B ∙ B ∙ B)) ∙ T      ≈˘⟨ congʳ $ congʳ $ isBluebird (B ∙ B ∙ B) T T ⟩
      B ∙ (B ∙ B ∙ B) ∙ T ∙ T ∙ (B ∙ (B ∙ B ∙ B)) ∙ T  ≈⟨⟩
      E ∙ T ∙ T ∙ E ∙ T                                ∎

    shortIsFinch : IsFinch short
    shortIsFinch x y z = begin
      short ∙ x ∙ y ∙ z              ≈⟨ congʳ $ congʳ $ congʳ $ short≈ETTET ⟩
      E ∙ T ∙ T ∙ E ∙ T ∙ x ∙ y ∙ z  ≈⟨ HasFinch.isFinch problem₂₅ x y z ⟩
      z ∙ y ∙ x                      ∎

problem₂₇ : ⦃ _ : HasCardinal ⦄ ⦃ _ : HasFinch ⦄ → HasVireo
problem₂₇ = record
  { V = C ∙ F
  ; isVireo = λ x y z → begin
      C ∙ F ∙ x ∙ y ∙ z  ≈⟨ congʳ $ isCardinal F x y ⟩
      F ∙ y ∙ x ∙ z      ≈⟨ isFinch y x z ⟩
      z ∙ x ∙ y          ∎
  }

problem₂₈ : ⦃ _ : HasFinch ⦄ ⦃ _ : HasRobin ⦄ → HasVireo
problem₂₈ = record
  { V = R ∙ F ∙ R
  ; isVireo = λ x y z → begin
      R ∙ F ∙ R ∙ x ∙ y ∙ z      ≈˘⟨ congʳ $ congʳ $ congʳ $ isRobin R R F ⟩
      R ∙ R ∙ R ∙ F ∙ x ∙ y ∙ z  ≈⟨ congʳ $ HasCardinal.isCardinal problem₂₁ F x y ⟩
      F ∙ y ∙ x ∙ z              ≈⟨ isFinch y x z ⟩
      z ∙ x ∙ y                  ∎
  }

problem₂₉ : ⦃ _ : HasCardinal ⦄ ⦃ _ : HasVireo ⦄ → HasFinch
problem₂₉ = record
  { F = C ∙ V
  ; isFinch = λ x y z → begin
      C ∙ V ∙ x ∙ y ∙ z  ≈⟨ congʳ $ isCardinal V x y ⟩
      V ∙ y ∙ x ∙ z      ≈⟨ isVireo y x z ⟩
      z ∙ y ∙ x          ∎
  }

problem₃₀ : ⦃ _ : HasRobin ⦄ ⦃ _ : HasKestrel ⦄ → HasIdentity
problem₃₀ = problem₁₆
  where instance hasCardinal = problem₂₁

module _ ⦃ _ : HasBluebird ⦄ ⦃ _ : HasCardinal ⦄ where
  problem₃₁ : HasCardinalOnceRemoved
  problem₃₁ = record
    { C* = B ∙ C
    ; isCardinalOnceRemoved = λ x y z w → begin
        B ∙ C ∙ x ∙ y ∙ z ∙ w  ≈⟨ congʳ $ congʳ $ isBluebird C x y ⟩
        C ∙ (x ∙ y) ∙ z ∙ w    ≈⟨ isCardinal (x ∙ y) z w ⟩
        x ∙ y ∙ w ∙ z          ∎
    }

  private instance hasCardinalOnceRemoved = problem₃₁

  problem₃₂ : HasRobinOnceRemoved
  problem₃₂ = record
    { R* = C* ∙ C*
    ; isRobinOnceRemoved = λ x y z w → begin
        C* ∙ C* ∙ x ∙ y ∙ z ∙ w  ≈⟨ congʳ $ isCardinalOnceRemoved C* x y z ⟩
        C* ∙ x ∙ z ∙ y ∙ w       ≈⟨ isCardinalOnceRemoved x z y w ⟩
        x ∙ z ∙ w ∙ y            ∎
    }

  private instance hasRobinOnceRemoved = problem₃₂

  problem₃₃ : HasFinchOnceRemoved
  problem₃₃ = record
    { F* = B ∙ C* ∙ R*
    ; isFinchOnceRemoved = λ x y z w → begin
        B ∙ C* ∙ R* ∙ x ∙ y ∙ z ∙ w  ≈⟨ congʳ $ congʳ $ congʳ $ isBluebird C* R* x ⟩
        C* ∙ (R* ∙ x) ∙ y ∙ z ∙ w    ≈⟨ isCardinalOnceRemoved (R* ∙ x) y z w ⟩
        R* ∙ x ∙ y ∙ w ∙ z           ≈⟨ isRobinOnceRemoved x y w z ⟩
        x ∙ w ∙ z ∙ y                ∎
    }

  private instance hasFinchOnceRemoved = problem₃₃

  problem₃₄ : HasVireoOnceRemoved
  problem₃₄ = record
    { V* = C* ∙ F*
    ; isVireoOnceRemoved = λ x y z w → begin
        C* ∙ F* ∙ x ∙ y ∙ z ∙ w  ≈⟨ congʳ $ isCardinalOnceRemoved F* x y z ⟩
        F* ∙ x ∙ z ∙ y ∙ w       ≈⟨ isFinchOnceRemoved x z y w ⟩
        x ∙ w ∙ y ∙ z            ∎
    }

  private instance hasVireoOnceRemoved = problem₃₄

  problem₃₅-C** : HasCardinalTwiceRemoved
  problem₃₅-C** = record
    { C** = B ∙ C*
    ; isCardinalTwiceRemoved = λ x y z₁ z₂ z₃ → begin
        B ∙ C* ∙ x ∙ y ∙ z₁ ∙ z₂ ∙ z₃  ≈⟨ congʳ $ congʳ $ congʳ $ isBluebird C* x y ⟩
        C* ∙ (x ∙ y) ∙ z₁ ∙ z₂ ∙ z₃    ≈⟨ isCardinalOnceRemoved (x ∙ y) z₁ z₂ z₃ ⟩
        x ∙ y ∙ z₁ ∙ z₃ ∙ z₂           ∎
    }

  problem₃₅-R** : HasRobinTwiceRemoved
  problem₃₅-R** = record
    { R** = B ∙ R*
    ; isRobinTwiceRemoved = λ x y z₁ z₂ z₃ → begin
        B ∙ R* ∙ x ∙ y ∙ z₁ ∙ z₂ ∙ z₃  ≈⟨ congʳ $ congʳ $ congʳ $ isBluebird R* x y ⟩
        R* ∙ (x ∙ y) ∙ z₁ ∙ z₂ ∙ z₃    ≈⟨ isRobinOnceRemoved (x ∙ y) z₁ z₂ z₃ ⟩
        x ∙ y ∙ z₂ ∙ z₃ ∙ z₁           ∎
    }

  problem₃₅-F** : HasFinchTwiceRemoved
  problem₃₅-F** = record
    { F** = B ∙ F*
    ; isFinchTwiceRemoved = λ x y z₁ z₂ z₃ → begin
        B ∙ F* ∙ x ∙ y ∙ z₁ ∙ z₂ ∙ z₃  ≈⟨ congʳ $ congʳ $ congʳ $ isBluebird F* x y ⟩
        F* ∙ (x ∙ y) ∙ z₁ ∙ z₂ ∙ z₃    ≈⟨ isFinchOnceRemoved (x ∙ y) z₁ z₂ z₃ ⟩
        x ∙ y ∙ z₃ ∙ z₂ ∙ z₁           ∎
    }

  problem₃₅-V** : HasVireoTwiceRemoved
  problem₃₅-V** = record
    { V** = B ∙ V*
    ; isVireoTwiceRemoved = λ x y z₁ z₂ z₃ → begin
        B ∙ V* ∙ x ∙ y ∙ z₁ ∙ z₂ ∙ z₃  ≈⟨ congʳ $ congʳ $ congʳ $ isBluebird V* x y ⟩
        V* ∙ (x ∙ y) ∙ z₁ ∙ z₂ ∙ z₃    ≈⟨ isVireoOnceRemoved (x ∙ y) z₁ z₂ z₃ ⟩
        x ∙ y ∙ z₃ ∙ z₁ ∙ z₂           ∎
    }

problem₃₆ : ⦃ _ : HasCardinalOnceRemoved ⦄ ⦃ _ : HasThrush ⦄ → HasVireo
problem₃₆ = record
  { V = C* ∙ T
  ; isVireo = λ x y z → begin
      C* ∙ T ∙ x ∙ y ∙ z  ≈⟨ isCardinalOnceRemoved T x y z ⟩
      T ∙ x ∙ z ∙ y       ≈⟨ congʳ $ isThrush x z ⟩
      z ∙ x ∙ y           ∎
  }

problem₃₇′ : ⦃ _ : HasBluebird ⦄ ⦃ _ : HasCardinal ⦄ → HasQueerBird
problem₃₇′ = record
  { Q = C ∙ B
  ; isQueerBird = λ x y z → begin
      C ∙ B ∙ x ∙ y ∙ z  ≈⟨ congʳ $ isCardinal B x y ⟩
      B ∙ y ∙ x ∙ z      ≈⟨ isBluebird y x z ⟩
      y ∙ (x ∙ z)        ∎
  }

problem₃₈′ : ⦃ _ : HasBluebird ⦄ ⦃ _ : HasCardinalOnceRemoved ⦄ → HasQuixoticBird
problem₃₈′ = record
  { Q₁ = C* ∙ B
  ; isQuixoticBird = λ x y z → begin
      C* ∙ B ∙ x ∙ y ∙ z  ≈⟨ isCardinalOnceRemoved B x y z ⟩
      B ∙ x ∙ z ∙ y       ≈⟨ isBluebird x z y ⟩
      x ∙ (z ∙ y)         ∎
  }

problem₃₉′-F* : ⦃ _ : HasFinchOnceRemoved ⦄ ⦃ _ : HasQueerBird ⦄ → HasQuizzicalBird
problem₃₉′-F* = record
  { Q₂ = F* ∙ Q
  ; isQuizzicalBird = λ x y z → begin
      F* ∙ Q ∙ x ∙ y ∙ z  ≈⟨ isFinchOnceRemoved Q x y z ⟩
      Q ∙ z ∙ y ∙ x       ≈⟨ isQueerBird z y x ⟩
      y ∙ (z ∙ x)         ∎
  }

problem₃₉′-R* : ⦃ _ : HasBluebird ⦄ ⦃ _ : HasRobinOnceRemoved ⦄ → HasQuizzicalBird
problem₃₉′-R* = record
  { Q₂ = R* ∙ B
  ; isQuizzicalBird = λ x y z → begin
      R* ∙ B ∙ x ∙ y ∙ z  ≈⟨ isRobinOnceRemoved B x y z ⟩
      B ∙ y ∙ z ∙ x       ≈⟨ isBluebird y z x ⟩
      y ∙ (z ∙ x)         ∎
  }

problem₄₁′ : ⦃ _ : HasBluebird ⦄ ⦃ _ : HasVireoOnceRemoved ⦄ → HasQuirkyBird
problem₄₁′ = record
  { Q₃ = V* ∙ B
  ; isQuirkyBird = λ x y z → begin
      V* ∙ B ∙ x ∙ y ∙ z  ≈⟨ isVireoOnceRemoved B x y z ⟩
      B ∙ z ∙ x ∙ y       ≈⟨ isBluebird z x y ⟩
      z ∙ (x ∙ y)         ∎
  }

problem₄₂′ : ⦃ _ : HasBluebird ⦄ ⦃ _ : HasFinchOnceRemoved ⦄ → HasQuackyBird
problem₄₂′ = record
  { Q₄ = F* ∙ B
  ; isQuackyBird = λ x y z → begin
      F* ∙ B ∙ x ∙ y ∙ z  ≈⟨ isFinchOnceRemoved B x y z ⟩
      B ∙ z ∙ y ∙ x       ≈⟨ isBluebird z y x ⟩
      z ∙ (y ∙ x)         ∎
  }

module _ ⦃ _ : HasBluebird ⦄ ⦃ _ : HasThrush ⦄ where
  private
    instance
      hasCardinal = problem₂₁-bonus
      hasCardinalOnceRemoved = problem₃₁
      hasRobinOnceRemoved = problem₃₂
      hasFinchOnceRemoved = problem₃₃
      hasVireoOnceRemoved = problem₃₄

  problem₃₇ : HasQueerBird
  problem₃₇ = problem₃₇′

  private instance hasQueerBird = problem₃₇

  problem₃₈ : HasQuixoticBird
  problem₃₈ = problem₃₈′

  private instance hasQuixoticBird = problem₃₈

  problem₃₉-F* : HasQuizzicalBird
  problem₃₉-F* = problem₃₉′-F*

  problem₃₉-R* : HasQuizzicalBird
  problem₃₉-R* = problem₃₉′-R*

  private instance hasQuizzicalBird = problem₃₉-F*

  problem₄₁ : HasQuirkyBird
  problem₄₁ = problem₄₁′

  problem₄₂ : HasQuackyBird
  problem₄₂ = problem₄₂′

module _ ⦃ _ : HasCardinal ⦄ where
  problem₄₀-Q₁ : ⦃ _ : HasQuizzicalBird ⦄ → HasQuixoticBird
  problem₄₀-Q₁ = record
    { Q₁ = C ∙ Q₂
    ; isQuixoticBird = λ x y z → begin
        C ∙ Q₂ ∙ x ∙ y ∙ z  ≈⟨ congʳ $ isCardinal Q₂ x y ⟩
        Q₂ ∙ y ∙ x ∙ z      ≈⟨ isQuizzicalBird y x z ⟩
        x ∙ (z ∙ y)         ∎
    }

  problem₄₀-Q₂ : ⦃ _ : HasQuixoticBird ⦄ → HasQuizzicalBird
  problem₄₀-Q₂ = record
    { Q₂ = C ∙ Q₁
    ; isQuizzicalBird = λ x y z → begin
        C ∙ Q₁ ∙ x ∙ y ∙ z  ≈⟨ congʳ $ isCardinal Q₁ x y ⟩
        Q₁ ∙ y ∙ x ∙ z      ≈⟨ isQuixoticBird y x z ⟩
        y ∙ (z ∙ x)         ∎
    }

  problem₄₃-Q₃ : ⦃ _ : HasQuackyBird ⦄ → HasQuirkyBird
  problem₄₃-Q₃ = record
    { Q₃ = C ∙ Q₄
    ; isQuirkyBird = λ x y z → begin
        C ∙ Q₄ ∙ x ∙ y ∙ z  ≈⟨ congʳ $ isCardinal Q₄ x y ⟩
        Q₄ ∙ y ∙ x ∙ z      ≈⟨ isQuackyBird y x z ⟩
        z ∙ (x ∙ y)         ∎
    }

  problem₄₃-Q₄ : ⦃ _ : HasQuirkyBird ⦄ → HasQuackyBird
  problem₄₃-Q₄ = record
    { Q₄ = C ∙ Q₃
    ; isQuackyBird = λ x y z → begin
        C ∙ Q₃ ∙ x ∙ y ∙ z  ≈⟨ congʳ $ isCardinal Q₃ x y ⟩
        Q₃ ∙ y ∙ x ∙ z      ≈⟨ isQuirkyBird y x z ⟩
        z ∙ (y ∙ x)         ∎
    }

problem₄₄ : ⦃ _ : HasQuixoticBird ⦄ ⦃ _ : HasThrush ⦄ → HasQuackyBird
problem₄₄ = record
  { Q₄ = Q₁ ∙ T
  ; isQuackyBird = λ x y z → begin
      Q₁ ∙ T ∙ x ∙ y ∙ z  ≈⟨ congʳ $ isQuixoticBird T x y ⟩
      T ∙ (y ∙ x) ∙ z     ≈⟨ isThrush (y ∙ x) z ⟩
      z ∙ (y ∙ x)         ∎
  }

problem₄₅ : ⦃ _ : HasQueerBird ⦄ ⦃ _ : HasThrush ⦄ → HasBluebird
problem₄₅ = record
  { B = Q ∙ T ∙ (Q ∙ Q)
  ; isBluebird = λ x y z → begin
      Q ∙ T ∙ (Q ∙ Q) ∙ x ∙ y ∙ z  ≈⟨ congʳ $ congʳ $ isQueerBird T (Q ∙ Q) x ⟩
      Q ∙ Q ∙ (T ∙ x) ∙ y ∙ z      ≈⟨ congʳ $ isQueerBird Q (T ∙ x) y ⟩
      T ∙ x ∙ (Q ∙ y) ∙ z          ≈⟨ congʳ $ isThrush x (Q ∙ y) ⟩
      Q ∙ y ∙ x ∙ z                ≈⟨ isQueerBird y x z ⟩
      x ∙ (y ∙ z)                  ∎
  }

problem₄₆ : ⦃ _ : HasQueerBird ⦄ ⦃ _ : HasThrush ⦄ → HasCardinal
problem₄₆ = record
  { C = Q ∙ Q ∙ (Q ∙ T)
  ; isCardinal = λ x y z → begin
      Q ∙ Q ∙ (Q ∙ T) ∙ x ∙ y ∙ z  ≈⟨ congʳ $ congʳ $ isQueerBird Q (Q ∙ T) x ⟩
      Q ∙ T ∙ (Q ∙ x) ∙ y ∙ z      ≈⟨ congʳ $ isQueerBird T (Q ∙ x) y ⟩
      Q ∙ x ∙ (T ∙ y) ∙ z          ≈⟨ isQueerBird x (T ∙ y) z ⟩
      T ∙ y ∙ (x ∙ z)              ≈⟨ isThrush y (x ∙ z) ⟩
      x ∙ z ∙ y                    ∎
  }

problem₄₇ : ⦃ _ : HasBluebird ⦄ ⦃ _ : HasThrush ⦄ → HasGoldfinch
problem₄₇ = record
  { G = D ∙ C
  ; isGoldfinch = λ x y z w → begin
      D ∙ C ∙ x ∙ y ∙ z ∙ w  ≈⟨ congʳ $ isDove C x y z ⟩
      C ∙ x ∙ (y ∙ z) ∙ w    ≈⟨ isCardinal x (y ∙ z) w ⟩
      x ∙ w ∙ (y ∙ z)        ∎
  } where
  instance
    hasCardinal = problem₂₁-bonus
    hasDove = problem₅