module FizzBuzz where

{-# IMPORT Data.Word #-}
{-# IMPORT FizzBuzz #-}

open import Data.Nat
open import IO.Primitive
open import Foreign.Haskell

postulate
  ℕ′ : Set
  zero′ : ℕ′
  suc′ : ℕ′ → ℕ′

{-# COMPILED_TYPE ℕ′ Data.Word.Word32 #-}
{-# COMPILED zero′ 0 #-}
{-# COMPILED suc′ succ #-}

fromℕ : ℕ → ℕ′
fromℕ zero = zero′
fromℕ (suc n) = suc′ (fromℕ n)

postulate FizzBuzz : ℕ′ → IO Unit
{-# COMPILED FizzBuzz FizzBuzz.fizzBuzz #-}

main : IO Unit
main = FizzBuzz (fromℕ 10000)


module tests.String where

open import Prelude.IO
open import Prelude.List
open import Prelude.String
open import Prelude.Unit

testString : String
testString = "To boldly go where no man gone before"

printList : forall {A} -> (A -> IO Unit) -> List A -> IO Unit
printList p [] = return unit
printList p (x :: xs) =
    p x ,,
    printList p xs

main : IO Unit
main =
    putStrLn testString ,,
    printList printChar (fromString testString) ,,
    putStrLn "" ,,
    putStrLn (fromList (fromString testString)) ,,
    return unit


-- Andreas, 2019-03-25, issue #3647, reported and bisected by nad.
-- Regression introduced in refactoring a78d7f54e447cadf039da81b50ff40c81aa93909.

{-# OPTIONS --allow-unsolved-metas #-}

-- {-# OPTIONS -v 90 #-}

postulate
  A : Set
  P : A → Set

Q : A → A → Set
Q _ x = P x

record R (P : A → Set) : Set where
  field f : (x : A) → P x → P x

open R ⦃ … ⦄

module M {x : A} where

  instance
    postulate
      r₁ r₂ : R (Q x)

postulate
  q₁ : (x : A) → P x

q₂ : (x : A) → P x
q₂ x = f _ (q₁ x)

-- WAS: internal error.

-- Should succeed with unsolved metas.


-- Andreas, 2017-06-14, issue #2603
-- reported by rfindler, shrunk test case by Ulf

-- {-# OPTIONS -v tc.conv:40 -v tc.conv.atom:50 -v tc:80 -v tc.meta.assign:70 #-}

{-# OPTIONS --allow-unsolved-metas #-}

open import Agda.Builtin.Equality

data List (A : Set) : Set where
  [] : List A

postulate
  Signal : Set

data Any (xs : List Signal) : Set where
  no : Any xs

any : ∀ xs → Any xs
any [] = no

record Env : Set where
  field sig : List Signal
open Env

Can : (θ : Env) → Any (sig θ) → Set
Can θ no = Signal

postulate
  elephant : ∀ θ → Can θ (any (sig θ)) ≡ Signal

lemma2 : Set
lemma2 rewrite elephant _ = Signal

-- Should succeed.
-- This lead to an internal error when the conversion checker
-- tried to eta expand a meta variable but dontAssignMetas was on.


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

open import Relation.Binary.PropositionalEquality using (_≡_; _≢_; sym; refl; subst; trans; cong)
open import Relation.Nullary using (Dec; yes; no)
open import Relation.Nullary.Decidable using (True; toWitness; fromWitness)
open import Function using (_∘_)

import Data.Maybe as Maybe
import Data.Empty as Empty
import Data.Unit as Unit
import Data.Nat as ℕ
import Data.Nat.Properties as ℕₚ
import Data.Product as Product
import Data.Product.Properties as Productₚ
import Data.Vec as Vec
import Data.Vec.Relation.Unary.All as All
import Data.Fin as Fin

open Maybe using (nothing; just)
open Empty using (⊥; ⊥-elim)
open Unit using (⊤; tt)
open ℕ using (ℕ; zero; suc)
open Product using (Σ-syntax; ∃-syntax; _×_; _,_; proj₂; proj₁)
open Vec using (Vec; []; _∷_)
open All using (All; []; _∷_)
open Fin using (Fin ; zero ; suc)
open Relation.Binary.PropositionalEquality.≡-Reasoning

import PiCalculus.Syntax
open PiCalculus.Syntax.Scoped
open import PiCalculus.Semantics
open import PiCalculus.LinearTypeSystem.Algebras

module PiCalculus.LinearTypeSystem.ContextLemmas (Ω : Algebras) where
open Algebras Ω
open import PiCalculus.LinearTypeSystem Ω

private
  variable
    n : ℕ
    idxs idxsₗ idxsᵣ : Idxs n
    γ : PreCtx n
    idx idx' : Idx
    t : Type
    P Q : Scoped n
    i j : Fin n
    Γ Δ Ξ Θ : Ctx idxs
    x x' y z : Usage idx ²

data _≔_⊗_ : Ctx idxs → Ctx idxs → Ctx idxs → Set where
  []  : [] ≔ [] ⊗ []
  _,_ : Γ ≔ Δ ⊗ Ξ → x ≔ y ∙² z → (Γ -, x) ≔ (Δ -, y) ⊗ (Ξ -, z)

ε : ∀ {idxs : Idxs n} → Ctx idxs
ε {idxs = []} = []
ε {idxs = _ -, _} = ε -, (0∙ , 0∙)

⊗-get : {idxs : Idxs n} {Γ Δ Ξ : Ctx idxs} (i : Fin n) → Γ ≔ Δ ⊗ Ξ → All.lookup i Γ ≔ All.lookup i Δ ∙² All.lookup i Ξ
⊗-get zero (Γ≔ , x≔) = x≔
⊗-get (suc i) (Γ≔ , x) = ⊗-get i Γ≔

⊗-idˡ : {idxs : Idxs n} {Γ : Ctx idxs} → Γ ≔ ε {idxs = idxs} ⊗ Γ
⊗-idˡ {Γ = []} = []
⊗-idˡ {Γ = Γ -, x} = ⊗-idˡ , ∙²-idˡ

⊗-unique : {Γ Γ' Δ Ξ  : Ctx idxs} → Γ' ≔ Δ ⊗ Ξ → Γ ≔ Δ ⊗ Ξ → Γ' ≡ Γ
⊗-unique [] [] = refl
⊗-unique (Γ'≔ , x'≔) (Γ≔ , x≔) rewrite ⊗-unique Γ'≔ Γ≔ | ∙²-unique x'≔ x≔ = refl

⊗-uniqueˡ : {Γ Δ Δ' Ξ  : Ctx idxs} → Γ ≔ Δ' ⊗ Ξ → Γ ≔ Δ ⊗ Ξ → Δ' ≡ Δ
⊗-uniqueˡ [] [] = refl
⊗-uniqueˡ (Δ'≔ , y'≔) (Δ≔ , y≔) rewrite ⊗-uniqueˡ Δ'≔ Δ≔ | ∙²-uniqueˡ y'≔ y≔ = refl

⊗-comm : {Γ Δ Ξ : Ctx idxs} → Γ ≔ Δ ⊗ Ξ → Γ ≔ Ξ ⊗ Δ
⊗-comm [] = []
⊗-comm (Γ≔ , x≔) = ⊗-comm Γ≔ , ∙²-comm x≔

⊗-assoc : {Γₘ Γₗ Γᵣ Γₗₗ Γₗᵣ : Ctx idxs}
        → Γₘ ≔ Γₗ ⊗ Γᵣ → Γₗ ≔ Γₗₗ ⊗ Γₗᵣ → Σ[ Γᵣ' ∈ Ctx idxs ] (Γₘ ≔ Γₗₗ ⊗ Γᵣ' × Γᵣ' ≔ Γₗᵣ ⊗ Γᵣ)
⊗-assoc [] [] = [] , [] , []
⊗-assoc (Γₘ≔ , xₘ≔) (Γₗ≔ , xₗ≔) with ⊗-assoc Γₘ≔ Γₗ≔ | ∙²-assoc xₘ≔ xₗ≔
... | (_ , Γₘ'≔ , Γᵣ'≔)  | (_ , xₘ'≔ , xᵣ'≔) = _ , ((Γₘ'≔ , xₘ'≔) , (Γᵣ'≔ , xᵣ'≔))

⊗-assoc⁻¹ : ∀ {x y z u v : Ctx idxs} → x ≔ y ⊗ z → z ≔ u ⊗ v → ∃[ w ] (x ≔ w ⊗ v × w ≔ y ⊗ u)
⊗-assoc⁻¹ a b = let _ , a' , b' = ⊗-assoc (⊗-comm a) (⊗-comm b) in _ , ⊗-comm a' , ⊗-comm b'

⊗-comp : {Γ Δₗ Δᵣ Δ Ξ Θ : Ctx idxs}
       → Γ ≔ Δₗ ⊗ Ξ → Ξ ≔ Δᵣ ⊗ Θ
       → Γ ≔ Δ  ⊗ Θ → Δ ≔ Δₗ ⊗ Δᵣ
⊗-comp l≔ r≔ Γ≔ with ⊗-assoc (⊗-comm l≔) (⊗-comm r≔)
⊗-comp l≔ r≔ Γ≔ | _ , Γ'≔ , R'≔ rewrite ⊗-uniqueˡ Γ≔ (⊗-comm Γ'≔) = ⊗-comm R'≔

⊗-idʳ : {Γ : Ctx idxs} → Γ ≔ Γ ⊗ ε
⊗-idʳ = ⊗-comm ⊗-idˡ

⊗-mut-cancel : ∀ {x y y' z : Ctx idxs} → x ≔ y ⊗ z → z ≔ y' ⊗ x → x ≡ z
⊗-mut-cancel [] [] = refl
⊗-mut-cancel (Γ≔ , x≔) (Ξ≔ , z≔) rewrite ⊗-mut-cancel Γ≔ Ξ≔ | ∙²-mut-cancel x≔ z≔ = refl

∋-≡Idx : {idxs : Idxs n} {i : Fin n} {Γ Δ : Ctx idxs} {x : Usage idx ²}
       → Γ ∋[ i ] x ▹ Δ → Vec.lookup idxs i ≡ idx
∋-≡Idx (zero x) = refl
∋-≡Idx (suc s) rewrite ∋-≡Idx s = refl

∋-≡Type : γ ∋[ i ] t → Vec.lookup γ i ≡ t
∋-≡Type zero = refl
∋-≡Type (suc t) rewrite ∋-≡Type t = refl

≡Type-∋ : Vec.lookup γ i ≡ t → γ ∋[ i ] t
≡Type-∋ {γ = _ -, _} {i = zero} refl = zero
≡Type-∋ {γ = _ -, _} {i = suc i} eq = suc (≡Type-∋ eq)

∋-⊗ : {Γ Ξ : Ctx idxs}
    → Γ ∋[ i ] x ▹ Ξ
    → Σ[ Δ ∈ Ctx idxs ]
      (Γ ≔ Δ ⊗ Ξ × Δ ∋[ i ] x ▹ ε {idxs = idxs})
∋-⊗ (zero x) = _ , (⊗-idˡ , x) , zero ∙²-idʳ
∋-⊗ (suc s) with ∋-⊗ s
∋-⊗ (suc s) | _ , Γ≔ , Δ≔ = _ , (Γ≔ , ∙²-idˡ) , suc Δ≔

⊗-∋ : {Γ Δ Ξ : Ctx idxs}
    → Γ ≔ Δ ⊗ Ξ
    → Δ ∋[ i ] x ▹ ε {idxs = idxs}
    → Γ ∋[ i ] x ▹ Ξ
⊗-∋ (sp , s) (zero x) rewrite ⊗-unique sp ⊗-idˡ | ∙²-unique x ∙²-idʳ = zero s
⊗-∋ (sp , s) (suc only) rewrite ∙²-unique s ∙²-idˡ = suc (⊗-∋ sp only)

∋-ℓ∅ : {idxs : Idxs n} {Γ : Ctx idxs} {i : Fin n} {idx : Idx}→ Vec.lookup idxs i ≡ idx → Γ ∋[ i ] ℓ∅ {idx} ▹ Γ
∋-ℓ∅ {Γ = _ -, _} {i = zero} refl = zero ∙²-idˡ
∋-ℓ∅ {Γ = _ -, _} {i = suc i} eq = suc (∋-ℓ∅ eq)

-- TODO: deprecate, convert to context first
∋-uniqueʳ : {i : Fin n} {idxs : Idxs n} {Γ Δ Ξ : Ctx idxs}
          → Γ ∋[ i ] x ▹ Δ → Γ ∋[ i ] x ▹ Ξ → Δ ≡ Ξ
∋-uniqueʳ (zero a) (zero b) rewrite ∙²-uniqueˡ (∙²-comm a) (∙²-comm b) = refl
∋-uniqueʳ (suc a) (suc b) rewrite ∋-uniqueʳ a b = refl

-- TODO: deprecate, convert to context first
∋-uniqueˡ : Γ ∋[ i ] x ▹ Δ → Ξ ∋[ i ] x ▹ Δ → Γ ≡ Ξ
∋-uniqueˡ (zero a) (zero b) rewrite ∙²-unique a b = refl
∋-uniqueˡ (suc a) (suc b) rewrite ∋-uniqueˡ a b = refl

∋-lookup-≡ : Γ ∋[ i ] x ▹ Δ → All.lookup i Γ ≔ x ∙² All.lookup i Δ
∋-lookup-≡ {Δ = _ -, _} (zero x) = x
∋-lookup-≡ {Δ = _ -, _} (suc s) = ∋-lookup-≡ s

∋-lookup-≢ : Γ ∋[ i ] x ▹ Δ → ∀ j → j ≢ i → All.lookup j Γ ≡ All.lookup j Δ
∋-lookup-≢ (zero x) zero j≢i = ⊥-elim (j≢i refl)
∋-lookup-≢ (suc xati) zero j≢i = refl
∋-lookup-≢ (zero x) (suc j) j≢i = refl
∋-lookup-≢ (suc xati) (suc j) j≢i = ∋-lookup-≢ xati j (j≢i ∘ cong suc)

∙²-⊗ : {Γ Δ Ξ : Ctx idxs}
     → Γ ∋[ i ] x ▹ ε → Δ ∋[ i ] y ▹ ε → Ξ ∋[ i ] z ▹ ε
     → x ≔ y ∙² z → Γ ≔ Δ ⊗ Ξ
∙²-⊗ (zero x) (zero y) (zero z) sp
  rewrite ∙²-unique x ∙²-idʳ | ∙²-unique y ∙²-idʳ | ∙²-unique z ∙²-idʳ = ⊗-idˡ , sp
∙²-⊗ (suc Γ≔) (suc Δ≔) (suc Ξ≔) sp = ∙²-⊗ Γ≔ Δ≔ Ξ≔ sp , ∙²-idˡ

diamond : {Γ Ξ Ψ : Ctx idxs}
        → i ≢ j
        → Γ ∋[ j ] x ▹ Ξ
        → Γ ∋[ i ] y ▹ Ψ
        → Σ[ Θ ∈ Ctx idxs ]
        ( Ξ ∋[ i ] y ▹ Θ
        × Ψ ∋[ j ] x ▹ Θ
        )
diamond i≢j (zero _) (zero _) = ⊥-elim (i≢j refl)
diamond i≢j (zero x) (suc ∋i) = _ , suc ∋i , zero x
diamond i≢j (suc ∋j) (zero x) = _ , zero x , suc ∋j
diamond i≢j (suc ∋j) (suc ∋i) with diamond (i≢j ∘ cong suc) ∋j ∋i
diamond i≢j (suc ∋j) (suc ∋i) | _ , ∋i' , ∋j' = _ , suc ∋i' , suc ∋j'

outer-diamond : {Γ Ξ Ψ Θ ΞΔ Δ ΨΔ : Ctx idxs}
              → i ≢ j
              → Γ ∋[ i ] x ▹ Ξ → Γ ∋[ j ] y ▹ Ψ
              → Ξ ∋[ j ] y ▹ Θ → Ψ ∋[ i ] x ▹ Θ
              → Ξ ≔ ΞΔ ⊗ Δ → Ψ ≔ ΨΔ ⊗ Δ
              → Σ[ ΘΔ ∈ Ctx idxs ] (Θ ≔ ΘΔ ⊗ Δ)
outer-diamond i≢j (zero _) (zero _) (zero _) (zero _) a b = ⊥-elim (i≢j refl)
outer-diamond i≢j (zero x₁) (suc ∋j) (suc ∈j) (zero x) (as , a) (bs , b) = _ , (bs , a)
outer-diamond i≢j (suc ∋i) (zero ∋j) (zero ∈j) (suc ∈i) (as , a) (bs , b) = _ , (as , b)
outer-diamond i≢j (suc ∋i) (suc ∋j) (suc ∈j) (suc ∈i) (as , a) (bs , b) with outer-diamond (i≢j ∘ cong suc) ∋i ∋j ∈j ∈i as bs
outer-diamond i≢j (suc ∋i) (suc ∋j) (suc ∈j) (suc ∈i) (as , a) (bs , b) | _ , s = _ , (s , a)

reverse : {Γ ΓΞ Ξ ΞΨ Ψ : Ctx idxs}
        → Γ ≔ ΓΞ ⊗ Ξ
        → Ξ ≔ ΞΨ ⊗ Ψ
        → Σ[ Θ ∈ Ctx idxs ]
        ( Γ ≔ ΞΨ ⊗ Θ
        × Θ ≔ ΓΞ ⊗ Ψ
        )
reverse Γ≔ΓΞ∙Ξ Ξ≔ΞΨ∙Ψ =
  let _ , Γ≔ΞΨ∙Θ , Θ≔Ψ∙ΓΞ = ⊗-assoc (⊗-comm Γ≔ΓΞ∙Ξ) Ξ≔ΞΨ∙Ψ in
  _ , Γ≔ΞΨ∙Θ , ⊗-comm Θ≔Ψ∙ΓΞ

boil : {Γ Ξ ΞΨ Θ Ψ ΘΨ : Ctx idxs}
     → Γ ∋[ i ] x ▹ Θ
     → Γ ∋[ i ] y ▹ Ξ
     → Ξ ≔ ΞΨ ⊗ Ψ
     → Θ ≔ ΘΨ ⊗ Ψ
     → All.lookup i ΘΨ ≡ ℓ∅
     → ∃[ z ] (x ≔ y ∙² z)
boil {i = zero} (zero a) (zero b) (_ , c) (_ , d) refl rewrite ∙²-unique d ∙²-idˡ with ∙²-assoc⁻¹ b c
boil {i = zero} (zero a) (zero b) (_ , c) (_ , d) refl | _ , e , f rewrite ∙²-uniqueˡ e a = _ , f
boil {i = suc i} (suc a) (suc b) (c , _) (d , _) eq = boil a b c d eq

split : x ≔ y ∙² z
      → Γ ∋[ i ] x ▹ Ξ
      → ∃[ Δ ] (Γ ∋[ i ] y ▹ Δ × Δ ∋[ i ] z ▹ Ξ)
split s (zero x) = let _ , x' , s' = ∙²-assoc x s in _ , zero x' , zero s'
split s (suc x) with split s x
split s (suc x) | _ , y , z = _ , suc y , suc z

split-ℓ∅ : {Γ ΓΨ Ψ ΓΘ Θ ΘΨ : Ctx idxs}
        → Γ ≔ ΓΨ ⊗ Ψ
        → Γ ≔ ΓΘ ⊗ Θ
        → Θ ≔ ΘΨ ⊗ Ψ
        → All.lookup i ΓΨ ≡ ℓ∅
        → All.lookup i ΓΘ ≡ ℓ∅ × All.lookup i ΘΨ ≡ ℓ∅
split-ℓ∅ {i = zero} (a , x) (b , y) (c , z) refl rewrite ∙²-unique x ∙²-idˡ with ∙²-mut-cancel y z
split-ℓ∅ {i = zero} (a , x) (b , y) (c , z) refl | refl = ∙²-uniqueˡ y ∙²-idˡ , ∙²-uniqueˡ z ∙²-idˡ
split-ℓ∅ {i = suc i} (a , _) (b , _) (c , _) eq = split-ℓ∅ a b c eq

⊢-⊗ : {γ : PreCtx n} {idxs : Idxs n} {Γ Ξ : Ctx idxs} → γ ； Γ ⊢ P ▹ Ξ → Σ[ Δ ∈ Ctx idxs ] (Γ ≔ Δ ⊗ Ξ)
⊢-⊗ 𝟘 = ε , ⊗-idˡ
⊢-⊗ (ν t m μ ⊢P) with ⊢-⊗ ⊢P
⊢-⊗ (ν t m μ ⊢P) | (_ -, _) , (P≔ , _) = _ , P≔
⊢-⊗ ((_ , x) ⦅⦆ ⊢P) with ⊢-⊗ ⊢P
⊢-⊗ ((_ , x) ⦅⦆ ⊢P) | (_ -, _) , (P≔ , _) =
  let _ , x≔ , _ = ∋-⊗ x
      _ , xP≔ , _ = ⊗-assoc⁻¹ x≔ P≔
   in _ , xP≔
⊢-⊗ ((_ , x) ⟨ _ , y ⟩ ⊢P) =
  let _ , x≔ , _ = ∋-⊗ x
      _ , y≔ , _ = ∋-⊗ y
      _ , P≔ = ⊢-⊗ ⊢P
      _ , xy≔ , _ = ⊗-assoc⁻¹ x≔ y≔
      _ , Pxy≔ , _ = ⊗-assoc⁻¹ xy≔ P≔
   in _ , Pxy≔
⊢-⊗ (⊢P ∥ ⊢Q) =
  let _ , P≔ = ⊢-⊗ ⊢P
      _ , Q≔ = ⊢-⊗ ⊢Q
      _ , PQ≔ , _ = ⊗-assoc⁻¹ P≔ Q≔
   in _ , PQ≔

ctx-insert : (i : Fin (suc n)) → Usage idx ² → Ctx idxs → Ctx (Vec.insert idxs i idx)
ctx-insert zero xs' Γ = Γ -, xs'
ctx-insert (suc i) xs' (Γ -, xs) = ctx-insert i xs' Γ -, xs

ctx-remove : Ctx idxs → (i : Fin (suc n)) → Ctx (Vec.remove idxs i)
ctx-remove (Γ -, _) zero = Γ
ctx-remove (Γ -, ys -, xs) (suc i) = ctx-remove (Γ -, ys) i -, xs

ctx-update : (i : Fin n) → Usage (Vec.lookup idxs i) ² → Ctx idxs → Ctx idxs
ctx-update zero m' (ms -, m) = ms -, m'
ctx-update (suc i) m' (ms -, m) = ctx-update i m' ms -, m

fromFin : {γ : PreCtx n} {idxs : Idxs n} {Γ : Ctx idxs}
        → ∀ i
        → {y z : Usage (Vec.lookup idxs i) ²}
        → All.lookup i Γ ≔ y ∙² z
        → γ ； Γ ∋[ i ] Vec.lookup γ i ； y ▹ ctx-update i z Γ
fromFin {γ = γ -, t} {Γ = Γ -, x} zero split = zero , (zero split)
fromFin {γ = γ -, t} {Γ = Γ -, x} (suc i) split = there (fromFin i split)

#_ : {γ : PreCtx n} {idxs : Idxs n} {Γ : Ctx idxs}
   → ∀ m {m<n : True (m ℕₚ.<? n)}
   → let i = Fin.fromℕ< (toWitness m<n)
     in {y : Usage (Vec.lookup idxs i) ²}
   → {check : True (∙²-computeʳ (All.lookup i Γ) y)}
   → let z , _ = toWitness check
     in γ ； Γ ∋[ i ] Vec.lookup γ i ； y ▹ ctx-update i z Γ
(# m) {m<n} {check = check} =
  let _ , split = toWitness check
  in fromFin (Fin.fromℕ< (toWitness m<n)) split


open import Data.Nat    using (ℕ; _+_) renaming (_≤?_ to _≤?ₙ_)
open import Data.Bool   using (Bool; true; false; not; _∧_)
open import Data.String using (String; _≟_)
open import Data.Sum    using (_⊎_; [_,_]′; inj₁; inj₂)
open import Data.Product               using (_×_; _,_)
open import Relation.Nullary           using (yes; no)
open import Relation.Nullary.Decidable using (⌊_⌋)
open import Data.Product using (_×_; _,_; -,_; _-,-_; ∃; ∃-syntax)
open import Relation.Binary.PropositionalEquality using (_≡_; refl; sym)
open import Level using (Level; suc; _⊔_)

open import IMP
open import Hoare

data True {l} : Set l where
  ⊤ : True

data acom {l} : Set (suc l) where
  SKIP  : acom
  _::=_ : String → aexp → acom
  _::_  : acom {l} → acom {l} → acom
  IF_THEN_ELSE_ : bexp → acom {l} → acom {l} → acom
  WHILE[_]_DO_ : assn {l} → bexp → acom {l} → acom

strip : ∀{l} → acom {l} → com
strip SKIP = SKIP
strip (x ::= a) = x ::= a
strip (c₁ :: c₂) = strip c₁ :: strip c₂
strip (IF b THEN c₁ ELSE c₂) = IF b THEN strip c₁ ELSE strip c₂
strip (WHILE[ I ] b DO c) = WHILE b DO strip c

pre : ∀{l} → acom {l} → assn → assn
pre SKIP Q = Q
pre (x ::= a) Q s = Q (s [ x ::= aval a s ])
pre (c₁ :: c₂) Q = pre c₁ (pre c₂ Q)
pre (IF b THEN c₁ ELSE c₂) Q s with bval b s
... | true = pre c₁ Q s
... | false = pre c₂ Q s
pre (WHILE[ I ] b DO c) Q = I

vc : ∀{l} → acom {l} → assn → Set l
vc SKIP Q = True
vc (x ::= x₁) Q = True
vc (c₁ :: c₂) Q = vc c₁ (pre c₂ Q) × vc c₂ Q
vc (IF b THEN c₁ ELSE c₂) Q = vc c₁ Q × vc c₂ Q
vc (WHILE[ I ] b DO c) Q =
     (∀ s → I s × bval b s ≡ true  → pre c I s)
   × (∀ s → I s × bval b s ≡ false → Q s)
   × vc c I

extract-if-pre₁ : ∀{l} {Q : assn {l}} {c₁ c₂ s} b
  → pre (IF b THEN c₁ ELSE c₂) Q s
  × bval b s ≡ true
  → pre c₁ Q s
extract-if-pre₁ b (x , y) rewrite y = x

extract-if-pre₂ : ∀{l} {Q : assn {l}} {c₁ c₂ s} b
  → pre (IF b THEN c₁ ELSE c₂) Q s
  × bval b s ≡ false
  → pre c₂ Q s
extract-if-pre₂ b (x , y) rewrite y = x

vc-correctness : ∀{l} {P Q : assn} c
  → vc {l} c Q
  → (∀ s → P s → pre c Q s)
  → ⊢[ P ] strip c [ Q ]
vc-correctness SKIP v i = Conseq i Skip (λ s z → z)
vc-correctness (x ::= a) v i = Conseq i Loc (λ r k → k)
vc-correctness (c₁ :: c₂) v i = Comp (vc-correctness c₁ (Data.Product.proj₁ v) i)
                                     (vc-correctness c₂ (Data.Product.proj₂ v) (λ s z → z))
vc-correctness {l}{P}{Q} (IF b THEN c₁ ELSE c₂) (fst , snd) i =
     Conseq i (If (vc-correctness c₁ fst (λ s p → extract-if-pre₁ b p))
                  (vc-correctness c₂ snd (λ s p → extract-if-pre₂ b p)))
              (λ s z → z)
vc-correctness (WHILE[ I ] b DO c) (fst , fst₁ , snd) i =
    Conseq i (While (vc-correctness c snd fst)) fst₁

pre-mono : ∀{l} {P P′ : assn {l}} {s′} c
  → (∀ s → P s → P′ s)
  → pre c P s′ → pre c P′ s′
pre-mono {s′ = s′} SKIP x x₁ = x s′ x₁
pre-mono (x₂ ::= x₃) x x₁ = x _ x₁
pre-mono (c :: c₁) x x₁ = pre-mono c (λ s → pre-mono c₁ x) x₁
pre-mono {s′ = s′} (IF x₂ THEN c₁ ELSE c₂) x x₁ with bval x₂ s′
... | true  = pre-mono c₁ x x₁
... | false = pre-mono c₂ x x₁
pre-mono (WHILE[ x₂ ] x₃ DO c) x x₁ = x₁

vc-mono : ∀{l} {P P′ : assn {l}} c
  → (∀ s → P s → P′ s)
  → vc c P → vc c P′
vc-mono SKIP _ _ = ⊤
vc-mono (x ::= a) _ _ = ⊤
vc-mono (c₁ :: c₂) pp′ (vcpre , vc2) = vc-mono c₁ (λ _ → pre-mono c₂ pp′) vcpre , vc-mono c₂ pp′ vc2
vc-mono (IF b THEN c₁ ELSE c₂) pp′ (vc₁ , vc₂) = vc-mono c₁ pp′ vc₁ , vc-mono c₂ pp′ vc₂
vc-mono (WHILE[ I ] b DO c) pp′ (I₁ , I₂ , vcc) = I₁ , (λ s z → pp′ s (I₂ s z)) , vcc

either : ∀ c → c ≡ true ⊎ c ≡ false
either true  = inj₁ refl
either false = inj₂ refl

construct-if-pre : ∀{l} {P Q : assn {l}} {ac₁ ac₂} b s
   → (bval b s ≡ true  → pre ac₁ Q s)
   → (bval b s ≡ false → pre ac₂ Q s)
   → pre (IF b THEN ac₁ ELSE ac₂) Q s
construct-if-pre b s f g with bval b s
... | true = f refl
... | false = g refl

vc-completeness : ∀{l} {P Q : assn {l}} c
  → ⊢[ P ] c [ Q ]
  → ∃[ c̃ ] ( c ≡ strip c̃
           × vc c̃ Q
           × (∀ s → P s → pre c̃ Q s))
vc-completeness c Skip = SKIP , refl , ⊤ , (λ x c → c)
vc-completeness c Loc = _ , refl , ⊤ ,  (λ x c → c)
vc-completeness (c₁ :: c₂) (Comp x y) with vc-completeness c₁ x
... | ac₁ , b , c , d                 with vc-completeness c₂ y
... | ac₂ , f , g , h rewrite b | f
                      = (ac₁ :: ac₂) , refl
                      , (vc-mono ac₁ h c , g)
                      , (λ s ps → pre-mono ac₁ h (d s ps))
vc-completeness {P = P} (IF b THEN c₁ ELSE c₂) (If d₁ d₂) with vc-completeness c₁ d₁
... | ac₁ , f , g , h                                     with vc-completeness c₂ d₂
... | ac₂ , j , k , m rewrite f | j
                      = (IF b THEN ac₁ ELSE ac₂) , refl
                      , (g , k)
                      , (λ s ps → construct-if-pre {P = P} b s (λ t → h s (ps , t)) (λ f → m s (ps , f)))
vc-completeness (WHILE b DO c) (While r) with vc-completeness c r
... | ac , f , g , h rewrite f = (WHILE[ _ ] b DO ac) , refl
                               , (h , (λ s z → z) , g)
                               , λ s z → z
vc-completeness c (Conseq x₁ r x₂) with vc-completeness c r
... | ac , f , g , h rewrite f
                     = ac , refl
                     , vc-mono ac x₂ g
                     , (λ s ps → pre-mono ac x₂ (h s (x₁ s ps)))


module OldBasicILP.Syntax.Translation where

open import Common.Context public

import OldBasicILP.Syntax.ClosedHilbertSequential as CHS
import OldBasicILP.Syntax.ClosedHilbert as CH

-- Translation from closed Hilbert-style sequential to closed Hilbert-style.

mutual
  chsᵀ→chᵀ : CHS.Ty → CH.Ty
  chsᵀ→chᵀ (CHS.α P)   = CH.α P
  chsᵀ→chᵀ (A CHS.▻ B) = chsᵀ→chᵀ A CH.▻ chsᵀ→chᵀ B
  chsᵀ→chᵀ (p CHS.⦂ A) = chsᴾ→chᴾ p CH.⦂ chsᵀ→chᵀ A
  chsᵀ→chᵀ (A CHS.∧ B) = chsᵀ→chᵀ A CH.∧ chsᵀ→chᵀ B
  chsᵀ→chᵀ CHS.⊤      = CH.⊤

  chsᴾ→chᴾ : ∀ {Ξ A} → CHS.Proof Ξ A → CH.Proof (chsᵀ→chᵀ A)
  chsᴾ→chᴾ CHS.[ d ] = CH.[ chsᴰ→ch d top ]

  chsᴰ→ch : ∀ {Ξ A} → CHS.⊢ᴰ Ξ → A ∈ Ξ → CH.⊢ (chsᵀ→chᵀ A)
  chsᴰ→ch (CHS.mp i j d) top     = CH.app (chsᴰ→ch d i) (chsᴰ→ch d j)
  chsᴰ→ch (CHS.ci d)     top     = CH.ci
  chsᴰ→ch (CHS.ck d)     top     = CH.ck
  chsᴰ→ch (CHS.cs d)     top     = CH.cs
  chsᴰ→ch (CHS.nec `d d) top     = CH.box (chsᴰ→ch `d top)
  chsᴰ→ch (CHS.cdist {Ξ} {A} {B} {`Ξ₁} {`Ξ₂} {`d₁} {`d₂} d) top = oops {A} {B} {`Ξ₁} {`Ξ₂} {`d₁} {`d₂}
  chsᴰ→ch (CHS.cup d)    top     = CH.cup
  chsᴰ→ch (CHS.cdown d)  top     = CH.cdown
  chsᴰ→ch (CHS.cpair d)  top     = CH.cpair
  chsᴰ→ch (CHS.cfst d)   top     = CH.cfst
  chsᴰ→ch (CHS.csnd d)   top     = CH.csnd
  chsᴰ→ch (CHS.unit d)   top     = CH.unit
  chsᴰ→ch (CHS.mp i j d) (pop k) = chsᴰ→ch d k
  chsᴰ→ch (CHS.ci d)     (pop k) = chsᴰ→ch d k
  chsᴰ→ch (CHS.ck d)     (pop k) = chsᴰ→ch d k
  chsᴰ→ch (CHS.cs d)     (pop k) = chsᴰ→ch d k
  chsᴰ→ch (CHS.nec `d d) (pop k) = chsᴰ→ch d k
  chsᴰ→ch (CHS.cdist d)  (pop k) = chsᴰ→ch d k
  chsᴰ→ch (CHS.cup d)    (pop k) = chsᴰ→ch d k
  chsᴰ→ch (CHS.cdown d)  (pop k) = chsᴰ→ch d k
  chsᴰ→ch (CHS.cpair d)  (pop k) = chsᴰ→ch d k
  chsᴰ→ch (CHS.cfst d)   (pop k) = chsᴰ→ch d k
  chsᴰ→ch (CHS.csnd d)   (pop k) = chsᴰ→ch d k
  chsᴰ→ch (CHS.unit d)   (pop k) = chsᴰ→ch d k

  -- FIXME: I can’t even postulate this.
  -- postulate
  --   ᴬlem₁ : ∀ {Ξ₁ Ξ₂ A B} {d₁ : CHS.⊢ᴰ Ξ₁ , A CHS.▻ B} {d₂ : CHS.⊢ᴰ Ξ₂ , A}
  --           → chsᴰ→ch (CHS.appᴰ d₁ d₂) ≡ CH.app (chsᴰ→ch d₁ top) (chsᴰ→ch d₂ top)

  postulate
    oops : ∀ {A B Ξ₁ Ξ₂} {d₁ : CHS.⊢ᴰ Ξ₁ , A CHS.▻ B} {d₂ : CHS.⊢ᴰ Ξ₂ , A}
           → CH.⊢ chsᴾ→chᴾ CHS.[ d₁ ] CH.⦂ (chsᵀ→chᵀ A CH.▻ chsᵀ→chᵀ B) CH.▻
                    chsᴾ→chᴾ CHS.[ d₂ ] CH.⦂ chsᵀ→chᵀ A CH.▻
                    chsᴾ→chᴾ CHS.[ CHS.appᴰ d₁ d₂ ] CH.⦂ chsᵀ→chᵀ B

  chs→ch : ∀ {A} → CHS.⊢ A → CH.⊢ (chsᵀ→chᵀ A)
  chs→ch (Ξ , d) = chsᴰ→ch d top

-- Translation from closed Hilbert-style to closed Hilbert-style sequential.

mutual
  chᵀ→chsᵀ : CH.Ty → CHS.Ty
  chᵀ→chsᵀ (CH.α P)   = CHS.α P
  chᵀ→chsᵀ (A CH.▻ B) = chᵀ→chsᵀ A CHS.▻ chᵀ→chsᵀ B
  chᵀ→chsᵀ (p CH.⦂ A) with chᴾ→chsᴾ p
  chᵀ→chsᵀ (p CH.⦂ A) | (Ξ , p′) = p′ CHS.⦂ chᵀ→chsᵀ A
  chᵀ→chsᵀ (A CH.∧ B) = chᵀ→chsᵀ A CHS.∧ chᵀ→chsᵀ B
  chᵀ→chsᵀ CH.⊤      = CHS.⊤

  chᴾ→chsᴾ : ∀ {A} → CH.Proof A → ∃ (λ Ξ → CHS.Proof Ξ (chᵀ→chsᵀ A))
  chᴾ→chsᴾ CH.[ d ] with ch→chs d
  chᴾ→chsᴾ CH.[ d ] | (Ξ , d′) = Ξ , CHS.[ d′ ]

  ch→chs : ∀ {A} → CH.⊢ A → CHS.⊢ (chᵀ→chsᵀ A)
  ch→chs (CH.app d₁ d₂) = CHS.app (ch→chs d₁) (ch→chs d₂)
  ch→chs CH.ci          = ∅ , CHS.ci CHS.nil
  ch→chs CH.ck          = ∅ , CHS.ck CHS.nil
  ch→chs CH.cs          = ∅ , CHS.cs CHS.nil
  ch→chs (CH.box d)     = CHS.box (ch→chs d)
  ch→chs CH.cdist       = ∅ , CHS.cdist CHS.nil
  ch→chs CH.cup         = ∅ , CHS.cup CHS.nil
  ch→chs CH.cdown       = ∅ , CHS.cdown CHS.nil
  ch→chs CH.cpair       = ∅ , CHS.cpair CHS.nil
  ch→chs CH.cfst        = ∅ , CHS.cfst CHS.nil
  ch→chs CH.csnd        = ∅ , CHS.csnd CHS.nil
  ch→chs CH.unit        = ∅ , CHS.unit CHS.nil


------------------------------------------------------------------------
-- Lemmas about the initial bag index
------------------------------------------------------------------------

module TotalParserCombinators.InitialBag where

open import Category.Monad
open import Data.List
import Data.List.Categorical
open import Data.List.Membership.Propositional using (_∈_)
open import Data.List.Membership.Propositional.Properties as M
  hiding (⊛-∈↔)
open import Data.List.Relation.Binary.BagAndSetEquality
  using () renaming (_∼[_]_ to _List-∼[_]_)
open import Data.List.Relation.Unary.Any
open import Data.List.Relation.Unary.Any.Properties
open import Data.Maybe hiding (_>>=_)
open import Data.Product
open import Data.Sum
open import Function.Base
open import Function.Equality using (_⟨$⟩_)
open import Function.Inverse as Inv using (_↔_)
import Function.Related as Related
open import Level
open import Relation.Binary.PropositionalEquality as P
  using (_≡_; refl)
open import Relation.Binary.HeterogeneousEquality as H
  using (refl) renaming (_≅_ to _≅′_)

open Inv.Inverse
open RawMonadPlus {f = zero} Data.List.Categorical.monadPlus
  using () renaming (_⊛_ to _⊛′_)
open Related using (SK-sym)

open import TotalParserCombinators.Parser
open import TotalParserCombinators.Semantics

------------------------------------------------------------------------
-- Optimisation

private

  abstract

    ⊛-∈↔ : ∀ {A B : Set} (fs : List (A → B)) {xs y} →
           (∃₂ λ f x → f ∈ fs × x ∈ xs × y ≡ f x) ↔ y ∈ (fs ⊛′ xs)
    ⊛-∈↔ = M.⊛-∈↔

------------------------------------------------------------------------
-- Sanity check: The initial set index is correctly defined

mutual

  complete : ∀ {Tok R xs x} {p : Parser Tok R xs} →
             x ∈ p · [] → x ∈ xs
  complete x∈p = complete′ x∈p refl

  private

    complete′ : ∀ {Tok R xs x s} {p : Parser Tok R xs} →
                x ∈ p · s → s ≡ [] → x ∈ xs
    complete′ return                                                    refl = to return↔            ⟨$⟩ refl
    complete′ (∣-left      x∈p₁)                                        refl = to ++↔                ⟨$⟩ inj₁ (complete x∈p₁)
    complete′ (∣-right xs₁ x∈p₂)                                        refl = to (++↔ {P = _≡_ _}
                                                                                {xs = xs₁})   ⟨$⟩ inj₂ (complete x∈p₂)
    complete′ (<$> x∈p)                                                 refl = to (map-∈↔ _)         ⟨$⟩ (_ , complete x∈p , refl)
    complete′ (_⊛_   {s₁ = []} {xs = just _}                f∈p₁ x∈p₂)  refl = to (⊛-∈↔ _)           ⟨$⟩ (_ , _ , complete f∈p₁
                                                                                , complete x∈p₂ , refl)
    complete′ (_>>=_ {s₁ = []} {xs = just xs} {f = just _}  x∈p₁ y∈p₂x) refl = to (>>=-∈↔ {xs = xs}) ⟨$⟩ (_ , complete x∈p₁
                                                                                , complete y∈p₂x)
    complete′ (cast {xs₁≈xs₂ = xs₁≈xs₂} x∈p)                            refl = to xs₁≈xs₂            ⟨$⟩ complete x∈p

    complete′ (_⊛_   {s₁ = []} {xs = nothing}               f∈p₁ x∈p₂)  refl with complete x∈p₂
    ... | ()
    complete′ (_>>=_ {s₁ = []} {xs = nothing}               x∈p₁ y∈p₂x) refl with complete x∈p₁
    ... | ()
    complete′ (_>>=_ {s₁ = []} {xs = just _}  {f = nothing} x∈p₁ y∈p₂x) refl with complete y∈p₂x
    ... | ()

    complete′ token                     ()
    complete′ (_⊛_    {s₁ = _ ∷ _} _ _) ()
    complete′ (_>>=_  {s₁ = _ ∷ _} _ _) ()
    complete′ (nonempty _)              ()

mutual

  sound : ∀ {Tok R xs x} (p : Parser Tok R xs) →
          x ∈ xs → x ∈ p · []
  sound (return x)              (here refl) = return
  sound (_∣_ {xs₁ = xs₁} p₁ p₂) x∈xs with from (++↔ {P = _≡_ _} {xs = xs₁}) ⟨$⟩ x∈xs
  ... | inj₁ x∈xs₁ = ∣-left      (sound p₁ x∈xs₁)
  ... | inj₂ x∈xs₂ = ∣-right xs₁ (sound p₂ x∈xs₂)
  sound (f <$> p) x∈xs with from (map-∈↔ f) ⟨$⟩ x∈xs
  ... | (y , y∈xs , refl) = <$> sound p y∈xs
  sound (_⊛_ {fs = fs} {just xs} p₁ p₂) y∈ys
    with from (⊛-∈↔ (flatten fs) {xs = xs}) ⟨$⟩ y∈ys
  sound (_⊛_ {fs = nothing} {just xs} p₁ p₂)  y∈ys | (f′ , x′ , ()    , x′∈xs , refl)
  sound (_⊛_ {fs = just fs} {just xs} p₁ p₂)  y∈ys | (f′ , x′ , f′∈fs , x′∈xs , refl) =
    _⊛_ {fs = ○} {xs = ○} (sound p₁ f′∈fs) (sound p₂ x′∈xs)
  sound (_>>=_ {xs = zs} {f = just f} p₁ p₂) y∈ys
    with from (>>=-∈↔ {xs = flatten zs} {f = f}) ⟨$⟩ y∈ys
  ... | (x , x∈zs , y∈fx) =
    _>>=_ {xs = zs} {f = just f} (sound p₁ x∈zs) (sound′ (p₂ x) x∈zs y∈fx)
  sound (cast xs₁≈xs₂ p) x∈xs = cast (sound p (from xs₁≈xs₂ ⟨$⟩ x∈xs))

  sound (return _)                 (there ())
  sound fail                       ()
  sound token                      ()
  sound (_⊛_   {xs = nothing} _ _) ()
  sound (_>>=_ {f  = nothing} _ _) ()
  sound (nonempty _)               ()

  private

    sound′ : ∀ {Tok R₁ R₂ x y xs} {zs : Maybe (List R₁)}
               (p : ∞⟨ zs ⟩Parser Tok R₂ xs) →
               x ∈ flatten zs → y ∈ xs → y ∈ ♭? p · []
    sound′ {zs = just _}  p _  = sound p
    sound′ {zs = nothing} p ()

mutual

  sound∘complete : ∀ {Tok R xs x} {p : Parser Tok R xs}
                   (x∈p : x ∈ p · []) →
                   sound p (complete x∈p) ≡ x∈p
  sound∘complete x∈p = H.≅-to-≡ (sound∘complete′ x∈p refl)

  private

    sound∘complete′ : ∀ {Tok R xs x s} {p : Parser Tok R xs}
                      (x∈p : x ∈ p · s) (s≡[] : s ≡ []) →
                      sound p (complete′ x∈p s≡[]) ≅′ x∈p
    sound∘complete′ return                                refl = refl
    sound∘complete′ (∣-left {xs₁ = xs₁} {xs₂ = xs₂} x∈p₁) refl
      rewrite left-inverse-of (++↔ {P = _≡_ _} {xs = xs₁} {ys = xs₂}) (inj₁ (complete x∈p₁)) =
        H.cong _∈_·_.∣-left (sound∘complete′ x∈p₁ refl)
    sound∘complete′ (∣-right xs₁ x∈p₂) refl
      rewrite left-inverse-of (++↔ {P = _≡_ _} {xs = xs₁}) (inj₂ (complete x∈p₂)) =
        H.cong (_∈_·_.∣-right xs₁) (sound∘complete′ x∈p₂ refl)
    sound∘complete′ (<$>_ {f = f} x∈p) refl
      rewrite left-inverse-of (map-∈↔ f) (_ , complete x∈p , refl) =
        H.cong _∈_·_.<$>_ (sound∘complete′ x∈p refl)
    sound∘complete′ (_⊛_ {s₁ = []} {fs = fs} {xs = just xs} f∈p₁ x∈p₂) refl
      with complete f∈p₁ | complete x∈p₂
      | from inv ⟨$⟩ (to inv ⟨$⟩ (_ , _ , complete f∈p₁ , complete x∈p₂ , refl))
      | left-inverse-of inv (_ , _ , complete f∈p₁ , complete x∈p₂ , refl)
      | sound∘complete f∈p₁ | sound∘complete x∈p₂
      where inv = ⊛-∈↔ (flatten fs) {xs = xs}
    sound∘complete′ (_⊛_ {s₁ = []} {fs = nothing} {xs = just xs} _ _) refl | () | _ | _ | _ | _ | _
    sound∘complete′ (_⊛_ {s₁ = []} {fs = just fs} {xs = just xs} {p₁ = p₁} {p₂ = p₂}
                         .(sound p₁ ∈fs) .(sound p₂ ∈xs)) refl
      | ∈fs | ∈xs | ._ | refl | refl | refl = refl
    sound∘complete′ (_>>=_ {x = x} {y = y} {s₁ = []} {xs = just _} {f = just f} {p₁ = p₁} {p₂ = p₂} x∈p₁ y∈p₂x) refl
      rewrite left-inverse-of (>>=-∈↔ {f = f}) (_ , complete x∈p₁ , complete y∈p₂x)
         with sound p₁ (complete x∈p₁)
            | sound∘complete x∈p₁
            | sound′ (p₂ x) (complete x∈p₁) (complete y∈p₂x)
            | helper (p₂ x) (complete x∈p₁) y∈p₂x
         where
         helper : ∀ {Tok R₁ R₂ x y ys} {xs : Maybe (List R₁)}
                  (p : ∞⟨ xs ⟩Parser Tok R₂ ys) →
                  (x∈xs : x ∈ flatten xs) (y∈p : y ∈ ♭? p · []) →
                  sound′ p x∈xs (complete y∈p) ≡ y∈p
         helper {xs = nothing} p () _
         helper {xs = just _}  p _  y∈p = sound∘complete y∈p
    ... | ._ | refl | ._ | refl = refl
    sound∘complete′ (cast {xs₁≈xs₂ = xs₁≈xs₂} x∈p)             refl with complete x∈p | sound∘complete x∈p
    sound∘complete′ (cast {xs₁≈xs₂ = xs₁≈xs₂} .(sound _ x∈xs)) refl | x∈xs | refl
      rewrite left-inverse-of xs₁≈xs₂ x∈xs = refl

    sound∘complete′ (_⊛_    {s₁ = []} {xs = nothing}              _    x∈p₂)  refl with complete x∈p₂
    ... | ()
    sound∘complete′ (_>>=_  {s₁ = []} {xs = nothing}              x∈p₁ y∈p₂x) refl with complete x∈p₁
    ... | ()
    sound∘complete′ (_>>=_  {s₁ = []} {xs = just _} {f = nothing} x∈p₁ y∈p₂x) refl with complete y∈p₂x
    ... | ()

    sound∘complete′ token                     ()
    sound∘complete′ (_⊛_    {s₁ = _ ∷ _} _ _) ()
    sound∘complete′ (_>>=_  {s₁ = _ ∷ _} _ _) ()
    sound∘complete′ (nonempty _)              ()

complete∘sound : ∀ {Tok R xs x}
                 (p : Parser Tok R xs) (x∈p : x ∈ xs) →
                 complete (sound p x∈p) ≡ x∈p
complete∘sound (return x)              (here refl) = refl
complete∘sound (_∣_ {xs₁ = xs₁} p₁ p₂) x∈xs
  with from             (++↔ {P = _≡_ _} {xs = xs₁}) ⟨$⟩ x∈xs
     | right-inverse-of (++↔ {P = _≡_ _} {xs = xs₁})     x∈xs
complete∘sound (_∣_ {xs₁ = xs₁} p₁ p₂) .(to ++↔                          ⟨$⟩ inj₁ x∈xs₁) | inj₁ x∈xs₁ | refl =
  P.cong (_⟨$⟩_ (to ++↔)                          ∘ inj₁) $ complete∘sound p₁ x∈xs₁
complete∘sound (_∣_ {xs₁ = xs₁} p₁ p₂) .(to (++↔ {P = _≡_ _} {xs = xs₁}) ⟨$⟩ inj₂ x∈xs₂) | inj₂ x∈xs₂ | refl =
  P.cong (_⟨$⟩_ (to (++↔ {P = _≡_ _} {xs = xs₁})) ∘ inj₂) $ complete∘sound p₂ x∈xs₂
complete∘sound (f <$> p) x∈xs
  with             from (map-∈↔ f) ⟨$⟩ x∈xs
     | right-inverse-of (map-∈↔ f)     x∈xs
complete∘sound (f <$> p) .(to (map-∈↔ f) ⟨$⟩ (y , y∈xs , refl)) | (y , y∈xs , refl) | refl =
  P.cong (λ y∈ → to (map-∈↔ _) ⟨$⟩ (y , y∈ , refl))
         (complete∘sound p y∈xs)
complete∘sound (_⊛_ {fs = fs} {just xs} p₁ p₂) y∈ys
  with from             (⊛-∈↔ (flatten fs) {xs = xs}) ⟨$⟩ y∈ys
     | right-inverse-of (⊛-∈↔ (flatten fs) {xs = xs})     y∈ys
complete∘sound (_⊛_ {fs = nothing} {xs = just xs} p₁ p₂)
               y∈ys                                                | (f′ , x′ , ()    , x′∈xs , refl) | _
complete∘sound (_⊛_ {fs = just fs} {xs = just xs} p₁ p₂)
               .(to (⊛-∈↔ _) ⟨$⟩ (f′ , x′ , f′∈fs , x′∈xs , refl)) | (f′ , x′ , f′∈fs , x′∈xs , refl) | refl =
  P.cong₂ (λ f′∈ x′∈ → to (⊛-∈↔ _) ⟨$⟩ (f′ , x′ , f′∈ , x′∈ , refl))
          (complete∘sound p₁ f′∈fs)
          (complete∘sound p₂ x′∈xs)
complete∘sound (_>>=_ {xs = zs}      {just f} p₁ p₂) y∈ys
  with from             (>>=-∈↔ {xs = flatten zs} {f = f}) ⟨$⟩ y∈ys
     | right-inverse-of (>>=-∈↔ {xs = flatten zs} {f = f})     y∈ys
complete∘sound (_>>=_ {xs = nothing} {just f} p₁ p₂) ._                                           | (x , ()   , y∈fx) | refl
complete∘sound (_>>=_ {xs = just zs} {just f} p₁ p₂) .(to (>>=-∈↔ {f = f}) ⟨$⟩ (x , x∈zs , y∈fx)) | (x , x∈zs , y∈fx) | refl =
  P.cong₂ (λ x∈ y∈ → to (>>=-∈↔ {f = f}) ⟨$⟩ (x , x∈ , y∈))
          (complete∘sound p₁ x∈zs)
          (complete∘sound (p₂ x) y∈fx)
complete∘sound (cast xs₁≈xs₂ p) x∈xs
  rewrite complete∘sound p (from xs₁≈xs₂ ⟨$⟩ x∈xs) =
    right-inverse-of xs₁≈xs₂ x∈xs

complete∘sound (return _)                 (there ())
complete∘sound fail                       ()
complete∘sound token                      ()
complete∘sound (_⊛_   {xs = nothing} _ _) ()
complete∘sound (_>>=_ {f  = nothing} _ _) ()
complete∘sound (nonempty _)               ()

correct : ∀ {Tok R xs x} {p : Parser Tok R xs} → x ∈ p · [] ↔ x ∈ xs
correct {p = p} = record
  { to         = P.→-to-⟶ complete
  ; from       = P.→-to-⟶ $ sound p
  ; inverse-of = record
    { left-inverse-of  = sound∘complete
    ; right-inverse-of = complete∘sound p
    }
  }

------------------------------------------------------------------------
-- Equal parsers have equal initial bags/sets

-- Note that this property holds also for the subbag and subset
-- relations.

cong : ∀ {k Tok R xs₁ xs₂}
         {p₁ : Parser Tok R xs₁} {p₂ : Parser Tok R xs₂} →
       p₁ ∼[ k ] p₂ → initial-bag p₁ List-∼[ k ] initial-bag p₂
cong {xs₁ = xs₁} {xs₂} {p₁} {p₂} p₁≈p₂ {x} =
  (x ∈ xs₁)    ↔⟨ SK-sym correct ⟩
  x ∈ p₁ · []  ∼⟨ p₁≈p₂ ⟩
  x ∈ p₂ · []  ↔⟨ correct ⟩
  (x ∈ xs₂)    ∎
  where open Related.EquationalReasoning


{-# OPTIONS --without-K #-}
module Model.Type.Core where

open import Cats.Category
open import Relation.Binary using (IsEquivalence)

open import Model.RGraph as RG using (RGraph)
open import Util.HoTT.Equiv
open import Util.HoTT.FunctionalExtensionality
open import Util.HoTT.HLevel
open import Util.HoTT.Homotopy
open import Util.HoTT.Univalence
open import Util.Prelude hiding (id) renaming (_∘_ to _∘F_)
open import Util.Relation.Binary.LogicalEquivalence using
  ( _↔_ ; forth ; back ; ↔-reflexive )
open import Util.Relation.Binary.PropositionalEquality using
  ( Σ-≡⁺ ; Σ-≡⁻ ; cast ; subst-subst ; subst-sym-subst ; subst-subst-sym )

open Category._≅_ public
open RG._⇒_

infixr 0 _⇒_
infix  4 _≈_ _≈⟦Type⟧_
infixr 9 _∘_

private
  variable Δ Γ Ψ : RGraph

-- This is an RGraph-indexed family of RGraphs.
record ⟦Type⟧ (Δ : RGraph) : Set₁ where
  no-eta-equality
  field
    ObjHSet : Δ .RG.Obj → HSet 0ℓ

  private
    module M₀ δ = HLevel (ObjHSet δ)
    module M₁ {δ} = HLevel (ObjHSet δ)

  open M₀ public using () renaming
    ( type to Obj )
  open M₁ public using () renaming
    ( level to Obj-IsSet )

  field
    eqHProp : ∀ {δ δ′} → Δ .RG.eq δ δ′ → Obj δ → Obj δ′ → HProp 0ℓ

  private
    module M₂ {δ δ′} (δ≈δ′ : Δ .RG.eq δ δ′) x y   = HLevel (eqHProp δ≈δ′ x y)
    module M₃ {δ δ′} {δ≈δ′ : Δ .RG.eq δ δ′} {x y} = HLevel (eqHProp δ≈δ′ x y)

  open M₂ public using () renaming
    ( type to eq )
  open M₃ public using () renaming
    ( level to eq-IsProp )

  field
    eq-refl : ∀ {δ} (x : Obj δ) → eq (Δ .RG.eq-refl δ) x x

open ⟦Type⟧ public

private
  variable T U V W : ⟦Type⟧ Δ

open RGraph

transportEq : ∀ (T : ⟦Type⟧ Δ) {δ γ} {δ≈γ₀ δ≈γ₁ : Δ .eq δ γ} {x y}
  → T .eq δ≈γ₀ x y → T .eq δ≈γ₁ x y
transportEq {Δ} T = subst (λ p → T .eq p _ _) (Δ .eq-IsProp _ _)

transportObj : ∀ (T : ⟦Type⟧ Δ) {δ γ}
  → δ ≡ γ
  → T .Obj δ
  → T .Obj γ
transportObj T = subst (T .Obj)

abstract
  transportObj-resp : ∀ (T : ⟦Type⟧ Δ) {δ γ}
    → (δ≡γ₀ δ≡γ₁ : δ ≡ γ)
    → ∀ {x y}
    → x ≡ y
    → transportObj T δ≡γ₀ x ≡ transportObj T δ≡γ₁ y
  transportObj-resp {Δ} T refl δ≡γ₁ x≡y
    rewrite Δ .Obj-IsSet δ≡γ₁ refl = x≡y

transportObj-resp-eq : ∀ (T : ⟦Type⟧ Δ) {δ₀ γ₀ δ₁ γ₁}
  → (δ₀≡γ₀ : δ₀ ≡ γ₀) (δ₁≡γ₁ : δ₁ ≡ γ₁)
  → ∀ {x y} {δ₀≈δ₁ : Δ .eq δ₀ δ₁} {γ₀≈γ₁ : Δ .eq γ₀ γ₁}
  → T .eq δ₀≈δ₁ x y
  → T .eq γ₀≈γ₁ (transportObj T δ₀≡γ₀ x) (transportObj T δ₁≡γ₁ y)
transportObj-resp-eq {Δ} T refl refl {δ₀≈δ₁ = δ₀≈δ₁} {γ₀≈γ₁} x≈y
  = transportEq T x≈y

abstract
  transportObj∘transportObj : ∀ (T : ⟦Type⟧ Δ) {δ δ′ δ″}
    → (p : δ ≡ δ′) (q : δ′ ≡ δ″) {x : T .Obj δ}
    → transportObj T q (transportObj T p x) ≡ transportObj T (trans p q) x
  transportObj∘transportObj T p q = subst-subst p

  transportObj-refl : ∀ (T : ⟦Type⟧ Δ) {δ}
    → (p : δ ≡ δ) {x : T .Obj δ}
    → transportObj T p x ≡ x
  transportObj-refl {Δ} T p rewrite Δ .Obj-IsSet p refl = refl

record _⇒_ (T U : ⟦Type⟧ Δ) : Set where
  no-eta-equality
  field
    fobj : ∀ {δ} → Obj T δ → Obj U δ
    feq : ∀ {δ δ′} (δ≈δ′ : Δ .RG.eq δ δ′) {x y}
      → eq T δ≈δ′ x y
      → eq U δ≈δ′ (fobj x) (fobj y)

open _⇒_ public

record _≈_ (f g : T ⇒ U) : Set where
  no-eta-equality
  constructor ≈⁺
  field
    ≈⁻ : ∀ δ (x : Obj T δ) → f .fobj x ≡ g .fobj x

open _≈_ public

≈-isEquivalence : (T U : ⟦Type⟧ Δ) → IsEquivalence (_≈_ {T = T} {U})
≈-isEquivalence T U = record
  { refl = ≈⁺ λ γ x → refl
  ; sym = λ f≈g → ≈⁺ λ γ x → sym (f≈g .≈⁻ γ x)
  ; trans = λ f≈g g≈h → ≈⁺ λ γ x → trans (f≈g .≈⁻ γ x) (g≈h .≈⁻ γ x)
  }

⇒Canon : (T U : ⟦Type⟧ Δ) → Set
⇒Canon {Δ} T U
  = Σ[ fobj ∈ (∀ {δ} → T .Obj δ → U .Obj δ) ]
      (∀ {δ δ′} (δ≈δ′ : Δ .RG.eq δ δ′) {x y}
        → T .eq δ≈δ′ x y → U .eq δ≈δ′ (fobj x) (fobj y))

⇒≅⇒Canon : (T ⇒ U) ≅ ⇒Canon T U
⇒≅⇒Canon = record
  { forth = λ f → f .fobj , f .feq
  ; isIso = record
    { back = λ f → record { fobj = f .proj₁ ; feq = f .proj₂ }
    ; back∘forth = λ where
        record { fobj = fo ; feq = fe } → refl
    ; forth∘back = λ x → refl
    }
  }

⇒Canon-IsSet : (T U : ⟦Type⟧ Δ) → IsSet (⇒Canon T U)
⇒Canon-IsSet T U = Σ-IsSet
  (∀∙-IsSet λ δ → →-IsSet (U .Obj-IsSet))
  (λ _ → ∀∙-IsSet λ δ → ∀∙-IsSet λ δ′ → ∀-IsSet λ δ≈δ′ → ∀∙-IsSet λ x
    → ∀∙-IsSet λ y → →-IsSet (IsProp→IsSet (U .eq-IsProp)))

⇒-IsSet : IsSet (T ⇒ U)
⇒-IsSet {T = T} {U} = ≅-pres-IsOfHLevel 2 (≅-sym ⇒≅⇒Canon) (⇒Canon-IsSet T U)

≈→≡Canon : {f g : T ⇒ U}
  → f ≈ g → ⇒≅⇒Canon .forth f ≡ ⇒≅⇒Canon .forth g
≈→≡Canon {U = U} f≈g = Σ-≡⁺
  ( (funext∙ (funext (λ x → f≈g .≈⁻ _ x)))
  , funext∙ (funext∙ (funext λ a → funext∙ (funext∙
      (funext λ eq → U .eq-IsProp _ _)))) )

≈→≡ : {f g : T ⇒ U} → f ≈ g → f ≡ g
≈→≡ f≈g = ≅-Injective ⇒≅⇒Canon (≈→≡Canon f≈g)

private
  open module M₀ {Δ} {T U : ⟦Type⟧ Δ}
    = IsEquivalence (≈-isEquivalence T U)
    public using () renaming
    ( refl to ≈-refl
    ; sym to ≈-sym
    ; trans to ≈-trans
    ; reflexive to ≈-reflexive )

id : {T : ⟦Type⟧ Δ} → T ⇒ T
id = record
  { fobj = λ x → x
  ; feq = λ γ≈γ′ x → x
  }

_∘_ : {T U V : ⟦Type⟧ Δ} → U ⇒ V → T ⇒ U → T ⇒ V
_∘_ {Γ} f g = record
  { fobj = f .fobj ∘F g .fobj
  ; feq = λ γ≈γ′ → f .feq γ≈γ′ ∘F g .feq γ≈γ′
  }

⟦Types⟧ : RGraph → Category (lsuc 0ℓ) 0ℓ 0ℓ
⟦Types⟧ Δ = record
  { Obj = ⟦Type⟧ Δ
  ; _⇒_ = _⇒_
  ; _≈_ = _≈_
  ; id = id
  ; _∘_ = _∘_
  ; equiv = ≈-isEquivalence _ _
  ; ∘-resp = λ {Δ Γ Ψ f g h i} f≈g h≈i
    → ≈⁺ λ γ x → trans (f≈g .≈⁻ γ (h .fobj x)) (cong (g .fobj) (h≈i .≈⁻ γ x))
  ; id-r = ≈⁺ λ γ x → refl
  ; id-l = ≈⁺ λ γ x → refl
  ; assoc = ≈⁺ λ γ x → refl
  }

module ⟦Types⟧ {Γ} = Category (⟦Types⟧ Γ)

_≈⟦Type⟧_ : (T U : ⟦Type⟧ Δ) → Set₁
_≈⟦Type⟧_ = ⟦Types⟧._≅_

private
  open module M₁ {Δ} = ⟦Types⟧.≅ {Δ} public using () renaming
    ( refl to ≈⟦Type⟧-refl
    ; sym to ≈⟦Type⟧-sym
    ; trans to ≈⟦Type⟧-trans
    ; reflexive to ≈⟦Type⟧-reflexive )

module ≅-Reasoning = ⟦Types⟧.≅-Reasoning
module ≈-Reasoning = ⟦Types⟧.≈-Reasoning

⟦Type⟧Canon : RGraph → Set₁
⟦Type⟧Canon Δ
  = Σ[ ObjHSet ∈ (Δ .Obj → HSet 0ℓ) ]
    Σ[ eq ∈ (∀ {δ δ′} (δ≈δ′ : Δ .eq δ δ′)
        → (x : ObjHSet δ .type) (y : ObjHSet δ′ .type) → HProp 0ℓ) ]
    (∀ {δ} (x : ObjHSet δ .type) → eq (Δ .eq-refl δ) x x .type)

⟦Type⟧≅⟦Type⟧Canon : ∀ {Δ} → ⟦Type⟧ Δ ≅ ⟦Type⟧Canon Δ
⟦Type⟧≅⟦Type⟧Canon {Δ} = record
  { forth = λ T → T .ObjHSet , T .eqHProp , T .eq-refl
  ; isIso = record
    { back = λ T → record
      { ObjHSet = T .proj₁
      ; eqHProp = T .proj₂ .proj₁
      ; eq-refl = T .proj₂ .proj₂
      }
    ; back∘forth = λ where
        record { ObjHSet = x ; eqHProp = y ; eq-refl = z } → refl
    ; forth∘back = λ x → refl
    }
  }

proj₁∘subst : ∀ {α β γ} {A : Set α} (B : A → Set β) (C : ∀ a → B a → Set γ)
  → ∀ {a a′} (p : a ≡ a′) (x : Σ (B a) (C a))
  → proj₁ (subst (λ a → Σ (B a) (C a)) p x) ≡ subst B p (proj₁ x)
proj₁∘subst B C refl x = refl

≈⟦Type⟧→≡Canon
  : T ≈⟦Type⟧ U
  → ⟦Type⟧≅⟦Type⟧Canon .forth T ≡ ⟦Type⟧≅⟦Type⟧Canon .forth U
≈⟦Type⟧→≡Canon {Δ} {T} {U} T≈U
  = Σ-≡⁺ (T≡U , Σ-≡⁺ (T≈≡U≈ , funext∙ (funext (λ x → U .eq-IsProp _ _))))
  where
    T≅U : ∀ δ → T .Obj δ ≅ U .Obj δ
    T≅U δ = record
      { forth = T≈U .forth .fobj
      ; isIso = record
        { back = T≈U .back .fobj
        ; back∘forth = λ x → T≈U .back-forth .≈⁻ _ _
        ; forth∘back = λ x → T≈U .forth-back .≈⁻ _ _
        }
      }

    T≡U : T .ObjHSet ≡ U .ObjHSet
    T≡U = funext λ δ → HLevel-≡⁺ _ _ (≅→≡ (T≅U δ))

    -- "HoTT makes everything so much nicer", they said. "It's all automatic",
    -- they said.
    abstract
      subst-type : ∀ {α n} (A B : HLevel n α)
        → (p : A .type ≡ B .type)
        → (x : A .type)
        → subst type (HLevel-≡⁺ A B p) x ≡ cast p x
      subst-type A B refl x with IsOfHLevel-IsProp _ (A .level) (B .level)
      ... | refl = refl

      -- I believe this equation would be definitional in Cubical TT.
      subst-T≡U : ∀ {δ} x
        → subst (λ T → T δ .type) T≡U x ≡ T≈U .forth .fobj x
      subst-T≡U {δ} x
        = trans (subst-funext (λ δ T → T .type) _ x)
          (trans (subst-type (T .ObjHSet δ) (U .ObjHSet δ) (≅→≡ (T≅U δ)) x)
            (cast-≅→≡ (T≅U δ)))

      go : (Δ : Set) (T U : Δ → HSet 0ℓ) (eqΔ : Δ → Δ → Set)
        → (eqT : ∀ δ δ′ → eqΔ δ δ′ → T δ .type → T δ′ .type → HProp 0ℓ)
        → (eqU : ∀ δ δ′ → eqΔ δ δ′ → U δ .type → U δ′ .type → HProp 0ℓ)
        → (T≡U : T ≡ U)
        → (∀ δ δ′ (δ≈δ′ : eqΔ δ δ′) (x : T δ .type) (y : T δ′ .type)
            → eqT _ _ δ≈δ′ x y .type
            ↔ eqU _ _ δ≈δ′
                (subst (λ T → T δ .type) T≡U x)
                (subst (λ T → T δ′ .type) T≡U y)
                .type)
        → _≡_ {A = ∀ {δ δ′} → eqΔ δ δ′ → U δ .type → U δ′ .type → HProp 0ℓ}
            (subst (λ T → ∀ {δ δ′} → eqΔ δ δ′ → T δ .type → T δ′ .type → HProp 0ℓ)
              T≡U (λ {δ δ′} → eqT δ δ′))
            (λ {δ δ′} → eqU δ δ′)
      go Δ T U eqΔ eqT eqU refl eq = funext∙ λ {δ} → funext∙ λ {δ′}
        → funext λ δ≈δ′ → funext λ x → funext λ y
        → HProp-≡⁺ _ _ (eq δ δ′ δ≈δ′ x y)

      T≈≡U≈ : _
      T≈≡U≈
        = trans
            (proj₁∘subst
              (λ T → ∀ {δ δ′} → Δ .eq δ δ′ → T δ .type → T δ′ .type → HProp 0ℓ)
              (λ T eq → ∀ {δ} (x : T δ .type) → eq (Δ .eq-refl δ) x x .type)
              T≡U
              ((λ {δ δ′} → T .eqHProp {δ} {δ′}), (λ {δ} x → T .eq-refl {δ} x)))
            (go (Δ .Obj) (T .ObjHSet) (U .ObjHSet) (Δ .eq)
              (λ δ δ′ → T .eqHProp {δ} {δ′})
              (λ δ δ′ → U .eqHProp {δ} {δ′})
              T≡U
              λ δ δ′ δ≈δ′ x y → record
                { forth = λ x≈y
                    → subst₂ (λ x y → U .eq δ≈δ′ x y) (sym (subst-T≡U x))
                        (sym (subst-T≡U y)) (T≈U .forth .feq δ≈δ′ x≈y)
                ; back = λ x≈y
                    → subst₂ (λ x y → T .eq δ≈δ′ x y)
                        (trans (cong (T≈U .back .fobj) (subst-T≡U x))
                          (T≈U .back-forth .≈⁻ δ x))
                        (trans (cong (T≈U .back .fobj) (subst-T≡U y))
                          (T≈U .back-forth .≈⁻ δ′ y))
                        (T≈U .back .feq δ≈δ′ x≈y)
                })

≈⟦Type⟧→≡ : T ≈⟦Type⟧ U → T ≡ U
≈⟦Type⟧→≡ T≈U = ≅-Injective ⟦Type⟧≅⟦Type⟧Canon (≈⟦Type⟧→≡Canon T≈U)

subT : ∀ {Δ Ω} → Δ RG.⇒ Ω → ⟦Type⟧ Ω → ⟦Type⟧ Δ
subT {Γ} {Ω} f T = record
  { ObjHSet = T .ObjHSet ∘F f .fobj
  ; eqHProp = T .eqHProp ∘F f .feq
  ; eq-refl = λ x
      → subst (λ p → T .eq p x x) (Ω .eq-IsProp _ _) (T .eq-refl x)
  }

subt : ∀ {Δ Ω} (f : Δ RG.⇒ Ω) {T U : ⟦Type⟧ Ω}
  → T ⇒ U
  → subT f T ⇒ subT f U
subt f g = record
  { fobj = g .fobj
  ; feq = λ γ≈γ′ → g .feq (f .feq γ≈γ′)
  }

subt-∘ : ∀ {Δ Ω} (f : Δ RG.⇒ Ω) {T U V : ⟦Type⟧ Ω}
  → (g : U ⇒ V) (h : T ⇒ U)
  → subt f (g ∘ h) ≈ subt f g ∘ subt f h
subt-∘ f g h = ≈⁺ λ δ γ → refl

subT∘subT : ∀ {Δ Γ Ψ}
  → {f : Δ RG.⇒ Ψ} {g : Γ RG.⇒ Δ} {T : ⟦Type⟧ Ψ}
  → subT g (subT f T) ≈⟦Type⟧ subT (f RG.∘ g) T
subT∘subT = record
  { forth = record { fobj = λ x → x ; feq = λ _ x → x }
  ; back = record { fobj = λ x → x ; feq = λ _ x → x }
  ; back-forth = ≈⁺ λ γ x → refl
  ; forth-back = ≈⁺ λ γ x → refl
  }

castObj : {T U : ⟦Type⟧ Δ} → T ≡ U → ∀ {δ} → Obj T δ → Obj U δ
castObj p {δ} = subst (λ T → Obj T δ) p

≡→≈⟦Type⟧ : {T U : ⟦Type⟧ Δ} → T ≡ U → T ≈⟦Type⟧ U
≡→≈⟦Type⟧ {Δ} {T} {U} T≡U = record
  { forth = record
    { fobj = λ {δ} → castObj T≡U
    ; feq = λ δ≈δ′ x≈y → go T≡U x≈y
    }
  ; back = record
    { fobj = λ {δ} → castObj (sym T≡U)
    ; feq = λ δ≈δ′ x≈y → go (sym T≡U) x≈y
    }
  ; back-forth = ≈⁺ λ δ x → subst-sym-subst T≡U
  ; forth-back = ≈⁺ λ δ x → subst-subst-sym T≡U
  }
  where
    go : {T U : ⟦Type⟧ Δ} (p : T ≡ U) → ∀ {δ δ′} {δ≈δ′ : Δ .eq δ δ′} {x y}
      → eq T δ≈δ′ x y
      → eq U δ≈δ′ (castObj p x) (castObj p y)
    go refl x≈y = x≈y


open import Agda.Builtin.Bool
open import Agda.Builtin.List
open import Agda.Builtin.Reflection
open import Agda.Builtin.Unit

P : Bool → Set
P true  = Bool
P false = Bool

f : (b : Bool) → P b
f true  = true
f false = false

pattern varg x = arg (arg-info visible relevant) x

create-constraint : TC Set
create-constraint =
  unquoteTC (def (quote P)
               (varg (def (quote f) (varg unknown ∷ [])) ∷ []))

macro

  should-fail : Term → TC ⊤
  should-fail _ =
    bindTC (noConstraints create-constraint) λ _ →
    returnTC tt

test : ⊤
test = should-fail


open import SOAS.Common
open import SOAS.Families.Core
open import Categories.Object.Initial
open import SOAS.Coalgebraic.Strength
import SOAS.Metatheory.MetaAlgebra

-- Substitution structure by initiality
module SOAS.Metatheory.Substitution {T : Set}
  (⅀F : Functor 𝔽amiliesₛ 𝔽amiliesₛ) (⅀:Str : Strength ⅀F)
  (𝔛 : Familyₛ) (open SOAS.Metatheory.MetaAlgebra ⅀F 𝔛)
  (𝕋:Init : Initial 𝕄etaAlgebras)
  where

open import SOAS.Context
open import SOAS.Variable
open import SOAS.Abstract.Hom
import SOAS.Abstract.Coalgebra as →□ ; open →□.Sorted
import SOAS.Abstract.Box as □ ; open □.Sorted

open import SOAS.Abstract.Monoid

open import SOAS.Coalgebraic.Map
open import SOAS.Coalgebraic.Monoid
open import SOAS.Coalgebraic.Lift

open import SOAS.Metatheory.Algebra ⅀F
open import SOAS.Metatheory.Semantics ⅀F ⅀:Str 𝔛 𝕋:Init
open import SOAS.Metatheory.Traversal ⅀F ⅀:Str 𝔛 𝕋:Init
open import SOAS.Metatheory.Renaming ⅀F ⅀:Str 𝔛 𝕋:Init
open import SOAS.Metatheory.Coalgebraic ⅀F ⅀:Str 𝔛 𝕋:Init

open Strength ⅀:Str

private
  variable
    Γ Δ : Ctx
    α β : T

-- Substitution is a 𝕋-parametrised traversal into 𝕋
module Substitution = Traversal 𝕋ᴮ 𝕒𝕝𝕘 id 𝕞𝕧𝕒𝕣

𝕤𝕦𝕓 : 𝕋 ⇾̣ 〖 𝕋 , 𝕋 〗
𝕤𝕦𝕓 = Substitution.𝕥𝕣𝕒𝕧

-- The renaming and algebra structures on 𝕋 are compatible, so 𝕤𝕦𝕓 is coalgebraic
𝕤𝕦𝕓ᶜ : Coalgebraic 𝕋ᴮ 𝕋ᴮ 𝕋ᴮ 𝕤𝕦𝕓
𝕤𝕦𝕓ᶜ = Travᶜ.𝕥𝕣𝕒𝕧ᶜ 𝕋ᴮ 𝕒𝕝𝕘 id 𝕞𝕧𝕒𝕣 𝕋ᴮ idᴮ⇒ Renaming.𝕤𝕖𝕞ᵃ⇒

module 𝕤𝕦𝕓ᶜ = Coalgebraic 𝕤𝕦𝕓ᶜ

-- Compatibility of renaming and substitution
compat : {ρ : Γ ↝ Δ} (t : 𝕋 α Γ) → 𝕣𝕖𝕟 t ρ ≡ 𝕤𝕦𝕓 t (𝕧𝕒𝕣 ∘ ρ)
compat {ρ = ρ} t =  begin 𝕣𝕖𝕟 t ρ           ≡˘⟨ 𝕥𝕣𝕒𝕧-η≈id 𝕋ᴮ id refl ⟩
                          𝕤𝕦𝕓 (𝕣𝕖𝕟 t ρ) 𝕧𝕒𝕣  ≡⟨ 𝕤𝕦𝕓ᶜ.f∘r ⟩
                          𝕤𝕦𝕓 t (𝕧𝕒𝕣 ∘ ρ)   ∎ where open ≡-Reasoning

-- Substitution associativity law
𝕤𝕦𝕓-comp : MapEq₂ 𝕋ᴮ 𝕋ᴮ 𝕒𝕝𝕘 (λ t σ ς → 𝕤𝕦𝕓 (𝕤𝕦𝕓 t σ) ς)
                           (λ t σ ς → 𝕤𝕦𝕓 t (λ v → 𝕤𝕦𝕓 (σ v) ς))
𝕤𝕦𝕓-comp = record
  { φ = id
  ; ϕ = 𝕤𝕦𝕓
  ; χ = 𝕞𝕧𝕒𝕣
  ; f⟨𝑣⟩ = 𝕥≈₁ 𝕥⟨𝕧⟩
  ; f⟨𝑚⟩ = trans (𝕥≈₁ 𝕥⟨𝕞⟩) 𝕥⟨𝕞⟩
  ; f⟨𝑎⟩ = λ{ {σ = σ}{ς}{t} → begin
        𝕤𝕦𝕓 (𝕤𝕦𝕓 (𝕒𝕝𝕘 t) σ) ς
    ≡⟨ 𝕥≈₁ 𝕥⟨𝕒⟩ ⟩
        𝕤𝕦𝕓 (𝕒𝕝𝕘 (str 𝕋ᴮ 𝕋 (⅀₁ 𝕤𝕦𝕓 t) σ)) ς
    ≡⟨ 𝕥⟨𝕒⟩ ⟩
        𝕒𝕝𝕘 (str 𝕋ᴮ 𝕋 (⅀₁ 𝕤𝕦𝕓 (str 𝕋ᴮ 𝕋 (⅀₁ 𝕤𝕦𝕓 t) σ)) ς)
    ≡˘⟨ congr (str-nat₂ 𝕤𝕦𝕓 (⅀₁ 𝕤𝕦𝕓 t) σ) (λ - → 𝕒𝕝𝕘 (str 𝕋ᴮ 𝕋 - ς)) ⟩
        𝕒𝕝𝕘 (str 𝕋ᴮ 𝕋 (str 𝕋ᴮ 〖 𝕋 , 𝕋 〗 (⅀.F₁ (λ { h ς → 𝕤𝕦𝕓 (h ς) }) (⅀₁ 𝕤𝕦𝕓 t)) σ) ς)
    ≡˘⟨ congr ⅀.homomorphism (λ - → 𝕒𝕝𝕘 (str 𝕋ᴮ 𝕋 (str 𝕋ᴮ 〖 𝕋 , 𝕋 〗 - σ) ς)) ⟩
        𝕒𝕝𝕘 (str 𝕋ᴮ 𝕋 (str 𝕋ᴮ 〖 𝕋 , 𝕋 〗 (⅀₁ (λ{ t σ → 𝕤𝕦𝕓 (𝕤𝕦𝕓 t σ)}) t) σ) ς)
    ∎ }
  ; g⟨𝑣⟩ = 𝕥⟨𝕧⟩
  ; g⟨𝑚⟩ = 𝕥⟨𝕞⟩
  ; g⟨𝑎⟩ = λ{ {σ = σ}{ς}{t} → begin
        𝕤𝕦𝕓 (𝕒𝕝𝕘 t) (λ v → 𝕤𝕦𝕓 (σ v) ς)
    ≡⟨ 𝕥⟨𝕒⟩ ⟩
        𝕒𝕝𝕘 (str 𝕋ᴮ 𝕋 (⅀₁ 𝕤𝕦𝕓 t) (λ v → 𝕤𝕦𝕓 (σ v) ς))
    ≡⟨ cong 𝕒𝕝𝕘 (str-dist 𝕋 𝕤𝕦𝕓ᶜ (⅀₁ 𝕤𝕦𝕓 t) (λ {τ} z → σ z) ς) ⟩
        𝕒𝕝𝕘 (str 𝕋ᴮ 𝕋 (str 𝕋ᴮ 〖 𝕋 , 𝕋 〗 (⅀.F₁ (precomp 𝕋 𝕤𝕦𝕓) (⅀₁ 𝕤𝕦𝕓 t)) σ) ς)
    ≡˘⟨ congr ⅀.homomorphism (λ - → 𝕒𝕝𝕘 (str 𝕋ᴮ 𝕋 (str 𝕋ᴮ 〖 𝕋 , 𝕋 〗 - σ) ς)) ⟩
        𝕒𝕝𝕘 (str 𝕋ᴮ 𝕋 (str 𝕋ᴮ 〖 𝕋 , 𝕋 〗 (⅀₁ (λ{ t σ ς → 𝕤𝕦𝕓 t (λ v → 𝕤𝕦𝕓 (σ v) ς)}) t) σ) ς)
    ∎ }
  } where open ≡-Reasoning ; open Substitution

-- Coalgebraic monoid structure on 𝕋
𝕋ᵐ : Mon 𝕋
𝕋ᵐ = record
  { η = 𝕧𝕒𝕣
  ; μ = 𝕤𝕦𝕓
  ; lunit = Substitution.𝕥⟨𝕧⟩
  ; runit = λ{ {t = t} → trans (𝕥𝕣𝕒𝕧-η≈𝕤𝕖𝕞 𝕋ᴮ 𝕋ᵃ id refl) 𝕤𝕖𝕞-id }
  ; assoc = λ{ {t = t} → MapEq₂.≈ 𝕤𝕦𝕓-comp t }
  }

open Mon 𝕋ᵐ using ([_/] ; [_,_/]₂ ; lunit ; runit ; assoc) public

𝕋ᴹ : CoalgMon 𝕋
𝕋ᴹ = record { ᴮ = 𝕋ᴮ ; ᵐ = 𝕋ᵐ ; η-compat = refl ; μ-compat = λ{ {t = t} → compat t } }

-- Corollaries: renaming and simultaneous substitution commutes with
-- single-variable substitution
open import SOAS.ContextMaps.Combinators
𝕣𝕖𝕟[/] : (ρ : Γ ↝ Δ)(b : 𝕋 α (β ∙ Γ))(a : 𝕋 β Γ)
      → 𝕣𝕖𝕟 ([ a /] b) ρ ≡ [ (𝕣𝕖𝕟 a ρ) /] (𝕣𝕖𝕟 b (rlift _ ρ))
𝕣𝕖𝕟[/] ρ b a = begin
      𝕣𝕖𝕟 ([ a /] b) ρ
  ≡⟨ 𝕤𝕦𝕓ᶜ.r∘f ⟩
      𝕤𝕦𝕓 b (λ v → 𝕣𝕖𝕟 (add 𝕋 a 𝕧𝕒𝕣 v) ρ)
  ≡⟨ cong (𝕤𝕦𝕓 b) (dext (λ{ new → refl ; (old y) → Renaming.𝕥⟨𝕧⟩})) ⟩
      𝕤𝕦𝕓 b (λ v → add 𝕋 (𝕣𝕖𝕟  a ρ) 𝕧𝕒𝕣 (rlift _ ρ v))
  ≡˘⟨ 𝕤𝕦𝕓ᶜ.f∘r ⟩
      [ 𝕣𝕖𝕟 a ρ /] (𝕣𝕖𝕟 b (rlift _ ρ))
  ∎ where open ≡-Reasoning

𝕤𝕦𝕓[/] : (σ : Γ ~[ 𝕋 ]↝ Δ)(b : 𝕋 α (β ∙ Γ))(a : 𝕋 β Γ)
      → 𝕤𝕦𝕓 ([ a /] b) σ ≡ [ 𝕤𝕦𝕓 a σ /] (𝕤𝕦𝕓 b (lift 𝕋ᴮ ⌈ β ⌋ σ))
𝕤𝕦𝕓[/] {β = β} σ b a = begin
      𝕤𝕦𝕓 ([ a /] b) σ
  ≡⟨ assoc ⟩
      𝕤𝕦𝕓 b (λ v → 𝕤𝕦𝕓 (add 𝕋 a 𝕧𝕒𝕣 v) σ)
  ≡⟨ cong (𝕤𝕦𝕓 b) (dext (λ{ new → sym lunit ; (old v) → sym (begin
        𝕤𝕦𝕓 (𝕣𝕖𝕟 (σ v) old) (add 𝕋 (𝕤𝕦𝕓 a σ) 𝕧𝕒𝕣)
    ≡⟨ 𝕤𝕦𝕓ᶜ.f∘r ⟩
        𝕤𝕦𝕓 (σ v) (λ v → add 𝕋 (𝕤𝕦𝕓 a σ) 𝕧𝕒𝕣 (old v))
    ≡⟨ cong (𝕤𝕦𝕓 (σ v)) (dext (λ{ new → refl ; (old v) → refl})) ⟩
        𝕤𝕦𝕓 (σ v) 𝕧𝕒𝕣
    ≡⟨ runit ⟩
        σ v
    ≡˘⟨ lunit ⟩
        𝕤𝕦𝕓 (𝕧𝕒𝕣 v) σ
    ∎)})) ⟩
      𝕤𝕦𝕓 b (λ v → 𝕤𝕦𝕓 (lift 𝕋ᴮ ⌈ β ⌋ σ v) (add 𝕋 (𝕤𝕦𝕓 a σ) 𝕧𝕒𝕣))
  ≡˘⟨ assoc ⟩
      [ 𝕤𝕦𝕓 a σ /] (𝕤𝕦𝕓 b (lift 𝕋ᴮ ⌈ β ⌋ σ))
  ∎ where open ≡-Reasoning


module Typed.LTLCRef where

open import Data.List.Relation.Ternary.Interleaving.Propositional
open import Relation.Unary hiding (_∈_)
open import Relation.Unary.PredicateTransformer using (Pt)
open import Function
open import Category.Monad

open import Relation.Ternary.Separation
open import Relation.Ternary.Separation.Allstar
open import Relation.Ternary.Separation.Morphisms
open import Relation.Ternary.Separation.Monad
open import Relation.Ternary.Separation.Monad.Reader

open import Prelude

data Ty : Set where
  unit : Ty
  ref  : Ty → Ty
  prod : Ty → Ty → Ty
  _⊸_  : (a b : Ty) → Ty

Ctx  = List Ty
CtxT = List Ty → List Ty

open import Relation.Ternary.Separation.Construct.List Ty
open import Relation.Ternary.Separation.Construct.Market
open import Relation.Ternary.Separation.Construct.Product

infixr 20 _◂_
_◂_ : Ty → CtxT → CtxT
(x ◂ f) Γ = x ∷ f Γ

variable a b c : Ty
variable ℓv  : Level
variable τ   : Set ℓv
variable Γ Γ₁ Γ₂ Γ₃ : List τ

data Exp : Ty → Ctx → Set where
  -- base type
  tt       : ε[ Exp unit ]
  letunit  : ∀[ Exp unit ✴ Exp a ⇒ Exp a ]

  -- linear λ calculus
  var      : ∀[ Just a ⇒ Exp a ]
  lam      : ∀[ (a ◂ id ⊢ Exp b) ⇒ Exp (a ⊸ b) ]
  ap       : ∀[ Exp (a ⊸ b) ✴ Exp a ⇒ Exp b ]

  -- products
  pair    : ∀[ Exp a ✴ Exp b ⇒ Exp (prod a b) ]
  letpair : ∀[ Exp (prod a b) ✴ (λ Γ → a ∷ b ∷ Γ) ⊢ Exp c ⇒ Exp c ]

  -- state
  ref     : ε[ Exp a ⇒ Exp (ref a) ]
  swaps   : ∀[ Exp (ref a) ✴ Exp b ⇒ Exp (prod a (ref b)) ]
  del     : ε[ Exp (ref unit) ⇒ Exp unit ]

-- store types
ST = List Ty

-- values
data Val : Ty → Pred ST 0ℓ where
  tt    : ε[ Val unit ]
  clos  : Exp b (a ∷ Γ) → ∀[ Allstar Val Γ ⇒ Val (a ⊸ b) ]
  ref   : ∀[ Just a ⇒ Val (ref a) ]
  pair  : ∀[ Val a ✴ Val b ⇒ Val (prod a b) ]

{- The 'give-it-to-me-straight' semantics -}

Store : ST → ST → Set
Store = Allstar Val

-- {- First attempt -- evaluation without a frame, seems simple enough... -}
-- eval₁ : ∀ {Ψ Γ} → Exp a Γ → Allstar Val Γ Φ₁ → Store Ψ Φ₂ → Φ₁ ⊎ Φ₂ ≣ Ψ →
--         ∃ λ Ψ' → ∃₂ λ Φ₃ Φ₄ → Store Ψ' Φ₃ × Val a Φ₄ × Φ₃ ⊎ Φ₄ ≣ Ψ'

-- eval₁ (num x) nil μ σ = -, -, -, μ , num x , ⊎-comm σ

-- eval₁ (lam e) env μ σ = -, -, -, μ , (clos e env) , ⊎-comm σ

-- eval₁ (ap (f ×⟨ σ ⟩ e)) env μ σ₂ =
--   let
--     env₁ ×⟨ σ₃ ⟩ env₂ = repartition σ env
--     _ , τ₁ , τ₂ = ⊎-assoc (⊎-comm σ₃) σ₂

--   {- Oops, store contains more stuff than used; i.e. we have a frame -}
--   in case eval₁ f env₁ μ {!τ₂!} of λ where
--     (_ , _ , _ , μ' , clos e env₃ , σ₄) → {!!}

-- eval₁ (var x) = {!!}

-- eval₁ (ref e) = {!!}

-- eval₁ (deref e) = {!!}

-- eval₁ (asgn x) = {!!}

-- {- First attempt -- evaluation *with* a frame. Are you sure want this? -}
-- eval₂ : ∀ {Ψ Γ Φf} → Exp a Γ → Allstar Val Γ Φ₁ → Store Ψ Φ₂ → Φ₁ ⊎ Φ₂ ≣ Φ → Φ ⊎ Φf ≣ Ψ →
--         ∃₂ λ Φ' Ψ' → ∃₂ λ Φ₃ Φ₄ → Store Ψ' Φ₃ × Val a Φ₄ × Φ₃ ⊎ Φ₄ ≣ Φ' × Φ' ⊎ Φf ≣ Ψ'
-- eval₂ (num x) nil μ σ₁ σ₂ =
--   case ⊎-id⁻ˡ σ₁ of λ where refl → -, -, -, -, μ , num x , ⊎-idʳ , σ₂
-- eval₂ (lam x) env μ σ₁ σ₂ = {!!}

-- eval₂ (pair (e₁ ×⟨ σ ⟩ e₂)) env μ σ₁ σ₂ =
--   let
--     env₁ ×⟨ σ₃ ⟩ env₂ = repartition σ env
--     _ , τ₁ , τ₂ = ⊎-assoc (⊎-comm σ₃) σ₁ -- separation between sub-env and store
--     _ , τ₃ , τ₄ = ⊎-assoc (⊎-comm τ₁) σ₂ -- compute the frame

--   in case eval₂ e₁ env₁ μ τ₂ τ₃ of λ where
--     (_ , _ , _ , _ , μ' , v₁ , σ₄ , σ₅) →
--        let v = eval₂ e₂ env₂ μ' {!τ₁!} {!!} in {!!}

-- eval₂ (var x) env μ σ₁ σ₂ = {!!}
-- eval₂ (ref e) env μ σ₁ σ₂ = {!!}
-- eval₂ (deref e) env μ σ₁ σ₂ = {!!}
-- eval₂ (asgn x) env μ σ₁ σ₂ = {!!}
-- eval₂ (ap (f ×⟨ σ ⟩ e)) env μ σ₁ σ₂ = {!!}

{- The monadic semantics -}

module _ {i : Size} where
  open import Relation.Ternary.Separation.Monad.Delay public
  open import Relation.Ternary.Separation.Monad.State
  open import Relation.Ternary.Separation.Monad.State.Heap Val

  open HeapOps (Delay i) {{ monad = delay-monad }}
    using (state-monad; newref; read; write; Cells)
    public

  open ReaderTransformer id-morph Val (StateT (Delay i) Cells)
    {{ monad = state-monad }}
    renaming (Reader to M'; reader-monad to monad)
    public

  open Monads.Monad monad public
  open Monads using (_&_; str; typed-str) public

M : Size → (Γ₁ Γ₂ : Ctx) → Pt ST 0ℓ
M i = M' {i}

mutual
  eval⊸ : ∀ {i Γ} → Exp (a ⊸ b) Γ → ∀[ Val a ⇒ M i Γ ε (Val b) ]
  eval⊸ e v = do
    clos e env ×⟨ σ₂ ⟩ v ← ►eval e & v
    empty                ← append (cons (v ×⟨ ⊎-comm σ₂ ⟩ env))
    ►eval e

  eval : ∀ {i Γ} → Exp a Γ → ε[ M i Γ ε (Val a) ]

  eval tt = do
    return tt

  eval (letunit (e₁ ×⟨ Γ≺ ⟩ e₂)) = do
    tt ← frame Γ≺ (►eval e₁)
    ►eval e₂

  eval (var refl) = do
    lookup

  eval (lam e) = do
    env ← ask
    return (clos e env)

  eval (pair (e₁ ×⟨ Γ≺ ⟩ e₂)) = do
    v₁    ← frame Γ≺ (►eval e₁)
    v₂✴v₁ ← ►eval e₂ & v₁
    return (pair (✴-swap v₂✴v₁))

  eval (letpair (e₁ ×⟨ Γ≺ ⟩ e₂)) = do
    pair (v₁ ×⟨ σ ⟩ v₂) ← frame Γ≺ (►eval e₁)
    empty               ← prepend (cons (v₁ ×⟨ σ ⟩ (singleton v₂)))
    ►eval e₂

  eval (ap (f ×⟨ Γ≺ ⟩ e)) = do
    v ← frame (⊎-comm Γ≺) (►eval e)
    eval⊸ f v

  eval (ref e) = do
    v ← ►eval e
    r ← liftM (newref v)
    return (ref r)

  eval (swaps (e₁ ×⟨ Γ≺ ⟩ e₂)) = do
    ref ra ← frame Γ≺ (►eval e₁)
    vb ×⟨ σ₁ ⟩ ra ← ►eval e₂ & ra
    rb ×⟨ σ₂ ⟩ va ← liftM (write (ra ×⟨ ⊎-comm σ₁ ⟩ vb))
    return (pair (va ×⟨ (⊎-comm σ₂) ⟩ (ref rb)))

  eval (del e) = do
    ref r ← ►eval e
    liftM (read r)

  ►eval : ∀ {i Γ} → Exp a Γ → ε[ M i Γ ε (Val a) ]
  app (app (►eval e) env σ) μ σ' = later (λ where .force → app (app (eval e) env σ) μ σ')


module Common.Char where

postulate
  Char : Set

{-# BUILTIN CHAR Char #-}


{- Byzantine Fault Tolerant Consensus Verification in Agda, version 0.9.

   Copyright (c) 2020, 2021, Oracle and/or its affiliates.
   Licensed under the Universal Permissive License v 1.0 as shown at https://opensource.oracle.com/licenses/upl
-}

-- This is a selection of useful functions and definitions
-- from the standard library that we tend to use a lot.

module Util.Prelude where

  open import Haskell.Prelude public
  open import Dijkstra.All public

  open import Level
    renaming (suc to ℓ+1; zero to ℓ0; _⊔_ to _ℓ⊔_)
    public

  1ℓ : Level
  1ℓ = ℓ+1 0ℓ

  open import Agda.Builtin.Unit
    public

  open import Function
    using (_∘_; _∘′_; case_of_; _on_; _∋_)
    public
  identity = Function.id

  open import Data.Unit.NonEta
    public

  open import Data.Empty
    public

  -- NOTE: This function is defined to give extra documentation when discharging
  -- absurd cases where Agda can tell by pattern matching that `A` is not
  -- inhabited. For example:
  -- > absurd (just v ≡ nothing) case impossibleProof of λ ()
  infix 0 absurd_case_of_
  absurd_case_of_ : ∀ {ℓ₁ ℓ₂} (A : Set ℓ₁) {B : Set ℓ₂} → A → (A → ⊥) → B
  absurd A case x of f = ⊥-elim (f x)

  open import Data.Nat
    renaming (_≟_ to _≟ℕ_; _≤?_ to _≤?ℕ_; _≥?_ to _≥?ℕ_; compare to compareℕ; Ordering to Orderingℕ)
    public

  max = _⊔_
  min = _⊓_

  open import Data.Nat.Properties
    hiding (≡-irrelevant ; _≟_)
    public

  open import Data.List
    renaming (map to List-map ; filter to List-filter ; lookup to List-lookup;
              tabulate to List-tabulate; foldl to List-foldl)
    hiding (fromMaybe; [_])
    public

  open import Data.List.Properties
    renaming (≡-dec to List-≡-dec; length-map to List-length-map; map-compose to List-map-compose; filter-++ to List-filter-++; length-filter to List-length-filter)
    using (∷-injective; length-++; map-++-commute; sum-++-commute; map-tabulate; tabulate-lookup; ++-identityʳ; ++-identityˡ)
    public

  open import Data.List.Relation.Binary.Subset.Propositional
    renaming (_⊆_ to _⊆List_)
    public

  open import Data.List.Relation.Unary.Any
    using (Any; here; there)
    renaming (lookup to Any-lookup; map to Any-map; satisfied to Any-satisfied
             ;index to Any-index; any to Any-any)
    public

  open import Data.List.Relation.Unary.Any.Properties
    using    (¬Any[])
    renaming ( map⁺       to Any-map⁺
             ; map⁻       to Any-map⁻
             ; concat⁺    to Any-concat⁺
             ; concat⁻    to Any-concat⁻
             ; ++⁻        to Any-++⁻
             ; ++⁺ʳ       to Any-++ʳ
             ; ++⁺ˡ       to Any-++ˡ
             ; singleton⁻ to Any-singleton⁻
             ; tabulate⁺  to Any-tabulate⁺
             ; filter⁻    to Any-filter⁻
             )
    public

  open import Data.List.Relation.Unary.All
    using (All; []; _∷_)
    renaming (head     to All-head;   tail     to All-tail;
              lookup   to All-lookup; tabulate to All-tabulate;
              reduce   to All-reduce; map      to All-map)
    public

  open import Data.List.Relation.Unary.All.Properties
    hiding   (All-map)
    renaming ( tabulate⁻ to All-tabulate⁻
             ; tabulate⁺ to All-tabulate⁺
             ; map⁺      to All-map⁺
             ; map⁻      to All-map⁻
             ; ++⁺       to All-++
             )
    public

  open import Data.List.Membership.Propositional
    using (_∈_; _∉_)
    public

  open import Data.List.Membership.Propositional.Properties
    renaming (∈-filter⁺ to List-∈-filter⁺; ∈-filter⁻ to List-∈-filter⁻)
    public

  open import Data.Vec
    using (Vec; []; _∷_)
    renaming (replicate to Vec-replicate; lookup to Vec-lookup
             ;map to Vec-map; head to Vec-head; tail to Vec-tail
             ;updateAt to Vec-updateAt; tabulate to Vec-tabulate
             ;allFin to Vec-allFin; toList to Vec-toList; fromList to Vec-fromList
             ;_++_ to _Vec-++_)
    public

  open import Data.Vec.Relation.Unary.All
    using ([]; _∷_)
    renaming (All to Vec-All; lookup to Vec-All-lookup)
    public

  open import Data.Vec.Properties
    using ()
    renaming (updateAt-minimal to Vec-updateAt-minimal
             ;[]=⇒lookup to Vec-[]=⇒lookup
             ;lookup⇒[]= to Vec-lookup⇒[]=
             ;lookup∘tabulate to Vec-lookup∘tabulate
             ;≡-dec to Vec-≡-dec)
    public

  open import Data.List.Relation.Binary.Pointwise
    using (decidable-≡)
    public

  open import Data.Bool
    renaming (_≟_ to _≟Bool_)
    hiding (_≤?_; _<_; _<?_; _≤_; not)
    public

  open import Data.Maybe
    renaming (map to Maybe-map; maybe to Maybe-maybe; zip to Maybe-zip ; _>>=_ to _Maybe->>=_)
    hiding (align; alignWith; zipWith)
    public

  -- a non-dependent eliminator
  -- note the traditional argument order is "switched", hence the 'S'
  maybeS : ∀ {a b} {A : Set a} {B : Set b} →
           (x : Maybe A) → B → ((x : A) → B) → B
  maybeS {B = B} x f t = Maybe-maybe {B = const B} t f x

  -- A Dijkstra version of maybeS, implemented using the version in
  -- Dijkstra.Syntax which has traditional argument order
  maybeSD : ∀ {ℓ₁ ℓ₂} {M : Set ℓ₁ → Set ℓ₂} ⦃ mmd : MonadMaybeD M ⦄
           → ∀ {A B : Set ℓ₁} → Maybe A → M B → (A → M B) → M B
  maybeSD ⦃ mmd ⦄ x y z = maybeD y z x

  module _ {Ev Wr St A B : Set} where
    maybeSMP-RWS : RWS Ev Wr St (Maybe A)
                 → B
                 → (A → RWS Ev Wr St B)
                 → RWS Ev Wr St B
    maybeSMP-RWS x y z = maybeMP-RWS y z x

  open import Data.Maybe.Relation.Unary.Any
    renaming (Any to Maybe-Any; dec to Maybe-Any-dec)
    hiding (map; zip; zipWith; unzip ; unzipWith)
    public

  maybe-any-⊥ : ∀{a}{A : Set a} → Maybe-Any {A = A} (λ _ → ⊤) nothing → ⊥
  maybe-any-⊥ ()

  headMay : ∀ {A : Set} → List A → Maybe A
  headMay     []  = nothing
  headMay (x ∷ _) = just x

  lastMay : ∀ {A : Set} → List A → Maybe A
  lastMay          []  = nothing
  lastMay     (x ∷ []) = just x
  lastMay (_ ∷ x ∷ xs) = lastMay (x ∷ xs)

  open import Data.Maybe.Properties
    using (just-injective)
    renaming (≡-dec to Maybe-≡-dec)
    public

  open import Data.Fin
    using (Fin; suc; zero; fromℕ; fromℕ< ; toℕ ; cast)
    renaming (_≟_ to _≟Fin_; _≤?_ to _≤?Fin_; _≤_ to _≤Fin_ ; _<_ to _<Fin_;
              inject₁ to Fin-inject₁; inject+ to Fin-inject+; inject≤ to Fin-inject≤)
    public

  fins : (n : ℕ) → List (Fin n)
  fins n = Vec-toList (Vec-allFin n)

  open import Data.Fin.Properties
    using (toℕ-injective; toℕ<n)
    renaming (<-cmp to Fin-<-cmp; <⇒≢ to <⇒≢Fin; suc-injective to Fin-suc-injective)
    public

  open import Relation.Binary.PropositionalEquality
    hiding (decSetoid)
    public

  open import Relation.Binary.HeterogeneousEquality
    using (_≅_)
    renaming (cong to ≅-cong; cong₂ to ≅-cong₂)
    public

  open import Relation.Binary
    public

  ≡-irrelevant : ∀{a}{A : Set a} → Irrelevant {a} {A} _≡_
  ≡-irrelevant refl refl = refl

  to-witness-lemma : ∀{ℓ}{A : Set ℓ}{a : A}{f : Maybe A}(x : Is-just f)
                   → to-witness x ≡ a → f ≡ just a
  to-witness-lemma (just x) refl = refl

  open import Relation.Nullary
    hiding (Irrelevant; proof)
    public

  open import Relation.Nullary.Decidable
    hiding (map)
    public

  open import Data.Sum
    renaming (map to ⊎-map; map₁ to ⊎-map₁; map₂ to ⊎-map₂)
    public

  open import Data.Sum.Properties
    using (inj₁-injective ; inj₂-injective)
    public

  ⊎-elimˡ : ∀ {ℓ₀ ℓ₁}{A₀ : Set ℓ₀}{A₁ : Set ℓ₁} → ¬ A₀ → A₀ ⊎ A₁ → A₁
  ⊎-elimˡ ¬a = either (⊥-elim ∘ ¬a) id

  ⊎-elimʳ : ∀ {ℓ₀ ℓ₁}{A₀ : Set ℓ₀}{A₁ : Set ℓ₁} → ¬ A₁ → A₀ ⊎ A₁ → A₀
  ⊎-elimʳ ¬a = either id (⊥-elim ∘ ¬a)

  open import Data.Product
    renaming (map to ×-map; map₂ to ×-map₂; map₁ to ×-map₁; <_,_> to split; swap to ×-swap)
    hiding (zip)
    public

  open import Data.Product.Properties
    public

  module _ {ℓA} {A : Set ℓA} where
    NoneOfKind : ∀ {ℓ} {P : A → Set ℓ} → List A → (p : (a : A) → Dec (P a)) → Set ℓA
    NoneOfKind xs p = List-filter p xs ≡ []

    postulate -- TODO-1: Replace with or prove using library properties?  Move to Lemmas?
      NoneOfKind⇒ : ∀ {ℓ} {P : A → Set ℓ} {Q : A → Set ℓ} {xs : List A}
                  → (p : (a : A) → Dec (P a))
                  → {q : (a : A) → Dec (Q a)}
                  → (∀ {a} → P a → Q a)  -- TODO-1: Use proper notation (Relation.Unary?)
                  → NoneOfKind xs q
                  → NoneOfKind xs p

  infix 4 _<?ℕ_
  _<?ℕ_ : Decidable _<_
  m <?ℕ n = suc m ≤?ℕ n

  infix 0 if-yes_then_else_
  infix 0 if-dec_then_else_
  if-yes_then_else_ : ∀ {ℓA ℓB} {A : Set ℓA} {B : Set ℓB} → Dec A → (A → B) → (¬ A → B) → B
  if-yes (yes prf) then f else _ = f prf
  if-yes (no  prf) then _ else g = g prf

  if-dec_then_else_ : ∀ {ℓA ℓB} {A : Set ℓA} {B : Set ℓB} → Dec A → B → B → B
  if-dec x then f else g = if-yes x then const f else const g

  open import Relation.Nullary.Negation
    using (contradiction; contraposition)
    public

  open import Relation.Binary
    using (Setoid; IsPreorder)
    public

  open import Relation.Unary
    using (_∪_)
    public

  open import Relation.Unary.Properties
    using (_∪?_)
    public

  -- Injectivity for a function of two potentially different types (A and B) via functions to a
  -- common type (C).

  Injective' : ∀ {b c d e}{B : Set b}{C : Set c}{D : Set d} → (hB : B → D) → (hC : C → D) → (_≈_ : B → C → Set e) → Set _
  Injective' {C = C} hB hC _≈_ = ∀ {b c} → hB b ≡ hC c → b ≈ c

  Injective  : ∀ {c d e}{C : Set c}{D : Set d} → (h : C → D) → (_≈_ : Rel C e) → Set _
  Injective h _≈_ = Injective' h h _≈_

  Injective-≡ : ∀ {c d}{C : Set c}{D : Set d} → (h : C → D) → Set _
  Injective-≡ h = Injective h _≡_

  Injective-int : ∀{a b c d e}{A : Set a}{B : Set b}{C : Set c}{D : Set d}
                → (_≈_ : A → B → Set e)
                → (h  : C → D)
                → (f₁ : A → C)
                → (f₂ : B → C)
                → Set (a ℓ⊔ b ℓ⊔ d ℓ⊔ e)
  Injective-int _≈_ h f₁ f₂ = ∀ {a₁} {b₁} → h (f₁ a₁) ≡ h (f₂ b₁) → a₁ ≈ b₁

  NonInjective : ∀{a b c}{A : Set a}{B : Set b}
               → (_≈_ : Rel A c)
               → (A → B) → Set (a ℓ⊔ b ℓ⊔ c)
  NonInjective {A = A} _≈_ f
    = Σ (A × A) (λ { (x₁ , x₂) → ¬ (x₁ ≈ x₂) × f x₁ ≡ f x₂ })

  NonInjective-≡ : ∀{a b}{A : Set a}{B : Set b}
                 → (A → B) → Set (a ℓ⊔ b)
  NonInjective-≡ = NonInjective _≡_

  NonInjective-≡-preds : ∀{a b}{A : Set a}{B : Set b}{ℓ₁ ℓ₂ : Level}
                      → (A → Set ℓ₁)
                      → (A → Set ℓ₂)
                      → (A → B) → Set (a ℓ⊔ b ℓ⊔ ℓ₁ ℓ⊔ ℓ₂)
  NonInjective-≡-preds Pred1 Pred2 f = Σ (NonInjective _≡_ f) λ { ((a₀ , a₁) , _ , _) → Pred1 a₀ × Pred2 a₁ }

  NonInjective-≡-pred : ∀{a b}{A : Set a}{B : Set b}{ℓ : Level}
                      → (P : A → Set ℓ)
                      → (A → B) → Set (a ℓ⊔ b ℓ⊔ ℓ)
  NonInjective-≡-pred Pred = NonInjective-≡-preds Pred Pred

  NonInjective-∘ : ∀{a b c}{A : Set a}{B : Set b}{C : Set c}
                 → {f : A → B}(g : B → C)
                 → NonInjective-≡  f
                 → NonInjective-≡ (g ∘ f)
  NonInjective-∘ g ((x0 , x1) , (x0≢x1 , fx0≡fx1))
    = ((x0 , x1) , x0≢x1 , (cong g fx0≡fx1))

  --------------------------------------------
  -- Handy fmap and bind for specific types --

  _<M$>_ : ∀{a b}{A : Set a}{B : Set b}
         → (f : A → B)
         → Maybe A → Maybe B
  _<M$>_ = Maybe-map

  <M$>-univ : ∀{a b}{A : Set a}{B : Set b}
            → (f : A → B)(x : Maybe A)
            → {y : B} → f <M$> x ≡ just y
            → ∃[ x' ] (x ≡ just x' × f x' ≡ y)
  <M$>-univ f (just x) refl = x , (refl , refl)

  maybe-lift : {A : Set}
             → {mx : Maybe A}{x : A}
             → (P : A → Set)
             → P x → mx ≡ just x
             → Maybe-maybe {B = const Set} P ⊥ mx
  maybe-lift {mx = just .x} {x} P px refl = px

  <M$>-nothing : ∀ {a b}{A : Set a}{B : Set b}(f : A → B)
               → f <M$> nothing ≡ nothing
  <M$>-nothing _ = refl

  _<⊎$>_ : ∀{a b c}{A : Set a}{B : Set b}{C : Set c}
         → (A → B) → C ⊎ A → C ⊎ B
  f <⊎$> (inj₁ hb) = inj₁ hb
  f <⊎$> (inj₂ x)  = inj₂ (f x)

  _⊎⟫=_ : ∀{a b c}{A : Set a}{B : Set b}{C : Set c}
        → C ⊎ A → (A → C ⊎ B) → C ⊎ B
  (inj₁ x) ⊎⟫= _ = inj₁ x
  (inj₂ a) ⊎⟫= f = f a

  -- a non-dependent eliminator
  -- note the traditional argument order is "switched", hence the 'S'
  eitherS : ∀ {a b c} {A : Set a} {B : Set b} {C : Set c}
            (x : Either A B) → ((x : A) → C) → ((x : B) → C) → C
  eitherS eab fa fb = case eab of λ where
    (Left  a) → fa a
    (Right b) → fb b

  -- A Dijkstra version of eitherS, implemented using the version in
  -- Dijkstra.Syntax which has traditional argument order
  eitherSD : ∀ {ℓ₁ ℓ₂ ℓ₃} {M : Set ℓ₁ → Set ℓ₂} ⦃ med : MonadEitherD M ⦄
           → ∀ {EL : Set ℓ₁ → Set ℓ₁ → Set ℓ₃} ⦃ _ : EitherLike EL ⦄
           → ∀ {E A B : Set ℓ₁} → EL E A → (E → M B) → (A → M B) → M B
  eitherSD ⦃ med ⦄ ⦃ el ⦄ x y z = eitherD y z x

  open import Data.String as String
    hiding (_==_ ; _≟_ ; concat)

  check : Bool → List String → Either String Unit
  check b t = if b then inj₂ unit else inj₁ (String.intersperse "; " t)

  toWitnessT : ∀{ℓ}{P : Set ℓ}{d : Dec P} → ⌊ d ⌋ ≡ true → P
  toWitnessT {d = yes proof} _ = proof

  toWitnessF : ∀{ℓ}{P : Set ℓ}{d : Dec P} → ⌊ d ⌋ ≡ false → ¬ P
  toWitnessF{d = no proof} _ = proof

  Any-satisfied-∈ : ∀{a ℓ}{A : Set a}{P : A → Set ℓ}{xs : List A}
                  → Any P xs → Σ A (λ x → P x × x ∈ xs)
  Any-satisfied-∈ (here px) = _ , (px , here refl)
  Any-satisfied-∈ (there p) = let (a , px , prf) = Any-satisfied-∈ p
                               in (a , px , there prf)

  f-sum : ∀{a}{A : Set a} → (A → ℕ) → List A → ℕ
  f-sum f = sum ∘ List-map f

  maybeSMP : ∀ {ℓ} {A B : Set} {m : Set → Set ℓ} ⦃ _ : Monad m ⦄ → m (Maybe A) → B → (A → m B) → m B
  maybeSMP ma b f = do
    x ← ma
    case x of λ where
      nothing  → pure b
      (just j) → f j

  open import LibraBFT.Base.Util public

  -- Like a Haskell list-comprehension for ℕ : [ n | n <- [from .. to] ]
  fromToList : ℕ → ℕ → List ℕ
  fromToList from to with from ≤′? to
  ... | no ¬pr = []
  ... | yes pr = fromToList-le from to pr []
   where
    fromToList-le : ∀ (from to : ℕ) (klel : from ≤′ to) (acc : List ℕ) → List ℕ
    fromToList-le from ._        ≤′-refl       acc = from ∷ acc
    fromToList-le from (suc to) (≤′-step klel) acc = fromToList-le from to klel (suc to ∷ acc)

  _ : fromToList 1 1 ≡ 1 ∷ []
  _ = refl
  _ : fromToList 1 2 ≡ 1 ∷ 2 ∷ []
  _ = refl
  _ : fromToList 2 1 ≡ []
  _ = refl


module _ {A : Set} (P : A → Set) where

  instance
   postulate
    forbidden : {x : A} → P x


-- Andreas, 2017-07-11, issue #2639 reported by nad
--
-- Unsolvable size constraints were added to the constraint set
-- each time the size solver ran.  This lead to exponentially
-- many size constraints.

-- {-# OPTIONS -v tc.size.solve:40 #-}

module Issue2639 (A : Set) where

open import Agda.Builtin.Nat
open import Agda.Builtin.Size

open import Issue2639.DR A

postulate
  P : {i : Size} → D i → Set

F : Set₁
F = Set
  where

  -- This postulate creates an unsolved size constraint.
  postulate
    unused : P a

  G : Nat → Set → Set₁
  G zero = λ { _ → Set }
  G (suc zero) = λ { _ → Set }
  G (suc (suc zero)) = λ { _ → Set }
  G (suc (suc (suc zero))) = λ { _ → Set }
  G (suc (suc (suc (suc zero)))) = λ { _ → Set }
  G _ = λ { _ → Set }


open import Data.Product using ( _,_ ; proj₁ ; proj₂ )
open import Web.Semantic.DL.ABox.Interp using
  ( Interp ; _*_ ; ⌊_⌋ ; ind )
open import Web.Semantic.DL.ABox.Interp.Morphism using
  ( _≲_ ; _**_ ; ≲-refl )
open import Web.Semantic.DL.ABox.Model using
  ( _⊨a_ ; _⊨b_ ; *-resp-⟨ABox⟩ ; ⊨a-resp-≲ )
open import Web.Semantic.DL.Category.Object using
  ( Object ; _,_ ; IN ; fin ; iface )
open import Web.Semantic.DL.Category.Morphism using
  ( _⇒_ ; _,_ ; BN ; impl
  ; apply ; apply✓ ; apply-init )
open import Web.Semantic.DL.Category.Wiring using
  ( identity ; wires-≈ ; wires-≈⁻¹ )
open import Web.Semantic.DL.Category.Composition using
  ( _∙_ ; ⊨a-intro-⟫ ; ⊨b-intro-⟫ )
open import Web.Semantic.DL.Integrity using ( med-≲ ; init-med )
open import Web.Semantic.DL.KB using ( _,_ )
open import Web.Semantic.DL.KB.Model using ( _⊨_ )
open import Web.Semantic.DL.Signature using ( Signature )
open import Web.Semantic.DL.TBox using ( TBox ; _,_ )
open import Web.Semantic.DL.TBox.Interp using ( _⊨_≈_ )
open import Web.Semantic.Util using
  ( id ; _⊕_⊕_ ; inode ; bnode ; enode ; left ; right )

module Web.Semantic.DL.Category.Properties.Composition.Lemmas
  {Σ : Signature} {S T : TBox Σ} where

identity-elim : ∀ (A : Object S T) I → (I ⊨a impl (identity A)) →
  ∀ x → (⌊ I ⌋ ⊨ ind I (inode x) ≈ ind I (enode x))
identity-elim (X , X∈Fin , A) I I⊨id x = wires-≈ id (proj₂ X∈Fin x) I⊨id

identity-intro : ∀ (A : Object S T) I →
  (∀ x → (⌊ I ⌋ ⊨ ind I (inode x) ≈ ind I (enode x))) →
    (I ⊨a impl (identity A))
identity-intro (X , X∈Fin , A) I ∀x∙x₁≈x₂ = wires-≈⁻¹ id ∀x∙x₁≈x₂ (proj₁ X∈Fin)

compose-left : ∀ {A B C : Object S T} (F : A ⇒ B) (G : B ⇒ C) I →
  (I ⊨a impl (F ∙ G)) → (left * I ⊨a impl F)
compose-left {X , X∈Fin , A} {Y , Y∈Fin , B} {Z , Z∈Fin , C}
  (V , F , F✓) (W , G , G✓) I (I⊨F , I⊨G) =
    *-resp-⟨ABox⟩ left I F I⊨F

compose-right : ∀ {A B C : Object S T} (F : A ⇒ B) (G : B ⇒ C) I →
  (I ⊨a impl (F ∙ G)) → (right * I ⊨a impl G)
compose-right {X , X∈Fin , A} {Y , Y∈Fin , B} {Z , Z∈Fin , C}
  (V , F , F✓) (W , G , G✓) I (I⊨F , I⊨G) =
    *-resp-⟨ABox⟩ right I G I⊨G

compose-mid : ∀ {A B C : Object S T} (F : A ⇒ B) (G : B ⇒ C)
  (I : Interp Σ (IN A ⊕ (BN F ⊕ IN B ⊕ BN G) ⊕ IN C)) →
    (inode * I ⊨ (S , T) , iface A) → (I ⊨a impl (F ∙ G)) →
      (bnode * bnode * I ⊨ (S , T) , iface B)
compose-mid {A} {B} {C} F G I ((I⊨S , I⊨T) , I⊨A) I⊨F⟫G =
  ((I⊨S , I⊨T) , ⊨a-resp-≲ (enode ** J≲I) (iface B) J⊨B) where

  J : Interp Σ (IN A ⊕ BN F ⊕ IN B)
  J = apply F (inode * I) ((I⊨S , I⊨T) , I⊨A)

  J⊨B : enode * J ⊨a iface B
  J⊨B = proj₂ (apply✓ F (inode * I) ((I⊨S , I⊨T) , I⊨A))

  J≲I : J ≲ left * I
  J≲I = med-≲ (init-med (apply-init F (inode * I) ((I⊨S , I⊨T) , I⊨A))
    (left * I) (≲-refl (inode * I)) (I⊨S , compose-left F G I I⊨F⟫G))

compose-resp-⊨a : ∀ {A B C : Object S T} (F : A ⇒ B) (G : B ⇒ C) I →
  (left * I ⊨a impl F) → (right * I ⊨a impl G) → (I ⊨a impl (F ∙ G))
compose-resp-⊨a {X , X∈Fin , A} {Y , Y∈Fin , B} {Z , Z∈Fin , C}
  (V , F , F✓) (W , G , G✓) I I⊨F I⊨G =
    ⊨a-intro-⟫ I F G I⊨F I⊨G

compose-resp-⊨b : ∀ {A B C : Object S T} {V W : Set} (F : A ⇒ B) (G : B ⇒ C)
  (I : Interp Σ (IN A ⊕ (V ⊕ IN B ⊕ W) ⊕ IN C)) →
    (left * I ⊨b impl F) → (right * I ⊨b impl G) → (I ⊨b impl (F ∙ G))
compose-resp-⊨b {X , X∈Fin , A} {Y , Y∈Fin , B} {Z , Z∈Fin , C}
  (V , F , F✓) (W , G , G✓) I I⊨F I⊨G =
    ⊨b-intro-⟫ I F G I⊨F I⊨G


------------------------------------------------------------------------
-- A memoising backend
------------------------------------------------------------------------

-- This code has bitrotted.

-- Following Frost/Szydlowski and Frost/Hafiz/Callaghan (but without
-- the left recursion fix). An improvement has been made: The user
-- does not have to insert memoisation annotations manually. Instead
-- all grammar nonterminals are memoised. This is perhaps a bit less
-- flexible, but less error-prone, since there is no need to guarantee
-- that all "keys" (arguments to the memoise combinator) are unique
-- (assuming that the nonterminal equality is strong enough).

open import Relation.Binary
import Relation.Binary.PropositionalEquality  as PropEq
import Relation.Binary.PropositionalEquality1 as PropEq1
open PropEq  using (_≡_)
open PropEq1 using (_≡₁_)
open import StructurallyRecursiveDescentParsing.Index
open import Data.Product as Prod

module StructurallyRecursiveDescentParsing.Memoised

  -- In order to be able to store results in a memo table (and avoid
  -- having to lift the table code to Set1) the result types have to
  -- come from the following universe:

  {Result : Set} (⟦_⟧ : Result → Set)

  -- Nonterminals also have to be small enough:

  {NT : Index → Result → Set} {LargeNT : NonTerminalType}
  (resultType : ∀ {i r} → LargeNT i r → Result)
  (resultTypeCorrect : ∀ {i r} (x : LargeNT i r) →
                       ⟦ resultType x ⟧ ≡₁ r)
  (notTooLarge : ∀ {i r} (x : LargeNT i r) → NT i (resultType x))

  -- Furthermore nonterminals need to be ordered, so that they can be
  -- used as memo table keys:

  {_≈_ _<_ : Rel (∃₂ NT)}
  (ntOrdered : IsStrictTotalOrder _≈_ _<_)

  -- And the underlying equality needs to be strong enough:

  (indicesEqual : _≈_ =[ (λ irx → (proj₁ irx , proj₁ (proj₂ irx))) ]⇒
                  _≡_ {Index × Result})

  -- Token type:

  {Tok : Set}

  where

open import Data.Bool renaming (true to ⊤; false to ⊥)
import Data.Nat as Nat
open Nat using (ℕ; zero; suc; pred; z≤n; s≤s)
import Data.Nat.Properties as NatProp
open import Function using (_∘_; _on_)
import Data.Vec  as Vec;  open Vec  using (Vec;  []; _∷_)
import Data.List as List; open List using (List; []; _∷_)
open import Data.Sum
open import Data.Maybe
open import Relation.Binary.OrderMorphism hiding (_∘_)
open _⇒-Poset_
import Relation.Binary.On as On
import Relation.Binary.Props.StrictTotalOrder as STOProps
open STOProps NatProp.strictTotalOrder

import StructurallyRecursiveDescentParsing.Memoised.Monad as Monad
open import StructurallyRecursiveDescentParsing.Type
open import StructurallyRecursiveDescentParsing.Utilities
  renaming (_∘_ to _∘′_)

------------------------------------------------------------------------
-- Some monotone functions

MonoFun : Set
MonoFun = poset ⇒-Poset poset

suc-mono : _≤_ =[ suc ]⇒ _≤_
suc-mono (inj₁ i<j)    = inj₁ (s≤s i<j)
suc-mono (inj₂ ≡-refl) = inj₂ ≡-refl

pred-mono : _≤_ =[ pred ]⇒ _≤_
pred-mono (inj₁ (s≤s (z≤n {zero})))  = inj₂ PropEq.refl
pred-mono (inj₁ (s≤s (z≤n {suc j}))) = inj₁ (s≤s z≤n)
pred-mono (inj₁ (s≤s (s≤s i<j)))     = inj₁ (s≤s i<j)
pred-mono (inj₂ PropEq.refl)         = inj₂ PropEq.refl

sucM : MonoFun
sucM = record
  { fun      = suc
  ; monotone = suc-mono
  }

predM : MonoFun
predM = record
  { fun      = pred
  ; monotone = pred-mono
  }

maybePredM : Empty → MonoFun
maybePredM e = if e then id else predM

lemma : ∀ e pos → fun (maybePredM e) pos ≤ pos
lemma ⊤ pos       = refl
lemma ⊥ zero      = refl
lemma ⊥ (suc pos) = inj₁ (Poset.refl Nat.poset)

------------------------------------------------------------------------
-- Parser monad

data Key : MonoFun → Result → Set where
  key : ∀ {e c r} (nt : NT (e ◇ c) r) → Key (maybePredM e) r

shuffle : ∃₂ Key → ∃₂ NT
shuffle (._ , _ , key x) = (, , x)

_≈K_ : Rel (∃₂ Key)
_≈K_ = _≈_ on shuffle

_<K_ : Rel (∃₂ Key)
_<K_ = _<_ on shuffle

ordered : IsStrictTotalOrder _≈K_ _<K_
ordered = On.isStrictTotalOrder shuffle ntOrdered

funsEqual : _≈K_ =[ proj₁ ]⇒ _≡_
funsEqual {(._ , _ , key _)} {(._ , _ , key _)} eq =
  PropEq.cong (maybePredM ∘ empty ∘ proj₁) (indicesEqual eq)

resultsEqual : _≈K_ =[ (λ rfk → proj₁ (proj₂ rfk)) ]⇒ _≡_
resultsEqual {(._ , _ , key _)} {(._ , _ , key _)} eq =
  PropEq.cong proj₂ (indicesEqual eq)

open Monad
       (StrictTotalOrder.isStrictTotalOrder NatProp.strictTotalOrder)
       (Vec Tok)
       ⟦_⟧
       ordered
       (λ {k₁} {k₂} → funsEqual    {k₁} {k₂})
       (λ {k₁} {k₂} → resultsEqual {k₁} {k₂})
open PM
  renaming ( return to return′
           ; _>>=_  to _>>=′_
           ; _=<<_  to _=<<′_
           ; ∅      to fail′
           ; _∣_    to _∣′_
           )

cast : ∀ {bnd f A₁ A₂} → A₁ ≡₁ A₂ → P bnd f A₁ → P bnd f A₂
cast refl p = p

------------------------------------------------------------------------
-- Run function for the parsers

-- Some helper functions.

private

  -- Extracts the first element from the input, if any.

  eat : ∀ {bnd} (inp : Input≤ bnd) →
        Maybe Tok × Input≤ (pred (position inp))
  eat {bnd} xs = helper (bounded xs) (string xs)
    where
    helper : ∀ {pos} → pos ≤ bnd → Vec Tok pos →
             Maybe Tok × Input≤ (pred pos)
    helper _  []       = (nothing , [] isBounded∶ refl)
    helper le (c ∷ cs) = (just c  , cs isBounded∶ refl)

  -- Fails if it encounters nothing.

  fromJust : ∀ {bnd} → Maybe Tok → P bnd idM Tok
  fromJust nothing  = fail′
  fromJust (just c) = return′ c

-- For every successful parse the run function returns the remaining
-- string. (Since there can be several successful parses a list of
-- strings is returned.)

-- This function is structurally recursive with respect to the
-- following lexicographic measure:
--
-- 1) The upper bound of the length of the input string.
-- 2) The parser's proper left corner tree.

private

 module Dummy (g : Grammar LargeNT Tok) where

  mutual
    parse : ∀ n {e c R} →
            Parser LargeNT Tok (e ◇ c) R →
            P n (if e then idM else predM) R
    parse n       (return x)          = return′ x
    parse n       (_∣_ {⊤}     p₁ p₂) = parse  n      p₁   ∣′ parse↑ n    p₂
    parse n       (_∣_ {⊥} {⊤} p₁ p₂) = parse↑ n      p₁   ∣′ parse  n    p₂
    parse n       (_∣_ {⊥} {⊥} p₁ p₂) = parse  n      p₁   ∣′ parse  n    p₂
    parse n       (p₁ ?>>= p₂)        = parse  n      p₁ >>=′ parse  n ∘′ p₂
    parse (suc n) (p₁ !>>= p₂)        = parse (suc n) p₁ >>=′ parse↑ n ∘′ p₂
    parse zero    (p₁ !>>= p₂)        = fail′
    parse n       fail                = fail′
    parse n       token               = fromJust =<<′ gmodify predM eat
    parse n       (! x)               = memoParse n x

    parse↑ : ∀ n {e c R} → Parser LargeNT Tok (e ◇ c) R → P n idM R
    parse↑ n {e} p = adjustBound (lemma e) (parse n p)

    memoParse : ∀ n {R e c} → LargeNT (e ◇ c) R →
                P n (if e then idM else predM) R
    memoParse n x = cast₁ (memoise k (cast₂ (parse n (g x))))
      where
      k     = key (notTooLarge x)
      cast₁ = cast (resultTypeCorrect x)
      cast₂ = cast (sym (resultTypeCorrect x))

-- Exported run function.

parse : ∀ {i R} →
        Grammar LargeNT Tok → Parser LargeNT Tok i R →
        List Tok → List (R × List Tok)
parse g p toks =
  List.map (Prod.map id (λ xs → Vec.toList (string xs))) $
  run (Vec.fromList toks) (Dummy.parse g _ p)

-- A variant which only returns parses which leave no remaining input.

parse-complete : ∀ {i R} →
                 Grammar Tok LargeNT → Parser Tok LargeNT i R →
                 List Tok → List R
parse-complete g p s =
  List.map proj₁ (List.filter (List.null ∘ proj₂) (parse g p s))


module Id where

id : {A : Set} -> A -> A
id x = {!!}


{-
Reported by sattler.christian, Oct 10 (3 days ago)

This is a funny one. The below code snippet produces the following error under the current Agda development version:

An internal error has occurred. Please report this as a bug.
Location of the error: src/full/Agda/TypeChecking/Eliminators.hs:85

Note the spurious Tm datatype that isn't used anywhere? Remove it, move its declaration forward, or its definition backward, and the internal error vanishes, leaving a few yellow spots.

Now uncomment the two implicit arguments at the bottom of the code. All metavars are now resolved. Now put the Tm datatype back in - yellow spots reappear, but different from before!
-}

{-# OPTIONS --cubical-compatible #-}
module Issue918 where

record ⊤ : Set where
  constructor tt

record Σ (A : Set) (B : A → Set) : Set where
  constructor _,_
  field
    proj₁ : A
    proj₂ : B proj₁

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

_∘_ : {A B C : Set} → (B → C) → (A → B) → A → C
g ∘ f = λ x → g (f x)

_+'_ : ℕ → ℕ → ℕ
i +' zero  = i
i +' suc j = suc i +' j

U : ℕ → Set
U zero    = ⊤
U (suc n) = Σ (U n) (λ _ → ⊤)

V : ℕ → Set
V zero    = ⊤
V (suc m) = Σ ⊤ (λ _ → V m)

combine : {i j : ℕ} → Σ (U i) (λ _ → V j) → U (i +' j)
combine {j = zero}  = λ {(A , _) → A}
combine {j = suc j} = combine {j = j} ∘ (λ {(Γ , (A , T)) → ((Γ , A) , T)})

data Tm : Set

ctx-hom : (m : ℕ) → U m → Set
ctx-hom zero    _       = ⊤
ctx-hom (suc m) (Δ , _) = Σ (ctx-hom m Δ) (λ _ → ⊤)

ctx-hom-split-iso : {m k : ℕ} {Δ : U m} {T : V k}
                  → ctx-hom (m +' k) (combine (Δ , T))
                  → Σ (ctx-hom m Δ) (λ _ → V k)
ctx-hom-split-iso {k = zero}  = λ Δ → (Δ , tt)
ctx-hom-split-iso {m} {k = suc k} {Δ} {(A , T)} =
    ((λ {((Γ , A) , T) → (Γ , (A , T))}))
  ∘ ctx-hom-split-iso {m = suc m} --{Δ = (Δ , A)}

data Tm where

{- Project Member #1 andreas.m.abel

That was quite a riddle to solve.

1. The internal error is actually triggered in the termination checking phase.
   I fixed this, will push soon.
   A workaround is --no-termination-check

2. The data-Tm-brace puts ctx-hom and ctx-hom-split-iso into a mutual block.
   This prevents ctx-hom to be unfolded during checking the -split-iso.
   You can achieve the same by explicitely putting the two defs into a mutual
   block.
   If the mutual block is removed, the yellow stuff appears.
   HO-unification is sensitive to reduction, at this moment I do not see an
   easy fix for this behavior.

3. "yellow spots reappear, but in different places"  I could not replay this.
   For me, the yellow only disappeared if I also gave {T = T}, but then
   it consistently disappears and reappears when putting in and out of a mutual
   block.

-}


------------------------------------------------------------------------------
-- Stream properties
------------------------------------------------------------------------------

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

module FOT.FOTC.Data.Stream.PropertiesI where

open import FOTC.Base
open import FOTC.Base.List
open import FOTC.Data.Colist.Type
open import FOTC.Data.List
open import FOTC.Data.List.PropertiesI
open import FOTC.Data.Stream.PropertiesI
open import FOTC.Data.Stream.Type

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

{-# TERMINATING #-}
++-Stream : ∀ {xs ys} → Colist xs → Stream ys → Stream (xs ++ ys)
++-Stream {xs} {ys} CLxs Sys with Colist-out CLxs
... | inj₁ prf = subst Stream (sym prf₁) Sys
 where
 prf₁ : xs ++ ys ≡ ys
 prf₁ = trans (++-leftCong prf) (++-[] ys)

... | inj₂ (x' , xs' , prf , CLxs') = subst Stream (sym prf₁) prf₂
   where
   prf₁ : xs ++ ys ≡ x' ∷ (xs' ++ ys)
   prf₁ = trans (++-leftCong prf) (++-∷ x' xs' ys)

   prf₂ : Stream (x' ∷ xs' ++ ys)
   prf₂ = Stream-in (x' , (xs' ++ ys) , refl , ++-Stream CLxs' Sys)

-- ++-Stream with a diferent type.
{-# TERMINATING #-}
++-Stream' : ∀ {xs ys} → Stream xs → Stream ys → Stream (xs ++ ys)
++-Stream' {xs} {ys} Sxs Sys with Stream-out Sxs
... | x' , xs' , prf , Sxs' = subst Stream prf₁ prf₂
  where
  prf₁ : x' ∷ (xs' ++ ys) ≡ xs ++ ys
  prf₁ = trans (sym (++-∷ x' xs' ys)) (++-leftCong (sym prf))

  prf₂ : Stream (x' ∷ xs' ++ ys)
  prf₂ = Stream-in (x' , xs' ++ ys , refl , ++-Stream' Sxs' Sys)


module Issue2487-4 where

open import Agda.Primitive -- this should not be consistency-checked

open import Agda.Builtin.Bool

f : Bool → Bool
f true = true
f _    = false