module Tactic.Reflection.DeBruijn where

open import Prelude hiding (abs)
open import Builtin.Reflection
open import Container.Traversable

record DeBruijn {a} (A : Set a) : Set a where
  field
    strengthenFrom : (from n : Nat) → A → Maybe A
    weakenFrom     : (from n : Nat) → A → A

  strengthen : Nat → A → Maybe A
  strengthen 0 = just
  strengthen n = strengthenFrom 0 n

  weaken : Nat → A → A
  weaken zero = id
  weaken n    = weakenFrom 0 n

open DeBruijn {{...}} public

patternBindings : List (Arg Pattern) → Nat
patternBindings = binds
  where
    binds : List (Arg Pattern) → Nat
    bind  : Pattern → Nat

    binds []             = 0
    binds (arg _ a ∷ as) = bind a + binds as

    bind (con c ps) = binds ps
    bind dot        = 1
    bind (var _)    = 1
    bind (lit l)    = 0
    bind (proj x)   = 0
    bind absurd     = 0

private
  Str : Set → Set
  Str A = Nat → Nat → A → Maybe A

  strVar : Str Nat
  strVar lo n x = if      x <? lo     then just x
                  else if x <? lo + n then nothing
                  else                just (x - n)

  strArgs    : Str (List (Arg Term))
  strArg     : Str (Arg Term)
  strSort    : Str Sort
  strClauses : Str (List Clause)
  strClause  : Str Clause
  strAbsTerm : Str (Abs Term)
  strAbsType : Str (Abs Type)

  strTerm : Str Term
  strTerm lo n (var x args)  = var <$> strVar lo n x <*> strArgs lo n args
  strTerm lo n (con c args)  = con c <$> strArgs lo n args
  strTerm lo n (def f args)  = def f <$> strArgs lo n args
  strTerm lo n (meta x args) = meta x <$> strArgs lo n args
  strTerm lo n (lam v t)     = lam v <$> strAbsTerm lo n t
  strTerm lo n (pi a b)      = pi    <$> strArg lo n a <*> strAbsType lo n b
  strTerm lo n (agda-sort s) = agda-sort <$> strSort lo n s
  strTerm lo n (lit l)       = just (lit l)
  strTerm lo n (pat-lam _ _) = just unknown -- todo
  strTerm lo n unknown       = just unknown

  strAbsTerm lo n (abs s t)  = abs s <$> strTerm (suc lo) n t
  strAbsType lo n (abs s t)  = abs s <$> strTerm (suc lo) n t

  strArgs    lo n []         = just []
  strArgs    lo n (x ∷ args) = _∷_   <$> strArg  lo n x <*> strArgs lo n args
  strArg     lo n (arg i v)  = arg i <$> strTerm lo n v
  strSort    lo n (set t)    = set   <$> strTerm lo n t
  strSort    lo n (lit l)    = just (lit l)
  strSort    lo n unknown    = just unknown

  strClauses lo k [] = just []
  strClauses lo k (c ∷ cs) = _∷_ <$> strClause lo k c <*> strClauses lo k cs

  strClause lo k (clause ps b)      = clause ps <$> strTerm (lo + patternBindings ps) k b
  strClause lo k (absurd-clause ps) = just (absurd-clause ps)

private
  Wk : Set → Set
  Wk A = Nat → Nat → A → A

  wkVar : Wk Nat
  wkVar lo k x = if x <? lo then x else x + k

  wkArgs    : Wk (List (Arg Term))
  wkArg     : Wk (Arg Term)
  wkSort    : Wk Sort
  wkClauses : Wk (List Clause)
  wkClause  : Wk Clause
  wkAbsTerm : Wk (Abs Term)

  wk : Wk Term
  wk lo k (var x args)  = var (wkVar lo k x) (wkArgs lo k args)
  wk lo k (con c args)  = con c (wkArgs lo k args)
  wk lo k (def f args)  = def f (wkArgs lo k args)
  wk lo k (meta x args) = meta x (wkArgs lo k args)
  wk lo k (lam v t)     = lam v (wkAbsTerm lo k t)
  wk lo k (pi a b)      = pi (wkArg lo k a) (wkAbsTerm lo k b)
  wk lo k (agda-sort s) = agda-sort (wkSort lo k s)
  wk lo k (lit l)       = lit l
  wk lo k (pat-lam cs args) = pat-lam (wkClauses lo k cs) (wkArgs lo k args)
  wk lo k unknown       = unknown

  wkAbsTerm lo k (abs s t)  = abs s (wk (suc lo) k t)
  wkArgs    lo k [] = []
  wkArgs    lo k (x ∷ args) = wkArg lo k x ∷ wkArgs lo k args
  wkArg     lo k (arg i v)  = arg i (wk lo k v)
  wkSort    lo k (set t)    = set (wk lo k t)
  wkSort    lo k (lit n)    = lit n
  wkSort    lo k unknown    = unknown

  wkClauses lo k [] = []
  wkClauses lo k (c ∷ cs) = wkClause lo k c ∷ wkClauses lo k cs

  wkClause lo k (clause ps b)      = clause ps (wk (lo + patternBindings ps) k b)
  wkClause lo k (absurd-clause ps) = absurd-clause ps

-- Instances --

DeBruijnTraversable : ∀ {a} {F : Set a → Set a} {{_ : Traversable F}}
                        {A : Set a} {{_ : DeBruijn A}} → DeBruijn (F A)
strengthenFrom {{DeBruijnTraversable}} lo k = traverse (strengthenFrom lo k)
weakenFrom     {{DeBruijnTraversable}} lo k = fmap     (weakenFrom lo k)

instance
  DeBruijnNat : DeBruijn Nat
  strengthenFrom {{DeBruijnNat}} = strVar
  weakenFrom     {{DeBruijnNat}} = wkVar

  DeBruijnTerm : DeBruijn Term
  strengthenFrom {{DeBruijnTerm}} = strTerm
  weakenFrom     {{DeBruijnTerm}} = wk

  DeBruijnList : ∀ {a} {A : Set a} {{_ : DeBruijn A}} → DeBruijn (List A)
  DeBruijnList = DeBruijnTraversable

  DeBruijnVec : ∀ {a} {A : Set a} {{_ : DeBruijn A}} {n : Nat} → DeBruijn (Vec A n)
  DeBruijnVec = DeBruijnTraversable

  DeBruijnArg : {A : Set} {{_ : DeBruijn A}} → DeBruijn (Arg A)
  DeBruijnArg = DeBruijnTraversable

  DeBruijnMaybe : {A : Set} {{_ : DeBruijn A}} → DeBruijn (Maybe A)
  DeBruijnMaybe = DeBruijnTraversable

-- Strip bound names (to ensure _==_ checks α-equality)
-- Doesn't touch pattern variables in pattern lambdas.

mutual

  stripBoundNames : Term → Term
  stripBoundNames (var x args)      = var x (stripArgs args)
  stripBoundNames (con c args)      = con c (stripArgs args)
  stripBoundNames (def f args)      = def f (stripArgs args)
  stripBoundNames (lam v t)         = lam v (stripAbs t)
  stripBoundNames (pat-lam cs args) = pat-lam (stripClauses cs) (stripArgs args)
  stripBoundNames (pi a b)          = pi (stripArg a) (stripAbs b)
  stripBoundNames (agda-sort s)     = agda-sort (stripSort s)
  stripBoundNames (lit l)           = lit l
  stripBoundNames (meta x args)     = meta x (stripArgs args)
  stripBoundNames unknown           = unknown

  private
    stripArgs : List (Arg Term) → List (Arg Term)
    stripArgs [] = []
    stripArgs (x ∷ xs) = stripArg x ∷ stripArgs xs

    stripArg : Arg Term → Arg Term
    stripArg (arg i t) = arg i (stripBoundNames t)

    stripAbs : Abs Term → Abs Term
    stripAbs (abs _ t) = abs "" (stripBoundNames t)

    stripClauses : List Clause → List Clause
    stripClauses [] = []
    stripClauses (x ∷ xs) = stripClause x ∷ stripClauses xs

    stripClause : Clause → Clause
    stripClause (clause ps t) = clause ps (stripBoundNames t)
    stripClause (absurd-clause ps) = absurd-clause ps

    stripSort : Sort → Sort
    stripSort (set t) = set (stripBoundNames t)
    stripSort (lit n) = lit n
    stripSort unknown = unknown


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

module Cubical.Data.Strict2Group.Explicit.Interface where

open import Cubical.Foundations.Prelude
open import Cubical.Data.Group.Base
open import Cubical.Data.Sigma
open import Cubical.Data.Strict2Group.Explicit.Base
open import Cubical.Data.Strict2Group.Explicit.Notation

module S2GInterface {ℓ : Level} ((strict2groupexp C₀ C₁ s t i ∘ si ti s∘ t∘ isMorph∘ assoc∘ lUnit∘ rUnit∘) : Strict2GroupExp ℓ) where

  open S2GBaseNotation C₀ C₁ s t i ∘ public

  module Identities1 where
    -- to be consistent with the other notation
    tarId = ti
    srcId = si
    -- identity is preserved by id
    id1₀≡1₁ : id 1₀ ≡ 1₁
    id1₀≡1₁ = morphId {G = C₀} {H = C₁} i

  open Identities1 public

  module C₁×₀C₁ where

    -- the composable morphisms as record type
    record Co : Type ℓ where
      constructor co
      field
        g f : TC₁
        coh : CohCond g f

    -- syntax
    𝓁 𝓇 : Co → TC₁
    𝓁 = Co.g
    𝓇 = Co.f
    𝒸 : (gfc : Co) → CohCond (𝓁 gfc) (𝓇 gfc)
    𝒸 = Co.coh

    -- compose a co object using ∘
    ⊙ : Co → TC₁
    ⊙ gfc = ∘ (𝓁 gfc) (𝓇 gfc) (𝒸 gfc)

    -- basically ∘, but for the sake of interfacing, we don't want to use ∘
    ⊙' : (g f : TC₁) → CohCond g f → TC₁
    ⊙' g f c = ⊙ (co g f c)

    -- interface for those names aswell
    src⊙ : (gfc : Co) → src (⊙ gfc) ≡ src (𝓇 gfc)
    src⊙ (co g f c) = s∘ g f c

    tar⊙ : (gfc : Co) → tar (⊙ gfc) ≡ tar (𝓁 gfc)
    tar⊙ (co g f c) = t∘ g f c

    src⊙' : (g f : TC₁) → (c : CohCond g f) → src (⊙' g f c) ≡ src f
    src⊙' g f c = src⊙ (co g f c)

    tar⊙' : (g f : TC₁) → (c : CohCond g f) → tar (⊙' g f c) ≡ tar g
    tar⊙' g f c = tar⊙ (co g f c)

    -- multiplication in C₁×₀C₁
    _∙Co_ : (gfc gfc' : Co) → Co
    (co g f coh) ∙Co (co g' f' coh') =
      co (g ∙₁ g') (f ∙₁ f')
        (src∙₁ g g' ∙ cong (_∙₀ src g') coh ∙ cong (tar f ∙₀_) coh' ∙ sym (tar∙₁ f f'))

    -- unit element w.r.t. ∙c. Too bad there is no \_c
    1c : Co
    1c = co 1₁ 1₁ ((cong src (sym id1₀≡1₁)) ∙∙ si 1₀ ∙∙ sym (ti 1₀) ∙ cong tar id1₀≡1₁)

    -- the interchange law reformulated using ⊙
    isMorph⊙ : (gfc gfc' : Co) → ⊙ (gfc ∙Co gfc') ≡ ⊙ gfc ∙₁ ⊙ gfc'
    isMorph⊙ (co _ _ c) (co _ _ c') = isMorph∘ c c'

    -- associator notation
    assoc⊙' : (h g f : TC₁) → (c : CohCond g f) → (c' : CohCond h g) → ⊙' (⊙' h g c') f ((src⊙' h g c') ∙ c) ≡ ⊙' h (⊙' g f c) (c' ∙ (sym (tar⊙' g f c)))
    assoc⊙' h g f c c' = assoc∘ c c'

    -- the left and right unit laws reformulated using ⊙
    lUnit⊙ : (f : TC₁) → ⊙ (co (id (tar f)) f (srcId (tar f))) ≡ f
    lUnit⊙ = lUnit∘
    rUnit⊙ : (f : TC₁) → ⊙ (co f (id (src f)) (sym (tarId (src f)))) ≡ f
    rUnit⊙ = rUnit∘

    -- the path component of f in C₁
    ΣC₁p : (f : TC₁) → Type ℓ
    ΣC₁p f = Σ[ f' ∈ TC₁ ] (f ≡ f')

    private
      -- for given g, the type of f that g can be precomposed with
      _∘* : TC₁ → Type ℓ
      g ∘* = Σ[ f ∈ TC₁ ] (CohCond g f)
      -- for given f, the type of g that f can be postcomposed with
      *∘_ : TC₁ → Type ℓ
      *∘ f = Σ[ g ∈ TC₁ ] (CohCond g f)

      -- alternate notation for ∘
      -- this is used in ∘*≡ to λ-abstract in cong
      _∘*_ : (g : TC₁) (fc : g ∘*) → TC₁
      _∘*_ g (f , c) = ∘ g f c
      _*∘_ : (f : TC₁) (gc : *∘ f) → TC₁
      _*∘_ f (g , c) = ∘ g f c

      -- since we have proof irrelevance in C₀ we can show that f ≡ f' → g∘f ≡ g∘f'
      ∘*≡ : (g : TC₁) → (fc : g ∘*) → (f'p : ΣC₁p (fst fc)) → g ∘* fc ≡ g ∘* ((fst f'p) , snd fc ∙ cong tar (snd f'p))
      ∘*≡ g fc f'p = cong (g ∘*_) (ΣPathP (snd f'p , isProp→PathP (λ j → Group.setStruc C₀ (src g) (tar (snd f'p j))) (snd fc) (snd fc ∙ cong tar (snd f'p))))
      *∘≡ : (f : TC₁) → (gc : *∘ f) → (g'p : ΣC₁p (fst gc)) → f *∘ gc ≡ f *∘ (fst g'p , ((cong src (sym (snd g'p))) ∙ snd gc))
      *∘≡ f gc g'p = cong (_*∘_ f) (ΣPathP ((snd g'p) , (isProp→PathP (λ j → Group.setStruc C₀ (src (snd g'p j)) (tar f)) (snd gc) (cong src (sym (snd g'p)) ∙ snd gc))))

    -- ⊙ respecs paths on the right
    ⊙≡ : ((co g f c) : Co) → (f'p : ΣC₁p f) → ⊙ (co g f c) ≡ ⊙ (co g (fst f'p) (c ∙ (cong tar (snd f'p))))
    ⊙≡ (co g f c) (f' , f≡f') = ∘*≡ g (f , c) (f' , f≡f')

    -- ⊙ respects paths on the left
    ≡⊙ : ((co g f c) : Co) → ((g' , g≡g') : ΣC₁p g) → ⊙ (co g f c) ≡ ⊙ (co g' f (cong src (sym g≡g') ∙ c))
    ≡⊙ (co g f c) (g' , g≡g') = *∘≡ f (g , c) (g' , g≡g')

    -- ⊙ resepcts paths on the coherence condition
    ⊙≡c : ((co g f c) : Co) → (c' : CohCond g f) → ⊙ (co g f c) ≡ ⊙ (co g f c')
    ⊙≡c (co g f c) c' = cong (λ z → ⊙ (co g f z)) (Group.setStruc C₀ (src g) (tar f) c c')

    -- implicit version of ⊙≡c
    ⊙≡c~ : {g f : TC₁} (c c' : CohCond g f) → ⊙ (co g f c) ≡ ⊙ (co g f c')
    ⊙≡c~ {g} {f} c c' = cong (λ z → ⊙ (co g f z)) (Group.setStruc C₀ (src g) (tar f) c c')

    -- ⊙ respecting paths on the left also changes the coherence condition so this should be used instead
    ≡⊙c* : {g g' f : TC₁} (c : CohCond g f) (g≡g' : g ≡ g') (c' : CohCond g' f) → ⊙' g f c ≡ ⊙' g' f c'
    ≡⊙c* {g} {g'} {f} c g≡g' c' = (≡⊙ (co g f c) (g' , g≡g')) ∙ ⊙≡c~ ((cong src (sym g≡g')) ∙ c) c'

    -- ⊙ respecting paths on the right also changes the coherence condition so this should be used instead
    ⊙≡c* : {g f f' : TC₁} (c : CohCond g f) (f≡f' : f ≡ f') (c' : CohCond g f') → ⊙' g f c ≡ ⊙' g f' c'
    ⊙≡c* {g} {f} {f'} c f≡f' c' = (⊙≡ (co g f c) (f' , f≡f')) ∙ ⊙≡c~ (c ∙ cong tar f≡f') c'

    -- use the left and right unit law with an arbitrary coherence proof c
    lUnit⊙c : (f : TC₁) → (c : CohCond (id (tar f)) f) → ⊙ (co (id (tar f)) f c) ≡ f
    lUnit⊙c f c = (⊙≡c (co (id (tar f)) f c) (srcId (tar f))) ∙ (lUnit⊙ f)
    rUnit⊙c : (f : TC₁) → (c : CohCond f (id (src f))) → ⊙ (co f (id (src f)) c) ≡ f
    rUnit⊙c f c = (⊙≡c (co f (id (src f)) c) (sym (tarId (src f)))) ∙ (rUnit⊙ f)

  open C₁×₀C₁ public

  module Identities2 where
    -- source and target of unit element
    tar1₁≡1₀ : tar 1₁ ≡ 1₀
    tar1₁≡1₀ = morphId {G = C₁} {H = C₀} t
    src1₁≡1₀ = morphId {G = C₁} {H = C₀} s

    -- taking the source is the same as the target of the identity of the source
    src≡tarIdSrc : (f : TC₁) → CohCond f (id (src f))
    src≡tarIdSrc f = sym (ti (src f))

  open Identities2 public


-- Andreas, 2015-05-10  Report wrong hiding for copattern

{-# OPTIONS --copatterns #-}

record ⊤ : Set where

record Foo (A : Set) : Set where
  field
    foo : A

bar : Foo ⊤
Foo.foo {bar} = _

-- Error WAS: Unexpected implicit argument

-- Better error:
-- Wrong hiding used for projection  Foo.foo
-- when checking that the clause Foo.foo {bar} = _ has type Foo ⊤


-- Raw terms, weakening (renaming) and substitution.

{-# OPTIONS --safe #-}

module Definition.Untyped where

open import Tools.Nat
open import Tools.Product
open import Tools.List
import Tools.PropositionalEquality as PE

import Data.Fin as Fin
import Data.Nat as Nat

infixl 30 _∙_^_
infix 30 Π_^_°_▹_°_°_
infixr 22 _^_°_▹▹_°_°_
infixl 30 _ₛ•ₛ_ _•ₛ_ _ₛ•_
infix 25 _[_]
infix 25 _[_]↑

data Relevance : Set where
  ! : Relevance -- proof-relevant
  % : Relevance -- proof-irrelevant

!≢% : ! PE.≢ %
!≢% ()

-- two levels of small types
data Level : Set where
  ⁰ : Level
  ¹ : Level

⁰≢¹ : ⁰ PE.≢ ¹
⁰≢¹ ()

data _<_ : (i j : Level) → Set where
  0<1 : ⁰ < ¹

data _≤_ (i j : Level) : Set where
  <is≤  : i < j → i ≤ j
  ≡is≤ : i PE.≡ j → i ≤ j

-- Large type levels : ι ⁰, ι ¹, ∞
data TypeLevel : Set where
  ι : Level → TypeLevel
  ∞ : TypeLevel

data _<∞_ : (i j : TypeLevel) → Set where
  emb< : ι ⁰ <∞ ι ¹
  ∞< : ι ¹ <∞ ∞
  -- ∞<⁰ : ι ⁰ <∞ ∞

data _≤∞_ (i j : TypeLevel) : Set where
  <∞is≤∞  : i <∞ j → i ≤∞ j
  ≡is≤∞ : i PE.≡ j → i ≤∞ j

next : Level → TypeLevel
next ⁰ = ι ¹
next ¹ = ∞

toLevel : TypeLevel → Level
toLevel (ι ⁰) = ⁰
toLevel (ι ¹) = ¹
toLevel ∞ = ¹

predLevel : TypeLevel → Level
predLevel (ι ⁰) = ⁰
predLevel (ι ¹) = ⁰
predLevel ∞ = ¹

maxLevel : (i : Level) → (j : Level) → Σ Level λ k → i ≤ k × j ≤ k
maxLevel ⁰ ⁰ = ⁰ , ((≡is≤ PE.refl) , (≡is≤ PE.refl))
maxLevel ⁰ ¹ = ¹ , ((<is≤ 0<1) , (≡is≤ PE.refl))
maxLevel ¹ ⁰ = ¹ , ((≡is≤ PE.refl) , (<is≤ 0<1))
maxLevel ¹ ¹ = ¹ , ((≡is≤ PE.refl) , (≡is≤ PE.refl))

⁰min : (i : Level) → ⁰ ≤ i
⁰min ⁰ = ≡is≤ PE.refl
⁰min ¹ = <is≤ 0<1

<next : ∀ {l} → ι l <∞ next l
<next {⁰} = emb<
<next {¹} = ∞<

levelBounded : (i : Level) → Σ TypeLevel λ k → ι i <∞ k
levelBounded i = next i , <next

ιinj : ∀ {l l'} → ι l PE.≡ ι l' → l PE.≡ l'
ιinj {⁰} {⁰} e = PE.refl
ιinj {¹} {¹} e = PE.refl

next-inj : ∀ {l l'} → next l PE.≡ next l' → l PE.≡ l'
next-inj {⁰} {⁰} e = PE.refl
next-inj {¹} {¹} e = PE.refl

-- In a typing judgment, a type is generally annotated with a pair of a relevance and a level
record TypeInfo : Set where
  constructor [_,_]
  field
    r : Relevance
    l : TypeLevel

toTypeInfo : Relevance × Level → TypeInfo
toTypeInfo ( r , l ) = [ r , ι l ]

-- Typing contexts (snoc-lists, isomorphic to lists).
data Con (A : Set) : Set where
  ε   : Con A               -- Empty context.
  _∙_^_ : Con A → A → TypeInfo → Con A  -- Context extension.

record GenT (A : Set) : Set where
  inductive
  constructor ⟦_,_⟧
  field
    l : Nat
    t : A

data Kind : Set where
  Ukind : Relevance → Level → Kind
  Pikind : Relevance → Level → Level → Level → Kind
  Natkind : Kind
  Lamkind : Level → Kind
  Appkind : Level → Kind
  Zerokind : Kind
  Suckind : Kind
  Natreckind : Level → Kind
  Emptykind : Level → Kind
  Emptyreckind : Level → Level → Kind
  Idkind : Kind
  Idreflkind : Kind
  Transpkind : Kind
  Castkind : Level → Kind
  Castreflkind : Kind
  Sigmakind : Kind
  Pairkind : Kind
  Fstkind : Kind
  Sndkind : Kind

data Term : Set where
  var : (x : Nat) → Term
  gen : (k : Kind) (c : List (GenT Term)) → Term

-- The Grammar of our language.

-- We represent the expressions of our language as de Bruijn terms.
-- Variables are natural numbers interpreted as de Bruijn indices.
-- Π, lam, ∃ , transp and natrec are binders.

-- Type constructors.
-- Universes of proof-relevant types
U      : Level → Term
U l = gen (Ukind ! l) []

-- Universes of proof-irrelevant types
SProp : Level → Term
SProp l = gen (Ukind % l) []

pattern Univ r l = gen (Ukind r l) []

-- Dependent product, with level annotations for the domain, codomain, and resulting type
Π_^_°_▹_°_°_   : Term → Relevance → Level → Term → Level → Level → Term  -- Dependent function type (B is a binder).
Π A ^ r ° lA ▹ B ° lB ° lΠ = gen (Pikind r lA lB lΠ) (⟦ 0 , A ⟧ ∷ ⟦ 1 , B ⟧ ∷ [])

-- Existential type : dependent pairs of proof-irrelevant terms
∃_▹_ : Term → Term → Term
∃ A ▹ B = gen Sigmakind (⟦ 0 , A ⟧ ∷ ⟦ 1 , B ⟧ ∷ [])

-- Natural numbers
ℕ      : Term
ℕ = gen Natkind []

-- Lambda-calculus.
-- var    : (x : Nat)        → Term  -- Variable (de Bruijn index).
-- var = var

lam_▹_^_    : Term → Term → Level → Term  -- Function abstraction (binder).
lam A ▹ t ^ l = gen (Lamkind l) (⟦ 0 , A ⟧ ∷ ⟦ 1 , t ⟧ ∷ [])

_∘_^_    : (t u : Term) (l : Level)    → Term  -- Application.
t ∘ u ^ l = gen (Appkind l) (⟦ 0 , t ⟧ ∷ ⟦ 0 , u ⟧ ∷ [])

⦅_,_,_⦆ : Term → Term → Term → Term -- Dependent pair formation
⦅ G , t , u ⦆ = gen Pairkind (⟦ 1 , G ⟧ ∷ ⟦ 0 , t ⟧ ∷ ⟦ 0 , u ⟧ ∷ [])

fst : (t : Term) → Term -- Dependent pair elimination
fst t = gen Fstkind (⟦ 0 , t ⟧ ∷ [])

snd : (t : Term) → Term -- Dependent pair elimination
snd t = gen Sndkind (⟦ 0 , t ⟧ ∷ [])

-- Introduction and elimination of natural numbers.
zero   : Term                     -- Natural number zero.
zero = gen Zerokind []

suc    : (t : Term)       → Term  -- Successor.
suc t = gen Suckind (⟦ 0 , t ⟧ ∷ [])

natrec : (l : Level) (A t u v : Term) → Term  -- Recursor (A is a binder).
natrec l A t u v = gen (Natreckind l) (⟦ 1 , A ⟧ ∷ ⟦ 0 , t ⟧ ∷ ⟦ 0 , u ⟧ ∷ ⟦ 0 , v ⟧ ∷ [])

-- Empty type
Empty : Level → Term
Empty l = gen (Emptykind l) []

-- Eliminator for the empty type
Emptyrec : (l lEmpty : Level) (A e : Term) -> Term
Emptyrec l lEmpty A e = gen (Emptyreckind l lEmpty) (⟦ 0 , A ⟧ ∷ ⟦ 0 , e ⟧ ∷ [])

-- Identity type
Id : (A t u : Term) → Term
Id A t u = gen Idkind (⟦ 0 , A ⟧ ∷ ⟦ 0 , t ⟧ ∷ ⟦ 0 , u ⟧ ∷ [])

-- witness of reflexivity of equality
Idrefl : (A t : Term) → Term
Idrefl A t = gen Idreflkind (⟦ 0 , A ⟧ ∷ ⟦ 0 , t ⟧ ∷ [])

-- transport on propositions
transp : (A P t s u e : Term) → Term
transp A P t s u e = gen Transpkind (⟦ 0 , A ⟧ ∷ ⟦ 1 , P ⟧ ∷ ⟦ 0 , t ⟧ ∷ ⟦ 0 , s ⟧ ∷ ⟦ 0 , u ⟧ ∷ ⟦ 0 , e ⟧ ∷ [])

-- cast between types, used to implement transport
cast : Level → (A B e t : Term) → Term
cast l A B e t = gen (Castkind l) (⟦ 0 , A ⟧ ∷ ⟦ 0 , B ⟧ ∷ ⟦ 0 , e ⟧ ∷ ⟦ 0 , t ⟧ ∷ [])

-- propositional proof that casting with reflexivity is the identity
castrefl : (A t : Term) → Term
castrefl A t = gen Castreflkind (⟦ 0 , A ⟧ ∷ ⟦ 0 , t ⟧ ∷ [])

-- Injectivity of term constructors w.r.t. propositional equality.

-- If  Π F G = Π H E  then  F = H  and  G = E.

Π-PE-injectivity : ∀ {F rF lF G lG lΠ H rH lH E lE lΠ'} → Π F ^ rF ° lF ▹ G ° lG ° lΠ PE.≡ Π H ^ rH ° lH ▹ E ° lE ° lΠ'
  → F PE.≡ H × rF PE.≡ rH × lF PE.≡ lH × G PE.≡ E × lG PE.≡ lE × lΠ PE.≡ lΠ'
Π-PE-injectivity PE.refl = PE.refl , PE.refl , PE.refl , PE.refl , PE.refl , PE.refl

∃-PE-injectivity : ∀ {F G H E} → ∃ F ▹ G PE.≡ ∃ H ▹ E
  → F PE.≡ H × G PE.≡ E
∃-PE-injectivity PE.refl = PE.refl , PE.refl

-- If  suc n = suc m  then  n = m.

suc-PE-injectivity : ∀ {n m} → suc n PE.≡ suc m → n PE.≡ m
suc-PE-injectivity PE.refl = PE.refl

Univ-PE-injectivity : ∀ {r r' l l'} → Univ r l PE.≡ Univ r' l' → r PE.≡ r' × l PE.≡ l'
Univ-PE-injectivity PE.refl = PE.refl , PE.refl

-- Neutral terms.

-- A term is neutral if
-- either it has a variable in head position that blocks reduction.
-- either it is of the form Emptyrec (or terms that should reduce to emptyrec, such as incompatible casts)

data Neutral : Term → Set where
  var     : ∀ n                     → Neutral (var n)
  ∘ₙ      : ∀ {k u l}     → Neutral k → Neutral (k ∘ u ^ l)
  natrecₙ : ∀ {l C c g k} → Neutral k → Neutral (natrec l C c g k)
  Idₙ : ∀ {A t u} → Neutral A → Neutral (Id A t u)
  Idℕₙ : ∀ {t u} → Neutral t → Neutral (Id ℕ t u)
  Idℕ0ₙ : ∀ {u} → Neutral u → Neutral (Id ℕ zero u)
  IdℕSₙ : ∀ {t u} → Neutral u → Neutral (Id ℕ (suc t) u)
  IdUₙ : ∀ {t u l} → Neutral t → Neutral (Id (U l) t u)
  IdUℕₙ : ∀ {u l} → Neutral u → Neutral (Id (U l) ℕ u)
  IdUΠₙ : ∀ {A rA lA B lB l u} → Neutral u → Neutral (Id (U l) (Π A ^ rA ° lA ▹ B ° lB ° l) u)
  castₙ : ∀ {l A B e t} → Neutral A → Neutral (cast l A B e t)
  castℕₙ : ∀ {l B e t} → Neutral B → Neutral (cast l ℕ B e t)
  castΠₙ : ∀ {l A rA lA P lP B e t} → Neutral B → Neutral (cast l (Π A ^ rA ° lA ▹ P ° lP ° l) B e t)
  castℕℕₙ : ∀ {l e t} → Neutral t → Neutral (cast l ℕ ℕ e t)
  castℕΠₙ : ∀ {l A rA B e t} → Neutral (cast l ℕ (Π A ^ rA ° ⁰ ▹ B ° ⁰ ° l) e t)
  castΠℕₙ : ∀ {l A rA B e t} → Neutral (cast l (Π A ^ rA ° ⁰ ▹ B ° ⁰ ° l) ℕ e t)
  castΠΠ%!ₙ : ∀ {l A B A' B' e t} → Neutral (cast l (Π A ^ % ° ⁰ ▹ B ° ⁰ ° l) (Π A' ^ ! ° ⁰ ▹ B' ° ⁰ ° l) e t)
  castΠΠ!%ₙ : ∀ {l A B A' B' e t} → Neutral (cast l (Π A ^ ! ° ⁰ ▹ B ° ⁰ ° l) (Π A' ^ % ° ⁰ ▹ B' ° ⁰ ° l) e t)
  Emptyrecₙ : ∀ {l lEmpty A e} -> Neutral (Emptyrec l lEmpty A e)

-- Weak head normal forms (whnfs).
-- These are the (lazy) values of our language.

data Whnf : Term → Set where

  -- Type constructors are whnfs.
  Uₙ    : ∀ {r l} → Whnf (Univ r l)
  Πₙ    : ∀ {A r lA B lB l} → Whnf (Π A ^ r ° lA ▹ B ° lB ° l)
  ∃ₙ    : ∀ {A B} → Whnf (∃ A ▹ B)
  ℕₙ    : Whnf ℕ
  Emptyₙ : ∀ {l} → Whnf (Empty l)

  -- Introductions are whnfs.
  lamₙ  : ∀ {A t l} → Whnf (lam A ▹ t ^ l)
  zeroₙ : Whnf zero
  sucₙ  : ∀ {t} → Whnf (suc t)

  -- Neutrals are whnfs.
  ne   : ∀ {n} → Neutral n → Whnf n

-- Whnf inequalities.

-- Different whnfs are trivially distinguished by propositional equality.
-- (The following statements are sometimes called "no-confusion theorems".)

U≢ℕ : ∀ {r l} → Univ r l PE.≢ ℕ
U≢ℕ ()

U≢Empty : ∀ {r l l'} → Univ r l PE.≢ Empty l'
U≢Empty ()

U≢Π : ∀ {r r' l F lF G lG l'} → Univ r l PE.≢ Π F ^ r' ° lF ▹ G ° lG ° l'
U≢Π ()

U≢∃ : ∀ {r l F G} → Univ r l PE.≢ ∃ F ▹ G
U≢∃ ()

U≢ne : ∀ {r l K} → Neutral K → Univ r l PE.≢ K
U≢ne () PE.refl

ℕ≢Π : ∀ {F r lF G lG l} → ℕ PE.≢ Π F ^ r ° lF ▹ G ° lG ° l
ℕ≢Π ()

ℕ≢∃ : ∀ {F G} → ℕ PE.≢ ∃ F ▹ G
ℕ≢∃ ()

ℕ≢Empty : ∀ {l} → ℕ PE.≢ Empty l
ℕ≢Empty ()

Empty≢ℕ : ∀ {l} → Empty l PE.≢ ℕ
Empty≢ℕ ()

ℕ≢ne : ∀ {K} → Neutral K → ℕ PE.≢ K
ℕ≢ne () PE.refl

Empty≢ne : ∀ {l K} → Neutral K → Empty l PE.≢ K
Empty≢ne () PE.refl

Empty≢Π : ∀ {F r lF G lG l l'} → Empty l' PE.≢ Π F ^ r ° lF ▹ G ° lG ° l
Empty≢Π ()

Empty≢∃ : ∀ {l F G} → Empty l PE.≢ ∃ F ▹ G
Empty≢∃ ()

Π≢ne : ∀ {F r lF G lG K l} → Neutral K → Π F ^ r ° lF ▹ G ° lG ° l PE.≢ K
Π≢ne () PE.refl

Π≢∃ : ∀ {F r lF G lG F' G' l} → Π F ^ r ° lF ▹ G ° lG ° l PE.≢ ∃ F' ▹ G'
Π≢∃ ()

∃≢ne : ∀ {F G K} → Neutral K → ∃ F ▹ G PE.≢ K
∃≢ne () PE.refl

zero≢suc : ∀ {n} → zero PE.≢ suc n
zero≢suc ()

zero≢ne : ∀ {k} → Neutral k → zero PE.≢ k
zero≢ne () PE.refl

suc≢ne : ∀ {n k} → Neutral k → suc n PE.≢ k
suc≢ne () PE.refl

-- Several views on whnfs (note: not recursive).

-- A whnf of type ℕ is either zero, suc t, or neutral.

data Natural : Term → Set where
  zeroₙ :                     Natural zero
  sucₙ  : ∀ {t}             → Natural (suc t)
  ne    : ∀ {n} → Neutral n → Natural n

-- A type in whnf is either Π A B, ℕ, or neutral.
-- Large types could also be U.

data Type : Term → Set where
  Πₙ : ∀ {A r lA B lB l} → Type (Π A ^ r ° lA ▹ B ° lB ° l)
  ℕₙ : Type ℕ
  Uₙ : ∀ {r l} → Type (Univ r l)
  Emptyₙ : ∀ {l} → Type (Empty l)
  ∃ₙ : ∀ {A B} → Type (∃ A ▹ B)
  ne : ∀{n} → Neutral n → Type n

-- A whnf of type Π A B is either lam t or neutral.

data Function : Term → Set where
  lamₙ : ∀{A t l} → Function (lam A ▹ t ^ l)
  ne : ∀{n} → Neutral n → Function n

-- These views classify only whnfs.
-- Natural, Type, and Function are a subsets of Whnf.

naturalWhnf : ∀ {n} → Natural n → Whnf n
naturalWhnf sucₙ = sucₙ
naturalWhnf zeroₙ = zeroₙ
naturalWhnf (ne x) = ne x

typeWhnf : ∀ {A} → Type A → Whnf A
typeWhnf Πₙ = Πₙ
typeWhnf ℕₙ = ℕₙ
typeWhnf Uₙ  = Uₙ
typeWhnf ∃ₙ = ∃ₙ
typeWhnf Emptyₙ = Emptyₙ
typeWhnf (ne x) = ne x

functionWhnf : ∀ {f} → Function f → Whnf f
functionWhnf lamₙ = lamₙ
functionWhnf (ne x) = ne x

------------------------------------------------------------------------
-- Weakening

-- In the following we define untyped weakenings η : Wk.
-- The typed form could be written η : Γ ≤ Δ with the intention
-- that η transport a term t living in context Δ to a context Γ
-- that can bind additional variables (which cannot appear in t).
-- Thus, if Δ ⊢ t : A and η : Γ ≤ Δ then Γ ⊢ wk η t : wk η A.
--
-- Even though Γ is "larger" than Δ we write Γ ≤ Δ to be conformant
-- with subtyping A ≤ B.  With subtyping, relation Γ ≤ Δ could be defined as
-- ``for all x ∈ dom(Δ) have Γ(x) ≤ Δ(x)'' (in the sense of subtyping)
-- and this would be the natural extension of weakenings.

data Wk : Set where
  id    : Wk        -- η : Γ ≤ Γ.
  step  : Wk  → Wk  -- If η : Γ ≤ Δ then step η : Γ∙A ≤ Δ.
  lift  : Wk  → Wk  -- If η : Γ ≤ Δ then lift η : Γ∙A ≤ Δ∙A.

-- Composition of weakening.
-- If η : Γ ≤ Δ and η′ : Δ ≤ Φ then η • η′ : Γ ≤ Φ.

infixl 30 _•_

_•_                :  Wk → Wk → Wk
id      • η′       =  η′
step η  • η′       =  step  (η • η′)
lift η  • id       =  lift  η
lift η  • step η′  =  step  (η • η′)
lift η  • lift η′  =  lift  (η • η′)

repeat : {A : Set} → (A → A) → A → Nat → A
repeat f a 0 = a
repeat f a (1+ n) = f (repeat f a n)

-- Weakening of variables.
-- If η : Γ ≤ Δ and x ∈ dom(Δ) then wkVar ρ x ∈ dom(Γ).

wkVar : (ρ : Wk) (n : Nat) → Nat
wkVar id       n        = n
wkVar (step ρ) n        = 1+ (wkVar ρ n)
wkVar (lift ρ) 0    = 0
wkVar (lift ρ) (1+ n) = 1+ (wkVar ρ n)

  -- Weakening of terms.
  -- If η : Γ ≤ Δ and Δ ⊢ t : A then Γ ⊢ wk η t : wk η A.

mutual
  wkGen : (ρ : Wk) (g : List (GenT Term)) → List (GenT Term)
  wkGen ρ [] = []
  wkGen ρ (⟦ l , t ⟧ ∷ g) = ⟦ l , (wk (repeat lift ρ l) t) ⟧ ∷ wkGen ρ g

  wk : (ρ : Wk) (t : Term) → Term
  wk ρ (var x) = var (wkVar ρ x)
  wk ρ (gen x c) = gen x (wkGen ρ c)

-- Adding one variable to the context requires wk1.
-- If Γ ⊢ t : B then Γ∙A ⊢ wk1 t : wk1 B.

wk1 : Term → Term
wk1 = wk (step id)

wk1d : Term → Term
wk1d = wk (lift (step id))

-- Weakening of a neutral term.

wkNeutral : ∀ {t} ρ → Neutral t → Neutral (wk ρ t)
wkNeutral ρ (var n)    = var (wkVar ρ n)
wkNeutral ρ (∘ₙ n)    = ∘ₙ (wkNeutral ρ n)
wkNeutral ρ (natrecₙ n) = natrecₙ (wkNeutral ρ n)
wkNeutral ρ Emptyrecₙ = Emptyrecₙ
wkNeutral ρ (Idₙ A) = Idₙ (wkNeutral ρ A)
wkNeutral ρ (Idℕₙ t) = Idℕₙ (wkNeutral ρ t)
wkNeutral ρ (Idℕ0ₙ t) = Idℕ0ₙ (wkNeutral ρ t)
wkNeutral ρ (IdℕSₙ t) = IdℕSₙ (wkNeutral ρ t)
wkNeutral ρ (IdUₙ t) = IdUₙ (wkNeutral ρ t)
wkNeutral ρ (IdUℕₙ t) = IdUℕₙ (wkNeutral ρ t)
wkNeutral ρ (IdUΠₙ t) = IdUΠₙ (wkNeutral ρ t)
wkNeutral ρ (castₙ A) = castₙ (wkNeutral ρ A)
wkNeutral ρ (castℕₙ A) = castℕₙ (wkNeutral ρ A)
wkNeutral ρ (castΠₙ A) = castΠₙ (wkNeutral ρ A)
wkNeutral ρ (castℕℕₙ t) = castℕℕₙ (wkNeutral ρ t)
wkNeutral ρ castℕΠₙ = castℕΠₙ
wkNeutral ρ castΠℕₙ = castΠℕₙ
wkNeutral ρ castΠΠ%!ₙ = castΠΠ%!ₙ
wkNeutral ρ castΠΠ!%ₙ = castΠΠ!%ₙ

-- Weakening can be applied to our whnf views.

wkNatural : ∀ {t} ρ → Natural t → Natural (wk ρ t)
wkNatural ρ sucₙ    = sucₙ
wkNatural ρ zeroₙ   = zeroₙ
wkNatural ρ (ne x) = ne (wkNeutral ρ x)

wkType : ∀ {t} ρ → Type t → Type (wk ρ t)
wkType ρ Πₙ      = Πₙ
wkType ρ ℕₙ      = ℕₙ
wkType ρ Uₙ      = Uₙ
wkType ρ ∃ₙ      = ∃ₙ
wkType ρ Emptyₙ  = Emptyₙ
wkType ρ (ne x) = ne (wkNeutral ρ x)

wkFunction : ∀ {t} ρ → Function t → Function (wk ρ t)
wkFunction ρ lamₙ    = lamₙ
wkFunction ρ (ne x) = ne (wkNeutral ρ x)

wkWhnf : ∀ {t} ρ → Whnf t → Whnf (wk ρ t)
wkWhnf ρ Uₙ      = Uₙ
wkWhnf ρ Πₙ      = Πₙ
wkWhnf ρ ∃ₙ      = ∃ₙ
wkWhnf ρ ℕₙ      = ℕₙ
wkWhnf ρ Emptyₙ  = Emptyₙ
wkWhnf ρ lamₙ    = lamₙ
wkWhnf ρ zeroₙ   = zeroₙ
wkWhnf ρ sucₙ    = sucₙ
wkWhnf ρ (ne x) = ne (wkNeutral ρ x)

-- Non-dependent version of Π.

_^_°_▹▹_°_°_ : Term → Relevance → Level → Term → Level → Level → Term
A ^ r ° lA ▹▹ B ° lB ° l = Π A ^ r ° lA ▹ wk1 B ° lB ° l

-- Non-dependent version of ∃.

_××_ : Term → Term → Term
A ×× B = ∃ A ▹ wk1 B

------------------------------------------------------------------------
-- Substitution

-- The substitution operation  subst σ t  replaces the free de Bruijn indices
-- of term t by chosen terms as specified by σ.

-- The substitution σ itself is a map from natural numbers to terms.

Subst : Set
Subst = Nat → Term

-- Given closed contexts ⊢ Γ and ⊢ Δ,
-- substitutions may be typed via Γ ⊢ σ : Δ meaning that
-- Γ ⊢ σ(x) : (subst σ Δ)(x) for all x ∈ dom(Δ).
--
-- The substitution operation is then typed as follows:
-- If Γ ⊢ σ : Δ and Δ ⊢ t : A, then Γ ⊢ subst σ t : subst σ A.
--
-- Although substitutions are untyped, typing helps us
-- to understand the operation on substitutions.

-- We may view σ as the infinite stream σ 0, σ 1, ...

-- Extract the substitution of the first variable.
--
-- If Γ ⊢ σ : Δ∙A  then Γ ⊢ head σ : subst σ A.

head : Subst → Term
head σ = σ 0

-- Remove the first variable instance of a substitution
-- and shift the rest to accommodate.
--
-- If Γ ⊢ σ : Δ∙A then Γ ⊢ tail σ : Δ.

tail : Subst → Subst
tail σ n = σ (1+ n)

-- Substitution of a variable.
--
-- If Γ ⊢ σ : Δ then Γ ⊢ substVar σ x : (subst σ Δ)(x).

substVar : (σ : Subst) (x : Nat) → Term
substVar σ x = σ x

-- Identity substitution.
-- Replaces each variable by itself.
--
-- Γ ⊢ idSubst : Γ.

idSubst : Subst
idSubst = var

-- Weaken a substitution by one.
--
-- If Γ ⊢ σ : Δ then Γ∙A ⊢ wk1Subst σ : Δ.

wk1Subst : Subst → Subst
wk1Subst σ x = wk1 (σ x)

-- Lift a substitution.
--
-- If Γ ⊢ σ : Δ then Γ∙A ⊢ liftSubst σ : Δ∙A.

liftSubst : (σ : Subst) → Subst
liftSubst σ 0    = var 0
liftSubst σ (1+ x) = wk1Subst σ x

-- Transform a weakening into a substitution.
--
-- If ρ : Γ ≤ Δ then Γ ⊢ toSubst ρ : Δ.

toSubst : Wk → Subst
toSubst pr x = var (wkVar pr x)

-- Apply a substitution to a term.
--
-- If Γ ⊢ σ : Δ and Δ ⊢ t : A then Γ ⊢ subst σ t : subst σ A.

mutual
  substGen : (σ : Subst) (g : List (GenT Term)) → List (GenT Term)
  substGen σ [] = []
  substGen σ (⟦ l , t ⟧ ∷ g) = ⟦ l , (subst (repeat liftSubst σ l) t) ⟧ ∷ substGen σ g

  subst : (σ : Subst) (t : Term) → Term
  subst σ (var x) = substVar σ x
  subst σ (gen x c) = gen x (substGen σ c)

-- Extend a substitution by adding a term as
-- the first variable substitution and shift the rest.
--
-- If Γ ⊢ σ : Δ and Γ ⊢ t : subst σ A then Γ ⊢ consSubst σ t : Δ∙A.

consSubst : Subst → Term → Subst
consSubst σ t 0    = t
consSubst σ t (1+ n) = σ n

-- Singleton substitution.
--
-- If Γ ⊢ t : A then Γ ⊢ sgSubst t : Γ∙A.

sgSubst : Term → Subst
sgSubst = consSubst idSubst

-- Compose two substitutions.
--
-- If Γ ⊢ σ : Δ and Δ ⊢ σ′ : Φ then Γ ⊢ σ ₛ•ₛ σ′ : Φ.

_ₛ•ₛ_ : Subst → Subst → Subst
_ₛ•ₛ_ σ σ′ x = subst σ (σ′ x)

-- Composition of weakening and substitution.
--
--  If ρ : Γ ≤ Δ and Δ ⊢ σ : Φ then Γ ⊢ ρ •ₛ σ : Φ.

_•ₛ_ : Wk → Subst → Subst
_•ₛ_ ρ σ x = wk ρ (σ x)

--  If Γ ⊢ σ : Δ and ρ : Δ ≤ Φ then Γ ⊢ σ ₛ• ρ : Φ.

_ₛ•_ : Subst → Wk → Subst
_ₛ•_ σ ρ x = σ (wkVar ρ x)

-- Substitute the first variable of a term with an other term.
--
-- If Γ∙A ⊢ t : B and Γ ⊢ s : A then Γ ⊢ t[s] : B[s].

_[_] : (t : Term) (s : Term) → Term
t [ s ] = subst (sgSubst s) t

-- Substitute the first variable of a term with an other term,
-- but let the two terms share the same context.
--
-- If Γ∙A ⊢ t : B and Γ∙A ⊢ s : A then Γ∙A ⊢ t[s]↑ : B[s]↑.

_[_]↑ : (t : Term) (s : Term) → Term
t [ s ]↑ = subst (consSubst (wk1Subst idSubst) s) t

_[_]↑↑ : (t : Term) (s : Term) → Term
t [ s ]↑↑ = subst (consSubst (wk1Subst (wk1Subst idSubst)) s) t

-- Definition of syntaxic sugar

Unit : ∀ {l} → Term
Unit {l} =  Π Empty l ^ % ° l ▹ Empty l ° l ° l

Idsym : (A x y e : Term) → Term
Idsym A x y e = transp A (Id (wk1 A) (var 0) (wk1 x)) x (Idrefl A x) y e


module Structure.Topology.Properties where


module PatternSynonymAmbiguousParse where

data X : Set where
  if_then_else_ : X -> X -> X -> X
  if_then_      : X -> X -> X
  x             : X

pattern bad x = if x then if x then x else x


postulate A : Set

record R : Set where
  constructor r
  field f : A

test : R → R
test x = let r a = x
             foo : R → A
             foo x = let r a = x in a
         in r (foo (r a))


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

data D : Set where
  @0 c : D

data P : D → Set where
  d : P c


-- MIT License

-- Copyright (c) 2021 Luca Ciccone and Luca Padovani

-- Permission is hereby granted, free of charge, to any person
-- obtaining a copy of this software and associated documentation
-- files (the "Software"), to deal in the Software without
-- restriction, including without limitation the rights to use,
-- copy, modify, merge, publish, distribute, sublicense, and/or sell
-- copies of the Software, and to permit persons to whom the
-- Software is furnished to do so, subject to the following
-- conditions:

-- The above copyright notice and this permission notice shall be
-- included in all copies or substantial portions of the Software.

-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
-- EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES
-- OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
-- NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
-- HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
-- WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
-- FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
-- OTHER DEALINGS IN THE SOFTWARE.

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

open import Size

open import Data.Empty
open import Data.Product
open import Data.Sum
open import Data.List using ([]; _∷_; _∷ʳ_; _++_)

open import Codata.Thunk

open import Relation.Nullary
open import Relation.Nullary.Negation using (contraposition)
open import Relation.Unary using (_∈_; _⊆_)
open import Relation.Binary.PropositionalEquality using (_≡_; _≢_; refl)

open import Function.Base using (case_of_)

open import Common

module Subtyping {ℙ : Set} (message : Message ℙ)
  where

open Message message

open import Trace message
open import SessionType message
open import Transitions message
open import Session message
open import Compliance message
open import HasTrace message

data Sub : SessionType -> SessionType -> Size -> Set where
  nil<:any : ∀{T i} -> Sub nil T i
  end<:def : ∀{T S i} (e : End T) (def : Defined S) -> Sub T S i
  inp<:inp : ∀{f g i}                 (inc : dom f ⊆ dom g) (F : (x : ℙ) -> Thunk (Sub (f x .force) (g x .force)) i) -> Sub (inp f) (inp g) i
  out<:out : ∀{f g i} (W : Witness g) (inc : dom g ⊆ dom f) (F : ∀{x} (!x : x ∈ dom g) -> Thunk (Sub (f x .force) (g x .force)) i) -> Sub (out f) (out g) i

_<:_ : SessionType -> SessionType -> Set
_<:_ T S = Sub T S ∞

sub-defined : ∀{T S} -> T <: S -> Defined T -> Defined S
sub-defined (end<:def _ def) _ = def
sub-defined (inp<:inp _ _) _   = inp
sub-defined (out<:out _ _ _) _ = out

sub-sound : ∀{T S R} -> Compliance (R # T) -> T <: S -> ∞Compliance (R # S)
force (sub-sound (win#def w def) sub) = win#def w (sub-defined sub def)
force (sub-sound (out#inp (_ , !x) F) (end<:def (inp U) def)) with U _ (proj₂ (compliance->defined (F !x .force)))
... | ()
force (sub-sound (out#inp (_ , !x) F) (inp<:inp _ G)) =
  out#inp (_ , !x) λ !x -> sub-sound (F !x .force) (G _ .force)
force (sub-sound (inp#out (_ , !x) F) (end<:def (out U) def)) = ⊥-elim (U _ !x)
force (sub-sound (inp#out (_ , !x) F) (out<:out {f} {g} (_ , !y) inc G)) =
  inp#out (_ , !y) λ !x -> sub-sound (F (inc !x) .force) (G !x .force)

SubtypingQ : SessionType -> SessionType -> Set
SubtypingQ T S = ∀{R} -> Compliance (R # T) -> Compliance (R # S)

if-eq : ℙ -> SessionType -> SessionType -> Continuation
force (if-eq x T S y) with x ?= y
... | yes _ = T
... | no _  = S

input* : SessionType
input* = inp λ _ -> λ where .force -> win

input : ℙ -> SessionType -> SessionType -> SessionType
input x T S = inp (if-eq x T S)

input*-but : ℙ -> SessionType
input*-but x = input x nil win

output : ℙ -> SessionType -> SessionType -> SessionType
output x T S = out (if-eq x T S)

input-if-eq-comp :
  ∀{f x T} ->
  Compliance (T # f x .force) ->
  ∀{y} (!y : y ∈ dom f) ->
  ∞Compliance (if-eq x T win y .force # f y .force)
force (input-if-eq-comp {_} {x} comp {y} !y) with x ?= y
... | yes refl = comp
... | no neq = win#def Win-win !y

output-if-eq-comp :
  ∀{f : Continuation}{x}{T} ->
  Compliance (T # f x .force) ->
  ∀{y} (!y : y ∈ dom (if-eq x T nil)) ->
  ∞Compliance (if-eq x T nil y .force # f y .force)
force (output-if-eq-comp {_} {x} comp {y} !y) with x ?= y
... | yes refl = comp
force (output-if-eq-comp {_} {x} comp {y} ()) | no neq

input*-comp : ∀{f} (W : Witness f) -> Compliance (input* # out f)
input*-comp W = inp#out W λ !x -> λ where .force -> win#def Win-win !x

input*-but-comp :
  ∀{f x}
  (W : Witness f)
  (N : ¬ x ∈ dom f) ->
  Compliance (input*-but x # out f)
input*-but-comp {f} {x} W N = inp#out W aux
  where
    aux : ∀{y : ℙ} -> (fy : y ∈ dom f) -> ∞Compliance (if-eq x nil win y .force # f y .force)
    force (aux {y} fy) with x ?= y
    ... | yes refl = ⊥-elim (N fy)
    ... | no neq = win#def Win-win fy

∈-output-if-eq : ∀{R} (x : ℙ) -> Defined R -> x ∈ dom (if-eq x R nil)
∈-output-if-eq x def with x ?= x
... | yes refl = def
... | no neq = ⊥-elim (neq refl)

input-comp : ∀{g x R} -> Compliance (R # g x .force) -> Compliance (input x R win # out g)
input-comp {g} {x} comp = inp#out (x , proj₂ (compliance->defined comp)) (input-if-eq-comp {g} comp)

output-comp : ∀{f x R} -> Compliance (R # f x .force) -> Compliance (output x R nil # inp f)
output-comp {f} {x} comp = out#inp (_ , ∈-output-if-eq x (proj₁ (compliance->defined comp))) (output-if-eq-comp {f} comp)

sub-inp-inp :
  ∀{f g}
  (spec : SubtypingQ (inp f) (inp g))
  (x : ℙ) ->
  SubtypingQ (f x .force) (g x .force)
sub-inp-inp spec x comp with spec (output-comp comp)
... | win#def (out U) def = ⊥-elim (U _ (∈-output-if-eq x (proj₁ (compliance->defined comp))))
... | out#inp (y , fy) F with F fy .force
... | comp' with x ?= y
... | yes refl = comp'
sub-inp-inp spec x comp | out#inp (y , fy) F | win#def () def | no neq

sub-out-out :
  ∀{f g}
  (spec : SubtypingQ (out f) (out g)) ->
  ∀{x} -> x ∈ dom g ->
  SubtypingQ (f x .force) (g x .force)
sub-out-out spec {x} gx comp with spec (input-comp comp)
... | inp#out W F with F gx .force
... | comp' with x ?= x
... | yes refl = comp'
... | no neq = ⊥-elim (neq refl)

sub-out->def :
  ∀{f g}
  (spec : SubtypingQ (out f) (out g))
  (Wf : Witness f) ->
  ∀{x} (gx : x ∈ dom g) ->
  x ∈ dom f
sub-out->def {f} spec Wf {x} gx with x ∈? f
... | yes fx = fx
... | no nfx with spec (input*-but-comp Wf nfx)
... | inp#out W F with F gx .force
... | res with x ?= x
sub-out->def {f} spec Wf {x} gx | no nfx | inp#out W F | win#def () def | yes refl
... | no neq = ⊥-elim (neq refl)

sub-inp->def : ∀{f g} (spec : SubtypingQ (inp f) (inp g)) -> ∀{x} (fx : x ∈ dom f) -> x ∈ dom g
sub-inp->def {f} spec {x} fx with spec {output x win nil} (output-comp (win#def Win-win fx))
... | win#def (out U) def = ⊥-elim (U _ (∈-output-if-eq x out))
... | out#inp W F with F (∈-output-if-eq x out) .force
... | comp = proj₂ (compliance->defined comp)

sub-complete : ∀{T S i} -> SubtypingQ T S -> Thunk (Sub T S) i
force (sub-complete {nil} {_} spec) = nil<:any
force (sub-complete {inp f} {nil} spec) with spec {win} (win#def Win-win inp)
... | win#def _ ()
force (sub-complete {inp _} {inp _} spec) = inp<:inp (sub-inp->def spec) λ x -> sub-complete (sub-inp-inp spec x)
force (sub-complete {inp f} {out _} spec) with Empty? f
... | inj₁ U = end<:def (inp U) out
... | inj₂ (x , ?x) with spec {output x win nil} (output-comp (win#def Win-win ?x))
... | win#def (out U) def = ⊥-elim (U x (∈-output-if-eq x out))
force (sub-complete {out f} {nil} spec) with spec {win} (win#def Win-win out)
... | win#def _ ()
force (sub-complete {out f} {inp _} spec) with Empty? f
... | inj₁ U = end<:def (out U) inp
... | inj₂ W with spec {input*} (input*-comp W)
... | win#def () _
force (sub-complete {out f} {out g} spec) with Empty? f
... | inj₁ Uf = end<:def (out Uf) out
... | inj₂ Wf with Empty? g
... | inj₂ Wg = out<:out Wg (sub-out->def spec Wf) λ !x -> sub-complete (sub-out-out spec !x)
... | inj₁ Ug with spec {input*} (input*-comp Wf)
... | inp#out (_ , !x) F = ⊥-elim (Ug _ !x)

SubtypingQ->SubtypingS : ∀{T S} -> SubtypingQ T S -> SubtypingS T S
SubtypingQ->SubtypingS spec comp = compliance-sound (spec (compliance-complete comp .force))

SubtypingS->SubtypingQ : ∀{T S} -> SubtypingS T S -> SubtypingQ T S
SubtypingS->SubtypingQ spec comp = compliance-complete (spec (compliance-sound comp)) .force

sub-excluded :
  ∀{T S φ}
  (sub : T <: S)
  (tφ  : T HasTrace φ)
  (nsφ : ¬ S HasTrace φ) ->
  ∃[ ψ ] ∃[ x ]
  (ψ ⊑ φ × T HasTrace ψ × S HasTrace ψ × T HasTrace (ψ ∷ʳ O x) × ¬ S HasTrace (ψ ∷ʳ O x))
sub-excluded nil<:any tφ nsφ = ⊥-elim (nil-has-no-trace tφ)
sub-excluded (end<:def e def) tφ nsφ with end-has-empty-trace e tφ
... | eq rewrite eq = ⊥-elim (nsφ (_ , def , refl))
sub-excluded (inp<:inp inc F) (_ , tdef , refl) nsφ =
  ⊥-elim (nsφ (_ , inp , refl))
sub-excluded (inp<:inp {f} {g} inc F) (_ , tdef , step inp tr) nsφ =
  let ψ , x , pre , tψ , sψ , tψx , nψx = sub-excluded (F _ .force) (_ , tdef , tr) (contraposition inp-has-trace nsφ) in
  _ , _ , some pre , inp-has-trace tψ , inp-has-trace sψ , inp-has-trace tψx , inp-has-no-trace nψx
sub-excluded (out<:out W inc F) (_ , tdef , refl) nsφ =
  ⊥-elim (nsφ (_ , out , refl))
sub-excluded (out<:out {f} {g} W inc F) (_ , tdef , step (out {_} {x} fx) tr) nsφ with x ∈? g
... | yes gx =
  let ψ , x , pre , tψ , sψ , tψx , nψx = sub-excluded (F gx .force) (_ , tdef , tr) (contraposition out-has-trace nsφ) in
  _ , _ , some pre , out-has-trace tψ , out-has-trace sψ , out-has-trace tψx , out-has-no-trace nψx
... | no ngx =
  [] , _ , none , (_ , out , refl) , (_ , out , refl) , (_ , fx , step (out fx) refl) , λ { (_ , _ , step (out gx) _) → ⊥-elim (ngx gx) }

sub-after : ∀{T S φ} (tφ : T HasTrace φ) (sφ : S HasTrace φ) -> T <: S -> after tφ <: after sφ
sub-after (_ , _ , refl) (_ , _ , refl) sub = sub
sub-after tφ@(_ , _ , step inp _) (_ , _ , step inp _) (end<:def e _) with end-has-empty-trace e tφ
... | ()
sub-after (_ , tdef , step inp tr) (_ , sdef , step inp sr) (inp<:inp _ F) =
  sub-after (_ , tdef , tr) (_ , sdef , sr) (F _ .force)
sub-after tφ@(_ , _ , step (out _) _) (_ , _ , step (out _) _) (end<:def e _) with end-has-empty-trace e tφ
... | ()
sub-after (_ , tdef , step (out _) tr) (_ , sdef , step (out gx) sr) (out<:out _ _ F) =
  sub-after (_ , tdef , tr) (_ , sdef , sr) (F gx .force)

sub-simulation :
  ∀{R R' T S S' φ}
  (comp : Compliance (R # T))
  (sub  : T <: S)
  (rr   : Transitions R (co-trace φ) R')
  (sr   : Transitions S φ S') ->
  ∃[ T' ] (Transitions T φ T' × T' <: S')
sub-simulation comp sub refl refl = _ , refl , sub
sub-simulation (win#def (out U) def) sub (step (out hx) rr) (step inp sr) = ⊥-elim (U _ hx)
sub-simulation (out#inp W F) (end<:def (inp U) def) (step (out hx) rr) (step inp sr) with F hx .force
... | comp = ⊥-elim (U _ (proj₂ (compliance->defined comp)))
sub-simulation (out#inp W F) (inp<:inp inc G) (step (out hx) rr) (step inp sr) =
  let _ , tr , sub = sub-simulation (F hx .force) (G _ . force) rr sr in
  _ , step inp tr , sub
sub-simulation (inp#out {h} {f} (_ , fx) F) (end<:def (out U) def) (step inp rr) (step (out gx) sr) with F fx .force
... | comp = ⊥-elim (U _ (proj₂ (compliance->defined comp)))
sub-simulation (inp#out W F) (out<:out W₁ inc G) (step inp rr) (step (out fx) sr) =
  let _ , tr , sub = sub-simulation (F (inc fx) .force) (G fx .force) rr sr in
  _ , step (out (inc fx)) tr , sub


{-# OPTIONS --instance-search-depth=5 --show-implicit #-}

open import Oscar.Prelude
open import Oscar.Class.Smap
open import Oscar.Class.Surjextensionality
open import Oscar.Class.Symmetry
open import Oscar.Class.Transitivity
open import Oscar.Data.Proposequality
open import Oscar.Data.Surjcollation
import Oscar.Class.Surjection.⋆

module Oscar.Data.Surjextenscollation where

module _ {𝔵 𝔞 𝔞̇ 𝔟 𝔟̇} {𝔛 : Ø 𝔵}
  (𝔄 : 𝔛 → 𝔛 → Ø 𝔞)
  (𝔅 : 𝔛 → Ø 𝔟)
  ⦃ _ : Smaphomarrow!.class 𝔄 𝔅 ⦄
  (𝔄̇ : ∀ {x y} → 𝔄 x y → 𝔄 x y → Ø 𝔞̇)
  (let ℭ : 𝔛 → Ø 𝔵 ∙̂ 𝔞 ∙̂ 𝔞̇ ∙̂ ↑̂ 𝔟̇
       ℭ = LeftExtensionṖroperty 𝔟̇ 𝔄 𝔄̇)
  (𝔅̇ : ∀ {y} → 𝔅 y → 𝔅 y → Ø 𝔟̇)
    ⦃ _ : ∀ {y} → Symmetry.class (𝔅̇ {y}) ⦄
    ⦃ _ : ∀ {y} → Transitivity.class (𝔅̇ {y}) ⦄
    ⦃ _ : Surjextensionality!.class 𝔄 𝔄̇ (Extension 𝔅) (Pointwise 𝔅̇) ⦄
  where

  surjextenscollation[_/_]⟦_/_⟧ : ∀ {m} → 𝔅 m → 𝔅 m → ℭ m
  surjextenscollation[_/_]⟦_/_⟧ s t =
    surjcollation⟦ 𝔄 / 𝔅̇ ⟧ s t , λ f≐g f◃s=f◃t →
      -- FIXME this (`surjextensionality[ Pointwise 𝔅̇ ] ⦃ ! ⦄ f≐g t ∙ f◃s=f◃t ∙ symmetry (surjextensionality[ Pointwise 𝔅̇ ] ⦃ ! ⦄ f≐g s)`) used to be a workaround for "instance search depth exhausted", but now does not seem to help. See the FIXME note in Oscar.Class.Surjextensionality.
      ⟪ f≐g ⟫[ Pointwise 𝔅̇ ] t ∙ f◃s=f◃t ∙ symmetry (⟪ f≐g ⟫[ Pointwise 𝔅̇ ] s)

module _ {𝔵 𝔞 𝔞̇} {𝔛 : Ø 𝔵} {𝔄 : 𝔛 → 𝔛 → Ø 𝔞}
  (𝔄̇ : ∀ {x y} → 𝔄 x y → 𝔄 x y → Ø 𝔞̇)
    {𝔟} {𝔅 : 𝔛 → Ø 𝔟}
    {𝔟̇} {𝔅̇ : ∀ {y} → 𝔅 y → 𝔅 y → Ø 𝔟̇}
    ⦃ _ : Smaphomarrow!.class 𝔄 𝔅 ⦄
    ⦃ _ : ∀ {y} → Symmetry.class (𝔅̇ {y}) ⦄
    ⦃ _ : ∀ {y} → Transitivity.class (𝔅̇ {y}) ⦄
    ⦃ _ : Surjextensionality!.class 𝔄 𝔄̇ (Extension 𝔅) (Pointwise 𝔅̇) ⦄
  where
  surjextenscollation⟦_⟧ = surjextenscollation[ 𝔄 / 𝔅 ]⟦ 𝔄̇ / 𝔅̇ ⟧

module _ {𝔵 𝔞 𝔞̇ 𝔟 𝔟̇} {𝔛 : Ø 𝔵} {𝔄 : 𝔛 → 𝔛 → Ø 𝔞} {𝔅 : 𝔛 → Ø 𝔟}
  (𝔄̇ : ∀ {x y} → 𝔄 x y → 𝔄 x y → Ø 𝔞̇)
  (𝔅̇ : ∀ {y} → 𝔅 y → 𝔅 y → Ø 𝔟̇)
    ⦃ _ : Smaphomarrow!.class 𝔄 𝔅 ⦄
    ⦃ _ : ∀ {y} → Symmetry.class (𝔅̇ {y}) ⦄
    ⦃ _ : ∀ {y} → Transitivity.class (𝔅̇ {y}) ⦄
    ⦃ _ : Surjextensionality!.class 𝔄 𝔄̇ (Extension 𝔅) (Pointwise 𝔅̇) ⦄
  where
  surjextenscollation⟦_/_⟧ = surjextenscollation[ 𝔄 / 𝔅 ]⟦ 𝔄̇ / 𝔅̇ ⟧

module Surjextenscollation
  {𝔵 𝔞 𝔞̇} {𝔛 : Ø 𝔵}
  (𝔄 : 𝔛 → 𝔛 → Ø 𝔞)
  (𝔄̇ : ∀ {x y} → 𝔄 x y → 𝔄 x y → Ø 𝔞̇)
    {𝔟} {𝔅 : 𝔛 → Ø 𝔟}
    {𝔟̇} {𝔅̇ : ∀ {y} → 𝔅 y → 𝔅 y → Ø 𝔟̇}
    ⦃ _ : Smaphomarrow!.class 𝔄 𝔅 ⦄
    ⦃ _ : ∀ {y} → Symmetry.class (𝔅̇ {y}) ⦄
    ⦃ _ : ∀ {y} → Transitivity.class (𝔅̇ {y}) ⦄
    ⦃ _ : Surjextensionality!.class 𝔄 𝔄̇ (Extension 𝔅) (Pointwise 𝔅̇) ⦄
  where
  method = surjextenscollation[ 𝔄 / 𝔅 ]⟦ 𝔄̇ / 𝔅̇ ⟧

  infix 18 _⟹_
  _⟹_ = method

module _
  {𝔵} {𝔛 : Ø 𝔵}
  {𝔞₁} {𝔄₁ : 𝔛 → Ø 𝔞₁}
  {𝔞₂} {𝔄₂ : 𝔛 → Ø 𝔞₂}
 (𝔄 : 𝔛 → 𝔛 → Ø 𝔞₁ ∙̂ 𝔞₂)
  ⦃ _ : 𝔄 ≡ Arrow 𝔄₁ 𝔄₂ ⦄
  (let 𝔄 = Arrow 𝔄₁ 𝔄₂)
  where
  open Surjextenscollation 𝔄 _≡̇_ public using () renaming (method to ≡-surjextenscollation⟦_⟧) public


{-# OPTIONS --without-K #-}
module function.isomorphism.properties where

open import level
open import sum
open import sets.nat.core
open import equality.core
open import equality.calculus
open import equality.reasoning
open import function.core
open import function.fibration
open import function.overloading
open import function.extensionality.core
open import function.extensionality.proof
open import function.isomorphism.core
open import function.isomorphism.coherent
open import function.isomorphism.lift
open import function.isomorphism.utils
open import function.isomorphism.two-out-of-six
open import hott.equivalence.core
open import hott.equivalence.alternative
open import hott.level.core
open import hott.loop.core
open import sets.unit

iso-adjunction : ∀ {i j}{X : Set i}{Y : Set j}
               → (isom : X ≅ Y)(x : X)(y : Y)
               → (apply isom x ≡ y) ≅ (x ≡ invert isom y)
iso-adjunction {i}{j}{X}{Y} isom x y
  = family-eq-iso total' (λ { (y , x) q → comm' x y q }) (y , x)
  where
    open _≅_ isom
    open ≅-Reasoning

    to-we : weak-equiv to
    to-we = proj₂ (≅⇒≈ isom)

    total' : (Σ (Y × X) λ { (y , x) → to x ≡ y })
           ≅ (Σ (Y × X) λ { (y , x) → x ≡ from y})
    total' = Σ-assoc-iso
           ·≅ ( Σ-ap-iso refl≅ λ y
              → contr-⊤-iso (to-we y)
              ·≅ sym≅ (contr-⊤-iso (singl-contr' (from y))) )
           ·≅ sym≅ Σ-assoc-iso

    comm' : (x : X)(y : Y)(p : to x ≡ y)
          → proj₁ (apply total' ((y , x) , p)) ≡ (y , x)
    comm' x y q = ap (_,_ y) (sym (ap from q) · iso₁ x)

private
  iso≡-lem : ∀ {i j}{X : Set i}{Y : Set j}
           → (isom : X ≅ Y)
           → (x x' : X)
           → weak-equiv (λ (p : x ≡ x') → ap (invert isom) (ap (apply isom) p))
  iso≡-lem {X = X} isom x x' = step₃
    where
      step₁ : ∀ {k}{A : Set k}(a a' : A)
            → weak-equiv {X = a ≡ a'} {Y = a ≡ a'} (ap (λ x → x))
      step₁ a a' = subst weak-equiv (sym (funext ap-id)) (proj₂ (≅⇒≈ refl≅))

      step₂ : weak-equiv (λ (p : x ≡ x') → ap (invert isom ∘ apply isom) p)
      step₂ = subst (λ u → weak-equiv {X = x ≡ x'} (ap u)) (sym (funext (_≅_.iso₁ isom)))
                    (step₁ x x')

      step₃ = subst weak-equiv (sym (funext λ p → ap-hom (apply isom) (invert isom) p)) step₂

iso≡ : ∀ {i j}{X : Set i}{Y : Set j}
     → (isom : X ≅ Y)
     → {x x' : X}
     → (x ≡ x')
     ≅ (apply isom x ≡ apply isom x')
iso≡ isom {x}{x'} = two-out-of-six.f-iso
  (ap (apply isom))
  (ap (invert isom))
  (ap (apply isom))
  (iso≡-lem isom x x')
  (iso≡-lem (sym≅ isom) (apply isom x) (apply isom x'))

private
  abstract
    Ω-iso' : ∀ {i j}{X : Set i}{Y : Set j}(n : ℕ)
           → (φ : X ≅ Y)(x : X)
           → Ω n x ≅ Ω n (apply φ x)
    Ω-iso' {X = X}{Y = Y} zero φ x = φ
    Ω-iso' (suc n) φ x = Ω-iso' n (iso≡ φ) refl

    Ω-iso-β : ∀ {i j}{X : Set i}{Y : Set j}(n : ℕ)
            → (φ : X ≅ Y)(x : X)
            → (p : Ω n x)
            → apply (Ω-iso' n φ x) p ≡ mapΩ n (apply φ) p
    Ω-iso-β zero φ x p = refl
    Ω-iso-β (suc n) φ x p = Ω-iso-β n (iso≡ φ) refl p

Ω-iso : ∀ {i j}{X : Set i}{Y : Set j}(n : ℕ)
      → (φ : X ≅ Y)(x : X)
      → Ω n x ≅ Ω n (apply φ x)
Ω-iso n φ x = ≈⇒≅ ( (λ p → mapΩ n (apply φ) p)
                  , subst weak-equiv eq we)
  where
    abstract
      we : weak-equiv (apply (Ω-iso' n φ x))
      we = proj₂ (≅⇒≈ (Ω-iso' n φ x))

      eq : apply (Ω-iso' n φ x) ≡ mapΩ n (apply φ)
      eq = funext (Ω-iso-β n φ x)

abstract
  subtype-eq : ∀ {i j k}{A : Set i}{P : A → Set j}
             → ((x : A) → h 1 (P x))
             → {X : Set k}
             → (isom : X ≅ Σ A P)
             → {x y : X}
             → (proj₁ (apply isom x) ≡ proj₁ (apply isom y))
             → x ≡ y
  subtype-eq hP isom p = iso⇒inj isom
    (unapΣ (p , h1⇒prop (hP _) _ _))


------------------------------------------------------------------------
-- The Agda standard library
--
-- Dependent product combinators for setoid equality preserving
-- functions
------------------------------------------------------------------------

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

module Data.Product.Function.Dependent.Setoid where

open import Data.Product
open import Data.Product.Relation.Binary.Pointwise.Dependent
open import Relation.Binary
open import Function
open import Function.Equality as F using (_⟶_; _⟨$⟩_)
open import Function.Equivalence as Eq
  using (Equivalence; _⇔_; module Equivalence)
open import Function.Injection as Inj
  using (Injection; Injective; _↣_; module Injection)
open import Function.Inverse as Inv
  using (Inverse; _↔_; module Inverse)
open import Function.LeftInverse as LeftInv
  using (LeftInverse; _↞_; _LeftInverseOf_; _RightInverseOf_; module LeftInverse)
open import Function.Surjection as Surj
  using (Surjection; _↠_; module Surjection)
open import Relation.Binary as B
open import Relation.Binary.Indexed.Heterogeneous
  using (IndexedSetoid)
open import Relation.Binary.Indexed.Heterogeneous.Construct.At
  using (_atₛ_)
open import Relation.Binary.PropositionalEquality as P using (_≡_)

------------------------------------------------------------------------
-- Properties related to "relatedness"
------------------------------------------------------------------------

private

  subst-cong : ∀ {i a p} {I : Set i} {A : I → Set a}
               (P : ∀ {i} → A i → A i → Set p) {i i′} {x y : A i}
               (i≡i′ : i ≡ i′) →
               P x y → P (P.subst A i≡i′ x) (P.subst A i≡i′ y)
  subst-cong P P.refl p = p

⟶ : ∀ {a₁ a₂ b₁ b₁′ b₂ b₂′}
      {A₁ : Set a₁} {A₂ : Set a₂}
      {B₁ : IndexedSetoid A₁ b₁ b₁′} (B₂ : IndexedSetoid A₂ b₂ b₂′)
    (f : A₁ → A₂) → (∀ {x} → (B₁ atₛ x) ⟶ (B₂ atₛ (f x))) →
    setoid (P.setoid A₁) B₁ ⟶ setoid (P.setoid A₂) B₂
⟶ {A₁ = A₁} {A₂} {B₁} B₂ f g = record
  { _⟨$⟩_ = fg
  ; cong  = fg-cong
  }
  where
  open B.Setoid (setoid (P.setoid A₁) B₁)
    using () renaming (_≈_ to _≈₁_)
  open B.Setoid (setoid (P.setoid A₂) B₂)
    using () renaming (_≈_ to _≈₂_)
  open B using (_=[_]⇒_)

  fg = map f (_⟨$⟩_ g)

  fg-cong : _≈₁_ =[ fg ]⇒ _≈₂_
  fg-cong (P.refl , ∼) = (P.refl , F.cong g ∼)

module _ {a₁ a₂ b₁ b₁′ b₂ b₂′} {A₁ : Set a₁} {A₂ : Set a₂} where

  equivalence : {B₁ : IndexedSetoid A₁ b₁ b₁′} {B₂ : IndexedSetoid A₂ b₂ b₂′}
    (A₁⇔A₂ : A₁ ⇔ A₂) →
    (∀ {x} → _⟶_ (B₁ atₛ x) (B₂ atₛ (Equivalence.to   A₁⇔A₂ ⟨$⟩ x))) →
    (∀ {y} → _⟶_ (B₂ atₛ y) (B₁ atₛ (Equivalence.from A₁⇔A₂ ⟨$⟩ y))) →
    Equivalence (setoid (P.setoid A₁) B₁) (setoid (P.setoid A₂) B₂)
  equivalence {B₁} {B₂} A₁⇔A₂ B-to B-from = record
    { to   = ⟶ B₂ (_⟨$⟩_ (to   A₁⇔A₂)) B-to
    ; from = ⟶ B₁ (_⟨$⟩_ (from A₁⇔A₂)) B-from
    } where open Equivalence

  equivalence-↞ : (B₁ : IndexedSetoid A₁ b₁ b₁′) {B₂ : IndexedSetoid A₂ b₂ b₂′}
    (A₁↞A₂ : A₁ ↞ A₂) →
    (∀ {x} → Equivalence (B₁ atₛ (LeftInverse.from A₁↞A₂ ⟨$⟩ x))
                         (B₂ atₛ x)) →
    Equivalence (setoid (P.setoid A₁) B₁) (setoid (P.setoid A₂) B₂)
  equivalence-↞ B₁ {B₂} A₁↞A₂ B₁⇔B₂ =
    equivalence (LeftInverse.equivalence A₁↞A₂) B-to B-from
    where
    B-to : ∀ {x} → _⟶_ (B₁ atₛ x) (B₂ atₛ (LeftInverse.to A₁↞A₂ ⟨$⟩ x))
    B-to = record
      { _⟨$⟩_ = λ x → Equivalence.to B₁⇔B₂ ⟨$⟩
                      P.subst (IndexedSetoid.Carrier B₁)
                         (P.sym $ LeftInverse.left-inverse-of A₁↞A₂ _)
                         x
      ; cong  = F.cong (Equivalence.to B₁⇔B₂) ∘
              subst-cong (λ {x} → IndexedSetoid._≈_ B₁ {x} {x})
                         (P.sym (LeftInverse.left-inverse-of A₁↞A₂ _))
      }

    B-from : ∀ {y} → _⟶_ (B₂ atₛ y) (B₁ atₛ (LeftInverse.from A₁↞A₂ ⟨$⟩ y))
    B-from = Equivalence.from B₁⇔B₂

  equivalence-↠ : {B₁ : IndexedSetoid A₁ b₁ b₁′} (B₂ : IndexedSetoid A₂ b₂ b₂′)
    (A₁↠A₂ : A₁ ↠ A₂) →
    (∀ {x} → Equivalence (B₁ atₛ x) (B₂ atₛ (Surjection.to A₁↠A₂ ⟨$⟩ x))) →
    Equivalence (setoid (P.setoid A₁) B₁) (setoid (P.setoid A₂) B₂)
  equivalence-↠ {B₁ = B₁} B₂ A₁↠A₂ B₁⇔B₂ =
    equivalence (Surjection.equivalence A₁↠A₂) B-to B-from
    where
    B-to : ∀ {x} → _⟶_ (B₁ atₛ x) (B₂ atₛ (Surjection.to A₁↠A₂ ⟨$⟩ x))
    B-to = Equivalence.to B₁⇔B₂

    B-from : ∀ {y} → _⟶_ (B₂ atₛ y) (B₁ atₛ (Surjection.from A₁↠A₂ ⟨$⟩ y))
    B-from = record
      { _⟨$⟩_ = λ x → Equivalence.from B₁⇔B₂ ⟨$⟩
                      P.subst (IndexedSetoid.Carrier B₂)
                         (P.sym $ Surjection.right-inverse-of A₁↠A₂ _)
                         x
      ; cong  = F.cong (Equivalence.from B₁⇔B₂) ∘
              subst-cong (λ {x} → IndexedSetoid._≈_ B₂ {x} {x})
                         (P.sym (Surjection.right-inverse-of A₁↠A₂ _))
      }

  injection : {B₁ : IndexedSetoid A₁ b₁ b₁′} (B₂ : IndexedSetoid A₂ b₂ b₂′) →
    (A₁↣A₂ : A₁ ↣ A₂) →
    (∀ {x} → Injection (B₁ atₛ x) (B₂ atₛ (Injection.to A₁↣A₂ ⟨$⟩ x))) →
    Injection (setoid (P.setoid A₁) B₁) (setoid (P.setoid A₂) B₂)
  injection {B₁ = B₁} B₂ A₁↣A₂ B₁↣B₂ = record
    { to        = to
    ; injective = inj
    }
    where
    to = ⟶ B₂ (Injection.to A₁↣A₂ ⟨$⟩_) (Injection.to B₁↣B₂)

    inj : Injective to
    inj (x , y) =
      Injection.injective A₁↣A₂ x ,
      lemma (Injection.injective A₁↣A₂ x) y
      where
      lemma :
        ∀ {x x′}
          {y : IndexedSetoid.Carrier B₁ x} {y′ : IndexedSetoid.Carrier B₁ x′} →
        x ≡ x′ →
        (eq : IndexedSetoid._≈_ B₂ (Injection.to B₁↣B₂ ⟨$⟩ y)
                              (Injection.to B₁↣B₂ ⟨$⟩ y′)) →
        IndexedSetoid._≈_ B₁ y y′
      lemma P.refl = Injection.injective B₁↣B₂

  left-inverse : (B₁ : IndexedSetoid A₁ b₁ b₁′) {B₂ : IndexedSetoid A₂ b₂ b₂′} →
    (A₁↞A₂ : A₁ ↞ A₂) →
    (∀ {x} → LeftInverse (B₁ atₛ (LeftInverse.from A₁↞A₂ ⟨$⟩ x))
                         (B₂ atₛ x)) →
    LeftInverse (setoid (P.setoid A₁) B₁) (setoid (P.setoid A₂) B₂)
  left-inverse B₁ {B₂} A₁↞A₂ B₁↞B₂ = record
    { to              = Equivalence.to   eq
    ; from            = Equivalence.from eq
    ; left-inverse-of = left
    }
    where
    eq = equivalence-↞ B₁ A₁↞A₂ (LeftInverse.equivalence B₁↞B₂)

    left : Equivalence.from eq LeftInverseOf Equivalence.to eq
    left (x , y) =
      LeftInverse.left-inverse-of A₁↞A₂ x ,
      IndexedSetoid.trans B₁
        (LeftInverse.left-inverse-of B₁↞B₂ _)
        (lemma (P.sym (LeftInverse.left-inverse-of A₁↞A₂ x)))
      where
      lemma :
        ∀ {x x′ y} (eq : x ≡ x′) →
        IndexedSetoid._≈_ B₁ (P.subst (IndexedSetoid.Carrier B₁) eq y) y
      lemma P.refl = IndexedSetoid.refl B₁

  surjection : {B₁ : IndexedSetoid A₁ b₁ b₁′} (B₂ : IndexedSetoid A₂ b₂ b₂′) →
    (A₁↠A₂ : A₁ ↠ A₂) →
    (∀ {x} → Surjection (B₁ atₛ x) (B₂ atₛ (Surjection.to A₁↠A₂ ⟨$⟩ x))) →
    Surjection (setoid (P.setoid A₁) B₁) (setoid (P.setoid A₂) B₂)
  surjection B₂ A₁↠A₂ B₁↠B₂ = record
    { to         = Equivalence.to eq
    ; surjective = record
      { from             = Equivalence.from eq
      ; right-inverse-of = right
      }
    }
    where
    eq = equivalence-↠ B₂ A₁↠A₂ (Surjection.equivalence B₁↠B₂)

    right : Equivalence.from eq RightInverseOf Equivalence.to eq
    right (x , y) =
      Surjection.right-inverse-of A₁↠A₂ x ,
      IndexedSetoid.trans B₂
        (Surjection.right-inverse-of B₁↠B₂ _)
        (lemma (P.sym $ Surjection.right-inverse-of A₁↠A₂ x))
      where
      lemma : ∀ {x x′ y} (eq : x ≡ x′) →
              IndexedSetoid._≈_ B₂ (P.subst (IndexedSetoid.Carrier B₂) eq y) y
      lemma P.refl = IndexedSetoid.refl B₂

  -- See also Data.Product.Function.Dependent.Setoid.WithK.inverse.


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

module Sharp where
  open import Basics
  open import Flat

  open import lib.NType2
  open import lib.Equivalence2
  open import lib.types.Modality

  -- --------------------------------------------------------------------------------------
  -- Postulating the ♯ Modality
  -- --------------------------------------------------------------------------------------
  postulate
    -- Here, I've tried to implement the rules for ♯ as in Shulman as closely as possible
    -- to the sequents in Figure 3 of Section 3.

    -- I'm pretty convinced now that this approach will work
    -- However, as currently (02/18/19) rewrite rules do not see the ♭ modality,
    -- it is not fully operational (and, clearly, has not been cleaned up).

    -- The litmus is proving the lexness of ♯ along the lines of Shulman 3.7

    {-
      We implement the ♯ typing operations in two ways.

      First, naively, as follows:
    -}

    -- Rule 1/5: Given a type A, we may form ♯ A
    ♯ : {i : ULevel} → Type i → Type i

    -- Rule 2/5: Given an a : A, we may form a^♯ : ♯ A
    _^♯ : {i : ULevel} {A : Type i} → A → ♯ A

    -- Rule 3/5: Given a crisp a :: ♯ A, we may form a ↓♯ : A
    _↓♯ : {@♭ i : ULevel} {@♭ A : Type i} → ♯ A ::→ A

    {-
      Rule 4/5
      Given a :: A, we have that (a ^♯) ↓♯ ≡ a.

      Δ | ∙ ⊢ a : A
      -------------------------
      Δ | Γ ⊢ (a ^♯) ↓♯ ≡ a : A

      A and a are crisp, but we can have any other context Γ appear
      which is fine, we just don't mention it.
    -}
    ^↓♯ : {@♭ i : ULevel} {@♭ A : Type i} (@♭ a : A)
          → ((a ^♯) ↓♯) ↦ a
    {-# REWRITE ^↓♯ #-}

    {-
      Rule 5/5
      Given a : ♯ A in any context, we have (a ↓♯) ^♯ ≡ a

      Δ | Γ ⊢ a : ♯ A
      ---------------
      Δ | Γ ⊢ (a ↓♯) ^♯ ≡ a : ♯ A

      Here we can do this in any context, but for agda that might mean
      "factoring through" the ptwise operations first...

      [WARNING] This implementation needs A to be crisp, and so doesn't
                express the above sequent (I think...)
    -}
    ↓^♯ : {@♭ i : ULevel} {@♭ A : Type i} (@♭ a : ♯ A)
          → ((a ↓♯) ^♯) ↦ a
    {-# REWRITE ↓^♯ #-}

    {-
      Now, we will postulate "pointwise" versions of the above operations which
      take in an additional crisp "context" Γ or Δ. The name Γ or Δ is chosen to match
      the role of the explicit "context" with its analogy in Shulman.

      In each of these, the context either becomes cohesive or not, according to the
      rules from Shulman (which are reproduced here for comparison).
    -}

    {-
      Rule 1/5, pointwise version
      If one has a crisp context Γ and a type A which depends crisply on Γ,
      Then one may form ♯ A which depends cohesively on Γ.

      Or, read backwards, to construct ♯ A in the context Γ, it suffices to assume
      That every variable x : Γ appearing in A is crisp.

      Δ, Γ | ∙ ⊢ A : Type
      -------------------
      Δ | Γ  ⊢ ♯ A : Type
    -}
    -- compare to ♯ : {i : ULevel} → Type i → Type i
    ♯-ptwise : {@♭ i : ULevel} {@♭ Γ : Type i} {j : ULevel}
               (A : Γ ::→ Type j)
               → (Γ → Type j)

    {-
      We relate the pointwise # with the naive one in the obvious way.

      That is, if we apply a pointwise operation to a crisp variable of the "context",
      this is the same as applying the naive operation pointwise to that variable.

      We take this sameness to be a judgemental equality, implemented as a rewrite rule.
    -}

    ♯-law : {@♭ i : ULevel} {@♭ Γ : Type i} {j : ULevel}
             (A : Γ ::→ Type j) (@♭ x : Γ)
             → (♯-ptwise A) x ↦ ♯ (A x)
    {-# REWRITE ♯-law #-}

    {-
      Rule 2/5, pointwise version
      If one has a : A in a crisp context Γ,
      one may form a ^♯ : ♯ A in the cohesive context Γ.

      Δ, Γ | ∙ ⊢ a : A
      -------------------
      Δ | Γ ⊢ a ^♯ : ♯ A
    -}
    ^♯-ptwise : {@♭ i : ULevel} {@♭ Γ : Type i} {j : ULevel}
                {A : Γ ::→ Type j} (a : (@♭ x : Γ) → A x)
                → (x : Γ) → (♯-ptwise A) x

    {-
      Relate the pointwise ^# with the naive one
    -}
    -- ^♯-law : {@♭ i : ULevel} {@♭ Γ : Type i} {j : ULevel}
    --           {A : Γ ::→ Type j} (a : (@♭ x : Γ) → A x)
    --           (@♭ x : Γ) → (^♯-ptwise a) x ↦ ((a x) ^♯)
    -- {-# REWRITE ^♯-law #-}

    {-
      Rule 3/5, pointwise version
      If one has a :: ♯ A in a crisp context Γ,
      one may form a ↓♯ : A, also in a crisp context Γ

      Δ | ∙ ⊢ a : ♯ A
      ---------------
      Δ | Γ ⊢ a ↓♯ : A

      It seems to me that to have a crisp variable of ♯ A requires A to be crisp...
      But this pointwise definition one doesn't. It just requires that the context
      is crisp.
    -}
    ↓♯-ptwise : {@♭ i : ULevel} {@♭ Δ : Type i} {j : ULevel} {A : Δ ::→ Type j}
                (a : (@♭ x : Δ) → (♯-ptwise A) x)
                → (@♭ x : Δ) → A x

    {-
      Rule 4/5, pointwise version
    -}
    ^↓♯-ptwise : {@♭ i : ULevel} {@♭ Γ : Type i} {j : ULevel}
                {A : Γ ::→ Type j} (a : (@♭ x : Γ) → A x) (@♭ x : Γ)
                → (((^♯-ptwise a) x) ↓♯) ↦ a x

    {-
      Rule 5/5, pointwise version
      I'm having a difficulty implementing the ptwise version of ↓^♯ that will fire
      whether or not A and a are crisp.
      I think this is because if they are, it is a special case of the ↓^♯ rule,
      But it is not strictly more general, since it keeps track of the "explicit context" Δ

      Or, if I take everything in ↓♯-ptwise to be crisp, then it doesn't typecheck at this
      generality.
    -}
    ↓^♯-ptwise : {@♭ i : ULevel} {j : ULevel} {@♭ Δ : Type i} {A : Δ ::→ Type j}
                 (a : (@♭ x : Δ) → (♯-ptwise A) x) (@♭ x : Δ)
                 → (((↓♯-ptwise a) x) ^♯) ↦ a x
    --                                      ^^^ : (♯-ptwise A) x
    --                ^^^^^^^^^^^               : (@♭ x : Δ) → A x
    --              ^^^^^^^^^^^^^^^^            : A x
    --             ^^^^^^^^^^^^^^^^^^^^^        : # (A x)
    {-# REWRITE ↓^♯-ptwise #-}

    -- [WARNING] When normalizing λ A x → (^♯-ptwise a) x, the rewrite ^♯-law will fire
    -- turning it into ((a x) ^♯), which is ill typed on cohesive x : Γ (and the typechecker
    -- complains)

    ↓♯-law : {@♭ i : ULevel} {@♭ Δ : Type i} {@♭ j : ULevel} {@♭ A : Δ ::→ Type j}
              (@♭ a : (@♭ x : Δ) → (♯-ptwise A) x)
              (@♭ x : Δ) → (↓♯-ptwise a) x ↦ ((a x) ↓♯)
    {-# REWRITE ↓♯-law #-}

    {-
      Finally, we define some convenient notation for the ptwise operations.

      To see how these work in practice, see below.
    -}
  syntax ♯-ptwise (λ γ → A) ctx = let♯ γ ::= ctx in♯-♯ A

  syntax ^♯-ptwise (λ γ → a) ctx = let♯ γ ::= ctx in♯ a ^^♯

  ^♯-ptwise-explicit : {@♭ i : ULevel} {@♭ Γ : Type i} {j : ULevel}
                       (A : Γ ::→ Type j) (a : (@♭ x : Γ) → A x)
                       → (x : Γ) → (♯-ptwise A) x
  ^♯-ptwise-explicit A = ^♯-ptwise {A = A}
  syntax ^♯-ptwise-explicit A (λ γ → t) ctx = let♯ γ ::= ctx in♯ t ^^♯-in-family A

  syntax ↓♯-ptwise (λ γ → a) ctx = let♯ γ ::= ctx in♯ a ↓↓♯

  -- ----------------------------------------------------------------------------------------------
  -- End of Postulates
  -- ----------------------------------------------------------------------------------------------

  -- We have to leave the universe levels out and assume they are crisp,
  -- otherwise the "context record" becomes large.
  -- It shouldn't matter tho, since ULevel is discrete.
  module _ {@♭ i j : ULevel} where
    private
      record Γ : Type (lsucc (lmax i j)) where
        constructor ctx
        field
          ᶜA   : Type i
          ᶜB   : Type j
          ᶜf   : ᶜA → ᶜB
          ᶜa   : ♯ ᶜA
      open Γ

    -- Functoriality of ♯
    ♯→ : {A : Type i} {B : Type j}
       (f : A → B) → (♯ A) → (♯ B)
    ♯→ {A} {B} f a =
      let♯ γ ::= (ctx A B f a) in♯
        (ᶜf γ (ᶜa γ ↓♯)) ^^♯ -- (f (a ↓♯)) ^♯

    -- The naturality square of the unit (judgemental!)
    ♯→-nat : {A : Type i} {B : Type j} (f : A → B)
             (a : A) → ((f a) ^♯) == ((♯→ f) (a ^♯))
    ♯→-nat {A} {B} f a = refl

  -- ♯-elmination (Shulman Theorem 3.4)
  {-
    The general form of these definitions is:
    Take the context (or the part of the context) you want to make crisp,
    and make a private record Γ with fields ᶜx for every variable x in the context.
    Then use the let♯ notation to crispify in the context.
  -}
  module _ {@♭ i j : ULevel} where
    private
      record Γ : Type (lsucc (lmax i j)) where
        constructor ctx
        field
          ᶜA : Type i
          ᶜB : (♯ ᶜA) → Type j
          ᶜf : (a : ᶜA) → ♯ (ᶜB (a ^♯))
          ᶜa : ♯ ᶜA
      open Γ

    ♯-elim : {A : Type i} (B : ♯ A → Type j)
             (f : (a : A) → ♯ (B (a ^♯)))
             → ((a : ♯ A) → ♯ (B a))
    ♯-elim {A} B f a =
      let♯ γ ::= (ctx A B f a) in♯
        (ᶜf γ (ᶜa γ ↓♯)) ↓♯ ^^♯
    syntax ♯-elim B (λ x → t) a = let♯ x ^♯:= a in♯ t in-family B

    -- Elimination with implicit family,
    ♯-elim' : {A : Type i} {B : ♯ A → Type j}
              (f : (a : A) → ♯ (B (a ^♯)))
              → ((a : ♯ A) → ♯ (B a))
    ♯-elim' {A} {B} f a = ♯-elim {A} B f a
    syntax ♯-elim' (λ x → t) a = let♯ x ^♯:= a in♯ t

    -- Crisp eliminators
    ♯-elim-crisp : {@♭ A : Type i} (@♭ B : ♯ A → Type j)
                   (f : (@♭ a : A) → ♯ (B (a ^♯)))
                   → (@♭ a : ♯ A) → ♯ (B a)
    ♯-elim-crisp B f a =
      let♯ ᶜf ::= f in♯ ((ᶜf (a ↓♯)) ↓♯) ^^♯
    syntax ♯-elim-crisp B (λ x → t) a = let♯ x ^♯::= a in♯ t in-family B

    -- β holds judgementally :)
    ♯-elim-β : {A : Type i} {B : ♯ A → Type j}
               (f : (a : A) → ♯ (B (a ^♯))) (a : A)
               → (♯-elim B f (a ^♯)) == (f a)
    ♯-elim-β f a = refl

    -- ♯-elim is inverse to precomposition by _^♯
    -- This proves that ♯ is a uniquely eliminating modality
    ♯-universal : {A : Type i} (B : ♯ A → Type j)
                  → ((a : ♯ A) → ♯ (B a)) ≃ ((a : A) → ♯ (B (a ^♯)))
    ♯-universal {A} B = equiv to fro to-fro fro-to
      where
        to : (f : (a : ♯ A) → ♯ (B a))
             → (a : A) → ♯ (B (a ^♯))
        to f = f ∘ _^♯

        fro : ((a : A) → ♯ (B (a ^♯))) → ((a : ♯ A) → ♯ (B a))
        fro = ♯-elim B

        to-fro : (f : (a : A) → ♯ (B (a ^♯))) → to (fro f) == f
        to-fro f = refl

        fro-to : (f : (a : ♯ A) → ♯ (B a)) → fro (to f) == f
        fro-to f = refl

  -- A type is codiscrete if the inclusion a ↦ a ^♯ is an equivalence.
  _is-codiscrete : {i : ULevel} (A : Type i) → Type i
  A is-codiscrete = (_^♯ {A = A}) is-an-equiv

  codisc-eq : {i : ULevel} {A : Type i} (p : A is-codiscrete) → A ≃ (♯ A)
  codisc-eq = _^♯ ,_

  un♯ : {i : ULevel} {A : Type i} (p : A is-codiscrete) → ♯ A → A
  un♯ p = <– (codisc-eq p)

  _is-codisc-is-a-prop : {i : ULevel} (A : Type i) → (A is-codiscrete) is-a-prop
  A is-codisc-is-a-prop = is-equiv-is-prop

  -- Shulman Theorem 3.5
  -- ♯ A is codiscrete.
  module _ {@♭ i : ULevel} where
    private
      record Γ : Type (lsucc i) where
        constructor ctx
        field
          ᶜA : Type i
          ᶜa : ♯ (♯ ᶜA)
      open Γ

    ♯-is-codiscrete : (A : Type i) → (♯ A) is-codiscrete
    ♯-is-codiscrete = λ A →
      (_^♯ {A = ♯ A}) is-an-equivalence-because fro is-inverse-by to-fro and fro-to
      where
        fro : {A : Type i} → ♯ (♯ A) → ♯ A
        fro {A} a = let♯ γ ::= (ctx A a) in♯ ((ᶜa γ ↓♯) ↓♯) ^^♯

        to-fro : {A : Type i} → (a : ♯ (♯ A)) → ((fro a) ^♯) == a
        to-fro a = refl

        fro-to : {A : Type i} → (a : ♯ A) → fro (a ^♯) == a
        fro-to a = refl

  {-
  module _ {@♭ i j : ULevel} {@♭ i j : Type i} where
    private
      record Γ : Type (lsucc (lmax i j)) where
        constructor ctx
        field
          ᶜA : Δ ::→ Type j
          ᶜx : Δ
      open Γ
    ♯-ptwise-is-codiscrete : (A : Δ ::→ Type j) (x : Δ)
                             → ((♯-ptwise A) x) is-codiscrete
    ♯-ptwise-is-codiscrete = λ A x →
      {!(_^\# {A = (♯-ptwise A) x}) is-an-equivalence-because fro is-inverse-by to-fro and fro-to!}
      where
        module _ {A : Δ ::→ Type j} {x : Δ} where
          fro : ♯ ((♯-ptwise A) x) → (♯-ptwise A) x
          fro = {!!}

          -- to-fro : (a : ♯ ((♯-ptwise A) x)) → ((fro a) ^♯) == a
         -- to-fro = {!!}

         -- fro-to : ∀ a → fro (a ^♯) == a
         -- fro-to = {!!}
    -}

  module _ {@♭ i j : ULevel} where
    record CTX-uncrisp {@♭ A : Type i} : Type (lsucc (lmax i j)) where
      constructor ctx
      field
        ᶜB : A → Type j
        ᶜf : (@♭ a : A) → ♯ (ᶜB a)
        ᶜa : A

    uncrisp : {@♭ A : Type i} (B : A → Type j)
              → ((@♭ a : A) → ♯ (B a))
              → ((a : A) → ♯ (B a))
    uncrisp B f a =
      let♯ γ ::= (ctx B f a) in♯
        (((ᶜf γ) (ᶜa γ)) ↓♯) ^^♯
      where open CTX-uncrisp

  Π-codisc : {@♭ i j : ULevel} {A : Type i} (B : A → Type j)
                 → ((a : A) → ♯ (B a)) is-codiscrete
  Π-codisc {A = A} B =
    _^♯ is-an-equivalence-because
      (λ f a → let♯ g ^♯:= f in♯ (g a)) is-inverse-by
        (λ _ → refl) and (λ _ → refl)

  -- The map ♯ (x == y) → (x == y) for x y : ♯ A, following RSS Lemma 1.25
  module _ {@♭ i : ULevel} {A : Type i} {x y : ♯ A} where
    private
      constx : ♯ (x == y) → ♯ A
      constx _ = x

      consty : ♯ (x == y) → ♯ A
      consty _ = y

      lemma₀ : (constx ∘ _^♯) == (consty ∘ _^♯)
      lemma₀ = λ= (λ p → p)

      lemma₁ : constx == consty
      lemma₁ = -- constx == consty because they are equalized by _^♯, via the universal prop of ♯
        –>-is-inj (♯-universal (λ (_ : ♯ (x == y)) → A)) constx consty lemma₀

    ♯-=-retract : ♯ (x == y) → x == y
    ♯-=-retract p = app= lemma₁ p

  -- To prove a type is an equivalence, it suffices to give a retract of _^♯
  _is-codiscrete-because_is-retract-by_ : {@♭ i : ULevel} (A : Type i)
                                          (r : ♯ A → A) (p : (a : A) → r (a ^♯)  == a)
                                          → A is-codiscrete
  A is-codiscrete-because r is-retract-by p =
    (_^♯ {A = A}) is-an-equivalence-because r is-inverse-by
        (λ a → -- Given an a : ♯ A, we will show ♯ ((r a)^♯ == a)
             (let♯ b ^♯:= a in♯ -- We suppose a is b ^♯
                   ((ap _^♯ (p b)) ^♯) -- apply p to b to get r (b ^♯) == b,
                                      -- then apply _^♯ to get (r b^♯)^♯ == b^♯
                                      -- then hit it with _^♯ to get ♯ ((r b^♯)^♯ == b^♯)
              in-family (λ (a : ♯ A) → ((r a) ^♯) == a) -- which is ♯ ((r a)^♯ == a) by our hypothesis,
             )  -- and we can strip the ♯ becacuse equality types in ♯ are codiscrete.
          |> (♯-=-retract {x = (r a) ^♯} {a})
        )
      and p

  -- We follow RSS Lemma 1.25
  =-is-codiscrete : {@♭ i : ULevel} {A : Type i} (x y : ♯ A)
                    → (x == y) is-codiscrete
  =-is-codiscrete {A = A} x y =
   (x == y) is-codiscrete-because ♯-=-retract is-retract-by proof
    where
      abstract -- UNFINISHED
        proof : (p : x == y) → (♯-=-retract (p ^♯)) == p
        proof = trust-me
          where postulate trust-me : (p : x == y) → (♯-=-retract (p ^♯)) == p

  ♯-modality : {@♭ i : ULevel} → Modality i
  ♯-modality {i} = record
                 { is-local = _is-codiscrete
                 ; is-local-is-prop = λ {A} → A is-codisc-is-a-prop
                 ; ◯ = ♯
                 ; ◯-is-local = λ {A} → ♯-is-codiscrete A
                 ; η = _^♯
                 ; ◯-elim = λ {A} {B} p f a → un♯ (p a) (♯-elim B (λ a → (f a) ^♯) a)
                 ; ◯-elim-β = λ {A} {B} p f a → <–-inv-l (codisc-eq (p (a ^♯))) (f a)
                 ; ◯-=-is-local = =-is-codiscrete
                 }

  _is-infinitesimal : {@♭ i : ULevel} → Type i → Type i
  _is-infinitesimal = Modality.is-◯-connected ♯-modality

  ♯→e : {@♭ i : ULevel} {A B : Type i} → A ≃ B → (♯ A) ≃ (♯ B)
  ♯→e = Modality.◯-emap ♯-modality

  ♯-Σ : ∀ {@♭ i} {A : Type i} (B : A → Type i)
        → A is-codiscrete → ((a : A) → (B a) is-codiscrete)
        → (Σ A B) is-codiscrete
  ♯-Σ {i} = (Modality.Σ-is-local {i}) ♯-modality

  ♯-Π : ∀ {@♭ i} {A : Type i} {B : A → Type i} (w : (a : A) → (B a) is-codiscrete)
        → (Π A B) is-codiscrete
  ♯-Π {i} = (Modality.Π-is-local {i}) ♯-modality

  -- Theorem 6.22 of Shulman
  -- Points of ♯ A are the points of A, and ♯ of the points of A is ♯ A.
  ♭♯-eq : {@♭ i : ULevel} {@♭ A : Type i} → ♭ (♯ A) ≃ ♭ A
  ♭♯-eq {A = A} = equiv to fro to-fro fro-to
    where
      to : ♭ (♯ A) → ♭ A
      to (a ^♭) = (a ↓♯) ^♭

      fro : ♭ A → ♭ (♯ A)
      fro (a ^♭) = (a ^♯) ^♭

      to-fro : (a : ♭ A) → to (fro a) == a
      to-fro (a ^♭) = refl

      fro-to : (a : ♭ (♯ A)) → fro (to a) == a
      fro-to (a ^♭) = ♭-ap _^♭ refl

  ♯♭-eq : {@♭ i : ULevel} {@♭ A : Type i} → ♯ (♭ A) ≃ ♯ A
  ♯♭-eq {A = A} = equiv to fro to-fro fro-to
    where
      to : ♯ (♭ A) → ♯ A
      to a =
        let♯ u ^♯:= a in♯
          let♭ v ^♭:= u in♭ (v ^♯)

      fro : ♯ A → ♯ (♭ A)
      fro a =
        let♯ u ^♯:= a in♯
          let♯ v ::= u in♯ (v ^♭) ^^♯

      abstract
        to-fro : (a : ♯ A) → to (fro a) == a
        to-fro a = -- It suffices to show ♯ (to fro a == a),
          (let♯ u ^♯:= a in♯ -- which lets us assume a = u^♯
            refl ^♯ -- so that the equality follows judgementally.
          in-family (λ a → to (fro a) == a))
          |> ♯-=-retract

        fro-to : (a : ♯ (♭ A)) → fro (to a) == a
        fro-to a = -- It suffices to show ♯ (fro to a == a),
          (let♯ u ^♯:= a in♯ -- which lets us assume a = u^♯ with u : ♭ A,
            (let♭ v ^♭:= u in♭ -- so we can assume u = v^♭,
                  refl ^♯ -- so that the equality follows judgementally.
             in-family (λ u → ♯ (fro (to (u ^♯)) == (u ^♯))))
           in-family (λ a → fro (to a) == a))
          |> ♯-=-retract

  -- Theorem 6.27 of Shulman
  -- The adjunction between ♭ and ♯
  ♭♯-adjoint : {@♭ i j : ULevel} {@♭ A : Type i} {@♭ B : A → Type j}
               → ♭ ((a : ♭ A) → B (a ↓♭)) ≃ ♭ ((a : A) → ♯ (B a))
  ♭♯-adjoint {A = A} {B = B} = equiv to fro to-fro fro-to
    where
      to :  ♭ ((a : ♭ A) → B (a ↓♭)) →  ♭ ((a : A) → ♯ (B a))
      to (f ^♭) = (λ a → let♯ u ::= a in♯ f (u ^♭) ^^♯) ^♭

      fro :  ♭ ((a : A) → ♯ (B a)) →  ♭ ((a : ♭ A) → B (a ↓♭))
      fro (f ^♭) = (λ a → let♭ u ^♭:= a in♭ ((f u) ↓♯) in-family (λ a → B (a ↓♭))) ^♭

      to-fro : ∀ f → to (fro f) == f
      to-fro (f ^♭) = refl

      fro-to : ∀ f → fro (to f) == f
      fro-to (f ^♭) =
        ♭-ap _^♭ -- We can strip ^♭ from both sides,
          ( λ= (λ a →  let♭ u ^♭:= a in♭ -- then, working at a crisp argument u,
                  refl -- we find both sides are judgementally the same.
               in-family (λ a → ♭-elim (λ a₁ → B (a₁ ↓♭)) (λ (@♭ u : _) → f (u ^♭)) a == f a)  )
            ) -- The "in family" gibberish just reminds agda what we are trying to prove.

  -- Shulman Theorem 3.7
  -- ♯ is left exact, in that x^♯ == y^♯ is ♯ (x == y)
  module _ {@♭ i : ULevel} where
    private
      record CTX-code : Type (lsucc i) where
        constructor ctx
        field
          ᶜA : Type i
          ᶜx : ♯ ᶜA
          ᶜy : ♯ ᶜA

    code : {A : Type i} → ♯ A → ♯ A → Type i
    code {A} x y =
      let♯ γ ::= (ctx A x y) in♯-♯ (((ᶜx γ) ↓♯) == ((ᶜy γ) ↓♯))
      where open CTX-code

    private
      record CTX-r : Type (lsucc i) where
        constructor ctx
        field
          ᶜA : Type i
          ᶜx : ♯ ᶜA

    r : {A : Type i} (x : ♯ A) → code x x
    r {A} x =
      let♯ γ ::= (ctx A x) in♯ (idp {a = (ᶜx γ) ↓♯}) ^^♯
      where open CTX-r
       -- for some reason, I can't use refl here, I need idp???

    encode : {A : Type i} {a b : ♯ A} → (a == b) → code a b
    encode {A} {a} {b} p = transport (λ y → code a y) p (r a)

    decode : {A : Type i} {a b : ♯ A} → code a b → (a == b)
    decode {A} {a} {b} = -- It suffices to give ♯ (code a b → a == b) by lemma.
      lemma a b (decode' a b)
      where
        lemma : {A : Type i} (a b : ♯ A)
                → ♯ (code a b → (a == b))
                → code a b → (a == b)
        lemma a b p e =
          ♯-=-retract $ -- it suffices to show ♯ (a == b)
            let♯ q ^♯:= p in♯ ((q e) ^♯) -- so we can assume p is of the form q ^♯.

        decode' : {A : Type i} (a b : ♯ A) → ♯ (code a b → (a == b))
        decode' {A} a b =
          let♯ u ^♯:= a in♯ -- By ♯-elim, we can assume a and b are of the form
            let♯ v ^♯:= b in♯ -- u ^♯ and v ^♯, and we'll give
                                 -- code (u ^♯) (v ^♯) → (u ^♯) == (v ^♯).
                   (λ p → ♯-=-retract -- Assuming a code p, it suffices to give
                                                    -- ♯ (u ^♯ == v ^♯).
                   (let♯ q ^♯:= p in♯ ((ap _^♯ q)^♯)) )^♯ -- So, we let p be q^♯
                                                          -- with q : u == v, and then
                                                          -- push this through the unit.
            in-family (λ b' → code (u ^♯) b' → (u ^♯) == b')
          in-family (λ a' → code a' b → a' == b)

    private -- context for encode-decode'
      record CTX-encode-decode : Type (lsucc i) where
        constructor ctx
        field
          ᶜA : Type i
          ᶜa : ♯ ᶜA
          ᶜb : ♯ ᶜA
          -- ᶜp : code ᶜa ᶜb
      open CTX-encode-decode
    {-
    encode-decode' : {A : Type i} {a b : ♯ A} → ♯ ((encode {a = a}{b = b})∘ decode == (idf (code a b)))
    encode-decode' {A} {a} {b} =
      let♯ γ ::= (ctx A a b) in♯
        {!let♯ u ^♯:= (ᶜa γ) in♯
           ?
         in-family (λ a' → (encode {a = a'}{b = ᶜb γ})∘ decode == (idf (code a' (ᶜb γ))))!}
      ^^♯-in-family (λ γ' → (encode {a = ᶜa γ'}{b = ᶜb γ'})∘ decode == (idf (code (ᶜa γ') (ᶜb γ'))))

    -- [WARNING] I get an error here complaining about A in (a ↓♯) == (b ↓♯) if doing this at
    -- p : code a b (I believe this to be because rewrite rules do not see the ♭ modality)
    encode-decode : {A : Type i} {a b : ♯ A} → (encode {a = a}{b = b})∘ decode == (idf (code a b))
    encode-decode {A} {a} {b} =
      λ= (λ p → {!!})

    -}

  -- For now, we'll just postulate it
  ♯-=-compare : {@♭ i : ULevel} {A : Type i} {x y : A}
                → ♯ (x == y) → (x ^♯) == (y ^♯)
  ♯-=-compare {x = x} {y = y} p =
    ♯-=-retract  $ -- it suffices to give ♯ (x ^♯ == y ^♯)
      let♯ q ^♯:= p in♯ -- in which case we may assume p = q ^♯ with q : x == y
        ((ap _^♯ q) ^♯) -- and so we can push this through.
  module _ {@♭ i : ULevel} where
    private
      record CTX-♯-lex : Type (lsucc i) where
        constructor ctx
        field
          ᶜA : Type i
          ᶜx : ᶜA
          ᶜy : ᶜA
    postulate
      ♯-lex : {A : Type i} {x y : A}
              → (♯-=-compare {x = x} {y = y}) is-an-equiv

    ♯-lex-eq : {A : Type i} {x y : A}
               → (♯ (x == y)) ≃ ((x ^♯) == (y ^♯))
    ♯-lex-eq {A}{x}{y} = ♯-=-compare , ♯-lex

    test : {A : Type i} {x y : ♯ A}
           → ♯ ((x ^♯) == (y ^♯) → ♯ (x == y))
    test {A} {x} {y} =
      let♯ γ ::= (ctx (♯ A) x y) in♯
        (λ p → let♯ q ::= p in♯
                  (♭-ap _↓♯ q)
                ^^♯-in-family (λ _ → (ᶜx γ == ᶜy γ)))
      ^^♯-in-family (λ γ → ((ᶜx γ) ^♯) == ((ᶜy γ) ^♯) → ♯ ((ᶜx γ) == (ᶜy γ)))
      where open CTX-♯-lex

  ♯-has-level-is-codisc : {@♭ i : ULevel} {A : Type i}
                          {n : ℕ₋₂} → (has-level n (♯ A)) is-codiscrete
  ♯-has-level-is-codisc {i} {A} {n} = replete helper (has-level-def-eq ⁻¹)
    where
      replete = (Modality.local-is-replete {i}) ♯-modality

      helper : {A : Type i}
               {n : ℕ₋₂} → (has-level-aux n (♯ A)) is-codiscrete
      helper {A} {⟨-2⟩} =
        ♯-Σ (λ x → (y : ♯ A) → x == y) (♯-is-codiscrete A) $
          λ x → ♯-Π (λ y → =-is-codiscrete x y)

      helper {A} {n = S n} =
        ♯-Π (λ x →
          ♯-Π (λ y →
            replete (replete (helper {A = (x == y)} {n}) (has-level-def-eq ⁻¹))
              (≃-preserves-level-eq ((codisc-eq $ =-is-codiscrete x y) ⁻¹))))

  ♯-preserves-level : {@♭ i : ULevel} {A : Type i}
                      {n : ℕ₋₂} (p : has-level n A)
                      → has-level n (♯ A)
  ♯-preserves-level {i} {A} {⟨-2⟩} p =
    has-level-in ( ((contr-center p)^♯) ,
      (λ y → ♯-=-retract $ -- It suffices to prove ♯ (center == y)
              let♯ u ^♯:= y in♯ -- so we can assume y is u ^♯
                ap _^♯ (contr-path p u) ^♯ -- and then apply _^♯ to the contractibility of A.
              in-family (λ y → ((contr-center p) ^♯) == y))
      )
  ♯-preserves-level {i} {A} {S n} p =
    has-level-in
      (λ x y → -- Given x y : ♯ A, we need to show that x == y has level n.
           ≃-preserves-level ((codisc-eq (=-is-codiscrete x y))⁻¹) lemma
      ) -- since x == y is ♯ (x == y), it will suffice to show that has level n.
    where
      lemma : {x y : ♯ A} →  has-level n (♯ (x == y))
      lemma {x} {y} = -- Since has-level is codiscrete on codiscretes,
        un♯ ♯-has-level-is-codisc $ -- we can let x and y be u^♯ and v^♯.
          let♯ u ^♯:= x in♯ -- Then, we use the lex-ness of ♯ and a bit of jiggling
             let♯ v ^♯:= y in♯ -- to show that we might as well prove the result of
                (≃-preserves-level (e u v) -- ♯ (u == v), which we can do by recursing.
                  (♯-preserves-level (has-level-apply p u v)))^♯
              in-family (λ y → has-level n (♯ ((u ^♯) == y)))
           in-family (λ x → has-level n (♯ (x == y)))
        where
          e : (u v : A) → ♯ (u == v) ≃ ♯ ((u ^♯) == (v ^♯))
          e u v = ♯ (u == v)
                ≃⟨ codisc-eq (♯-is-codiscrete (u == v)) ⟩
                  ♯ (♯ (u == v))
                ≃⟨ ♯→e ♯-lex-eq ⟩
                  ♯ ((u ^♯) == (v ^♯))
                ≃∎

  ♯ₙ : {@♭ i : ULevel} {n : ℕ₋₂}
       → (A : n -Type i) → (n -Type i)
  ♯ₙ A = (♯ (fst A)) , ♯-preserves-level (snd A)


-- Home to all functions creating, modifying or removing ScopeEnv or ScopeState
module ScopeState where
open import Data.List using (List) renaming ([] to emptyList ; map to listMap ; _∷_ to _cons_)
open import Data.String renaming (_++_ to _then_)
open import Data.Bool
open import Data.Nat
open import Data.Fin renaming (zero to fzero ; suc to fsuc) hiding (_+_)
open import Relation.Binary.PropositionalEquality
open import Data.Maybe renaming (map to maybemap) hiding (monad)
open import ParseTree
open import Data.List.Properties
open import Data.Vec hiding (_>>=_) renaming (lookup to veclookup)
open import Category.Monad.State
open import Data.Product hiding (map)
open import Data.Sum hiding (map)
open import Data.Empty
open import Relation.Nullary
open import Category.Monad
open import Relation.Binary.Core
open import Relation.Binary.PropositionalEquality.TrustMe
open import Data.Unit
open import AgdaHelperFunctions
open import Data.Nat.Show
import IO.Primitive as Prim
open import ParseTreeOperations

data ScopeType : Set where
  funcDef : ScopeType
  moduleDef : (name : Identifier) -> ScopeType
  addFuncToModule : ScopeType
  addVariableToType : ScopeType
  topLevel : ScopeType

data Scope (maxVars : ℕ) (maxScopes : ℕ): Set where
 mkScope : (scopeType : ScopeType) ->
           (enclosing : Maybe (Fin maxScopes)) -> -- Nothing if this is the top scope
           (declaredVars : List (Fin maxVars)) -> -- the list of variables declared in this scope
           Scope maxVars maxScopes

getType : {m n : ℕ} -> Scope m n -> ScopeType
getType (mkScope scopeType enclosing declaredVars) = scopeType

--appendToDeclared : {m n : ℕ} -> Fin m -> Scope m n -> Scope m n
--appendToDeclared what (mkScope scopeType enclosing declaredVars) =
--  mkScope scopeType enclosing (what cons declaredVars)

getDeclared : {m n : ℕ} -> Scope m n -> List (Fin m)
getDeclared (mkScope scopeType enclosing declaredVars) = declaredVars

data ScopeEnv : Set where
  env : {numVars : ℕ} ->
        (vars : Vec String numVars) ->
        (maxScopes : ℕ) ->
        (scopes : Vec (Scope numVars maxScopes) maxScopes ) ->
        (current : Fin maxScopes) ->
        ScopeEnv

ScopeState : Set -> Set
ScopeState = StateT  (ScopeEnv) (λ x -> Prim.IO (String ⊎ x))

--open RawMonadState (StateTMonadState ScopeEnv {M = IOStringError} EitherOverIO) public

liftIO : {a : Set} -> Prim.IO a -> ScopeState a
liftIO action e = do
  a <- action
  return (inj₂ (a , e))
  where open RawMonad IOMonad

runScopeState : {a : Set} -> ScopeState a -> ScopeEnv -> Prim.IO (String ⊎ a)
runScopeState s e = do
  inj₂ ( result , e) <- s e
    where inj₁ e -> return $ inj₁ e
  return $ inj₂ result
  where open RawMonad IOMonad -- brings return and bind for the Prim.IO monad into scope
fail : {a : Set} -> String -> ScopeState a
fail message = λ x -> Prim.return $ inj₁ message

-- Try an action and return an error message on failure rather than
-- propagating the failure. All state changes are rolled back.
try : {a : Set} -> ScopeState a -> ScopeState (String ⊎ a)
try st environment = do
  inj₂ (x , newEnv) <- st environment
    where inj₁ error -> return $ inj₂ $ inj₁ error , environment
  return $ inj₂ $ inj₂ x , newEnv
  where open RawMonad IOMonad

open RawMonadState (StateTMonadState ScopeEnv (SumMonadT IOMonad String)) public

newEnv : ScopeEnv
newEnv = env [] 1 ((mkScope topLevel nothing emptyList) ∷ [])   fzero

-- Variable adding

newRaise : {n : ℕ} -> Fin n -> Fin (1 + n)
newRaise fzero = fzero
newRaise (fsuc f) = fsuc (newRaise f)

raiseScopeType : {n m : ℕ} -> Scope n m -> Scope (1 + n) m
raiseScopeType (mkScope t s declared) = mkScope t s (listMap newRaise declared)

raiseType : {n m : ℕ} -> (x : Scope n m) -> getType x ≡ getType (raiseScopeType x)
raiseType (mkScope scopeType enclosing declaredVars) = refl

mapRaiseType : {n m o : ℕ} -> (x : Vec (Scope n m) o) -> (curr : Fin o)
  -> getType (veclookup curr x) ≡ getType (veclookup curr (map raiseScopeType x))
mapRaiseType (x ∷ xs) fzero with veclookup fzero (x ∷ xs)
... | c = raiseType c
mapRaiseType (x ∷ xs) (fsuc curr) = mapRaiseType xs curr

addVarToScope : {n m : ℕ} -> (Scope n m) -> (what : Fin (1 + n))
          -> (Scope (1 + n) m)
addVarToScope (mkScope scopeType enclosing declaredVars) what =
    mkScope scopeType enclosing (what cons (listMap newRaise declaredVars))

addVar : {n m numScopes : ℕ}(xs : Vec (Scope n m) numScopes) ->
  (atPos : Fin numScopes) -> (what : Fin (1 + n)) ->
    Vec (Scope (1 + n) m) numScopes
addVar (x ∷ xs) fzero what = addVarToScope x what ∷ map raiseScopeType xs
addVar (x ∷ xs) (fsuc atPos) what = raiseScopeType x ∷ addVar xs atPos what

addExistingVarToScope : {n m : ℕ} -> (Scope n m) -> (what : Fin n)
          -> (Scope n m)
addExistingVarToScope (mkScope scopeType enclosing declaredVars) what =
    mkScope scopeType enclosing (what cons declaredVars)

addExistingVar : {n m numScopes : ℕ}(xs : Vec (Scope n m) numScopes) ->
  (atPos : Fin numScopes) -> (what : Fin n) ->
    Vec (Scope n m) numScopes
addExistingVar [] () what
addExistingVar (x ∷ xs) fzero what = (addExistingVarToScope x what) ∷ xs
addExistingVar (x ∷ xs) (fsuc atPos) what = x ∷ addExistingVar xs atPos what

-- returns input identifier with id and scope id filled in
addIdentifier :  Identifier -> ScopeState Identifier
addIdentifier (identifier name isInRange scope declaration {b}{c} {c2}) = do
  env {numVars} vars maxScopes scopes current <- get
  let newScopes = (addVar scopes current (fromℕ numVars))
  put (env (vars ∷ʳ name) maxScopes
     newScopes
       current)
  return (identifier name isInRange (toℕ current) numVars {b}{c} {c2})

raiseEnclosingScope : {maxVars maxScopes : ℕ} -> Scope maxVars maxScopes
    -> Scope maxVars (1 + maxScopes)
raiseEnclosingScope (mkScope scopeType enclosing declaredVars) =
    mkScope scopeType (maybemap newRaise enclosing) declaredVars

addScope : (b : ScopeType) ->  ScopeState ℕ
addScope scopeType = do
  env vars maxScopes scopes current <- get
  let newScopes = map raiseEnclosingScope scopes ∷ʳ
                   mkScope scopeType
                    (just (newRaise current)) emptyList
  put (env vars (1 + maxScopes)
                      newScopes
                      (fromℕ maxScopes)
                       )
  return maxScopes

castCurrent : {n m : ℕ} -> {A : Set} -> Vec A n -> Fin m -> ScopeState (Fin n)
castCurrent [] x = fail "Something went wrong with scope saving"
castCurrent (x ∷ vec) fzero = return fzero
castCurrent (x ∷ vec) (fsuc f) = do
  r <- castCurrent vec f
  return (fsuc r)

saveAndReturnToScope : {A : Set} -> ScopeState A -> ScopeState A
saveAndReturnToScope ss = do
  env vars maxScopes scopes current <- get
  c <- ss
  env vars₁ maxScopes₁ scopes₁ current₁ <- get
  newCurr <- castCurrent scopes₁ current
  let newEnv = env vars₁ maxScopes₁ scopes₁ newCurr
  put newEnv
  return c

setScope : (n : ℕ) -> ScopeState ℕ
setScope n (env vars maxScopes scopes current) with suc n Data.Nat.≤? maxScopes
setScope n (env vars maxScopes scopes current) | yes p = return n (env vars maxScopes scopes (fromℕ≤ p)) --inj₂ (n , (env vars maxScopes scopes (fromℕ≤ p)))
setScope n e | no ¬p = Prim.return $ inj₁ "Tried to set scope to invalid value" --inj₁ "Tried to set scope to invalid value"

filter : {A : Set} -> (A -> Bool) -> List A -> List A
filter f emptyList = emptyList
filter f (x cons l) = if (f x) then (x cons (filter f l)) else filter f l

-- this is the lookup function from Schäfer's algorithm
-- TODO: Simple dummy function, does not sufficiently reflect real
-- scoping rules
-- TODO: Agda does not understand that this terminates because
-- the fact that the enclosing scope must be farther to the front of
-- the scopes list is not encoded in the type yet
-- returns the declaration id the input string
{-# TERMINATING #-}
lookup : String -> ScopeState ℕ
lookup s = saveAndReturnToScope (do
  env vars maxScopes scopes current <- get
  mkScope scopeType enclosing decl <- return (veclookup current scopes)
  emptyList <- return ( filter (λ x -> veclookup x vars == s) decl)
    where x cons xs -> return (toℕ x)
  just n <- return enclosing
    where _ -> fail $ "There is no enclosing scope while looking up: " then s
  setScope (toℕ n)
  lookup s)

-- fill in the declaration and scope information in an identifier
-- given that the name has already been declared

fillInIdentifier : Identifier -> ScopeState Identifier
fillInIdentifier (identifier name isInRange scope declaration {b}{c} {c2}) = do
  x <- saveAndReturnToScope (lookup name)
  suc n <- return x
    where zero -> fail ("Identifier not found in file: " then name)
  env vars maxScopes scopes current <- get
  return (identifier name isInRange (toℕ current) (suc n) {b}{c} {c2})

-- at the place where something is declared, you can only use simple names.
-- TODO: Actually, this should be adequately bounded by the current scope. But how to implement?

access : Identifier -> ScopeState Identifier
access (identifier name isInRange scope declaration {b}{c} {c2}) = do
  env {numVars} vars maxScopes scopes current <- get
  yes p <- return (suc declaration Data.Nat.≤? numVars)
    where _ -> fail "Parse tree scoping has produced a nonsense declaration"
  let newName = veclookup (fromℕ≤ p) vars
  anything <- setScope scope
  identifier n r s d <- fillInIdentifier (identifier newName isInRange scope declaration {b}{c} {c2})
  yes x <- return (d Data.Nat.≟ declaration)
    where no y -> fail "Could not perform name change because this would change the meaning of the code"
  return (identifier n r s d {b}{c} {c2})

mapState : {A B : Set} -> (A -> ScopeState B) -> List A -> ScopeState (List B)
mapState f emptyList = return emptyList
mapState f (x cons list) = do
  x1 <- f x
  xs <- mapState f list
  return (x1 cons xs)

addContentReferenceToModuleTop : TypeSignature -> ScopeState ℕ
addContentReferenceToModuleTop (typeSignature (identifier name isInRange scope 0) funcType) = fail "Trying to add signature which has not been scoped"
addContentReferenceToModuleTop (typeSignature (identifier name isInRange scope declaration) funcType) = do
  env {numVars } vars maxScopes scopes current <- get
  yes p <- return (suc declaration Data.Nat.≤? numVars)
    where _ -> fail "Found messed-up scoping"
  let newScopes = addExistingVar scopes current (fromℕ≤ p)
  return declaration

_after_ : {A B C : Set} -> (B -> ScopeState C) -> (A -> ScopeState B) -> A -> ScopeState C
_after_ f g x = do
  prelim <- g x
  f prelim

getNameForId : ℕ -> ScopeState String
getNameForId n = do
  env {numVars } vars maxScopes scopes current <- get
  yes p <- return (suc n Data.Nat.≤? numVars)
    where _ -> fail "Can't get name for this invalid identifier"
  let r = veclookup (fromℕ≤ p) vars
  return r

replaceName : {A : Set} -> {n : ℕ} -> Fin n -> A -> Vec A n -> Vec A n
replaceName fzero a (x ∷ list) = a ∷ list
replaceName (fsuc n) a (x ∷ list) = x ∷ replaceName n a list

replaceID : ℕ -> String -> ScopeState String
replaceID which newName = do
  env {numVars} vars maxScopes scopes current <- get
  yes p <- return (suc which Data.Nat.≤? numVars)
    where _ -> fail "Can't rename this invalid identifier"
  let newList = replaceName (fromℕ≤ p) newName vars
  put (env {numVars } newList maxScopes scopes current)
  return newName

currentScopeTypeIsFuncDef : ScopeState Bool
currentScopeTypeIsFuncDef = do
  env {numVars } vars maxScopes scopes current <- get
  mkScope funcDef enclosing declaredVars <- return (veclookup current scopes)
    where _ -> fail "This is not the scope type you expected"
  return true

isNameInUse : String -> ScopeState Bool
isNameInUse s = do
  env vars maxScopes scopes current <- get
  return $ Data.List.any (λ x -> x == s) (Data.Vec.toList vars)

-- terminates because vars is not infinite.
{-# TERMINATING #-}
makeUniqueName : ℕ -> ScopeState String
makeUniqueName n = do
    let proposedName = Data.String.concat $ "renameMe" Data.List.∷ (Data.Nat.Show.show n) Data.List.∷ emptyList
    b <- isNameInUse proposedName
    if b
      then makeUniqueName $ suc n
      else return proposedName

getUniqueIdentifierWithInScope : Bool -> ScopeState Identifier
getUniqueIdentifierWithInScope b = do
  name <- makeUniqueName 0
  id <- addIdentifier $ identifier name (λ _ -> before) 0 0 {b}{emptyList} {emptyList}
  return id

getUniqueIdentifier : ScopeState Identifier
getUniqueIdentifier = getUniqueIdentifierWithInScope true


module AmbiguousName where

module A where
  postulate X : Set

module B where
  module A where
    postulate X : Set

open A renaming (X to Y)
open B

Z = A.X


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

open import Cubical.HITs.TypeQuotients.Base public
open import Cubical.HITs.TypeQuotients.Properties public