{-# OPTIONS --cubical --safe #-}
module Cubical.Data.Graph.Examples where

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

open import Cubical.Data.Empty
open import Cubical.Data.Unit renaming (Unit to ⊤)
open import Cubical.Data.Nat
open import Cubical.Data.SumFin
open import Cubical.Relation.Nullary

open import Cubical.Data.Sum
open import Cubical.Data.Prod

open import Cubical.Data.Graph.Base

-- Some small graphs of common shape

⇒⇐ : Graph ℓ-zero ℓ-zero
Obj ⇒⇐ = Fin 3
Hom ⇒⇐ fzero               (fsuc fzero) = ⊤
Hom ⇒⇐ (fsuc (fsuc fzero)) (fsuc fzero) = ⊤
Hom ⇒⇐ _ _ = ⊥

⇐⇒ : Graph ℓ-zero ℓ-zero
Obj ⇐⇒ = Fin 3
Hom ⇐⇒ (fsuc fzero) fzero               = ⊤
Hom ⇐⇒ (fsuc fzero) (fsuc (fsuc fzero)) = ⊤
Hom ⇐⇒ _ _ = ⊥

-- paralell pair graph
⇉ : Graph ℓ-zero ℓ-zero
Obj ⇉ = Fin 2
Hom ⇉ fzero (fsuc fzero) = Fin 2
Hom ⇉ _ _ = ⊥

-- The graph ω = 0 → 1 → 2 → ···

data Adj : ℕ → ℕ → Type₀ where
  adj : ∀ n → Adj n (suc n)

areAdj : ∀ m n → Dec (Adj m n)
areAdj zero zero          = no λ ()
areAdj zero (suc zero)    = yes (adj zero)
areAdj zero (suc (suc n)) = no λ ()
areAdj (suc m) zero       = no λ ()
areAdj (suc m) (suc n)    = mapDec (λ { (adj .m) → adj (suc m) })
                                   (λ { ¬a (adj .(suc m)) → ¬a (adj m) })
                                   (areAdj m n)

ωGr : Graph ℓ-zero ℓ-zero
Obj ωGr = ℕ
Hom ωGr m n with areAdj m n
... | yes _ = ⊤ -- if n ≡ (suc m)
... | no  _ = ⊥ -- otherwise

record ωDiag ℓ : Type (ℓ-suc ℓ) where
  field
    ωObj : ℕ → Type ℓ
    ωHom : ∀ n → ωObj n → ωObj (suc n)

  asDiag : Diag ℓ ωGr
  asDiag $ n = ωObj n
  _<$>_ asDiag {m} {n} f with areAdj m n
  asDiag <$> tt | yes (adj m) = ωHom m

-- The finite connected subgraphs of ω: 𝟘,𝟙,𝟚,𝟛,...

data AdjFin : ∀ {k} → Fin k → Fin k → Type₀ where
  adj : ∀ {k} (n : Fin k) → AdjFin (finj n) (fsuc n)

adj-fsuc : ∀ {k} {m n : Fin k} → AdjFin (fsuc m) (fsuc n) → AdjFin m n
adj-fsuc {suc k} {.(finj n)} {fsuc n} (adj .(fsuc n)) = adj n

areAdjFin : ∀ {k} (m n : Fin k) → Dec (AdjFin m n)
areAdjFin {suc k}       fzero fzero           = no λ ()
areAdjFin {suc (suc k)} fzero (fsuc fzero)    = yes (adj fzero)
areAdjFin {suc (suc k)} fzero (fsuc (fsuc n)) = no λ ()
areAdjFin {suc k}       (fsuc m) fzero        = no λ ()
areAdjFin {suc k}       (fsuc m) (fsuc n)     = mapDec (λ { (adj m) → adj (fsuc m) })
                                                       (λ { ¬a a → ¬a (adj-fsuc a) })
                                                       (areAdjFin {k} m n)

[_]Gr : ℕ → Graph ℓ-zero ℓ-zero
Obj [ k ]Gr = Fin k
Hom [ k ]Gr m n with areAdjFin m n
... | yes _ = ⊤ -- if n ≡ (suc m)
... | no  _ = ⊥ -- otherwise

𝟘Gr 𝟙Gr 𝟚Gr 𝟛Gr : Graph ℓ-zero ℓ-zero
𝟘Gr = [ 0 ]Gr; 𝟙Gr = [ 1 ]Gr; 𝟚Gr = [ 2 ]Gr; 𝟛Gr = [ 3 ]Gr

record [_]Diag ℓ (k : ℕ) : Type (ℓ-suc ℓ) where
  field
    []Obj : Fin (suc k) → Type ℓ
    []Hom : ∀ (n : Fin k) → []Obj (finj n) → []Obj (fsuc n)

  asDiag : Diag ℓ [ suc k ]Gr
  asDiag $ n = []Obj n
  _<$>_ asDiag {m} {n} f with areAdjFin m n
  _<$>_ asDiag {.(finj n)} {fsuc n} f | yes (adj .n) = []Hom n

-- Disjoint union of graphs

module _ {ℓv ℓe ℓv' ℓe'} where

  _⊎Gr_ : ∀ (G : Graph ℓv ℓe) (G' : Graph ℓv' ℓe') → Graph (ℓ-max ℓv ℓv') (ℓ-max ℓe ℓe')
  Obj (G ⊎Gr G') = Obj G ⊎ Obj G'
  Hom (G ⊎Gr G') (inl x) (inl y) = Lift {j = ℓe'} (Hom G x y)
  Hom (G ⊎Gr G') (inr x) (inr y) = Lift {j = ℓe } (Hom G' x y)
  Hom (G ⊎Gr G') _ _ = Lift ⊥

  record ⊎Diag ℓ (G : Graph ℓv ℓe) (G' : Graph ℓv' ℓe')
               : Type (ℓ-max (ℓ-suc ℓ) (ℓ-max (ℓ-max ℓv ℓv') (ℓ-max ℓe ℓe'))) where
    field
      ⊎Obj : Obj G ⊎ Obj G' → Type ℓ
      ⊎Homl : ∀ {x y} → Hom G  x y → ⊎Obj (inl x) → ⊎Obj (inl y)
      ⊎Homr : ∀ {x y} → Hom G' x y → ⊎Obj (inr x) → ⊎Obj (inr y)

    asDiag : Diag ℓ (G ⊎Gr G')
    asDiag $ x = ⊎Obj x
    _<$>_ asDiag {inl x} {inl y} f = ⊎Homl (lower f)
    _<$>_ asDiag {inr x} {inr y} f = ⊎Homr (lower f)

-- Cartesian product of graphs

module _ {ℓv ℓe ℓv' ℓe'} where

  -- We need decidable equality in order to define the cartesian product
  DecGraph : ∀ ℓv ℓe → Type (ℓ-suc (ℓ-max ℓv ℓe))
  DecGraph ℓv ℓe = Σ[ G ∈ Graph ℓv ℓe ] Discrete (Obj G)

  _×Gr_ : (G : DecGraph ℓv ℓe) (G' : DecGraph ℓv' ℓe') → Graph (ℓ-max ℓv ℓv') (ℓ-max ℓe ℓe')
  Obj (G ×Gr G') = Obj (fst G) × Obj (fst G')
  Hom (G ×Gr G') (x , x') (y , y') with snd G x y | snd G' x' y'
  ... | yes _ | yes _ = Hom (fst G) x y ⊎ Hom (fst G') x' y'
  ... | yes _ | no  _ = Lift {j = ℓe } (Hom (fst G') x' y')
  ... | no  _ | yes _ = Lift {j = ℓe'} (Hom (fst G) x y)
  ... | no  _ | no  _ = Lift ⊥

  record ×Diag ℓ (G : DecGraph ℓv ℓe) (G' : DecGraph ℓv' ℓe')
               : Type (ℓ-max (ℓ-suc ℓ) (ℓ-max (ℓ-max ℓv ℓv') (ℓ-max ℓe ℓe'))) where
    field
      ×Obj : Obj (fst G) × Obj (fst G') → Type ℓ
      ×Hom₁ : ∀ {x y} (f : Hom (fst G) x y) (x' : Obj (fst G'))    → ×Obj (x , x') → ×Obj (y , x')
      ×Hom₂ : ∀ (x : Obj (fst G)) {x' y'} (f : Hom (fst G') x' y') → ×Obj (x , x') → ×Obj (x , y')

    asDiag : Diag ℓ (G ×Gr G')
    asDiag $ x = ×Obj x
    _<$>_ asDiag {x , x'} {y , y'} f with snd G x y | snd G' x' y'
    _<$>_ asDiag {x , x'} {y , y'} (inl f) | yes _ | yes p' = subst _ p' (×Hom₁ f x')
    _<$>_ asDiag {x , x'} {y , y'} (inr f) | yes p | yes _  = subst _ p  (×Hom₂ x f )
    _<$>_ asDiag {x , x'} {y , y'} f | yes p | no  _  = subst _ p  (×Hom₂ x (lower f) )
    _<$>_ asDiag {x , x'} {y , y'} f | no  _ | yes p' = subst _ p' (×Hom₁ (lower f) x')


module FFI where

open import Common.Prelude

_+'_ : Nat → Nat → Nat
zero +' y = y
suc x +' y = suc (x +' y)
{-# COMPILE GHC _+'_ = (+) :: Integer -> Integer -> Integer #-}

-- on-purpose buggy haskell implementation!
_+''_ : Nat → Nat → Nat
zero +'' y = y
suc x +'' y = suc (x +'' y)
{-# COMPILE GHC _+''_ = (-) :: Integer -> Integer -> Integer #-}

open import Common.IO
open import Common.Unit

main : IO Unit
main = printNat (10 +' 5) ,,
  printNat (30 +'' 7)


open import Prelude
open import core
open import contexts
open import weakening

module typed-expansion where
  mutual
    typed-expansion-synth : ∀{Φ Γ p e τ} →
                                      Φ , Γ ⊢ p ~~> e ⇒ τ →
                                      Γ ⊢ e => τ
    typed-expansion-synth SPEConst = SConst
    typed-expansion-synth (SPEAsc x) = SAsc (typed-expansion-ana x)
    typed-expansion-synth (SPEVar x₁) = SVar x₁
    typed-expansion-synth (SPELam x₁ D) = SLam x₁ (typed-expansion-synth D)
    typed-expansion-synth (SPEAp D1 x D2 x₂) = SAp x₂ (typed-expansion-synth D1) x (typed-expansion-ana D2)
    typed-expansion-synth SPEHole = SEHole
    typed-expansion-synth (SPNEHole x D) = SNEHole x (typed-expansion-synth D)
    typed-expansion-synth (SPEApLivelit hd fr x x₁ x₂ x₃ x₄ x₅) = SAp (HDAsc hd) (SAsc (weaken-ana-closed fr x₅)) MAArr (typed-expansion-ana x₄)
    typed-expansion-synth (SPEFst h x) = SFst (typed-expansion-synth h) x
    typed-expansion-synth (SPESnd h x) = SSnd (typed-expansion-synth h) x
    typed-expansion-synth (SPEPair h h₁ x) = SPair x (typed-expansion-synth h) (typed-expansion-synth h₁)

    typed-expansion-ana : ∀{Φ Γ p e τ} →
                                  Φ , Γ ⊢ p ~~> e ⇐ τ →
                                  Γ ⊢ e <= τ
    typed-expansion-ana (APELam x₁ x₂ D) = ALam x₁ x₂ (typed-expansion-ana D)
    typed-expansion-ana (APESubsume h ch) = ASubsume (typed-expansion-synth h) ch


module Data.Bin.Minus where

  open import Data.Bin hiding (suc; fromℕ)
  open Data.Bin using (2+_)
  open import Data.Bin.Bijection using (fromℕ)
  open import Data.Fin hiding (_-_; _+_; toℕ; _<_; fromℕ)
  open import Data.List
  open import Data.Digit
  open import Relation.Binary.PropositionalEquality
  open import Data.Nat using (ℕ; _∸_; suc; zero) renaming (_+_ to _ℕ+_)

  infixl 6 _-?_
  infixl 6 _-_

  open import Function

  pred' : Bin → Bin
  pred' 0# = 0#
  pred' ([] 1#) = 0#
  pred' ((zero ∷ t) 1#) = case Data.Bin.pred t of
    λ {
      0# → [] 1# ;
      (t' 1#) → (suc zero ∷ t') 1#
    }
  pred' ((suc zero ∷ t) 1#) = (zero ∷ t) 1#
  pred' ((suc (suc ()) ∷ _) 1#)

  open import Data.Sum
  open import Data.Unit
  import Data.Nat.Properties

  data Greater (a b : Bin) : Set where
   greater : ∀ (diff : Bin⁺) → b + diff 1# ≡ a → Greater a b

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

  import Data.Bin.Addition
  open import Data.Bin.Props

  greater-to-< : ∀ a b → Greater a b → b < a
  greater-to-< ._ b (greater diff refl) =
    let
      zz = Data.Nat.Properties.+-mono-≤
        {1} {toℕ (diff 1#)} {toℕ b} {toℕ b}
        (case z<nz diff of λ { (Data.Bin.less p) → p })
        Data.Nat.Properties.≤-refl
    in
     Data.Bin.less (Data.Nat.Properties.≤-trans zz (
       Data.Nat.Properties.≤-reflexive (
         trans
           (sym (Data.Nat.Properties.+-comm (toℕ b) _))
           (sym (Data.Bin.Addition.+-is-addition b (diff 1#)))
           )))

  open import Data.Product

  data Difference (a b : Bin) : Set where
    positive : Greater a b → Difference a b
    negative : Greater b a → Difference a b
    equal : a ≡ b → Difference a b

  open import Relation.Nullary

  open import Algebra.Structures

  import Data.Bin.Addition
  open IsCommutativeMonoid Data.Bin.Addition.is-commutativeMonoid
    using (identity; identityˡ)
    renaming (comm to +-comm; assoc to +-assoc)

  open import Data.Product
  identityʳ = proj₂ identity

  ∷-pred : Bit → Bin⁺ → Bin⁺
  ∷-pred zero [] = []
  ∷-pred zero (h ∷ t) = suc zero ∷ ∷-pred h t
  ∷-pred (suc zero) l = zero ∷ l
  ∷-pred (suc (suc ())) l

  open Relation.Binary.PropositionalEquality.≡-Reasoning

  open import Data.Bin.Multiplication using (∷1#-interpretation)

  open import Function using (_⟨_⟩_)

  seems-trivial : ∀ xs → (zero ∷ xs) 1# + [] 1# ≡ (suc zero ∷ xs) 1#
  seems-trivial xs = cong (λ q → q + [] 1#) (∷1#-interpretation zero xs ⟨ trans ⟩ (identityˡ (xs 1# *2))) ⟨ trans ⟩ +-comm (xs 1# *2) ([] 1#) ⟨ trans ⟩ sym (∷1#-interpretation (suc zero) xs)

  open import Data.Bin.Props

  carry : ∀ t → [] 1# + (suc zero ∷ t) 1# ≡ ([] 1# + t 1#) *2
  carry t =
   begin
    [] 1# + (suc zero ∷ t) 1#
     ≡⟨ cong (_+_ ([] 1#)) (∷1#-interpretation (suc zero) t) ⟩
    [] 1# + ([] 1# + t 1# *2)
     ≡⟨ sym (+-assoc ([] 1#) ([] 1#) (t 1# *2)) ⟩
    [] 1# *2 + (t 1# *2)
     ≡⟨ sym (*2-distrib ([] 1#) (t 1#)) ⟩
    ([] 1# + t 1#) *2
   ∎

  1+∷-pred : ∀ h t → [] 1# + (∷-pred h t) 1# ≡ (h ∷ t) 1#
  1+∷-pred zero [] = refl
  1+∷-pred zero (x ∷ xs) =
   begin
    [] 1# + (suc zero ∷ ∷-pred x xs) 1#
     ≡⟨ carry (∷-pred x xs) ⟩
    ([] 1# + (∷-pred x xs) 1#) *2
     ≡⟨ cong _*2 (1+∷-pred x xs) ⟩
    (x ∷ xs) 1# *2
     ≡⟨ refl ⟩
    (zero ∷ x ∷ xs) 1#
   ∎
  1+∷-pred (suc zero) t = +-comm ([] 1#) ((zero ∷ t) 1#) ⟨ trans ⟩ seems-trivial t
  1+∷-pred (suc (suc ())) t

  data Comparison (A : Set) : Set where
    greater : A → Comparison A
    equal : Comparison A
    less : A → Comparison A

  map-cmp : {A B : Set} → (A → B) → Comparison A → Comparison B
  map-cmp f (greater a) = greater (f a)
  map-cmp f (less a) = less (f a)
  map-cmp f equal = equal

  _%f_ : ∀ {b} → Fin (suc b) → Fin (suc b) → Comparison (Fin b)
  zero %f zero = equal
  zero %f suc b = less b
  suc a %f zero = greater a
  _%f_ {suc base} (suc a) (suc b) = map-cmp inject₁ (a %f b)
  _%f_ {zero} (suc ()) (suc ())

  _*2-1 : Bin⁺ → Bin⁺
  [] *2-1 = []
  (suc zero ∷ t) *2-1 = suc zero ∷ zero ∷ t
  (zero ∷ t) *2-1 = suc zero ∷ (t *2-1)
  (suc (suc ()) ∷ t) *2-1

  _*2+1' : Bin⁺ → Bin⁺
  l *2+1' = suc zero ∷ l

  addBit : Bin⁺ → Comparison (Fin 1) → Bin⁺
  addBit gt (greater zero) = gt *2+1'
  addBit gt equal = zero ∷ gt
  addBit gt (less zero) = gt *2-1
  addBit gt (less (suc ()))
  addBit gt (greater (suc ()))

  open import Data.Bin.Utils

  *2-1-lem : ∀ d → (d *2-1) 1# + [] 1# ≡ d 1# *2
  *2-1-lem [] = refl
  *2-1-lem (zero ∷ xs) =
   begin
    (zero ∷ xs) *2-1 1# + [] 1#
     ≡⟨ refl ⟩
    (suc zero ∷ (xs *2-1)) 1# + [] 1#
     ≡⟨ +-comm ((suc zero ∷ xs *2-1) 1#) ([] 1#)  ⟩
    [] 1# + (suc zero ∷ (xs *2-1)) 1#
     ≡⟨ carry (xs *2-1) ⟩
    ([] 1# + (xs *2-1) 1#) *2
     ≡⟨ cong _*2 (+-comm ([] 1#) ((xs *2-1) 1#)) ⟩
    ((xs *2-1) 1# + [] 1#) *2
     ≡⟨ cong _*2 (*2-1-lem xs) ⟩
    (xs 1# *2) *2
     ≡⟨ refl ⟩
    (zero ∷ xs) 1# *2
   ∎
  *2-1-lem (suc zero ∷ xs) =
   begin
    (suc zero ∷ zero ∷ xs) 1# + [] 1#
     ≡⟨ cong (λ q → q + [] 1#) (∷1#-interpretation (suc zero) (zero ∷ xs)) ⟩
    [] 1# + (zero ∷ xs) 1# *2 + [] 1#
     ≡⟨ refl ⟩
    [] 1# + xs 1# *2 *2 + [] 1#
     ≡⟨ +-comm ([] 1# + xs 1# *2 *2) ([] 1#) ⟩
    [] 1# + ([] 1# + xs 1# *2 *2)
     ≡⟨ sym (+-assoc ([] 1#) ([] 1#) (xs 1# *2 *2)) ⟩
    [] 1# *2 + xs 1# *2 *2
     ≡⟨ sym (*2-distrib ([] 1#) (xs 1# *2)) ⟩
    ([] 1# + xs 1# *2) *2
     ≡⟨ cong _*2 (sym (∷1#-interpretation (suc zero) xs)) ⟩
    (suc zero ∷ xs) 1# *2
     ≡⟨ refl ⟩
    (zero ∷ suc zero ∷ xs) 1#
   ∎
  *2-1-lem (suc (suc ()) ∷ xs)

  addBit-lem : ∀ x y d → addBit d (x %f y) 1# + bitToBin y ≡ d 1# *2 + bitToBin x
  addBit-lem zero zero d = refl
  addBit-lem (suc zero) zero d = refl
  addBit-lem zero (suc zero) d = *2-1-lem d ⟨ trans ⟩ sym (identityʳ (d 1# *2))
  addBit-lem (suc zero) (suc zero) d = refl
  addBit-lem (suc (suc ())) _ d
  addBit-lem _ (suc (suc ())) d

  +-cong₁ : ∀ {z} {x y} → x ≡ y → x + z ≡ y + z
  +-cong₁ {z} = cong (λ q → q + z)

  +-cong₂ : ∀ {z} {x y} → x ≡ y → z + x ≡ z + y
  +-cong₂ {z} = cong (λ q → z + q)

  refineGt : ∀ xs ys (x y : Bit) → Greater (xs 1#) (ys 1#) → Greater ((x ∷ xs) 1#) ((y ∷ ys) 1#)
  refineGt xs ys x y (greater d ys+d=xs) = greater (addBit d (x %f y)) good where
    good : (y ∷ ys) 1# + addBit d (x %f y) 1# ≡ (x ∷ xs) 1#
    good =
     begin
      (y ∷ ys) 1# + addBit d (x %f y) 1#
       ≡⟨ +-cong₁ {addBit d (x %f y) 1#} (∷1#-interpretation y ys) ⟩
      bitToBin y + (ys 1#) *2 + addBit d (x %f y) 1#
       ≡⟨ +-comm (bitToBin y + (ys 1#) *2) (addBit d (x %f y) 1#) ⟩
      addBit d (x %f y) 1# + (bitToBin y + (ys 1#) *2)
       ≡⟨ sym (+-assoc (addBit d (x %f y) 1#) (bitToBin y) ((ys 1#) *2)) ⟩
      (addBit d (x %f y) 1# + bitToBin y) + (ys 1#) *2
       ≡⟨ +-cong₁ {(ys 1#) *2} (addBit-lem x y d) ⟩
      (d 1# *2 + bitToBin x) + (ys 1#) *2
       ≡⟨ +-cong₁ {(ys 1#) *2} (+-comm (d 1# *2) (bitToBin x)) ⟩
      (bitToBin x + d 1# *2 ) + (ys 1#) *2
       ≡⟨  +-assoc (bitToBin x) (d 1# *2) ((ys 1#) *2) ⟩
      bitToBin x + (d 1# *2 + (ys 1#) *2)
       ≡⟨ +-cong₂ {bitToBin x} (+-comm (d 1# *2) ((ys 1#) *2)) ⟩
      bitToBin x + ((ys 1#) *2 + d 1# *2)
       ≡⟨ +-cong₂ {bitToBin x} (sym (*2-distrib (ys 1#) (d 1#))) ⟩
      bitToBin x + (ys 1# + d 1#) *2
       ≡⟨ +-cong₂ {bitToBin x} (cong _*2 ys+d=xs) ⟩
      bitToBin x + xs 1# *2
       ≡⟨ sym (∷1#-interpretation x xs) ⟩
      (x ∷ xs) 1#
     ∎

  compare-bit : ∀ a b xs → Difference ((a ∷ xs) 1#) ((b ∷ xs) 1#)
  compare-bit 0b 0b xs = equal refl
  compare-bit 1b 0b xs = positive (greater [] (seems-trivial xs))
  compare-bit 0b 1b xs = negative (greater [] (seems-trivial xs))
  compare-bit 1b 1b xs = equal refl
  compare-bit (2+ ()) _ xs
  compare-bit _ (2+ ()) xs

  _-⁺_ : ∀ a b → Difference (a 1#) (b 1#)
  [] -⁺ [] = equal refl
  [] -⁺ (x ∷ xs) = negative (greater (∷-pred x xs) (1+∷-pred x xs))
  (x ∷ xs) -⁺ [] = positive (greater (∷-pred x xs) (1+∷-pred x xs))
  (x ∷ xs) -⁺ (y ∷ ys) =
    case xs -⁺ ys of
      λ {
        (positive gt) → positive (refineGt xs ys x y gt) ;
        (negative lt) → negative (refineGt ys xs y x lt) ;
        (equal refl) → compare-bit _ _ xs
     }

  _-?_ : ∀ a b → Difference a b
  0# -? 0# = equal refl
  a 1# -? 0# = positive (greater a (identityˡ (a 1#)))
  0# -? a 1# = negative (greater a (identityˡ (a 1#)))
  a 1# -? b 1# = a -⁺ b

  _%⁺_ : Bin⁺ → Bin⁺ → Comparison Bin⁺
  [] %⁺ [] = equal
  (h ∷ t) %⁺ [] = greater (∷-pred h t)
  [] %⁺ (h ∷ t) = less (∷-pred h t)
  (x ∷ xs) %⁺ (y ∷ ys) with xs %⁺ ys
  ... | greater gt = greater (addBit gt (x %f y))
  ... | less lt = less (addBit lt (y %f x))
  ... | equal = map-cmp (λ _ → []) (x %f y)

  succ : Bin⁺ → Bin⁺
  succ [] = zero ∷ []
  succ (zero ∷ t) = suc zero ∷ t
  succ (suc zero ∷ t) = zero ∷ succ t
  succ (suc (suc ()) ∷ t)

  succpred-id : ∀ x xs → succ (∷-pred x xs) ≡ x ∷ xs
  succpred-id zero [] = refl
  succpred-id zero (x ∷ xs) = cong (λ z → zero ∷ z) (succpred-id x xs)
  succpred-id (suc zero) xs = refl
  succpred-id (suc (suc ())) xs

  -- CR: difference-to-∸ : ∀ {a b} → Difference a b → Bin
  -- difference-to-bin

  _-_ : Bin → Bin → Bin
  x - y with x -? y
  ... | positive (greater d _) = d 1#
  ... | equal _ = 0#
  ... | negative _ = 0#

  open import Data.Bin.Bijection using (fromℕ-bijection; toℕ-inj; fromToℕ-inverse; fromℕ-inj)

  open import Data.Bin.Addition using (+-is-addition)

  suc-inj : ∀ {x y : ℕ} → Data.Nat.suc x ≡ suc y → x ≡ y
  suc-inj {x} .{x} refl = refl

  ℕ-+-inj₂ : ∀ z {a b} → Data.Nat._+_ z a ≡ Data.Nat._+_ z b → a ≡ b
  ℕ-+-inj₂ zero refl = refl
  ℕ-+-inj₂ (suc n) eq = ℕ-+-inj₂ n (suc-inj eq)

  +-inj₂ : ∀ z {a b} → z + a ≡ z + b → a ≡ b
  +-inj₂ z {a} {b} z+a≡z+b = toℕ-inj ( ℕ-+-inj₂ (toℕ z) (sym (+-is-addition z a) ⟨ trans ⟩ cong toℕ z+a≡z+b ⟨ trans ⟩ +-is-addition z b) )

  nat-+zz : ∀ a b → Data.Nat._+_ a b ≡ 0 → a ≡ 0
  nat-+zz zero b _ = refl
  nat-+zz (suc _) b ()

  +zz : ∀ a b → a + b ≡ 0# → a ≡ 0#
  +zz a b eq = toℕ-inj (nat-+zz (toℕ a) (toℕ b) (sym (+-is-addition a b) ⟨ trans ⟩ cong toℕ eq))

  minus-elim : ∀ x z → z + x - z ≡ x
  minus-elim x z with (z + x -? z)
  ... | positive (greater d z+d=z+x) = +-inj₂ z z+d=z+x
  ... | equal z+x≡z = +-inj₂ z (identityʳ z ⟨ trans ⟩ sym z+x≡z)
  ... | negative (greater d z+x+d≡z) = sym (+zz x (d 1#) (+-inj₂ z
         ( sym (+-assoc z x (d 1#)) ⟨ trans ⟩ z+x+d≡z ⟨ trans ⟩ sym (identityʳ z))))

  import Data.Bin.NatHelpers

  x≮z→x≡z+y : ∀ {x z} → ¬ x < z → ∃ λ y → x ≡ z + y
  x≮z→x≡z+y {x} {z} x≮z = case
    Data.Bin.NatHelpers.x≮z→x≡z+y (λ toℕ-leq → x≮z (less toℕ-leq))
    of λ { (y , eq) →  fromℕ y , toℕ-inj (
    begin
     toℕ x
      ≡⟨ eq ⟩
     toℕ z ℕ+ y
      ≡⟨ cong (λ q → toℕ z ℕ+ q) (fromℕ-inj (sym (fromToℕ-inverse (fromℕ y)))) ⟩
     toℕ z ℕ+ toℕ (fromℕ y)
      ≡⟨ sym (+-is-addition z (fromℕ y)) ⟩
     toℕ (z + fromℕ y)
    ∎) }

  -+-elim' : ∀ {x z} → ¬ x < z → x - z + z ≡ x
  -+-elim' {x} {z} x≮z = case x≮z→x≡z+y x≮z of
    λ { (y , refl) →
   begin
    z + y - z + z
     ≡⟨ cong (λ q → q + z) (minus-elim y z)⟩
    y + z
     ≡⟨ +-comm y z ⟩
    z + y
   ∎ }


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

open import HoTT
open import groups.ProductRepr
open import cohomology.Theory
open import homotopy.WedgeCofiber

{- For the cohomology group of a suspension ΣX, the group inverse has the
 - explicit form Cⁿ(flip-susp) : Cⁿ(ΣX) → Cⁿ(ΣX).
 -}

module cohomology.InverseInSusp {i} (CT : CohomologyTheory i)
  (n : ℤ) {X : Ptd i} where

open CohomologyTheory CT
open import cohomology.Wedge CT n

private
  module Subtract = SuspRec {C = de⊙ (⊙Susp X ⊙∨ ⊙Susp X)}
    (winl south)
    (winr south)
    (λ x → ap winl (! (merid x)) ∙ wglue ∙ ap winr (merid x))

  subtract = Subtract.f

  ⊙subtract : ⊙Susp X ⊙→ ⊙Susp X ⊙∨ ⊙Susp X
  ⊙subtract = (subtract , ! (ap winl (merid (pt X))))

  projl-subtract : ∀ σ → projl (subtract σ) == Susp-flip σ
  projl-subtract = Susp-elim idp idp $
    ↓-='-from-square ∘ vert-degen-square ∘ λ x →
      ap-∘ projl subtract (merid x)
      ∙ ap (ap projl) (Subtract.merid-β x)
      ∙ ap-∙ projl (ap winl (! (merid x))) (wglue ∙ ap winr (merid x))
      ∙ ((∘-ap projl winl (! (merid x))
          ∙ ap-idf _)
         ∙2 (ap-∙ projl wglue (ap winr (merid x))
             ∙ (Projl.glue-β
                ∙2 (∘-ap projl winr (merid x) ∙ ap-cst _ _))))
      ∙ ∙-unit-r _
      ∙ ! (SuspFlip.merid-β x)

  projr-subtract : ∀ σ → projr (subtract σ) == σ
  projr-subtract = Susp-elim idp idp $
    ↓-∘=idf-in' projr subtract ∘ λ x →
      ap (ap projr) (Subtract.merid-β x)
      ∙ ap-∙ projr (ap winl (! (merid x))) (wglue ∙ ap winr (merid x))
      ∙ ((∘-ap projr winl (! (merid x)) ∙ ap-cst _ _)
         ∙2 (ap-∙ projr wglue (ap winr (merid x))
             ∙ (Projr.glue-β
                ∙2 (∘-ap projr winr (merid x) ∙ ap-idf _))))

  fold-subtract : ∀ σ → fold (subtract σ) == south
  fold-subtract = Susp-elim idp idp $
    ↓-app=cst-in ∘ ! ∘ λ x →
      ∙-unit-r _
      ∙ ap-∘ fold subtract (merid x)
      ∙ ap (ap fold) (Subtract.merid-β x)
      ∙ ap-∙ fold (ap winl (! (merid x))) (wglue ∙ ap winr (merid x))
      ∙ ((∘-ap fold winl (! (merid x)) ∙ ap-idf _)
         ∙2 (ap-∙ fold wglue (ap winr (merid x))
             ∙ (Fold.glue-β
                ∙2 (∘-ap fold winr (merid x) ∙ ap-idf _))))
      ∙ !-inv-l (merid x)

  abstract
    cancel : ∀ x
      → GroupHom.f (×ᴳ-fanin (C-is-abelian n _) (C-fmap n (⊙Susp-flip X)) (idhom _)) (x , x)
      == Cident n (⊙Susp X)
    cancel x =
        ap2 (Group.comp (C n (⊙Susp X)))
          (! (CEl-fmap-base-indep n projl-subtract x))
          (! (CEl-fmap-idf n x) ∙ ! (CEl-fmap-base-indep n projr-subtract x))
      ∙ (C-Wedge-in-comm-sqr' (⊙Susp X) (⊙Susp X) ⊙subtract □$ᴳ (x , x))
      ∙ ap (CEl-fmap n ⊙subtract)
          ( ap (GroupIso.g (C-Wedge (⊙Susp X) (⊙Susp X)) ∘ diag) (! (CEl-fmap-idf n x))
          ∙ (C-Wedge-rec-comm-sqr' (⊙Susp X) (⊙Susp X) (⊙idf _) (⊙idf _) □$ᴳ x))
      ∙ ∘-CEl-fmap n ⊙subtract ⊙fold x
      ∙ CEl-fmap-base-indep n (λ σ → fold-subtract σ ∙ ! (merid (pt X))) x
      ∙ CEl-fmap-cst n x

abstract
  C-Susp-flip-is-inv : ∀ x → CEl-fmap n (⊙Susp-flip X) x == Group.inv (C n (⊙Susp X)) x
  C-Susp-flip-is-inv x = ! (Group.inv-unique-l (C n (⊙Susp X)) _ x (cancel x))


{-# OPTIONS --safe #-}
module Cubical.Algebra.AbGroup.Base where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Equiv
open import Cubical.Foundations.Equiv.HalfAdjoint
open import Cubical.Foundations.HLevels
open import Cubical.Foundations.Isomorphism
open import Cubical.Foundations.Univalence
open import Cubical.Foundations.Transport
open import Cubical.Foundations.SIP

open import Cubical.Data.Sigma
open import Cubical.Data.Unit

open import Cubical.Algebra.Semigroup
open import Cubical.Algebra.Monoid
open import Cubical.Algebra.CommMonoid
open import Cubical.Algebra.Group
open import Cubical.Algebra.Group.Morphisms
open import Cubical.Algebra.Group.MorphismProperties
open import Cubical.Algebra.Group.DirProd

open import Cubical.Displayed.Base
open import Cubical.Displayed.Auto
open import Cubical.Displayed.Record
open import Cubical.Displayed.Universe

open Iso

private
  variable
    ℓ ℓ' : Level

record IsAbGroup {G : Type ℓ}
                 (0g : G) (_+_ : G → G → G) (-_ : G → G) : Type ℓ where

  constructor isabgroup

  field
    isGroup : IsGroup 0g _+_ -_
    comm    : (x y : G) → x + y ≡ y + x

  open IsGroup isGroup public

record AbGroupStr (A : Type ℓ) : Type (ℓ-suc ℓ) where

  constructor abgroupstr

  field
    0g        : A
    _+_       : A → A → A
    -_        : A → A
    isAbGroup : IsAbGroup 0g _+_ -_

  infix  8 -_
  infixr 7 _+_

  open IsAbGroup isAbGroup public

AbGroup : ∀ ℓ → Type (ℓ-suc ℓ)
AbGroup ℓ = TypeWithStr ℓ AbGroupStr

makeIsAbGroup : {G : Type ℓ} {0g : G} {_+_ : G → G → G} { -_ : G → G}
              (is-setG : isSet G)
              (assoc   : (x y z : G) → x + (y + z) ≡ (x + y) + z)
              (rid     : (x : G) → x + 0g ≡ x)
              (rinv    : (x : G) → x + (- x) ≡ 0g)
              (comm    : (x y : G) → x + y ≡ y + x)
            → IsAbGroup 0g _+_ -_
makeIsAbGroup is-setG assoc rid rinv comm =
  isabgroup (makeIsGroup is-setG assoc rid (λ x → comm _ _ ∙ rid x) rinv (λ x → comm _ _ ∙ rinv x)) comm

makeAbGroup : {G : Type ℓ} (0g : G) (_+_ : G → G → G) (-_ : G → G)
            (is-setG : isSet G)
            (assoc : (x y z : G) → x + (y + z) ≡ (x + y) + z)
            (rid : (x : G) → x + 0g ≡ x)
            (rinv : (x : G) → x + (- x) ≡ 0g)
            (comm    : (x y : G) → x + y ≡ y + x)
          → AbGroup ℓ
makeAbGroup 0g _+_ -_ is-setG assoc rid rinv comm =
  _ , abgroupstr 0g _+_ -_ (makeIsAbGroup is-setG assoc rid rinv comm)

open GroupStr
open AbGroupStr
open IsAbGroup

AbGroupStr→GroupStr : {G : Type ℓ} → AbGroupStr G → GroupStr G
AbGroupStr→GroupStr A .1g = A .0g
AbGroupStr→GroupStr A ._·_ = A ._+_
AbGroupStr→GroupStr A .inv = A .-_
AbGroupStr→GroupStr A .isGroup = A .isAbGroup .isGroup

AbGroup→Group : AbGroup ℓ → Group ℓ
fst (AbGroup→Group A) = fst A
snd (AbGroup→Group A) = AbGroupStr→GroupStr (snd A)

Group→AbGroup : (G : Group ℓ) → ((x y : fst G) → _·_ (snd G) x y ≡ _·_ (snd G) y x) → AbGroup ℓ
fst (Group→AbGroup G comm) = fst G
AbGroupStr.0g (snd (Group→AbGroup G comm)) = 1g (snd G)
AbGroupStr._+_ (snd (Group→AbGroup G comm)) = _·_ (snd G)
AbGroupStr.- snd (Group→AbGroup G comm) = inv (snd G)
IsAbGroup.isGroup (AbGroupStr.isAbGroup (snd (Group→AbGroup G comm))) = isGroup (snd G)
IsAbGroup.comm (AbGroupStr.isAbGroup (snd (Group→AbGroup G comm))) = comm

AbGroup→CommMonoid : AbGroup ℓ → CommMonoid ℓ
AbGroup→CommMonoid (_ , abgroupstr  _ _ _ G) =
  _ , commmonoidstr _ _ (iscommmonoid (IsAbGroup.isMonoid G) (IsAbGroup.comm G))

isSetAbGroup : (A : AbGroup ℓ) → isSet ⟨ A ⟩
isSetAbGroup A = isSetGroup (AbGroup→Group A)

AbGroupHom : (G : AbGroup ℓ) (H : AbGroup ℓ') → Type (ℓ-max ℓ ℓ')
AbGroupHom G H = GroupHom (AbGroup→Group G) (AbGroup→Group H)

AbGroupIso : (G : AbGroup ℓ) (H : AbGroup ℓ') → Type (ℓ-max ℓ ℓ')
AbGroupIso G H = GroupIso (AbGroup→Group G) (AbGroup→Group H)

IsAbGroupEquiv : {A : Type ℓ} {B : Type ℓ'}
  (G : AbGroupStr A) (e : A ≃ B) (H : AbGroupStr B) → Type (ℓ-max ℓ ℓ')
IsAbGroupEquiv G e H = IsGroupHom (AbGroupStr→GroupStr G) (e .fst) (AbGroupStr→GroupStr H)

AbGroupEquiv : (G : AbGroup ℓ) (H : AbGroup ℓ') → Type (ℓ-max ℓ ℓ')
AbGroupEquiv G H = Σ[ e ∈ (G .fst ≃ H .fst) ] IsAbGroupEquiv (G .snd) e (H .snd)

isPropIsAbGroup : {G : Type ℓ} (0g : G) (_+_ : G → G → G) (- : G → G)
                → isProp (IsAbGroup 0g _+_ -)
isPropIsAbGroup 0g _+_ -_ (isabgroup GG GC) (isabgroup HG HC) =
  λ i → isabgroup (isPropIsGroup _ _ _ GG HG i) (isPropComm GC HC i)
  where
  isSetG : isSet _
  isSetG = GG .IsGroup.isMonoid .IsMonoid.isSemigroup .IsSemigroup.is-set

  isPropComm : isProp ((x y : _) → x + y ≡ y + x)
  isPropComm = isPropΠ2 λ _ _ → isSetG _ _

𝒮ᴰ-AbGroup : DUARel (𝒮-Univ ℓ) AbGroupStr ℓ
𝒮ᴰ-AbGroup =
  𝒮ᴰ-Record (𝒮-Univ _) IsAbGroupEquiv
    (fields:
      data[ _+_ ∣ autoDUARel _ _ ∣ pres· ]
      data[ 0g ∣ autoDUARel _ _ ∣ pres1 ]
      data[ -_ ∣ autoDUARel _ _ ∣ presinv ]
      prop[ isAbGroup ∣ (λ _ _ → isPropIsAbGroup _ _ _) ])
  where
  open AbGroupStr
  open IsGroupHom

-- Extract the characterization of equality of groups
AbGroupPath : (G H : AbGroup ℓ) → (AbGroupEquiv G H) ≃ (G ≡ H)
AbGroupPath = ∫ 𝒮ᴰ-AbGroup .UARel.ua

-- TODO: Induced structure results are temporarily inconvenient while we transition between algebra
-- representations
module _ (G : AbGroup ℓ) {A : Type ℓ} (m : A → A → A)
  (e : ⟨ G ⟩ ≃ A)
  (p· : ∀ x y → e .fst (G .snd ._+_ x y) ≡ m (e .fst x) (e .fst y))
  where

  private
    module G = AbGroupStr (G .snd)

    FamilyΣ : Σ[ B ∈ Type ℓ ] (B → B → B) → Type ℓ
    FamilyΣ (B , n) =
      Σ[ e ∈ B ]
      Σ[ i ∈ (B → B) ]
      IsAbGroup e n i

    inducedΣ : FamilyΣ (A , m)
    inducedΣ =
      subst FamilyΣ
        (UARel.≅→≡ (autoUARel (Σ[ B ∈ Type ℓ ] (B → B → B))) (e , p·))
        (G.0g , G.-_ , G.isAbGroup)

  InducedAbGroup : AbGroup ℓ
  InducedAbGroup .fst = A
  InducedAbGroup .snd ._+_ = m
  InducedAbGroup .snd .0g = inducedΣ .fst
  InducedAbGroup .snd .-_ = inducedΣ .snd .fst
  InducedAbGroup .snd .isAbGroup = inducedΣ .snd .snd

  InducedAbGroupPath : G ≡ InducedAbGroup
  InducedAbGroupPath = AbGroupPath _ _ .fst (e , makeIsGroupHom p·)

open IsMonoid
open IsSemigroup
open IsGroup

dirProdAb : AbGroup ℓ → AbGroup ℓ' → AbGroup (ℓ-max ℓ ℓ')
dirProdAb A B =
  Group→AbGroup (DirProd (AbGroup→Group A) (AbGroup→Group B))
                 λ p q → ΣPathP (comm (isAbGroup (snd A)) _ _
                                , comm (isAbGroup (snd B)) _ _)

trivialAbGroup : ∀ {ℓ} → AbGroup ℓ
fst trivialAbGroup = Unit*
0g (snd trivialAbGroup) = tt*
_+_ (snd trivialAbGroup) _ _ = tt*
(- snd trivialAbGroup) _ = tt*
is-set (isSemigroup (isMonoid (isGroup (isAbGroup (snd trivialAbGroup))))) =
  isProp→isSet isPropUnit*
assoc (isSemigroup (isMonoid (isGroup (isAbGroup (snd trivialAbGroup))))) _ _ _ = refl
identity (isMonoid (isGroup (isAbGroup (snd trivialAbGroup)))) _ = refl , refl
inverse (isGroup (isAbGroup (snd trivialAbGroup))) _ = refl , refl
comm (isAbGroup (snd trivialAbGroup)) _ _ = refl

-- useful lemma
move4 : ∀ {ℓ} {A : Type ℓ} (x y z w : A) (_+_ : A → A → A)
       → ((x y z : A) → x + (y + z) ≡ (x + y) + z)
       → ((x y : A) → x + y ≡ y + x)
      → (x + y) + (z + w) ≡ ((x + z) + (y + w))
move4 x y z w _+_ assoc comm =
     sym (assoc x y (z + w))
  ∙∙ cong (x +_) (assoc y z w ∙∙ cong (_+ w) (comm y z) ∙∙ sym (assoc z y w))
  ∙∙ assoc x z (y + w)

---- The type of homomorphisms A → B is an AbGroup if B is -----
module _ {ℓ ℓ' : Level} (AGr : Group ℓ) (BGr : AbGroup ℓ') where
  private
    strA = snd AGr
    strB = snd BGr

    _* = AbGroup→Group

    A = fst AGr
    B = fst BGr
    open IsGroupHom

    open AbGroupStr strB
      renaming (_+_ to _+B_ ; -_ to -B_ ; 0g to 0B
              ; rid to ridB ; lid to lidB
              ; assoc to assocB ; comm to commB
              ; invr to invrB ; invl to invlB)
    open GroupStr strA
      renaming (_·_ to _∙A_ ; inv to -A_
                ; 1g to 1A ; rid to ridA)

  trivGroupHom : GroupHom AGr (BGr *)
  fst trivGroupHom x = 0B
  snd trivGroupHom = makeIsGroupHom λ _ _ → sym (ridB 0B)

  compHom : GroupHom AGr (BGr *) → GroupHom AGr (BGr *) → GroupHom AGr (BGr *)
  fst (compHom f g) x = fst f x +B fst g x
  snd (compHom f g) =
      makeIsGroupHom λ x y
      → cong₂ _+B_ (pres· (snd f) x y) (pres· (snd g) x y)
      ∙ move4 (fst f x) (fst f y) (fst g x) (fst g y)
              _+B_ assocB commB

  invHom : GroupHom AGr (BGr *) → GroupHom AGr (BGr *)
  fst (invHom (f , p)) x = -B f x
  snd (invHom (f , p)) =
    makeIsGroupHom
      λ x y → cong -B_ (pres· p x y)
            ∙∙ GroupTheory.invDistr (BGr *) (f x) (f y)
            ∙∙ commB _ _

  open AbGroupStr
  open IsAbGroup
  open IsGroup
  open IsMonoid
  open IsSemigroup

  HomGroup : AbGroup (ℓ-max ℓ ℓ')
  fst HomGroup = GroupHom AGr (BGr *)
  0g (snd HomGroup) = trivGroupHom
  AbGroupStr._+_ (snd HomGroup) = compHom
  AbGroupStr.- snd HomGroup = invHom
  is-set (isSemigroup (isMonoid (isGroup (isAbGroup (snd HomGroup))))) =
    isSetGroupHom
  assoc (isSemigroup (isMonoid (isGroup (isAbGroup (snd HomGroup))))) (f , p) (g , q) (h , r) =
    Σ≡Prop (λ _ → isPropIsGroupHom _ _)
      (funExt λ x → assocB _ _ _)
  fst (identity (isMonoid (isGroup (isAbGroup (snd HomGroup)))) (f , p)) =
    Σ≡Prop (λ _ → isPropIsGroupHom _ _) (funExt λ y → ridB _)
  snd (identity (isMonoid (isGroup (isAbGroup (snd HomGroup)))) (f , p)) =
    Σ≡Prop (λ _ → isPropIsGroupHom _ _) (funExt λ x → lidB _)
  fst (inverse (isGroup (isAbGroup (snd HomGroup))) (f , p)) =
    Σ≡Prop (λ _ → isPropIsGroupHom _ _) (funExt λ x → invrB (f x))
  snd (inverse (isGroup (isAbGroup (snd HomGroup))) (f , p)) =
    Σ≡Prop (λ _ → isPropIsGroupHom _ _) (funExt λ x → invlB (f x))
  comm (isAbGroup (snd HomGroup)) (f , p) (g , q) =
    Σ≡Prop (λ _ → isPropIsGroupHom _ _)
      (funExt λ x → commB _ _)


-- Andreas, 2014-01-10, reported by fredrik.forsberg

record ⊤ : Set where

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

syntax Σ A (λ x → B) = Σ[ x ∈ A ] B

test : Set
test = {! Σ[ x ∈ ⊤ ] ?!}

-- Fredrik's report:

-- Using the darcs version of Agda from today 10 January,
-- if I load the file and give (or refine) in the hole, I end up with
--
--   test = Σ ⊤ (λ x → {!!})
--
-- i.e. Agda has translated away the syntax Σ[ x ∈ ⊤ ] {!!} for me.
-- I would of course expect
--
--   test = Σ[ x ∈ ⊤ ] {!!}
--
-- instead, and I think this used to be the behaviour? (Using the Σ from
-- the standard library, this is more annoying, as one gets
--
--   test = Σ-syntax ⊤ (λ x → {!!})
--
-- as a result.)
--
-- This might be related to issue 994?

-- Expected test case behavior:
--
-- Bad (at the time of report:
--
--   (agda2-give-action 0 "Σ ⊤ (λ x → ?)")
--
-- Good:
--
--   (agda2-give-action 0 'no-paren)


{-# OPTIONS --cubical --no-import-sorts #-}

module NumberFirstAttempt where

open import Agda.Primitive renaming (_⊔_ to ℓ-max; lsuc to ℓ-suc; lzero to ℓ-zero)

private
  variable
    ℓ ℓ' ℓ'' : Level

open import Cubical.Foundations.Everything renaming (_⁻¹ to _⁻¹ᵖ; assoc to ∙-assoc)
open import Cubical.Relation.Binary.Base -- Rel
open import Cubical.Data.Unit.Base -- Unit

record PoorField : Type (ℓ-suc (ℓ-max ℓ ℓ')) where
  field
    Carrier : Type ℓ
    -- comm ring
    0f   : Carrier
    1f   : Carrier
    _+_  : Carrier → Carrier → Carrier
    _·_  : Carrier → Carrier → Carrier
    -_   : Carrier → Carrier
    -- lattice
    _<_  : Rel Carrier Carrier ℓ' -- stronger than _#_ and _≤_
    min  : Carrier → Carrier → Carrier
    max  : Carrier → Carrier → Carrier
    -- other
    _#_  : Rel Carrier Carrier ℓ'
    _≤_  : Rel Carrier Carrier ℓ'
    ∣_∣ᶠ' : Carrier → Σ[ x ∈ Carrier ] 0f ≤ x -- absolute value NOTE: better have `0 ≤ x` as a separate property
    _⁻¹ᶠ : (x : Carrier) → {{x # 0f}} → Carrier
    conj : Carrier → Carrier -- complex conjugation (only for ℂ; this is the identity function on ℝ)
    -- sqrt⁺ -- positive sqrt
    --       -- need that on ℝ₀⁺ to define a norm from an inner product
    --       -- on ℝ₀⁺ we have `∀ x → sqrt (x · x) ≡ x`
    -- NOTE: squares are nonnegative in an ordered field

  ∣_∣ᶠ : Carrier → Carrier -- NOTE: well, this should be "into" ℝ₀⁺
  ∣ x ∣ᶠ = fst (∣ x ∣ᶠ')

  _-_ : Carrier → Carrier → Carrier
  x - y = x + (- y)

  infix  9 _⁻¹ᶠ
  infix  8 -_
  infixl 7 _·_
  infixl 6 _+_
  infixl 6 _-_
  infixl 4 _#_
  infixl 4 _<_
  infixl 4 _≤_

record IsℝField (PF : PoorField {ℓ} {ℓ'}) : Type (ℓ-suc (ℓ-max ℓ ℓ')) where
  open PoorField PF

record Isℝ₀⁺Field (PF : PoorField {ℓ} {ℓ'}) : Type (ℓ-suc (ℓ-max ℓ ℓ')) where
  open PoorField PF
  field
    isℝField : IsℝField PF
    isNonnegative : ∀ x → 0f ≤ x
  open IsℝField isℝField public

record Isℝ⁺Field (PF : PoorField {ℓ} {ℓ'}) : Type (ℓ-suc (ℓ-max ℓ ℓ')) where
  open PoorField PF
  field
    isℝField : IsℝField PF
    -- NOTE: 0f is not an element of ℝ⁺, so we do not have a neutral element for addition
    --       so the following holds in a different way
    -- isPositive : ∀ x → 0f < x
  open IsℝField isℝField public

record Is𝕂Field (PF : PoorField {ℓ} {ℓ'}) : Type (ℓ-suc (ℓ-max ℓ ℓ')) where
  open PoorField PF

record ℝField : Type (ℓ-suc (ℓ-max ℓ ℓ')) where
  field
    poorField : PoorField {ℓ} {ℓ'}
    isℝField : IsℝField poorField
  open PoorField poorField public
  open IsℝField isℝField public

record ℝ₀⁺Field : Type (ℓ-suc (ℓ-max ℓ ℓ')) where
  field
    poorField : PoorField {ℓ} {ℓ'}
    isℝ₀⁺Field : Isℝ₀⁺Field poorField
  open PoorField poorField public
  open Isℝ₀⁺Field isℝ₀⁺Field public

record ℝ⁺Field : Type (ℓ-suc (ℓ-max ℓ ℓ')) where
  field
    poorField : PoorField {ℓ} {ℓ'}
    isℝ⁺Field : Isℝ⁺Field poorField
  open PoorField poorField public
  open Isℝ⁺Field isℝ⁺Field public

record 𝕂Field : Type (ℓ-suc (ℓ-max ℓ ℓ')) where
  field
    poorField : PoorField {ℓ} {ℓ'}
    is𝕂Field : Is𝕂Field poorField
  open PoorField poorField public
  open Is𝕂Field is𝕂Field public

postulate
  ℝℓ ℝℓ' : Level
  ℝF    : ℝField   {ℝℓ} {ℝℓ'} -- reals
  ℝ⁺F   : ℝ⁺Field  {ℝℓ} {ℝℓ'} -- positive reals without 0
  ℝ₀⁺F  : ℝ₀⁺Field {ℝℓ} {ℝℓ'} -- positive reals with 0

open ℝField ℝF using () renaming
  ( Carrier to ℝ
  )

record PoorSubField-ℝ (φ : ℝ → Type ℓ) : Type (ℓ-max ℝℓ ℓ) where
  -- module R = ℝField ℝF
  open ℝField ℝF
  field
    ι : Σ ℝ φ

  _<⁺_ : Σ ℝ φ → Σ ℝ φ → Type ℝℓ'
  _<⁺_ (x , xp) (y , yp) = x < y

module Test where
  module R =  ℝField ℝF
  φᵢ = λ(x : ℝ) → Unit

  -- the following "absorbs" different `Σ ℝ φ` ℝ-numbers and falls back to the "raw" operation from ℝ
  _+_ : {φ₁ φ₂ : ℝ → Type ℓ'} → Σ ℝ φ₁ → Σ ℝ φ₂ → Σ ℝ φᵢ
  _+_ (x , _) (y , _) = x R.+ y , tt

  -- we might add an enumeration for different φs and pattern-match on those
  data ℝ-props (x : ℝ) : Type ℝℓ where
    φ-id : Unit → ℝ-props x
    -- more ...

  -- this works for subsets of ℝ but not for inter-sort-mixing (e.g. ℕ + ℝ) .. which we do want to coerce explicitly?
  -- we could start with a number, e.g. z₀ ∈ ℕ
  -- then include it into ℝ and have a Σ ℝ φ-from-nat
  -- we could track the from-nat'ness and back-coerce this number when needed (as long as from-nat is preserved)

  {-
  data ℝ-sub (x : ℝ) : Type ℝℓ where
    φ-from-ℝ   : Unit -- default "fallback" case
    φ-from-ℕ   : Σ[ z ∈ ℕ ] ℕ↪ℝ z ≡ x -- with this we can use the `reflects`-properties of `ℕ↪ℝ` to get corresponding properties on ℕ
    φ-from-ℤ   : Σ[ z ∈ ℤ ] ℤ↪ℝ z ≡ x
    φ-from-ℚ   : Σ[ z ∈ ℚ ] ℚ↪ℝ z ≡ x
    φ-from-ℝ₀⁺ :  0f ≤ x
                ¬( x < 0f)
    φ-from-ℝ⁺  :  0f < x
    -- ... more

  -- first projection
  num : ∀{x} → ℝ-sub x → ℝ
  num p = ... cases

  -- target type "table"
  +-Coerce : (x y : ℝ-sub) → Type ℝℓ
  +-Coerce x y = ... cases

  -- implementation
  _+_ : (x y : ℝ-sub) → +-Coerce x y
  x + y = ... cases
  -}

record IsPoorFieldInclusion
  {ℓ ℓ' ℓₚ ℓₚ'}
  (F : PoorField {ℓ} {ℓₚ}) (G : PoorField {ℓ'} {ℓₚ'})
  (f : (PoorField.Carrier F) → (PoorField.Carrier G)) : Type (ℓ-max (ℓ-max ℓ ℓ') (ℓ-max ℓₚ ℓₚ'))
  where
  private
    module F = PoorField F
    module G = PoorField G
  field
    -- injectivity? might follow from preserves-#?
    reflects-≡    : ∀ x y → f x   ≡ f y →   x ≡     y
    -- lattice
    preserves-<   : ∀ x y →   x F.<   y → f x G.< f y
    preserves-≤   : ∀ x y →   x F.≤   y → f x G.≤ f y
    preserves-#   : ∀ x y →   x F.#   y → f x G.# f y
    reflects-<    : ∀ x y → f x G.< f y →   x F.<   y
    reflects-≤    : ∀ x y → f x G.≤ f y →   x F.≤   y
    reflects-#    : ∀ x y → f x G.# f y →   x F.#   y
    preserves-min : ∀ x y → f (F.min x y) ≡ G.min (f x) (f y)
    preserves-max : ∀ x y → f (F.max x y) ≡ G.max (f x) (f y)
    preserves-0   :         f  F.0f       ≡ G.0f
    -- Fin 1 does not preserve
    preserves-1   :         f  F.1f       ≡ G.1f
    -- Fin k might not preserve
    preserves-+   : ∀ x y → f (x F.+ y)   ≡ f x G.+  f y
    preserves-·   : ∀ x y → f (x F.· y)   ≡ f x G.·  f y
    -- ℕ might not preserve
    preserves-    : ∀ x   → f (  F.- x)   ≡     G.- (f x)
    -- ℤ does not preserve
    -- preserves-⁻¹' : ∀ x → (p : x F.# F.0f) → f (F._⁻¹ᶠ x {{p}}) ≡ G._⁻¹ᶠ (f x) {{ transport (λ i → f x G.# preserves-0 i) (preserves-# x F.0f p) }}
    -- NOTE: we better let the "user" decide how the proof of `f x # 0` is obtained
    preserves-⁻¹  : ∀ x → (p : x F.# F.0f) → (q : f x G.# G.0f) → f (F._⁻¹ᶠ x {{p}}) ≡ G._⁻¹ᶠ (f x) {{q}}

record PoorFieldInclusion {ℓ ℓ' ℓₚ ℓₚ'} (F : PoorField {ℓ} {ℓₚ}) (G : PoorField {ℓ'} {ℓₚ'}) : Type (ℓ-max (ℓ-max ℓ ℓ') (ℓ-max ℓₚ ℓₚ')) where
  constructor poorfieldmor
  module F = PoorField F
  module G = PoorField G
  field
    fun : F.Carrier → G.Carrier
    isPoorFieldInclusion : IsPoorFieldInclusion F G fun
  open IsPoorFieldInclusion isPoorFieldInclusion public


module UniDB.Morph.ShiftsPrime where

open import UniDB.Spec
open import UniDB.Basic
open import UniDB.Subst
open import Function
open import Data.Product

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

mutual
  data Shifts* : MOR where
    refl : {γ : Dom} → Shifts* γ γ
    incl : {γ₁ γ₂ : Dom} (ξ : Shifts+ γ₁ γ₂) → Shifts* γ₁ γ₂

  data Shifts+ : MOR where
    step : {γ₁ γ₂ : Dom} (ξ : Shifts* γ₁ γ₂) → Shifts+ γ₁ (suc γ₂)
    skip : {γ₁ γ₂ : Dom} (ξ : Shifts+ γ₁ γ₂) → Shifts+ (suc γ₁) (suc γ₂)

mutual
  shiftIx* : {γ₁ γ₂ : Dom} (ξ : Shifts* γ₁ γ₂) (i : Ix γ₁) → Ix γ₂
  shiftIx* refl     i = i
  shiftIx* (incl ξ) i = shiftIx+ ξ i

  shiftIx+ : {γ₁ γ₂ : Dom} (ξ : Shifts+ γ₁ γ₂) (i : Ix γ₁) → Ix γ₂
  shiftIx+ (skip ξ) zero    = zero
  shiftIx+ (skip ξ) (suc i) = suc (shiftIx+ ξ i)
  shiftIx+ (step ξ) i       = suc (shiftIx* ξ i)

mutual
  _⊙**_ : {γ₁ γ₂ γ₃ : Dom} (ξ₁ : Shifts* γ₁ γ₂) (ξ₂ : Shifts* γ₂ γ₃) → Shifts* γ₁ γ₃
  ξ₁ ⊙** refl    = ξ₁
  ξ₁ ⊙** incl ξ₂ = incl (ξ₁ ⊙*+ ξ₂)

  _⊙*+_ : {γ₁ γ₂ γ₃ : Dom} (ξ₁ : Shifts* γ₁ γ₂) (ξ₂ : Shifts+ γ₂ γ₃) → Shifts+ γ₁ γ₃
  refl    ⊙*+ ξ₂ = ξ₂
  incl ξ₁ ⊙*+ ξ₂ = ξ₁ ⊙++ ξ₂

  _⊙+*_ : {γ₁ γ₂ γ₃ : Dom} (ξ₁ : Shifts+ γ₁ γ₂) (ξ₂ : Shifts* γ₂ γ₃) → Shifts+ γ₁ γ₃
  ξ₁ ⊙+* refl    = ξ₁
  ξ₁ ⊙+* incl ξ₂ = ξ₁ ⊙++ ξ₂

  _⊙++_ : {γ₁ γ₂ γ₃ : Dom} (ξ₁ : Shifts+ γ₁ γ₂) (ξ₂ : Shifts+ γ₂ γ₃) → Shifts+ γ₁ γ₃
  ξ₁      ⊙++ step ξ₂ = step (incl (ξ₁ ⊙+* ξ₂))
  step ξ₁ ⊙++ skip ξ₂ = step (incl (ξ₁ ⊙*+ ξ₂))
  skip ξ₁ ⊙++ skip ξ₂ = skip (ξ₁ ⊙++ ξ₂)

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

instance
  iLkShifts* : {T : STX} {{vrT : Vr T}} → Lk T Shifts*
  lk {{iLkShifts*}} ξ i = vr {_} (shiftIx* ξ i)

  iLkShifts+ : {T : STX} {{vrT : Vr T}} → Lk T Shifts+
  lk {{iLkShifts+}} ξ i = vr {_} (shiftIx+ ξ i)

  iUpShifts* : Up Shifts*
  _↑₁ {{iUpShifts*}} refl     = refl
  _↑₁ {{iUpShifts*}} (incl ξ) = incl (skip ξ)
  _↑_ {{iUpShifts*}} ξ 0 = ξ
  _↑_ {{iUpShifts*}} ξ (suc δ⁺) = ξ ↑ δ⁺ ↑₁
  ↑-zero {{iUpShifts*}} ξ = refl
  ↑-suc {{iUpShifts*}} ξ δ⁺ = refl

  iUpShifts+ : Up Shifts+
  _↑₁ {{iUpShifts+}} ξ = skip ξ
  _↑_ {{iUpShifts+}} ξ 0 = ξ
  _↑_ {{iUpShifts+}} ξ (suc δ⁺) = ξ ↑ δ⁺ ↑₁
  ↑-zero {{iUpShifts+}} ξ = refl
  ↑-suc {{iUpShifts+}} ξ δ⁺ = refl

  iIdmShifts* : Idm Shifts*
  idm {{iIdmShifts*}} γ = refl {γ}

  iWkmShifts* : Wkm Shifts*
  wkm {{iWkmShifts*}} zero    = idm {Shifts*} _
  wkm {{iWkmShifts*}} (suc δ) = incl (step (wkm {Shifts*} δ))

  iCompShifts* : Comp Shifts*
  _⊙_ {{iCompShifts*}} = _⊙**_

  iCompShifts+ : Comp Shifts+
  _⊙_ {{iCompShifts+}} = _⊙++_

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

suc-inj : {γ : Dom} {i j : Ix γ} → _≡_ {A = Ix (suc γ)} (suc i) (suc j) → i ≡ j
suc-inj refl = refl

shift₁≠id : {γ : Dom} (ξ : Shifts+ γ γ) →
  Σ[ i ∈ Ix γ ] shiftIx+ ξ i ≢ i
shift₁≠id (skip ξ) with shift₁≠id ξ
shift₁≠id (skip ξ) | w , ¬p = suc w , ¬p ∘ suc-inj
shift₁≠id (step ξ) = zero , λ ()

mutual
  extensionality-shifts* : {γ₁ γ₂ : Dom} (ξ₁ ξ₂ : Shifts* γ₁ γ₂)
    (hyp : (i : Ix γ₁) → lk {Ix} ξ₁ i ≡ lk {Ix} ξ₂ i) →
    ξ₁ ≡ ξ₂
  extensionality-shifts* refl      refl      hyp = refl
  extensionality-shifts* refl      (incl ξ₂) hyp with shift₁≠id ξ₂
  ... | w , ¬p = case ¬p (sym (hyp w)) of λ()
  extensionality-shifts* (incl ξ₁) refl      hyp with shift₁≠id ξ₁
  ... | w , ¬p = case ¬p (hyp w) of λ()
  extensionality-shifts* (incl ξ₁) (incl ξ₂) hyp = cong incl (extensionality-shifts+ ξ₁ ξ₂ hyp)

  extensionality-shifts+ : {γ₁ γ₂ : Dom} (ξ₁ ξ₂ : Shifts+ γ₁ γ₂)
    (hyp : (i : Ix γ₁) → lk {Ix} ξ₁ i ≡ lk {Ix} ξ₂ i) →
    ξ₁ ≡ ξ₂
  extensionality-shifts+ (skip ξ₁) (skip ξ₂) hyp = cong skip (extensionality-shifts+ ξ₁ ξ₂ (suc-inj ∘ hyp ∘ suc))
  extensionality-shifts+ (skip ξ₁) (step ξ₂) hyp = case hyp zero of λ()
  extensionality-shifts+ (step ξ₁) (skip ξ₂) hyp = case hyp zero of λ()
  extensionality-shifts+ (step ξ₁) (step ξ₂) hyp = cong step (extensionality-shifts* ξ₁ ξ₂ (suc-inj ∘ hyp))

mutual
  shiftIx-⊙** : {γ₁ γ₂ γ₃ : Dom} (ξ₁ : Shifts* γ₁ γ₂) (ξ₂ : Shifts* γ₂ γ₃) →
    (i : Ix γ₁) → shiftIx* (ξ₁ ⊙** ξ₂) i ≡ shiftIx* ξ₂ (shiftIx* ξ₁ i)
  shiftIx-⊙** ξ₁ refl      i = refl
  shiftIx-⊙** ξ₁ (incl ξ₂) i = shiftIx-⊙*+ ξ₁ ξ₂ i

  shiftIx-⊙*+ : {γ₁ γ₂ γ₃ : Dom} (ξ₁ : Shifts* γ₁ γ₂) (ξ₂ : Shifts+ γ₂ γ₃) →
    (i : Ix γ₁) → shiftIx+ (ξ₁ ⊙*+ ξ₂) i ≡ shiftIx+ ξ₂ (shiftIx* ξ₁ i)
  shiftIx-⊙*+ refl      ξ₂ i = refl
  shiftIx-⊙*+ (incl ξ₁) ξ₂ i = shiftIx-⊙++ ξ₁ ξ₂ i

  shiftIx-⊙+* : {γ₁ γ₂ γ₃ : Dom} (ξ₁ : Shifts+ γ₁ γ₂) (ξ₂ : Shifts* γ₂ γ₃) →
    (i : Ix γ₁) → shiftIx+ (ξ₁ ⊙+* ξ₂) i ≡ shiftIx* ξ₂ (shiftIx+ ξ₁ i)
  shiftIx-⊙+* ξ₁ refl      i = refl
  shiftIx-⊙+* ξ₁ (incl ξ₂) i = shiftIx-⊙++ ξ₁ ξ₂ i

  shiftIx-⊙++ : {γ₁ γ₂ γ₃ : Dom} (ξ₁ : Shifts+ γ₁ γ₂) (ξ₂ : Shifts+ γ₂ γ₃) →
    (i : Ix γ₁) → shiftIx+ (ξ₁ ⊙++ ξ₂) i ≡ shiftIx+ ξ₂ (shiftIx+ ξ₁ i)
  shiftIx-⊙++ ξ₁        (step ξ₂) i       = cong suc (shiftIx-⊙+* ξ₁ ξ₂ i)
  shiftIx-⊙++ (step ξ₁) (skip ξ₂) i       = cong suc (shiftIx-⊙*+ ξ₁ ξ₂ i)
  shiftIx-⊙++ (skip ξ₁) (skip ξ₂) zero    = refl
  shiftIx-⊙++ (skip ξ₁) (skip ξ₂) (suc i) = cong suc (shiftIx-⊙++ ξ₁ ξ₂ i)

⊙**-↑₁ : {γ₁ γ₂ γ₃ : Dom} (ξ₁ : Shifts* γ₁ γ₂) (ξ₂ : Shifts* γ₂ γ₃) →
  (ξ₁ ⊙** ξ₂) ↑₁ ≡ (ξ₁ ↑₁) ⊙** (ξ₂ ↑₁)
⊙**-↑₁ ξ₁        refl      = refl
⊙**-↑₁ refl      (incl ξ₂) = refl
⊙**-↑₁ (incl ξ₁) (incl ξ₂) = refl

⊙++-↑₁ : {γ₁ γ₂ γ₃ : Dom} (ξ₁ : Shifts+ γ₁ γ₂) (ξ₂ : Shifts+ γ₂ γ₃) →
  (ξ₁ ⊙++ ξ₂) ↑₁ ≡ (ξ₁ ↑₁) ⊙++ (ξ₂ ↑₁)
⊙++-↑₁ ξ₁        (step ξ₂) = refl
⊙++-↑₁ (step ξ₁) (skip ξ₂) = refl
⊙++-↑₁ (skip ξ₁) (skip ξ₂) = refl

mutual
  ⊙***-assoc : {γ₁ γ₂ γ₃ γ₄ : Dom}
    (ξ₁ : Shifts* γ₁ γ₂) (ξ₂ : Shifts* γ₂ γ₃) (ξ₃ : Shifts* γ₃ γ₄) →
    (ξ₁ ⊙** (ξ₂ ⊙** ξ₃)) ≡ ((ξ₁ ⊙** ξ₂) ⊙** ξ₃)
  ⊙***-assoc ξ₁ ξ₂ refl      = refl
  ⊙***-assoc ξ₁ ξ₂ (incl ξ₃) = cong incl (⊙**+-assoc ξ₁ ξ₂ ξ₃)

  ⊙**+-assoc : {γ₁ γ₂ γ₃ γ₄ : Dom}
    (ξ₁ : Shifts* γ₁ γ₂) (ξ₂ : Shifts* γ₂ γ₃) (ξ₃ : Shifts+ γ₃ γ₄) →
    (ξ₁ ⊙*+ (ξ₂ ⊙*+ ξ₃)) ≡ ((ξ₁ ⊙** ξ₂) ⊙*+ ξ₃)
  ⊙**+-assoc ξ₁ refl      ξ₃ = refl
  ⊙**+-assoc ξ₁ (incl ξ₂) ξ₃ = ⊙*++-assoc ξ₁ ξ₂ ξ₃

  ⊙*++-assoc : {γ₁ γ₂ γ₃ γ₄ : Dom}
    (ξ₁ : Shifts* γ₁ γ₂) (ξ₂ : Shifts+ γ₂ γ₃) (ξ₃ : Shifts+ γ₃ γ₄) →
    (ξ₁ ⊙*+ (ξ₂ ⊙++ ξ₃)) ≡ ((ξ₁ ⊙*+ ξ₂) ⊙++ ξ₃)
  ⊙*++-assoc refl      ξ₂ ξ₃ = refl
  ⊙*++-assoc (incl ξ₁) ξ₂ ξ₃ = ⊙+++-assoc ξ₁ ξ₂ ξ₃

  ⊙++*-assoc : {γ₁ γ₂ γ₃ γ₄ : Dom}
    (ξ₁ : Shifts+ γ₁ γ₂) (ξ₂ : Shifts+ γ₂ γ₃) (ξ₃ : Shifts* γ₃ γ₄) →
    (ξ₁ ⊙++ (ξ₂ ⊙+* ξ₃)) ≡ ((ξ₁ ⊙++ ξ₂) ⊙+* ξ₃)
  ⊙++*-assoc ξ₁ ξ₂ refl      = refl
  ⊙++*-assoc ξ₁ ξ₂ (incl ξ₃) = ⊙+++-assoc ξ₁ ξ₂ ξ₃

  ⊙+*+-assoc : {γ₁ γ₂ γ₃ γ₄ : Dom}
    (ξ₁ : Shifts+ γ₁ γ₂) (ξ₂ : Shifts* γ₂ γ₃) (ξ₃ : Shifts+ γ₃ γ₄) →
    (ξ₁ ⊙++ (ξ₂ ⊙*+ ξ₃)) ≡ ((ξ₁ ⊙+* ξ₂) ⊙++ ξ₃)
  ⊙+*+-assoc ξ₁ refl      ξ₃ = refl
  ⊙+*+-assoc ξ₁ (incl ξ₂) ξ₃ = ⊙+++-assoc ξ₁ ξ₂ ξ₃

  ⊙+++-assoc : {γ₁ γ₂ γ₃ γ₄ : Dom}
    (ξ₁ : Shifts+ γ₁ γ₂) (ξ₂ : Shifts+ γ₂ γ₃) (ξ₃ : Shifts+ γ₃ γ₄) →
    (ξ₁ ⊙++ (ξ₂ ⊙++ ξ₃)) ≡ ((ξ₁ ⊙++ ξ₂) ⊙++ ξ₃)
  ⊙+++-assoc ξ₁        ξ₂        (step ξ₃) = cong (step ∘ incl) (⊙++*-assoc ξ₁ ξ₂ ξ₃)
  ⊙+++-assoc ξ₁        (step ξ₂) (skip ξ₃) = cong (step ∘ incl) (⊙+*+-assoc ξ₁ ξ₂ ξ₃)
  ⊙+++-assoc (step ξ₁) (skip ξ₂) (skip ξ₃) = cong (step ∘ incl) (⊙*++-assoc ξ₁ ξ₂ ξ₃)
  ⊙+++-assoc (skip ξ₁) (skip ξ₂) (skip ξ₃) = cong skip (⊙+++-assoc ξ₁ ξ₂ ξ₃)

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

module _ {T : STX} {{vrT : Vr T}} where

  instance
    iLkUpShifts* : {{wkT : Wk T}} {{wkVrT : WkVr T}} → LkUp T Shifts*
    lk-↑₁-zero {{iLkUpShifts*}} refl       = refl
    lk-↑₁-zero {{iLkUpShifts*}} (incl ξ)   = refl
    lk-↑₁-suc  {{iLkUpShifts*}} refl i     = sym (wk₁-vr {T} i)
    lk-↑₁-suc  {{iLkUpShifts*}} (incl ξ) i = sym (wk₁-vr {T} (shiftIx+ ξ i))

    iLkRenShifts* : LkRen T Shifts*
    lk-ren {{iLkRenShifts*}} ξ i = refl

    iLkIdmShifts* : LkIdm T Shifts*
    lk-idm {{iLkIdmShifts*}} i = refl

    iLkWkmShifts* : LkWkm T Shifts*
    lk-wkm {{iLkWkmShifts*}} δ i = cong vr (lem δ i)
      where
        lem : {γ : Dom} (δ : Dom) (i : Ix γ) →
          shiftIx* (wkm {Shifts*} δ) i ≡ wk {Ix} δ i
        lem zero i = refl
        lem (suc δ) i = cong suc (lem δ i)

    iLkCompApShifts* : {{apTT : Ap T T}} {{apVrT : ApVr T}} → LkCompAp T Shifts*
    lk-⊙-ap {{iLkCompApShifts*}} {Ξ} ξ₁ ξ₂ i = begin
      vr (lk {Ix} (ξ₁ ⊙ ξ₂) i)     ≡⟨ cong vr (shiftIx-⊙** ξ₁ ξ₂ i) ⟩
      lk {T} ξ₂ (lk {Ix} ξ₁ i)      ≡⟨ sym (ap-vr {T} ξ₂ (lk ξ₁ i)) ⟩
      ap {T} ξ₂ (vr (lk {Ix} ξ₁ i)) ∎ -- sym {!ap-vr {T} !}

instance
  iUpIdmShifts* : UpIdm Shifts*
  idm-↑₁ {{iUpIdmShifts*}} = refl

  iCompIdmShifts* : CompIdm Shifts*
  ⊙-idm {{iCompIdmShifts*}} ξ        = refl
  idm-⊙ {{iCompIdmShifts*}} refl     = refl
  idm-⊙ {{iCompIdmShifts*}} (incl ξ) = refl

  iUpCompShifts* : UpComp Shifts*
  ⊙-↑₁ {{iUpCompShifts*}} ξ₁ ξ₂ = ⊙**-↑₁ ξ₁ ξ₂
    -- extensionality-shifts* ((ξ₁ ⊙ ξ₂) ↑₁) (ξ₁ ↑₁ ⊙ ξ₂ ↑₁)
    --   (lk≃ {Ix} {Shifts*} {ξ = (ξ₁ ⊙ ξ₂) ↑₁} {ξ₁ ↑₁ ⊙ ξ₂ ↑₁}
    --   (⊙-↑₁-pointwise {Ix} {{apWkTT =  iApWk Ix Ix}} {Shifts*} ξ₁ ξ₂))

  iCompAssoc* : CompAssoc Shifts*
  ⊙-assoc {{iCompAssoc*}} = ⊙***-assoc

  iUpCompShifts+ : UpComp Shifts+
  ⊙-↑₁ {{iUpCompShifts+}} = ⊙++-↑₁

  iCompAssoc+ : CompAssoc Shifts+
  ⊙-assoc {{iCompAssoc+}} = ⊙+++-assoc

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

{-
  iWkmHomShifts* : WkmHom Shifts*
  wkm-zero {{iWkmHomShifts*}}   = {!!}
  wkm-suc  {{iWkmHomShifts*}} δ = {!!}
-}


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

module UpperNaturals where

  open import Basics
  open import lib.Basics
  open import lib.NType2

  open import lib.types.Pi
  open import lib.types.Nat
  open import lib.types.Truncation

  ≤-antisymmetry : {n m : ℕ} (_ : n ≤ m) (_ : m ≤ n) → n == m
  ≤-antisymmetry {_} {_} (inl p) _ = p
  ≤-antisymmetry {_} {_} _ (inl p) = ! p
  ≤-antisymmetry {_} {_} (inr p) q = quodlibet (<-to-≱ p q)

  -- A propositional version of _≤_
  _≤p_ : ℕ → ℕ → PropT₀
  n ≤p m = (n ≤ m) , (≤-is-prop {n} {m})

  _is-upward-closed : (N : ℕ → PropT₀) → Type _
  N is-upward-closed = (n m : ℕ) → n ≤ m → (N n) holds → (N m) holds

  upward-closed-is-a-prop : (N : ℕ → PropT₀) → (N is-upward-closed) is-a-prop
  upward-closed-is-a-prop N = mp (λ _ → mp (λ m → mp (λ _ → mp (λ _ → (N m) holds-is-a-prop))))
    where
      mp = mapping-into-prop-is-a-prop

  ℕ→PropT₀-is-a-set : (ℕ → PropT₀) is-a-set
  ℕ→PropT₀-is-a-set = Π-level {_}{_}{ℕ}{λ _ → PropT₀}{0} (λ _ → hProp-is-set _)

  ℕ↑-prop : SubtypeProp (ℕ → PropT₀) _
  ℕ↑-prop = _is-upward-closed , upward-closed-is-a-prop

  {- The Upper Naturals
     An upper natural is an upward closed proposition concerning natural numbers.

     The interpretation is that an upper natural is a natural ``defined by its upper bounds'', in the
     sense that for the proposition N holding of a natural n means that n is an upper bound of N.

     The important bit about upper naturals is that they satisfy the well-ordering principle,
     constructively.
  -}
  ℕ↑ : Type₁
  ℕ↑ = Subtype ℕ↑-prop
   -- Σ (ℕ → PropT₀) _is-upward-closed

  ℕ↑-is-a-set : ℕ↑ is-a-set
  ℕ↑-is-a-set = Subtype-level ℕ↑-prop

  _is-an-upper-bound-of_ : ℕ → ℕ↑ → Type _
  n is-an-upper-bound-of M = ((fst M) n) holds

  _≤:↑_ : ℕ↑ → ℕ → Type _
  M ≤:↑ n = n is-an-upper-bound-of M

  ≤:↑-is-a-prop : {M : ℕ↑} {n : ℕ} → (M ≤:↑ n) is-a-prop
  ≤:↑-is-a-prop {M} {n} = ((fst M) n) holds-is-a-prop

  ≤p-is-upward-closed : {n : ℕ} → (n ≤p_) is-upward-closed
  ≤p-is-upward-closed = λ n m z z₁ → ≤-trans z₁ z

  _^↑ : ℕ → ℕ↑
  n ^↑ = (n ≤p_) , ≤p-is-upward-closed

  -- 0 is bounded above by every number.
  O↑ : ℕ↑
  O↑ = O ^↑

  -- Infinity is defined to be the number with no upper bounds.
  ∞↑ : ℕ↑
  ∞↑ = (λ _ → False) , proof
    where proof : (λ _ → False) is-upward-closed
          proof = λ n m _ z → z

  ∞↑-has-no-upper-bounds : (n : ℕ) → ¬ (∞↑ ≤:↑ n)
  ∞↑-has-no-upper-bounds n = λ z → z

  ≤:↑-refl : {n : ℕ} → n is-an-upper-bound-of (n ^↑)
  ≤:↑-refl = ≤-refl

  -- The ordering on the upper naturals is defined by saying that
  -- N is at most M if every upper bound of M is an upper bound of N.
  _≤↑_ : ℕ↑ → ℕ↑ → Type _
  N ≤↑ M = (n : ℕ) → M ≤:↑ n → N ≤:↑ n

  ≤↑-is-a-prop : {N M : ℕ↑} → (N ≤↑ M) is-a-prop
  ≤↑-is-a-prop {N} {M} = mp (λ n → mp (λ _ → ≤:↑-is-a-prop {N} {n}))
    where mp = mapping-into-prop-is-a-prop

  ≤↑-refl : {N : ℕ↑} → N ≤↑ N
  ≤↑-refl = λ n z → z

  ≤↑-trans : {N M P : ℕ↑} → N ≤↑ M → M ≤↑ P → N ≤↑ P
  ≤↑-trans = λ z z₁ n z₂ → z n (z₁ n z₂)

  ^↑-is-monotone : {n m : ℕ} → n ≤ m → (n ^↑) ≤↑ (m ^↑)
  ^↑-is-monotone = λ x k x₁ → ≤-trans x x₁

  ^↑-yoneda : {n : ℕ} {M : ℕ↑} → M ≤↑ (n ^↑) → M ≤:↑ n
  ^↑-yoneda {n} {M} = λ x → x n ≤:↑-refl

  ^↑-is-full : {n m : ℕ} → (n ^↑) ≤↑ (m ^↑) → n ≤ m
  ^↑-is-full {n} {m} = λ z → z m (inl idp)

  ^↑-is-ff : {n m : ℕ} → (n ≤ m) ≃ ((n ^↑) ≤↑ (m ^↑))
  ^↑-is-ff {n} {m} = equiv ^↑-is-monotone ^↑-is-full
    (λ b → prop-path (≤↑-is-a-prop {(n ^↑)} {(m ^↑)}) (λ _ → ≤-trans (b m (inl idp))) b)
    (λ a → prop-path ≤-is-prop (≤-trans a (inl idp)) a)

  =-to-≤↑ : {N M : ℕ↑} → N == M → N ≤↑ M
  =-to-≤↑ idp = λ n z → z

  ^↑-is-injective : {n m : ℕ} → (n ^↑) == (m ^↑) → n == m
  ^↑-is-injective {n} {m}  =
    λ x → ≤-antisymmetry (^↑-is-full (=-to-≤↑ x)) (^↑-is-full ((=-to-≤↑ (! x))))

  O↑≤↑ : (N : ℕ↑) → O↑ ≤↑ N
  O↑≤↑ N = λ n x → ^↑-is-monotone (O≤ n) n ≤:↑-refl

  _≤↑∞↑ : (N : ℕ↑) → N ≤↑ ∞↑
  N ≤↑∞↑ = λ n x → quodlibet (∞↑-has-no-upper-bounds n x)

  minℕ : (P : ℕ → Type₀) → ℕ↑
  minℕ P =
    (λ n → min-pred n) ,
      (λ n m x → Trunc-rec (implication n m x))
    where
      min-pred : (n : ℕ) → PropT₀
      min-pred n = ∃ (λ k → (P k) And (k ≤ n))

      implication : (n m : ℕ) (x : n ≤ m)
                    → Σ ℕ (λ k → (P k) And (k ≤ n))
                    → min-pred m holds
      implication n m x = λ {(k , p) → [ k , fst p , ≤-trans (snd p) x ] }

  {- Probably requires propositional resizing
  minℕ↑ : (P : ℕ↑ → Type₀) → ℕ↑
  minℕ↑ P =
    (λ n → min-pred n) ,
      (λ n m x → Trunc-rec (implication n m x))
    where
      min-pred : (n : ℕ) → PropT₀
      min-pred n = ∃ (λ K → (P K) And (K ≤:↑ n))

      implication : (n m : ℕ) (x : n ≤ m)
                    → Σ ℕ↑ (λ K → (P K) And (K ≤:↑ n))
                    → min-pred m holds
      implication n m x = λ {(k , p) → [ k , fst p , ≤-trans (snd p) x ] }
  -}


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

module polynomial-rings where

import rings
open rings public

{- We state the universal property of the polynomial ring R[x]. -}

precomp-universal-property-polynomial-Ring :
  {l1 l2 l3 : Level} (R : Ring l1) (S : Ring l2) (T : Ring l3)
  (f : hom-Ring R S) (s : type-Ring S) →
  hom-Ring S T → (hom-Ring R T) × (type-Ring T)
precomp-universal-property-polynomial-Ring R S T f s g =
  pair (comp-hom-Ring R S T g f) (map-hom-Ring S T g s)

universal-property-polynomial-Ring :
  (l : Level) {l1 l2 : Level} (R : Ring l1) (S : Ring l2)
  (f : hom-Ring R S) (s : type-Ring S) → UU (lsuc l ⊔ l1 ⊔ l2)
universal-property-polynomial-Ring l R S f s =
  (T : Ring l) →
  is-equiv (precomp-universal-property-polynomial-Ring R S T f s)


module RandomAccessList.Redundant where

open import RandomAccessList.Redundant.Core
open import RandomAccessList.Redundant.Core.Properties
open import BuildingBlock.BinaryLeafTree using (BinaryLeafTree; Node; Leaf)
import BuildingBlock.BinaryLeafTree as BLT

-- open import Data.Fin
open import Data.Num.Nat
open import Data.Num.Redundant
open import Data.Num.Redundant.Properties
open import Data.Nat renaming (_<_ to _<ℕ_)
open import Data.Nat.DivMod
open import Data.Nat.Etc
open import Data.Product
open import Relation.Nullary using (Dec; yes; no)
open import Relation.Nullary.Negation using (contradiction; contraposition)
open import Relation.Binary.PropositionalEquality as PropEq
    using (_≡_; _≢_; refl; cong; trans; sym; subst; inspect)

--------------------------------------------------------------------------------
--  Operations
--------------------------------------------------------------------------------

consₙ : ∀ {n A} → BinaryLeafTree A n → 0-2-RAL A n → 0-2-RAL A n
consₙ a []            = a 1∷ []
consₙ a (      0∷ xs) = a 1∷ xs
consₙ a (x     1∷ xs) = a , x 2∷ xs
consₙ a (x , y 2∷ xs) = a 1∷ consₙ (Node x y) xs

cons : ∀ {A} → A → 0-2-RAL A 0 → 0-2-RAL A 0
cons a xs = consₙ (Leaf a) xs

headₙ :  ∀ {n A} → (xs : 0-2-RAL A n) → ⟦ xs ⟧ₙ ≉ zero ∷ [] → BinaryLeafTree A n
headₙ []            p = contradiction (eq refl) p
headₙ (      0∷ xs) p = proj₁ (BLT.split (headₙ xs (contraposition (>>-zero ⟦ xs ⟧ₙ) p)))
headₙ (x     1∷ xs) p = x
headₙ (x , y 2∷ xs) p = x

head : ∀ {A} → (xs : 0-2-RAL A 0) → ⟦ xs ⟧ ≉ zero ∷ [] → A
head xs p = BLT.head (headₙ xs p)

tailₙ : ∀ {n A} → (xs : 0-2-RAL A n) → ⟦ xs ⟧ₙ ≉ zero ∷ [] → 0-2-RAL A n
tailₙ []            p = contradiction (eq refl) p
tailₙ (      0∷ xs) p = proj₂ (BLT.split (headₙ xs (contraposition (>>-zero ⟦ xs ⟧ₙ) p))) 1∷ tailₙ xs (contraposition (>>-zero ⟦ xs ⟧ₙ) p)
tailₙ (x     1∷ xs) p = 0∷ xs
tailₙ (x , y 2∷ xs) p = y 1∷ xs

tail : ∀ {A} → (xs : 0-2-RAL A 0) → ⟦ xs ⟧ ≉ zero ∷ [] → 0-2-RAL A 0
tail xs p = tailₙ xs p
--------------------------------------------------------------------------------
--  Searching
--------------------------------------------------------------------------------

data Finite : Redundant → Set where
    finite  : ∀ {bound}                         -- # of elements
            → (a : Redundant)                   -- inhabitant
            → {a<bound : a < bound}
            → Finite bound

elemAt : ∀ {n A} → (xs : 0-2-RAL A n) → Finite ⟦ xs ⟧ → A
elemAt {n} {A} [] (finite a {a<[]}) = contradiction a<[] {!   !}
-- elemAt {n} {A} [] (finite a {a<b}) = contradiction a<b (contraposition (map-≤ refl (to≡ (<<<-zero 0 ⟦ [] {A} {n} ⟧ {⟦[]⟧≈zero∷[] ([] {A} {n}) {refl}}))) (λ ()))
elemAt (0∷ xs) i = elemAt xs {!   !}
elemAt (x     1∷ xs) i = {!   !}
elemAt (x , y 2∷ xs) i = {!   !}

{-
-- data Occurrence : Set where
--    here : ∀ {a n} → a * Fin (2 ^ n) → Occurrence
--    there : Occurrence

transportFin : ∀ {a b} → a ≡ b → Fin a → Fin b
transportFin refl i = i

elemAt : ∀ {n A} → (xs : 0-2-RAL A n) → Fin ⟦ xs ⟧ → A
elemAt {zero} [] ()
elemAt {suc n} {A} []    i = elemAt {n} ([] {A} {n}) (transportFin (⟦[]⟧≡⟦[]⟧ {m = suc n} {n = n} {A = A}) i)
elemAt     (      0∷ xs) i = elemAt xs (transportFin (⟦0∷xs⟧≡⟦xs⟧ xs) i)
elemAt {n} (x     1∷ xs) i with (1 * 2 ^ n) ≤? toℕ i
elemAt     (x     1∷ xs) i | yes p rewrite splitIndex x xs = elemAt xs (reduce≥ i p)
elemAt {n} (x     1∷ xs) i | no ¬p with toℕ i divMod (2 ^ n)
elemAt (x 1∷ xs) i | no ¬p | result quotient remainder property = BLT.elemAt x remainder
elemAt {n} (x , y 2∷ xs) i with (2 * 2 ^ n) ≤? toℕ i
elemAt     (x , y 2∷ xs) i | yes p rewrite splitIndex2 x y xs = elemAt xs (reduce≥ i p)
elemAt {n} (x , y 2∷ xs) i | no ¬p with toℕ i divMod (2 ^ n)
elemAt (x , y 2∷ xs) i | no ¬p | result zero remainder property = BLT.elemAt x remainder
elemAt (x , y 2∷ xs) i | no ¬p | result (suc quotient) remainder property = BLT.elemAt y remainder
-}


module Shift (Gnd : Set)(U : Set)(El : U -> Set) where

open import Basics
open import Pr
open import Nom
import Kind
open Kind Gnd U El
import Cxt
open Cxt Kind
import Loc
open Loc Kind
import Term
open Term Gnd U El

popH : {D : Cxt}{M : Loc}{S T : Kind} ->
       D [ M / Head ]- T -> D [ M * S / Head ]- T
popH ( ` x -! xg )  = ` x -! xg
popH ( # v -! _ )   = # (pop v) -! _

weak : {G D : Cxt}{L M : Loc}{S : Kind} ->
       ({T : Kind} -> G [ L / Head ]- T -> D [ M / Head ]- T) ->
       {T : Kind} -> G [ L * S / Head ]- T -> D [ M * S / Head ]- T
weak rho (` x -! p )        = popH (rho (` x -! p))
weak rho (# top -! _ )      = # top -! _
weak rho (# (pop v) -! _ )  = popH (rho (# v -! _))

shift : {G D : Cxt}{L M : Loc} ->
  ({T : Kind} -> G [ L / Head ]- T -> D [ M / Head ]- T) ->
  {j : Jud}{T : Kind} -> G [ L / j ]- T  ->  D [ M / j ]- T
shift {G} {D} rho (t -! tg) = chug rho t tg where
  chug : {j : Jud}{L M : Loc} ->
    ({T : Kind} -> G [ L / Head ]- T -> D [ M / Head ]- T) ->
    {T : Kind}(t : L [ j ]- T) -> [| Good G t |] ->  D [ M / j ]- T
  chug {Head} rho h hg = rho ( h -! hg )
  chug rho [ s ] sg = G[ chug rho s sg ]
  chug rho (fn A f) fg = Gfn A (\ a -> chug rho (f a) (fg a))
  chug rho (\\ b) bg = G\\ (chug (weak rho) b bg)
  chug rho (a ^ s) sg = a G^ chug rho s sg
  chug rho (r & s) rsg = chug rho r (fst rsg) G& chug rho s (snd rsg)
  chug rho nil _ = Gnil
  chug rho (h $ s) hsg = chug rho h (fst hsg) G$ chug rho s (snd hsg)

bind : {G : Cxt}(x : Nom){Gx : [| G Hasn't x |]}{S : Kind}{j : Jud}{T : Kind} ->
       (G [ x - S ]) {Gx} [ EL / j ]- T -> G [ EL * S / j ]- T
bind {G} x {Gx}{S} = shift topx where
  topx : {T : Kind} -> (G [ x - S ]) {Gx} [ EL / Head ]- T ->
         G [ EL * S / Head ]- T
  topx (` y -! yg) with nomEq x y
  topx (` .x -! refl) | yes refl = # top -! _
  topx (` y -! yg)    | no _     = ` y -! yg
  topx (# () -! _)


module Issue274 where

-- data ⊥ : Set where

record U : Set where
  constructor roll
  field ap : U → U

-- lemma : U → ⊥
-- lemma (roll u) = lemma (u (roll u))

-- bottom : ⊥
-- bottom = lemma (roll λ x → x)


open import Nat
open import Prelude
open import List
open import contexts

module core where
  -- types
  data typ : Set where
    b     : typ
    ⦇·⦈    : typ
    _==>_ : typ → typ → typ
    _⊗_   : typ → typ → typ

  -- arrow type constructors bind very tightly
  infixr 25  _==>_
  infixr 25  _⊗_

  -- we use natural numbers as names throughout the development. here we
  -- provide some aliases to that the definitions below are more readable
  -- about what's being named, even though the underlying implementations
  -- are the same and there's no abstraction protecting you from breaking
  -- invariants.

  -- written `x` in math
  varname : Set
  varname = Nat

  -- written `u` in math
  holename : Set
  holename = Nat

  -- written `a` in math
  livelitname : Set
  livelitname = Nat

  -- "external expressions", or the middle layer of expressions. presented
  -- first because of the dependence structure below.
  data eexp : Set where
    c       : eexp
    _·:_    : eexp → typ → eexp
    X       : varname → eexp
    ·λ      : varname → eexp → eexp
    ·λ_[_]_ : varname → typ → eexp → eexp
    ⦇⦈[_]   : holename → eexp
    ⦇⌜_⌟⦈[_] : eexp → holename → eexp
    _∘_     : eexp → eexp → eexp
    ⟨_,_⟩   : eexp → eexp → eexp
    fst     : eexp → eexp
    snd     : eexp → eexp

  -- the type of type contexts, i.e. Γs in the judegments below
  tctx : Set
  tctx = typ ctx

  mutual
    -- identity substitution, substitition environments
    data env : Set where
      Id : (Γ : tctx) → env
      Subst : (d : iexp) → (y : varname) → env → env

    -- internal expressions, the bottom most layer of expresions. these are
    -- what the elaboration phase targets and the expressions on which
    -- evaluation is given.
    data iexp : Set where
      c         : iexp
      X         : varname → iexp
      ·λ_[_]_   : varname → typ → iexp → iexp
      ⦇⦈⟨_⟩     : (holename × env) → iexp
      ⦇⌜_⌟⦈⟨_⟩    : iexp → (holename × env) → iexp
      _∘_       : iexp → iexp → iexp
      _⟨_⇒_⟩    : iexp → typ → typ → iexp
      _⟨_⇒⦇⦈⇏_⟩ : iexp → typ → typ → iexp
      ⟨_,_⟩   : iexp → iexp → iexp
      fst     : iexp → iexp
      snd     : iexp → iexp

  -- convenient notation for chaining together two agreeable casts
  _⟨_⇒_⇒_⟩ : iexp → typ → typ → typ → iexp
  d ⟨ τ1 ⇒ τ2 ⇒ τ3 ⟩ = d ⟨ τ1 ⇒ τ2 ⟩ ⟨ τ2 ⇒ τ3 ⟩

  record livelitdef : Set where
    field
      expand : iexp
      model-type : typ
      expansion-type : typ

  -- unexpanded expressions, the outermost layer of expressions: a langauge
  -- exactly like eexp, but also with livelits
  mutual
    data uexp : Set where
      c       : uexp
      _·:_    : uexp → typ → uexp
      X       : varname → uexp
      ·λ      : varname → uexp → uexp
      ·λ_[_]_ : varname → typ → uexp → uexp
      ⦇⦈[_]   : holename → uexp
      ⦇⌜_⌟⦈[_]  : uexp → holename → uexp
      _∘_     : uexp → uexp → uexp
      ⟨_,_⟩   : uexp → uexp → uexp
      fst     : uexp → uexp
      snd     : uexp → uexp
      -- new forms below
      ＄_⟨_⁏_⟩[_] : (a : livelitname) → (d : iexp) → (ϕᵢ : List splice) → (u : holename) → uexp

    splice : Set
    splice = typ × uexp

  -- type consistency
  data _~_ : (t1 t2 : typ) → Set where
    TCRefl  : {τ : typ} → τ ~ τ
    TCHole1 : {τ : typ} → τ ~ ⦇·⦈
    TCHole2 : {τ : typ} → ⦇·⦈ ~ τ
    TCArr   : {τ1 τ2 τ1' τ2' : typ} →
               τ1 ~ τ1' →
               τ2 ~ τ2' →
               τ1 ==> τ2 ~ τ1' ==> τ2'
    TCProd  : {τ1 τ2 τ1' τ2' : typ} →
               τ1 ~ τ1' →
               τ2 ~ τ2' →
               (τ1 ⊗ τ2) ~ (τ1' ⊗ τ2')

  -- type inconsistency
  data _~̸_ : (τ1 τ2 : typ) → Set where
    ICBaseArr1 : {τ1 τ2 : typ} → b ~̸ τ1 ==> τ2
    ICBaseArr2 : {τ1 τ2 : typ} → τ1 ==> τ2 ~̸ b
    ICArr1 : {τ1 τ2 τ3 τ4 : typ} →
               τ1 ~̸ τ3 →
               τ1 ==> τ2 ~̸ τ3 ==> τ4
    ICArr2 : {τ1 τ2 τ3 τ4 : typ} →
               τ2 ~̸ τ4 →
               τ1 ==> τ2 ~̸ τ3 ==> τ4
    ICBaseProd1 : {τ1 τ2 : typ} → b ~̸ τ1 ⊗ τ2
    ICBaseProd2 : {τ1 τ2 : typ} → τ1 ⊗ τ2 ~̸ b
    ICProdArr1 : {τ1 τ2 τ3 τ4 : typ} →
                τ1 ==> τ2 ~̸ τ3 ⊗ τ4
    ICProdArr2 : {τ1 τ2 τ3 τ4 : typ} →
                τ1 ⊗ τ2 ~̸ τ3 ==> τ4
    ICProd1 : {τ1 τ2 τ3 τ4 : typ} →
               τ1 ~̸ τ3 →
               τ1 ⊗ τ2 ~̸ τ3 ⊗ τ4
    ICProd2 : {τ1 τ2 τ3 τ4 : typ} →
               τ2 ~̸ τ4 →
               τ1 ⊗ τ2 ~̸ τ3 ⊗ τ4

  --- matching for arrows
  data _▸arr_ : typ → typ → Set where
    MAHole : ⦇·⦈ ▸arr ⦇·⦈ ==> ⦇·⦈
    MAArr  : {τ1 τ2 : typ} → τ1 ==> τ2 ▸arr τ1 ==> τ2

  -- matching for products
  data _▸prod_ : typ → typ → Set where
    MPHole : ⦇·⦈ ▸prod ⦇·⦈ ⊗ ⦇·⦈
    MPProd  : {τ1 τ2 : typ} → τ1 ⊗ τ2 ▸prod τ1 ⊗ τ2

  -- the type of hole contexts, i.e. Δs in the judgements
  hctx : Set
  hctx = (typ ctx × typ) ctx

  -- notation for a triple to match the CMTT syntax
  _::_[_] : holename → typ → tctx → (holename × (tctx × typ))
  u :: τ [ Γ ] = u , (Γ , τ)

  -- the hole name u does not appear in the term e
  data hole-name-new : (e : eexp) (u : holename) → Set where
    HNConst : ∀{u} → hole-name-new c u
    HNAsc : ∀{e τ u} →
            hole-name-new e u →
            hole-name-new (e ·: τ) u
    HNVar : ∀{x u} → hole-name-new (X x) u
    HNLam1 : ∀{x e u} →
             hole-name-new e u →
             hole-name-new (·λ x e) u
    HNLam2 : ∀{x e u τ} →
             hole-name-new e u →
             hole-name-new (·λ x [ τ ] e) u
    HNHole : ∀{u u'} →
             u' ≠ u →
             hole-name-new (⦇⦈[ u' ]) u
    HNNEHole : ∀{u u' e} →
               u' ≠ u →
               hole-name-new e u →
               hole-name-new (⦇⌜ e ⌟⦈[ u' ]) u
    HNAp : ∀{ u e1 e2 } →
           hole-name-new e1 u →
           hole-name-new e2 u →
           hole-name-new (e1 ∘ e2) u
    HNFst  : ∀{ u e } →
           hole-name-new e u →
           hole-name-new (fst e) u
    HNSnd  : ∀{ u e } →
           hole-name-new e u →
           hole-name-new (snd e) u
    HNPair : ∀{ u e1 e2 } →
           hole-name-new e1 u →
           hole-name-new e2 u →
           hole-name-new ⟨ e1 , e2 ⟩ u

  -- two terms that do not share any hole names
  data holes-disjoint : (e1 : eexp) → (e2 : eexp) → Set where
    HDConst : ∀{e} → holes-disjoint c e
    HDAsc : ∀{e1 e2 τ} → holes-disjoint e1 e2 → holes-disjoint (e1 ·: τ) e2
    HDVar : ∀{x e} → holes-disjoint (X x) e
    HDLam1 : ∀{x e1 e2} → holes-disjoint e1 e2 → holes-disjoint (·λ x e1) e2
    HDLam2 : ∀{x e1 e2 τ} → holes-disjoint e1 e2 → holes-disjoint (·λ x [ τ ] e1) e2
    HDHole : ∀{u e2} → hole-name-new e2 u → holes-disjoint (⦇⦈[ u ]) e2
    HDNEHole : ∀{u e1 e2} → hole-name-new e2 u → holes-disjoint e1 e2 → holes-disjoint (⦇⌜ e1 ⌟⦈[ u ]) e2
    HDAp :  ∀{e1 e2 e3} → holes-disjoint e1 e3 → holes-disjoint e2 e3 → holes-disjoint (e1 ∘ e2) e3
    HDFst  : ∀{e1 e2} → holes-disjoint e1 e2 → holes-disjoint (fst e1) e2
    HDSnd  : ∀{e1 e2} → holes-disjoint e1 e2 → holes-disjoint (snd e1) e2
    HDPair : ∀{e1 e2 e3} → holes-disjoint e1 e3 → holes-disjoint e2 e3 → holes-disjoint ⟨ e1 , e2 ⟩ e3

  -- bidirectional type checking judgements for eexp
  mutual
    -- synthesis
    data _⊢_=>_ : (Γ : tctx) (e : eexp) (τ : typ) → Set where
      SConst  : {Γ : tctx} → Γ ⊢ c => b
      SAsc    : {Γ : tctx} {e : eexp} {τ : typ} →
                 Γ ⊢ e <= τ →
                 Γ ⊢ (e ·: τ) => τ
      SVar    : {Γ : tctx} {τ : typ} {x : varname} →
                 (x , τ) ∈ Γ →
                 Γ ⊢ X x => τ
      SAp     : {Γ : tctx} {e1 e2 : eexp} {τ τ1 τ2 : typ} →
                 holes-disjoint e1 e2 →
                 Γ ⊢ e1 => τ1 →
                 τ1 ▸arr τ2 ==> τ →
                 Γ ⊢ e2 <= τ2 →
                 Γ ⊢ (e1 ∘ e2) => τ
      SEHole  : {Γ : tctx} {u : holename} → Γ ⊢ ⦇⦈[ u ] => ⦇·⦈
      SNEHole : {Γ : tctx} {e : eexp} {τ : typ} {u : holename} →
                 hole-name-new e u →
                 Γ ⊢ e => τ →
                 Γ ⊢ ⦇⌜ e ⌟⦈[ u ] => ⦇·⦈
      SLam    : {Γ : tctx} {e : eexp} {τ1 τ2 : typ} {x : varname} →
                 x # Γ →
                 (Γ ,, (x , τ1)) ⊢ e => τ2 →
                 Γ ⊢ ·λ x [ τ1 ] e => τ1 ==> τ2
      SFst    : ∀{ e τ τ1 τ2 Γ} →
                Γ ⊢ e => τ →
                τ ▸prod τ1 ⊗ τ2 →
                Γ ⊢ fst e => τ1
      SSnd    : ∀{ e τ τ1 τ2 Γ} →
                Γ ⊢ e => τ →
                τ ▸prod τ1 ⊗ τ2 →
                Γ ⊢ snd e => τ2
      SPair   : ∀{ e1 e2 τ1 τ2 Γ} →
                holes-disjoint e1 e2 →
                Γ ⊢ e1 => τ1 →
                Γ ⊢ e2 => τ2 →
                Γ ⊢ ⟨ e1 , e2 ⟩ => τ1 ⊗ τ2

    -- analysis
    data _⊢_<=_ : (Γ : tctx) (e : eexp) (τ : typ) → Set where
      ASubsume : {Γ : tctx} {e : eexp} {τ τ' : typ} →
                 Γ ⊢ e => τ' →
                 τ ~ τ' →
                 Γ ⊢ e <= τ
      ALam : {Γ : tctx} {e : eexp} {τ τ1 τ2 : typ} {x : varname} →
                 x # Γ →
                 τ ▸arr τ1 ==> τ2 →
                 (Γ ,, (x , τ1)) ⊢ e <= τ2 →
                 Γ ⊢ (·λ x e) <= τ

  -- those types without holes
  data _tcomplete : typ → Set where
    TCBase : b tcomplete
    TCArr : ∀{τ1 τ2} → τ1 tcomplete → τ2 tcomplete → (τ1 ==> τ2) tcomplete
    TCProd : ∀{τ1 τ2} → τ1 tcomplete → τ2 tcomplete → (τ1 ⊗ τ2) tcomplete

  -- those external expressions without holes
  data _ecomplete : eexp → Set where
    ECConst : c ecomplete
    ECAsc : ∀{τ e} → τ tcomplete → e ecomplete → (e ·: τ) ecomplete
    ECVar : ∀{x} → (X x) ecomplete
    ECLam1 : ∀{x e} → e ecomplete → (·λ x e) ecomplete
    ECLam2 : ∀{x e τ} → e ecomplete → τ tcomplete → (·λ x [ τ ] e) ecomplete
    ECAp : ∀{e1 e2} → e1 ecomplete → e2 ecomplete → (e1 ∘ e2) ecomplete
    ECFst : ∀{e} → e ecomplete → (fst e) ecomplete
    ECSnd : ∀{e} → e ecomplete → (snd e) ecomplete
    ECPair : ∀{e1 e2} → e1 ecomplete → e2 ecomplete → ⟨ e1 , e2 ⟩ ecomplete

  -- those internal expressions without holes
  data _dcomplete : iexp → Set where
    DCVar : ∀{x} → (X x) dcomplete
    DCConst : c dcomplete
    DCLam : ∀{x τ d} → d dcomplete → τ tcomplete → (·λ x [ τ ] d) dcomplete
    DCAp : ∀{d1 d2} → d1 dcomplete → d2 dcomplete → (d1 ∘ d2) dcomplete
    DCCast : ∀{d τ1 τ2} → d dcomplete → τ1 tcomplete → τ2 tcomplete → (d ⟨ τ1 ⇒ τ2 ⟩) dcomplete
    DCFst : ∀{d} → d dcomplete → (fst d) dcomplete
    DCSnd : ∀{d} → d dcomplete → (snd d) dcomplete
    DCPair : ∀{d1 d2} → d1 dcomplete → d2 dcomplete → ⟨ d1 , d2 ⟩ dcomplete

  -- contexts that only produce complete types
  _gcomplete : tctx → Set
  Γ gcomplete = (x : varname) (τ : typ) → (x , τ) ∈ Γ → τ tcomplete

  -- those internal expressions where every cast is the identity cast and
  -- there are no failed casts
  data cast-id : iexp → Set where
    CIConst  : cast-id c
    CIVar    : ∀{x} → cast-id (X x)
    CILam    : ∀{x τ d} → cast-id d → cast-id (·λ x [ τ ] d)
    CIHole   : ∀{u} → cast-id (⦇⦈⟨ u ⟩)
    CINEHole : ∀{d u} → cast-id d → cast-id (⦇⌜ d ⌟⦈⟨ u ⟩)
    CIAp     : ∀{d1 d2} → cast-id d1 → cast-id d2 → cast-id (d1 ∘ d2)
    CICast   : ∀{d τ} → cast-id d → cast-id (d ⟨ τ ⇒ τ ⟩)
    CIFst    : ∀{d} → cast-id d → cast-id (fst d)
    CISnd    : ∀{d} → cast-id d → cast-id (snd d)
    CIPair   : ∀{d1 d2} → cast-id d1 → cast-id d2 → cast-id ⟨ d1 , d2 ⟩

  -- expansion
  mutual
    -- synthesis
    data _⊢_⇒_~>_⊣_ : (Γ : tctx) (e : eexp) (τ : typ) (d : iexp) (Δ : hctx) → Set where
      ESConst : ∀{Γ} → Γ ⊢ c ⇒ b ~> c ⊣ ∅
      ESVar   : ∀{Γ x τ} → (x , τ) ∈ Γ →
                         Γ ⊢ X x ⇒ τ ~> X x ⊣ ∅
      ESLam   : ∀{Γ x τ1 τ2 e d Δ } →
                     (x # Γ) →
                     (Γ ,, (x , τ1)) ⊢ e ⇒ τ2 ~> d ⊣ Δ →
                      Γ ⊢ ·λ x [ τ1 ] e ⇒ (τ1 ==> τ2) ~> ·λ x [ τ1 ] d ⊣ Δ
      ESAp : ∀{Γ e1 τ τ1 τ1' τ2 τ2' d1 Δ1 e2 d2 Δ2 } →
              holes-disjoint e1 e2 →
              Δ1 ## Δ2 →
              Γ ⊢ e1 => τ1 →
              τ1 ▸arr τ2 ==> τ →
              Γ ⊢ e1 ⇐ (τ2 ==> τ) ~> d1 :: τ1' ⊣ Δ1 →
              Γ ⊢ e2 ⇐ τ2 ~> d2 :: τ2' ⊣ Δ2 →
              Γ ⊢ e1 ∘ e2 ⇒ τ ~> (d1 ⟨ τ1' ⇒ τ2 ==> τ ⟩) ∘ (d2 ⟨ τ2' ⇒ τ2 ⟩) ⊣ (Δ1 ∪ Δ2)
      ESEHole : ∀{ Γ u } →
                Γ ⊢ ⦇⦈[ u ] ⇒ ⦇·⦈ ~> ⦇⦈⟨ u , Id Γ ⟩ ⊣  ■ (u :: ⦇·⦈ [ Γ ])
      ESNEHole : ∀{ Γ e τ d u Δ } →
                 Δ ## (■ (u , Γ , ⦇·⦈)) →
                 Γ ⊢ e ⇒ τ ~> d ⊣ Δ →
                 Γ ⊢ ⦇⌜ e ⌟⦈[ u ] ⇒ ⦇·⦈ ~> ⦇⌜ d ⌟⦈⟨ u , Id Γ  ⟩ ⊣ (Δ ,, u :: ⦇·⦈ [ Γ ])
      ESAsc : ∀ {Γ e τ d τ' Δ} →
                 Γ ⊢ e ⇐ τ ~> d :: τ' ⊣ Δ →
                 Γ ⊢ (e ·: τ) ⇒ τ ~> d ⟨ τ' ⇒ τ ⟩ ⊣ Δ
      ESFst  : ∀{Γ e τ τ' d τ1 τ2 Δ} →
                 Γ ⊢ e => τ →
                 τ ▸prod τ1 ⊗ τ2 →
                 Γ ⊢ e ⇐ τ1 ⊗ τ2 ~> d :: τ' ⊣ Δ →
                 Γ ⊢ fst e ⇒ τ1 ~> fst (d ⟨ τ' ⇒ τ1 ⊗ τ2 ⟩) ⊣ Δ
      ESSnd  : ∀{Γ e τ τ' d τ1 τ2 Δ} →
                 Γ ⊢ e => τ →
                 τ ▸prod τ1 ⊗ τ2 →
                 Γ ⊢ e ⇐ τ1 ⊗ τ2 ~> d :: τ' ⊣ Δ →
                 Γ ⊢ snd e ⇒ τ2 ~> snd (d ⟨ τ' ⇒ τ1 ⊗ τ2 ⟩) ⊣ Δ
      ESPair : ∀{Γ e1 τ1 d1 Δ1 e2 τ2 d2 Δ2} →
                 holes-disjoint e1 e2 →
                 Δ1 ## Δ2 →
                 Γ ⊢ e1 ⇒ τ1 ~> d1 ⊣ Δ1 →
                 Γ ⊢ e2 ⇒ τ2 ~> d2 ⊣ Δ2 →
                 Γ ⊢ ⟨ e1 , e2 ⟩ ⇒ τ1 ⊗ τ2 ~> ⟨ d1 , d2 ⟩ ⊣ (Δ1 ∪ Δ2)

    -- analysis
    data _⊢_⇐_~>_::_⊣_ : (Γ : tctx) (e : eexp) (τ : typ) (d : iexp) (τ' : typ) (Δ : hctx) → Set where
      EALam : ∀{Γ x τ τ1 τ2 e d τ2' Δ } →
              (x # Γ) →
              τ ▸arr τ1 ==> τ2 →
              (Γ ,, (x , τ1)) ⊢ e ⇐ τ2 ~> d :: τ2' ⊣ Δ →
              Γ ⊢ ·λ x e ⇐ τ ~> ·λ x [ τ1 ] d :: τ1 ==> τ2' ⊣ Δ
      EASubsume : ∀{e Γ τ' d Δ τ} →
                  ((u : holename) → e ≠ ⦇⦈[ u ]) →
                  ((e' : eexp) (u : holename) → e ≠ ⦇⌜ e' ⌟⦈[ u ]) →
                  Γ ⊢ e ⇒ τ' ~> d ⊣ Δ →
                  τ ~ τ' →
                  Γ ⊢ e ⇐ τ ~> d :: τ' ⊣ Δ
      EAEHole : ∀{ Γ u τ  } →
                Γ ⊢ ⦇⦈[ u ] ⇐ τ ~> ⦇⦈⟨ u , Id Γ  ⟩ :: τ ⊣ ■ (u :: τ [ Γ ])
      EANEHole : ∀{ Γ e u τ d τ' Δ  } →
                 Δ ## (■ (u , Γ , τ)) →
                 Γ ⊢ e ⇒ τ' ~> d ⊣ Δ →
                 Γ ⊢ ⦇⌜ e ⌟⦈[ u ] ⇐ τ ~> ⦇⌜ d ⌟⦈⟨ u , Id Γ  ⟩ :: τ ⊣ (Δ ,, u :: τ [ Γ ])

  -- ground types
  data _ground : (τ : typ) → Set where
    GBase : b ground
    GHole : ⦇·⦈ ==> ⦇·⦈ ground
    GProd : ⦇·⦈ ⊗ ⦇·⦈ ground

  mutual
    -- substitution typing
    data _,_⊢_:s:_ : hctx → tctx → env → tctx → Set where
      STAId : ∀{Γ Γ' Δ} →
                  ((x : varname) (τ : typ) → (x , τ) ∈ Γ' → (x , τ) ∈ Γ) →
                  Δ , Γ ⊢ Id Γ' :s: Γ'
      STASubst : ∀{Γ Δ σ y Γ' d τ } →
               Δ , Γ ,, (y , τ) ⊢ σ :s: Γ' →
               Δ , Γ ⊢ d :: τ →
               Δ , Γ ⊢ Subst d y σ :s: Γ'

    -- type assignment
    data _,_⊢_::_ : (Δ : hctx) (Γ : tctx) (d : iexp) (τ : typ) → Set where
      TAConst : ∀{Δ Γ} → Δ , Γ ⊢ c :: b
      TAVar : ∀{Δ Γ x τ} → (x , τ) ∈ Γ → Δ , Γ ⊢ X x :: τ
      TALam : ∀{ Δ Γ x τ1 d τ2} →
              x # Γ →
              Δ , (Γ ,, (x , τ1)) ⊢ d :: τ2 →
              Δ , Γ ⊢ ·λ x [ τ1 ] d :: (τ1 ==> τ2)
      TAAp : ∀{ Δ Γ d1 d2 τ1 τ} →
             Δ , Γ ⊢ d1 :: τ1 ==> τ →
             Δ , Γ ⊢ d2 :: τ1 →
             Δ , Γ ⊢ d1 ∘ d2 :: τ
      TAEHole : ∀{ Δ Γ σ u Γ' τ} →
                (u , (Γ' , τ)) ∈ Δ →
                Δ , Γ ⊢ σ :s: Γ' →
                Δ , Γ ⊢ ⦇⦈⟨ u , σ ⟩ :: τ
      TANEHole : ∀ { Δ Γ d τ' Γ' u σ τ } →
                 (u , (Γ' , τ)) ∈ Δ →
                 Δ , Γ ⊢ d :: τ' →
                 Δ , Γ ⊢ σ :s: Γ' →
                 Δ , Γ ⊢ ⦇⌜ d ⌟⦈⟨ u , σ ⟩ :: τ
      TACast : ∀{ Δ Γ d τ1 τ2} →
             Δ , Γ ⊢ d :: τ1 →
             τ1 ~ τ2 →
             Δ , Γ ⊢ d ⟨ τ1 ⇒ τ2 ⟩ :: τ2
      TAFailedCast : ∀{Δ Γ d τ1 τ2} →
             Δ , Γ ⊢ d :: τ1 →
             τ1 ground →
             τ2 ground →
             τ1 ≠ τ2 →
             Δ , Γ ⊢ d ⟨ τ1 ⇒⦇⦈⇏ τ2 ⟩ :: τ2
      TAFst : ∀{Δ Γ d τ1 τ2} →
             Δ , Γ ⊢ d :: τ1 ⊗ τ2 →
             Δ , Γ ⊢ fst d :: τ1
      TASnd : ∀{Δ Γ d τ1 τ2} →
             Δ , Γ ⊢ d :: τ1 ⊗ τ2 →
             Δ , Γ ⊢ snd d :: τ2
      TAPair : ∀{Δ Γ d1 d2 τ1 τ2} →
             Δ , Γ ⊢ d1 :: τ1 →
             Δ , Γ ⊢ d2 :: τ2 →
             Δ , Γ ⊢ ⟨ d1 , d2 ⟩ :: τ1 ⊗ τ2

  -- substitution
  [_/_]_ : iexp → varname → iexp → iexp
  [ d / y ] c = c
  [ d / y ] X x
    with natEQ x y
  [ d / y ] X .y | Inl refl = d
  [ d / y ] X x  | Inr neq = X x
  [ d / y ] (·λ x [ x₁ ] d')
    with natEQ x y
  [ d / y ] (·λ .y [ τ ] d') | Inl refl = ·λ y [ τ ] d'
  [ d / y ] (·λ x [ τ ] d')  | Inr x₁ = ·λ x [ τ ] ( [ d / y ] d')
  [ d / y ] ⦇⦈⟨ u , σ ⟩ = ⦇⦈⟨ u , Subst d y σ ⟩
  [ d / y ] ⦇⌜ d' ⌟⦈⟨ u , σ  ⟩ =  ⦇⌜ [ d / y ] d' ⌟⦈⟨ u , Subst d y σ ⟩
  [ d / y ] (d1 ∘ d2) = ([ d / y ] d1) ∘ ([ d / y ] d2)
  [ d / y ] (d' ⟨ τ1 ⇒ τ2 ⟩ ) = ([ d / y ] d') ⟨ τ1 ⇒ τ2 ⟩
  [ d / y ] (d' ⟨ τ1 ⇒⦇⦈⇏ τ2 ⟩ ) = ([ d / y ] d') ⟨ τ1 ⇒⦇⦈⇏ τ2 ⟩
  [ d / y ] ⟨ d1 , d2 ⟩ = ⟨ [ d / y ] d1 , [ d / y ] d2 ⟩
  [ d / y ] (fst d') = fst ([ d / y ] d')
  [ d / y ] (snd d') = snd ([ d / y ] d')

  -- applying an environment to an expression
  apply-env : env → iexp → iexp
  apply-env (Id Γ) d = d
  apply-env (Subst d y σ) d' = [ d / y ] ( apply-env σ d')

  -- values
  data _val : (d : iexp) → Set where
    VConst : c val
    VLam   : ∀{x τ d} → (·λ x [ τ ] d) val
    VPair  : ∀{d1 d2} → d1 val → d2 val → ⟨ d1 , d2 ⟩ val

  -- boxed values
  data _boxedval : (d : iexp) → Set where
    BVVal : ∀{d} → d val → d boxedval
    BVPair : ∀{d1 d2} → d1 boxedval → d2 boxedval → ⟨ d1 , d2 ⟩ boxedval
    BVArrCast : ∀{ d τ1 τ2 τ3 τ4 } →
                τ1 ==> τ2 ≠ τ3 ==> τ4 →
                d boxedval →
                d ⟨ (τ1 ==> τ2) ⇒ (τ3 ==> τ4) ⟩ boxedval
    BVProdCast : ∀{ d τ1 τ2 τ3 τ4 } →
                τ1 ⊗ τ2 ≠ τ3 ⊗ τ4 →
                d boxedval →
                d ⟨ (τ1 ⊗ τ2) ⇒ (τ3 ⊗ τ4) ⟩ boxedval
    BVHoleCast : ∀{ τ d } → τ ground → d boxedval → d ⟨ τ ⇒ ⦇·⦈ ⟩ boxedval

  mutual
    -- indeterminate forms
    data _indet : (d : iexp) → Set where
      IEHole : ∀{u σ} → ⦇⦈⟨ u , σ ⟩ indet
      INEHole : ∀{d u σ} → d final → ⦇⌜ d ⌟⦈⟨ u , σ ⟩ indet
      IAp : ∀{d1 d2} → ((τ1 τ2 τ3 τ4 : typ) (d1' : iexp) →
                       d1 ≠ (d1' ⟨(τ1 ==> τ2) ⇒ (τ3 ==> τ4)⟩)) →
                       d1 indet →
                       d2 final →
                       (d1 ∘ d2) indet
      IFst   : ∀{d} →
               d indet →
               (∀{d1 d2} → d ≠ ⟨ d1 , d2 ⟩) →
               (∀{d' τ1 τ2 τ3 τ4} → d ≠ (d' ⟨ τ1 ⊗ τ2 ⇒ τ3 ⊗ τ4 ⟩)) →
               (fst d) indet
      ISnd   : ∀{d} →
               d indet →
               (∀{d1 d2} → d ≠ ⟨ d1 , d2 ⟩) →
               (∀{d' τ1 τ2 τ3 τ4} → d ≠ (d' ⟨ τ1 ⊗ τ2 ⇒ τ3 ⊗ τ4 ⟩)) →
               (snd d) indet
      IPair1 : ∀{d1 d2} →
               d1 indet →
               d2 final →
               ⟨ d1 , d2 ⟩ indet
      IPair2 : ∀{d1 d2} →
               d1 final →
               d2 indet →
               ⟨ d1 , d2 ⟩ indet
      ICastArr : ∀{d τ1 τ2 τ3 τ4} →
                 τ1 ==> τ2 ≠ τ3 ==> τ4 →
                 d indet →
                 d ⟨ (τ1 ==> τ2) ⇒ (τ3 ==> τ4) ⟩ indet
      ICastProd : ∀{d τ1 τ2 τ3 τ4} →
                 τ1 ⊗ τ2 ≠ τ3 ⊗ τ4 →
                 d indet →
                 d ⟨ (τ1 ⊗ τ2) ⇒ (τ3 ⊗ τ4) ⟩ indet
      ICastGroundHole : ∀{ τ d } →
                        τ ground →
                        d indet →
                        d ⟨ τ ⇒  ⦇·⦈ ⟩ indet
      ICastHoleGround : ∀ { d τ } →
                        ((d' : iexp) (τ' : typ) → d ≠ (d' ⟨ τ' ⇒ ⦇·⦈ ⟩)) →
                        d indet →
                        τ ground →
                        d ⟨ ⦇·⦈ ⇒ τ ⟩ indet
      IFailedCast : ∀{ d τ1 τ2 } →
                    d final →
                    τ1 ground →
                    τ2 ground →
                    τ1 ≠ τ2 →
                    d ⟨ τ1 ⇒⦇⦈⇏ τ2 ⟩ indet

    -- final expressions
    data _final : (d : iexp) → Set where
      FBoxedVal : ∀{d} → d boxedval → d final
      FIndet    : ∀{d} → d indet    → d final

  -- contextual dynamics

  -- evaluation contexts
  data ectx : Set where
    ⊙ : ectx
    _∘₁_ : ectx → iexp → ectx
    _∘₂_ : iexp → ectx → ectx
    ⦇⌜_⌟⦈⟨_⟩ : ectx → (holename × env ) → ectx
    fst·_ : ectx → ectx
    snd·_ : ectx → ectx
    ⟨_,_⟩₁ : ectx → iexp → ectx
    ⟨_,_⟩₂ : iexp → ectx → ectx
    _⟨_⇒_⟩ : ectx → typ → typ → ectx
    _⟨_⇒⦇·⦈⇏_⟩ : ectx → typ → typ → ectx

  -- note: this judgement is redundant: in the absence of the premises in
  -- the red brackets, all syntactically well formed ectxs are valid. with
  -- finality premises, that's not true, and that would propagate through
  -- additions to the calculus. so we leave it here for clarity but note
  -- that, as written, in any use case its either trival to prove or
  -- provides no additional information

   --ε is an evaluation context
  data _evalctx : (ε : ectx) → Set where
    ECDot : ⊙ evalctx
    ECAp1 : ∀{d ε} →
            ε evalctx →
            (ε ∘₁ d) evalctx
    ECAp2 : ∀{d ε} →
            -- d final → -- red brackets
            ε evalctx →
            (d ∘₂ ε) evalctx
    ECNEHole : ∀{ε u σ} →
               ε evalctx →
               ⦇⌜ ε ⌟⦈⟨ u , σ ⟩ evalctx
    ECFst   : ∀{ε} →
              (fst· ε) evalctx
    ECSnd   : ∀{ε} →
              (snd· ε) evalctx
    ECPair1 : ∀{d ε} →
              ε evalctx →
              ⟨ ε , d ⟩₁ evalctx
    ECPair2 : ∀{d ε} →
              -- d final → -- red brackets
              ε evalctx →
              ⟨ d , ε ⟩₂ evalctx
    ECCast : ∀{ ε τ1 τ2} →
             ε evalctx →
             (ε ⟨ τ1 ⇒ τ2 ⟩) evalctx
    ECFailedCast : ∀{ ε τ1 τ2 } →
                   ε evalctx →
                   ε ⟨ τ1 ⇒⦇·⦈⇏ τ2 ⟩ evalctx

  -- d is the result of filling the hole in ε with d'
  data _==_⟦_⟧ : (d : iexp) (ε : ectx) (d' : iexp) → Set where
    FHOuter : ∀{d} → d == ⊙ ⟦ d ⟧
    FHAp1 : ∀{d1 d1' d2 ε} →
           d1 == ε ⟦ d1' ⟧ →
           (d1 ∘ d2) == (ε ∘₁ d2) ⟦ d1' ⟧
    FHAp2 : ∀{d1 d2 d2' ε} →
           -- d1 final → -- red brackets
           d2 == ε ⟦ d2' ⟧ →
           (d1 ∘ d2) == (d1 ∘₂ ε) ⟦ d2' ⟧
    FHNEHole : ∀{ d d' ε u σ} →
              d == ε ⟦ d' ⟧ →
              ⦇⌜ d ⌟⦈⟨ (u , σ ) ⟩ ==  ⦇⌜ ε ⌟⦈⟨ (u , σ ) ⟩ ⟦ d' ⟧
    FHFst   : ∀{d d' ε} →
              d == ε ⟦ d' ⟧ →
              fst d == (fst· ε) ⟦ d' ⟧
    FHSnd   : ∀{d d' ε} →
              d == ε ⟦ d' ⟧ →
              snd d == (snd· ε) ⟦ d' ⟧
    FHPair1 : ∀{d1 d1' d2 ε} →
              d1 == ε ⟦ d1' ⟧ →
              ⟨ d1 , d2 ⟩ == ⟨ ε , d2 ⟩₁ ⟦ d1' ⟧
    FHPair2 : ∀{d1 d2 d2' ε} →
              d2 == ε ⟦ d2' ⟧ →
              ⟨ d1 , d2 ⟩ == ⟨ d1 , ε ⟩₂ ⟦ d2' ⟧
    FHCast : ∀{ d d' ε τ1 τ2 } →
            d == ε ⟦ d' ⟧ →
            d ⟨ τ1 ⇒ τ2 ⟩ == ε ⟨ τ1 ⇒ τ2 ⟩ ⟦ d' ⟧
    FHFailedCast : ∀{ d d' ε τ1 τ2} →
            d == ε ⟦ d' ⟧ →
            (d ⟨ τ1 ⇒⦇⦈⇏ τ2 ⟩) == (ε ⟨ τ1 ⇒⦇·⦈⇏ τ2 ⟩) ⟦ d' ⟧

  -- matched ground types
  data _▸gnd_ : typ → typ → Set where
    MGArr : ∀{τ1 τ2} →
            (τ1 ==> τ2) ≠ (⦇·⦈ ==> ⦇·⦈) →
            (τ1 ==> τ2) ▸gnd (⦇·⦈ ==> ⦇·⦈)
    MGProd : ∀{τ1 τ2} →
            (τ1 ⊗ τ2) ≠ (⦇·⦈ ⊗ ⦇·⦈) →
            (τ1 ⊗ τ2) ▸gnd (⦇·⦈ ⊗ ⦇·⦈)

  -- instruction transition judgement
  data _→>_ : (d d' : iexp) → Set where
    ITLam : ∀{ x τ d1 d2 } →
            -- d2 final → -- red brackets
            ((·λ x [ τ ] d1) ∘ d2) →> ([ d2 / x ] d1)
    ITFst : ∀{d1 d2} →
            -- d1 final → -- red brackets
            -- d2 final → -- red brackets
            fst ⟨ d1 , d2 ⟩ →> d1
    ITSnd : ∀{d1 d2} →
            -- d1 final → -- red brackets
            -- d2 final → -- red brackets
            snd ⟨ d1 , d2 ⟩ →> d2
    ITCastID : ∀{d τ } →
               -- d final → -- red brackets
               (d ⟨ τ ⇒ τ ⟩) →> d
    ITCastSucceed : ∀{d τ } →
                    -- d final → -- red brackets
                    τ ground →
                    (d ⟨ τ ⇒ ⦇·⦈ ⇒ τ ⟩) →> d
    ITCastFail : ∀{ d τ1 τ2} →
                 -- d final → -- red brackets
                 τ1 ground →
                 τ2 ground →
                 τ1 ≠ τ2 →
                 (d ⟨ τ1 ⇒ ⦇·⦈ ⇒ τ2 ⟩) →> (d ⟨ τ1 ⇒⦇⦈⇏ τ2 ⟩)
    ITApCast : ∀{d1 d2 τ1 τ2 τ1' τ2' } →
               -- d1 final → -- red brackets
               -- d2 final → -- red brackets
               ((d1 ⟨ (τ1 ==> τ2) ⇒ (τ1' ==> τ2')⟩) ∘ d2) →> ((d1 ∘ (d2 ⟨ τ1' ⇒ τ1 ⟩)) ⟨ τ2 ⇒ τ2' ⟩)
    ITFstCast : ∀{d τ1 τ2 τ1' τ2' } →
               -- d final → -- red brackets
               fst (d ⟨ τ1 ⊗ τ2 ⇒ τ1' ⊗ τ2' ⟩) →> ((fst d) ⟨ τ1 ⇒ τ1' ⟩)
    ITSndCast : ∀{d τ1 τ2 τ1' τ2' } →
               -- d final → -- red brackets
               snd (d ⟨ τ1 ⊗ τ2 ⇒ τ1' ⊗ τ2' ⟩) →> ((snd d) ⟨ τ2 ⇒ τ2' ⟩)
    ITGround : ∀{ d τ τ'} →
               -- d final → -- red brackets
               τ ▸gnd τ' →
               (d ⟨ τ ⇒ ⦇·⦈ ⟩) →> (d ⟨ τ ⇒ τ' ⇒ ⦇·⦈ ⟩)
    ITExpand : ∀{d τ τ' } →
               -- d final → -- red brackets
               τ ▸gnd τ' →
               (d ⟨ ⦇·⦈ ⇒ τ ⟩) →> (d ⟨ ⦇·⦈ ⇒ τ' ⇒ τ ⟩)

  -- single step (in contextual evaluation sense)
  data _↦_ : (d d' : iexp) → Set where
    Step : ∀{ d d0 d' d0' ε} →
           d == ε ⟦ d0 ⟧ →
           d0 →> d0' →
           d' == ε ⟦ d0' ⟧ →
           d ↦ d'

  -- reflexive transitive closure of single steps into multi steps
  data _↦*_ : (d d' : iexp) → Set where
    MSRefl : ∀{d} → d ↦* d
    MSStep : ∀{d d' d''} →
                 d ↦ d' →
                 d' ↦* d'' →
                 d  ↦* d''

  -- freshness
  mutual
    -- ... with respect to a hole context
    data envfresh : varname → env → Set where
      EFId : ∀{x Γ} → x # Γ → envfresh x (Id Γ)
      EFSubst : ∀{x d σ y} → fresh x d
                           → envfresh x σ
                           → x ≠ y
                           → envfresh x (Subst d y σ)

    -- ... for inernal expressions
    data fresh : varname → iexp → Set where
      FConst : ∀{x} → fresh x c
      FVar   : ∀{x y} → x ≠ y → fresh x (X y)
      FLam   : ∀{x y τ d} → x ≠ y → fresh x d → fresh x (·λ y [ τ ] d)
      FHole  : ∀{x u σ} → envfresh x σ → fresh x (⦇⦈⟨ u , σ ⟩)
      FNEHole : ∀{x d u σ} → envfresh x σ → fresh x d → fresh x (⦇⌜ d ⌟⦈⟨ u , σ ⟩)
      FAp     : ∀{x d1 d2} → fresh x d1 → fresh x d2 → fresh x (d1 ∘ d2)
      FCast   : ∀{x d τ1 τ2} → fresh x d → fresh x (d ⟨ τ1 ⇒ τ2 ⟩)
      FFailedCast : ∀{x d τ1 τ2} → fresh x d → fresh x (d ⟨ τ1 ⇒⦇⦈⇏ τ2 ⟩)
      FFst  : ∀{x d} → fresh x d → fresh x (fst d)
      FSnd  : ∀{x d} → fresh x d → fresh x (snd d)
      FPair : ∀{x d1 d2} → fresh x d1 → fresh x d2 → fresh x ⟨ d1 , d2 ⟩

  -- ... for external expressions
  data freshe : varname → eexp → Set where
    FRHConst : ∀{x} → freshe x c
    FRHAsc   : ∀{x e τ} → freshe x e → freshe x (e ·: τ)
    FRHVar   : ∀{x y} → x ≠ y → freshe x (X y)
    FRHLam1  : ∀{x y e} → x ≠ y → freshe x e → freshe x (·λ y e)
    FRHLam2  : ∀{x τ e y} → x ≠ y → freshe x e → freshe x (·λ y [ τ ] e)
    FRHEHole : ∀{x u} → freshe x (⦇⦈[ u ])
    FRHNEHole : ∀{x u e} → freshe x e → freshe x (⦇⌜ e ⌟⦈[ u ])
    FRHAp : ∀{x e1 e2} → freshe x e1 → freshe x e2 → freshe x (e1 ∘ e2)
    FRHFst  : ∀{x e} → freshe x e → freshe x (fst e)
    FRHSnd  : ∀{x e} → freshe x e → freshe x (snd e)
    FRHPair : ∀{x e1 e2} → freshe x e1 → freshe x e2 → freshe x ⟨ e1 , e2 ⟩

  -- with respect to all bindings in a context
  freshΓ : {A : Set} → (Γ : A ctx) → (e : eexp) → Set
  freshΓ {A} Γ e = (x : varname) → dom Γ x → freshe x e

  -- x is not used in a binding site in d
  mutual
    data unbound-in-σ : varname → env → Set where
      UBσId : ∀{x Γ} → unbound-in-σ x (Id Γ)
      UBσSubst : ∀{x d y σ} → unbound-in x d
                            → unbound-in-σ x σ
                            → x ≠ y
                            → unbound-in-σ x (Subst d y σ)

    data unbound-in : (x : varname) (d : iexp) → Set where
      UBConst : ∀{x} → unbound-in x c
      UBVar : ∀{x y} → unbound-in x (X y)
      UBLam2 : ∀{x d y τ} → x ≠ y
                           → unbound-in x d
                           → unbound-in x (·λ_[_]_ y τ d)
      UBHole : ∀{x u σ} → unbound-in-σ x σ
                         → unbound-in x (⦇⦈⟨ u , σ ⟩)
      UBNEHole : ∀{x u σ d }
                  → unbound-in-σ x σ
                  → unbound-in x d
                  → unbound-in x (⦇⌜ d ⌟⦈⟨ u , σ ⟩)
      UBAp : ∀{ x d1 d2 } →
            unbound-in x d1 →
            unbound-in x d2 →
            unbound-in x (d1 ∘ d2)
      UBCast : ∀{x d τ1 τ2} → unbound-in x d → unbound-in x (d ⟨ τ1 ⇒ τ2 ⟩)
      UBFailedCast : ∀{x d τ1 τ2} → unbound-in x d → unbound-in x (d ⟨ τ1 ⇒⦇⦈⇏ τ2 ⟩)
      UBFst  : ∀{x d} → unbound-in x d → unbound-in x (fst d)
      UBSnd  : ∀{x d} → unbound-in x d → unbound-in x (snd d)
      UBPair : ∀{x d1 d2} → unbound-in x d1 → unbound-in x d2 → unbound-in x ⟨ d1 , d2 ⟩

  mutual
    remove-from-free' : varname → eexp → List varname
    remove-from-free' x e = remove-all natEQ (free-vars e) x

    free-vars : (e : eexp) → List varname
    free-vars c = []
    free-vars (e ·: τ) = free-vars e
    free-vars (X x) = x :: []
    free-vars (·λ x e) = remove-from-free' x e
    free-vars (·λ x [ τ ] e) = remove-from-free' x e
    free-vars ⦇⦈[ u ] = []
    free-vars ⦇⌜ e ⌟⦈[ u ] = free-vars e
    free-vars (e₁ ∘ e₂) = free-vars e₁ ++ free-vars e₂
    free-vars ⟨ x , x₁ ⟩ = free-vars x ++ free-vars x₁
    free-vars (fst x) = free-vars x
    free-vars (snd x) = free-vars x

  mutual
    data binders-disjoint-σ : env → iexp → Set where
      BDσId : ∀{Γ d} → binders-disjoint-σ (Id Γ) d
      BDσSubst : ∀{d1 d2 y σ} → binders-disjoint d1 d2
                              → binders-disjoint-σ σ d2
                              → binders-disjoint-σ (Subst d1 y σ) d2

    -- two terms that do not share any binders
    data binders-disjoint : (d1 : iexp) → (d2 : iexp) → Set where
      BDConst : ∀{d} → binders-disjoint c d
      BDVar : ∀{x d} → binders-disjoint (X x) d
      BDLam : ∀{x τ d1 d2} → binders-disjoint d1 d2
                            → unbound-in x d2
                            → binders-disjoint (·λ_[_]_ x τ d1) d2
      BDHole : ∀{u σ d2} → binders-disjoint-σ σ d2
                         → binders-disjoint (⦇⦈⟨ u , σ ⟩) d2
      BDNEHole : ∀{u σ d1 d2} → binders-disjoint-σ σ d2
                              → binders-disjoint d1 d2
                              → binders-disjoint (⦇⌜ d1 ⌟⦈⟨ u , σ ⟩) d2
      BDAp :  ∀{d1 d2 d3} → binders-disjoint d1 d3
                          → binders-disjoint d2 d3
                          → binders-disjoint (d1 ∘ d2) d3
      BDCast : ∀{d1 d2 τ1 τ2} → binders-disjoint d1 d2 → binders-disjoint (d1 ⟨ τ1 ⇒ τ2 ⟩) d2
      BDFailedCast : ∀{d1 d2 τ1 τ2} → binders-disjoint d1 d2 → binders-disjoint (d1 ⟨ τ1 ⇒⦇⦈⇏ τ2 ⟩) d2
      BDFst  : ∀{d1 d2} → binders-disjoint d1 d2 → binders-disjoint (fst d1) d2
      BDSnd  : ∀{d1 d2} → binders-disjoint d1 d2 → binders-disjoint (snd d1) d2
      BDPair : ∀{d1 d2 d3} →
               binders-disjoint d1 d3 →
               binders-disjoint d2 d3 →
               binders-disjoint ⟨ d1 , d2 ⟩ d3

  mutual
  -- each term has to be binders unique, and they have to be pairwise
  -- disjoint with the collection of bound vars
    data binders-unique-σ : env → Set where
      BUσId : ∀{Γ} → binders-unique-σ (Id Γ)
      BUσSubst : ∀{d y σ} → binders-unique d
                          → binders-unique-σ σ
                          → binders-disjoint-σ σ d
                          → binders-unique-σ (Subst d y σ)

    -- all the variable names in the term are unique
    data binders-unique : iexp → Set where
      BUHole : binders-unique c
      BUVar : ∀{x} → binders-unique (X x)
      BULam : {x : varname} {τ : typ} {d : iexp} → binders-unique d
                                                → unbound-in x d
                                                → binders-unique (·λ_[_]_ x τ d)
      BUEHole : ∀{u σ} → binders-unique-σ σ
                        → binders-unique (⦇⦈⟨ u , σ ⟩)
      BUNEHole : ∀{u σ d} → binders-unique d
                           → binders-unique-σ σ
                           → binders-unique (⦇⌜ d ⌟⦈⟨ u , σ ⟩)
      BUAp : ∀{d1 d2} → binders-unique d1
                       → binders-unique d2
                       → binders-disjoint d1 d2
                       → binders-unique (d1 ∘ d2)
      BUCast : ∀{d τ1 τ2} → binders-unique d
                           → binders-unique (d ⟨ τ1 ⇒ τ2 ⟩)
      BUFailedCast : ∀{d τ1 τ2} → binders-unique d
                                 → binders-unique (d ⟨ τ1 ⇒⦇⦈⇏ τ2 ⟩)
      BUFst  : ∀{d} →
               binders-unique d →
               binders-unique (fst d)
      BUSnd  : ∀{d} →
               binders-unique d →
               binders-unique (snd d)
      BUPair : ∀{d1 d2} →
               binders-unique d1 →
               binders-unique d2 →
               binders-disjoint d1 d2 →
               binders-unique ⟨ d1 , d2 ⟩

  _⇓_ : iexp → iexp → Set
  d1 ⇓ d2 = (d1 ↦* d2 × d2 final)

  -- this is the decoding function, so half the iso. this won't work long term
  postulate
    _↑_ : iexp → eexp → Set
    _↓_ : eexp → iexp → Set
    iso : Set
    Exp : typ

-- naming conventions:
--
-- type contexts, tctx, are named Γ (because they always are)
-- hole contextst, ??, are named Δ
--
-- types, typ, are named τ
-- unexpanded expressions, uexp, are named ê (for "_e_xpression but also following the POPL17 notation)
-- expanded expressions, eexp, are named e (for "_e_xpression")
-- internal expressions, iexp, are named d (because they have a _d_ynamics)
-- splices are named ψ

  -- function-like livelit context well-formedness
  mutual
    livelitctx = Σ[ Φ' ∈ livelitdef ctx ] (Φ' livelitctx')

    data _livelitctx' : (Φ' : livelitdef ctx) → Set where
      PhiWFEmpty     : ∅ livelitctx'
      PhiWFMac       : ∀{a π} →
                          (Φ : livelitctx) →
                           a # π1 Φ →
                           (π1 Φ ,, (a , π)) livelitctx'

  _₁ : (Φ : livelitctx) → livelitdef ctx
  _₁ = π1

  infixr 25 _₁

  _,,_::_⦅given_⦆ : (Φ : livelitctx) →
                 (a : livelitname) →
                 livelitdef →
                 a # (Φ)₁ →
                 livelitctx
  Φ ,, a :: π ⦅given #h ⦆ = ((Φ)₁ ,, (a , π) , PhiWFMac Φ #h)

  -- livelit expansion
  mutual
    data _,_⊢_~~>_⇒_ : (Φ : livelitctx) →
                       (Γ : tctx) →
                       (ê : uexp) →
                       (e : eexp) →
                       (τ : typ) →
                       Set
      where
        SPEConst : ∀{Φ Γ} → Φ , Γ ⊢ c ~~> c ⇒ b
        SPEAsc   : ∀{Φ Γ ê e τ} →
                           Φ , Γ ⊢ ê ~~> e ⇐ τ →
                           Φ , Γ ⊢ (ê ·: τ) ~~> e ·: τ ⇒ τ
        SPEVar   : ∀{Φ Γ x τ} →
                           (x , τ) ∈ Γ →
                           Φ , Γ ⊢ (X x) ~~> (X x) ⇒ τ
        SPELam   : ∀{Φ Γ x e τ1 τ2 ê} →
                           x # Γ →
                           Φ , Γ ,, (x , τ1) ⊢ ê ~~> e ⇒ τ2 →
                           Φ , Γ ⊢ (·λ_[_]_ x τ1 ê) ~~> (·λ x [ τ1 ] e) ⇒ (τ1 ==> τ2)
        SPEAp    : ∀{Φ Γ ê1 ê2 τ1 τ2 τ e1 e2} →
                           Φ , Γ ⊢ ê1 ~~> e1 ⇒ τ1 →
                           τ1 ▸arr τ2 ==> τ →
                           Φ , Γ ⊢ ê2 ~~> e2 ⇐ τ2 →
                           holes-disjoint e1 e2 →
                           Φ , Γ ⊢ ê1 ∘ ê2 ~~> e1 ∘ e2 ⇒ τ
        SPEHole  : ∀{Φ Γ u} → Φ , Γ ⊢ ⦇⦈[ u ] ~~> ⦇⦈[ u ] ⇒ ⦇·⦈
        SPNEHole : ∀{Φ Γ ê e τ u} →
                           hole-name-new e u →
                           Φ , Γ ⊢ ê ~~> e ⇒ τ →
                           Φ , Γ ⊢ ⦇⌜ ê ⌟⦈[ u ] ~~> ⦇⌜ e ⌟⦈[ u ] ⇒ ⦇·⦈
        SPEFst   : ∀{Φ Γ ê e τ τ1 τ2} →
                           Φ , Γ ⊢ ê ~~> e ⇒ τ →
                           τ ▸prod τ1 ⊗ τ2 →
                           Φ , Γ ⊢ fst ê ~~> fst e ⇒ τ1
        SPESnd   : ∀{Φ Γ ê e τ τ1 τ2} →
                           Φ , Γ ⊢ ê ~~> e ⇒ τ →
                           τ ▸prod τ1 ⊗ τ2 →
                           Φ , Γ ⊢ snd ê ~~> snd e ⇒ τ2
        SPEPair  : ∀{Φ Γ ê1 ê2 τ1 τ2 e1 e2} →
                           Φ , Γ ⊢ ê1 ~~> e1 ⇒ τ1 →
                           Φ , Γ ⊢ ê2 ~~> e2 ⇒ τ2 →
                           holes-disjoint e1 e2 →
                           Φ , Γ ⊢ ⟨ ê1 , ê2 ⟩ ~~> ⟨ e1 , e2 ⟩ ⇒ τ1 ⊗ τ2
        SPEApLivelit  : ∀{Φ Γ a dm π denc eexpanded τsplice psplice esplice u} →
                         holes-disjoint eexpanded esplice →
                         freshΓ Γ eexpanded →
                         (a , π) ∈ (Φ)₁ →
                         ∅ , ∅ ⊢ dm :: (livelitdef.model-type π) →
                         ((livelitdef.expand π) ∘ dm) ⇓ denc →
                         denc ↑ eexpanded →
                         Φ , Γ ⊢ psplice ~~> esplice ⇐ τsplice →
                         ∅ ⊢ eexpanded <= τsplice ==> (livelitdef.expansion-type π) →
                         Φ , Γ ⊢ ＄ a ⟨ dm ⁏ (τsplice , psplice) :: [] ⟩[ u ] ~~> ((eexpanded ·: τsplice ==> livelitdef.expansion-type π) ∘ esplice) ⇒ livelitdef.expansion-type π

    data _,_⊢_~~>_⇐_ : (Φ : livelitctx) →
                       (Γ : tctx) →
                       (ê : uexp) →
                       (e : eexp) →
                       (τ : typ) →
                       Set
      where
        APELam     : ∀{Φ Γ x e τ τ1 τ2 ê} →
                           x # Γ →
                           τ ▸arr τ1 ==> τ2 →
                           Φ , Γ ,, (x , τ1) ⊢ ê ~~> e ⇐ τ2 →
                           Φ , Γ ⊢ (·λ x ê) ~~> (·λ x e) ⇐ τ
        APESubsume : ∀{Φ Γ ê e τ τ'} →
                           Φ , Γ ⊢ ê ~~> e ⇒ τ' →
                           τ ~ τ' →
                           Φ , Γ ⊢ ê ~~> e ⇐ τ


{-# OPTIONS --cubical-compatible #-}
postulate
  A : Set
  B : A → Set

T = (@0 x : A) → B x


-- Andreas, 2018-04-16, inspired by issue #3032 reported by sattlerc

-- A termination issue without visible recursion.

postulate
  A : Set
  B : Set
  t : B

mutual

  data C : (b : B) → Set where
    c : (x : C t) → C (foo t bar)

  postulate
    bar : C t

  foo : (b : B) → C b → B
  foo y (c x) = y

-- Should not termination check.
-- y is actually "foo t bar" here, a potentially non-terminating recursive call.