open import Coinduction using ( ∞ ; ♭ ; ♯_ )
open import Data.Empty using ( ⊥ )
open import Data.Bool using ( Bool ; true ; false ; if_then_else_ )
open import Data.Product using ( ∃ ; _×_ ; _,_ ; ,_ )
open import Data.Strict using ( Strict ; ! )
open import Data.Sum using ( _⊎_ ; inj₁ ; inj₂ )
open import Data.Unit using ( ⊤ ; tt )
open import System.IO.Transducers.Session
  using ( Session ; I ; Σ ; _∼_ ; ∼-sym ; Γ ; _/_ ; IsΣ ; IsΣ-≡ ; ⟨_⟩ ; _&_ ; ¿ ; _+_  )
  renaming ( unit₁ to ∼-unit₁ ; unit₂ to ∼-unit₂ ; assoc to ∼-assoc )
open import System.IO.Transducers.Trace using ( _≤_ ; _⊑_ ; Trace ; [] ; _∷_ )
open import Relation.Binary.PropositionalEquality using ( _≡_ ; refl )
open import Relation.Nullary using ( Dec ; yes ; no )

module System.IO.Transducers.Lazy where

-- S ⇛ T is the type of transducers whose inputs
-- are traces through S, and whose output are traces through T.

-- Note that input is coinductive, but output is inductive,
-- which guarantees that transducers will map finite traces
-- to finite traces.

-- The name transducer comes from automata theory -- these
-- are essentially I/O automata, or strategies in a two-player
-- game without the move alternation restriction.

-- In this module, we give definitions for lazy transducers,
-- there is a separate module for stict transducers.

infixr 4 _⇒_ _≃_ _≲_
infixr 6 _⟫_
infixr 8 _[&]_ _⟨&⟩_ _⟨+⟩_ _⟨¿⟩_

-- Lazy transducers, which may perform output before input.

data _⇒_ : (S T : Session) → Set₁ where
  inp : ∀ {T A V F} → ∞ ((a : A) → (♭ F a ⇒ T)) → (Σ V F ⇒ T)
  out : ∀ {S B W G} → (b : B) → (S ⇒ ♭ G b) → (S ⇒ Σ W G)
  done : ∀ {S} → (S ⇒ S)

-- Semantically, we only need done at type I,
-- we have it at all types just for efficiency.

data _⤇_ : (S T : Session) → Set₁ where
  inp : ∀ {T A V F} → ∞ ((a : A) → (♭ F a ⤇ T)) → (Σ V F ⤇ T)
  out : ∀ {S B W G} → (b : B) → (S ⤇ ♭ G b) → (S ⤇ Σ W G)
  done : (I ⤇ I)

ι : ∀ {S T} → (S ⤇ T) → (S ⇒ T)
ι (inp P)   = inp (♯ λ a → ι (♭ P a))
ι (out b P) = out b (ι P)
ι done      = done

ι⁻¹ : ∀ {S T} → (S ⇒ T) → (S ⤇ T)
ι⁻¹ (inp P)        = inp (♯ λ a → ι⁻¹ (♭ P a))
ι⁻¹ (out b P)      = out b (ι⁻¹ P)
ι⁻¹ (done {I})     = done
ι⁻¹ (done {Σ V F}) = inp (♯ λ a → out a (ι⁻¹ done))

-- Helper functions to build transducers in terms of Γ and _/_

out' : ∀ {S T} b → (S ⇒ T / b) → (S ⇒ T)
out' {S} {I}     () P
out' {S} {Σ W G} b  P = out b P

-- Helper function to output a whole trace.

out* : ∀ {S T U} → (T ≤ U) → (S ⇒ T) → (S ⇒ U)
out* []       P = P
out* (b ∷ bs) P = out* bs (out' b P)

-- Semantics as a function from partial traces to partial traces

⟦_⟧ : ∀ {S T} → (S ⇒ T) → (Trace S) → (Trace T)
⟦ inp P   ⟧ []       = []
⟦ inp P   ⟧ (a ∷ as) = ⟦ ♭ P a ⟧ as
⟦ out b P ⟧ as       = b ∷ ⟦ P ⟧ as
⟦ done    ⟧ as       = as

-- Extensional equivalence on trace functions

_≃_ : ∀ {S T} → (f g : Trace S → Trace T) → Set
f ≃ g = ∀ as → f as ≡ g as

-- Improvement order on trace functions

_≲_ : ∀ {S T} → (f g : Trace S → Trace T) → Set₁
f ≲ g = ∀ as → f as ⊑ g as

-- Equivalent sessions give rise to a transducer

equiv : ∀ {S T} → (S ∼ T) → (S ⇒ T)
equiv I       = done
equiv (Σ V F) = inp (♯ λ a → out a (equiv (♭ F a)))

-- Transducers form a category with composition given by
-- parallel (data flow) composition.  This is defined by the
-- usual expansion laws for parallel composition, together with
-- the unit law for done.  Since composition is deterministic,
-- we prioritize output over input.

_⟫_ : ∀ {S T U} → (S ⇒ T) → (T ⇒ U) → (S ⇒ U)
done    ⟫ Q       = Q
P       ⟫ done    = P
P       ⟫ out b Q = out b (P ⟫ Q)
out b P ⟫ inp Q   = P ⟫ ♭ Q b
inp P   ⟫ Q       = inp (♯ λ a → ♭ P a ⟫ Q)

-- The category has monoidal structure given by &, with
-- action on morphisms:

_[&]_ : ∀ {S T U V} → (S ⇒ T) → (U ⇒ V) → ((S & U) ⇒ (T & V))
inp {I} P    [&] out c Q = out c (inp P [&] Q)
inp P        [&] Q       = inp (♯ λ a → ♭ P a [&] Q)
out b P      [&] Q       = out b (P [&] Q)
done {I}     [&] Q       = Q
done {Σ V F} [&] Q       = inp (♯ λ a → out a (done {♭ F a} [&] Q))

-- Units for &

unit₁ : ∀ {S} → (I & S) ⇒ S
unit₁ = equiv ∼-unit₁

unit₁⁻¹ : ∀ {S} → S ⇒ (I & S)
unit₁⁻¹ = equiv (∼-sym ∼-unit₁)

unit₂ : ∀ {S} → (S & I) ⇒ S
unit₂ = equiv ∼-unit₂

unit₂⁻¹ : ∀ {S} → S ⇒ (S & I)
unit₂⁻¹ = equiv (∼-sym ∼-unit₂)

-- Associativity of &

assoc : ∀ {S T U} → (S & (T & U)) ⇒ ((S & T) & U)
assoc {S} = equiv (∼-assoc {S})

assoc⁻¹ : ∀ {S T U} → ((S & T) & U) ⇒ (S & (T & U))
assoc⁻¹ {S} = equiv (∼-sym (∼-assoc {S}))

-- Projections

discard : ∀ {S} → (S ⇒ I)
discard {I}     = done
discard {Σ V F} = inp (♯ λ a → discard)

π₁ : ∀ {S T} → (S & T ⇒ S)
π₁ {I}     = discard
π₁ {Σ V F} = inp (♯ λ a → out a π₁)

π₂ : ∀ {S T} → (S & T ⇒ T)
π₂ {I}     = done
π₂ {Σ V F} = inp (♯ λ a → π₂ {♭ F a})

-- The category is almost cartesian, at the cost of
-- buffering.  WARNING.  BUFFERING.  This is bad.  Do not do this.

-- The "almost" is due to a failure of the projection properties:
-- P ⟨&⟩ Q ⟫ π₂ is not equivalent to Q, since Q may do output immediately,
-- and P ⟨&⟩ Q ⟫ π₂ can only output after it has consumed all its input.
-- Similarly π₁ ⟨&⟩ π₂ is not equivalent to done, as π₂'s output will
-- be bufferred.

-- This implementation uses output buffering, hopefully output
-- is usually smaller than input.

buffer : ∀ {S T U V} → (S ⇒ T) → (S ⇒ U) → (U ≤ V) → (S ⇒ T & V)
buffer (inp P)        (inp Q)   cs = inp (♯ λ a → buffer (♭ P a) (♭ Q a) cs)
buffer (inp P)        (out c Q) cs = buffer (inp P) Q (c ∷ cs)
buffer (inp P)        done      cs = inp (♯ λ c → buffer (♭ P c) done (c ∷ cs))
buffer (out b P)      Q         cs = out b (buffer P Q cs)
buffer (done {I})     Q         cs = out* cs Q
buffer (done {Σ V F}) (inp Q)   cs = inp (♯ λ a → out a (buffer done (♭ Q a) cs))
buffer (done {Σ V F}) (out c Q) cs = buffer done Q (c ∷ cs)
buffer (done {Σ V F}) done      cs = inp (♯ λ c → out c (buffer done done (c ∷ cs)))

_⟨&⟩_ : ∀ {S T U} → (S ⇒ T) → (S ⇒ U) → (S ⇒ T & U)
P ⟨&⟩ Q = buffer P Q []

-- If you want input buffering, you can implement it using copy and _[&]_.

copy : ∀ {S} → (S ⇒ (S & S))
copy = done ⟨&⟩ done

-- Braiding structure

swap'' : ∀ {T U} → (I ≤ U) → T ⇒ (T & U)
swap'' {I}     cs = out* cs done
swap'' {Σ W G} cs = inp (♯ λ b → out b (swap'' cs))

swap' : ∀ {S T} {isΣ : IsΣ T} {U} → (S ≤ U) → (S & T) ⇒ (T & U)
swap' {I}             cs = swap'' cs
swap' {Σ V F} {Σ W G} cs = inp (♯ λ c → swap' (c ∷ cs))
swap' {Σ V F} {I}  {} cs

swap : ∀ {S T} → ((S & T) ⇒ (T & S))
swap {I}     {T}     = unit₂⁻¹
swap {Σ V F} {I}     = unit₂
swap {Σ V F} {Σ W G} = swap' {Σ V F} []

-- Choice

ι₁ : ∀ {S T} → (S ⇒ S + T)
ι₁ = out true done

ι₂ : ∀ {S T} → (T ⇒ S + T)
ι₂ = out false done

choice : ∀ {S T U} → (S ⇒ U) → (T ⇒ U) → ∀ b → ((if b then S else T) ⇒ U)
choice P Q true  = P
choice P Q false = Q

_[+]_ : ∀ {S T U V} → (S ⇒ U) → (T ⇒ V) → ((S + T) ⇒ (U + V))
P [+] Q = inp (♯ choice (out true P) (out false Q))

_⟨+⟩_ : ∀ {S T U} {isΣ : IsΣ U} → (S ⇒ U) → (T ⇒ U) → ((S + T) ⇒ U)
_⟨+⟩_ {S} {T} {Σ X H} P Q = inp (♯ choice P Q)
_⟨+⟩_ {S} {T} {I}  {} P Q

-- Options.

some : ∀ {S} → (S ⇒ ¿ S)
some = ι₁

none : ∀ {S} → (I ⇒ ¿ S)
none = ι₂

[¿] : ∀ {S T} → (S ⇒ T) → (¿ S ⇒ ¿ T)
[¿] P = P [+] done

_⟨¿⟩_ : ∀ {S T} {isΣ : IsΣ T} → (S ⇒ T) → (I ⇒ T) → (¿ S ⇒ T)
_⟨¿⟩_ {S} {T} {isΣ} = _⟨+⟩_ {S} {I} {T} {isΣ}


-- Andreas, 2012-01-13
module Issue555a where

-- Do we want to allow this?
data Exp : Set → Set1
data Exp Γ where -- needs to report that too many parameters are given
  var : Exp Γ
  bla : {Δ : Set} → Exp Δ → Exp (Δ → Γ) → Exp Γ

-- A declared index is turned into a parameter by the definition.

data ℕ : Set where
  zero : ℕ
  suc  : ℕ → ℕ

data Vec : Set → ℕ → Set
data Vec A where
  nil : Vec A zero
  _∷_ : {n : ℕ} → A → Vec A n → Vec A (suc n)


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

module Number.Instances.QuoIntFromIntSIP where

open import Agda.Primitive renaming (_⊔_ to ℓ-max; lsuc to ℓ-suc; lzero to ℓ-zero)
open import Cubical.Foundations.Everything hiding (⋆) renaming (_⁻¹ to _⁻¹ᵖ; assoc to ∙-assoc)
open import Cubical.Foundations.Logic renaming (inl to inlᵖ; inr to inrᵖ)

-- open import Cubical.Relation.Nullary.Base renaming (¬_ to ¬ᵗ_)
-- open import Cubical.Relation.Binary.Base
-- open import Cubical.Data.Sum.Base renaming (_⊎_ to infixr 4 _⊎_)
open import Cubical.Data.Sigma.Base renaming (_×_ to infixr 4 _×_)
-- open import Cubical.Data.Sigma
-- open import Cubical.Data.Bool as Bool using (Bool; not; true; false)
-- open import Cubical.Data.Empty renaming (elim to ⊥-elim; ⊥ to ⊥⊥) -- `⊥` and `elim`
-- open import Cubical.Foundations.Logic renaming (¬_ to ¬ᵖ_; inl to inlᵖ; inr to inrᵖ)
-- open import Function.Base using (it; _∋_; _$_)
open import Cubical.Foundations.Isomorphism
open import Cubical.Foundations.Univalence

open import Cubical.HITs.PropositionalTruncation --.Properties
open import Cubical.Foundations.SIP

-- open import Utils using (!_; !!_)
-- open import MoreLogic.Reasoning
open import MoreLogic.Definitions
-- open import MoreLogic.Properties
-- open import MorePropAlgebra.Definitions hiding (_≤''_)
-- open import MorePropAlgebra.Structures
-- open import MorePropAlgebra.Bundles
-- open import MorePropAlgebra.Consequences
open import Number.Structures2
open import Number.Bundles2

-- import Agda.Builtin.Int as Builtin
-- import Data.Integer.Base as BuiltinBase
-- import Data.Integer.Properties as BuiltinProps

-- open import Cubical.Data.Nat.Literals
-- open import Number.Prelude.Nat
-- open import Number.Prelude.Int
-- import Cubical.Data.Int as Int
-- import Number.Instances.Int

-- LinearlyOrderedCommRing ≡ LOCR

record LOCRStructure {ℓ ℓ'} (Carrier : Type ℓ) : Type (ℓ-max ℓ (ℓ-suc ℓ')) where
  constructor locrstructure
  field
    0f 1f   : Carrier
    _+_     : Carrier → Carrier → Carrier
    -_      : Carrier → Carrier
    _·_     : Carrier → Carrier → Carrier
    min max : Carrier → Carrier → Carrier
    _<_     : hPropRel Carrier Carrier ℓ'
    is-LOCR : [ isLinearlyOrderedCommRing 0f 1f _+_ _·_ -_ _<_ min max ]

LOCRΣ : ∀{ℓ ℓ'} → Type (ℓ-suc (ℓ-max ℓ ℓ'))
LOCRΣ {ℓ} {ℓ'} = TypeWithStr {ℓ' = ℓ-max ℓ (ℓ-suc ℓ')} ℓ (LOCRStructure {ℓ} {ℓ'})

record LOCRΣEquiv {ℓ} {ℓ'} (Σ₁ Σ₂ : LOCRΣ {ℓ} {ℓ'}) (Carrier₁≃₂ : fst Σ₁ ≃ fst Σ₂) : Type (ℓ-max ℓ (ℓ-suc ℓ')) where
  constructor locrΣequiv
  Carrier₁   = fst Σ₁
  Carrier₂   = fst Σ₂
  Structure₁ = snd Σ₁
  Structure₂ = snd Σ₂
  private
    module ₁ = LOCRStructure Structure₁
    module ₂ = LOCRStructure Structure₂
  〚_〛 = equivFun Carrier₁≃₂
  field
    pres0 : 〚 ₁.0f 〛 ≡ ₂.0f
    pres1 : 〚 ₁.1f 〛 ≡ ₂.1f
    isHom--   : ∀ y   → 〚         ₁.- y 〛 ≡             ₂.- 〚 y 〛
    isHom-+   : ∀ x y → 〚       x ₁.+ y 〛 ≡       〚 x 〛 ₂.+ 〚 y 〛
    isHom-·   : ∀ x y → 〚       x ₁.· y 〛 ≡       〚 x 〛 ₂.· 〚 y 〛
    isHom-min : ∀ x y → 〚 ₁.min x     y 〛 ≡ ₂.min 〚 x 〛     〚 y 〛
    isHom-max : ∀ x y → 〚 ₁.max x     y 〛 ≡ ₂.max 〚 x 〛     〚 y 〛
    isHom-<   : ∀ x y →         x ₁.< y   ≡       〚 x 〛 ₂.< 〚 y 〛

LOCREquivStr : ∀{ℓ ℓ'} → StrEquiv (LOCRStructure {ℓ} {ℓ'}) (ℓ-max ℓ (ℓ-suc ℓ'))
LOCREquivStr Σ₁@(Carrier₁ , Structure₁) Σ₂@(Carrier₂ , Structure₂) Carrier₁≃₂ = LOCRΣEquiv Σ₁ Σ₂ Carrier₁≃₂

LOCRUnivalentStructure : ∀{ℓ ℓ'} → UnivalentStr (LOCRStructure {ℓ} {ℓ'}) LOCREquivStr
LOCRUnivalentStructure {A = Σ₁@(Carrier₁ , Structure₁)} {B = Σ₂@(Carrier₂ , Structure₂)} Carrier₁≃₂ = f , φ where
  Carrier₁≡Carrier₂ : Carrier₁ ≡ Carrier₂
  Carrier₁≡Carrier₂ = ua Carrier₁≃₂
  module ₁ = LOCRStructure Structure₁
  module ₂ = LOCRStructure Structure₂
  〚_〛 = equivFun Carrier₁≃₂
  -- {-# DISPLAY equivFun Carrier₁≃₂ x = 〚 x 〛 #-} -- somehow omits its `x` ?

  -- I guess this is what we have "the machinery" for
  f : LOCREquivStr Σ₁ Σ₂ Carrier₁≃₂
    → PathP (λ i → LOCRStructure (Carrier₁≡Carrier₂ i)) Structure₁ Structure₂
  f (locrΣequiv pres0 pres1 isHom-- isHom-+ isHom-· isHom-min isHom-max isHom-<) = {!   !}
  φ : isEquiv f
  φ .equiv-proof Structure₁≡₂ = {!   !}

-- R ≃[ LOCREquivStr ] S ≡ Σ _ (LOCRΣEquiv R S)
-- LOCRΣPath : ∀{ℓ ℓ'} (R S : LOCRΣ {ℓ} {ℓ'}) → (R ≃[ LOCREquivStr ] S) ≃ (R ≡ S)
-- "an equivalence between the two carriers that fulfills the axioms in `LOCRΣEquiv` is equivalent to a path between the two structures"
LOCRΣPath* : ∀{ℓ ℓ'} (R S : LOCRΣ {ℓ} {ℓ'}) → Σ _ (LOCRΣEquiv R S) ≃ (R ≡ S)
LOCRΣPath* = SIP LOCRUnivalentStructure

open import Cubical.Structures.Axioms
open import Cubical.Structures.Auto
open import Cubical.Foundations.Equiv
open import Cubical.Foundations.Equiv.HalfAdjoint -- congIso

module _ {ℓ ℓ'} where
  LOCRRawStructure'    = λ(X : Type ℓ) → X × X × (X → X) × (X → X → X) × (X → X → X) × (X → X → X) × (X → X → X) × (X → X → hProp ℓ')
  LOCRRawEquivStr'     = AutoEquivStr LOCRRawStructure'

  LOCRRawUnivalentStr' : UnivalentStr _ LOCRRawEquivStr'
  LOCRRawUnivalentStr' = autoUnivalentStr LOCRRawStructure'

  LOCRAxioms' : (X : Type ℓ) (Structure : LOCRRawStructure' X) → _
  LOCRAxioms' X (0f , 1f , -_ , _+_ , _·_ , min , max , _<_) = [ isLinearlyOrderedCommRing 0f 1f _+_ _·_ -_ _<_ min max ]

  LOCRStructure'          = AxiomsStructure LOCRRawStructure' LOCRAxioms'
  LOCRΣ'                  = TypeWithStr ℓ LOCRStructure'
  LOCREquivStr'           = AxiomsEquivStr LOCRRawEquivStr' LOCRAxioms'

  LOCRUnivalentStructure' : UnivalentStr LOCRStructure' LOCREquivStr'
  LOCRUnivalentStructure' = axiomsUnivalentStr _ γ LOCRRawUnivalentStr' where
    γ : (X : Type ℓ) (s : LOCRRawStructure' X) → isProp (LOCRAxioms' X s)
    γ X (0f , 1f , -_ , _+_ , _·_ , min , max , _<_) = isProp[] (isLinearlyOrderedCommRing 0f 1f _+_ _·_ -_ _<_ min max)

  LOCRΣPath' : (A B : LOCRΣ') → (A ≃[ LOCREquivStr' ] B) ≃ (A ≡ B)
  LOCRΣPath' = SIP LOCRUnivalentStructure'

  LOCRΣ→' : LOCRΣ {ℓ} {ℓ'} → LOCRΣ'
  LOCRΣ→' (X , s) = let open LOCRStructure s in X , (0f , 1f , -_ , _+_ , _·_ , min , max , _<_) , is-LOCR

  LOCRΣ←' : LOCRΣ' → LOCRΣ {ℓ} {ℓ'}
  LOCRΣ←' (X , (0f , 1f , -_ , _+_ , _·_ , min , max , _<_) , is-LOCR) = (X , γ) where
    γ : LOCRStructure {ℓ} {ℓ'} X
    γ  .LOCRStructure.0f      = 0f
    γ  .LOCRStructure.1f      = 1f
    γ  .LOCRStructure._+_     = _+_
    γ  .LOCRStructure.-_      = -_
    γ  .LOCRStructure._·_     = _·_
    γ  .LOCRStructure.min     = min
    γ  .LOCRStructure.max     = max
    γ  .LOCRStructure._<_     = _<_
    γ  .LOCRStructure.is-LOCR = is-LOCR

  LOCRΣIso : Iso LOCRΣ LOCRΣ'
  LOCRΣIso = iso LOCRΣ→' LOCRΣ←' (λ _ → refl) (λ _ → refl)

  LOCRΣEquiv' = λ(A B : LOCRΣ {ℓ} {ℓ'}) → LOCRΣ→' A ≃[ LOCREquivStr' ] LOCRΣ→' B

  LOCRΣEquivIso : {R S : LOCRΣ} → Iso (Σ _ (LOCRΣEquiv R S)) (LOCRΣEquiv' R S)
  LOCRΣEquivIso .Iso.fun (Carrier₁≃₂ , locrΣequiv pres0   pres1   isHom--   isHom-+   isHom-·   isHom-min   isHom-max   isHom-<) =
                         (Carrier₁≃₂ ,            pres0 , pres1 , isHom-- , isHom-+ , isHom-· , isHom-min , isHom-max , isHom-<)
  LOCRΣEquivIso .Iso.inv (Carrier₁≃₂ ,            pres0 , pres1 , isHom-- , isHom-+ , isHom-· , isHom-min , isHom-max , isHom-<) =
                         (Carrier₁≃₂ , locrΣequiv pres0   pres1   isHom--   isHom-+   isHom-·   isHom-min   isHom-max   isHom-<)
  LOCRΣEquivIso .Iso.rightInv _ = refl
  LOCRΣEquivIso .Iso.leftInv  _ = refl

  -- obtained by SIP-machinery:
  --   our previously defined LOCRΣEquiv-record is equivalent to a path
  LOCRΣPath : (R S : LOCRΣ {ℓ} {ℓ'}) → Σ _ (LOCRΣEquiv R S) ≃ (R ≡ S)
  LOCRΣPath R S =
    Σ _ (LOCRΣEquiv R S) ≃⟨ isoToEquiv LOCRΣEquivIso ⟩
    LOCRΣEquiv' R S ≃⟨ LOCRΣPath' _ _ ⟩
    LOCRΣ→' R ≡ LOCRΣ→' S ≃⟨ isoToEquiv (invIso (congIso LOCRΣIso)) ⟩
    R ≡ S ■


------------------------------------------------------------------------
-- Well-typed polymorphic and iso-recursive lambda terms
------------------------------------------------------------------------

module SystemF.WtTerm where

import Category.Functor as Functor
import Category.Applicative.Indexed as Applicative
open Functor.Morphism using (op-<$>)
open import Data.Fin using (Fin; zero; suc; inject+)
open import Data.Fin.Substitution
open import Data.Fin.Substitution.Lemmas
open import Data.List using (List; _∷_)
open import Data.List.All using (All; []; _∷_)
open import Data.Nat using (zero; suc; ℕ; _+_)
open import Data.Product using (_,_)
open import Data.Vec using (Vec; []; _∷_; _++_; lookup; map; toList; zip)
open import Data.Vec.Properties
  using (map-∘; map-cong; lookup-++-inject+)
open import Data.Vec.Categorical
  using (lookup-functor-morphism)
open import Function as Fun using (_∘_)
open import Relation.Binary.PropositionalEquality as PropEq
  using (_≡_; refl; cong; cong₂; subst; sym)
open PropEq.≡-Reasoning
open import Relation.Nullary using (¬_)

open import SystemF.Type
open import SystemF.Term

------------------------------------------------------------------------
-- Typing derivations for polymorphic and iso-recursive lambda terms

-- Typing contexts mapping free (term) variables to types.  A context
-- of type Ctx m n maps m free variables to types containing up to n
-- free type variables each.
Ctx : ℕ → ℕ → Set
Ctx m n = Vec (Type n) m

-- Type and variable substitutions lifted to typing contexts
module CtxSubst where

  infixl 8 _/_ _/Var_

  -- Type substitution lifted to typing contexts
  _/_ : ∀ {m n k} → Ctx m n → Sub Type n k → Ctx m k
  Γ / σ = Γ TypeSubst.⊙ σ

  -- Weakening of typing contexts with additional type variables
  weaken : ∀ {m n} → Ctx m n → Ctx m (1 + n)
  weaken Γ = map TypeSubst.weaken Γ

  -- Variable substitution (renaming) lifted to typing contexts
  _/Var_ : ∀ {m n k} → Sub Fin m k → Ctx k n → Ctx m n
  σ /Var Γ = map (λ x → lookup Γ x) σ

open TypeSubst using () renaming (_[/_]  to _[/tp_])
open CtxSubst  using () renaming (weaken to weakenCtx)

infix  4 _⊢_∈_ _⊢_∉_ _⊢val_∈_ _⊢ⁿ_∈_
infixl 9 _·_ _[_]

-- Typing derivations for well-typed terms
data _⊢_∈_ {m n} (Γ : Ctx m n) : Term m n → Type n → Set where
  var    : (x : Fin m) → Γ ⊢ var x ∈ lookup Γ x
  Λ      : ∀ {t a} → (weakenCtx Γ) ⊢ t ∈ a → Γ ⊢ Λ t ∈ ∀' a
  λ'     : ∀ {t b} → (a : Type n) → a ∷ Γ ⊢ t ∈ b → Γ ⊢ λ' a t ∈ a →' b
  μ      : ∀ {t} → (a : Type n) → a ∷ Γ ⊢ t ∈ a → Γ ⊢ μ a t ∈ a
  _[_]   : ∀ {t a} → Γ ⊢ t ∈ ∀' a → (b : Type n) → Γ ⊢ t [ b ] ∈ a [/tp b ]
  _·_    : ∀ {s t a b} → Γ ⊢ s ∈ a →' b → Γ ⊢ t ∈ a → Γ ⊢ s · t ∈ b
  fold   : ∀ {t} → (a : Type (1 + n)) → Γ ⊢ t ∈ a [/tp μ a ] →
           Γ ⊢ fold a t ∈ μ a
  unfold : ∀ {t} → (a : Type (1 + n)) → Γ ⊢ t ∈ μ a →
           Γ ⊢ unfold a t ∈ a [/tp μ a ]

-- Negation of well-typedness.
_⊢_∉_ : ∀ {m n} → Ctx m n → Term m n → Type n → Set
Γ ⊢ t ∉ a = ¬ Γ ⊢ t ∈ a

-- Typing derivations for well-typed values.
data _⊢val_∈_ {m n} (Γ : Ctx m n) : Val m n → Type n → Set where
  Λ    : ∀ {t a} → (weakenCtx Γ) ⊢ t ∈ a → Γ ⊢val Λ t ∈ ∀' a
  λ'   : ∀ {t b} → (a : Type n) → a ∷ Γ ⊢ t ∈ b → Γ ⊢val λ' a t ∈ a →' b
  fold : ∀ {v} → (a : Type (1 + n)) → Γ ⊢val v ∈ a [/tp μ a ] →
         Γ ⊢val fold a v ∈ μ a

-- Conversion from well-typed values to well-typed terms.
⊢⌜_⌝ : ∀ {m n} {Γ : Ctx m n} {v a} → Γ ⊢val v ∈ a → Γ ⊢ ⌜ v ⌝ ∈ a
⊢⌜ Λ x      ⌝ = Λ x
⊢⌜ λ' a t   ⌝ = λ' a t
⊢⌜ fold a t ⌝ = fold a ⊢⌜ t ⌝

-- Collections of typing derivations for well-typed terms.
data _⊢ⁿ_∈_ {m n} (Γ : Ctx m n) :
  ∀ {k} → Vec (Term m n) k → Vec (Type n) k → Set where
    []  : Γ ⊢ⁿ [] ∈ []
    _∷_ : ∀ {t a k} {ts : Vec (Term m n) k} {as : Vec (Type n) k} →
          Γ ⊢ t ∈ a → Γ ⊢ⁿ ts ∈ as → Γ ⊢ⁿ t ∷ ts ∈ a ∷ as

-- Lookup a well-typed term in a collection thereof.
lookup-⊢ : ∀ {m n k} {Γ : Ctx m n} {ts : Vec (Term m n) k}
             {as : Vec (Type n) k} →
           (x : Fin k) → Γ ⊢ⁿ ts ∈ as → Γ ⊢ lookup ts x ∈ lookup as x
lookup-⊢ zero    (⊢t ∷ ⊢ts) = ⊢t
lookup-⊢ (suc x) (⊢t ∷ ⊢ts) = lookup-⊢ x ⊢ts

------------------------------------------------------------------------
-- Lemmas about type and variable substitutions (renaming) lifted to
-- typing contexts

module CtxLemmas where
  open CtxSubst public

  private module Tp  = TypeLemmas
  private module Var = VarSubst

  -- Term variable substitution (renaming) commutes with type
  -- substitution.
  /Var-/ : ∀ {m n k l} (ρ : Sub Fin m k) (Γ : Ctx k n) (σ : Sub Type n l) →
           (ρ /Var Γ) / σ ≡ ρ /Var (Γ / σ)
  /Var-/ ρ Γ σ = begin
      (ρ /Var Γ) / σ
    ≡⟨ sym (map-∘ _ _ ρ) ⟩
      map (λ x → (lookup Γ x) Tp./ σ) ρ
    ≡⟨ map-cong (λ x → sym (Tp.lookup-⊙ x {ρ₁ = Γ})) ρ ⟩
      map (λ x → lookup (Γ / σ) x) ρ
    ∎

  -- Term variable substitution (renaming) commutes with weakening of
  -- typing contexts with an additional type variable.
  /Var-weaken : ∀ {m n k} (ρ : Sub Fin m k) (Γ : Ctx k n) →
                weaken (ρ /Var Γ) ≡ ρ /Var (weaken Γ)
  /Var-weaken ρ Γ = begin
    weaken (ρ /Var Γ)    ≡⟨ Tp.map-weaken ⟩
    (ρ /Var Γ) / Tp.wk   ≡⟨ /Var-/ ρ Γ Tp.wk ⟩
    ρ /Var (Γ / Tp.wk)   ≡⟨ sym (cong (_/Var_ ρ) (Tp.map-weaken {ρ = Γ})) ⟩
    ρ /Var (weaken Γ)    ∎

  -- Term variable substitution (renaming) commutes with term variable
  -- lookup in typing context.
  /Var-lookup : ∀ {m n k} (x : Fin m) (ρ : Sub Fin m k) (Γ : Ctx k n) →
                lookup (ρ /Var Γ) x ≡ lookup Γ (lookup ρ x)
  /Var-lookup x ρ Γ = op-<$> (lookup-functor-morphism x) (λ x → lookup Γ x) ρ

  -- Term variable substitution (renaming) commutes with weakening of
  -- typing contexts with an additional term variable.
  /Var-∷ : ∀ {m n k} (a : Type n) (ρ : Sub Fin m k) (Γ : Ctx k n) →
           a ∷ (ρ /Var Γ) ≡ (ρ Var.↑) /Var (a ∷ Γ)
  /Var-∷ a []      Γ = refl
  /Var-∷ a (x ∷ ρ) Γ = cong (_∷_ a) (cong (_∷_ (lookup Γ x)) (begin
    map (λ x → lookup Γ x) ρ                   ≡⟨ refl ⟩
    map (λ x → lookup (a ∷ Γ) (suc x)) ρ       ≡⟨ map-∘ _ _ ρ ⟩
    map (λ x → lookup (a ∷ Γ) x) (map suc ρ)   ∎))

  -- Invariants of term variable substitution (renaming)
  idVar-/Var   : ∀ {m n} (Γ : Ctx m n) → Γ ≡ (Var.id /Var Γ)
  wkVar-/Var-∷ : ∀ {m n} (Γ : Ctx m n) (a : Type n) → Γ ≡ (Var.wk /Var (a ∷ Γ))

  idVar-/Var []      = refl
  idVar-/Var (a ∷ Γ) = cong (_∷_ a) (wkVar-/Var-∷ Γ a)

  wkVar-/Var-∷ Γ a = begin
    Γ                    ≡⟨ idVar-/Var Γ ⟩
    Var.id /Var Γ         ≡⟨ map-∘ _ _ VarSubst.id ⟩
    Var.wk /Var (a ∷ Γ)   ∎

------------------------------------------------------------------------
-- Substitutions in well-typed terms

-- Helper lemmas for applying type and term equalities in typing
-- derivations
⊢subst : ∀ {m n} {Γ₁ Γ₂ : Ctx m n} {t₁ t₂ : Term m n} {a₁ a₂ : Type n} →
  Γ₁ ≡ Γ₂ → t₁ ≡ t₂ → a₁ ≡ a₂ → Γ₁ ⊢ t₁ ∈ a₁ → Γ₂ ⊢ t₂ ∈ a₂
⊢subst refl refl refl hyp = hyp

⊢substCtx : ∀ {m n} {Γ₁ Γ₂ : Ctx m n} {t : Term m n} {a : Type n} →
  Γ₁ ≡ Γ₂ → Γ₁ ⊢ t ∈ a → Γ₂ ⊢ t ∈ a
⊢substCtx refl hyp = hyp

⊢substTp : ∀ {m n} {Γ : Ctx m n} {t : Term m n} {a₁ a₂ : Type n} →
  a₁ ≡ a₂ → Γ ⊢ t ∈ a₁ → Γ ⊢ t ∈ a₂
⊢substTp refl hyp = hyp

-- Type substitutions lifted to well-typed terms
module WtTermTypeSubst where
  open TypeLemmas hiding (_/_; _[/_]; weaken)
  private
    module Tp = TypeLemmas
    module Tm = TermTypeLemmas
    module C  = CtxSubst

  infixl 8 _/_

  -- Type substitutions lifted to well-typed terms
  _/_ : ∀ {m n k} {Γ : Ctx m n} {t : Term m n} {a : Type n} →
        Γ ⊢ t ∈ a → (σ : Sub Type n k) → Γ C./ σ ⊢ t Tm./ σ ∈ a Tp./ σ
  _/_  {Γ = Γ} (var x) σ = ⊢substTp (lookup-⊙ x {ρ₁ = Γ}) (var x)
  _/_ {Γ = Γ} (Λ ⊢t)  σ =
    Λ (⊢substCtx (sym (map-weaken-⊙ Γ σ)) (⊢t / σ ↑))
  λ' a ⊢t           / σ = λ' (a Tp./ σ) (⊢t / σ)
  μ a ⊢t            / σ = μ  (a Tp./ σ) (⊢t / σ)
  _[_] {a = a} ⊢t b / σ =
    ⊢substTp (sym (sub-commutes a)) ((⊢t / σ) [ b Tp./ σ ])
  ⊢s · ⊢t           / σ = (⊢s / σ) · (⊢t / σ)
  fold a ⊢t         / σ =
    fold (a Tp./ σ ↑) (⊢substTp (sub-commutes a) (⊢t / σ))
  unfold a ⊢t       / σ =
    ⊢substTp (sym (sub-commutes a)) (unfold (a Tp./ σ ↑) (⊢t / σ))

  -- Weakening of terms with additional type variables lifted to
  -- well-typed terms.
  weaken : ∀ {m n} {Γ : Ctx m n} {t : Term m n} {a : Type n} →
           Γ ⊢ t ∈ a → C.weaken Γ ⊢ Tm.weaken t ∈ Tp.weaken a
  weaken {t = t} {a = a} ⊢t =
    ⊢subst (sym map-weaken) (Tm./-wk t) (/-wk {t = a}) (⊢t / wk)

  -- Weakening of terms with additional type variables lifted to
  -- collections of well-typed terms.
  weakenAll : ∀ {m n k} {Γ : Ctx m n} {ts : Vec (Term m n) k}
                {as : Vec (Type n) k} → Γ ⊢ⁿ ts ∈ as →
                C.weaken Γ ⊢ⁿ map Tm.weaken ts ∈ map Tp.weaken as
  weakenAll {ts = []}    {[]}    []         = []
  weakenAll {ts = _ ∷ _} {_ ∷ _} (⊢t ∷ ⊢ts) = weaken ⊢t ∷ weakenAll ⊢ts

  -- Shorthand for single-variable type substitutions in well-typed
  -- terms.
  _[/_] : ∀ {m n} {Γ : Ctx m (1 + n)} {t a} →
          Γ ⊢ t ∈ a → (b : Type n) → Γ C./ sub b ⊢ t Tm./ sub b ∈ a Tp./ sub b
  ⊢t [/ b ] = ⊢t / sub b

  -- A weakened version of the shorthand for single-variable type
  -- substitutions that fits well with well-typed type application.
  _[/_]′ : ∀ {m n} {Γ : Ctx m n} {t a} → C.weaken Γ ⊢ t ∈ a →
           (b : Type n) → Γ ⊢ t Tm./ sub b ∈ a Tp./ sub b
  ⊢t [/ b ]′ = ⊢substCtx Tp.map-weaken-⊙-sub (⊢t / sub b)

-- Term substitutions lifted to well-typed terms
module WtTermTermSubst where
  private
    module Tp  = TermTypeSubst
    module Tm  = TermTermSubst
    module Var = VarSubst
    module C   = CtxLemmas
    TmSub = Tm.TermSub Term

  infix 4 _⇒_⊢_

  -- Well-typed term substitutions are collections of well-typed terms.
  _⇒_⊢_ : ∀ {m n k} → Ctx m n → Ctx k n → TmSub m n k → Set
  Γ ⇒ Δ ⊢ ρ = Δ ⊢ⁿ ρ ∈ Γ

  infixl 8  _/_ _/Var_
  infix  10 _↑

  -- Application of term variable substitutions (renaming) lifted to
  -- well-typed terms.
  _/Var_ : ∀ {m n k} {Γ : Ctx k n} {t : Term m n} {a : Type n}
             (ρ : Sub Fin m k) → ρ C./Var Γ ⊢ t ∈ a → Γ ⊢ t Tm./Var ρ ∈ a
  _/Var_ {Γ = Γ} ρ (var x)   =
    ⊢substTp (sym (C./Var-lookup x ρ Γ)) (var (lookup ρ x))
  _/Var_ {Γ = Γ} ρ (Λ ⊢t)    =
    Λ    (ρ      /Var ⊢substCtx (C./Var-weaken ρ Γ) ⊢t)
  _/Var_ {Γ = Γ} ρ (λ' a ⊢t) =
    λ' a (ρ Var.↑ /Var ⊢substCtx (C./Var-∷ a ρ Γ) ⊢t)
  _/Var_ {Γ = Γ} ρ (μ a ⊢t)  =
    μ  a (ρ Var.↑ /Var ⊢substCtx (C./Var-∷ a ρ Γ) ⊢t)
  ρ /Var (⊢t [ b ])          = (ρ /Var ⊢t) [ b ]
  ρ /Var (⊢s · ⊢t)           = (ρ /Var ⊢s) · (ρ /Var ⊢t)
  ρ /Var (fold a ⊢t)         = fold   a (ρ /Var ⊢t)
  ρ /Var (unfold a ⊢t)       = unfold a (ρ /Var ⊢t)

  -- Weakening of terms with additional term variables lifted to
  -- well-typed terms.
  weaken : ∀ {m n} {Γ : Ctx m n} {t : Term m n} {a b : Type n} →
           Γ ⊢ t ∈ a → b ∷ Γ ⊢ Tm.weaken t ∈ a
  weaken {Γ = Γ} {b = b} ⊢t =
    Var.wk /Var ⊢substCtx (C.wkVar-/Var-∷ Γ b) ⊢t

  -- Weakening of terms with additional term variables lifted to
  -- collections of well-typed terms.
  weakenAll : ∀ {m n k} {Γ : Ctx m n} {ts : Vec (Term m n) k}
                {as : Vec (Type n) k} {b : Type n} →
              Γ ⊢ⁿ ts ∈ as → b ∷ Γ ⊢ⁿ map Tm.weaken ts ∈ as
  weakenAll {ts = []}    {[]}    []         = []
  weakenAll {ts = _ ∷ _} {_ ∷ _} (⊢t ∷ ⊢ts) = weaken ⊢t ∷ weakenAll ⊢ts

  -- Lifting of well-typed term substitutions.
  _↑ : ∀ {m n k} {Γ : Ctx m n} {Δ : Ctx k n} {ρ b} →
       Γ ⇒ Δ ⊢ ρ → b ∷ Γ ⇒ b ∷ Δ ⊢ ρ Tm.↑
  ⊢ρ ↑ = var zero ∷ weakenAll ⊢ρ

  -- The well-typed identity substitution.
  id : ∀ {m n} {Γ : Ctx m n} → Γ ⇒ Γ ⊢ Tm.id
  id {zero}  {Γ = []}    = []
  id {suc m} {Γ = a ∷ Γ} = id ↑

  -- Well-typed weakening (as a substitution).
  wk : ∀ {m n} {Γ : Ctx m n} {a} → Γ ⇒ a ∷ Γ ⊢ Tm.wk
  wk = weakenAll id

  -- A well-typed substitution which only replaces the first variable.
  sub : ∀ {m n} {Γ : Ctx m n} {t a} → Γ ⊢ t ∈ a → a ∷ Γ ⇒ Γ ⊢ Tm.sub t
  sub ⊢t = ⊢t ∷ id

  -- Application of term substitutions lifted to well-typed terms
  _/_ : ∀ {m n k} {Γ : Ctx m n} {Δ : Ctx k n} {t a ρ} →
        Γ ⊢ t ∈ a → Γ ⇒ Δ ⊢ ρ → Δ ⊢ t Tm./ ρ ∈ a
  var x       / ⊢ρ = lookup-⊢ x ⊢ρ
  Λ ⊢t        / ⊢ρ = Λ (⊢t / (WtTermTypeSubst.weakenAll ⊢ρ))
  λ' a ⊢t     / ⊢ρ = λ' a (⊢t / ⊢ρ ↑)
  μ a ⊢t      / ⊢ρ = μ a (⊢t / ⊢ρ ↑)
  (⊢t [ a ])  / ⊢ρ = (⊢t / ⊢ρ) [ a ]
  (⊢s · ⊢t)   / ⊢ρ = (⊢s / ⊢ρ) · (⊢t / ⊢ρ)
  fold a ⊢t   / ⊢ρ = fold a (⊢t / ⊢ρ)
  unfold a ⊢t / ⊢ρ = unfold a (⊢t / ⊢ρ)

  -- Shorthand for well-typed single-variable term substitutions.
  _[/_] : ∀ {m n} {Γ : Ctx m n} {s t a b} →
          b ∷ Γ ⊢ s ∈ a → Γ ⊢ t ∈ b → Γ ⊢ s Tm./ Tm.sub t ∈ a
  ⊢s [/ ⊢t ] = ⊢s / sub ⊢t

------------------------------------------------------------------------
-- Encoding of additional well-typed term operators
--
-- These correspond to admissible typing rules for the asscociated
-- term operators.

module WtTermOperators where
  open TypeOperators renaming (id to idTp)
  open TypeOperatorLemmas
  open TypeLemmas hiding (id)
  private
    module Ut   = TermOperators
    module ⊢Tp  = WtTermTypeSubst
    module ⊢Tm  = WtTermTermSubst

  -- Polymorphic identity function
  id : ∀ {m n} {Γ : Ctx m n} → Γ ⊢ Ut.id ∈ idTp
  id = Λ (λ' (var (zero)) (var zero))

  -- Bottom elimination/univeral property of the initial type
  ⊥-elim : ∀ {m n} {Γ : Ctx m n} (a : Type n) → Γ ⊢ Ut.⊥-elim a ∈ ⊥ →' a
  ⊥-elim a = λ' ⊥ ((var zero) [ a ])

  -- Unit value
  tt : ∀ {m n} {Γ : Ctx m n} → Γ ⊢ Ut.tt ∈ ⊤
  tt = id

  -- Top introduction/universal property of the terminal type
  ⊤-intro : ∀ {m n} {Γ : Ctx m n} → (a : Type n) → Γ ⊢ Ut.⊤-intro a ∈ a →' ⊤
  ⊤-intro {n = n} a = λ' a (id {n = n})

  -- Packing existential types
  as-∃_pack_,_ : ∀ {m n} {Γ : Ctx m n}
                   (a : Type (1 + n)) (b : Type n) {t : Term m n} →
                 Γ ⊢ t ∈ a [/tp b ] → Γ ⊢ Ut.as-∃ a pack b , t ∈ ∃ a
  as-∃ a pack b , ⊢t =
    Λ (λ' (∀' (weaken↑ a →' var (suc zero))) ((var zero [ weaken b ]) · ⊢t′))
    where ⊢t′ = ⊢Tm.weaken (⊢substTp (weaken-sub a b) (⊢Tp.weaken ⊢t))

  -- Unpacking existential types
  unpack_in'_ : ∀ {m n} {Γ : Ctx m n} {s : Term m n}
                  {t : Term (1 + m) (1 + n)} {a : Type (1 + n)} {b : Type n} →
                Γ ⊢ s ∈ ∃ a → a ∷ weakenCtx Γ ⊢ t ∈ weaken b →
                Γ ⊢ Ut.unpack_in'_ s t {a} {b} ∈ b
  unpack_in'_ {a = a} {b = b} ⊢s ⊢t = (⊢s [ b ]) · Λ (⊢substTp a≡ (λ' a ⊢t))
    where
      a≡ : a →' weaken b ≡ weaken↑ a / (sub b) ↑ →' weaken b
      a≡ = cong (λ a → a →' weaken b) (begin
        a                       ≡⟨ sym (id-vanishes a) ⟩
        a / TypeLemmas.id       ≡⟨ cong (λ σ → a / σ) (sym (id-↑⋆ 1)) ⟩
        a / (TypeLemmas.id) ↑   ≡⟨ cong (λ σ → a / σ ↑) (sym wk-⊙-sub) ⟩
        a / (wk ⊙ sub b) ↑      ≡⟨ cong (λ σ → a / σ) (↑⋆-distrib 1) ⟩
        a / wk ↑ ⊙ (sub b) ↑    ≡⟨ /-⊙ a ⟩
        a / wk ↑ / (sub b) ↑    ∎)

  -- n-ary term abstraction
  λⁿ : ∀ {m n k} {Γ : Ctx m n} (as : Vec (Type n) k) {b : Type n}
       {t : Term (k + m) n} → as ++ Γ ⊢ t ∈ b → Γ ⊢ Ut.λⁿ as t ∈ as →ⁿ b
  λⁿ []       ⊢t = ⊢t
  λⁿ (a ∷ as) ⊢t = λⁿ as (λ' a ⊢t)

  infixl 9 _·ⁿ_

  -- n-ary term application
  _·ⁿ_ : ∀ {m n k} {Γ : Ctx m n} {s : Term m n} {ts : Vec (Term m n) k}
           {as : Vec (Type n) k} {b : Type n} →
         Γ ⊢ s ∈ as →ⁿ b → Γ ⊢ⁿ ts ∈ as → Γ ⊢ s Ut.·ⁿ ts ∈ b
  _·ⁿ_ {ts = []}    {[]}    ⊢s []         = ⊢s
  _·ⁿ_ {ts = _ ∷ _} {_ ∷ _} ⊢s (⊢t ∷ ⊢ts) = ⊢s ·ⁿ ⊢ts · ⊢t

  -- Record/tuple constructor
  new : ∀ {m n k} {Γ : Ctx m n} {ts : Vec (Term m n) k} {as : Vec (Type n) k} →
        Γ ⊢ⁿ ts ∈ as → Γ ⊢ Ut.new ts {as} ∈ rec as
  new {ts = []}    {[]}     []         = tt
  new {ts = _ ∷ _} {a ∷ as} (⊢t ∷ ⊢ts) =
    Λ (λ' (map weaken (a ∷ as) →ⁿ var zero)
          (var zero ·ⁿ ⊢Tm.weakenAll (⊢Tp.weakenAll (⊢t ∷ ⊢ts))))

  -- Field access/projection
  π : ∀ {m n k} {Γ : Ctx m n} (x : Fin k) {t : Term m n}
        {as : Vec (Type n) k} →
      Γ ⊢ t ∈ rec as → Γ ⊢ Ut.π x t {as} ∈ lookup as x
  π             () {as = []}     ⊢t
  π {m} {Γ = Γ} x  {as = a ∷ as} ⊢t =
    (⊢t [ b ]) · ⊢substTp as′→ⁿb′≡ (λⁿ as′ (var x′))
    where
      as′ = a ∷ as
      x′  = inject+ m x
      b   = lookup as′ x
      b′  = lookup (as′ ++ Γ) x′
      as′→ⁿb′≡ : as′ →ⁿ b′ ≡ (map weaken as′ →ⁿ var zero) [/tp b ]
      as′→ⁿb′≡ = begin
          as′ →ⁿ b′
        ≡⟨ cong (λ b → as′ →ⁿ b) (lookup-++-inject+ as′ Γ x) ⟩
          as′ →ⁿ b
        ≡⟨ cong (λ as′ → as′ →ⁿ b) (sym (map-weaken-⊙-sub {ρ = as′})) ⟩
          map weaken as′ ⊙ sub b →ⁿ b
        ≡⟨ sym (/-→ⁿ (map weaken as′) (var zero) (sub b)) ⟩
          (map weaken as′ →ⁿ var zero) [/tp b ]
        ∎


-- Andreas, 2016-12-03, issue 2307
-- preserve record (vs. constructor) in internal syntax

open import Common.Equality

postulate
  A : Set
  a : A

record R : Set where
  constructor c
  field f : A
open R

postulate
  r : R
  g h : R → R

fail1 : g (c a) ≡ h (record{ f = a })
fail1 = refl

-- ERROR:     g (c a) != h (c a)
-- Expected:  g (c a) != h (record{ f = a })


------------------------------------------------------------------------
-- INCREMENTAL λ-CALCULUS
--
-- Reexport Data.List.All from the standard library.
--
-- At one point, we reinvented Data.List.All from the Agda
-- standard library, under the name dependent list. We later
-- replaced our reinvention by this adapter module that just
-- exports the standard library's version with partly different
-- names.
------------------------------------------------------------------------

module Base.Data.DependentList where

open import Data.List.All public
  using
    ( head
    ; tail
    ; map
    ; tabulate
    )
  renaming
    ( All to DependentList
    ; _∷_ to _•_
    ; [] to ∅
    )

-- Maps a binary function over two dependent lists.
-- Should this be in the Agda standard library?
zipWith : ∀ {a p q r} {A : Set a} {P : A → Set p} {Q : A → Set q} {R : A → Set r} →
  (f : {a : A} → P a → Q a → R a) →
  ∀ {xs} → DependentList P xs → DependentList Q xs → DependentList R xs
zipWith f ∅ ∅ = ∅
zipWith f (p • ps) (q • qs) = f p q • zipWith f ps qs


{-# OPTIONS --universe-polymorphism --no-positivity-check #-}

module Alg-IIR where

data Level : Set where
      zero : Level
      suc  : Level -> Level

{-# BUILTIN LEVEL     Level #-}
{-# BUILTIN LEVELZERO zero  #-}
{-# BUILTIN LEVELSUC  suc   #-}

max : Level -> Level -> Level
max  zero    m      = m
max (suc n)  zero   = suc n
max (suc n) (suc m) = suc (max n m)

{-# BUILTIN LEVELMAX max #-}

_o_ : ∀ {a b c}
        {A : Set a} {B : A → Set b} {C : {x : A} → B x → Set c} →
      (∀ {x} (y : B x) → C y) → (g : (x : A) → B x) →
      ((x : A) → C (g x))
f o g = λ x → f (g x)
infixl 50 _o_

record Sg {a b : Level}(S : Set a)(T : S -> Set b) : Set (max a b) where
  constructor _,_
  field
    fst : S
    snd : T fst

infixr 40 _,_

record Lifted {l : Level} (A : Set l) : Set (suc l) where
  constructor lif
  field
    fil : A

open Lifted

lift : {i : Level} -> Set i -> Set (suc i)
lift x =  Lifted x

unl : {l r : Level}{A : Set l}{P : Lifted A -> Set r} ->
      ((a : A) -> P (lif a)) -> (a : Lifted A) -> P a
unl p a = p (fil a)

mutual
  data IRD (I : Set1)(J : I -> Set1) : Set1 where
    var : I -> IRD I J
    con : Set -> IRD I J
    _*_ : (S : IRD I J) -> (Deco S -> IRD I J) -> IRD I J
    _>_ : (S : Set) -> (S -> IRD I J) -> IRD I J

  Deco : forall {I J} -> IRD I J -> Set1
  Deco {I}{J} (var i) = J i
  Deco (con A) = lift A -- grr
  Deco (S * T) = Sg (Deco S) \ s -> Deco (T s)
  Deco (S > T) = (s : S) -> Deco (T s)

_-:>_ : forall {a b c}{I : Set a} -> (I -> Set b) -> (I -> Set c)
        -> Set (max a (max b c))
_-:>_ {I = I} S T = (i : I) -> S i -> T i

mutual
  Func : forall {I J} -> IRD I J -> (X : I -> Set)(d : X -:> J) -> Set
  Func (var i) X d = X i
  Func (con A) X d = A
  Func (S * T) X d = Sg (Func S X d) \ s -> Func (T (deco S X d s)) X d
  Func (S > T) X d = (s : S) -> Func (T s) X d

  deco : forall {I J} -> (D : IRD I J) -> (X : I -> Set)(d : X -:> J) ->
           Func D X d -> Deco D
  deco (var i) X d x = d i x
  deco (con A) X d a = lif a
  deco (S * T) X d (s , t) = s' , t' where
    s' = deco S X d s
    t' = deco (T s') X d t
  deco (S > T) X d f = \ s -> deco (T s) X d (f s)

mutual
  data DATA {I J}(F : I -> IRD I J)(d : (Deco o F) -:> J)(i : I) : Set where
    <_> : Func (F i) (DATA F d) decode -> DATA F d i

  decode : forall {I J}{F : I -> IRD I J}{d : (Deco o F) -:> J} ->
           DATA F d -:> J
  decode {I}{J}{F}{d} i < xs > = d i (deco (F i) (DATA F d) decode xs)

data MyTags : Set where
  zz ss : MyTags

[_/_] : forall {l}{P : MyTags -> Set l} -> P zz -> P ss -> (t : MyTags) -> P t
[ z / s ] zz = z
[ z / s ] ss = s

record One {a} : Set a where
  constructor <>

NAT : One {suc zero} -> IRD One \ _ -> One
NAT _ = con MyTags * unl [ con One / var _ ]

Nat : Set
Nat = DATA NAT _ _

myze : Nat
myze = < zz , _ >

mysu : Nat -> Nat
mysu n = < ss , n >

data Two : Set where
  tt ff : Two

not : Two -> Two
not tt = ff
not ff = tt

_&&_ : Two -> Two -> Two
tt && b = b
ff && b = ff

_=N=_ : Nat -> Nat -> Two
< zz , _ > =N= < zz , _ > = tt
< zz , _ > =N= < ss , _ > = ff
< ss , _ > =N= < zz , _ > = ff
< ss , m > =N= < ss , n > = m =N= n

data Zero : Set where

So : Two -> Set
So tt = One
So ff = Zero

FREL :  One {suc zero} -> IRD One \ _ -> Lifted (Nat -> Two)
FREL _ = con MyTags * unl
           [ con One
           / (var _ * unl \ f -> con Nat * unl \ x -> con (So (f x)))
           ]

frel : Deco o FREL -:> \ _ -> Lifted (Nat -> Two)
frel _ (lif zz , _)                  = lif \ _ -> tt
frel _ (lif ss , lif f , lif x , p)  = lif \ y -> not (y =N= x) && f y

Frel : Set
Frel = DATA FREL frel _

good : Frel
good = < ss , < ss , < ss , < zz , _ > ,
         myze , _ > ,
         mysu myze , _ > ,
         mysu (mysu myze) , _ >

{-
bad : Frel
bad =  < ss , < ss , < ss , < zz , _ > ,
         myze , _ > ,
         mysu myze , _ > ,
         myze , {!!} >
-}

UNI :  One {suc zero} -> IRD One \ _ -> Set
UNI _ =  con MyTags * unl
           [ con One
           / (var _ * \ S -> S > \ _ -> var _)
           ]

uni : Deco o UNI -:> \ _ -> Set
uni i (lif zz , _) = Nat
uni i (lif ss , S , T) = (s : S) -> T s


module BasicIPC.Metatheory.GentzenSpinalNormalForm-HereditarySubstitution where

open import BasicIPC.Syntax.GentzenSpinalNormalForm public

-- Hereditary substitution and reduction.

mutual
  [_≔_]ⁿᶠ_ : ∀ {A B Γ} → (i : A ∈ Γ) → Γ ∖ i ⊢ⁿᶠ A → Γ ⊢ⁿᶠ B → Γ ∖ i ⊢ⁿᶠ B
  [ i ≔ s ]ⁿᶠ neⁿᶠ (spⁿᵉ j  xs) with i ≟∈ j
  [ i ≔ s ]ⁿᶠ neⁿᶠ (spⁿᵉ .i xs) | same   = reduce s ([ i ≔ s ]ˢᵖ xs)
  [ i ≔ s ]ⁿᶠ neⁿᶠ (spⁿᵉ ._ xs) | diff j = neⁿᶠ (spⁿᵉ j ([ i ≔ s ]ˢᵖ xs))
  [ i ≔ s ]ⁿᶠ lamⁿᶠ t           = lamⁿᶠ ([ pop i ≔ mono⊢ⁿᶠ weak⊆ s ]ⁿᶠ t)
  [ i ≔ s ]ⁿᶠ pairⁿᶠ t u        = pairⁿᶠ ([ i ≔ s ]ⁿᶠ t) ([ i ≔ s ]ⁿᶠ u)
  [ i ≔ s ]ⁿᶠ unitⁿᶠ            = unitⁿᶠ

  [_≔_]ˢᵖ_ : ∀ {A B C Γ} → (i : A ∈ Γ) → Γ ∖ i ⊢ⁿᶠ A → Γ ⊢ˢᵖ B ⦙ C → Γ ∖ i ⊢ˢᵖ B ⦙ C
  [ i ≔ s ]ˢᵖ nilˢᵖ      = nilˢᵖ
  [ i ≔ s ]ˢᵖ appˢᵖ xs u = appˢᵖ ([ i ≔ s ]ˢᵖ xs) ([ i ≔ s ]ⁿᶠ u)
  [ i ≔ s ]ˢᵖ fstˢᵖ xs   = fstˢᵖ ([ i ≔ s ]ˢᵖ xs)
  [ i ≔ s ]ˢᵖ sndˢᵖ xs   = sndˢᵖ ([ i ≔ s ]ˢᵖ xs)

  reduce : ∀ {A C Γ} → Γ ⊢ⁿᶠ A → Γ ⊢ˢᵖ A ⦙ C → Γ ⊢ⁿᶠ C
  reduce t            nilˢᵖ        = t
  reduce (lamⁿᶠ t)    (appˢᵖ xs u) = reduce ([ top ≔ u ]ⁿᶠ t) xs
  reduce (pairⁿᶠ t u) (fstˢᵖ xs)   = reduce t xs
  reduce (pairⁿᶠ t u) (sndˢᵖ xs)   = reduce u xs

-- Reduction-based normal forms.

appⁿᶠ : ∀ {A B Γ} → Γ ⊢ⁿᶠ A ▻ B → Γ ⊢ⁿᶠ A → Γ ⊢ⁿᶠ B
appⁿᶠ t u = reduce t (appˢᵖ nilˢᵖ u)

fstⁿᶠ : ∀ {A B Γ} → Γ ⊢ⁿᶠ A ∧ B → Γ ⊢ⁿᶠ A
fstⁿᶠ t = reduce t (fstˢᵖ nilˢᵖ)

sndⁿᶠ : ∀ {A B Γ} → Γ ⊢ⁿᶠ A ∧ B → Γ ⊢ⁿᶠ B
sndⁿᶠ t = reduce t (sndˢᵖ nilˢᵖ)

-- Useful equipment for deriving neutrals.

≪appˢᵖ : ∀ {A B C Γ} → Γ ⊢ˢᵖ C ⦙ A ▻ B → Γ ⊢ⁿᶠ A → Γ ⊢ˢᵖ C ⦙ B
≪appˢᵖ nilˢᵖ        t = appˢᵖ nilˢᵖ t
≪appˢᵖ (appˢᵖ xs u) t = appˢᵖ (≪appˢᵖ xs t) u
≪appˢᵖ (fstˢᵖ xs)   t = fstˢᵖ (≪appˢᵖ xs t)
≪appˢᵖ (sndˢᵖ xs)   t = sndˢᵖ (≪appˢᵖ xs t)

≪fstˢᵖ : ∀ {A B C Γ} → Γ ⊢ˢᵖ C ⦙ A ∧ B → Γ ⊢ˢᵖ C ⦙ A
≪fstˢᵖ nilˢᵖ        = fstˢᵖ nilˢᵖ
≪fstˢᵖ (appˢᵖ xs u) = appˢᵖ (≪fstˢᵖ xs) u
≪fstˢᵖ (fstˢᵖ xs)   = fstˢᵖ (≪fstˢᵖ xs)
≪fstˢᵖ (sndˢᵖ xs)   = sndˢᵖ (≪fstˢᵖ xs)

≪sndˢᵖ : ∀ {A B C Γ} → Γ ⊢ˢᵖ C ⦙ A ∧ B → Γ ⊢ˢᵖ C ⦙ B
≪sndˢᵖ nilˢᵖ        = sndˢᵖ nilˢᵖ
≪sndˢᵖ (appˢᵖ xs u) = appˢᵖ (≪sndˢᵖ xs) u
≪sndˢᵖ (fstˢᵖ xs)   = fstˢᵖ (≪sndˢᵖ xs)
≪sndˢᵖ (sndˢᵖ xs)   = sndˢᵖ (≪sndˢᵖ xs)

-- Derived neutrals.

varⁿᵉ : ∀ {A Γ} → A ∈ Γ → Γ ⊢ⁿᵉ A
varⁿᵉ i = spⁿᵉ i nilˢᵖ

appⁿᵉ : ∀ {A B Γ} → Γ ⊢ⁿᵉ A ▻ B → Γ ⊢ⁿᶠ A → Γ ⊢ⁿᵉ B
appⁿᵉ (spⁿᵉ i xs) t = spⁿᵉ i (≪appˢᵖ xs t)

fstⁿᵉ : ∀ {A B Γ} → Γ ⊢ⁿᵉ A ∧ B → Γ ⊢ⁿᵉ A
fstⁿᵉ (spⁿᵉ i xs) = spⁿᵉ i (≪fstˢᵖ xs)

sndⁿᵉ : ∀ {A B Γ} → Γ ⊢ⁿᵉ A ∧ B → Γ ⊢ⁿᵉ B
sndⁿᵉ (spⁿᵉ i xs) = spⁿᵉ i (≪sndˢᵖ xs)

-- Iterated expansion.

expand : ∀ {A Γ} → Γ ⊢ⁿᵉ A → Γ ⊢ⁿᶠ A
expand {α P}   t = neⁿᶠ t
expand {A ▻ B} t = lamⁿᶠ (expand (appⁿᵉ (mono⊢ⁿᵉ weak⊆ t) (expand (varⁿᵉ top))))
expand {A ∧ B} t = pairⁿᶠ (expand (fstⁿᵉ t)) (expand (sndⁿᵉ t))
expand {⊤}    t = unitⁿᶠ

-- Expansion-based normal forms.

varⁿᶠ : ∀ {A Γ} → A ∈ Γ → Γ ⊢ⁿᶠ A
varⁿᶠ i = expand (varⁿᵉ i)

-- Translation from simple terms to normal forms.

tm→nf : ∀ {A Γ} → Γ ⊢ A → Γ ⊢ⁿᶠ A
tm→nf (var i)    = varⁿᶠ i
tm→nf (lam t)    = lamⁿᶠ (tm→nf t)
tm→nf (app t u)  = appⁿᶠ (tm→nf t) (tm→nf u)
tm→nf (pair t u) = pairⁿᶠ (tm→nf t) (tm→nf u)
tm→nf (fst t)    = fstⁿᶠ (tm→nf t)
tm→nf (snd t)    = sndⁿᶠ (tm→nf t)
tm→nf unit       = unitⁿᶠ

-- Normalisation by hereditary substitution.

norm : ∀ {A Γ} → Γ ⊢ A → Γ ⊢ A
norm = nf→tm ∘ tm→nf


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

open import HoTT

module cohomology.WithCoefficients where

→Ω-group-structure : ∀ {i j} (X : Ptd i) (Y : Ptd j)
  → GroupStructure (fst (X ⊙→ ⊙Ω Y))
→Ω-group-structure X Y = record {
  ident = ⊙cst;
  inv = λ F → ((! ∘ fst F) , ap ! (snd F));
  comp = λ F G → ⊙conc ⊙∘ ⊙×-in F G;
  unitl = λ G → pair= idp (unitl-lemma (snd G));
  unitr = λ F → ⊙λ= (∙-unit-r ∘ fst F) (unitr-lemma (snd F));
  assoc = λ F G H → ⊙λ=
    (λ x → ∙-assoc (fst F x) (fst G x) (fst H x))
    (assoc-lemma (snd F) (snd G) (snd H));
  invl = λ F → ⊙λ= (!-inv-l ∘ fst F) (invl-lemma (snd F));
  invr = λ F → ⊙λ= (!-inv-r ∘ fst F) (invr-lemma (snd F))}
  where
  unitl-lemma : ∀ {i} {A : Type i} {x : A} {p : x == x} (α : p == idp)
    → ap (uncurry _∙_) (ap2 _,_ idp α) ∙ idp == α
  unitl-lemma idp = idp

  unitr-lemma : ∀ {i} {A : Type i} {x : A} {p : x == x} (α : p == idp)
    → ap (uncurry _∙_) (ap2 _,_ α idp) ∙ idp == ∙-unit-r p ∙ α
  unitr-lemma idp = idp

  assoc-lemma : ∀ {i} {A : Type i} {x : A} {p q r : x == x}
    (α : p == idp) (β : q == idp) (γ : r == idp)
    → ap (uncurry _∙_) (ap2 _,_ (ap (uncurry _∙_) (ap2 _,_ α β) ∙ idp) γ) ∙ idp
      == ∙-assoc p q r
         ∙ ap (uncurry _∙_) (ap2 _,_ α (ap (uncurry _∙_) (ap2 _,_ β γ) ∙ idp)) ∙ idp
  assoc-lemma idp idp idp = idp

  invl-lemma : ∀ {i} {A : Type i} {x : A} {p : x == x} (α : p == idp)
    → ap (uncurry _∙_) (ap2 _,_ (ap ! α) α) ∙ idp == !-inv-l p ∙ idp
  invl-lemma idp = idp

  invr-lemma : ∀ {i} {A : Type i} {x : A} {p : x == x} (α : p == idp)
    → ap (uncurry _∙_) (ap2 _,_ α (ap ! α)) ∙ idp == !-inv-r p ∙ idp
  invr-lemma idp = idp

→Ω-group : ∀ {i j} (X : Ptd i) (Y : Ptd j) → Group (lmax i j)
→Ω-group X Y = Trunc-group (→Ω-group-structure X Y)

{- →Ω-group is functorial in the first argument -}

→Ω-group-dom-act : ∀ {i j k} {X : Ptd i} {Y : Ptd j}
  (f : fst (X ⊙→ Y)) (Z : Ptd k)
  → (→Ω-group Y Z →ᴳ →Ω-group X Z)
→Ω-group-dom-act {Y = Y} f Z =
  Trunc-group-hom (λ g → g ⊙∘ f)
    (λ g₁ g₂ → ⊙∘-assoc ⊙conc (⊙×-in g₁ g₂) f
               ∙ ap (λ w → ⊙conc ⊙∘ w) (⊙×-in-pre∘ g₁ g₂ f))

→Ω-group-dom-idf : ∀ {i j} {X : Ptd i} (Y : Ptd j)
  → →Ω-group-dom-act (⊙idf X) Y == idhom (→Ω-group X Y)
→Ω-group-dom-idf Y = hom= _ _ $ λ= $ Trunc-elim
  (λ _ → =-preserves-level _ Trunc-level) (λ _ → idp)

→Ω-group-dom-∘ : ∀ {i j k l} {X : Ptd i} {Y : Ptd j} {Z : Ptd k}
  (g : fst (Y ⊙→ Z)) (f : fst (X ⊙→ Y)) (W : Ptd l)
  → →Ω-group-dom-act (g ⊙∘ f) W
    == →Ω-group-dom-act f W ∘ᴳ →Ω-group-dom-act g W
→Ω-group-dom-∘ g f W = hom= _ _ $ λ= $
  Trunc-elim (λ _ → =-preserves-level _ Trunc-level)
    (λ h → ap [_] (! (⊙∘-assoc h g f)))

{- Pointed maps out of bool -}

Bool⊙→-out : ∀ {i} {X : Ptd i}
  → fst (⊙Lift {j = i} ⊙Bool ⊙→ X) → fst X
Bool⊙→-out (h , _) = h (lift false)

Bool⊙→-equiv : ∀ {i} (X : Ptd i)
  → fst (⊙Lift {j = i} ⊙Bool ⊙→ X) ≃ fst X
Bool⊙→-equiv {i} X = equiv Bool⊙→-out g f-g g-f
  where
  g : fst X → fst (⊙Lift {j = i} ⊙Bool ⊙→ X)
  g x = ((λ {(lift b) → if b then snd X else x}) , idp)

  f-g : ∀ x → Bool⊙→-out (g x) == x
  f-g x = idp

  g-f : ∀ H → g (Bool⊙→-out H) == H
  g-f (h , hpt) = pair=
    (λ= lemma)
    (↓-app=cst-in $
      idp
        =⟨ ! (!-inv-l hpt) ⟩
      ! hpt ∙ hpt
        =⟨ ! (app=-β lemma (lift true)) |in-ctx (λ w → w ∙ hpt) ⟩
      app= (λ= lemma) (lift true) ∙ hpt ∎)
    where lemma : ∀ b → fst (g (h (lift false))) b == h b
          lemma (lift true) = ! hpt
          lemma (lift false) = idp

abstract
  Bool⊙→-path : ∀ {i} (X : Ptd i)
    → fst (⊙Lift {j = i} ⊙Bool ⊙→ X) == fst X
  Bool⊙→-path X = ua (Bool⊙→-equiv X)

abstract
  Bool⊙→Ω-is-π₁ : ∀ {i} (X : Ptd i)
    → →Ω-group (⊙Lift {j = i} ⊙Bool) X == πS 0 X
  Bool⊙→Ω-is-π₁ {i} X = group-ua $
    Trunc-group-iso Bool⊙→-out (λ _ _ → idp) (snd (Bool⊙→-equiv (⊙Ω X)))


-- There was a bug where reexported constructors weren't
-- properly translated when termination checking.
module OpenPublicTermination where

 module A where
   data U : Set where
     nat  : U
     list : U -> U

 module A' where
   open A public

 open A'

 f : U -> U
 f nat = nat
 f (list nat) = nat
 f (list (list u)) = f (list u)


module UninstantiatedDotPattern where

f : Set -> Set -> Set
f .X X = X


module InstanceArgumentsAmbiguous where

postulate A B : Set
          f : {{a : A}} → B
          a₁ a₂ : A

test : B
test = f


module Issue208 where

record R : Set where
  foo : Set
  foo = {!!}


module RandomAccessList.Standard.Properties where

open import BuildingBlock
open import BuildingBlock.BinaryLeafTree using (BinaryLeafTree; Node; Leaf)
import      BuildingBlock.BinaryLeafTree as BLT

open import RandomAccessList.Standard
open import RandomAccessList.Standard.Core
open import RandomAccessList.Standard.Core.Properties

open import Data.Nat
open import Data.Nat.Etc
open import Data.Nat.Properties.Simple
open import Data.Product as Prod
open import Data.Product hiding (map)
open import Data.Empty using (⊥-elim)
open import Function
open import Relation.Nullary using (Dec; yes; no; ¬_)
open import Relation.Nullary.Decidable using (False; True; fromWitnessFalse)
open import Relation.Nullary.Negation using (contraposition)

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

tailₙ-suc : ∀ {n A} → (xs : 0-1-RAL A n) → (p : ⟦ xs ⟧ ≢ 0)
           → suc ⟦ tailₙ xs p ⟧ₙ ≡ ⟦ xs ⟧ₙ
tailₙ-suc {n} {A} [] p = ⊥-elim (p (⟦[]⟧≡0 ([] {A} {n}) refl))
tailₙ-suc (  0∷ xs) p =
    begin
        2 + (2 * ⟦ tailₙ xs (⟦0∷xs⟧≢0⇒⟦xs⟧≢0 xs p) ⟧ₙ)
    ≡⟨ sym (+-*-suc 2 ⟦ tailₙ xs (⟦0∷xs⟧≢0⇒⟦xs⟧≢0 xs p) ⟧ₙ) ⟩
        2 * suc ⟦ tailₙ xs (⟦0∷xs⟧≢0⇒⟦xs⟧≢0 xs p) ⟧ₙ
    ≡⟨ cong (_*_ 2) (tailₙ-suc xs (⟦0∷xs⟧≢0⇒⟦xs⟧≢0 xs p)) ⟩
        2 * ⟦ xs ⟧ₙ
    ∎
tailₙ-suc (x 1∷ xs) p = refl

tail-suc : ∀ {A} → (xs : 0-1-RAL A 0) → (p : ⟦ xs ⟧ ≢ 0)
          → suc ⟦ tail xs p ⟧ ≡ ⟦ xs ⟧
tail-suc {A} [] p = ⊥-elim (p (⟦[]⟧≡0 ([] {A} {0}) refl))
tail-suc (0∷ xs) p =
    begin
        2 + (2 * ⟦ tailₙ xs (⟦0∷xs⟧≢0⇒⟦xs⟧≢0 xs p) ⟧ₙ + 0)
    ≡⟨ sym (+-assoc 2 (2 * ⟦ tailₙ xs (⟦0∷xs⟧≢0⇒⟦xs⟧≢0 xs p) ⟧ₙ) 0)  ⟩
        2 + 2 * ⟦ tailₙ xs (⟦0∷xs⟧≢0⇒⟦xs⟧≢0 xs p) ⟧ₙ + 0
    ≡⟨ cong (λ x → x + 0) (sym (+-*-suc 2 ⟦ tailₙ xs (⟦0∷xs⟧≢0⇒⟦xs⟧≢0 xs p) ⟧ₙ)) ⟩
        2 * suc ⟦ tailₙ xs (⟦0∷xs⟧≢0⇒⟦xs⟧≢0 xs p) ⟧ₙ + 0
    ≡⟨ cong (λ x → 2 * x + 0) (tailₙ-suc xs (⟦0∷xs⟧≢0⇒⟦xs⟧≢0 xs p)) ⟩
        2 * ⟦ xs ⟧ₙ + 0
    ∎
tail-suc (x 1∷ xs) p = refl

headₙ-tailₙ-consₙ : ∀ {n A} → (xs : 0-1-RAL A n) → (p : ⟦ xs ⟧ ≢ 0)
                 → consₙ (headₙ xs p) (tailₙ xs p) ≡ xs
headₙ-tailₙ-consₙ {n} {A} [] p = ⊥-elim (p (⟦[]⟧≡0 ([] {A} {n}) refl))
headₙ-tailₙ-consₙ (0∷ xs) p = let p' = contraposition (trans (⟦0∷xs⟧≡⟦xs⟧ xs)) p in
    begin
        consₙ (headₙ (0∷ xs) p) (tailₙ (0∷ xs) p)
    ≡⟨ refl ⟩
        consₙ (proj₁ (BLT.split (headₙ xs p'))) ((proj₂ (BLT.split (headₙ xs p'))) 1∷ tailₙ xs p')
    ≡⟨ refl ⟩
        0∷ (consₙ (Node ((proj₁ (BLT.split (headₙ xs p')))) ((proj₂ (BLT.split (headₙ xs p'))))) (tailₙ xs p'))
    ≡⟨ cong (λ x → 0∷ consₙ x (tailₙ xs p')) (BLT.split-merge (headₙ xs p')) ⟩
        0∷ consₙ (headₙ xs (p')) (tailₙ xs p')
    ≡⟨ cong 0∷_ (headₙ-tailₙ-consₙ xs p') ⟩
        0∷ xs
    ∎
headₙ-tailₙ-consₙ (x 1∷ xs) p = refl

head-tail-cons : ∀ {A} → (xs : 0-1-RAL A 0) → (p : ⟦ xs ⟧ ≢ 0)
               → cons (head xs p) (tail xs p) ≡ xs
head-tail-cons {A} [] p = ⊥-elim (p (⟦[]⟧≡0 ([] {A} {0}) refl))
head-tail-cons (0∷ xs) p = let p' = contraposition (trans (⟦0∷xs⟧≡⟦xs⟧ xs)) p in
    begin
        cons (head (0∷ xs) p) (tail (0∷ xs) p)
    ≡⟨ cong (λ x → consₙ x (proj₂ (BLT.split (headₙ xs p')) 1∷ tailₙ xs p')) (lemma (proj₁ (BLT.split (headₙ xs p')))) ⟩
        0∷ consₙ (Node (proj₁ (BLT.split (headₙ xs p'))) (proj₂ (BLT.split (headₙ xs p')))) (tailₙ xs p')
    ≡⟨ cong (λ x → 0∷ consₙ x (tailₙ xs p')) (BLT.split-merge (headₙ xs p')) ⟩
        0∷ consₙ (headₙ xs p') (tailₙ xs p')
    ≡⟨ cong 0∷_ (headₙ-tailₙ-consₙ xs p') ⟩
        0∷ xs
    ∎
    where
        lemma : ∀ {A} → (xs : BinaryLeafTree A 0) → Leaf (BLT.head xs) ≡ xs
        lemma (Leaf x) = refl
head-tail-cons (Leaf x 1∷ xs) p = refl

{-
    begin
        {!   !}
    ≡⟨ {!   !} ⟩
        {!   !}
    ≡⟨ {!   !} ⟩
        {!   !}
    ≡⟨ {!   !} ⟩
        {!   !}
    ≡⟨ {!   !} ⟩
        {!   !}
    ∎
-}


{-# OPTIONS --without-K --safe #-}
-- https://www.cs.bham.ac.uk/~mhe/papers/omniscient-journal-revised.pdf

module Constructive.OmniscienceAlt where

open import Level renaming (zero to lzero; suc to lsuc)
import Data.Bool as 𝔹 using (_≤_)
open import Data.Bool as 𝔹 using (Bool; true; false; T; f≤t; b≤b; _∧_; not; _∨_)
import Data.Bool.Properties as 𝔹ₚ
open import Data.Empty
open import Data.Unit using (tt)
open import Data.Nat
open import Data.Nat.Properties
open import Data.Product as Prod
open import Data.Sum as Sum
open import Function.Base
open import Relation.Binary as B
open import Relation.Binary.PropositionalEquality
open import Relation.Nullary
open import Relation.Nullary.Decidable
import Relation.Unary as U

-- agda-misc
open import Constructive.Axiom
open import Constructive.Axiom.Properties
open import Constructive.Axiom.Properties.Base.Lemma
open import Constructive.Common
open import Constructive.Combinators

ℕ∞ : Set
ℕ∞ = Σ (ℕ → Bool) λ x → ∀ i → T (x i) → T (x (suc i))

fromℕ-C : ℕ → ℕ → Bool
fromℕ-C zero    zero    = false
fromℕ-C zero    (suc n) = true
fromℕ-C (suc m) zero    = false
fromℕ-C (suc m) (suc n) = fromℕ-C m n

fromℕ-convergent : ∀ n i → T (fromℕ-C n i) → T (fromℕ-C n (suc i))
fromℕ-convergent zero    (suc i) t = tt
fromℕ-convergent (suc n) (suc i) t = fromℕ-convergent n i t

fromℕ : ℕ → ℕ∞
fromℕ n = fromℕ-C n , fromℕ-convergent n

∞ : ℕ∞
∞ = (λ _ → false) , (λ i x → x)

_≈_ : Rel (ℕ → Bool) lzero
α ≈ β = ∀ i → α i ≡ β i

_≉_ : Rel (ℕ → Bool) lzero
α ≉ β = ¬ (α ≈ β)

_#_ : Rel (ℕ → Bool) lzero
α # β = ∃ λ i → α i ≢ β i

#⇒≉  : {α β : ℕ → Bool} → α # β → α ≉ β
#⇒≉ {α} {β} (i , αi≢βi) α≈β = αi≢βi (α≈β i)

≈-refl : {α : ℕ → Bool} → α ≈ α
≈-refl _ = refl

≈-sym : {α β : ℕ → Bool} → α ≈ β → β ≈ α
≈-sym α≈β i = sym (α≈β i)

≈-trans : {α β γ : ℕ → Bool} → α ≈ β → β ≈ γ → α ≈ γ
≈-trans α≈β β≈γ i = trans (α≈β i) (β≈γ i)

_≈∞_ : Rel ℕ∞ lzero
x ≈∞ y = proj₁ x ≈ proj₁ y

_≉∞_ : Rel ℕ∞ lzero
x ≉∞ y = proj₁ x ≉ proj₁ y

_#∞_ : Rel ℕ∞ lzero
x #∞ y = proj₁ x # proj₁ y

-- Proposition 3.1
-- r = ≤-any

≤-any : (ℕ → Bool) → (ℕ → Bool)
≤-any α zero    = α 0
≤-any α (suc n) = α (suc n) ∨ ≤-any α n

≤-any-idem : ∀ α → ≤-any (≤-any α) ≈ ≤-any α
≤-any-idem α zero    = refl
≤-any-idem α (suc n) = begin
  (α (suc n) ∨ ≤-any α n) ∨ ≤-any (≤-any α) n
    ≡⟨ cong ((α (suc n) ∨ ≤-any α n) ∨_) $ ≤-any-idem α n ⟩
  (α (suc n) ∨ ≤-any α n) ∨ ≤-any α n
    ≡⟨ 𝔹ₚ.∨-assoc (α (suc n)) (≤-any α n) (≤-any α n) ⟩
  α (suc n) ∨ (≤-any α n ∨ ≤-any α n)
    ≡⟨ cong (α (suc n) ∨_) $ 𝔹ₚ.∨-idem (≤-any α n) ⟩
  α (suc n) ∨ ≤-any α n
    ∎
  where open ≡-Reasoning

private
  T-∧-× : ∀ {x y} → T (x ∧ y) → (T x × T y)
  T-∧-× {true} {true} t = tt , tt

  T-×-∧ : ∀ {x y} → (T x × T y) → T (x ∧ y)
  T-×-∧ {true} {true} (tt , tt) = tt

  T-∨-introʳ : ∀ {x y} → T y → T (x ∨ y)
  T-∨-introʳ {true} {true} t = tt
  T-∨-introʳ {false} {true} t = tt

  T-∨-introˡ : ∀ {x y} → T x → T (x ∨ y)
  T-∨-introˡ {true} {true} t = tt
  T-∨-introˡ {true} {false} t = tt

≤-any-convergent : ∀ α i → T (≤-any α i) → T (≤-any α (suc i))
≤-any-convergent α n t = T-∨-introʳ t

≤-any-ℕ∞ : (ℕ → Bool) → ℕ∞
≤-any-ℕ∞ α = ≤-any α , ≤-any-convergent α

≤-any-construct : ∀ α n → T (α n) → T (≤-any α n)
≤-any-construct α zero    t = t
≤-any-construct α (suc n) t = T-∨-introˡ t

private
  not-injective : ∀ {x y} → not x ≡ not y → x ≡ y
  not-injective {false} {false} refl = refl
  not-injective {true}  {true}  refl = refl

  x≢y⇒not[x]≡y : ∀ {x y} → x ≢ y → not x ≡ y
  x≢y⇒not[x]≡y {false} {false} x≢y = contradiction refl x≢y
  x≢y⇒not[x]≡y {false} {true} x≢y = refl
  x≢y⇒not[x]≡y {true} {false} x≢y = refl
  x≢y⇒not[x]≡y {true} {true} x≢y = contradiction refl x≢y

  x≢y⇒x≡not[y] : ∀ {x y} → x ≢ y → x ≡ not y
  x≢y⇒x≡not[y] {x} {y} x≢y = subst (_≡ not y) (𝔹ₚ.not-involutive x) $
                             x≢y⇒not[x]≡y {not x} {not y} (x≢y ∘′ not-injective)

  x≡y⇒not[x]≢y : ∀ {x y} → x ≡ y → not x ≢ y
  x≡y⇒not[x]≢y {false} {false} p ()
  x≡y⇒not[x]≢y {false} {true} () q
  x≡y⇒not[x]≢y {true} {false} () q
  x≡y⇒not[x]≢y {true} {true} p ()

  not[x]≡true→x≢true : ∀ {x} → not x ≡ true → x ≢ true
  not[x]≡true→x≢true {false} refl ()
  not[x]≡true→x≢true {true}  ()   p

  false≢true : false ≢ true
  false≢true ()

lpo-Bool⇒∀x→x#∞⊎x≈∞ : LPO-Bool ℕ → ∀ x → (x #∞ ∞) ⊎ (x ≈∞ ∞)
lpo-Bool⇒∀x→x#∞⊎x≈∞ lpo-Bool (α , con) with lpo-Bool α
... | inj₁ (x , αx≡true) = inj₁ (x , λ αx≡false → false≢true (trans (sym αx≡false) αx≡true))
... | inj₂ ¬∃x→αx≡true   = inj₂ λ i →  x≢y⇒x≡not[y] $′ ¬∃P→∀¬P ¬∃x→αx≡true i

T-to-≡ : ∀ {x} → T x → x ≡ true
T-to-≡ {true} tx = refl

≡-to-T : ∀ {x} → x ≡ true → T x
≡-to-T {true} x≡true = tt

private
  T-¬-not : ∀ {x} → ¬ (T x) → T (not x)
  T-¬-not {false} n = tt
  T-¬-not {true}  n = n tt

  T-not-¬ : ∀ {x} → T (not x) → ¬ (T x)
  T-not-¬ {false} tt ()
  T-not-¬ {true}  () y

¬T-≤-any : ∀ α x → ¬ T (≤-any α x) → ∃ λ y → ¬ T (α y)
¬T-≤-any α zero    ¬T with α 0 | inspect α 0
... | true  | [ α0≡true ]  = contradiction tt ¬T
... | false | [ α0≡false ] = zero , (λ T[α0] → subst T α0≡false T[α0])
¬T-≤-any α (suc x) ¬T with α (suc x) | inspect α (suc x)
... | true  | [ αsn≡true ] = ¬T-≤-any α x ¬T
... | false | [ αsn≡false ] = (suc x) , (λ T[αsn] → subst T αsn≡false T[αsn])
{-
¬T-≤-any′ : ∀ α x → ¬ T (≤-any (not ∘′ α) x) → ∃ λ y → T (α y)
¬T-≤-any′ α x ¬T =
  Prod.map₂ (λ nt → subst T (𝔹ₚ.not-involutive _) (T-¬-not nt)) $′
  ¬T-≤-any (not ∘ α) x ¬T

∀x→x#∞⊎x≈∞⇒lpo-Bool : (∀ x → (x #∞ ∞) ⊎ (x ≈∞ ∞)) → LPO-Bool ℕ
∀x→x#∞⊎x≈∞⇒lpo-Bool ≈∞? P with ≈∞? (≤-any-ℕ∞ (λ n → not (P n)))
... | inj₁ (x , ≤-any[not∘P,x]≢true) =
  inj₁ (Prod.map₂ T-to-≡ (¬T-≤-any′ P x (contraposition T-to-≡ ≤-any[not∘P,x]≢true)))
... | inj₂ ∀i→≤-any[not∘P,i]≡true =
  inj₂ (∀¬P→¬∃P λ i → not[x]≡true→x≢true (T-to-≡ $ ≤-any-extract (not ∘ P) i $ ≡-to-T (∀i→≤-any[not∘P,i]≡true i)))

--  ≤-any (λ n → not (P n)) x ≡ true → ⊥
-- ≤-any (not ∘ P) x ≡ false
--
--  ---------------------------
--  T (≤-any P x)
-}


-- Instances of Gaussian integers.

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

module GauInt.Instances where

open import Data.Integer using (+_ ; -[1+_] ; +[1+_])
open import Data.Nat using (suc )

open import Instances
open import GauInt.Base renaming (-_ to -𝔾_ ; _-_ to _-𝔾_ ; _+_ to _+𝔾_ ; _*_ to _*𝔾_ ; NonZero to NonZero𝔾 ; rank to rank𝔾)

-- Instances to overload operations.
instance
  sr𝔾 : SemiRing 𝔾
  _+_ {{sr𝔾}} = _+𝔾_
  _*_ {{sr𝔾}} = _*𝔾_
  0# {{sr𝔾}} = 0𝔾
  1# {{sr𝔾}} = 1𝔾

instance
  ring𝔾 : Ring 𝔾
  ring𝔾 .sra = sr𝔾
  ring𝔾 .-_ = -𝔾_

instance
  Rank𝔾 : Rank 𝔾
  Rank𝔾 .rank = rank𝔾

-- This depends on how the boolean equality on 𝔾 is defined. To be
-- precise, it depends on the order of comparing the components.
instance
  nzp : ∀ {n} {y} -> NonZero𝔾 (+ suc n + y i)
  nzp = _

  nzn : ∀ {n} {y} -> NonZero𝔾 (-[1+ n ] + y i)
  nzn = _

  nzpi : ∀ {n} -> NonZero𝔾 (0# + (+ suc n) i)
  nzpi = _

  nzni : ∀ {n} -> NonZero𝔾 (0# + (-[1+ n ]) i)
  nzni = _

instance
  NZT𝔾 : NonZeroTypeclass 𝔾
  NZT𝔾 .NonZero = NonZero𝔾

{-

-- Translation from NonZero predicate to non-equality.
test-t : ∀ (x : 𝔾) -> .{{NonZero x}} -> ¬ x ≡ 0#
test-t (+_ zero + +[1+ n ] i) = λ {()}
test-t (+_ zero + -[1+_] n i) = λ {()}
test-t (+[1+ n ] + x₁ i) = λ {()}
test-t (-[1+_] n + x₁ i) = λ {()}

open import Relation.Binary.Structures
open IsDecEquivalence {{...}}
open IsDecTotalOrder {{...}}
open import Data.Nat.Instances
open import Data.Integer.Instances
test : {!!}
test = 0ℤ ≤? 0ℤ

-}


module functor where

open import level

record Functor {ℓ : Level} (F : Set ℓ → Set ℓ) : Set (lsuc ℓ) where
  constructor mkFunc
  field
    fmap : ∀{A B : Set ℓ} → (A → B) → F A → F B

open Functor public


------------------------------------------------------------------------
-- From the Agda standard library
--
-- Sizes for Agda's sized types
------------------------------------------------------------------------

module Common.Size where

open import Agda.Builtin.Size public renaming (ω to ∞; SizeU to SizeUniv)


------------------------------------------------------------------------
-- The Agda standard library
--
-- Directed acyclic multigraphs
------------------------------------------------------------------------

-- A representation of DAGs, based on the idea underlying Martin
-- Erwig's FGL. Note that this representation does not aim to be
-- efficient.

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

module Data.Graph.Acyclic where

open import Level using (_⊔_)
open import Data.Nat.Base as Nat using (ℕ; zero; suc; _<′_)
import Data.Nat.Properties as Nat
open import Data.Fin as Fin
  using (Fin; Fin′; zero; suc; #_; toℕ; _≟_) renaming (_ℕ-ℕ_ to _-_)
import Data.Fin.Properties as FP
import Data.Fin.Permutation.Components as PC
open import Data.Product as Prod using (∃; _×_; _,_)
open import Data.Maybe.Base using (Maybe; nothing; just)
open import Data.Empty
open import Data.Unit.Base using (⊤; tt)
open import Data.Vec as Vec using (Vec; []; _∷_)
open import Data.List.Base as List using (List; []; _∷_)
open import Function
open import Induction.Nat using (<′-rec; <′-Rec)
open import Relation.Nullary
open import Relation.Binary.PropositionalEquality as P using (_≡_)

------------------------------------------------------------------------
-- A lemma

private

  lemma : ∀ n (i : Fin n) → n - suc i <′ n
  lemma zero    ()
  lemma (suc n) i  = Nat.≤⇒≤′ $ Nat.s≤s $ FP.nℕ-ℕi≤n n i

------------------------------------------------------------------------
-- Node contexts

record Context {ℓ e} (Node : Set ℓ) (Edge : Set e) (n : ℕ) : Set (ℓ ⊔ e) where
  constructor context
  field
    label      : Node
    successors : List (Edge × Fin n)

open Context public

-- Map for contexts.

module _ {ℓ₁ e₁} {N₁ : Set ℓ₁} {E₁ : Set e₁}
         {ℓ₂ e₂} {N₂ : Set ℓ₂} {E₂ : Set e₂} where

  cmap : ∀ {n} → (N₁ → N₂) → (List (E₁ × Fin n) → List (E₂ × Fin n)) →
         Context N₁ E₁ n → Context N₂ E₂ n
  cmap f g c = context (f (label c)) (g (successors c))

------------------------------------------------------------------------
-- Graphs

infixr 3 _&_

-- The DAGs are indexed on the number of nodes.

data Graph {ℓ e} (Node : Set ℓ) (Edge : Set e) : ℕ → Set (ℓ ⊔ e) where
  ∅   : Graph Node Edge 0
  _&_ : ∀ {n} (c : Context Node Edge n) (g : Graph Node Edge n) →
        Graph Node Edge (suc n)

private

  example : Graph ℕ ℕ 5
  example = context 0 [] &
            context 1 ((10 , # 1) ∷ (11 , # 1) ∷ []) &
            context 2 ((12 , # 0) ∷ []) &
            context 3 [] &
            context 4 [] &
            ∅

------------------------------------------------------------------------
-- Higher-order functions

module _ {ℓ e} {N : Set ℓ} {E : Set e} {t} where

-- "Fold right".

  foldr : (T : ℕ → Set t) →
          (∀ {n} → Context N E n → T n → T (suc n)) →
          T 0 →
          ∀ {m} → Graph N E m → T m
  foldr T _∙_ x ∅       = x
  foldr T _∙_ x (c & g) = c ∙ foldr T _∙_ x g

-- "Fold left".

  foldl : ∀ {n} (T : ℕ → Set t) →
          ((i : Fin n) → T (toℕ i) → Context N E (n - suc i) →
          T (suc (toℕ i))) →
          T 0 →
          Graph N E n → T n
  foldl T f x ∅       = x
  foldl T f x (c & g) = foldl (T ∘′ suc) (f ∘ suc) (f zero x c) g

module _ {ℓ₁ e₁} {N₁ : Set ℓ₁} {E₁ : Set e₁}
         {ℓ₂ e₂} {N₂ : Set ℓ₂} {E₂ : Set e₂} where

-- Maps over node contexts.

  map : (∀ {n} → Context N₁ E₁ n → Context N₂ E₂ n) →
        ∀ {n} → Graph N₁ E₁ n → Graph N₂ E₂ n
  map f = foldr _ (λ c → f c &_) ∅

-- Maps over node labels.

nmap : ∀ {ℓ₁ ℓ₂ e} {N₁ : Set ℓ₁} {N₂ : Set ℓ₂} {E : Set e} →
       ∀ {n} → (N₁ → N₂) → Graph N₁ E n → Graph N₂ E n
nmap f = map (cmap f id)

-- Maps over edge labels.

emap : ∀ {ℓ e₁ e₂} {N : Set ℓ} {E₁ : Set e₁} {E₂ : Set e₂} →
       ∀ {n} → (E₁ → E₂) → Graph N E₁ n → Graph N E₂ n
emap f = map (cmap id (List.map (Prod.map f id)))

-- Zips two graphs with the same number of nodes. Note that one of the
-- graphs has a type which restricts it to be completely disconnected.

zipWith : ∀ {ℓ₁ ℓ₂ ℓ e} {N₁ : Set ℓ₁} {N₂ : Set ℓ₂} {N : Set ℓ} {E : Set e} →
          ∀ {n} → (N₁ → N₂ → N) → Graph N₁ ⊥ n → Graph N₂ E n → Graph N E n
zipWith _∙_ ∅         ∅         = ∅
zipWith _∙_ (c₁ & g₁) (c₂ & g₂) =
  context (label c₁ ∙ label c₂) (successors c₂) & zipWith _∙_ g₁ g₂

------------------------------------------------------------------------
-- Specific graphs

-- A completeley disconnected graph.

disconnected : ∀ n → Graph ⊤ ⊥ n
disconnected zero    = ∅
disconnected (suc n) = context tt [] & disconnected n

-- A complete graph.

complete : ∀ n → Graph ⊤ ⊤ n
complete zero    = ∅
complete (suc n) =
  context tt (List.map (tt ,_) $ Vec.toList (Vec.allFin n)) &
  complete n

------------------------------------------------------------------------
-- Queries

module _ {ℓ e} {N : Set ℓ} {E : Set e} where

-- The top-most context.

  head : ∀ {n} → Graph N E (suc n) → Context N E n
  head (c & g) = c

-- The remaining graph.

  tail : ∀ {n} → Graph N E (suc n) → Graph N E n
  tail (c & g) = g

-- Finds the context and remaining graph corresponding to a given node
-- index.

  _[_] : ∀ {n} → Graph N E n → (i : Fin n) → Graph N E (suc (n - suc i))
  ∅       [ () ]
  (c & g) [ zero ]  = c & g
  (c & g) [ suc i ] = g [ i ]

-- The nodes of the graph (node number relative to "topmost" node ×
-- node label).

  nodes : ∀ {n} → Graph N E n → Vec (Fin n × N) n
  nodes = Vec.zip (Vec.allFin _) ∘
          foldr (Vec N) (λ c → label c ∷_) []

private

  test-nodes : nodes example ≡ (# 0 , 0) ∷ (# 1 , 1) ∷ (# 2 , 2) ∷
                               (# 3 , 3) ∷ (# 4 , 4) ∷ []
  test-nodes = P.refl

module _ {ℓ e} {N : Set ℓ} {E : Set e} where

-- Topological sort. Gives a vector where earlier nodes are never
-- successors of later nodes.

  topSort : ∀ {n} → Graph N E n → Vec (Fin n × N) n
  topSort = nodes

-- The edges of the graph (predecessor × edge label × successor).
--
-- The predecessor is a node number relative to the "topmost" node in
-- the graph, and the successor is a node number relative to the
-- predecessor.

  edges : ∀ {n} → Graph N E n → List (∃ λ i → E × Fin (n - suc i))
  edges {n} =
    foldl (λ _ → List (∃ λ i → E × Fin (n - suc i)))
          (λ i es c → es List.++ List.map (i ,_) (successors c))
          []

private

  test-edges : edges example ≡ (# 1 , 10 , # 1) ∷ (# 1 , 11 , # 1) ∷
                               (# 2 , 12 , # 0) ∷ []
  test-edges = P.refl

-- The successors of a given node i (edge label × node number relative
-- to i).

sucs : ∀ {ℓ e} {N : Set ℓ} {E : Set e} →
       ∀ {n} → Graph N E n → (i : Fin n) → List (E × Fin (n - suc i))
sucs g i = successors $ head (g [ i ])

private

  test-sucs : sucs example (# 1) ≡ (10 , # 1) ∷ (11 , # 1) ∷ []
  test-sucs = P.refl

-- The predecessors of a given node i (node number relative to i ×
-- edge label).

preds : ∀ {ℓ e} {N : Set ℓ} {E : Set e} →
        ∀ {n} → Graph N E n → (i : Fin n) → List (Fin′ i × E)
preds g       zero    = []
preds (c & g) (suc i) =
  List._++_ (List.mapMaybe (p i) $ successors c)
            (List.map (Prod.map suc id) $ preds g i)
  where
  p : ∀ {e} {E : Set e} {n} (i : Fin n) → E × Fin n → Maybe (Fin′ (suc i) × E)
  p i (e , j)  with i ≟ j
  p i (e , .i) | yes P.refl = just (zero , e)
  p i (e , j)  | no _       = nothing

private

  test-preds : preds example (# 3) ≡
               (# 1 , 10) ∷ (# 1 , 11) ∷ (# 2 , 12) ∷ []
  test-preds = P.refl

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

-- Weakens a node label.

weaken : ∀ {n} {i : Fin n} → Fin (n - suc i) → Fin n
weaken {n} {i} j = Fin.inject≤ j (FP.nℕ-ℕi≤n n (suc i))

-- Labels each node with its node number.

number : ∀ {ℓ e} {N : Set ℓ} {E : Set e} →
         ∀ {n} → Graph N E n → Graph (Fin n × N) E n
number {N = N} {E} =
  foldr (λ n → Graph (Fin n × N) E n)
        (λ c g → cmap (zero ,_) id c & nmap (Prod.map suc id) g)
        ∅

private

  test-number : number example ≡
                (context (# 0 , 0) [] &
                 context (# 1 , 1) ((10 , # 1) ∷ (11 , # 1) ∷ []) &
                 context (# 2 , 2) ((12 , # 0) ∷ []) &
                 context (# 3 , 3) [] &
                 context (# 4 , 4) [] &
                 ∅)
  test-number = P.refl

-- Reverses all the edges in the graph.

reverse : ∀ {ℓ e} {N : Set ℓ} {E : Set e} →
          ∀ {n} → Graph N E n → Graph N E n
reverse {N = N} {E} g =
  foldl (Graph N E)
        (λ i g' c →
           context (label c)
                   (List.map (Prod.swap ∘ Prod.map PC.reverse id) $
                             preds g i)
           & g')
        ∅ g

private

  test-reverse : reverse (reverse example) ≡ example
  test-reverse = P.refl

------------------------------------------------------------------------
-- Views

-- Expands the subgraph induced by a given node into a tree (thus
-- losing all sharing).

data Tree {ℓ e} (N : Set ℓ) (E : Set e) : Set (ℓ ⊔ e) where
  node : (label : N) (successors : List (E × Tree N E)) → Tree N E

module _ {ℓ e} {N : Set ℓ} {E : Set e} where

  toTree : ∀ {n} → Graph N E n → Fin n → Tree N E
  toTree g i = <′-rec Pred expand _ (g [ i ])
    where
    Pred = λ n → Graph N E (suc n) → Tree N E

    expand : (n : ℕ) → <′-Rec Pred n → Pred n
    expand n rec (c & g) =
      node (label c)
           (List.map
              (Prod.map id (λ i → rec (n - suc i) (lemma n i) (g [ i ])))
              (successors c))

-- Performs the toTree expansion once for each node.

  toForest : ∀ {n} → Graph N E n → Vec (Tree N E) n
  toForest g = Vec.map (toTree g) (Vec.allFin _)

private

  test-toForest : toForest example ≡
                    let n3 = node 3 [] in
                    node 0 [] ∷
                    node 1 ((10 , n3) ∷ (11 , n3) ∷ []) ∷
                    node 2 ((12 , n3) ∷ []) ∷
                    node 3 [] ∷
                    node 4 [] ∷
                    []
  test-toForest = P.refl


-- a hodge-podge of tests

module Test where

import Test.Class
import Test.EquivalenceExtensionṖroperty
import Test.EquivalenceṖroperty
import Test.EquivalentCandidates
import Test.EquivalentCandidates-2
import Test.Factsurj3
import Test.Functor -- FIXME doesn't work with open import Everything
import Test.ProblemWithDerivation
import Test.ProblemWithDerivation-2
import Test.ProblemWithDerivation-3
import Test.ProblemWithDerivation-4
import Test.ProblemWithDerivation-5
import Test.ProblemWithLevelZero
import Test.ProblemWithSym
import Test.ṖropertyFacts -- FIXME doesn't work with open import Everything
import Test.ṖropertyFactsSubstitunction
import Test.SubstitunctionPropId
import Test.Surjcollation -- FIXME remove commented import block?
import Test.Surjidentity
import Test.SurjidentityI
import Test.SurjidentityP
import Test.Symmetrical
import Test.SymmetricalSubstitunction
import Test.Test0
import Test.Test1
import Test.Test2
import Test.Test3
import Test.Test4
import Test.Test5
import Test.Test6
import Test.Test7
import Test.Thickandthin
import Test.Transassociativity
import Test.UnifiesSubstitunction
import Test.𝓢urjectivityWithOverlapping𝓢urjection


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

module Number.Prelude.QuoInt where

open import Cubical.HITs.Ints.QuoInt public using
  ( ℤ
  ; HasFromNat
  ; HasFromNeg
  ; Int≡ℤ
  ; signed
  ; posneg
  ; ℤ→Int
  ; sucℤ
  ; predℤ
  ; pos
  ; neg
  ; sucℤ-+ʳ
  ; Sign
  ; spos
  ; sneg
  ) renaming
  ( isSetℤ         to is-setᶻ
  ; _+_            to _+ᶻ_
  ; _*_            to _·ᶻ_
  ; -_             to infixl 6 -ᶻ_
  ; *-comm         to ·ᶻ-comm
  ; *-assoc        to ·ᶻ-assoc
  ; +-comm         to +ᶻ-comm
  ; +-assoc        to +ᶻ-assoc
  ; sign           to signᶻ
  ; abs            to absᶻ
  ; _*S_           to _·ˢ_
  )

open import Number.Instances.QuoInt public using
  ( ℤlattice
  ; ⊕-identityʳ
  ) renaming
  ( is-LinearlyOrderedCommRing to is-LinearlyOrderedCommRingᶻ
  ; min                    to minᶻ
  ; max                    to maxᶻ
  ; _<_                    to _<ᶻ_
  ; ·-reflects-<           to ·ᶻ-reflects-<ᶻ
  ; ·-reflects-<ˡ          to ·ᶻ-reflects-<ᶻˡ
  ; 0<1                    to 0<1
  ; +-reflects-<           to +ᶻ-reflects-<ᶻ
  ; +-preserves-<          to +ᶻ-preserves-<ᶻ
  ; +-creates-<            to +ᶻ-creates-<ᶻ
  ; suc-creates-<          to suc-creates-<ᶻ
  ; +-creates-≤            to +ᶻ-creates-≤ᶻ
  ; ·-creates-<            to ·ᶻ-creates-<ᶻ
  ; ·-creates-≤            to ·ᶻ-creates-≤ᶻ
  ; ·-creates-≤-≡          to ·ᶻ-creates-≤ᶻ-≡
  ; ·-creates-<ˡ-≡         to ·ᶻ-creates-<ᶻˡ-≡
  ; ·-creates-<-flippedˡ-≡ to ·ᶻ-creates-<ᶻ-flippedˡ-≡
  ; ·-creates-<-flippedʳ-≡ to ·ᶻ-creates-<ᶻ-flippedʳ-≡
  ; ≤-dicho                to ≤ᶻ-dicho
  ; ≤-min-+                to ≤ᶻ-minᶻ-+ᶻ
  ; ≤-max-+                to ≤ᶻ-maxᶻ-+ᶻ
  ; ≤-min-·                to ≤ᶻ-minᶻ-·ᶻ
  ; ≤-max-·                to ≤ᶻ-maxᶻ-·ᶻ
  ; +-min-distribʳ         to +ᶻ-minᶻ-distribʳ
  ; ·-min-distribʳ         to ·ᶻ-minᶻ-distribʳ
  ; +-max-distribʳ         to +ᶻ-maxᶻ-distribʳ
  ; ·-max-distribʳ         to ·ᶻ-maxᶻ-distribʳ
  ; +-min-distribˡ         to +ᶻ-minᶻ-distribˡ
  ; ·-min-distribˡ         to ·ᶻ-minᶻ-distribˡ
  ; +-max-distribˡ         to +ᶻ-maxᶻ-distribˡ
  ; ·-max-distribˡ         to ·ᶻ-maxᶻ-distribˡ
  ; pos<pos[suc]           to pos<ᶻpos[suc]
  ; 0<ᶻpos[suc]            to 0<ᶻpos[suc]
  ; ·-nullifiesˡ           to ·ᶻ-nullifiesˡ
  ; ·-nullifiesʳ           to ·ᶻ-nullifiesʳ
  ; ·-preserves-0<         to ·ᶻ-preserves-0<ᶻ
  ; ·-reflects-0<          to ·ᶻ-reflects-0<ᶻ
  ; ·-creates-<-≡          to ·ᶻ-creates-<ᶻ-≡
  ; -flips-<0              to -flips-<ᶻ0
  ; -flips-<               to -ᶻ-flips-<ᶻ
  ; -identity-·            to -ᶻ-identity-·ᶻ
  ; -distˡ                 to -ᶻ-distˡ
  ; ·-reflects-<-flippedˡ  to ·ᶻ-reflects-<ᶻ-flippedˡ
  ; ·-reflects-<-flippedʳ  to ·ᶻ-reflects-<ᶻ-flippedʳ
  ; #-dicho                to #ᶻ-dicho
  ; ·-preserves-signˡ      to ·ᶻ-preserves-signᶻˡ
  ; #⇒≢                    to #ᶻ⇒≢
  ; <-split-pos            to <ᶻ-split-pos
  ; <-split-neg            to <ᶻ-split-neg
  ; <0-sign                to <ᶻ0-signᶻ
  ; 0<-sign                to 0<ᶻ-signᶻ
  ; sign-pos               to signᶻ-pos
  ; ·-reflects-≡ˡ          to ·ᶻ-reflects-≡ˡ
  ; ·-reflects-≡ʳ          to ·ᶻ-reflects-≡ʳ
  )

open import Number.Structures2
open IsLinearlyOrderedCommRing is-LinearlyOrderedCommRingᶻ public using () renaming
  ( _-_           to _-ᶻ_
  -- ; is-LinearlyOrderedCommSemiring to is-LinearlyOrderedCommSemiringᶻ
  ; _≤_           to _≤ᶻ_      -- NOTE: somehow this get an ugly prefix turning `0 ≤ᶻ aᶻ` into `(is-LinearlyOrderedCommSemiringᶻ IsLinearlyOrderedCommSemiring.≤ pos 0) aⁿᶻ`
  ; _#_           to _#ᶻ_      --       but some-other-how _#ᶻ_ works fine ... ?
  ; <-irrefl      to <ᶻ-irrefl --       turns out that this was due to `p = [ 0 ≤ᶻ aⁿᶻ ] ∋ is-0≤ⁿᶻ` instead of `p : [ 0 ≤ᶻ aⁿᶻ ]; p = is-0≤ⁿᶻ`
  ; <-trans       to <ᶻ-trans
  ; +-<-ext       to +ᶻ-<ᶻ-ext
  ; +-rinv        to +ᶻ-rinv
  ; +-identity    to +ᶻ-identity
  ; ·-preserves-< to ·ᶻ-preserves-<ᶻ
  ; <-tricho      to <ᶻ-tricho
  ; <-asym        to <ᶻ-asym
  ; ·-identity    to ·ᶻ-identity
  ; is-min        to is-minᶻ
  ; is-max        to is-maxᶻ
  ; is-dist       to is-distᶻ
  )

-- open IsLinearlyOrderedCommSemiring is-LinearlyOrderedCommSemiringᶻ public using () renaming
--   ( _≤_           to _≤ᶻ_ )

open import MorePropAlgebra.Properties.Lattice ℤlattice
open OnSet is-setᶻ public using () renaming
  ( min-≤              to minᶻ-≤ᶻ
  ; max-≤              to maxᶻ-≤ᶻ
  ; ≤-reflectsʳ-≡      to ≤ᶻ-reflectsʳ-≡
  ; ≤-reflectsˡ-≡      to ≤ᶻ-reflectsˡ-≡
  ; min-identity       to minᶻ-identity
  ; min-identity-≤     to minᶻ-identity-≤ᶻ
  ; max-identity-≤     to maxᶻ-identity-≤ᶻ
  ; min-comm           to minᶻ-comm
  ; min-assoc          to minᶻ-assoc
  ; max-identity       to maxᶻ-identity
  ; max-comm           to maxᶻ-comm
  ; max-assoc          to maxᶻ-assoc
  ; min-max-absorptive to minᶻ-maxᶻ-absorptive
  ; max-min-absorptive to maxᶻ-minᶻ-absorptive
  )


open import Agda.Builtin.Equality
open import Agda.Builtin.Nat

data ⊥ : Set where

data Zero : Set where
  zero : Zero

data One : Set where
  suc : Zero → One

one : One
one = suc zero

data _≤_ : One → Zero → Set where

leq : ∀ m n → Nat → Nat → m ≤ n → ⊥
leq (suc m) zero = λ i j ()

test : Nat → one ≤ zero → ⊥
test = leq one zero 5

-- Normalise: test
-- Expected:  λ j ()


module TruthValue where

open import OscarPrelude

record TruthValue : Set
 where
  constructor ⟨_⟩
  field
    truthValue : Bool

open TruthValue public


-- Andreas, 2019-05-30, issue #3823
-- Named where module M should be in scope in rhs.
-- This enables to use it in expressions like record{M}.

open import Agda.Builtin.Equality

record R : Set₂ where
  field
    A : Set₁

r : R
r = record {M}
  module M where
    A = Set

-- ERROR WAS:
-- No module M in scope
-- when scope checking record { M }

test : r ≡ record {A = Set}
test = refl

-- Should succeed.

-- Should also work with module parameters.

s : Set₁ → R
s B = record {L}
  module L where
    A = B

-- With rewrite:

postulate
  B : Set
  a b : B
  a≡b : a ≡ b
  P : B → Set

record W : Set where
  field
    wrap : P b

w : P a → W
w p rewrite a≡b = record {N}
  module N where
    wrap = p

-- Should also succeed in the presence of `rewrite`.

module N' = N  -- See issue #3824.


------------------------------------------------------------------------
-- The Agda standard library
--
-- A data structure which keeps track of an upper bound on the number
-- of elements /not/ in a given list
------------------------------------------------------------------------

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

open import Level using (0ℓ)
open import Relation.Binary

module Data.List.Countdown (D : DecSetoid 0ℓ 0ℓ) where

open import Data.Empty
open import Data.Fin using (Fin; zero; suc; punchOut)
open import Data.Fin.Properties
  using (suc-injective; punchOut-injective)
open import Function
open import Function.Equality using (_⟨$⟩_)
open import Function.Injection
  using (Injection; module Injection)
open import Data.List hiding (lookup)
open import Data.List.Relation.Unary.Any as Any using (here; there)
open import Data.Nat.Base using (ℕ; zero; suc)
open import Data.Product
open import Data.Sum
open import Data.Sum.Properties
open import Relation.Nullary
open import Relation.Binary.PropositionalEquality as PropEq
  using (_≡_; _≢_; refl; cong)
open PropEq.≡-Reasoning

private
  open module D = DecSetoid D
    hiding (refl) renaming (Carrier to Elem)
  open import Data.List.Membership.Setoid D.setoid

------------------------------------------------------------------------
-- Helper functions

private

  -- The /first/ occurrence of x in xs.

  first-occurrence : ∀ {xs} x → x ∈ xs → x ∈ xs
  first-occurrence x (here x≈y)           = here x≈y
  first-occurrence x (there {x = y} x∈xs) with x ≟ y
  ... | yes x≈y = here x≈y
  ... | no  _   = there $ first-occurrence x x∈xs

  -- The index of the first occurrence of x in xs.

  first-index : ∀ {xs} x → x ∈ xs → Fin (length xs)
  first-index x x∈xs = Any.index $ first-occurrence x x∈xs

  -- first-index preserves equality of its first argument.

  first-index-cong : ∀ {x₁ x₂ xs} (x₁∈xs : x₁ ∈ xs) (x₂∈xs : x₂ ∈ xs) →
                     x₁ ≈ x₂ → first-index x₁ x₁∈xs ≡ first-index x₂ x₂∈xs
  first-index-cong {x₁} {x₂} x₁∈xs x₂∈xs x₁≈x₂ = helper x₁∈xs x₂∈xs
    where
    helper : ∀ {xs} (x₁∈xs : x₁ ∈ xs) (x₂∈xs : x₂ ∈ xs) →
             first-index x₁ x₁∈xs ≡ first-index x₂ x₂∈xs
    helper (here x₁≈x) (here x₂≈x)           = refl
    helper (here x₁≈x) (there {x = x} x₂∈xs) with x₂ ≟ x
    ... | yes x₂≈x = refl
    ... | no  x₂≉x = ⊥-elim (x₂≉x (trans (sym x₁≈x₂) x₁≈x))
    helper (there {x = x} x₁∈xs) (here x₂≈x) with x₁ ≟ x
    ... | yes x₁≈x = refl
    ... | no  x₁≉x = ⊥-elim (x₁≉x (trans x₁≈x₂ x₂≈x))
    helper (there {x = x} x₁∈xs) (there x₂∈xs) with x₁ ≟ x | x₂ ≟ x
    ... | yes x₁≈x | yes x₂≈x = refl
    ... | yes x₁≈x | no  x₂≉x = ⊥-elim (x₂≉x (trans (sym x₁≈x₂) x₁≈x))
    ... | no  x₁≉x | yes x₂≈x = ⊥-elim (x₁≉x (trans x₁≈x₂ x₂≈x))
    ... | no  x₁≉x | no  x₂≉x = cong suc $ helper x₁∈xs x₂∈xs

  -- first-index is injective in its first argument.

  first-index-injective
    : ∀ {x₁ x₂ xs} (x₁∈xs : x₁ ∈ xs) (x₂∈xs : x₂ ∈ xs) →
      first-index x₁ x₁∈xs ≡ first-index x₂ x₂∈xs → x₁ ≈ x₂
  first-index-injective {x₁} {x₂} = helper
    where
    helper : ∀ {xs} (x₁∈xs : x₁ ∈ xs) (x₂∈xs : x₂ ∈ xs) →
             first-index x₁ x₁∈xs ≡ first-index x₂ x₂∈xs → x₁ ≈ x₂
    helper (here x₁≈x) (here x₂≈x)             _  = trans x₁≈x (sym x₂≈x)
    helper (here x₁≈x) (there {x = x} x₂∈xs)   _  with x₂ ≟ x
    helper (here x₁≈x) (there {x = x} x₂∈xs)   _  | yes x₂≈x = trans x₁≈x (sym x₂≈x)
    helper (here x₁≈x) (there {x = x} x₂∈xs)   () | no  x₂≉x
    helper (there {x = x} x₁∈xs) (here x₂≈x)   _  with x₁ ≟ x
    helper (there {x = x} x₁∈xs) (here x₂≈x)   _  | yes x₁≈x = trans x₁≈x (sym x₂≈x)
    helper (there {x = x} x₁∈xs) (here x₂≈x)   () | no  x₁≉x
    helper (there {x = x} x₁∈xs) (there x₂∈xs) _  with x₁ ≟ x | x₂ ≟ x
    helper (there {x = x} x₁∈xs) (there x₂∈xs) _  | yes x₁≈x | yes x₂≈x = trans x₁≈x (sym x₂≈x)
    helper (there {x = x} x₁∈xs) (there x₂∈xs) () | yes x₁≈x | no  x₂≉x
    helper (there {x = x} x₁∈xs) (there x₂∈xs) () | no  x₁≉x | yes x₂≈x
    helper (there {x = x} x₁∈xs) (there x₂∈xs) eq | no  x₁≉x | no  x₂≉x =
      helper x₁∈xs x₂∈xs (suc-injective eq)

------------------------------------------------------------------------
-- The countdown data structure

-- If counted ⊕ n is inhabited then there are at most n values of type
-- Elem which are not members of counted (up to _≈_). You can read the
-- symbol _⊕_ as partitioning Elem into two parts: counted and
-- uncounted.

infix 4 _⊕_

record _⊕_ (counted : List Elem) (n : ℕ) : Set where
  field
    -- An element can be of two kinds:
    -- ⑴ It is provably in counted.
    -- ⑵ It is one of at most n elements which may or may not be in
    --   counted. The "at most n" part is guaranteed by the field
    --   "injective".

    kind      : ∀ x → x ∈ counted ⊎ Fin n
    injective : ∀ {x y i} → kind x ≡ inj₂ i → kind y ≡ inj₂ i → x ≈ y

-- A countdown can be initialised by proving that Elem is finite.

empty : ∀ {n} → Injection D.setoid (PropEq.setoid (Fin n)) → [] ⊕ n
empty inj =
  record { kind      = inj₂ ∘ _⟨$⟩_ to
         ; injective = λ {x} {y} {i} eq₁ eq₂ → injective (begin
             to ⟨$⟩ x  ≡⟨ inj₂-injective eq₁ ⟩
             i         ≡⟨ PropEq.sym $ inj₂-injective eq₂ ⟩
             to ⟨$⟩ y  ∎)
         }
  where open Injection inj

-- A countdown can also be initialised by proving that Elem is finite.

emptyFromList : (counted : List Elem) → (∀ x → x ∈ counted) →
                [] ⊕ length counted
emptyFromList counted complete = empty record
  { to = record
    { _⟨$⟩_ = λ x → first-index x (complete x)
    ; cong  = first-index-cong (complete _) (complete _)
    }
  ; injective = first-index-injective (complete _) (complete _)
  }

-- Finds out if an element has been counted yet.

lookup : ∀ {counted n} → counted ⊕ n → ∀ x → Dec (x ∈ counted)
lookup {counted} _ x = Any.any (_≟_ x) counted

-- When no element remains to be counted all elements have been
-- counted.

lookup! : ∀ {counted} → counted ⊕ zero → ∀ x → x ∈ counted
lookup! counted⊕0 x with _⊕_.kind counted⊕0 x
... | inj₁ x∈counted = x∈counted
... | inj₂ ()

private

  -- A variant of lookup!.

  lookup‼ : ∀ {m counted} →
            counted ⊕ m → ∀ x → x ∉ counted → ∃ λ n → m ≡ suc n
  lookup‼ {suc m} counted⊕n x x∉counted = (m , refl)
  lookup‼ {zero}  counted⊕n x x∉counted =
    ⊥-elim (x∉counted $ lookup! counted⊕n x)

-- Counts a previously uncounted element.

insert : ∀ {counted n} →
         counted ⊕ suc n → ∀ x → x ∉ counted → x ∷ counted ⊕ n
insert {counted} {n} counted⊕1+n x x∉counted =
  record { kind = kind′; injective = inj }
  where
  open _⊕_ counted⊕1+n

  helper : ∀ x y i {j} →
           kind x ≡ inj₂ i → kind y ≡ inj₂ j → i ≡ j → x ≈ y
  helper _ _ _ eq₁ eq₂ refl = injective eq₁ eq₂

  kind′ : ∀ y → y ∈ x ∷ counted ⊎ Fin n
  kind′  y with y ≟ x | kind x | kind y | helper x y
  kind′  y | yes y≈x | _              | _              | _   = inj₁ (here y≈x)
  kind′  y | _       | inj₁ x∈counted | _              | _   = ⊥-elim (x∉counted x∈counted)
  kind′  y | _       | _              | inj₁ y∈counted | _   = inj₁ (there y∈counted)
  kind′  y | no  y≉x | inj₂ i         | inj₂ j         | hlp =
    inj₂ (punchOut (y≉x ∘ sym ∘ hlp _ refl refl))

  inj : ∀ {y z i} → kind′ y ≡ inj₂ i → kind′ z ≡ inj₂ i → y ≈ z
  inj {y} {z} eq₁ eq₂ with y ≟ x | z ≟ x | kind x | kind y | kind z
                         | helper x y | helper x z | helper y z
  inj ()  _   | yes _ | _     | _              | _      | _      | _ | _ | _
  inj _   ()  | _     | yes _ | _              | _      | _      | _ | _ | _
  inj _   _   | no  _ | no  _ | inj₁ x∈counted | _      | _      | _ | _ | _ = ⊥-elim (x∉counted x∈counted)
  inj ()  _   | no  _ | no  _ | inj₂ _         | inj₁ _ | _      | _ | _ | _
  inj _   ()  | no  _ | no  _ | inj₂ _         | _      | inj₁ _ | _ | _ | _
  inj eq₁ eq₂ | no  _ | no  _ | inj₂ i         | inj₂ _ | inj₂ _ | _ | _ | hlp =
    hlp _ refl refl $
      punchOut-injective {i = i} _ _ $
        (PropEq.trans (inj₂-injective eq₁) (PropEq.sym (inj₂-injective eq₂)))

-- Counts an element if it has not already been counted.

lookupOrInsert : ∀ {counted m} →
                 counted ⊕ m →
                 ∀ x → x ∈ counted ⊎
                       ∃ λ n → m ≡ suc n × x ∷ counted ⊕ n
lookupOrInsert counted⊕n x with lookup counted⊕n x
... | yes x∈counted = inj₁ x∈counted
... | no  x∉counted with lookup‼ counted⊕n x x∉counted
...   | (n , refl) = inj₂ (n , refl , insert counted⊕n x x∉counted)


-- Andreas, 2012-05-14, issue reported by Nisse
-- {-# OPTIONS -v term:20 #-}
module Issue636 where

open import Common.Coinduction

data ⊥ : Set where

data D : Set where
  c : ∞ D → D

d : D
d = c (♯ d)

not-d : D → ⊥
not-d (c x) = not-d (♭ x)

bad : ⊥
bad = not-d d