module STLC3 where

open import Data.Nat
open import Data.Nat.Properties using (≤-antisym; ≤-trans; ≰⇒>)
-- open import Data.List
open import Data.Empty using (⊥-elim)
open import Relation.Binary.PropositionalEquality using (_≡_; refl; sym; trans; cong; cong₂; subst)
open import Relation.Nullary.Decidable using (map)
open import Relation.Nullary
open import Data.Product

-- de Bruijn indexed lambda calculus
infix  5 ƛ_
infixl 7 _∙_
infix  9 var_

-- indexed by the number of binders out there
data Term : ℕ → Set where
  -- if x < n
  --  then var x is bound
  --  else var x is free
  var_ : ∀ {n} → (x : ℕ) → Term n

  ƛ_ : ∀ {n} → Term (suc n) → Term n

  _∙_ : ∀ {n} → Term n → Term n → Term n

data Var : Set where
  Bound : ∀ {n x} → (bound : n > x) → Var
  FreeIncr : ∀ {n x depth} → (free : suc x ≰ n) → (prop : depth ≡ suc x) → Var
  Free : ∀ {n x depth} →(free : suc x ≰ n) → (safe : suc x ≰ depth) → Var

sort : (n x depth : ℕ) → suc n ≥ depth → Var
sort n x depth P with n >? x
sort n x depth P | yes p = Bound p
sort n x depth P | no ¬p with depth >? x
sort n x depth P | no ¬p | yes q = FreeIncr ¬p (≤-antisym (≤-trans P (≰⇒> ¬p)) q)
sort n x depth P | no ¬p | no ¬q = Free ¬p ¬q

-- only "shift" the variable when
--  1. it's free
--  2. it will be captured after substitution
shift : ∀ {n} → (i : ℕ) → suc n ≥ i → Term n → Term (suc n)
shift {n} depth P (var x) with sort n x depth P
shift {n} depth P (var x) | Bound bound = var x
shift {n} depth P (var x) | FreeIncr free prop = var suc x
shift {n} depth P (var x) | Free free safe = var x
shift depth P (ƛ M) = ƛ shift (suc depth) (s≤s P) M
shift depth P (M ∙ N) = shift depth P M ∙ shift depth P N

infixl 10 _[_/_/_]
_[_/_/_] : ∀ {n} → Term (suc n) → Term n → (i : ℕ) → n ≥ i → Term n
(var x)   [ N / i / n≥i ] with x ≟ i
(var x)   [ N / i / n≥i ] | yes p = N
(var x)   [ N / i / n≥i ] | no ¬p = var x
(ƛ M)     [ N / i / n≥i ] = ƛ (M [ shift (suc i) (s≤s n≥i) N / suc i / s≤s n≥i ])
(L ∙ M)   [ N / i / n≥i ] = L [ N / i / n≥i ] ∙ M [ N / i / n≥i ]

-- substitution
infixl 10 _[_]
_[_] : ∀ {n} → Term (suc n) → Term n → Term n
M [ N ] = M [ N / zero / z≤n ]

-- β reduction
infix 3 _β→_
data _β→_ {n : ℕ} : Term n → Term n → Set where

  β-ƛ-∙ : ∀ {M N} → ((ƛ M) ∙ N) β→ M [ N ]

  β-ƛ : ∀ {M N} → M β→ N → ƛ M β→ ƛ N

  β-∙-l : ∀ {L M N} → M β→ N → M ∙ L β→ N ∙ L

  β-∙-r : ∀ {L M N} → M β→ N → L ∙ M β→ L ∙ N

-- the reflexive and transitive closure of _β→_
infix  2 _β→*_
infixr 4 _→*_
data _β→*_ {n : ℕ} : Term n → Term n → Set where

  ∎ : ∀ {M} → M β→* M

  _→*_ : ∀ {L M N}
    → L β→  M
    → M β→* N
    --------------
    → L β→* N

infixl  3 _<β>_
_<β>_ : ∀ {n} {M N O : Term n} → M β→* N → N β→* O → M β→* O
∎          <β> N→O = N→O
L→M →* M→N <β> N→O = L→M →* (M→N <β> N→O)

hop : ∀ {n} {M N : Term n} → M β→ N → M β→* N
hop M→N = M→N →* ∎

-- infix  2 _-↠_

infixr 2 _→⟨_⟩_
_→⟨_⟩_
  : ∀ {n} {M N : Term n}
  → ∀ L
  → L β→ M
  → M β→* N
  --------------
  → L β→* N
L →⟨ P ⟩ Q = P →* Q

infixr 2 _→*⟨_⟩_
_→*⟨_⟩_
  : ∀ {n} {M N : Term n}
  → ∀ L
  → L β→* M
  → M β→* N
  --------------
  → L β→* N
L →*⟨ P ⟩ Q = P <β> Q

infix 3 _→∎
_→∎ : ∀ {n} (M : Term n) → M β→* M
M →∎ = ∎

-- the symmetric closure of _β→*_

infix  1 _β≡_
data _β≡_ {n : ℕ} : Term n → Term n → Set where
  β-sym : ∀ {M N}
    → M β→* N
    → N β→* M
    -------
    → M β≡ N

infixr 2 _=*⟨_⟩_
_=*⟨_⟩_
  : ∀ {n} {M N : Term n}
  → ∀ L
  → L β≡ M
  → M β≡ N
  --------------
  → L β≡ N
L =*⟨ β-sym A B ⟩ β-sym C D = β-sym (A <β> C) (D <β> B)

infixr 2 _=*⟨⟩_
_=*⟨⟩_
  : ∀ {n} {N : Term n}
  → ∀ L
  → L β≡ N
  --------------
  → L β≡ N
L =*⟨⟩ β-sym C D = β-sym C D

infix 3 _=∎
_=∎ : ∀ {n} → (M : Term n) → M β≡ M
M =∎ = β-sym ∎ ∎

forward : ∀ {n} {M N : Term n} → M β≡ N → M β→* N
forward (β-sym A _) = A

backward : ∀ {n} {M N : Term n} → M β≡ N → N β→* M
backward (β-sym _ B) = B

-- data Normal : Set where

Normal : ∀ {n} → Term n → Set
Normal M = ¬ ∃ (λ N → M β→ N)

normal : ∀ {n} {M N : Term n} → Normal M → M β→* N → M ≡ N
normal P ∎            = refl
normal P (M→L →* L→N) = ⊥-elim (P (_ , M→L))

cong-ƛ : ∀ {n} {M N : Term (suc n)} → M β→* N → ƛ M β→* ƛ N
cong-ƛ ∎            = ∎
cong-ƛ (M→N →* N→O) = β-ƛ M→N →* cong-ƛ N→O

cong-∙-l : ∀ {n} {L M N : Term n} → M β→* N → M ∙ L β→* N ∙ L
cong-∙-l ∎            = ∎
cong-∙-l (M→N →* N→O) = β-∙-l M→N →* cong-∙-l N→O

cong-∙-r : ∀ {n} {L M N : Term n} → M β→* N → L ∙ M β→* L ∙ N
cong-∙-r ∎            = ∎
cong-∙-r (M→N →* N→O) = β-∙-r M→N →* cong-∙-r N→O

cong-shift! : ∀ {n i} (M : Term (suc n)) (N : Term n) → (n≥i : n ≥ i) → shift (suc i) (s≤s n≥i) ((ƛ M) ∙ N) β→ shift (suc i) (s≤s n≥i) (M [ N ])
cong-shift! (var x) N n≥i = {!   !}
cong-shift! (ƛ M) N n≥i = {!   !}
cong-shift! (M ∙ L) N n≥i = {!   !}

cong-shift : ∀ {n i} {M N : Term n} → (n≥i : n ≥ i) → M β→ N → shift (suc i) (s≤s n≥i) M β→ shift (suc i) (s≤s n≥i) N
cong-shift n≥i (β-ƛ-∙ {M} {N}) = cong-shift! M N n≥i
cong-shift n≥i (β-ƛ M→N) = β-ƛ (cong-shift (s≤s n≥i) M→N)
cong-shift n≥i (β-∙-l M→N) = β-∙-l (cong-shift n≥i M→N)
cong-shift n≥i (β-∙-r M→N) = β-∙-r (cong-shift n≥i M→N)

-- cong-shift : ∀ {n i} {M N : Term n} → n ≥ i → M β→ N → shift (suc i) M β→ shift (suc i) N
-- cong-shift {n} n≥i (β-ƛ-∙ {var x} {var y}) with suc n >? x
-- cong-shift {n} n≥i (β-ƛ-∙ {var x} {var y}) | yes p with suc y ≤? n
-- cong-shift {n} n≥i (β-ƛ-∙ {var zero} {var y}) | yes p | yes q with n >? y
-- cong-shift {n} n≥i (β-ƛ-∙ {var zero} {var y}) | yes p | yes q | yes r = β-ƛ-∙
-- cong-shift {n} n≥i (β-ƛ-∙ {var zero} {var y}) | yes p | yes q | no ¬r = ⊥-elim (¬r q)
-- cong-shift {n} n≥i (β-ƛ-∙ {var suc x} {var y}) | yes p | yes q with n >? suc x
-- cong-shift {n} n≥i (β-ƛ-∙ {var suc x} {var y}) | yes p | yes q | yes r = {!   !} -- dump
-- cong-shift {n} {i} n≥i (β-ƛ-∙ {var suc x} {var y}) | yes p | yes q | no ¬r with suc i >? suc x
-- -- ≤-antisym p
-- cong-shift {n} {i} n≥i (β-ƛ-∙ {var suc x} {var y}) | yes p | yes q | no ¬r | yes s = {! (≰⇒> ¬r)  !} -- fishy
-- cong-shift {n} {i} n≥i (β-ƛ-∙ {var suc x} {var y}) | yes p | yes q | no ¬r | no ¬s = {!   !} -- dump
-- cong-shift {n} {i} n≥i (β-ƛ-∙ {var x} {var y}) | yes p | no ¬q with suc i >? y
-- cong-shift {n} {i} n≥i (β-ƛ-∙ {var zero} {var y}) | yes p | no ¬q | yes r with n >? y
-- cong-shift {n} {i} n≥i (β-ƛ-∙ {var zero} {var y}) | yes p | no ¬q | yes r | yes s = ⊥-elim (¬q s)
-- cong-shift {n} {i} n≥i (β-ƛ-∙ {var zero} {var y}) | yes p | no ¬q | yes r | no ¬s with suc i >? y
-- cong-shift {n} {i} n≥i (β-ƛ-∙ {var zero} {var y}) | yes p | no ¬q | yes r | no ¬s | yes t = β-ƛ-∙
-- cong-shift {n} {i} n≥i (β-ƛ-∙ {var zero} {var y}) | yes p | no ¬q | yes r | no ¬s | no ¬t = ⊥-elim (¬t r)
-- cong-shift {n} {i} n≥i (β-ƛ-∙ {var suc x} {var y}) | yes p | no ¬q | yes r with n >? suc x
-- cong-shift {n} {i} n≥i (β-ƛ-∙ {var suc x} {var y}) | yes p | no ¬q | yes r | yes t = {!   !} -- dump
-- cong-shift {n} {i} n≥i (β-ƛ-∙ {var suc x} {var y}) | yes p | no ¬q | yes r | no ¬t with suc i >? suc x
-- cong-shift {n} {i} n≥i (β-ƛ-∙ {var suc x} {var y}) | yes p | no ¬q | yes r | no ¬t | yes u = {!   !} -- fishy
-- cong-shift {n} {i} n≥i (β-ƛ-∙ {var suc x} {var y}) | yes p | no ¬q | yes r | no ¬t | no ¬u = β-ƛ-∙
-- cong-shift {n} {i} n≥i (β-ƛ-∙ {var x} {var y}) | yes p | no ¬q | no ¬r = {!   !}
-- cong-shift {n} n≥i (β-ƛ-∙ {var x} {var y}) | no ¬p = {!   !}
-- cong-shift {n} n≥i (β-ƛ-∙ {var x} {ƛ N}) = {!   !}
-- cong-shift {n} n≥i (β-ƛ-∙ {var x} {N ∙ O}) = {!   !}
-- -- cong-shift {n} (β-ƛ-∙ {var x} {N}) with suc n >? x
-- -- cong-shift {n} (β-ƛ-∙ {var zero} {N}) | yes p = β-ƛ-∙
-- -- cong-shift {n} (β-ƛ-∙ {var suc x} {N}) | yes (s≤s p) with n >? suc x
-- -- cong-shift {n} (β-ƛ-∙ {var suc x} {N}) | yes (s≤s p) | yes q = {!   !}
-- -- cong-shift {n} {i} (β-ƛ-∙ {var suc x} {N}) | yes (s≤s p) | no ¬q with suc i >? suc x
-- -- cong-shift {n} {i} (β-ƛ-∙ {var suc x} {N}) | yes (s≤s p) | no ¬q | yes r = {!   !} -- fishy
-- -- cong-shift {n} {i} (β-ƛ-∙ {var suc x} {N}) | yes (s≤s p) | no ¬q | no ¬r = {!   !}
-- -- cong-shift {n} (β-ƛ-∙ {var zero} {var x}) | no ¬p = {!   !}
-- -- cong-shift {n} (β-ƛ-∙ {var zero} {ƛ N}) | no ¬p = {!   !}
-- -- cong-shift {n} (β-ƛ-∙ {var zero} {N ∙ O}) | no ¬p = {!   !}
-- -- cong-shift {n} (β-ƛ-∙ {var suc x} {N}) | no ¬p = {!   !}
-- cong-shift n≥i (β-ƛ-∙ {ƛ M} {N}) = {!   !}
-- cong-shift n≥i (β-ƛ-∙ {L ∙ var x} {N}) = {!   !}
-- cong-shift n≥i (β-ƛ-∙ {L ∙ (ƛ M)} {N}) = {!   !}
-- cong-shift n≥i (β-ƛ-∙ {L ∙ (M ∙ K)} {N}) = {!   !}
-- cong-shift n≥i (β-ƛ M→N) = β-ƛ (cong-shift _ M→N)
-- cong-shift n≥i (β-∙-l M→N) = β-∙-l (cong-shift _ M→N)
-- cong-shift n≥i (β-∙-r M→N) = β-∙-r (cong-shift _ M→N)

-- -- cong-[] : ∀ {n i} {M N : Term n} → (L : Term (suc n)) → M β→ N → L [ M / i ] β→* L [ N / i ]
-- -- cong-[] {i = i} (var x) M→N with x ≟ i
-- -- cong-[] {i = i} (var x) M→N | yes p = hop M→N
-- -- cong-[] {i = i} (var x) M→N | no ¬p = ∎
-- -- cong-[] {n} {i} (ƛ L) M→N = {!   !}
-- --   -- cong-ƛ (cong-[] L (cong-shift M→N))
-- -- cong-[] {i = i} {M} {N} (L ∙ K) M→N =
-- --     L [ M / i ] ∙ K [ M / i ]
-- --   →*⟨ cong-∙-l (cong-[] L M→N) ⟩
-- --     L [ N / i ] ∙ K [ M / i ]
-- --   →*⟨ cong-∙-r (cong-[] K M→N) ⟩
-- --     L [ N / i ] ∙ K [ N / i ]
-- --   →∎

-- cong-[]2 : ∀ {n i} {M N : Term n} → (L : Term (suc n)) → n ≥ i → M β→ N → L [ M / i ] β→* L [ N / i ]
-- cong-[]2 {n} {i} (var x) n≥i M→N with x ≟ i
-- cong-[]2 {n} {i} (var x) n≥i M→N | yes p = hop M→N
-- cong-[]2 {n} {i} (var x) n≥i M→N | no ¬p = ∎
-- cong-[]2 {n} {i} (ƛ M)   n≥i M→N = cong-ƛ (cong-[]2 M (s≤s n≥i) {! cong-shift  !})
-- cong-[]2 {n} {i} {M} {N} (L ∙ K) n≥i M→N =
--     L [ M / i ] ∙ K [ M / i ]
--   →*⟨ cong-∙-l (cong-[]2 L _ M→N) ⟩
--     L [ N / i ] ∙ K [ M / i ]
--   →*⟨ cong-∙-r (cong-[]2 K _ M→N) ⟩
--     L [ N / i ] ∙ K [ N / i ]
--   →∎

-- β→confluent :  ∀ {n} (M N O : Term n) → (M β→ N) → (M β→ O) → ∃ (λ P → (N β→* P) × (O β→* P))
-- β→confluent .((ƛ M) ∙ N) _ _ (β-ƛ-∙ {M} {N}) β-ƛ-∙ = (M [ N ]) , (∎ , ∎)
-- β→confluent .((ƛ M) ∙ N) _ .(O ∙ N) (β-ƛ-∙ {M} {N}) (β-∙-l {N = O} M→O) = (O ∙ N) , ({!   !} , ∎)
-- β→confluent .((ƛ M) ∙ N) _ .((ƛ M) ∙ O) (β-ƛ-∙ {M} {N}) (β-∙-r {N = O} N→O) = (M [ O ]) , (cong-[]2 M z≤n N→O , (hop β-ƛ-∙))
-- β→confluent .(ƛ M) .(ƛ N) .(ƛ O) (β-ƛ {M} {N} M→N) (β-ƛ {N = O} M→O) with β→confluent M N O M→N M→O
-- β→confluent .(ƛ M) .(ƛ N) .(ƛ O) (β-ƛ {M} {N} M→N) (β-ƛ {N = O} M→O) | P , N→P , O→P = (ƛ P) , ((cong-ƛ N→P) , (cong-ƛ O→P))
-- β→confluent .((ƛ M) ∙ L) .(N ∙ L) _ (β-∙-l {L} {N = N} M→N) (β-ƛ-∙ {M}) = (N ∙ L) , (∎ , {!   !})
-- β→confluent .(M ∙ L) .(N ∙ L) .(K ∙ L) (β-∙-l {L} {M} {N} M→N) (β-∙-l {N = K} M→O) with β→confluent M N K M→N M→O
-- β→confluent .(M ∙ L) .(N ∙ L) .(K ∙ L) (β-∙-l {L} {M} {N} M→N) (β-∙-l {N = K} M→O) | P , N→P , K→P = P ∙ L , ((cong-∙-l N→P) , cong-∙-l K→P)
-- β→confluent .(M ∙ L) .(N ∙ L) .(M ∙ K) (β-∙-l {L} {M} {N} M→N) (β-∙-r {N = K} M→O) = N ∙ K , hop (β-∙-r M→O) , hop (β-∙-l M→N)
-- β→confluent .((ƛ L) ∙ M) .((ƛ L) ∙ N) _ (β-∙-r {M = M} {N} M→N) (β-ƛ-∙ {L}) = (L [ N ]) , (hop β-ƛ-∙ , cong-[]2 L _ M→N)
-- β→confluent .(K ∙ M) .(K ∙ N) .(L ∙ M) (β-∙-r {K} {M} {N} M→N) (β-∙-l {N = L} K→L) = (L ∙ N) , ((hop (β-∙-l K→L)) , hop (β-∙-r M→N))
-- β→confluent .(_ ∙ M) .(_ ∙ N) .(_ ∙ O) (β-∙-r {M = M} {N} M→N) (β-∙-r {N = O} M→O) with β→confluent M N O M→N M→O
-- β→confluent .(L ∙ M) .(L ∙ N) .(L ∙ O) (β-∙-r {L} {M} {N} M→N) (β-∙-r {N = O} M→O) | P , N→P , O→P = (L ∙ P) , (cong-∙-r N→P , cong-∙-r O→P)

-- β→*-confluent :  ∀ {n} {M N O : Term n} → (M β→* N) → (M β→* O) → ∃ (λ P → (N β→* P) × (O β→* P))
-- β→*-confluent {n} {M} {.M} {O} ∎            M→O          = O , M→O , ∎
-- β→*-confluent {n} {M} {N} {.M} (M→L →* L→N) ∎            = N , ∎   , (M→L →* L→N)
-- β→*-confluent {n} {M} {N} {O}  (M→L →* L→N) (M→K →* K→O) = {!   !}

-- normal-unique : ∀ {n} {M N O : Term n} → Normal N → Normal O → M β→* N → M β→* O → N ≡ O
-- normal-unique P Q M→N M→O = let X = β→*-confluent M→N M→O in trans (normal P (proj₁ (proj₂ X))) (sym (normal Q (proj₂ (proj₂ X))))


-- The default include path should contain Agda.Primitive

module TestDefaultIncludePath where

import Agda.Primitive

-- That's it.


-- Andreas, 2012-01-11, bug reported by Adam Gundry
module Issue551 where

data Bool : Set where
  true false : Bool

data _≡_ {A : Set}(a : A) : A → Set where
  refl : a ≡ a

cong : {A B : Set}(f : A → B){a a' : A} → a ≡ a' → f a ≡ f a'
cong f refl = refl

implicit : {A : Set}{{a : A}} -> A
implicit {{a}} = a

record PackBool : Set where
  constructor pack
  field unpack : Bool
open PackBool

data IrrBool : Set where
  irr : .(b : PackBool) -> IrrBool

p : irr (pack true) ≡ irr (pack false)
p = refl

-- The following should fail:

unirr : IrrBool -> PackBool
unirr (irr x) = implicit
-- unirr (irr x) = x gives an error message (as well it should)
-- but using instance arguments circumvents the check.

q : true ≡ false
q = cong (λ x → unpack (unirr x)) p


------------------------------------------------------------------------
-- A proof of univalence
------------------------------------------------------------------------

-- The code is based on code by Anders Mörtberg from Agda's reference
-- manual or the cubical library.

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

module Equality.Path.Univalence where

open import Agda.Builtin.Cubical.Glue as Glue hiding (_≃_)

open import Equality.Path
open import Prelude

open import Equivalence equality-with-J as Eq using (_≃_)
import Equivalence.Contractible-preimages equality-with-J as CP
import Equivalence.Half-adjoint equality-with-J as HA
open import Function-universe equality-with-J hiding (id)
open import Preimage equality-with-J
open import Univalence-axiom equality-with-J hiding (≃⇒≡)

private
  variable
    a b ℓ : Level
    A     : Type a

private

  -- Conversions between CP._≃_ and Glue._≃_.

  ≃-CP⇒≃-Glue : {B : Type b} → A CP.≃ B → A Glue.≃ B
  ≃-CP⇒≃-Glue = Σ-map id (λ eq → record { equiv-proof = eq })

  ≃-Glue⇒≃-CP : {B : Type b} → A Glue.≃ B → A CP.≃ B
  ≃-Glue⇒≃-CP = Σ-map id Glue.isEquiv.equiv-proof

  -- Equivalences can be converted to equalities (if the two types live
  -- in the same universe).

  ≃-CP⇒≡ : {A B : Type ℓ} → A CP.≃ B → A ≡ B
  ≃-CP⇒≡ {A = A} {B = B} A≃B = λ i → primGlue B
    (λ { (i = 0̲) → A
       ; (i = 1̲) → B
    })
    (λ { (i = 0̲) → ≃-CP⇒≃-Glue A≃B
       ; (i = 1̲) → ≃-CP⇒≃-Glue CP.id
    })

  -- If ≃-CP⇒≡ is applied to the identity equivalence, then the result
  -- is equal to CP.id.

  ≃-CP⇒≡-id : ≃-CP⇒≡ CP.id ≡ refl {x = A}
  ≃-CP⇒≡-id {A = A} = λ i j → primGlue A
    {φ = max i (max j (- j))}
    (λ _ → A)
    (λ _ → ≃-CP⇒≃-Glue CP.id)

  -- ≃-CP⇒≡ is a left inverse of CP.≡⇒≃.

  ≃-CP⇒≡∘≡⇒≃ :
    {A B : Type ℓ} (A≡B : A ≡ B) →
    ≃-CP⇒≡ (CP.≡⇒≃ A≡B) ≡ A≡B
  ≃-CP⇒≡∘≡⇒≃ = elim
    (λ A≡B → ≃-CP⇒≡ (CP.≡⇒≃ A≡B) ≡ A≡B)
    (λ A →
       ≃-CP⇒≡ (CP.≡⇒≃ refl)  ≡⟨ cong ≃-CP⇒≡ CP.≡⇒≃-refl ⟩
       ≃-CP⇒≡ CP.id          ≡⟨ ≃-CP⇒≡-id ⟩∎
       refl                  ∎)

  -- ≃-CP⇒≡ is a right inverse of CP.≡⇒≃.

  ≡⇒≃∘≃-CP⇒≡ :
    {A B : Type ℓ} (A≃B : A CP.≃ B) →
    CP.≡⇒≃ (≃-CP⇒≡ A≃B) ≡ A≃B
  ≡⇒≃∘≃-CP⇒≡ {A = A} {B = B} A≃B =
    Σ-≡,≡→≡
      (proj₁ (CP.≡⇒≃ (≃-CP⇒≡ A≃B))                            ≡⟨⟩
       proj₁ (transport (λ i → A CP.≃ ≃-CP⇒≡ A≃B i) 0̲ CP.id)  ≡⟨⟩
       transport (λ i → A → ≃-CP⇒≡ A≃B i) 0̲ id                ≡⟨⟩
       transport (λ _ → A → B) 0̲ (proj₁ A≃B)                  ≡⟨ cong (_$ proj₁ A≃B) $ transport-refl 0̲ ⟩∎
       proj₁ A≃B                                              ∎)
      (CP.propositional ext _ _ _)

  -- Univalence for CP._≃_.

  univ-CP : CP.Univalence ℓ
  univ-CP =
    Is-equivalence≃Is-equivalence-CP _ $
    _≃_.is-equivalence $
    Eq.↔→≃ _ ≃-CP⇒≡ ≡⇒≃∘≃-CP⇒≡ ≃-CP⇒≡∘≡⇒≃

-- Univalence.

univ : ∀ {ℓ} → Univalence ℓ
univ {A = A} {B = B} = record
  { univalence = from , proofs
  }
  where
  univ′ : Univalence′ A B
  univ′ = _≃_.from (Univalence≃Univalence-CP ext) univ-CP

  from : A ≃ B → A ≡ B
  from = proj₁ (Univalence′.univalence univ′)

  abstract

    proofs : HA.Proofs ≡⇒≃ from
    proofs = proj₂ (Univalence′.univalence univ′)

-- Equivalences can be converted to equalities (if the two types live
-- in the same universe).

≃⇒≡ : {A B : Type ℓ} → A ≃ B → A ≡ B
≃⇒≡ = _≃_.from Eq.⟨ _ , Univalence′.univalence univ ⟩

private

  -- The type primGlue A B f is equivalent to A.

  primGlue≃-CP :
    (φ : I)
    (B : Partial φ (Type ℓ))
    (f : PartialP φ (λ x → B x Glue.≃ A)) →
    primGlue A B f CP.≃ A
  primGlue≃-CP {A = A} φ B f =
      prim^unglue {φ = φ}
    , λ x →
          ( prim^glue
              (λ p → CP.inverse (proj₂ (f-CP p)) x)
              (hcomp (lemma₁ x) x)
          , (hcomp (lemma₁ x) x  ≡⟨ sym $ hfill (lemma₁ x) (inˢ x) ⟩∎
             x                   ∎)
          )
        , λ y i →
              prim^glue (λ { (φ = 1̲) → proj₁ (lemma₂ is-one y i) })
                        (hcomp (lemma₃ y i) x)
            , (hcomp (lemma₃ y i) x  ≡⟨ sym $ hfill (lemma₃ y i) (inˢ x) ⟩∎
               x                     ∎)
    where
    f-CP : PartialP φ (λ x → B x CP.≃ A)
    f-CP p = ≃-Glue⇒≃-CP (f p)

    lemma₁ : A → ∀ i → Partial φ A
    lemma₁ x i (φ = 1̲) = (
      x                                               ≡⟨ sym (CP.right-inverse-of (proj₂ (f-CP is-one)) x) ⟩∎
      proj₁ (f-CP _) (CP.inverse (proj₂ (f-CP _)) x)  ∎) i

    lemma₂ :
      ∀ {x} p (y : proj₁ (f-CP p) ⁻¹ x) →
      ( CP.inverse (proj₂ (f-CP p)) x
      , CP.right-inverse-of (proj₂ (f-CP p)) x
      ) ≡
      y
    lemma₂ {x} p = CP.irrelevance (proj₂ (f-CP p)) x

    lemma₃ : ∀ {x} → prim^unglue {e = f} ⁻¹ x →
             ∀ i → I → Partial (max φ (max i (- i))) A
    lemma₃     y i j (φ = 1̲) = sym (proj₂ (lemma₂ is-one y i)) j
    lemma₃ {x} _ i j (i = 0̲) = hfill (lemma₁ x) (inˢ x) j
    lemma₃     y i j (i = 1̲) = sym (proj₂ y) j

-- An alternative formulation of univalence.

other-univ : Other-univalence ℓ
other-univ {ℓ = ℓ} {B = B} =                  $⟨ other-univ-CP ⟩
  Contractible (∃ λ (A : Type ℓ) → A CP.≃ B)  ↝⟨ (H-level-cong _ 0 $
                                                  ∃-cong λ _ → inverse $
                                                  ≃≃≃-CP {k = equivalence} ext) ⦂ (_ → _) ⟩□
  Contractible (∃ λ (A : Type ℓ) → A ≃ B)     □
  where
  other-univ-CP : Contractible (∃ λ (A : Type ℓ) → A CP.≃ B)
  other-univ-CP =
      (B , CP.id)
    , λ (A , A≃B) i →
          let C : ∀ i → Partial (max i (- i)) (Type ℓ)
              C = λ { i (i = 0̲) → B
                    ; i (i = 1̲) → A
                    }

              f : ∀ i → PartialP (max i (- i)) (λ j → C i j Glue.≃ B)
              f = λ { i (i = 0̲) → ≃-CP⇒≃-Glue CP.id
                    ; i (i = 1̲) → ≃-CP⇒≃-Glue A≃B
                    }
          in
            primGlue     _ _ (f i)
          , primGlue≃-CP _ _ (f i)


-- {-# OPTIONS -v tc.check.app:70 #-}
-- {-# OPTIONS -v tc.proj.amb:30 #-}

record S : Set₁ where
  field X : Set

record T : Set₁ where
  field X : Set

open S
open T

ok : S → Set
ok s = X s

test : S → Set
test s = s .X

-- Error WAS:
-- Cannot resolve overloaded projection X because it is not applied to
-- a visible argument
-- when inferring the type of .X

-- Should succeed.


-- Andreas, 2017-12-04, Re: issue #2862, reported by m0davis,
-- Make sure there is similar problem with functions.

open import Agda.Builtin.Equality

data Bool : Set where
  true false : Bool

val : Bool

module M where
  val = true  -- Should fail

  val≡true : val ≡ true
  val≡true = refl

val = false

data ⊥ : Set where

¬val≡true : val ≡ true → ⊥
¬val≡true ()

boom : ⊥
boom = ¬val≡true Z.val≡true


{-# OPTIONS -v 2 #-}
module Leftovers.Examples where

open import Leftovers.Utils
open import Leftovers.Leftovers
open import Leftovers.Equality

open import Data.Bool
open import Relation.Binary.PropositionalEquality

open import Data.Nat
open import Data.Product

open import Data.Unit

-- notNot :  ∀ b → not (not b) ≡ b
-- notNot = (by {A = ∀ b → not (not b) ≡ b} (cases (quote Bool)) {!!}) -- (refl , refl)

-- applyTo : ∀ {ℓ1 ℓ2} {X : Set ℓ1} { Y : Set ℓ2 } → (X → Y) → X → Y
-- applyTo f x = f x

-- infixr 40 applyTo
-- syntax applyTo e₁ (λ x → e₂) = x ≔ e₁ ︔ e₂

plusZero : ∀ n → n ≡ n + 0
plusZero =
   getNormal (by {A = ∀ n → n ≡ n + 0} (cases (quote ℕ)) ((λ x → cong suc (plusZero x)) , refl))
   -- (by {A = ∀ n → n ≡ n + 0} (cases (quote ℕ)) ((λ x → cong suc (plusZero x)) , refl))

-- plusZero' : ∀ n → n ≡ n + 0
-- plusZero' = getNormal
--   ((the ((zero ≡ zero × (∀ x → suc x ≡ suc x + 0)) → ∀ n → n ≡ n + 0) λ h → identity (λ { zero → proj₁ h ; (suc x) → (proj₂ h) x }))
--     (refl , λ x → cong suc (plusZero' x)))

-- -- plusZero'' : ∀ n → n ≡ n + 0
-- -- plusZero'' = (the (zero ≡ zero → (∀ x → suc x ≡ suc x + 0) → ∀ n → n ≡ n + 0) λ h1 h2 → (λ { zero → h1 ; (suc x) → h2 x})) refl  ((the (Dummy → ∀ x → suc x ≡ suc x + 0) (λ {dummy → λ x → cong suc (plusZero'' x)})) dummy)

-- -- plusZero' =
-- --   let
-- --     h : (zero ≡ zero × ∀ n → suc n ≡ (suc n) + 0)
-- --     h = refl , λ n → cong suc (plusZero' n)
-- --   in λ { zero → proj₁ h ; (suc x) → (proj₂ h) x}
-- -- plusZeroR : ∀ n → n + 0 ≡ n
-- -- plusZeroR = by (refl-cases (quote ℕ)) ?


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

open import lib.Basics
open import lib.types.Coproduct
open import lib.types.Paths
open import lib.types.Pointed
open import lib.types.Pushout
open import lib.types.PushoutFlattening
open import lib.types.PushoutFmap
open import lib.types.Span
open import lib.types.Unit

-- Wedge of two pointed types is defined as a particular case of pushout

module lib.types.Wedge where

module _ {i j} (X : Ptd i) (Y : Ptd j) where

  wedge-span : Span
  wedge-span = span (de⊙ X) (de⊙ Y) Unit (λ _ → pt X) (λ _ → pt Y)

  Wedge : Type (lmax i j)
  Wedge = Pushout wedge-span

  infix 80 _∨_
  _∨_ = Wedge

module _ {i j} {X : Ptd i} {Y : Ptd j} where

  winl : de⊙ X → X ∨ Y
  winl x = left x

  winr : de⊙ Y → X ∨ Y
  winr y = right y

  wglue : winl (pt X) == winr (pt Y)
  wglue = glue tt

module _ {i j} (X : Ptd i) (Y : Ptd j) where

  ⊙Wedge : Ptd (lmax i j)
  ⊙Wedge = ⊙[ Wedge X Y , winl (pt X) ]

  infix 80 _⊙∨_
  _⊙∨_ = ⊙Wedge

module _ {i j} {X : Ptd i} {Y : Ptd j} where

  ⊙winl : X ⊙→ X ⊙∨ Y
  ⊙winl = (winl , idp)

  ⊙winr : Y ⊙→ X ⊙∨ Y
  ⊙winr = (winr , ! wglue)

module _ {i j} {X : Ptd i} {Y : Ptd j} where

  module WedgeElim {k} {P : X ∨ Y → Type k}
    (inl* : (x : de⊙ X) → P (winl x)) (inr* : (y : de⊙ Y) → P (winr y))
    (glue* : inl* (pt X) == inr* (pt Y) [ P ↓ wglue ]) where

    private
      module M = PushoutElim inl* inr* (λ _ → glue*)

    f = M.f
    glue-β = M.glue-β unit

  open WedgeElim public using () renaming (f to Wedge-elim)

  module WedgeRec {k} {C : Type k} (inl* : de⊙ X → C) (inr* : de⊙ Y → C)
    (glue* : inl* (pt X) == inr* (pt Y)) where

    private
      module M = PushoutRec {d = wedge-span X Y} inl* inr* (λ _ → glue*)

    f = M.f
    glue-β = M.glue-β unit

  open WedgeRec public using () renaming (f to Wedge-rec)

module ⊙WedgeRec {i j k} {X : Ptd i} {Y : Ptd j} {Z : Ptd k}
  (g : X ⊙→ Z) (h : Y ⊙→ Z) where

  open WedgeRec (fst g) (fst h) (snd g ∙ ! (snd h)) public

  ⊙f : X ⊙∨ Y ⊙→ Z
  ⊙f = (f , snd g)

  ⊙winl-β : ⊙f ⊙∘ ⊙winl == g
  ⊙winl-β = idp

  ⊙winr-β : ⊙f ⊙∘ ⊙winr == h
  ⊙winr-β = ⊙λ= (λ _ → idp) $
    ap (_∙ snd g)
       (ap-! f wglue ∙ ap ! glue-β ∙ !-∙ (snd g) (! (snd h)))
    ∙ ∙-assoc (! (! (snd h))) (! (snd g)) (snd g)
    ∙ ap (! (! (snd h)) ∙_) (!-inv-l (snd g))
    ∙ ∙-unit-r (! (! (snd h)))
    ∙ !-! (snd h)

⊙Wedge-rec = ⊙WedgeRec.⊙f

⊙Wedge-rec-post∘ : ∀ {i j k l} {X : Ptd i} {Y : Ptd j} {Z : Ptd k} {W : Ptd l}
  (k : Z ⊙→ W) (g : X ⊙→ Z) (h : Y ⊙→ Z)
  → k ⊙∘ ⊙Wedge-rec g h == ⊙Wedge-rec (k ⊙∘ g) (k ⊙∘ h)
⊙Wedge-rec-post∘ k g h = ⊙λ=
  (Wedge-elim (λ _ → idp) (λ _ → idp)
    (↓-='-in' $ ⊙WedgeRec.glue-β (k ⊙∘ g) (k ⊙∘ h)
               ∙ lemma (fst k) (snd g) (snd h) (snd k)
               ∙ ! (ap (ap (fst k)) (⊙WedgeRec.glue-β g h))
               ∙ ∘-ap (fst k) (fst (⊙Wedge-rec g h)) wglue))
  idp
  where
  lemma : ∀ {i j} {A : Type i} {B : Type j} (f : A → B) {x y z : A} {w : B}
    (p : x == z) (q : y == z) (r : f z == w)
    → (ap f p ∙ r) ∙ ! (ap f q ∙ r) == ap f (p ∙ ! q)
  lemma f idp idp idp = idp

⊙Wedge-rec-η : ∀ {i j} {X : Ptd i} {Y : Ptd j}
  → ⊙Wedge-rec ⊙winl ⊙winr == ⊙idf (X ⊙∨ Y)
⊙Wedge-rec-η = ⊙λ=
  (Wedge-elim (λ _ → idp) (λ _ → idp)
    (↓-='-in' $ ap-idf wglue
               ∙ ! (!-! wglue)
               ∙ ! (⊙WedgeRec.glue-β ⊙winl ⊙winr)))
  idp

module _ {i j} {X : Ptd i} {Y : Ptd j} where

  add-wglue : de⊙ (X ⊙⊔ Y) → X ∨ Y
  add-wglue (inl x) = winl x
  add-wglue (inr y) = winr y

  ⊙add-wglue : X ⊙⊔ Y ⊙→ X ⊙∨ Y
  ⊙add-wglue = add-wglue , idp

module Fold {i} {X : Ptd i} = ⊙WedgeRec (⊙idf X) (⊙idf X)
fold = Fold.f
⊙fold = Fold.⊙f

module _ {i j} (X : Ptd i) (Y : Ptd j) where

  module Projl = ⊙WedgeRec (⊙idf X) (⊙cst {X = Y})
  module Projr = ⊙WedgeRec (⊙cst {X = X}) (⊙idf Y)

  projl = Projl.f
  projr = Projr.f
  ⊙projl = Projl.⊙f
  ⊙projr = Projr.⊙f

module _ {i i' j j'} {X : Ptd i} {X' : Ptd i'} {Y : Ptd j} {Y' : Ptd j'}
  (eqX : X ⊙≃ X') (eqY : Y ⊙≃ Y') where

  wedge-span-emap : SpanEquiv (wedge-span X Y) (wedge-span X' Y')
  wedge-span-emap = ( span-map (fst (fst eqX)) (fst (fst eqY)) (idf _)
                        (comm-sqr λ _ → snd (fst eqX))
                        (comm-sqr λ _ → snd (fst eqY))
                    , snd eqX , snd eqY , idf-is-equiv _)

  ∨-emap : X ∨ Y ≃ X' ∨ Y'
  ∨-emap = Pushout-emap wedge-span-emap

  ⊙∨-emap : X ⊙∨ Y ⊙≃ X' ⊙∨ Y'
  ⊙∨-emap = ≃-to-⊙≃ ∨-emap (ap winl (snd (fst eqX)))


{-# OPTIONS --no-termination-check #-}

module Pi where

open import Data.Empty
open import Data.Unit
open import Data.Sum hiding (map)
open import Data.Product hiding (map)

open import Relation.Binary.PropositionalEquality hiding (sym; [_])

infixr 30 _⟷_
infixr 30 _⟺_
infixr 20 _◎_

------------------------------------------------------------------------------
-- A universe of our value types

data B : Set where
  ZERO  : B
  ONE   : B
  PLUS  : B → B → B
  TIMES : B → B → B

⟦_⟧ : B → Set
⟦ ZERO ⟧         = ⊥
⟦ ONE ⟧          = ⊤
⟦ PLUS b1 b2 ⟧   = ⟦ b1 ⟧ ⊎ ⟦ b2 ⟧
⟦ TIMES b1 b2 ⟧  = ⟦ b1 ⟧ × ⟦ b2 ⟧

------------------------------------------------------------------------------
-- Primitive isomorphisms

data _⟷_ : B → B → Set where
  -- (+,0) commutative monoid
  unite₊  : { b : B } → PLUS ZERO b ⟷ b
  uniti₊  : { b : B } → b ⟷ PLUS ZERO b
  swap₊   : { b₁ b₂ : B } → PLUS b₁ b₂ ⟷ PLUS b₂ b₁
  assocl₊ : { b₁ b₂ b₃ : B } → PLUS b₁ (PLUS b₂ b₃) ⟷ PLUS (PLUS b₁ b₂) b₃
  assocr₊ : { b₁ b₂ b₃ : B } → PLUS (PLUS b₁ b₂) b₃ ⟷ PLUS b₁ (PLUS b₂ b₃)
  -- (*,1) commutative monoid
  unite⋆  : { b : B } → TIMES ONE b ⟷ b
  uniti⋆  : { b : B } → b ⟷ TIMES ONE b
  swap⋆   : { b₁ b₂ : B } → TIMES b₁ b₂ ⟷ TIMES b₂ b₁
  assocl⋆ : { b₁ b₂ b₃ : B } → TIMES b₁ (TIMES b₂ b₃) ⟷ TIMES (TIMES b₁ b₂) b₃
  assocr⋆ : { b₁ b₂ b₃ : B } → TIMES (TIMES b₁ b₂) b₃ ⟷ TIMES b₁ (TIMES b₂ b₃)
  -- * distributes over +
  dist    : { b₁ b₂ b₃ : B } →
            TIMES (PLUS b₁ b₂) b₃ ⟷ PLUS (TIMES b₁ b₃) (TIMES b₂ b₃)
  factor  : { b₁ b₂ b₃ : B } →
            PLUS (TIMES b₁ b₃) (TIMES b₂ b₃) ⟷ TIMES (PLUS b₁ b₂) b₃
  -- id
  id⟷   : { b : B } → b ⟷ b

adjointP : { b₁ b₂ : B } → (b₁ ⟷ b₂) → (b₂ ⟷ b₁)
adjointP unite₊    = uniti₊
adjointP uniti₊    = unite₊
adjointP swap₊     = swap₊
adjointP assocl₊   = assocr₊
adjointP assocr₊   = assocl₊
adjointP unite⋆    = uniti⋆
adjointP uniti⋆    = unite⋆
adjointP swap⋆     = swap⋆
adjointP assocl⋆   = assocr⋆
adjointP assocr⋆   = assocl⋆
adjointP dist      = factor
adjointP factor    = dist
adjointP id⟷      = id⟷

evalP : { b₁ b₂ : B } → (b₁ ⟷ b₂) → ⟦ b₁ ⟧ → ⟦ b₂ ⟧
evalP unite₊ (inj₁ ())
evalP unite₊ (inj₂ v) = v
evalP uniti₊ v = inj₂ v
evalP swap₊ (inj₁ v) = inj₂ v
evalP swap₊ (inj₂ v) = inj₁ v
evalP assocl₊ (inj₁ v) = inj₁ (inj₁ v)
evalP assocl₊ (inj₂ (inj₁ v)) = inj₁ (inj₂ v)
evalP assocl₊ (inj₂ (inj₂ v)) = inj₂ v
evalP assocr₊ (inj₁ (inj₁ v)) = inj₁ v
evalP assocr₊ (inj₁ (inj₂ v)) = inj₂ (inj₁ v)
evalP assocr₊ (inj₂ v) = inj₂ (inj₂ v)
evalP unite⋆ (tt , v) = v
evalP uniti⋆ v = (tt , v)
evalP swap⋆ (v₁ , v₂) = (v₂ , v₁)
evalP assocl⋆ (v₁ , (v₂ , v₃)) = ((v₁ , v₂) , v₃)
evalP assocr⋆ ((v₁ , v₂) , v₃) = (v₁ , (v₂ , v₃))
evalP dist (inj₁ v₁ , v₃) = inj₁ (v₁ , v₃)
evalP dist (inj₂ v₂ , v₃) = inj₂ (v₂ , v₃)
evalP factor (inj₁ (v₁ , v₃)) = (inj₁ v₁ , v₃)
evalP factor (inj₂ (v₂ , v₃)) = (inj₂ v₂ , v₃)
evalP id⟷ v = v

-- Backwards evaluator

bevalP : { b₁ b₂ : B } → (b₁ ⟷ b₂) → ⟦ b₂ ⟧ → ⟦ b₁ ⟧
bevalP c v = evalP (adjointP c) v

------------------------------------------------------------------------------
-- Closure combinators

data _⟺_ : B → B → Set where
  iso    : { b₁ b₂ : B } → (b₁ ⟷ b₂) → (b₁ ⟺ b₂)
  sym    : { b₁ b₂ : B } → (b₁ ⟺ b₂) → (b₂ ⟺ b₁)
  _◎_    : { b₁ b₂ b₃ : B } → (b₁ ⟺ b₂) → (b₂ ⟺ b₃) → (b₁ ⟺ b₃)
  _⊕_    : { b₁ b₂ b₃ b₄ : B } →
           (b₁ ⟺ b₃) → (b₂ ⟺ b₄) → (PLUS b₁ b₂ ⟺ PLUS b₃ b₄)
  _⊗_    : { b₁ b₂ b₃ b₄ : B } →
           (b₁ ⟺ b₃) → (b₂ ⟺ b₄) → (TIMES b₁ b₂ ⟺ TIMES b₃ b₄)

--

adjoint : { b₁ b₂ : B } → (b₁ ⟺ b₂) → (b₂ ⟺ b₁)
adjoint (iso c) = iso (adjointP c)
adjoint (sym c)   = c
adjoint (c₁ ◎ c₂) = adjoint c₂ ◎ adjoint c₁
adjoint (c₁ ⊕ c₂) = adjoint c₁ ⊕ adjoint c₂
adjoint (c₁ ⊗ c₂) = adjoint c₁ ⊗ adjoint c₂

--

-- (Context a b c d) represents a combinator (c <-> d) with a hole
-- requiring something of type (a <-> b). When we use these contexts,
-- it is always the case that the (c <-> a) part of the computation
-- has ALREADY been done and that we are about to evaluate (a <-> b)
-- using a given 'a'. The continuation takes the output 'b' and
-- produces a 'd'.

data Context : B → B → B → B → Set where
  emptyC : {a b : B} → Context a b a b
  seqC₁ : {a b c i o : B} → (b ⟺ c) → Context a c i o → Context a b i o
  seqC₂ : {a b c i o : B} → (a ⟺ b) → Context a c i o → Context b c i o
  leftC : {a b c d i o : B} →
          (c ⟺ d) → Context (PLUS a c) (PLUS b d) i o → Context a b i o
  rightC : {a b c d i o : B} →
           (a ⟺ b) → Context (PLUS a c) (PLUS b d) i o → Context c d i o
  -- the (i <-> a) part of the computation is completely done; so we must store
  -- the value of type [[ c ]] as part of the context
  fstC : {a b c d i o : B} →
         ⟦ c ⟧ → (c ⟺ d) → Context (TIMES a c) (TIMES b d) i o → Context a b i o
  -- the (i <-> c) part of the computation and the (a <-> b) part of
  -- the computation are completely done; so we must store the value
  -- of type [[ b ]] as part of the context
  sndC : {a b c d i o : B} →
         (a ⟺ b) → ⟦ b ⟧ → Context (TIMES a c) (TIMES b d) i o → Context c d i o

-- Evaluation

mutual

  -- The (c <-> a) part of the computation has been done.
  -- We have an 'a' and we are about to do the (a <-> b) computation.
  -- We get a 'b' and examine the context to get the 'd'
  eval_c : { a b c d : B } → (a ⟺ b) → ⟦ a ⟧ → Context a b c d → ⟦ d ⟧
  eval_c (iso f) v C = eval_k (iso f) (evalP f v) C
  eval_c (sym c) v C = eval_c (adjoint c) v C
  eval_c (f ◎ g) v C = eval_c f v (seqC₁ g C)
  eval_c (f ⊕ g) (inj₁ v) C = eval_c f v (leftC g C)
  eval_c (f ⊕ g) (inj₂ v) C = eval_c g v (rightC f C)
  eval_c (f ⊗ g) (v₁ , v₂) C = eval_c f v₁ (fstC v₂ g C)

  -- The (c <-> a) part of the computation has been done.
  -- The (a <-> b) part of the computation has been done.
  -- We need to examine the context to get the 'd'.
  -- We rebuild the combinator on the way out.
  eval_k : { a b c d : B } → (a ⟺ b) → ⟦ b ⟧ → Context a b c d → ⟦ d ⟧
  eval_k f v emptyC = v
  eval_k f v (seqC₁ g C) = eval_c g v (seqC₂ f C)
  eval_k g v (seqC₂ f C) = eval_k (f ◎ g) v C
  eval_k f v (leftC g C) = eval_k (f ⊕ g) (inj₁ v) C
  eval_k g v (rightC f C) = eval_k (f ⊕ g) (inj₂ v) C
  eval_k f v₁ (fstC v₂ g C) = eval_c g v₂ (sndC f v₁ C)
  eval_k g v₂ (sndC f v₁ C) = eval_k (f ⊗ g) (v₁ , v₂) C

-- Backwards evaluator

mutual

  -- The (d <-> b) part of the computation has been done.
  -- We have a 'b' and we are about to do the (a <-> b) computation backwards.
  -- We get an 'a' and examine the context to get the 'c'
  beval_c : { a b c d : B } → (a ⟺ b) → ⟦ b ⟧ → Context a b c d → ⟦ c ⟧
  beval_c (iso f) v C = beval_k (iso f) (bevalP f v) C
  beval_c (sym c) v C = beval_c (adjoint c) v C
  beval_c (f ◎ g) v C = beval_c g v (seqC₂ f C)
  beval_c (f ⊕ g) (inj₁ v) C = beval_c f v (leftC g C)
  beval_c (f ⊕ g) (inj₂ v) C = beval_c g v (rightC f C)
  beval_c (f ⊗ g) (v₁ , v₂) C = beval_c g v₂ (sndC f v₁ C)

  -- The (d <-> b) part of the computation has been done.
  -- The (a <-> b) backwards computation has been done.
  -- We have an 'a' and examine the context to get the 'c'
  beval_k : { a b c d : B } → (a ⟺ b) → ⟦ a ⟧ → Context a b c d → ⟦ c ⟧
  beval_k f v emptyC = v
  beval_k g v (seqC₂ f C) = beval_c f v (seqC₁ g C)
  beval_k f v (seqC₁ g C) = beval_k (f ◎ g) v C
  beval_k f v (leftC g C) = beval_k (f ⊕ g) (inj₁ v) C
  beval_k g v (rightC f C) = beval_k (f ⊕ g) (inj₂ v) C
  beval_k g v₂ (sndC f v₁ C) = beval_c f v₁ (fstC v₂ g C)
  beval_k f v₁ (fstC v₂ g C) = beval_k (f ⊗ g) (v₁ , v₂) C

------------------------------------------------------------------------------
-- Proposition 'Reversible'

-- eval_c : { a b c d : B } → (a ⟺ b) → ⟦ a ⟧ → Context a b c d → ⟦ d ⟧
-- eval_k : { a b c d : B } → (a ⟺ b) → ⟦ b ⟧ → Context a b c d → ⟦ d ⟧
-- beval_c : { a b c d : B } → (a ⟺ b) → ⟦ b ⟧ → Context a b c d → ⟦ c ⟧
-- beval_k : { a b c d : B } → (a ⟺ b) → ⟦ a ⟧ → Context a b c d → ⟦ c ⟧

-- Prop. 2.2
{-
logical-reversibility : {a b : B} {f : a ⟺ b} {va : ⟦ a ⟧} {vb : ⟦ b ⟧} →
  eval_c f va emptyC ≡ eval_k f vb emptyC →
  eval_c (adjoint f) vb emptyC ≡ eval_k (adjoint f) va emptyC
logical-reversibility = λ fwd≡bwd → {!!}
-}
------------------------------------------------------------------------------


postulate
  A : Set

f : {{_ : A}} → A
f = {!!}


module Load where

data Bool : Set where
  tt : Bool
  ff : Bool


open import Nat
open import Prelude
open import aasubsume-min
open import contexts
open import judgemental-erase
open import lemmas-matching
open import statics-core
open import synth-unicity

module determinism where
  -- since we do not specify the name of newly inserted hole names,
  -- we only have determinism up to renaming of holes. we don't
  -- need to consider alpha equivalence for binders, since the
  --
  -- the same action applied to the same type makes the same type
  actdet-type : {t t' t'' : ztyp} {α : action} →
                (t + α +> t') →
                (t + α +> t'') →
                (t' == t'')
  actdet-type TMArrChild1 TMArrChild1 = refl
  actdet-type TMArrChild2 TMArrChild2 = refl
  actdet-type TMArrParent1 TMArrParent1 = refl
  actdet-type TMArrParent1 (TMArrZip1 ())
  actdet-type TMArrParent2 TMArrParent2 = refl
  actdet-type TMArrParent2 (TMArrZip2 ())
  actdet-type TMDel TMDel = refl
  actdet-type TMConArrow TMConArrow = refl
  actdet-type TMConNum TMConNum = refl
  actdet-type (TMArrZip1 ()) TMArrParent1
  actdet-type (TMArrZip1 p1) (TMArrZip1 p2) with actdet-type p1 p2
  ... | refl = refl
  actdet-type (TMArrZip2 ()) TMArrParent2
  actdet-type (TMArrZip2 p1) (TMArrZip2 p2) with actdet-type p1 p2
  ... | refl = refl
  actdet-type TMPlusChild1 TMPlusChild1 = refl
  actdet-type TMPlusChild2 TMPlusChild2 = refl
  actdet-type TMPlusParent1 TMPlusParent1 = refl
  actdet-type (TMPlusZip1 ()) TMPlusParent1
  actdet-type TMPlusParent2 TMPlusParent2 = refl
  actdet-type (TMPlusZip2 ()) TMPlusParent2
  actdet-type TMConPlus TMConPlus = refl
  actdet-type TMPlusParent1 (TMPlusZip1 ())
  actdet-type (TMPlusZip1 x) (TMPlusZip1 y) with actdet-type x y
  ... | refl = refl
  actdet-type TMPlusParent2 (TMPlusZip2 ())
  actdet-type (TMPlusZip2 x) (TMPlusZip2 y) with actdet-type x y
  ... | refl = refl
  actdet-type TMProdChild1 TMProdChild1 = refl
  actdet-type TMProdChild2 TMProdChild2 = refl
  actdet-type TMProdParent1 TMProdParent1 = refl
  actdet-type TMProdParent1 (TMProdZip1 ())
  actdet-type TMProdParent2 TMProdParent2 = refl
  actdet-type TMProdParent2 (TMProdZip2 ())
  actdet-type TMConProd TMConProd = refl
  actdet-type (TMProdZip1 ()) TMProdParent1
  actdet-type (TMProdZip1 x) (TMProdZip1 y) with actdet-type x y
  ... | refl = refl
  actdet-type (TMProdZip2 ()) TMProdParent2
  actdet-type (TMProdZip2 x) (TMProdZip2 y) with actdet-type x y
  ... | refl = refl

  -- all expressions only move to one other expression
  movedet : {e e' e'' : zexp} {δ : direction} →
            (e + move δ +>e e') →
            (e + move δ +>e e'') →
            e' == e''
  movedet EMAscChild1 EMAscChild1 = refl
  movedet EMAscChild2 EMAscChild2 = refl
  movedet EMAscParent1 EMAscParent1 = refl
  movedet EMAscParent2 EMAscParent2 = refl
  movedet EMLamChild1 EMLamChild1 = refl
  movedet EMLamParent EMLamParent = refl
  movedet EMHalfLamChild1 EMHalfLamChild1 = refl
  movedet EMHalfLamChild2 EMHalfLamChild2 = refl
  movedet EMHalfLamParent1 EMHalfLamParent1 = refl
  movedet EMHalfLamParent2 EMHalfLamParent2 = refl
  movedet EMPlusChild1 EMPlusChild1 = refl
  movedet EMPlusChild2 EMPlusChild2 = refl
  movedet EMPlusParent1 EMPlusParent1 = refl
  movedet EMPlusParent2 EMPlusParent2 = refl
  movedet EMApChild1 EMApChild1 = refl
  movedet EMApChild2 EMApChild2 = refl
  movedet EMApParent1 EMApParent1 = refl
  movedet EMApParent2 EMApParent2 = refl
  movedet EMNEHoleChild1 EMNEHoleChild1 = refl
  movedet EMNEHoleParent EMNEHoleParent = refl
  movedet EMInlChild1 EMInlChild1 = refl
  movedet EMInlParent EMInlParent = refl
  movedet EMInrChild1 EMInrChild1 = refl
  movedet EMInrParent EMInrParent = refl
  movedet EMCaseParent1 EMCaseParent1 = refl
  movedet EMCaseParent2 EMCaseParent2 = refl
  movedet EMCaseParent3 EMCaseParent3 = refl
  movedet EMCaseChild1 EMCaseChild1 = refl
  movedet EMCaseChild2 EMCaseChild2 = refl
  movedet EMCaseChild3 EMCaseChild3 = refl
  movedet EMPairChild1 EMPairChild1 = refl
  movedet EMPairChild2 EMPairChild2 = refl
  movedet EMPairParent1 EMPairParent1 = refl
  movedet EMPairParent2 EMPairParent2 = refl
  movedet EMFstChild1 EMFstChild1 = refl
  movedet EMFstParent EMFstParent = refl
  movedet EMSndChild1 EMSndChild1 = refl
  movedet EMSndParent EMSndParent = refl

  -- non-movement lemmas; theses show up pervasively throughout and save a
  -- lot of pattern matching.
  lem-nomove-part : ∀ {t t'} → ▹ t ◃ + move parent +> t' → ⊥
  lem-nomove-part ()

  lem-nomove-pars : ∀{Γ e t e' t'} → Γ ⊢ ▹ e ◃ => t ~ move parent ~> e' => t' → ⊥
  lem-nomove-pars (SAMove ())

  lem-nomove-para : ∀{Γ e t e'} → Γ ⊢ ▹ e ◃ ~ move parent ~> e' ⇐ t → ⊥
  lem-nomove-para (AASubsume e x x₁ x₂) = lem-nomove-pars x₁
  lem-nomove-para (AAMove ())

  -- if a move action on a synthetic action makes a new form, it's unique
  synthmovedet : {Γ : tctx} {e e' e'' : zexp} {t' t'' : htyp} {δ : direction} →
                 Γ ⊢ e => t' ~ move δ ~> e'' => t'' →
                 e + move δ +>e e' →
                 e'' == e'
  synthmovedet (SAMove m1) m2 = movedet m1 m2
  -- all these cases lead to absurdities based on movement
  synthmovedet (SAZipAsc1 x) EMAscParent1 = abort (lem-nomove-para x)
  synthmovedet (SAZipAsc2 x _ _ _) EMAscParent2 = abort (lem-nomove-part x)
  synthmovedet (SAZipApArr _ _ _ x _) EMApParent1 = abort (lem-nomove-pars x)
  synthmovedet (SAZipApAna _ _ x) EMApParent2 = abort (lem-nomove-para x)
  synthmovedet (SAZipPlus1 x) EMPlusParent1 = abort (lem-nomove-para x)
  synthmovedet (SAZipPlus2 x) EMPlusParent2 = abort (lem-nomove-para x)
  synthmovedet (SAZipNEHole _ _ x) EMNEHoleParent = abort (lem-nomove-pars x)
  synthmovedet (SAZipPair1 _ _ x _) EMPairParent1 = abort (lem-nomove-pars x)
  synthmovedet (SAZipPair2 _ _ _ x) EMPairParent2 = abort (lem-nomove-pars x)
  synthmovedet (SAZipFst _ _ _ _ x) EMFstParent = abort (lem-nomove-pars x)
  synthmovedet (SAZipSnd _ _ _ _ x) EMSndParent = abort (lem-nomove-pars x)
  synthmovedet (SAZipLam1 _ _ _ x _ _) EMHalfLamParent1 = abort (lem-nomove-part x)
  synthmovedet (SAZipLam2 _ _ _ x) EMHalfLamParent2 = abort (lem-nomove-pars x)

  anamovedet : {Γ : tctx} {e e' e'' : zexp} {t : htyp} {δ : direction} →
               Γ ⊢ e ~ move δ ~> e'' ⇐ t →
               e + move δ +>e e' →
               e'' == e'
  anamovedet (AASubsume x₂ x x₃ x₁) m = synthmovedet x₃ m
  anamovedet (AAMove x) m = movedet x m
  anamovedet (AAZipLam x₁ x₂ d) EMLamParent = abort (lem-nomove-para d)
  anamovedet (AAZipInl x d) EMInlParent = abort (lem-nomove-para d)
  anamovedet (AAZipInr x d) EMInrParent = abort (lem-nomove-para d)
  anamovedet (AAZipCase1 x₁ x₂ x₃ x₄ x₅ x₆ x₇ x₈) EMCaseParent1 =
    abort (lem-nomove-pars x₅)
  anamovedet (AAZipCase2 x₁ x₂ x₃ x₄ d) EMCaseParent2 = abort (lem-nomove-para d)
  anamovedet (AAZipCase3 x₁ x₂ x₃ x₄ d) EMCaseParent3 = abort (lem-nomove-para d)

  lem-plusholematch : ∀ {t t1 t2} → t ~̸ (⦇-⦈ ⊕ ⦇-⦈) → t ~ ⦇-⦈ → t ▸sum (t1 ⊕ t2) → ⊥
  lem-plusholematch a TCRefl MSHole = a TCHole2
  lem-plusholematch a TCHole1 MSHole = a TCHole2
  lem-plusholematch a TCHole1 MSSum = a (TCSum TCHole1 TCHole1)
  lem-plusholematch a TCHole2 MSHole = a TCHole2

  lem-prodholematch : ∀ {t t1 t2} → t ~̸ (⦇-⦈ ⊠ ⦇-⦈) → t ~ ⦇-⦈ → t ▸prod (t1 ⊠ t2) → ⊥
  lem-prodholematch a TCRefl MPHole = a TCHole2
  lem-prodholematch a TCHole1 MPHole = a TCHole2
  lem-prodholematch a TCHole1 MPProd = a (TCProd TCHole1 TCHole1)
  lem-prodholematch a TCHole2 MPHole = a TCHole2

  mutual
    -- an action on an expression in a synthetic position produces one
    -- resultant expression and type.
    actdet-synth : {Γ : tctx} {e e' e'' : zexp} {e◆ : hexp} {t t' t'' : htyp} {α : action} →
                   (E : erase-e e e◆) →
                   (Γ ⊢ e◆ => t) →
                   (d1 : Γ ⊢ e => t ~ α ~> e'  => t') →
                   (d2 : Γ ⊢ e => t ~ α ~> e'' => t'') →
                   {p1 : aasubmin-synth d1} →
                   {p2 : aasubmin-synth d2} →
                   (e' == e'' × t' == t'')
    actdet-synth er wt (SAMove x₁) (SAMove x₂) = movedet x₁ x₂ , refl
    actdet-synth er wt SADel SADel = refl , refl
    actdet-synth er wt SAConAsc SAConAsc = refl , refl
    actdet-synth er wt (SAConPlus1 x₁) (SAConPlus1 x₂) = refl , refl
    actdet-synth er wt (SAConPlus1 x₁) (SAConPlus2 x₂) = abort (x₂ x₁)
    actdet-synth er wt (SAConPlus2 x₁) (SAConPlus1 x₂) = abort (x₁ x₂)
    actdet-synth er wt (SAConPlus2 x₁) (SAConPlus2 x₂) = refl , refl
    actdet-synth er wt (SAConApArr x₁) (SAConApArr x₂)
      with ▸arr-unicity x₁ x₂
    ... | refl = refl , refl
    actdet-synth er wt (SAConApArr x₁) (SAConApOtw x₂) = abort (x₂ (▸arr-consist-hole x₁))
    actdet-synth er wt (SAConApOtw x₁) (SAConApArr x₂) = abort (x₁ (▸arr-consist-hole x₂))
    actdet-synth er wt (SAConApOtw x₁) (SAConApOtw x₂) = refl , refl
    actdet-synth er wt SAConNEHole SAConNEHole = refl , refl

    actdet-synth (EEAscL E) (SAsc x) (SAMove EMAscParent1) (SAZipAsc1 x₂) =
      abort (lem-nomove-para x₂)
    actdet-synth (EEAscL E) (SAsc x) (SAZipAsc1 x₁) (SAMove EMAscParent1) =
      abort (lem-nomove-para x₁)
    actdet-synth (EEAscL E) (SAsc x) (SAZipAsc1 x₁) (SAZipAsc1 x₂) {p1} {p2}
     with actdet-ana E x x₁ x₂ {p1} {p2}
    ... | refl = refl , refl

    actdet-synth (EEAscR x) (SAsc x₁) (SAMove EMAscParent2) (SAZipAsc2 a _ _ _) =
      abort (lem-nomove-part a)
    actdet-synth (EEAscR x) (SAsc x₁) (SAZipAsc2 a _ _ _) (SAMove EMAscParent2) =
      abort (lem-nomove-part a)
    actdet-synth (EEAscR x) (SAsc x₂) (SAZipAsc2 a e1 _ _) (SAZipAsc2 b e2 _ _)
      with actdet-type a b
    ... | refl = refl , eraset-det e1 e2

    actdet-synth (EEHalfLamL x) (SLam x₁ wt) (SAMove EMHalfLamParent1)
                 (SAZipLam1 x₃ x₄ x₅ x₆ x₇ x₈) = abort (lem-nomove-part x₆)
    actdet-synth (EEHalfLamL x) (SLam x₁ wt) (SAZipLam1 x₂ x₃ x₄ x₅ x₆ x₇)
                 (SAMove EMHalfLamParent1) = abort (lem-nomove-part x₅)
    actdet-synth (EEHalfLamL x) (SLam x₁ wt) (SAZipLam1 x₂ x₃ x₄ x₅ x₆ x₇)
                 (SAZipLam1 x₈ x₉ x₁₀ x₁₁ x₁₂ x₁₃) with actdet-type x₅ x₁₁
    ... | refl with eraset-det x₄ x₁₀
    ... | refl with synthunicity x₇ x₁₃
    ... | refl = refl , refl

    actdet-synth (EEHalfLamR er) (SLam x wt) (SAMove EMHalfLamParent2)
                 (SAZipLam2 x₂ x₃ x₄ y) = abort (lem-nomove-pars y)
    actdet-synth (EEHalfLamR er) (SLam x wt) (SAZipLam2 x₁ x₂ x₃ x₄)
                 (SAMove EMHalfLamParent2) = abort (lem-nomove-pars x₄)
    actdet-synth (EEHalfLamR er) (SLam x wt) (SAZipLam2 x₁ x₂ x₃ d1)
                 (SAZipLam2 x₅ x₆ x₇ d2) {p1} {p2} with erasee-det x₂ x₆
    ... | refl with actdet-synth x₂ x₃ d1 d2 {p1} {p2}
    ... | refl , refl = refl , refl

    actdet-synth (EEApL E) (SAp m wt x) (SAMove EMApParent1) (SAZipApArr _ x₂ x₃ d2 x₄) =
      abort (lem-nomove-pars d2)
    actdet-synth (EEApL E) (SAp m wt x) (SAZipApArr _ x₁ x₂ d1 x₃) (SAMove EMApParent1) =
      abort (lem-nomove-pars d1)
    actdet-synth (EEApL E) (SAp m wt x) (SAZipApArr a x₁ x₂ d1 x₃)
                 (SAZipApArr b x₄ x₅ d2 x₆) {p1} {p2}
      with erasee-det x₁ x₄
    ... | refl with synthunicity x₂ x₅
    ... | refl with erasee-det E x₁
    ... | refl with actdet-synth E x₅ d1 d2 {p1} {p2}
    ... | refl , refl with ▸arr-unicity a b
    ... | refl = refl , refl

    actdet-synth (EEApR E) (SAp m wt x) (SAMove EMApParent2) (SAZipApAna x₂ x₃ x₄) =
      abort (lem-nomove-para x₄)
    actdet-synth (EEApR E) (SAp m wt x) (SAZipApAna x₁ x₂ x₃) (SAMove EMApParent2) =
      abort (lem-nomove-para x₃)
    actdet-synth (EEApR E) (SAp m wt x) (SAZipApAna x₁ x₂ d1) (SAZipApAna x₄ x₅ d2)  {p1} {p2}
     with synthunicity m x₂
    ... | refl with ▸arr-unicity x₁ wt
    ... | refl with synthunicity m x₅
    ... | refl with ▸arr-unicity x₄ wt
    ... | refl with actdet-ana E x d1 d2  {p1} {p2}
    ... | refl = refl , refl

    actdet-synth (EEPlusL E) (SPlus x x₁) (SAMove EMPlusParent1) (SAZipPlus1 d2) =
      abort (lem-nomove-para d2)
    actdet-synth (EEPlusL E) (SPlus x x₁) (SAZipPlus1 x₂) (SAMove EMPlusParent1) =
      abort (lem-nomove-para x₂)
    actdet-synth (EEPlusL E) (SPlus x x₁) (SAZipPlus1 x₂) (SAZipPlus1 x₃) {p1} {p2}
      = ap1 (λ x₄ → x₄ ·+₁ _) (actdet-ana E x x₂ x₃  {p1} {p2}) , refl

    actdet-synth (EEPlusR E) (SPlus x x₁) (SAMove EMPlusParent2) (SAZipPlus2 x₃) =
      abort (lem-nomove-para x₃)
    actdet-synth (EEPlusR E) (SPlus x x₁) (SAZipPlus2 x₂) (SAMove EMPlusParent2) =
      abort (lem-nomove-para x₂)
    actdet-synth (EEPlusR E) (SPlus x x₁) (SAZipPlus2 x₂) (SAZipPlus2 x₃) {p1} {p2}
      = ap1 (_·+₂_ _) (actdet-ana E x₁ x₂ x₃ {p1} {p2}) , refl

    actdet-synth EETop SEHole (SAConVar {Γ = G} p) (SAConVar p₁) =
      refl , (ctxunicity {Γ = G} p p₁)
    actdet-synth EETop SEHole (SAConLam x₁) (SAConLam x₂) = refl , refl
    actdet-synth EETop SEHole SAConNumlit SAConNumlit = refl , refl

    actdet-synth EETop (SNEHole wt) (SAFinish x) (SAFinish x₁) = refl , synthunicity x x₁

    actdet-synth (EENEHole E) (SNEHole wt) (SAMove EMNEHoleParent) (SAZipNEHole _ x₁ d2) =
      abort (lem-nomove-pars d2)
    actdet-synth (EENEHole E) (SNEHole wt) (SAZipNEHole _ x d1) (SAMove EMNEHoleParent) =
      abort (lem-nomove-pars d1)
    actdet-synth (EENEHole E) (SNEHole wt) (SAZipNEHole a x d1) (SAZipNEHole b x₁ d2) {p1} {p2}
      with erasee-det a b
    ... | refl with synthunicity x x₁
    ... | refl with actdet-synth a x d1 d2  {p1} {p2}
    ... | refl , refl = refl , refl

      -- new cases for sums
    actdet-synth EETop SEHole SAConInl SAConInl = refl , refl
    actdet-synth EETop SEHole SAConInr SAConInr = refl , refl
    actdet-synth er wt (SAConCase1 x₁ x₂ x₃) (SAConCase1 x₄ x₅ x₆) = refl , refl
    actdet-synth er wt (SAConCase1 x₁ x₂ MSHole) (SAConCase2 x₄ x₅ x₆) = abort (x₆ TCHole2)
    actdet-synth EETop wt (SAConCase1 x₁ x₂ MSSum) (SAConCase2 x₄ x₅ x₆) =
      abort (x₆ (TCSum TCHole1 TCHole1))
    actdet-synth EETop wt (SAConCase2 x₁ x₂ x₃) (SAConCase1 x₄ x₅ MSHole) = abort (x₃ TCHole2)
    actdet-synth EETop wt (SAConCase2 x₁ x₂ x₃) (SAConCase1 x₄ x₅ MSSum) =
      abort (x₃ (TCSum TCHole1 TCHole1))
    actdet-synth er wt (SAConCase2 x₁ x₂ x₃) (SAConCase2 x₄ x₅ x₆) = refl , refl

      -- new cases for products
    actdet-synth EETop wt (SAConFst1 x) (SAConFst1 x₁) with ▸prod-unicity x x₁
    ... | refl = refl , refl
    actdet-synth EETop wt (SAConFst1 x) (SAConFst2 x₁) = abort (x₁ (▸prod-consist-hole x))
    actdet-synth EETop wt (SAConFst2 x) (SAConFst1 x₁) = abort (x (▸prod-consist-hole x₁))
    actdet-synth EETop wt (SAConFst2 x) (SAConFst2 x₁) = refl , refl
    actdet-synth EETop wt (SAConSnd1 x) (SAConSnd1 x₁) with ▸prod-unicity x x₁
    ... | refl = refl , refl
    actdet-synth EETop wt (SAConSnd1 x) (SAConSnd2 x₁) = abort (x₁ (▸prod-consist-hole x))
    actdet-synth EETop wt (SAConSnd2 x) (SAConSnd1 x₁) = abort (x (▸prod-consist-hole x₁))
    actdet-synth EETop wt (SAConSnd2 x) (SAConSnd2 x₁) = refl , refl
    actdet-synth EETop SEHole SAConPair SAConPair = refl , refl
    actdet-synth (EEPairL er) (SPair wt wt₁) (SAMove EMPairParent1)
                 (SAZipPair1 er₁ wt₂ d wt₃) = abort (lem-nomove-pars d)
    actdet-synth (EEPairL er) (SPair wt wt₁) (SAZipPair1 er₁ wt₂ d wt₃)
                 (SAMove EMPairParent1) = abort (lem-nomove-pars d)
    actdet-synth (EEPairL er) (SPair wt wt₁) (SAZipPair1 er₁ wt₂ d₁ wt₃)
                 (SAZipPair1 er₂ wt₄ d₂ wt₅) {p1} {p2}
      with actdet-synth er₁ wt₂ d₁ d₂ {p1} {p2}
    ... | refl , refl = refl , refl
    actdet-synth (EEPairR er) (SPair wt wt₁) (SAMove EMPairParent2)
                 (SAZipPair2 wt₂ er₁ wt₃ d) = abort (lem-nomove-pars d)
    actdet-synth (EEPairR er) (SPair wt wt₁) (SAZipPair2 wt₂ er₁ wt₃ d)
                 (SAMove EMPairParent2) = abort (lem-nomove-pars d)
    actdet-synth (EEPairR er) (SPair wt wt₁) (SAZipPair2 wt₂ er₁ wt₃ d₁)
                 (SAZipPair2 wt₄ er₂ wt₅ d₂) {p1} {p2}
      with actdet-synth er₁ wt₃ d₁ d₂ {p1} {p2}
    ... | refl , refl = refl , refl
    actdet-synth (EEFst er) (SFst wt x₁) (SAMove EMFstParent)
                 (SAZipFst pr pr₁ er₁ wt₁ d) = abort (lem-nomove-pars d)
    actdet-synth (EEFst er) (SFst wt x₁) (SAZipFst pr pr₁ er₁ wt₁ d)
                 (SAMove EMFstParent) = abort (lem-nomove-pars d)
    actdet-synth (EEFst er) (SFst wt x₁) (SAZipFst pr pr₁ er₁ wt₁ d₁)
                 (SAZipFst pr₂ pr₃ er₂ wt₂ d₂) {p1} {p2}
      with erasee-det er₁ er₂
    ... | refl with synthunicity wt₁ wt₂
    ... | refl with actdet-synth er₁ wt₁ d₁ d₂ {p1} {p2}
    ... | refl , refl with ▸prod-unicity pr₁ pr₃
    ... | refl = refl , refl
    actdet-synth (EESnd er) (SSnd wt x₁) (SAMove EMSndParent) (SAZipSnd pr pr₁ er₁ wt₁ d) =
      abort (lem-nomove-pars d)
    actdet-synth (EESnd er) (SSnd wt x₁) (SAZipSnd pr pr₁ er₁ wt₁ d) (SAMove EMSndParent) =
      abort (lem-nomove-pars d)
    actdet-synth (EESnd er) (SSnd wt x₁) (SAZipSnd pr pr₁ er₁ wt₁ d₁)
                 (SAZipSnd pr₂ pr₃ er₂ wt₂ d₂) {p1} {p2}
      with erasee-det er₁ er₂
    ... | refl with synthunicity wt₁ wt₂
    ... | refl with actdet-synth er₁ wt₁ d₁ d₂ {p1} {p2}
    ... | refl , refl with ▸prod-unicity pr₁ pr₃
    ... | refl = refl , refl

    -- an action on an expression in an analytic position produces one
    -- resultant expression and type.
    actdet-ana : {Γ : tctx} {e e' e'' : zexp} {e◆ : hexp} {t : htyp} {α : action} →
                 erase-e e e◆ →
                 Γ ⊢ e◆ <= t →
                 (d1 : Γ ⊢ e ~ α ~> e' ⇐ t) →
                 (d2 : Γ ⊢ e ~ α ~> e'' ⇐ t) →
                 {p1 : aasubmin-ana d1} →
                 {p2 : aasubmin-ana d2} →
                 e' == e''
    -- lambda cases first
    -- an erased lambda can't be typechecked with subsume
    actdet-ana (EELam _) (ASubsume () _) _ _

    -- for things paired with movements, punt to the move determinism case
    actdet-ana _ _ D (AAMove y) = anamovedet D y
    actdet-ana _ _ (AAMove y) D =  ! (anamovedet D y)

    -- lambdas never match with subsumption actions, because it won't be well typed.
    actdet-ana EETop      (ALam x₁ x₂ wt) (AASubsume EETop () x₅ x₆) _
    actdet-ana (EELam _) (ALam x₁ x₂ wt) (AASubsume (EELam x₃) () x₅ x₆) _
    actdet-ana EETop      (ALam x₁ x₂ wt) _ (AASubsume EETop () x₅ x₆)
    actdet-ana (EELam _) (ALam x₁ x₂ wt) _ (AASubsume (EELam x₃) () x₅ x₆)

    -- with the cursor at the top, there are only two possible actions
    actdet-ana EETop (ALam x₁ x₂ wt) AADel AADel = refl
    actdet-ana EETop (ALam x₁ x₂ wt) AAConAsc AAConAsc = refl

    -- and for the remaining case, recurr on the smaller derivations
    actdet-ana (EELam er) (ALam x₁ x₂ wt) (AAZipLam x₃ x₄ d1) (AAZipLam x₅ x₆ d2) {p1} {p2}
       with ▸arr-unicity x₄ x₆
    ... | refl with ▸arr-unicity x₄ x₂
    ... | refl with actdet-ana er wt d1 d2  {p1} {p2}
    ... | refl = refl

    -- now the subsumption cases
    -- subsume / subsume, so pin things down then recurr
    actdet-ana er (ASubsume a b) (AASubsume x x₁ x₂ x₃) (AASubsume x₄ x₅ x₆ x₇) {p1} {p2}
      with erasee-det x₄ x
    ... | refl with erasee-det er x₄
    ... | refl with synthunicity x₅ x₁
    ... | refl = π1 (actdet-synth x x₅ x₂ x₆ {min-ana-lem x₂ p1} {min-ana-lem x₆ p2})

    -- (these are all repeated below, irritatingly.)
    actdet-ana EETop (ASubsume a b) (AASubsume EETop x SADel x₁) AADel = refl
    actdet-ana EETop (ASubsume a b) (AASubsume EETop x SAConAsc x₁) AAConAsc {p1} = abort p1
    actdet-ana EETop (ASubsume SEHole b) (AASubsume EETop SEHole (SAConVar {Γ = Γ} p) x₂)
               (AAConVar x₅ p₁)
      with ctxunicity {Γ = Γ} p p₁
    ... | refl = abort (x₅ x₂)
    actdet-ana EETop (ASubsume SEHole b) (AASubsume EETop SEHole (SAConLam x₄) x₂)
               (AAConLam1 x₅ m) {p1} = abort p1
    actdet-ana EETop (ASubsume a b) (AASubsume EETop x₁ (SAConLam x₃) x₂) (AAConLam2 x₅ x₆) =
      abort (x₆ x₂)
    actdet-ana EETop (ASubsume a b) (AASubsume EETop x₁ SAConNumlit x₂) (AAConNumlit x₄) =
      abort (x₄ x₂)
    actdet-ana EETop (ASubsume a b) (AASubsume EETop x (SAFinish x₂) x₁) (AAFinish x₄) = refl

    -- subsume / del
    actdet-ana er (ASubsume a b) AADel (AASubsume x x₁ SADel x₃) = refl
    actdet-ana er (ASubsume a b) AADel AADel = refl

    -- subsume / conasc
    actdet-ana EETop (ASubsume a b) AAConAsc (AASubsume EETop x₁ SAConAsc x₃) {p2 = p2} =
      abort p2
    actdet-ana er (ASubsume a b) AAConAsc AAConAsc = refl

    -- subsume / convar
    actdet-ana EETop (ASubsume SEHole b) (AAConVar x₁ p)
               (AASubsume EETop SEHole (SAConVar {Γ = Γ} p₁) x₅)
      with ctxunicity {Γ = Γ} p p₁
    ... | refl = abort (x₁ x₅)
    actdet-ana er (ASubsume a b) (AAConVar x₁ p) (AAConVar x₂ p₁) = refl

    -- subsume / conlam1
    actdet-ana EETop (ASubsume SEHole b) (AAConLam1 x₁ x₂)
               (AASubsume EETop SEHole (SAConLam x₃) x₆) {p2 = p2} = abort p2
    actdet-ana er (ASubsume a b) (AAConLam1 x₁ MAHole) (AAConLam2 x₃ x₄) =
      abort (x₄ TCHole2)
    actdet-ana er (ASubsume a b) (AAConLam1 x₁ MAArr) (AAConLam2 x₃ x₄) =
      abort (x₄ (TCArr TCHole1 TCHole1))
    actdet-ana er (ASubsume a b) (AAConLam1 x₁ x₂) (AAConLam1 x₃ x₄) = refl

    -- subsume / conlam2
    actdet-ana EETop (ASubsume SEHole TCRefl) (AAConLam2 x₁ x₂)
               (AASubsume EETop SEHole x₅ x₆) = abort (x₂ TCHole2)
    actdet-ana EETop (ASubsume SEHole TCHole1) (AAConLam2 x₁ x₂)
               (AASubsume EETop SEHole (SAConLam x₃) x₆) = abort (x₂ x₆)
    actdet-ana EETop (ASubsume SEHole TCHole2) (AAConLam2 x₁ x₂)
               (AASubsume EETop SEHole x₅ x₆) = abort (x₂ TCHole2)
    actdet-ana EETop (ASubsume a b) (AAConLam2 x₂ x₁) (AAConLam1 x₃ MAHole) = abort (x₁ TCHole2)
    actdet-ana EETop (ASubsume a b) (AAConLam2 x₂ x₁) (AAConLam1 x₃ MAArr) =
      abort (x₁ (TCArr TCHole1 TCHole1))
    actdet-ana er (ASubsume a b) (AAConLam2 x₂ x) (AAConLam2 x₃ x₄) = refl

    -- subsume / numlit
    actdet-ana er (ASubsume a b) (AAConNumlit x) (AASubsume x₁ x₂ SAConNumlit x₄) = abort (x x₄)
    actdet-ana er (ASubsume a b) (AAConNumlit x) (AAConNumlit x₁) = refl

    -- subsume / finish
    actdet-ana er (ASubsume a b) (AAFinish x) (AASubsume x₁ x₂ (SAFinish x₃) x₄) = refl
    actdet-ana er (ASubsume a b) (AAFinish x) (AAFinish x₁) = refl

    -- new cases for sums

    -- injections and cases, like lambdas, only check. so they can't be
    -- part of a subsume or a subsume action. so a lot of these cases
    -- just fall out immediately.
    actdet-ana (EEInl _) (ASubsume () _) _ _
    actdet-ana (EEInr _) (ASubsume () _) _ _
    actdet-ana (EECase1 _) (ASubsume () _) _ _
    actdet-ana (EECase2 _) (ASubsume () _) _ _
    actdet-ana (EECase3 _) (ASubsume () _) _ _

    actdet-ana EETop (AInl x wt) (AASubsume EETop () _ x₄) _
    actdet-ana EETop (AInl x wt) _ (AASubsume EETop () _ x₄)
    actdet-ana EETop (AInr x wt) (AASubsume EETop () _ x₄) _
    actdet-ana EETop (AInr x wt) _ (AASubsume EETop () _ x₄)
    actdet-ana EETop (ACase _ _ _ _ _ _) _ (AASubsume EETop () _ x₄)
    actdet-ana EETop (ACase _ _ _ _ _ _) (AASubsume EETop () _ x₄) _

    actdet-ana (EEInr er) (AInr x wt) (AASubsume (EEInr x₁) () x₃ x₄) _
    actdet-ana (EEInr er) (AInr x wt) _ (AASubsume (EEInr x₁) () x₃ x₄)
    actdet-ana (EEInl er) (AInl x wt) (AASubsume (EEInl x₁) () x₃ x₄) _
    actdet-ana (EEInl er) (AInl x wt) _ (AASubsume (EEInl x₁) () x₃ x₄)

    actdet-ana (EECase1 er) (ACase x₁ x₂ x₃ x₄ wt wt₁) _ (AASubsume (EECase1 x₉) () x₁₁ x₁₂)
    actdet-ana (EECase2 er) (ACase x₁ x₂ x₃ x₄ wt wt₁) _ (AASubsume (EECase2 x₉) () x₁₁ x₁₂)
    actdet-ana (EECase3 er) (ACase x₁ x₂ x₃ x₄ wt wt₁) _ (AASubsume (EECase3 x₉) () x₁₁ x₁₂)

    actdet-ana (EECase1 er) (ACase x₁ x₂ x₃ x₄ wt wt₁) (AASubsume (EECase1 x₉) () x₁₁ x₁₂) _
    actdet-ana (EECase2 er) (ACase x₁ x₂ x₃ x₄ wt wt₁) (AASubsume (EECase2 x₉) () x₁₁ x₁₂) _
    actdet-ana (EECase3 er) (ACase x₁ x₂ x₃ x₄ wt wt₁) (AASubsume (EECase3 x₉) () x₁₁ x₁₂) _

    actdet-ana EETop (ASubsume SEHole x₂) (AAConCase x₃ x₄)
               (AASubsume EETop SEHole (SAConCase1 x₁ x₅ MSHole) x₈) {p2 = p2} = abort p2
    actdet-ana EETop (ASubsume SEHole x₂) (AAConCase x₃ x₄)
               (AASubsume EETop SEHole (SAConCase2 x₁ x₅ x₆) x₈) = abort (x₆ TCHole2)
    actdet-ana EETop (ASubsume SEHole x₂) (AASubsume EETop SEHole (SAConCase1 x₁ x₃ MSHole) x₆)
               (AAConCase x₇ x₈) {p1} = abort p1
    actdet-ana EETop (ASubsume SEHole x₂) (AASubsume EETop SEHole (SAConCase2 x₁ x₃ x₄) x₆)
               (AAConCase x₇ x₈) = abort (x₄ TCHole2)

      -- the cases where the derivations match just go through
    actdet-ana er (ASubsume x x₁) (AAConInl1 x₂) (AAConInl1 x₃) = refl
    actdet-ana EETop (ASubsume SEHole x₁) (AAConInl2 x₂) (AAConInl2 x₃) = refl
    actdet-ana er (ASubsume x x₁) (AAConInr1 x₂) (AAConInr1 x₃) = refl
    actdet-ana er (ASubsume x x₁) (AAConInr2 x₂) (AAConInr2 x₃) = refl
    actdet-ana EETop (ASubsume SEHole x₂) (AAConCase x₃ x₄) (AAConCase x₅ x₆) = refl
    actdet-ana er (AInl x wt) AADel AADel = refl
    actdet-ana er (AInl x wt) AAConAsc AAConAsc = refl
    actdet-ana er (AInr x wt) AADel AADel = refl
    actdet-ana er (AInr x wt) AAConAsc AAConAsc = refl
    actdet-ana er (ACase x₁ x₂ x₃ x₄ wt wt₁) AADel AADel = refl
    actdet-ana er (ACase x₁ x₂ x₃ x₄ wt wt₁) AAConAsc AAConAsc = refl

    -- everything else we need to argue a little bit more carefully

    -- matching zipper cases; these cause us to recurr
    actdet-ana (EEInl er) (AInl x wt) (AAZipInl x₁ d1) (AAZipInl x₂ d2) {p1} {p2}
       with ▸sum-unicity x₂ x₁
    ... | refl with ▸sum-unicity x x₁
    ... | refl = ap1 inl (actdet-ana er wt d1 d2  {p1} {p2})

    actdet-ana (EEInr er) (AInr x wt) (AAZipInr x₁ d1) (AAZipInr x₂ d2) {p1} {p2}
       with ▸sum-unicity x₂ x₁
    ... | refl with ▸sum-unicity x x₁
    ... | refl = ap1 inr (actdet-ana er wt d1 d2  {p1} {p2})

    actdet-ana (EECase1 er) (ACase x₂ x₃ x₄ x₅ wt wt₁) (AAZipCase1 x₆ x₇ x₈ x₉ x₁₀ x₁₁ x₁₂ x₁₃)
               (AAZipCase1 x₁₄ x₁₅ x₁₆ x₁₇ x₁₈ x₁₉ x₂₀ x₂₁) {p1} {p2}
       with erasee-det x₈ x₁₆
    ... | refl with synthunicity x₁₇ x₉
    ... | refl with actdet-synth x₈ x₉ x₁₈ x₁₀ {p2} {p1}
    ... | refl , refl = refl

    actdet-ana (EECase2 er) (ACase x₂ x₃ x₄ x₅ wt wt₁) (AAZipCase2 x₆ x₇ x₈ x₉ d1)
               (AAZipCase2 x₁₁ x₁₂ x₁₃ x₁₄ d2) {p1} {p2}
       with synthunicity x₅ x₈
    ... | refl with synthunicity x₅ x₁₃
    ... | refl with ▸sum-unicity x₁₄ x₉
    ... | refl with ▸sum-unicity x₉ x₄
    ... | refl with actdet-ana er wt d1 d2 {p1} {p2}
    ... | refl = refl

    actdet-ana (EECase3 er) (ACase x₂ x₃ x₄ x₅ wt wt₁) (AAZipCase3 x₆ x₇ x₈ x₉ d1)
               (AAZipCase3 x₁₁ x₁₂ x₁₃ x₁₄ d2) {p1} {p2}
      with synthunicity x₈ x₁₃
    ... | refl with synthunicity x₈ x₅
    ... | refl with ▸sum-unicity x₄ x₉
    ... | refl with ▸sum-unicity x₄ x₁₄
    ... | refl with actdet-ana er wt₁ d1 d2 {p1} {p2}
    ... | refl = refl

    actdet-ana EETop (ASubsume SEHole x₁) (AASubsume EETop SEHole SAConInl x₅)
               (AAConInl1 x₆) {p1} = abort p1
    actdet-ana EETop (ASubsume SEHole x₁) (AASubsume EETop SEHole SAConInl x₅)
               (AAConInl2 x₆) = abort (x₆ x₅)
    actdet-ana EETop (ASubsume SEHole x₁) (AASubsume EETop SEHole SAConInr x₅)
               (AAConInr1 x₆) {p1} = abort p1
    actdet-ana EETop (ASubsume SEHole x₁) (AASubsume EETop SEHole SAConInr x₅)
               (AAConInr2 x₆) = abort (x₆ x₅)
    actdet-ana EETop (ASubsume SEHole x₁) (AAConInl1 x₂)
               (AASubsume EETop SEHole SAConInl x₆) {p2 = p2} = abort p2
    actdet-ana EETop (ASubsume SEHole x₁) (AAConInr1 x₂)
               (AASubsume EETop SEHole SAConInr c) {p2 = p2} = abort p2

    actdet-ana EETop (ASubsume SEHole x₁) (AAConInl1 q) (AAConInl2 x₃) =
      abort (lem-plusholematch x₃ x₁ q)
    actdet-ana EETop (ASubsume SEHole x₁) (AAConInl2 x₂) (AASubsume EETop SEHole SAConInl x₆) =
      abort (x₂ x₆)
    actdet-ana EETop (ASubsume SEHole x₁) (AAConInl2 x₂) (AAConInl1 q) =
      abort (lem-plusholematch x₂ x₁ q)
    actdet-ana EETop (ASubsume SEHole x₁) (AAConInr1 x₂) (AAConInr2 x₃) =
      abort (lem-plusholematch x₃ x₁ x₂)
    actdet-ana EETop (ASubsume SEHole x₁) (AAConInr2 x₂) (AASubsume EETop x₄ SAConInr x₆) =
      abort (x₂ x₆)
    actdet-ana EETop (ASubsume SEHole x₁) (AAConInr2 x₂) (AAConInr1 x₃) =
      abort (lem-plusholematch x₂ x₁ x₃)


-- Andreas, 2015-08-26
{-# OPTIONS --rewriting #-} -- Should give error

open import Agda.Builtin.Equality
open import Common.List

{-# BUILTIN REWRITE _≡_ #-}

lengthMap : {A B : Set} (f : A → B) (xs : List A) →
            length (map f xs) ≡ length xs
lengthMap f [] = refl
lengthMap f (x ∷ xs) rewrite lengthMap f xs = refl

{-# REWRITE lengthMap #-}


open import Nat
open import Prelude
open import core
open import contexts
open import typed-elaboration
open import lemmas-gcomplete
open import lemmas-complete

module complete-elaboration where
  mutual
    complete-elaboration-synth : ∀{e τ Γ Δ d} →
                               Γ gcomplete →
                               e ecomplete →
                               Γ ⊢ e ⇒ τ ~> d ⊣ Δ →
                               (d dcomplete × τ tcomplete × Δ == ∅)
    complete-elaboration-synth gc ec ESConst = DCConst , TCBase , refl
    complete-elaboration-synth gc ec (ESVar x₁) = DCVar , gc _ _ x₁ , refl
    complete-elaboration-synth gc (ECLam2 ec x₁) (ESLam x₂ exp)
      with complete-elaboration-synth (gcomp-extend gc x₁ x₂) ec exp
    ... | ih1 , ih2 , ih3 = DCLam ih1 x₁ , TCArr x₁ ih2 , ih3
    complete-elaboration-synth gc (ECAp ec ec₁) (ESAp _ _ x MAHole x₂ x₃)
      with comp-synth gc ec x
    ... | ()
    complete-elaboration-synth gc (ECAp ec ec₁) (ESAp {Δ1 = Δ1} {Δ2 = Δ2} _ _ x MAArr x₂ x₃)
      with comp-synth gc ec x
    ... | TCArr t1 t2
      with complete-elaboration-ana gc ec (TCArr t1 t2) x₂ | complete-elaboration-ana gc ec₁ t1 x₃
    ... | ih1 , _ ,  ih4 | ih2 , _ , ih3 = DCAp (DCCast ih1 (comp-ana gc x₂ ih1) (TCArr t1 t2)) (DCCast ih2 (comp-ana gc x₃ ih2) t1) ,
                                  t2 ,
                                  tr (λ qq → (qq ∪ Δ2) == ∅) (! ih4) (tr (λ qq → (∅ ∪ qq) == ∅) (! ih3) refl)
    complete-elaboration-synth gc () ESEHole
    complete-elaboration-synth gc () (ESNEHole _ exp)
    complete-elaboration-synth gc (ECAsc x ec) (ESAsc x₁)
      with complete-elaboration-ana gc ec x x₁
    ... | ih1 , _ , ih2 = DCCast ih1 (comp-ana gc x₁ ih1) x , x , ih2

    complete-elaboration-ana : ∀{e τ τ' Γ Δ d} →
                             Γ gcomplete →
                             e ecomplete →
                             τ tcomplete →
                             Γ ⊢ e ⇐ τ ~> d :: τ' ⊣ Δ →
                             (d dcomplete × τ' tcomplete × Δ == ∅)
    complete-elaboration-ana gc (ECLam1 ec) () (EALam x₁ MAHole exp)
    complete-elaboration-ana gc (ECLam1 ec) (TCArr t1 t2)  (EALam x₁ MAArr exp)
      with complete-elaboration-ana (gcomp-extend gc t1 x₁) ec t2 exp
    ... | ih , ih3 , ih2 = DCLam ih t1 , TCArr t1 ih3 , ih2
    complete-elaboration-ana gc ec tc (EASubsume x x₁ x₂ x₃)
      with complete-elaboration-synth gc ec x₂
    ... | ih1 , ih2 , ih3 = ih1 , ih2 , ih3

    -- this is just a convenience since it shows up a few times above
    comp-ana : ∀{Γ e τ d τ' Δ} →
       Γ gcomplete →
       Γ ⊢ e ⇐ τ ~> d :: τ' ⊣ Δ →
       d dcomplete →
       τ' tcomplete
    comp-ana gc ex dc = complete-ta gc (π2 (typed-elaboration-ana ex)) dc


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

open import Categories.Category using (module Commutation)
  renaming (Category to Setoid-Category)
open import Categories.Category.Monoidal using (Monoidal)
open import Categories.Category.Monoidal.Symmetric using (Symmetric)

module Categories.Enriched.Category.Opposite
  {o ℓ e} {V : Setoid-Category o ℓ e} {M : Monoidal V} (S : Symmetric M) where

-- The dual of a V-enriched category.
--
-- Note that, for this construction to work, V needs to be a
-- *symmetric* monoidal category.

open import Data.Product using (_,_)

import Categories.Category.Monoidal.Braided.Properties as BraidedProperties
open import Categories.Category.Monoidal.Reasoning M
open import Categories.Category.Monoidal.Utilities M using (module Shorthands)
open import Categories.Enriched.Category M using (Category)
open import Categories.Morphism.Reasoning V

open Setoid-Category V renaming (id to idV) using (_⇒_; _∘_; assoc)
open Commutation V
open Shorthands
open Symmetric S
open BraidedProperties (Symmetric.braided S) using (braiding-coherence)

private σ = λ {A B} → braiding.⇒.η (A , B)

-- The opposite of a V-enriched category.

op : ∀ {v} → Category v → Category v
op C = record
  { Obj = Obj
  ; hom = λ A B → hom B A
  ; id  = id
  ; ⊚   = ⊚ ∘ σ
  ; ⊚-assoc = begin
      (⊚ ∘ σ) ∘ (⊚ ∘ σ) ⊗₁ idV               ≈⟨ refl⟩∘⟨ split₁ʳ ⟩
      (⊚ ∘ σ) ∘ ⊚ ⊗₁ idV ∘ σ ⊗₁ idV          ≈⟨ extend² (braiding.⇒.commute _) ⟩
      (⊚ ∘ idV ⊗₁ ⊚) ∘ σ ∘ σ ⊗₁ idV          ≈⟨ ⊚-assoc′ ⟩∘⟨refl ⟩
      (⊚ ∘ ⊚ ⊗₁ idV ∘ α⇐) ∘ σ ∘ σ ⊗₁ idV     ≈˘⟨ assoc ⟩∘⟨refl ⟩
      ((⊚ ∘ ⊚ ⊗₁ idV) ∘ α⇐) ∘ σ ∘ σ ⊗₁ idV   ≈⟨ pullʳ invert-braidings ⟩
      (⊚ ∘ ⊚ ⊗₁ idV) ∘ σ ∘ idV ⊗₁ σ ∘ α⇒     ≈˘⟨ refl⟩∘⟨ assoc ⟩
      (⊚ ∘ ⊚ ⊗₁ idV) ∘ (σ ∘ idV ⊗₁ σ) ∘ α⇒
                                    ≈˘⟨ pushˡ (extend² (braiding.⇒.commute _)) ⟩
      ((⊚ ∘ σ) ∘ idV ⊗₁ ⊚ ∘ idV ⊗₁ σ) ∘ α⇒   ≈˘⟨ pullˡ (refl⟩∘⟨ split₂ʳ) ⟩
      (⊚ ∘ σ) ∘ idV ⊗₁ (⊚ ∘ σ) ∘ α⇒   ∎
  ; unitˡ = λ {A B} → begin
      (⊚ ∘ σ) ∘ id ⊗₁ idV   ≈⟨ pullʳ (braiding.⇒.commute _) ⟩
      ⊚ ∘ idV ⊗₁ id ∘ σ     ≈⟨ pullˡ unitʳ ⟩
      ρ⇒ ∘ σ                ≈˘⟨ switch-fromtoʳ braided-iso braiding-coherence ⟩
      λ⇒                    ∎
  ; unitʳ = begin
      (⊚ ∘ σ) ∘ idV ⊗₁ id   ≈⟨ pullʳ (braiding.⇒.commute _) ⟩
      ⊚ ∘ id ⊗₁ idV ∘ σ     ≈⟨ pullˡ unitˡ ⟩
      λ⇒ ∘ σ                ≈⟨ braiding-coherence ⟩
      ρ⇒                    ∎
  }
  where
    open Category C

    ⊚-assoc′ : ∀ {A B C D} →
               [ hom C D ⊗₀ (hom B C ⊗₀ hom A B) ⇒ hom A D ]⟨
                 idV ⊗₁ ⊚    ⇒⟨ hom C D ⊗₀ hom A C ⟩
                 ⊚
               ≈ α⇐          ⇒⟨ (hom C D ⊗₀ hom B C) ⊗₀ hom A B ⟩
                 ⊚ ⊗₁ idV    ⇒⟨ hom B D ⊗₀ hom A B ⟩
                 ⊚
               ⟩
    ⊚-assoc′ = switch-fromtoʳ associator (assoc ○ ⟺ ⊚-assoc) ○ assoc

    -- implements the following equation of string diagrams
    --
    --     |   |   |               |   |   |
    --      \ /    |               |    \ /
    --       \     |               |     \
    --      / \   /                 \   / \
    --     |   \ /        ===        \ /   |
    --      \   \                     /   /
    --       \ / \                   / \ /
    --        \   \                 /   /
    --       / \   \               /   / \
    --      |   |   |             |   |   |
    --
    invert-braidings : ∀ {A B C} →
                       [ (A ⊗₀ B) ⊗₀ C ⇒ (C ⊗₀ B) ⊗₀ A ]⟨
                         σ ⊗₁ idV      ⇒⟨ (B ⊗₀ A) ⊗₀ C ⟩
                         σ             ⇒⟨ C ⊗₀ (B ⊗₀ A) ⟩
                         α⇐
                       ≈ α⇒            ⇒⟨ A ⊗₀ (B ⊗₀ C) ⟩
                         idV ⊗₁ σ      ⇒⟨ A ⊗₀ (C ⊗₀ B) ⟩
                         σ
                       ⟩
    invert-braidings = begin
        α⇐ ∘ σ ∘ σ ⊗₁ idV
      ≈⟨ extendʳ (switch-tofromʳ associator (⟺ hexagon₂)) ⟩
        ((σ ⊗₁ idV ∘ α⇐) ∘ idV ⊗₁ σ) ∘ α⇒ ∘ σ ⊗₁ idV
      ≈⟨ assoc ⟩
        (σ ⊗₁ idV ∘ α⇐) ∘ idV ⊗₁ σ ∘ α⇒ ∘ σ ⊗₁ idV
      ≈˘⟨ pushʳ (switch-fromtoˡ associator (⟺ hexagon₁)) ⟩
        σ ⊗₁ idV ∘ σ ∘ α⇒
      ≈˘⟨ extendʳ (braiding.⇒.commute _) ⟩
        σ ∘ idV ⊗₁ σ ∘ α⇒
      ∎


-- Andreas, 2016-01-08 allow --type-in-type with universe polymorphism

{-# OPTIONS --type-in-type #-}

-- {-# OPTIONS --v tc:30 #-}
-- {-# OPTIONS --v tc.conv.level:60 #-}

open import Common.Level
open import Common.Equality

Type : Set
Type = Set

data E α β : Set β where
  e : Set α → E α β

data D {α} (A : Set α) : Set where
  d : A → D A

-- Make sure we do not get unsolved level metas

id : ∀{a}{A : Set a} → A → A
id x = x

test = id Set

data Unit : Set where
  unit : Unit

test1 = id unit

data UnitP {α} : Set α where
  unitP : UnitP

test2 = id unitP

-- All levels are equal
-- (need not be for --type-in-type, but this is how it is implemented):

level0≡1 : lzero ≡ lsuc lzero
level0≡1 = refl

levelTrivial : ∀{a b : Level} → a ≡ b
levelTrivial = refl


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

open import HoTT

module groups.ReducedWord {i} {A : Type i} (dec : has-dec-eq A) where

  is-reduced : Word A → Type i
  is-reduced nil                   = Lift ⊤
  is-reduced (_     :: nil)        = Lift ⊤
  is-reduced (inl x :: inl y :: w) = is-reduced (inl y :: w)
  is-reduced (inl x :: inr y :: w) = (x ≠ y) × is-reduced (inr y :: w)
  is-reduced (inr x :: inl y :: w) = (x ≠ y) × is-reduced (inl y :: w)
  is-reduced (inr x :: inr y :: w) = is-reduced (inr y :: w)

  -- Everything is a set.

  A-is-set : is-set A
  A-is-set = dec-eq-is-set dec

  PlusMinus-has-dec-eq : has-dec-eq (PlusMinus A)
  PlusMinus-has-dec-eq (inl x) (inl y) with dec x y
  PlusMinus-has-dec-eq (inl x) (inl y) | inl p  = inl $ ap inl p
  PlusMinus-has-dec-eq (inl x) (inl y) | inr ¬p = inr $ ¬p ∘ lower ∘ Coprod=-in
  PlusMinus-has-dec-eq (inl x) (inr y) = inr $ lower ∘ Coprod=-in
  PlusMinus-has-dec-eq (inr x) (inl y) = inr $ lower ∘ Coprod=-in
  PlusMinus-has-dec-eq (inr x) (inr y) with dec x y
  PlusMinus-has-dec-eq (inr x) (inr y) | inl p  = inl $ ap inr p
  PlusMinus-has-dec-eq (inr x) (inr y) | inr ¬p = inr $ ¬p ∘ lower ∘ Coprod=-in

  Word-has-dec-eq : has-dec-eq (Word A)
  Word-has-dec-eq nil nil = inl idp
  Word-has-dec-eq nil (_ :: w) = inr $ lower ∘ List=-in
  Word-has-dec-eq (_ :: v) nil = inr $ lower ∘ List=-in
  Word-has-dec-eq (x :: v) (y :: w) with PlusMinus-has-dec-eq x y
  Word-has-dec-eq (x :: v) (y :: w) | inl x=y with Word-has-dec-eq v w
  Word-has-dec-eq (x :: v) (y :: w) | inl x=y | inl v=w = inl $ List=-out (x=y , v=w)
  Word-has-dec-eq (x :: v) (y :: w) | inl x=y | inr v≠w = inr $ v≠w ∘ snd ∘ List=-in
  Word-has-dec-eq (x :: v) (y :: w) | inr x≠y = inr $ x≠y ∘ fst ∘ List=-in

  instance
    Word-is-set : is-set (Word A)
    Word-is-set = dec-eq-is-set Word-has-dec-eq

  is-reduced-is-prop : {w : Word A} → is-prop (is-reduced w)
  is-reduced-is-prop {nil}                 = ⟨⟩
  is-reduced-is-prop {x    :: nil}         = ⟨⟩
  is-reduced-is-prop {inl x :: inl y :: l} = is-reduced-is-prop {inl y :: l}
  is-reduced-is-prop {inl x :: inr y :: l} = ⟨⟩ where instance _ = is-reduced-is-prop {inr y :: l}
  is-reduced-is-prop {inr x :: inl y :: l} = ⟨⟩ where instance _ = is-reduced-is-prop {inl y :: l}
  is-reduced-is-prop {inr x :: inr y :: l} = is-reduced-is-prop {inr y :: l}

  is-reduced-prop : SubtypeProp (Word A) i
  is-reduced-prop = is-reduced , λ w → is-reduced-is-prop {w}

  -- The subtype

  ReducedWord : Type i
  ReducedWord = Subtype is-reduced-prop

  instance
    ReducedWord-is-set : is-set ReducedWord
    ReducedWord-is-set = Subtype-level is-reduced-prop where instance _ = is-reduced-is-prop

  -- Identifications in [ReducedWord].

  ReducedWord= : ReducedWord → ReducedWord → Type i
  ReducedWord= = Subtype= is-reduced-prop

  ReducedWord=-out : {x y : ReducedWord} → ReducedWord= x y → x == y
  ReducedWord=-out = Subtype=-out is-reduced-prop

  -- The group structure of reduced words

  private
    rw-unit : ReducedWord
    rw-unit = nil , lift tt

    abstract
      tail-is-reduced : ∀ x w → is-reduced (x :: w) → is-reduced w
      tail-is-reduced x nil red = lift tt
      tail-is-reduced (inl x) (inl y :: w) red = red
      tail-is-reduced (inl x) (inr y :: w) red = snd red
      tail-is-reduced (inr x) (inl y :: w) red = snd red
      tail-is-reduced (inr x) (inr y :: w) red = red

    rw-cons : PlusMinus A → ReducedWord → ReducedWord
    rw-cons x (nil , _) = (x :: nil) , lift tt
    rw-cons (inl x) ((inl y :: l) , red) = (inl x :: inl y :: l) , red
    rw-cons (inl x) ((inr y :: l) , red) with dec x y
    rw-cons (inl x) ((inr y :: l) , red) | inl p = l , tail-is-reduced (inr y) l red
    rw-cons (inl x) ((inr y :: l) , red) | inr ¬p = (inl x :: inr y :: l) , (¬p , red)
    rw-cons (inr x) ((inl y :: l) , red) with dec x y
    rw-cons (inr x) ((inl y :: l) , red) | inl p = l , tail-is-reduced (inl y) l red
    rw-cons (inr x) ((inl y :: l) , red) | inr ¬p = (inr x :: inl y :: l) , (¬p , red)
    rw-cons (inr x) ((inr y :: l) , red) = (inr x :: inr y :: l) , red

    rw-++' : Word A → ReducedWord → ReducedWord
    rw-++' w₁ rw₂ = foldr rw-cons rw₂ w₁

    reduce : Word A → ReducedWord
    reduce w = rw-++' w rw-unit

    rw-++ : ReducedWord → ReducedWord → ReducedWord
    rw-++ rw₁ rw₂ = rw-++' (fst rw₁) rw₂

    abstract
      -- assoc
      rw-cons-reduced : ∀ x w
        → (red : is-reduced w)
        → (red' : is-reduced (x :: w))
        → rw-cons x (w , red) == (x :: w) , red'
      rw-cons-reduced x nil _ _ = ReducedWord=-out idp
      rw-cons-reduced (inl x) (inl y :: w) _ red' = ReducedWord=-out idp
      rw-cons-reduced (inl x) (inr y :: w) _ red' with dec x y
      rw-cons-reduced (inl x) (inr y :: w) _ red' | inl p = ⊥-rec $ fst red' $ p
      rw-cons-reduced (inl x) (inr y :: w) _ red' | inr ¬p = ReducedWord=-out idp
      rw-cons-reduced (inr x) (inl y :: w) _ red' with dec x y
      rw-cons-reduced (inr x) (inl y :: w) _ red' | inl p = ⊥-rec $ fst red' $ p
      rw-cons-reduced (inr x) (inl y :: w) _ red' | inr ¬p = ReducedWord=-out idp
      rw-cons-reduced (inr x) (inr y :: w) _ red' = ReducedWord=-out idp

      rw-cons-flip : ∀ x w red red'
        → rw-cons x ((flip x :: w) , red) == w , red'
      rw-cons-flip (inl x) w _ _ with dec x x
      rw-cons-flip (inl x) w _ _ | inl x=x = ReducedWord=-out idp
      rw-cons-flip (inl x) w _ _ | inr x≠x = ⊥-rec (x≠x idp)
      rw-cons-flip (inr x) w _ _ with dec x x
      rw-cons-flip (inr x) w _ _ | inl x=x = ReducedWord=-out idp
      rw-cons-flip (inr x) w _ _ | inr x≠x = ⊥-rec (x≠x idp)

      rw-cons-cons-flip : ∀ x rw
        → rw-cons x (rw-cons (flip x) rw) == rw
      rw-cons-cons-flip x (nil , red) = rw-cons-flip x nil _ red
      rw-cons-cons-flip (inl x) ((inl y :: w) , red) with dec x y
      rw-cons-cons-flip (inl x) ((inl y :: w) , red) | inl x=y =
          rw-cons-reduced (inl x) w _ (transport! (λ z → is-reduced (inl z :: w)) x=y red)
        ∙ ReducedWord=-out (ap (λ z → inl z :: w) x=y)
      rw-cons-cons-flip (inl x) ((inl y :: w) , red) | inr x≠y =
        rw-cons-flip (inl x) (inl y :: w) (x≠y , red) red
      rw-cons-cons-flip (inl x) ((inr y :: w) , red) = rw-cons-flip (inl x) (inr y :: w) red red
      rw-cons-cons-flip (inr x) ((inl y :: w) , red) = rw-cons-flip (inr x) (inl y :: w) red red
      rw-cons-cons-flip (inr x) ((inr y :: w) , red) with dec x y
      rw-cons-cons-flip (inr x) ((inr y :: w) , red) | inl x=y =
          rw-cons-reduced (inr x) w _ (transport! (λ z → is-reduced (inr z :: w)) x=y red)
        ∙ ReducedWord=-out (ap (λ z → inr z :: w) x=y)
      rw-cons-cons-flip (inr x) ((inr y :: w) , red) | inr x≠y =
        rw-cons-flip (inr x) (inr y :: w) (x≠y , red) red

      rw-++-cons : ∀ x rw₁ rw₂
        →  rw-++ (rw-cons x rw₁) rw₂
        == rw-cons x (rw-++ rw₁ rw₂)
      rw-++-cons x       (nil           , _) rw₂ = idp
      rw-++-cons (inl x) ((inl y :: w₁) , _) rw₂ = idp
      rw-++-cons (inl x) ((inr y :: w₁) , _) rw₂ with dec x y
      rw-++-cons (inl x) ((inr y :: w₁) , _) rw₂ | inl p rewrite p =
        ! (rw-cons-cons-flip (inl y) (rw-++' w₁ rw₂))
      rw-++-cons (inl x) ((inr y :: w₁) , _) rw₂ | inr ¬p = idp
      rw-++-cons (inr x) ((inl y :: w₁) , _) rw₂ with dec x y
      rw-++-cons (inr x) ((inl y :: w₁) , _) rw₂ | inl p rewrite p =
        ! (rw-cons-cons-flip (inr y) (rw-++' w₁ rw₂))
      rw-++-cons (inr x) ((inl y :: w₁) , _) rw₂ | inr ¬p = idp
      rw-++-cons (inr x) ((inr y :: w₁) , _) rw₂ = idp

      rw-++-assoc' : ∀ w₁ rw₂ rw₃
        →  rw-++ (rw-++' w₁ rw₂) rw₃
        == rw-++' w₁ (rw-++' (fst rw₂) rw₃)
      rw-++-assoc' nil rw₂ rw = idp
      rw-++-assoc' (x :: w₁) rw₂ rw₃ =
          rw-++-cons x (rw-++' w₁ rw₂) rw₃
        ∙ ap (rw-cons x) (rw-++-assoc' w₁ rw₂ rw₃)

    -- inv
    abstract
      head2-is-reduced : ∀ x y w → is-reduced (x :: y :: w) → is-reduced (x :: y :: nil)
      head2-is-reduced (inl x) (inl y) w red = lift tt
      head2-is-reduced (inl x) (inr y) w red = fst red , lift tt
      head2-is-reduced (inr x) (inl y) w red = fst red , lift tt
      head2-is-reduced (inr x) (inr y) w red = lift tt

      cons-is-reduced : ∀ x y w → is-reduced (x :: y :: nil) → is-reduced (y :: w)
        → is-reduced (x :: y :: w)
      cons-is-reduced (inl x) (inl y) _ _    red₂ = red₂
      cons-is-reduced (inl x) (inr y) _ red₁ red₂ = fst red₁ , red₂
      cons-is-reduced (inr x) (inl y) _ red₁ red₂ = fst red₁ , red₂
      cons-is-reduced (inr x) (inr y) _ _    red₂ = red₂

      ++-is-reduced : ∀ w₁ x w₂ → is-reduced (w₁ ++ (x :: nil)) → is-reduced (x :: w₂)
        → is-reduced ((w₁ ++ (x :: nil)) ++ w₂)
      ++-is-reduced nil            _ _  _    red₂ = red₂
      ++-is-reduced (x :: nil)     y w₂ red₁ red₂ = cons-is-reduced x y w₂ red₁ red₂
      ++-is-reduced (x :: y :: w₁) z w₂ red₁ red₂ =
        cons-is-reduced x y ((w₁ ++ (z :: nil)) ++ w₂)
          (head2-is-reduced x y (w₁ ++ (z :: nil)) red₁)
          (++-is-reduced (y :: w₁) z w₂ (tail-is-reduced x (y :: w₁ ++ (z :: nil)) red₁) red₂)

      swap2-is-reduced : ∀ x y → is-reduced (x :: y :: nil) → is-reduced (y :: x :: nil)
      swap2-is-reduced (inl x) (inl y) red = lift tt
      swap2-is-reduced (inl x) (inr y) red = fst red ∘ ! , lift tt
      swap2-is-reduced (inr x) (inl y) red = fst red ∘ ! , lift tt
      swap2-is-reduced (inr x) (inr y) red = lift tt

      reverse-is-reduced : ∀ w → is-reduced w → is-reduced (reverse w)
      reverse-is-reduced nil red = red
      reverse-is-reduced (x :: nil) red = red
      reverse-is-reduced (x :: y :: w) red =
        ++-is-reduced
          (reverse w) y (x :: nil)
          (reverse-is-reduced (y :: w) (tail-is-reduced x (y :: w) red))
          (swap2-is-reduced x y (head2-is-reduced x y w red))

      flip2-is-reduced : ∀ x y → is-reduced (x :: y :: nil) → is-reduced (flip x :: flip y :: nil)
      flip2-is-reduced (inl x) (inl y) red = red
      flip2-is-reduced (inl x) (inr y) red = red
      flip2-is-reduced (inr x) (inl y) red = red
      flip2-is-reduced (inr x) (inr y) red = red

      Word-flip-is-reduced : ∀ w → is-reduced w → is-reduced (Word-flip w)
      Word-flip-is-reduced nil           red = red
      Word-flip-is-reduced (x :: nil)    red = red
      Word-flip-is-reduced (x :: y :: w) red =
        cons-is-reduced (flip x) (flip y) (Word-flip w)
          (flip2-is-reduced x y (head2-is-reduced x y w red))
          (Word-flip-is-reduced (y :: w) (tail-is-reduced x (y :: w) red))

    rw-inv : ReducedWord → ReducedWord
    rw-inv (w , red) = reverse (Word-flip w) , reverse-is-reduced (Word-flip w) (Word-flip-is-reduced w red)

    abstract
      rw-inv-l-lemma : ∀ w₁ x w₂ (red₂ : is-reduced (x :: w₂)) (red₂' : is-reduced w₂)
        →  rw-++' (w₁ ++ (flip x :: nil)) ((x :: w₂) , red₂)
        == rw-++' w₁ (w₂ , red₂')
      rw-inv-l-lemma nil (inl x) w₂ _ _ with dec x x
      rw-inv-l-lemma nil (inl x) w₂ _ _ | inl p = ReducedWord=-out idp
      rw-inv-l-lemma nil (inl x) w₂ _ _ | inr ¬p = ⊥-rec (¬p idp)
      rw-inv-l-lemma nil (inr x) w₂ _ _ with dec x x
      rw-inv-l-lemma nil (inr x) w₂ _ _ | inl p = ReducedWord=-out idp
      rw-inv-l-lemma nil (inr x) w₂ _ _ | inr ¬p = ⊥-rec (¬p idp)
      rw-inv-l-lemma (x :: w₁) y w₂ red₂ red₂' =
        ap (rw-cons x) (rw-inv-l-lemma w₁ y w₂ red₂ red₂')

      rw-inv-l' : ∀ w (red : is-reduced w)
        → rw-++' (reverse (Word-flip w)) (w , red) == nil , lift tt
      rw-inv-l' nil _ = idp
      rw-inv-l' (x :: w) red =
          rw-inv-l-lemma (reverse (Word-flip w)) x w red (tail-is-reduced x w red)
        ∙ rw-inv-l' w (tail-is-reduced x w red)

      suffix-is-reduced : ∀ w₁ w₂ → is-reduced (w₁ ++ w₂) → is-reduced w₂
      suffix-is-reduced nil w₂ red = red
      suffix-is-reduced (x :: w₁) w₂ red = suffix-is-reduced w₁ w₂ $ tail-is-reduced x (w₁ ++ w₂) red

  ReducedWord-group-struct : GroupStructure ReducedWord
  ReducedWord-group-struct = record
    { ident = nil , lift tt
    ; inv = rw-inv
    ; comp = rw-++
    ; unit-l = λ _ → idp
    ; assoc = λ rw → rw-++-assoc' (fst rw)
    ; inv-l = uncurry rw-inv-l'
    }

  ReducedWord-group : Group i
  ReducedWord-group = group _ ReducedWord-group-struct

  private
    abstract
      QuotWordRel-cons : ∀ x w₂ (red₂ : is-reduced w₂)
        → QuotWordRel (x :: w₂) (fst (rw-cons x (w₂ , red₂)))
      QuotWordRel-cons x nil _ = qwr-refl idp
      QuotWordRel-cons (inl x) (inl y :: w) _ = qwr-refl idp
      QuotWordRel-cons (inl x) (inr y :: w) _ with dec x y
      QuotWordRel-cons (inl x) (inr y :: w) _ | inl x=y rewrite x=y = qwr-flip (inl y) w
      QuotWordRel-cons (inl x) (inr y :: w) _ | inr x≠y = qwr-refl idp
      QuotWordRel-cons (inr x) (inl y :: w) _ with dec x y
      QuotWordRel-cons (inr x) (inl y :: w) _ | inl x=y rewrite x=y = qwr-flip (inr y) w
      QuotWordRel-cons (inr x) (inl y :: w) _ | inr x≠y = qwr-refl idp
      QuotWordRel-cons (inr x) (inr y :: w) _ = qwr-refl idp

      QuotWordRel-++ : ∀ w₁ rw₂
        → QuotWordRel (w₁ ++ fst rw₂) (fst (rw-++' w₁ rw₂))
      QuotWordRel-++ nil _ = qwr-refl idp
      QuotWordRel-++ (x :: w₁) rw₂ =
        qwr-trans (qwr-cons x (QuotWordRel-++ w₁ rw₂)) $
        uncurry (QuotWordRel-cons x) (rw-++' w₁ rw₂)

  -- freeness
  ReducedWord-to-FreeGroup : ReducedWord-group →ᴳ FreeGroup A
  ReducedWord-to-FreeGroup = group-hom (λ rw → qw[ fst rw ])
    (λ rw₁ rw₂ → ! $ quot-rel $ QuotWordRel-++ (fst rw₁) rw₂)

  private
    abstract
      reduce-emap : ∀ {w₁ w₂} → QuotWordRel w₁ w₂ → reduce w₁ == reduce w₂
      reduce-emap (qwr-refl p) = ap reduce p
      reduce-emap (qwr-trans qwr₁ qwr₂) = reduce-emap qwr₁ ∙ reduce-emap qwr₂
      reduce-emap (qwr-sym qwr) = ! (reduce-emap qwr)
      reduce-emap (qwr-cons x qwr) = ap (rw-cons x) (reduce-emap qwr)
      reduce-emap (qwr-flip x w) = rw-cons-cons-flip x (reduce w)

    to = GroupHom.f ReducedWord-to-FreeGroup

    from : QuotWord A → ReducedWord
    from = QuotWord-rec reduce reduce-emap

    abstract
      QuotWordRel-reduce : ∀ w
        → QuotWordRel w (fst (reduce w))
      QuotWordRel-reduce nil = qwr-refl idp
      QuotWordRel-reduce (x :: w) =
        qwr-trans (qwr-cons x (QuotWordRel-reduce w)) $
        uncurry (QuotWordRel-cons x) (reduce w)

      to-from : ∀ qw → to (from qw) == qw
      to-from = QuotWord-elim
        (λ w → ! $ quot-rel $ QuotWordRel-reduce w)
        (λ _ → prop-has-all-paths-↓)

      from-to : ∀ rw → from (to rw) == rw
      from-to = Group.unit-r ReducedWord-group

  ReducedWord-iso-FreeGroup : ReducedWord-group ≃ᴳ FreeGroup A
  ReducedWord-iso-FreeGroup = ReducedWord-to-FreeGroup , is-eq to from to-from from-to


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

open import Fragment.Algebra.Signature

module Fragment.Algebra.Free.Monad (Σ : Signature) where

open import Fragment.Algebra.Free.Base Σ
open import Fragment.Algebra.Algebra Σ
open import Fragment.Algebra.Homomorphism Σ using (_⟿_; Congruent; Homomorphic)
open import Fragment.Setoid.Morphism

open import Level using (Level)

open import Data.Vec using (Vec; []; _∷_; map)
open import Data.Vec.Relation.Binary.Pointwise.Inductive
  using (Pointwise; []; _∷_)

open import Relation.Binary using (Setoid)

private
  variable
    a b ℓ₁ ℓ₂ : Level

unit : ∀ {S : Setoid a ℓ₁} → S ↝ Herbrand S
unit = record { ∣_∣      = atom
              ; ∣_∣-cong = atom
              }

module _
  {A : Setoid a ℓ₁}
  {B : Setoid b ℓ₂}
  (f : A ↝ Herbrand B)
  where

  private

    open Setoid ∥ Free B ∥/≈

    module _ {A : Set a} {B : Set b} where

      mutual
        map-∣bind∣ : ∀ {n} → (A → Term B)
                 → Vec (Term A) n → Vec (Term B) n
        map-∣bind∣ f []       = []
        map-∣bind∣ f (x ∷ xs) = ∣bind∣ f x ∷ map-∣bind∣ f xs

        ∣bind∣ : (A → Term B) → Term A → Term B
        ∣bind∣ f (atom x)     = f x
        ∣bind∣ f (term op xs) = term op (map-∣bind∣ f xs)

    mutual
      map-∣bind∣-cong : ∀ {n} {xs ys : Vec ∥ Free A ∥ n}
                        → Pointwise (_~_ A) xs ys
                        → Pointwise (_~_ B) (map-∣bind∣ ∣ f ∣ xs)
                                            (map-∣bind∣ ∣ f ∣ ys)
      map-∣bind∣-cong []       = []
      map-∣bind∣-cong (p ∷ ps) = ∣bind∣-cong p ∷ map-∣bind∣-cong ps

      ∣bind∣-cong : Congruent (_~_ A) (_~_ B) (∣bind∣ ∣ f ∣)
      ∣bind∣-cong (atom p)                 = ∣ f ∣-cong p
      ∣bind∣-cong {x = term op _} (term p) = term (map-∣bind∣-cong p)

    map-∣bind∣≡map : ∀ {n} {xs : Vec ∥ Free A ∥ n}
                     → Pointwise (_~_ B) (map-∣bind∣ ∣ f ∣ xs)
                                         (map (∣bind∣ ∣ f ∣) xs)
    map-∣bind∣≡map {xs = []}     = []
    map-∣bind∣≡map {xs = x ∷ xs} = refl ∷ map-∣bind∣≡map

    ∣bind∣-hom : Homomorphic (Free A) (Free B) (∣bind∣ ∣ f ∣)
    ∣bind∣-hom op []       = refl
    ∣bind∣-hom op (x ∷ xs) = sym (term (map-∣bind∣≡map {xs = x ∷ xs}))

    ∣bind∣⃗ : Herbrand A ↝ Herbrand B
    ∣bind∣⃗ = record { ∣_∣      = ∣bind∣ ∣ f ∣
                     ; ∣_∣-cong = ∣bind∣-cong
                     }

  bind : Free A ⟿ Free B
  bind = record { ∣_∣⃗    = ∣bind∣⃗
                ; ∣_∣-hom = ∣bind∣-hom
                }

fmap : ∀ {A : Setoid a ℓ₁} {B : Setoid b ℓ₂}
       → A ↝ B
       → Free A ⟿ Free B
fmap f = bind (unit · f)

join : ∀ {A : Setoid a ℓ₁} → Free (Herbrand A) ⟿ Free A
join = bind id


module FixityOutOfScopeInRecord where

record R : Set where
  infixl 30 _+_


module Subst where

open import Prelude
open import Lambda

infix 100 _[_] _[_:=_] _↑
infixl 100 _↑_ _↑ˢ_ _↑ˣ_ _↓ˣ_
infixl 60 _-_

{-
_-_ : {τ : Type}(Γ : Ctx) -> Var Γ τ -> Ctx
ε     - ()
Γ , τ - vz   = Γ
Γ , τ - vs x = (Γ - x) , τ

wkˣ : {Γ : Ctx}{σ τ : Type}
      (x : Var Γ σ) -> Var (Γ - x) τ -> Var Γ τ
wkˣ vz     y      = vs y
wkˣ (vs x) vz     = vz
wkˣ (vs x) (vs y) = vs (wkˣ x y)

wk : {Γ : Ctx}{σ τ : Type}
     (x : Var Γ σ) -> Term (Γ - x) τ -> Term Γ τ
wk x (var y) = var (wkˣ x y)
wk x (s • t) = wk x s • wk x t
wk x (ƛ t)   = ƛ wk (vs x) t

_↑ : {Γ : Ctx}{σ τ : Type} -> Term Γ τ -> Term (Γ , σ) τ
t ↑ = wk vz t

_↑_ : {Γ : Ctx}{τ : Type} -> Term Γ τ -> (Δ : Ctx) -> Term (Γ ++ Δ) τ
t ↑ ε       = t
t ↑ (Δ , σ) = (t ↑ Δ) ↑

data Cmpˣ {Γ : Ctx}{τ : Type}(x : Var Γ τ) :
          {σ : Type} -> Var Γ σ -> Set where
  same : Cmpˣ x x
  diff : {σ : Type}(y : Var (Γ - x) σ) -> Cmpˣ x (wkˣ x y)

_≟_ : {Γ : Ctx}{σ τ : Type}(x : Var Γ σ)(y : Var Γ τ) -> Cmpˣ x y
vz   ≟ vz   = same
vz   ≟ vs y = diff y
vs x ≟ vz   = diff vz
vs x ≟ vs y with x ≟ y
vs x ≟ vs .x         | same   = same
vs x ≟ vs .(wkˣ x y) | diff y = diff (vs y)

_[_:=_] : {Γ : Ctx}{σ τ : Type} ->
         Term Γ σ -> (x : Var Γ τ) -> Term (Γ - x) τ ->
         Term (Γ - x) σ
var y   [ x := u ] with x ≟ y
var .x         [ x := u ] | same = u
var .(wkˣ x y) [ x := u ] | diff y = var y
(s • t) [ x := u ] = s [ x := u ] • t [ x := u ]
(ƛ t)   [ x := u ] = ƛ t [ vs x := u ↑ ]
-}

infix 30 _─⟶_
infixl 90 _/_

_─⟶_ : Ctx -> Ctx -> Set
Γ ─⟶ Δ = Terms Γ Δ

idS : forall {Γ} -> Γ ─⟶ Γ
idS = tabulate var

infixr 80 _∘ˢ_

[_] : forall {Γ σ  } -> Term Γ σ -> Γ ─⟶ Γ , σ
[ t ] = idS ◄ t

wkS : forall {Γ Δ τ} -> Γ ─⟶ Δ -> Γ , τ ─⟶ Δ
wkS ∅       = ∅
wkS (θ ◄ t) = wkS θ ◄ wk t

_↑ : forall {Γ Δ τ} -> (Γ ─⟶ Δ) -> Γ , τ ─⟶ Δ , τ
θ ↑ = wkS θ ◄ vz

_/_ : forall {Γ Δ τ} -> Term Δ τ -> Γ ─⟶ Δ -> Term Γ τ
vz      / (θ ◄ u) = u
wk t    / (θ ◄ u) = t / θ
(s • t) / θ       = s / θ • t / θ
(ƛ t)   / θ       = ƛ t / θ ↑

_∘ˢ_ : forall {Γ Δ Θ} -> Δ ─⟶ Θ -> Γ ─⟶ Δ -> Γ ─⟶ Θ
∅       ∘ˢ θ = ∅
(δ ◄ t) ∘ˢ θ = δ ∘ˢ θ ◄ t / θ

inj : forall {Γ Δ τ} Θ -> Term Γ τ -> Γ ─⟶ Δ ++ Θ -> Γ ─⟶ Δ , τ ++ Θ
inj ε       t θ       = θ ◄ t
inj (Θ , σ) t (θ ◄ u) = inj Θ t θ ◄ u

[_⟵_] : forall {Γ τ} Δ -> Term (Γ ++ Δ) τ -> Γ ++ Δ ─⟶ Γ , τ ++ Δ
[ Δ ⟵ t ] = inj Δ t idS

_↑_ : forall {Γ σ} -> Term Γ σ -> (Δ : Ctx) -> Term (Γ ++ Δ) σ
t ↑ ε       = t
t ↑ (Δ , τ) = wk (t ↑ Δ)

_↑ˢ_ : forall {Γ Δ} -> Terms Γ Δ -> (Θ : Ctx) -> Terms (Γ ++ Θ) Δ
∅        ↑ˢ Θ = ∅
(ts ◄ t) ↑ˢ Θ = ts ↑ˢ Θ ◄ t ↑ Θ

_↑ˣ_ : forall {Γ τ} -> Var Γ τ -> (Δ : Ctx) -> Var (Γ ++ Δ) τ
x ↑ˣ ε       = x
x ↑ˣ (Δ , σ) = vsuc (x ↑ˣ Δ)

lem-var-↑ˣ : forall {Γ τ}(x : Var Γ τ)(Δ : Ctx) ->
             var (x ↑ˣ Δ) ≡ var x ↑ Δ
lem-var-↑ˣ x ε       = refl
lem-var-↑ˣ x (Δ , σ) = cong wk (lem-var-↑ˣ x Δ)

{- Not true!
lem-•-↑ : forall {Γ σ τ}(t : Term Γ (σ ⟶ τ))(u : Term Γ σ) Δ ->
          (t ↑ Δ) • (u ↑ Δ) ≡ (t • u) ↑ Δ
lem-•-↑ t u ε       = refl
lem-•-↑ t u (Δ , δ) = {! !}

lem-•ˢ-↑ : forall {Γ Θ τ}(t : Term Γ (Θ ⇒ τ))(ts : Terms Γ Θ) Δ ->
           (t ↑ Δ) •ˢ (ts ↑ˢ Δ) ≡ (t •ˢ ts) ↑ Δ
lem-•ˢ-↑ t ∅        Δ = refl
lem-•ˢ-↑ t (u ◄ us) Δ = {! !}
-}

{-
_[_] : {Γ : Ctx}{σ τ : Type} ->
       Term (Γ , τ) σ -> Term Γ τ -> Term Γ σ
t [ u ] = t / [ u ]
-}

{-
vz      [ u ] = u
wk t    [ u ] = {! !}
(s • t) [ u ] = {! !}
(ƛ_ {τ = ρ} t)   [ u ] = ƛ {! !}
-}

{-
_↓ˣ_ : {Γ : Ctx}{σ τ : Type}
       (y : Var Γ σ)(x : Var (Γ - y) τ) -> Var (Γ - wkˣ y x) σ
vz   ↓ˣ x    = vz
vs y ↓ˣ vz   = y
vs y ↓ˣ vs x = vs (y ↓ˣ x)

lem-commute-minus :
  {Γ : Ctx}{σ τ : Type}(y : Var Γ σ)(x : Var (Γ - y) τ) ->
  Γ - y - x ≡ Γ - wkˣ y x - (y ↓ˣ x)
lem-commute-minus vz     x      = refl
lem-commute-minus (vs y) vz     = refl
lem-commute-minus (vs {Γ} y) (vs x) with Γ - y - x | lem-commute-minus y x
... | ._ | refl = refl

Lem-wk-[] :
      {Γ : Ctx}{τ σ ρ : Type}
      (y : Var Γ τ)
      (x : Var (Γ - y) σ)
      (t : Term (Γ - wkˣ y x) ρ)
      (u : Term (Γ - y - x) τ) -> Set
Lem-wk-[] {Γ}{τ}{σ}{ρ} y x t u =
    wk (wkˣ y x) t [ y := wk x u ]
    ≡ wk x t[u']'
  where
    u' : Term (Γ - wkˣ y x - y ↓ˣ x) τ
    u' = subst (\Δ -> Term Δ τ) (sym (lem-commute-minus y x)) u

    t[u']' : Term (Γ - y - x) ρ
    t[u']' = subst (\Δ -> Term Δ ρ) (lem-commute-minus y x)
             (t [ y ↓ˣ x := u' ])

postulate
 lem-wk-[] : {Γ : Ctx}{σ τ ρ : Type}
             (y : Var Γ τ)(x : Var (Γ - y) σ)
             (t : Term (Γ - wkˣ y x) ρ){u : Term (Γ - y - x) τ} ->
             Lem-wk-[] y x t u
{-
lem-wk-[] y x (var z) = {! !}
lem-wk-[] y x (t • u) = {! !}
lem-wk-[] y x (ƛ t)   = {! !}
-}

lem-wk-[]' : {Γ : Ctx}{σ τ ρ : Type}
            (x : Var Γ σ)(t : Term (Γ - x , ρ) τ){u : Term (Γ - x) ρ} ->
            wk x (t [ vz := u ]) ≡ wk (vs x) t [ vz := wk x u ]
lem-wk-[]' x t = sym (lem-wk-[] vz x t)

-}