module Proc where

open import Basics

module ProcDef (U : Set)(T : U -> Set)(Name : U -> Set) where

  LT : U -> Set
  LT a = Lift (T a)

  record Tran (a b : U) : Set where
    field
      upV   : T b -> LT a
      downV : T a -> LT b

  mapLT : {a b : U} -> (T a -> LT b) -> List (T a) -> List (T b)
  mapLT f [] = []
  mapLT f (x :: xs) with f x
  ... | bot    = mapLT f xs
  ... | lift y = y :: mapLT f xs

  infixr 40 _!_ _!_+_
  infix  40 >_
  infixr 30 _||_ _/|_

  data Proc (a : U) : Set where
    o     : Proc a
    >_    : (T a -> Proc a) -> Proc a
    _!_   : LT a -> Proc a -> Proc a
    _!_+_ : LT a -> Proc a -> (T a -> Proc a) -> Proc a
    _||_  : Proc a -> Proc a -> Proc a
    _/|_  : {b : U} -> Tran a b -> Proc b -> Proc a
    def   : Name a -> Proc a

  Env : Set
  Env = (a : U) -> Name a -> Proc a

record Param : Set1 where
  field
    U    : Set
    T    : U -> Set
    Name : U -> Set
    env  : ProcDef.Env U T Name

module Process (param : Param) where

  private open module Par = Param param      public
  private open module Pro = ProcDef U T Name public

  infixr 40 _!g_ _!_+g_
  infix  40 >g_
  infixr 30 _||g_ _/|g_

  data Guard {a : U} : Proc a -> Set where
    og     : Guard o
    >g_    : (f : T a -> Proc a)                          -> Guard (> f)
    _!g_   : (w : LT a)(p : Proc a)                       -> Guard (w ! p)
    _!_+g_ : (w : LT a)(p : Proc a)(f : T a -> Proc a)    -> Guard (w ! p + f)
    _||g_  : {p1 p2 : Proc a} -> Guard p1 -> Guard p2     -> Guard (p1 || p2)
    _/|g_  : {b : U}(φ : Tran a b){p : Proc b} -> Guard p -> Guard (φ /| p)
    defg   : (x : Name a) -> Guard (env a x)              -> Guard (def x)

  infix 20 _-[_]->_ _-!_!->_

  open Tran

  data _-[_]->_ {a : U} : Proc a -> LT a -> Proc a -> Set where
    qtau   : {p : Proc a}                    -> p -[ bot ]-> p
    rx-o   : {v : T a}                       -> o -[ lift v ]-> o
    rx-!   : {v : T a}{w : LT a}{p : Proc a} -> w ! p -[ lift v ]-> w ! p
    rx->   : {v : T a}{f : T a -> Proc a}    -> > f -[ lift v ]-> f v
    rx-+   : {v : T a}{w : LT a}{p : Proc a}{f : T a -> Proc a} ->
             w ! p + f -[ lift v ]-> f v
    rx-||  : {v : T a}{p1 p2 p1' p2' : Proc a} ->
             p1 -[ lift v ]-> p1' ->
             p2 -[ lift v ]-> p2' ->
             p1 || p2 -[ lift v ]-> p1' || p2'
    rx-/|  : {v : T a}{b : U}{φ : Tran a b}{q q' : Proc b} ->
             q -[ downV φ v ]-> q'   ->
             φ /| q -[ lift v ]-> φ /| q'
    rx-def : {v : T a}{p : Proc a}{x : Name a} ->
             env a x -[ lift v ]-> p ->
             def x -[ lift v ]-> p

  data _-!_!->_ {a : U} : Proc a -> LT a -> Proc a -> Set where
    tx-!   : {w : LT a}{p : Proc a} -> w ! p -! w !-> p
    tx-+   : {w : LT a}{p : Proc a}{f : T a -> Proc a} ->
             w ! p + f -! w !-> p
    tx-!|  : {w : LT a}{p p' q q' : Proc a} ->
             p -! w !-> p' -> q -[ w ]-> q' ->
             p || q -! w !-> p' || q'
    tx-|!  : {w : LT a}{p p' q q' : Proc a} ->
             p -[ w ]-> p' -> q -! w !-> q' ->
             p || q -! w !-> p' || q'
    tx-/|  : {b : U}{w : LT b}{φ : Tran a b}{q q' : Proc b} ->
             q -! w !-> q' ->
             φ /| q -! upV φ =<< w !-> φ /| q'
    tx-def : {w : LT a}{p : Proc a}{x : Name a} ->
             env a x -! w !-> p ->
             def x -! w !-> p

  data Silent {a : U} : Proc a -> Set where
    silent-o   : Silent o
    silent->   : {f : T a -> Proc a} -> Silent (> f)
    silent-||  : {p1 p2 : Proc a} ->
                 Silent p1 -> Silent p2 -> Silent (p1 || p2)
    silent-def : {x : Name a} ->
                 Silent (env _ x) -> Silent (def x)
    silent-/|  : {b : U}{φ : Tran a b}{p : Proc b} ->
                 Silent p -> Silent (φ /| p)

  infixr 40 _>!>_ _>*>_

  data _-[_]->*_ {a : U} : Proc a -> List (T a) -> Proc a -> Set where
    rnop  : {p : Proc a} -> p -[ [] ]->* p
    _>?>_ : {p q r : Proc a}{x : T a}{xs : List (T a)} ->
            p -[ lift x  ]->  q ->
            q -[ xs      ]->* r ->
            p -[ x :: xs ]->* r

  rx-||* : forall {a xs}{p1 p2 q1 q2 : Proc a} ->
           p1 -[ xs ]->* p2 ->
           q1 -[ xs ]->* q2 ->
           p1 || q1 -[ xs ]->* p2 || q2
  rx-||* rnop rnop = rnop
  rx-||* (s1 >?> t1) (s2 >?> t2) = rx-|| s1 s2 >?> rx-||* t1 t2

  rx-/|* : forall {a b xs}{φ : Tran a b}{p q : Proc b} ->
           p -[ mapLT (downV φ) xs ]->* q ->
           φ /| p -[ xs ]->* φ /| q
  rx-/|* {xs = []}      rnop      = rnop
  rx-/|* {xs = x :: xs}{φ = φ} t  with it (downV φ x) refl
  rx-/|* {xs = x :: xs}{φ}{p}{q} t | it bot eq =
      rx-/| (lem₁ eq) >?> rx-/|* (lem₂ eq t)
    where
      lem₁ : forall {w} -> w == bot -> p -[ w ]-> p
      lem₁ refl = qtau

      lem₂ : downV φ x == bot ->
             p -[ mapLT (downV φ) (x :: xs) ]->* q ->
             p -[ mapLT (downV φ) xs ]->* q
      lem₂ eq   h with downV φ x
      lem₂ refl h | .bot = h
  rx-/|* {a}{b}{x :: xs}{φ}{p}{q} t | it (lift y) eq =
      rx-/| (lem₁ eq t) >?> rx-/|* (lem₂ eq t)
    where
      Eqn = downV φ x == lift y
      Asm = p -[ mapLT (downV φ) (x :: xs) ]->* q

      r : Eqn -> Asm -> Proc b
      r eq t with downV φ x
      r refl (_>?>_ {q = q} _ _) | ._ = q

      lem₁ : (eq : Eqn)(h : Asm) -> p -[ downV φ x ]-> r eq h
      lem₁ eq   t with downV φ x
      lem₁ refl (s >?> _) | ._ = s

      lem₂ : (eq : Eqn)(h : Asm) -> r eq h -[ mapLT (downV φ) xs ]->* q
      lem₂ eq   t with downV φ x
      lem₂ refl (_ >?> t) | ._ = t

  data _-!_!->*_ {a : U} : Proc a -> List (T a) -> Proc a -> Set where
    tnop : {p : Proc a} -> p -! [] !->* p
    _>!>_ : {p q r : Proc a}{x : T a}{xs : List (T a)} ->
            p -! lift x  !->  q ->
            q -! xs      !->* r ->
            p -! x :: xs !->* r
    _>*>_ : {p q r : Proc a}{xs : List (T a)} ->
            p -! bot !->  q ->
            q -! xs  !->* r ->
            p -! xs  !->* r


open import Nat
open import Prelude
open import List
open import core
open import judgemental-erase

module moveerase where
  -- type actions don't change the term other than moving the cursor
  -- around
  moveeraset : {t t' : τ̂} {δ : direction} →
            (t + move δ +> t') →
            (t ◆t) == (t' ◆t)
  moveeraset TMArrChild1 = refl
  moveeraset TMArrChild2 = refl
  moveeraset TMArrParent1 = refl
  moveeraset TMArrParent2 = refl
  moveeraset (TMArrZip1 {t2 = t2} m) = ap1 (λ x → x ==> t2) (moveeraset m)
  moveeraset (TMArrZip2 {t1 = t1} m) = ap1 (λ x → t1 ==> x) (moveeraset m)

  -- the actual movements don't change the erasure
  moveerase : {e e' : ê} {δ : direction} →
            (e + move δ +>e e') →
            (e ◆e) == (e' ◆e)
  moveerase EMAscChild1 = refl
  moveerase EMAscChild2 = refl
  moveerase EMAscParent1 = refl
  moveerase EMAscParent2 = refl
  moveerase EMLamChild1 = refl
  moveerase EMLamParent = refl
  moveerase EMPlusChild1 = refl
  moveerase EMPlusChild2 = refl
  moveerase EMPlusParent1 = refl
  moveerase EMPlusParent2 = refl
  moveerase EMApChild1 = refl
  moveerase EMApChild2 = refl
  moveerase EMApParent1 = refl
  moveerase EMApParent2 = refl
  moveerase EMNEHoleChild1 = refl
  moveerase EMNEHoleParent = refl

  -- this form is essentially the same as above, but for judgemental
  -- erasure, which is sometimes more convenient.
  moveerasee' : {e e' : ê} {e◆ : ė} {δ : direction} →
            erase-e e e◆ →
            (e + move δ +>e e') →
            erase-e e' e◆
  moveerasee' er1 m with erase-e◆ er1
  ... | refl = ◆erase-e _ _ (! (moveerase m))

  moveeraset' : ∀{ t t◆ t'' δ} →
                 erase-t t t◆ →
                 t + move δ +> t'' →
                 erase-t t'' t◆
  moveeraset' er m with erase-t◆ er
  moveeraset' er m | refl = ◆erase-t _ _ (! (moveeraset m))

  -- movements don't change either the type or expression under expression
  -- actions
  mutual
    moveerase-synth : ∀{Γ e e' e◆ t t' δ } →
                       (er : erase-e e e◆) →
                       Γ ⊢ e◆ => t →
                       Γ ⊢ e => t ~ move δ ~> e' => t' →
                       (e ◆e) == (e' ◆e) × t == t'
    moveerase-synth er wt (SAMove x) = moveerase x , refl
    moveerase-synth (EEAscL er) (SAsc x) (SAZipAsc1 x₁) = ap1 (λ q → q ·: _) (moveerase-ana er x x₁) , refl
    moveerase-synth er wt (SAZipAsc2 x x₁ x₂ x₃)
      with (moveeraset x)
    ... | qq = ap1 (λ q → _ ·: q) qq , eq-ert-trans qq x₂ x₁
    moveerase-synth (EEApL er) (SAp wt x x₁) (SAZipApArr x₂ x₃ x₄ d x₅)
      with erasee-det x₃ er
    ... | refl with synthunicity wt x₄
    ... | refl with moveerase-synth er x₄ d
    ... | pp , refl with matcharrunicity x x₂
    ... | refl = (ap1 (λ q → q ∘ _) pp ) , refl
    moveerase-synth (EEApR er) (SAp wt x x₁) (SAZipApAna x₂ x₃ x₄)
      with synthunicity x₃ wt
    ... | refl with matcharrunicity x x₂
    ... | refl = ap1 (λ q → _ ∘ q)  (moveerase-ana er x₁ x₄ ) , refl
    moveerase-synth (EEPlusL er) (SPlus x x₁) (SAZipPlus1 x₂) = ap1 (λ q → q ·+ _) (moveerase-ana er x x₂)  , refl
    moveerase-synth (EEPlusR er) (SPlus x x₁) (SAZipPlus2 x₂) = ap1 (λ q → _ ·+ q) (moveerase-ana er x₁ x₂) , refl
    moveerase-synth er wt (SAZipHole x x₁ d) = ap1 ⦇⌜_⌟⦈ (π1 (moveerase-synth x x₁ d)) , refl

    moveerase-ana : ∀{Γ e e' e◆ t δ } →
                      (er : erase-e e e◆) →
                      Γ ⊢ e◆ <= t →
                      Γ ⊢ e ~ move δ ~> e' ⇐ t →
                      (e ◆e) == (e' ◆e)
    moveerase-ana er wt (AASubsume x x₁ x₂ x₃) = π1 (moveerase-synth x x₁ x₂)
    moveerase-ana er wt (AAMove x) = moveerase x
    moveerase-ana (EELam er) (ASubsume () x₂) _
    moveerase-ana (EELam er) (ALam x₁ x₂ wt) (AAZipLam x₃ x₄ d) with matcharrunicity x₂ x₄
    ... | refl =  ap1 (λ q → ·λ _ q) (moveerase-ana er wt d)


module Issue5563 where

F : (@0 A : Set) → A → A
F A x =
  let
    y : A
    y = x
  in y


------------------------------------------------------------------------
-- The Agda standard library
--
-- Coinductive lists
------------------------------------------------------------------------

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

module Codata.Musical.Colist where

open import Category.Monad
open import Codata.Musical.Notation
open import Codata.Musical.Conat using (Coℕ; zero; suc)
open import Data.Bool.Base using (Bool; true; false)
open import Data.BoundedVec.Inefficient as BVec
  using (BoundedVec; []; _∷_)
open import Data.Empty using (⊥)
open import Data.Maybe using (Maybe; nothing; just; Is-just)
open import Data.Maybe.Relation.Unary.Any using (just)
open import Data.Nat.Base using (ℕ; zero; suc; _≥′_; ≤′-refl; ≤′-step)
open import Data.Nat.Properties using (s≤′s)
open import Data.List.Base using (List; []; _∷_)
open import Data.List.NonEmpty using (List⁺; _∷_)
open import Data.Product as Prod using (∃; _×_; _,_)
open import Data.Sum as Sum using (_⊎_; inj₁; inj₂; [_,_]′)
open import Function
open import Function.Equality using (_⟨$⟩_)
open import Function.Inverse as Inv using (_↔_; _↔̇_; Inverse; inverse)
open import Level using (_⊔_)
open import Relation.Binary
import Relation.Binary.Construct.FromRel as Ind
import Relation.Binary.Reasoning.Preorder as PreR
import Relation.Binary.Reasoning.PartialOrder as POR
open import Relation.Binary.PropositionalEquality as P using (_≡_)
open import Relation.Nullary
open import Relation.Nullary.Negation

module ¬¬Monad {p} where
  open RawMonad (¬¬-Monad {p}) public
open ¬¬Monad  -- we don't want the RawMonad content to be opened publicly

------------------------------------------------------------------------
-- The type

infixr 5 _∷_

data Colist {a} (A : Set a) : Set a where
  []  : Colist A
  _∷_ : (x : A) (xs : ∞ (Colist A)) → Colist A

{-# FOREIGN GHC
  data AgdaColist a    = Nil | Cons a (MAlonzo.RTE.Inf (AgdaColist a))
  type AgdaColist' l a = AgdaColist a
  #-}
{-# COMPILE GHC Colist = data AgdaColist' (Nil | Cons) #-}
{-# COMPILE UHC Colist = data __LIST__ (__NIL__ | __CONS__) #-}

module Colist-injective {a} {A : Set a} where

 ∷-injectiveˡ : ∀ {x y : A} {xs ys} → (Colist A ∋ x ∷ xs) ≡ y ∷ ys → x ≡ y
 ∷-injectiveˡ P.refl = P.refl

 ∷-injectiveʳ : ∀ {x y : A} {xs ys} → (Colist A ∋ x ∷ xs) ≡ y ∷ ys → xs ≡ ys
 ∷-injectiveʳ P.refl = P.refl

data Any {a p} {A : Set a} (P : A → Set p) :
         Colist A → Set (a ⊔ p) where
  here  : ∀ {x xs} (px  : P x)          → Any P (x ∷ xs)
  there : ∀ {x xs} (pxs : Any P (♭ xs)) → Any P (x ∷ xs)

module _  {a p} {A : Set a} {P : A → Set p} where

 here-injective : ∀ {x xs p q} → (Any P (x ∷ xs) ∋ here p) ≡ here q → p ≡ q
 here-injective P.refl = P.refl

 there-injective : ∀ {x xs p q} → (Any P (x ∷ xs) ∋ there p) ≡ there q → p ≡ q
 there-injective P.refl = P.refl

data All {a p} {A : Set a} (P : A → Set p) :
         Colist A → Set (a ⊔ p) where
  []  : All P []
  _∷_ : ∀ {x xs} (px : P x) (pxs : ∞ (All P (♭ xs))) → All P (x ∷ xs)

module All-injective {a p} {A : Set a} {P : A → Set p} where

 ∷-injectiveˡ : ∀ {x xs} {px qx pxs qxs} →
                (All P (x ∷ xs) ∋ px ∷ pxs) ≡ qx ∷ qxs → px ≡ qx
 ∷-injectiveˡ P.refl = P.refl

 ∷-injectiveʳ : ∀ {x xs} {px qx pxs qxs} →
                (All P (x ∷ xs) ∋ px ∷ pxs) ≡ qx ∷ qxs → pxs ≡ qxs
 ∷-injectiveʳ P.refl = P.refl

------------------------------------------------------------------------
-- Some operations

null : ∀ {a} {A : Set a} → Colist A → Bool
null []      = true
null (_ ∷ _) = false

length : ∀ {a} {A : Set a} → Colist A → Coℕ
length []       = zero
length (x ∷ xs) = suc (♯ length (♭ xs))

map : ∀ {a b} {A : Set a} {B : Set b} → (A → B) → Colist A → Colist B
map f []       = []
map f (x ∷ xs) = f x ∷ ♯ map f (♭ xs)

fromList : ∀ {a} {A : Set a} → List A → Colist A
fromList []       = []
fromList (x ∷ xs) = x ∷ ♯ fromList xs

take : ∀ {a} {A : Set a} (n : ℕ) → Colist A → BoundedVec A n
take zero    xs       = []
take (suc n) []       = []
take (suc n) (x ∷ xs) = x ∷ take n (♭ xs)

replicate : ∀ {a} {A : Set a} → Coℕ → A → Colist A
replicate zero    x = []
replicate (suc n) x = x ∷ ♯ replicate (♭ n) x

lookup : ∀ {a} {A : Set a} → ℕ → Colist A → Maybe A
lookup n       []       = nothing
lookup zero    (x ∷ xs) = just x
lookup (suc n) (x ∷ xs) = lookup n (♭ xs)

infixr 5 _++_

_++_ : ∀ {a} {A : Set a} → Colist A → Colist A → Colist A
[]       ++ ys = ys
(x ∷ xs) ++ ys = x ∷ ♯ (♭ xs ++ ys)

-- Interleaves the two colists (until the shorter one, if any, has
-- been exhausted).

infixr 5 _⋎_

_⋎_ : ∀ {a} {A : Set a} → Colist A → Colist A → Colist A
[]       ⋎ ys = ys
(x ∷ xs) ⋎ ys = x ∷ ♯ (ys ⋎ ♭ xs)

concat : ∀ {a} {A : Set a} → Colist (List⁺ A) → Colist A
concat []                     = []
concat ((x ∷ [])       ∷ xss) = x ∷ ♯ concat (♭ xss)
concat ((x ∷ (y ∷ xs)) ∷ xss) = x ∷ ♯ concat ((y ∷ xs) ∷ xss)

[_] : ∀ {a} {A : Set a} → A → Colist A
[ x ] = x ∷ ♯ []

------------------------------------------------------------------------
-- Any lemmas

-- Any lemma for map.

Any-map : ∀ {a b p} {A : Set a} {B : Set b} {P : B → Set p}
          {f : A → B} {xs} →
          Any P (map f xs) ↔ Any (P ∘ f) xs
Any-map {P = P} {f} {xs} = inverse to from from∘to to∘from
  where
  to : ∀ {xs} → Any P (map f xs) → Any (P ∘ f) xs
  to {[]}     ()
  to {x ∷ xs} (here px) = here px
  to {x ∷ xs} (there p) = there (to p)

  from : ∀ {xs} → Any (P ∘ f) xs → Any P (map f xs)
  from (here px) = here px
  from (there p) = there (from p)

  from∘to : ∀ {xs} (p : Any P (map f xs)) → from (to p) ≡ p
  from∘to {[]}     ()
  from∘to {x ∷ xs} (here px) = P.refl
  from∘to {x ∷ xs} (there p) = P.cong there (from∘to p)

  to∘from : ∀ {xs} (p : Any (P ∘ f) xs) → to (from p) ≡ p
  to∘from (here px) = P.refl
  to∘from (there p) = P.cong there (to∘from p)

-- Any lemma for _⋎_. This lemma implies that every member of xs or ys
-- is a member of xs ⋎ ys, and vice versa.

Any-⋎ : ∀ {a p} {A : Set a} {P : A → Set p} xs {ys} →
        Any P (xs ⋎ ys) ↔ (Any P xs ⊎ Any P ys)
Any-⋎ {P = P} = λ xs → record
  { to         = P.→-to-⟶ (to xs)
  ; from       = P.→-to-⟶ (from xs)
  ; inverse-of = record
    { left-inverse-of  = from∘to xs
    ; right-inverse-of = to∘from xs
    }
  }
  where
  to : ∀ xs {ys} → Any P (xs ⋎ ys) → Any P xs ⊎ Any P ys
  to []       p         = inj₂ p
  to (x ∷ xs) (here px) = inj₁ (here px)
  to (x ∷ xs) (there p) = [ inj₂ , inj₁ ∘ there ]′ (to _ p)

  mutual

    from-left : ∀ {xs ys} → Any P xs → Any P (xs ⋎ ys)
    from-left           (here px) = here px
    from-left {ys = ys} (there p) = there (from-right ys p)

    from-right : ∀ xs {ys} → Any P ys → Any P (xs ⋎ ys)
    from-right []       p = p
    from-right (x ∷ xs) p = there (from-left p)

  from : ∀ xs {ys} → Any P xs ⊎ Any P ys → Any P (xs ⋎ ys)
  from xs = Sum.[ from-left , from-right xs ]

  from∘to : ∀ xs {ys} (p : Any P (xs ⋎ ys)) → from xs (to xs p) ≡ p
  from∘to []                 p                          = P.refl
  from∘to (x ∷ xs)           (here px)                  = P.refl
  from∘to (x ∷ xs) {ys = ys} (there p)                  with to ys p | from∘to ys p
  from∘to (x ∷ xs) {ys = ys} (there .(from-left q))     | inj₁ q | P.refl = P.refl
  from∘to (x ∷ xs) {ys = ys} (there .(from-right ys q)) | inj₂ q | P.refl = P.refl

  mutual

    to∘from-left : ∀ {xs ys} (p : Any P xs) →
                   to xs {ys = ys} (from-left p) ≡ inj₁ p
    to∘from-left           (here px) = P.refl
    to∘from-left {ys = ys} (there p)
      rewrite to∘from-right ys p = P.refl

    to∘from-right : ∀ xs {ys} (p : Any P ys) →
                    to xs (from-right xs p) ≡ inj₂ p
    to∘from-right []                 p = P.refl
    to∘from-right (x ∷ xs) {ys = ys} p
      rewrite to∘from-left {xs = ys} {ys = ♭ xs} p = P.refl

  to∘from : ∀ xs {ys} (p : Any P xs ⊎ Any P ys) → to xs (from xs p) ≡ p
  to∘from xs = Sum.[ to∘from-left , to∘from-right xs ]

------------------------------------------------------------------------
-- Equality

-- xs ≈ ys means that xs and ys are equal.

infix 4 _≈_

data _≈_ {a} {A : Set a} : (xs ys : Colist A) → Set a where
  []  :                                       []     ≈ []
  _∷_ : ∀ x {xs ys} (xs≈ : ∞ (♭ xs ≈ ♭ ys)) → x ∷ xs ≈ x ∷ ys

-- The equality relation forms a setoid.

setoid : ∀ {ℓ} → Set ℓ → Setoid _ _
setoid A = record
  { Carrier       = Colist A
  ; _≈_           = _≈_
  ; isEquivalence = record
    { refl  = refl
    ; sym   = sym
    ; trans = trans
    }
  }
  where
  refl : Reflexive _≈_
  refl {[]}     = []
  refl {x ∷ xs} = x ∷ ♯ refl

  sym : Symmetric _≈_
  sym []        = []
  sym (x ∷ xs≈) = x ∷ ♯ sym (♭ xs≈)

  trans : Transitive _≈_
  trans []        []         = []
  trans (x ∷ xs≈) (.x ∷ ys≈) = x ∷ ♯ trans (♭ xs≈) (♭ ys≈)

module ≈-Reasoning where
  import Relation.Binary.Reasoning.Setoid as EqR
  private
    open module R {a} {A : Set a} = EqR (setoid A) public

-- map preserves equality.

map-cong : ∀ {a b} {A : Set a} {B : Set b}
           (f : A → B) → _≈_ =[ map f ]⇒ _≈_
map-cong f []        = []
map-cong f (x ∷ xs≈) = f x ∷ ♯ map-cong f (♭ xs≈)

-- Any respects pointwise implication (for the predicate) and equality
-- (for the colist).

Any-resp : ∀ {a p q} {A : Set a} {P : A → Set p} {Q : A → Set q}
           {xs ys} → (∀ {x} → P x → Q x) → xs ≈ ys →
           Any P xs → Any Q ys
Any-resp f (x ∷ xs≈) (here px) = here (f px)
Any-resp f (x ∷ xs≈) (there p) = there (Any-resp f (♭ xs≈) p)

-- Any maps pointwise isomorphic predicates and equal colists to
-- isomorphic types.

Any-cong : ∀ {a p q} {A : Set a} {P : A → Set p} {Q : A → Set q}
           {xs ys} → P ↔̇ Q → xs ≈ ys → Any P xs ↔ Any Q ys
Any-cong {A = A} {P} {Q} {xs} {ys} P↔Q = λ xs≈ys → record
  { to         = P.→-to-⟶ (to xs≈ys)
  ; from       = P.→-to-⟶ (from xs≈ys)
  ; inverse-of = record
    { left-inverse-of  = from∘to _
    ; right-inverse-of = to∘from _
    }
  }
  where
  open Setoid (setoid _) using (sym)

  to : ∀ {xs ys} → xs ≈ ys → Any P xs → Any Q ys
  to xs≈ys = Any-resp (Inverse.to P↔Q ⟨$⟩_) xs≈ys

  from : ∀ {xs ys} → xs ≈ ys → Any Q ys → Any P xs
  from xs≈ys = Any-resp (Inverse.from P↔Q ⟨$⟩_) (sym xs≈ys)

  to∘from : ∀ {xs ys} (xs≈ys : xs ≈ ys) (q : Any Q ys) →
            to xs≈ys (from xs≈ys q) ≡ q
  to∘from (x ∷ xs≈) (there q) = P.cong there (to∘from (♭ xs≈) q)
  to∘from (x ∷ xs≈) (here qx) =
    P.cong here (Inverse.right-inverse-of P↔Q qx)

  from∘to : ∀ {xs ys} (xs≈ys : xs ≈ ys) (p : Any P xs) →
            from xs≈ys (to xs≈ys p) ≡ p
  from∘to (x ∷ xs≈) (there p) = P.cong there (from∘to (♭ xs≈) p)
  from∘to (x ∷ xs≈) (here px) =
    P.cong here (Inverse.left-inverse-of P↔Q px)

------------------------------------------------------------------------
-- Indices

-- Converts Any proofs to indices into the colist. The index can also
-- be seen as the size of the proof.

index : ∀ {a p} {A : Set a} {P : A → Set p} {xs} → Any P xs → ℕ
index (here px) = zero
index (there p) = suc (index p)

-- The position returned by index is guaranteed to be within bounds.

lookup-index : ∀ {a p} {A : Set a} {P : A → Set p} {xs} (p : Any P xs) →
               Is-just (lookup (index p) xs)
lookup-index (here px) = just _
lookup-index (there p) = lookup-index p

-- Any-resp preserves the index.

index-Any-resp :
  ∀ {a p q} {A : Set a} {P : A → Set p} {Q : A → Set q}
    {f : ∀ {x} → P x → Q x} {xs ys}
  (xs≈ys : xs ≈ ys) (p : Any P xs) →
  index (Any-resp f xs≈ys p) ≡ index p
index-Any-resp (x ∷ xs≈) (here px) = P.refl
index-Any-resp (x ∷ xs≈) (there p) =
  P.cong suc (index-Any-resp (♭ xs≈) p)

-- The left-to-right direction of Any-⋎ returns a proof whose size is
-- no larger than that of the input proof.

index-Any-⋎ :
  ∀ {a p} {A : Set a} {P : A → Set p} xs {ys} (p : Any P (xs ⋎ ys)) →
  index p ≥′ [ index , index ]′ (Inverse.to (Any-⋎ xs) ⟨$⟩ p)
index-Any-⋎ []                 p         = ≤′-refl
index-Any-⋎ (x ∷ xs)           (here px) = ≤′-refl
index-Any-⋎ (x ∷ xs) {ys = ys} (there p)
  with Inverse.to (Any-⋎ ys) ⟨$⟩ p | index-Any-⋎ ys p
... | inj₁ q | q≤p = ≤′-step q≤p
... | inj₂ q | q≤p = s≤′s    q≤p

------------------------------------------------------------------------
-- Memberships, subsets, prefixes

-- x ∈ xs means that x is a member of xs.

infix 4 _∈_

_∈_ : ∀ {a} → {A : Set a} → A → Colist A → Set a
x ∈ xs = Any (_≡_ x) xs

-- xs ⊆ ys means that xs is a subset of ys.

infix 4 _⊆_

_⊆_ : ∀ {a} → {A : Set a} → Colist A → Colist A → Set a
xs ⊆ ys = ∀ {x} → x ∈ xs → x ∈ ys

-- xs ⊑ ys means that xs is a prefix of ys.

infix 4 _⊑_

data _⊑_ {a} {A : Set a} : Colist A → Colist A → Set a where
  []  : ∀ {ys}                            → []     ⊑ ys
  _∷_ : ∀ x {xs ys} (p : ∞ (♭ xs ⊑ ♭ ys)) → x ∷ xs ⊑ x ∷ ys

-- Any can be expressed using _∈_ (and vice versa).

Any-∈ : ∀ {a p} {A : Set a} {P : A → Set p} {xs} →
        Any P xs ↔ ∃ λ x → x ∈ xs × P x
Any-∈ {P = P} = record
  { to         = P.→-to-⟶ to
  ; from       = P.→-to-⟶ (λ { (x , x∈xs , p) → from x∈xs p })
  ; inverse-of = record
    { left-inverse-of  = from∘to
    ; right-inverse-of = λ { (x , x∈xs , p) → to∘from x∈xs p }
    }
  }
  where
  to : ∀ {xs} → Any P xs → ∃ λ x → x ∈ xs × P x
  to (here  p) = _ , here P.refl , p
  to (there p) = Prod.map id (Prod.map there id) (to p)

  from : ∀ {x xs} → x ∈ xs → P x → Any P xs
  from (here P.refl) p = here p
  from (there x∈xs)  p = there (from x∈xs p)

  to∘from : ∀ {x xs} (x∈xs : x ∈ xs) (p : P x) →
            to (from x∈xs p) ≡ (x , x∈xs , p)
  to∘from (here P.refl) p = P.refl
  to∘from (there x∈xs)  p =
    P.cong (Prod.map id (Prod.map there id)) (to∘from x∈xs p)

  from∘to : ∀ {xs} (p : Any P xs) →
            let (x , x∈xs , px) = to p in from x∈xs px ≡ p
  from∘to (here _)  = P.refl
  from∘to (there p) = P.cong there (from∘to p)

-- Prefixes are subsets.

⊑⇒⊆ : ∀ {a} → {A : Set a} → _⊑_ {A = A} ⇒ _⊆_
⊑⇒⊆ []          ()
⊑⇒⊆ (x ∷ xs⊑ys) (here ≡x)    = here ≡x
⊑⇒⊆ (_ ∷ xs⊑ys) (there x∈xs) = there (⊑⇒⊆ (♭ xs⊑ys) x∈xs)

-- The prefix relation forms a poset.

⊑-Poset : ∀ {ℓ} → Set ℓ → Poset _ _ _
⊑-Poset A = record
  { Carrier        = Colist A
  ; _≈_            = _≈_
  ; _≤_            = _⊑_
  ; isPartialOrder = record
    { isPreorder = record
      { isEquivalence = Setoid.isEquivalence (setoid A)
      ; reflexive     = reflexive
      ; trans         = trans
      }
    ; antisym  = antisym
    }
  }
  where
  reflexive : _≈_ ⇒ _⊑_
  reflexive []        = []
  reflexive (x ∷ xs≈) = x ∷ ♯ reflexive (♭ xs≈)

  trans : Transitive _⊑_
  trans []        _          = []
  trans (x ∷ xs≈) (.x ∷ ys≈) = x ∷ ♯ trans (♭ xs≈) (♭ ys≈)

  tail : ∀ {x xs y ys} → x ∷ xs ⊑ y ∷ ys → ♭ xs ⊑ ♭ ys
  tail (_ ∷ p) = ♭ p

  antisym : Antisymmetric _≈_ _⊑_
  antisym []       [] = []
  antisym (x ∷ p₁) p₂ = x ∷ ♯ antisym (♭ p₁) (tail p₂)

module ⊑-Reasoning where
  private
    open module R {a} {A : Set a} = POR (⊑-Poset A)
      public renaming (_≤⟨_⟩_ to _⊑⟨_⟩_)

-- The subset relation forms a preorder.

⊆-Preorder : ∀ {ℓ} → Set ℓ → Preorder _ _ _
⊆-Preorder A = Ind.preorder (setoid A) _∈_
                 (λ xs≈ys → ⊑⇒⊆ (⊑P.reflexive xs≈ys))
  where module ⊑P = Poset (⊑-Poset A)

module ⊆-Reasoning where
  private
    open module R {a} {A : Set a} = PreR (⊆-Preorder A)
      public renaming (_∼⟨_⟩_ to _⊆⟨_⟩_)

  infix 1 _∈⟨_⟩_

  _∈⟨_⟩_ : ∀ {a} {A : Set a} (x : A) {xs ys} →
           x ∈ xs → xs IsRelatedTo ys → x ∈ ys
  x ∈⟨ x∈xs ⟩ xs⊆ys = (begin xs⊆ys) x∈xs

-- take returns a prefix.

take-⊑ : ∀ {a} {A : Set a} n (xs : Colist A) →
         let toColist = fromList {a} ∘ BVec.toList in
         toColist (take n xs) ⊑ xs
take-⊑ zero    xs       = []
take-⊑ (suc n) []       = []
take-⊑ (suc n) (x ∷ xs) = x ∷ ♯ take-⊑ n (♭ xs)

------------------------------------------------------------------------
-- Finiteness and infiniteness

-- Finite xs means that xs has finite length.

data Finite {a} {A : Set a} : Colist A → Set a where
  []  : Finite []
  _∷_ : ∀ x {xs} (fin : Finite (♭ xs)) → Finite (x ∷ xs)

module Finite-injective {a} {A : Set a} where

 ∷-injective : ∀ {x : A} {xs p q} → (Finite (x ∷ xs) ∋ x ∷ p) ≡ x ∷ q → p ≡ q
 ∷-injective P.refl = P.refl

-- Infinite xs means that xs has infinite length.

data Infinite {a} {A : Set a} : Colist A → Set a where
  _∷_ : ∀ x {xs} (inf : ∞ (Infinite (♭ xs))) → Infinite (x ∷ xs)

module Infinite-injective {a} {A : Set a} where

 ∷-injective : ∀ {x : A} {xs p q} → (Infinite (x ∷ xs) ∋ x ∷ p) ≡ x ∷ q → p ≡ q
 ∷-injective P.refl = P.refl

-- Colists which are not finite are infinite.

not-finite-is-infinite :
  ∀ {a} {A : Set a} (xs : Colist A) → ¬ Finite xs → Infinite xs
not-finite-is-infinite []       hyp with hyp []
... | ()
not-finite-is-infinite (x ∷ xs) hyp =
  x ∷ ♯ not-finite-is-infinite (♭ xs) (hyp ∘ _∷_ x)

-- Colists are either finite or infinite (classically).

finite-or-infinite :
  ∀ {a} {A : Set a} (xs : Colist A) → ¬ ¬ (Finite xs ⊎ Infinite xs)
finite-or-infinite xs = helper <$> excluded-middle
  where
  helper : Dec (Finite xs) → Finite xs ⊎ Infinite xs
  helper (yes fin) = inj₁ fin
  helper (no ¬fin) = inj₂ $ not-finite-is-infinite xs ¬fin

-- Colists are not both finite and infinite.

not-finite-and-infinite :
  ∀ {a} {A : Set a} {xs : Colist A} → Finite xs → Infinite xs → ⊥
not-finite-and-infinite []        ()
not-finite-and-infinite (x ∷ fin) (.x ∷ inf) =
  not-finite-and-infinite fin (♭ inf)

------------------------------------------------------------------------
-- Legacy

import Codata.Colist as C
open import Codata.Thunk
import Size

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

  fromMusical : ∀ {i} → Colist A → C.Colist A i
  fromMusical []       = C.[]
  fromMusical (x ∷ xs) = x C.∷ λ where .force → fromMusical (♭ xs)

  toMusical : C.Colist A Size.∞ → Colist A
  toMusical C.[]       = []
  toMusical (x C.∷ xs) = x ∷ ♯ toMusical (xs .force)


import Level as L
open import Relation.Nullary
open import Relation.Binary
open import Relation.Binary.PropositionalEquality
open import Data.Product
open import Data.Empty
open import Data.Nat
open import Data.Nat.Properties
open import RevMachine

module PartialRevNoRepeat {ℓ} (M : PartialRevMachine {ℓ}) where
  infix  99 _ᵣₑᵥ
  infixr 10 _∷_
  infixr 10 _++↦_

  open RevMachine.PartialRevMachine M

  is-stuck : State → Set _
  is-stuck st = ∄[ st' ] (st ↦ st')

  is-initial : State → Set _
  is-initial st = ∄[ st' ] (st' ↦ st)

  data _↦ᵣₑᵥ_ : State → State → Set (L.suc ℓ) where
    _ᵣₑᵥ : ∀ {st₁ st₂} → st₁ ↦ st₂ → st₂ ↦ᵣₑᵥ st₁

  data _↦*_ : State → State → Set (L.suc ℓ) where
    ◾ : {st : State} → st ↦* st
    _∷_ : {st₁ st₂ st₃ : State} → st₁ ↦ st₂ → st₂ ↦* st₃ → st₁ ↦* st₃

  _++↦_ : {st₁ st₂ st₃ : State} → st₁ ↦* st₂ → st₂ ↦* st₃ → st₁ ↦* st₃
  ◾ ++↦ st₁↦*st₂ = st₁↦*st₂
  (st₁↦st₁' ∷ st₁'↦*st₂) ++↦ st₂'↦*st₃ = st₁↦st₁' ∷ (st₁'↦*st₂ ++↦ st₂'↦*st₃)

  len↦ : ∀ {st st'} → st ↦* st' → ℕ
  len↦ ◾ = 0
  len↦ (_ ∷ r) = 1 + len↦ r

  data _↦ᵣₑᵥ*_ : State → State → Set (L.suc ℓ) where
    ◾ : ∀ {st} → st ↦ᵣₑᵥ* st
    _∷_ : ∀ {st₁ st₂ st₃} → st₁ ↦ᵣₑᵥ st₂ → st₂ ↦ᵣₑᵥ* st₃ → st₁ ↦ᵣₑᵥ* st₃

  _++↦ᵣₑᵥ_ : ∀ {st₁ st₂ st₃} → st₁ ↦ᵣₑᵥ* st₂ → st₂ ↦ᵣₑᵥ* st₃ → st₁ ↦ᵣₑᵥ* st₃
  ◾ ++↦ᵣₑᵥ st₁↦ᵣₑᵥ*st₂ = st₁↦ᵣₑᵥ*st₂
  (st₁↦ᵣₑᵥst₁' ∷ st₁'↦ᵣₑᵥ*st₂) ++↦ᵣₑᵥ st₂'↦ᵣₑᵥ*st₃ = st₁↦ᵣₑᵥst₁' ∷ (st₁'↦ᵣₑᵥ*st₂ ++↦ᵣₑᵥ st₂'↦ᵣₑᵥ*st₃)

  Rev↦ : ∀ {st₁ st₂} → st₁ ↦* st₂ → st₂ ↦ᵣₑᵥ* st₁
  Rev↦ ◾ = ◾
  Rev↦ (r ∷ rs) = Rev↦ rs ++↦ᵣₑᵥ ((r ᵣₑᵥ) ∷ ◾)

  Rev↦ᵣₑᵥ : ∀ {st₁ st₂} → st₁ ↦ᵣₑᵥ* st₂ → st₂ ↦* st₁
  Rev↦ᵣₑᵥ ◾ = ◾
  Rev↦ᵣₑᵥ ((r ᵣₑᵥ) ∷ rs) = Rev↦ᵣₑᵥ rs ++↦ (r ∷ ◾)

  deterministic* : ∀ {st st₁ st₂} → st ↦* st₁ → st ↦* st₂
                 → is-stuck st₁ → is-stuck st₂
                 → st₁ ≡ st₂
  deterministic* ◾ ◾ stuck₁ stuck₂ = refl
  deterministic* ◾ (r ∷ ↦*₂) stuck₁ stuck₂ = ⊥-elim (stuck₁ (_ , r))
  deterministic* (r ∷ ↦*₁) ◾ stuck₁ stuck₂ = ⊥-elim (stuck₂ (_ , r))
  deterministic* (r₁ ∷ ↦*₁) (r₂ ∷ ↦*₂) stuck₁ stuck₂ with deterministic r₁ r₂
  ... | refl = deterministic* ↦*₁ ↦*₂ stuck₁ stuck₂

  deterministic*' : ∀ {st st₁ st'} → (rs₁ : st ↦* st₁) → (rs : st ↦* st')
                  → is-stuck st'
                  → Σ[ rs' ∈ st₁ ↦* st' ] (len↦ rs ≡ len↦ rs₁ + len↦ rs')
  deterministic*' ◾ rs stuck = rs , refl
  deterministic*' (r ∷ rs₁) ◾ stuck = ⊥-elim (stuck (_ , r))
  deterministic*' (r ∷ rs₁) (r' ∷ rs) stuck with deterministic r r'
  ... | refl with deterministic*' rs₁ rs stuck
  ... | (rs' , eq) = rs' , cong suc eq

  deterministicᵣₑᵥ* : ∀ {st st₁ st₂} → st ↦ᵣₑᵥ* st₁ → st ↦ᵣₑᵥ* st₂ → ¬ (is-fail st)
                    → is-initial st₁ → is-initial st₂
                    → st₁ ≡ st₂
  deterministicᵣₑᵥ* ◾ ◾ _ initial₁ initial₂ = refl
  deterministicᵣₑᵥ* ◾ (r ᵣₑᵥ ∷ ↦ᵣₑᵥ*₂) _ initial₁ initial₂ = ⊥-elim (initial₁ (_ , r))
  deterministicᵣₑᵥ* (r ᵣₑᵥ ∷ ↦ᵣₑᵥ*₁) ◾ _ initial₁ initial₂ = ⊥-elim (initial₂ (_ , r))
  deterministicᵣₑᵥ* (_∷_ {_} {st'} {_} (r₁ ᵣₑᵥ) ↦ᵣₑᵥ*₁) (r₂ ᵣₑᵥ ∷ ↦ᵣₑᵥ*₂) nf initial₁ initial₂ with is-fail? st'
  ... | yes st'-f  = ⊥-elim (fail-is-stuck st'-f (_ , r₁))
  ... | no  st'-nf with deterministicᵣₑᵥ r₁ r₂ nf
  ... | refl = deterministicᵣₑᵥ* ↦ᵣₑᵥ*₁ ↦ᵣₑᵥ*₂ st'-nf initial₁ initial₂

  data _↦[_]_ : State → ℕ → State → Set (L.suc ℓ) where
    ◾ : ∀ {st} → st ↦[ 0 ] st
    _∷_ : ∀ {st₁ st₂ st₃ n} → st₁ ↦ st₂ → st₂ ↦[ n ] st₃ → st₁ ↦[ suc n ] st₃

  _++↦ⁿ_ : ∀ {st₁ st₂ st₃ n m} → st₁ ↦[ n ] st₂ → st₂ ↦[ m ] st₃ → st₁ ↦[ n + m ] st₃
  ◾ ++↦ⁿ st₁↦*st₂ = st₁↦*st₂
  (st₁↦st₁' ∷ st₁'↦*st₂) ++↦ⁿ st₂'↦*st₃ = st₁↦st₁' ∷ (st₁'↦*st₂ ++↦ⁿ st₂'↦*st₃)

  data _↦ᵣₑᵥ[_]_ : State → ℕ → State → Set (L.suc ℓ) where
    ◾ : ∀ {st} → st ↦ᵣₑᵥ[ 0 ] st
    _∷_ : ∀ {st₁ st₂ st₃ n} → st₁ ↦ᵣₑᵥ st₂ → st₂ ↦ᵣₑᵥ[ n ] st₃ → st₁ ↦ᵣₑᵥ[ suc n ] st₃

  _++↦ᵣₑᵥⁿ_ : ∀ {st₁ st₂ st₃ n m} → st₁ ↦ᵣₑᵥ[ n ] st₂ → st₂ ↦ᵣₑᵥ[ m ] st₃ → st₁ ↦ᵣₑᵥ[ n + m ] st₃
  ◾ ++↦ᵣₑᵥⁿ st₁↦*st₂ = st₁↦*st₂
  (st₁↦st₁' ∷ st₁'↦*st₂) ++↦ᵣₑᵥⁿ st₂'↦*st₃ = st₁↦st₁' ∷ (st₁'↦*st₂ ++↦ᵣₑᵥⁿ st₂'↦*st₃)

  deterministicⁿ : ∀ {st st₁ st₂ n} → st ↦[ n ] st₁ → st ↦[ n ] st₂
                 → st₁ ≡ st₂
  deterministicⁿ ◾ ◾ = refl
  deterministicⁿ (r₁ ∷ rs₁) (r₂ ∷ rs₂) with deterministic r₁ r₂
  ... | refl = deterministicⁿ rs₁ rs₂

  deterministicᵣₑᵥⁿ : ∀ {st st₁ st₂ n} → st ↦ᵣₑᵥ[ n ] st₁ → st ↦ᵣₑᵥ[ n ] st₂ → ¬ (is-fail st)
                    → st₁ ≡ st₂
  deterministicᵣₑᵥⁿ ◾ ◾ _ = refl
  deterministicᵣₑᵥⁿ (_∷_ {_} {st'} {_} (r₁ ᵣₑᵥ)  rs₁) (r₂ ᵣₑᵥ ∷ rs₂) nf with is-fail? st'
  ... | yes st'-f  = ⊥-elim (fail-is-stuck st'-f (_ , r₁))
  ... | no  st'-nf with deterministicᵣₑᵥ r₁ r₂ nf
  ... | refl = deterministicᵣₑᵥⁿ rs₁ rs₂ st'-nf

  private
    split↦ⁿ : ∀ {st st'' n m} → st ↦[ n + m ] st''
            → ∃[ st' ] (st ↦[ n ] st' × st' ↦[ m ] st'')
    split↦ⁿ {n = 0} {m} rs = _ , ◾ , rs
    split↦ⁿ {n = suc n} {m} (r ∷ rs) with split↦ⁿ {n = n} {m} rs
    ... | st' , st↦ⁿst' , st'↦ᵐst'' = st' , (r ∷ st↦ⁿst') , st'↦ᵐst''

    split↦ᵣₑᵥⁿ : ∀ {st st'' n m} → st ↦ᵣₑᵥ[ n + m ] st''
               → ∃[ st' ] (st ↦ᵣₑᵥ[ n ] st' × st' ↦ᵣₑᵥ[ m ] st'')
    split↦ᵣₑᵥⁿ {n = 0} {m} rs = _ , ◾ , rs
    split↦ᵣₑᵥⁿ {n = suc n} {m} (r ∷ rs) with split↦ᵣₑᵥⁿ {n = n} {m} rs
    ... | st' , st↦ⁿst' , st'↦ᵐst'' = st' , (r ∷ st↦ⁿst') , st'↦ᵐst''

    diff : ∀ {n m} → n < m → ∃[ k ] (0 < k × n + k ≡ m)
    diff {0} {(suc m)} (s≤s z≤n) = suc m , s≤s z≤n , refl
    diff {(suc n)} {(suc (suc m))} (s≤s (s≤s n≤m)) with diff {n} {suc m} (s≤s n≤m)
    ... | k , 0<k , eq = k , 0<k , cong suc eq

  Revⁿ : ∀ {st st' n} → st ↦[ n ] st' → st' ↦ᵣₑᵥ[ n ] st
  Revⁿ {n = 0} ◾ = ◾
  Revⁿ {n = suc n} (r ∷ rs) rewrite +-comm 1 n = Revⁿ rs ++↦ᵣₑᵥⁿ (r ᵣₑᵥ ∷ ◾)

  NoRepeat : ∀ {st₀ stₙ stₘ n m}
           → is-initial st₀
           → n < m
           → st₀ ↦[ n ] stₙ
           → st₀ ↦[ m ] stₘ
           → stₙ ≢ stₘ
  NoRepeat {stₙ = st} {_} {m} st₀-is-init n<m st₀↦ᵐst st₀↦ᵐ⁺ᵏ⁺¹st refl with diff n<m
  ... | suc k , 0<k , refl with is-fail? st
  ... | yes st-is-f with split↦ⁿ {n = m} {1 + k} st₀↦ᵐ⁺ᵏ⁺¹st
  ... | st′ , st₀↦ᵐst′ , (r ∷ rs) with deterministicⁿ st₀↦ᵐst st₀↦ᵐst′
  ... | refl = ⊥-elim (fail-is-stuck st-is-f (_ , r))
  NoRepeat {stₙ = st} {_} {m} st₀-is-init n<m st₀↦ᵐst st₀↦ᵐ⁺ᵏ⁺¹st refl | suc k , 0<k , refl | no st-is-nf with (Revⁿ st₀↦ᵐst , Revⁿ st₀↦ᵐ⁺ᵏ⁺¹st)
  ... | st'↦ᵐst₀' , st'↦ᵐ⁺ᵏ⁺¹st₀' with split↦ᵣₑᵥⁿ st'↦ᵐ⁺ᵏ⁺¹st₀'
  ... | st′ , st'↦ᵐst′ , st′↦ᵏ⁺¹st₀' with deterministicᵣₑᵥⁿ st'↦ᵐst₀' st'↦ᵐst′ st-is-nf
  ... | refl with st′↦ᵏ⁺¹st₀'
  ... | r ᵣₑᵥ ∷ rs = ⊥-elim (st₀-is-init (_ , r))


------------------------------------------------------------------------
-- A type for values that should be erased at run-time
------------------------------------------------------------------------

-- The definitions in this module are reexported from Erased.

-- This module imports Equivalence.Erased.

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

open import Equality
open import Prelude hiding ([_,_])

module Erased.Level-2
  {c⁺} (eq-J : ∀ {a p} → Equality-with-J a p c⁺) where

open Derived-definitions-and-properties eq-J

open import Logical-equivalence using (_⇔_)

open import Bijection eq-J as Bijection using (_↔_; Has-quasi-inverse)
open import Embedding eq-J as Emb using (Embedding; Is-embedding)
open import Equivalence eq-J as Eq using (_≃_; Is-equivalence)
open import Equivalence.Erased eq-J as EEq
  using (_≃ᴱ_; Is-equivalenceᴱ)
open import Function-universe eq-J as F hiding (id; _∘_)
open import H-level eq-J as H-level
open import H-level.Closure eq-J
open import Injection eq-J using (_↣_; Injective)
open import Monad eq-J hiding (map; map-id; map-∘)
open import Preimage eq-J using (_⁻¹_)
open import Surjection eq-J using (_↠_; Split-surjective)

open import Erased.Level-1 eq-J as E₁
  hiding (module []-cong; module []-cong₂-⊔)

private

  variable
    a b c ℓ ℓ₁ ℓ₂ ℓ₃ : Level
    A B              : Type a
    eq k k′ p x y    : A
    P                : A → Type p
    f g              : A → B
    n                : ℕ

------------------------------------------------------------------------
-- Results that depend on an instantiation of the []-cong axioms (for
-- two universe levels as well as their maximum)

module []-cong₂-⊔
  (ax₁ : E₁.[]-cong-axiomatisation ℓ₁)
  (ax₂ : E₁.[]-cong-axiomatisation ℓ₂)
  (ax  : E₁.[]-cong-axiomatisation (ℓ₁ ⊔ ℓ₂))
  where

  open E₁.Erased-cong ax ax
  open E₁.[]-cong₁ ax₂
  open E₁.[]-cong₂ ax₁ ax₂
  open E₁.[]-cong₂-⊔ ax₁ ax₂ ax

  private

    module EEq′ = EEq.[]-cong₂-⊔ ax₁ ax₂ ax

  ----------------------------------------------------------------------
  -- Erased commutes with all kinds of functions (in some cases
  -- assuming extensionality)

  private

    -- A lemma used below.

    Erased-≃ᴱ↔≃ᴱ :
      {@0 A : Type ℓ₁} {@0 B : Type ℓ₂} →
      Erased (A ≃ᴱ B) ↝[ ℓ₁ ⊔ ℓ₂ ∣ ℓ₁ ⊔ ℓ₂ ]ᴱ (Erased A ≃ᴱ Erased B)
    Erased-≃ᴱ↔≃ᴱ {A = A} {B = B} ext =
      Erased (A ≃ᴱ B)                                                   ↔⟨ Erased-cong-≃ EEq.≃ᴱ-as-Σ ⟩
      Erased (∃ λ (f : A → B) → Is-equivalenceᴱ f)                      ↔⟨ Erased-Σ↔Σ ⟩
      (∃ λ (f : Erased (A → B)) → Erased (Is-equivalenceᴱ (erased f)))  ↝⟨ (Σ-cong Erased-Π↔Π-Erased λ _ →
                                                                            EEq′.Erased-Is-equivalenceᴱ↔Is-equivalenceᴱ ext) ⟩
      (∃ λ (f : Erased A → Erased B) → Is-equivalenceᴱ f)               ↔⟨ inverse EEq.≃ᴱ-as-Σ ⟩□
      Erased A ≃ᴱ Erased B                                              □

  -- Erased commutes with all kinds of functions (in some cases
  -- assuming extensionality).

  Erased-↝↝↝ :
    {@0 A : Type ℓ₁} {@0 B : Type ℓ₂} →
    Erased (A ↝[ k ] B) ↝[ ℓ₁ ⊔ ℓ₂ ∣ ℓ₁ ⊔ ℓ₂ ] (Erased A ↝[ k ] Erased B)
  Erased-↝↝↝ {k = implication} _ = from-isomorphism Erased-Π↔Π-Erased

  Erased-↝↝↝ {k = logical-equivalence} _ = from-isomorphism Erased-⇔↔⇔

  Erased-↝↝↝ {k = injection} {A = A} {B = B} ext =
    Erased (A ↣ B)                                              ↔⟨ Erased-cong-↔ ↣↔∃-Injective ⟩
    Erased (∃ λ (f : A → B) → Injective f)                      ↔⟨ Erased-Σ↔Σ ⟩
    (∃ λ (f : Erased (A → B)) → Erased (Injective (erased f)))  ↝⟨ Σ-cong Erased-Π↔Π-Erased (λ _ → Erased-Injective↔Injective ext) ⟩
    (∃ λ (f : Erased A → Erased B) → Injective f)               ↔⟨ inverse ↣↔∃-Injective ⟩□
    Erased A ↣ Erased B                                         □

  Erased-↝↝↝ {k = embedding} {A = A} {B = B} ext =
    Erased (Embedding A B)                                         ↔⟨ Erased-cong-↔ Emb.Embedding-as-Σ ⟩
    Erased (∃ λ (f : A → B) → Is-embedding f)                      ↔⟨ Erased-Σ↔Σ ⟩
    (∃ λ (f : Erased (A → B)) → Erased (Is-embedding (erased f)))  ↝⟨ Σ-cong Erased-Π↔Π-Erased (λ _ → Erased-Is-embedding↔Is-embedding ext) ⟩
    (∃ λ (f : Erased A → Erased B) → Is-embedding f)               ↔⟨ inverse Emb.Embedding-as-Σ ⟩□
    Embedding (Erased A) (Erased B)                                □

  Erased-↝↝↝ {k = surjection} {A = A} {B = B} {k = k′} ext =
    Erased (A ↠ B)                                                     ↔⟨ Erased-cong-↔ ↠↔∃-Split-surjective ⟩
    Erased (∃ λ (f : A → B) → Split-surjective f)                      ↔⟨ Erased-Σ↔Σ ⟩
    (∃ λ (f : Erased (A → B)) → Erased (Split-surjective (erased f)))  ↝⟨ Σ-cong Erased-Π↔Π-Erased (λ _ →
                                                                          Erased-Split-surjective↔Split-surjective
                                                                            (lower-extensionality? k′ ℓ₁ lzero ext)) ⟩
    (∃ λ (f : Erased A → Erased B) → Split-surjective f)               ↔⟨ inverse ↠↔∃-Split-surjective ⟩□
    Erased A ↠ Erased B                                                □

  Erased-↝↝↝ {k = bijection} {A = A} {B = B} ext =
    Erased (A ↔ B)                                                      ↔⟨ Erased-cong-↔ Bijection.↔-as-Σ ⟩
    Erased (∃ λ (f : A → B) → Has-quasi-inverse f)                      ↔⟨ Erased-Σ↔Σ ⟩
    (∃ λ (f : Erased (A → B)) → Erased (Has-quasi-inverse (erased f)))  ↝⟨ (Σ-cong Erased-Π↔Π-Erased λ _ →
                                                                            Erased-Has-quasi-inverse↔Has-quasi-inverse ext) ⟩
    (∃ λ (f : Erased A → Erased B) → Has-quasi-inverse f)               ↔⟨ inverse Bijection.↔-as-Σ ⟩□
    Erased A ↔ Erased B                                                 □

  Erased-↝↝↝ {k = equivalence} {A = A} {B = B} ext =
    Erased (A ≃ B)                                                   ↔⟨ Erased-cong-↔ Eq.≃-as-Σ ⟩
    Erased (∃ λ (f : A → B) → Is-equivalence f)                      ↔⟨ Erased-Σ↔Σ ⟩
    (∃ λ (f : Erased (A → B)) → Erased (Is-equivalence (erased f)))  ↝⟨ Σ-cong Erased-Π↔Π-Erased (λ _ → Erased-Is-equivalence↔Is-equivalence ext) ⟩
    (∃ λ (f : Erased A → Erased B) → Is-equivalence f)               ↔⟨ inverse Eq.≃-as-Σ ⟩□
    Erased A ≃ Erased B                                              □

  Erased-↝↝↝ {k = equivalenceᴱ} ext = Erased-≃ᴱ↔≃ᴱ ext

  -- Erased commutes with all kinds of functions (in some cases
  -- assuming extensionality).

  Erased-↝↔↝ :
    {@0 A : Type ℓ₁} {@0 B : Type ℓ₂} →
    Extensionality? k (ℓ₁ ⊔ ℓ₂) (ℓ₁ ⊔ ℓ₂) →
    Erased (A ↝[ k ] B) ↔ (Erased A ↝[ k ] Erased B)
  Erased-↝↔↝ {k = implication}         = λ _ → Erased-Π↔Π-Erased
  Erased-↝↔↝ {k = logical-equivalence} = λ _ → Erased-⇔↔⇔
  Erased-↝↔↝ {k = injection}           = Erased-↝↝↝
  Erased-↝↔↝ {k = embedding}           = Erased-↝↝↝
  Erased-↝↔↝ {k = surjection}          = Erased-↝↝↝
  Erased-↝↔↝ {k = bijection}           = Erased-↝↝↝
  Erased-↝↔↝ {k = equivalence}         = Erased-↝↝↝
  Erased-↝↔↝ {k = equivalenceᴱ}        = λ ([ ext ]) → Erased-≃ᴱ↔≃ᴱ ext

  -- Erased-↝↔↝ and Erased-↝↝↝ produce equal functions.

  to-Erased-↝↔↝≡to-Erased-↝↝↝ :
    {@0 A : Type ℓ₁} {@0 B : Type ℓ₂}
    (ext : Extensionality? k (ℓ₁ ⊔ ℓ₂) (ℓ₁ ⊔ ℓ₂))
    (ext′ : Extensionality? k′ (ℓ₁ ⊔ ℓ₂) (ℓ₁ ⊔ ℓ₂)) →
    _↔_.to (Erased-↝↔↝ {k = k} {A = A} {B = B} ext) ≡
    to-implication (Erased-↝↝↝ {k = k} {A = A} {B = B} {k = k′} ext′)
  to-Erased-↝↔↝≡to-Erased-↝↝↝ {k = implication}         {k′ = implication}         _ _   = refl _
  to-Erased-↝↔↝≡to-Erased-↝↝↝ {k = implication}         {k′ = logical-equivalence} _ _   = refl _
  to-Erased-↝↔↝≡to-Erased-↝↝↝ {k = implication}         {k′ = injection}           _ _   = refl _
  to-Erased-↝↔↝≡to-Erased-↝↝↝ {k = implication}         {k′ = embedding}           _ _   = refl _
  to-Erased-↝↔↝≡to-Erased-↝↝↝ {k = implication}         {k′ = surjection}          _ _   = refl _
  to-Erased-↝↔↝≡to-Erased-↝↝↝ {k = implication}         {k′ = bijection}           _ _   = refl _
  to-Erased-↝↔↝≡to-Erased-↝↝↝ {k = implication}         {k′ = equivalence}         _ _   = refl _
  to-Erased-↝↔↝≡to-Erased-↝↝↝ {k = implication}         {k′ = equivalenceᴱ}        _ _   = refl _
  to-Erased-↝↔↝≡to-Erased-↝↝↝ {k = logical-equivalence} {k′ = implication}         _ _   = refl _
  to-Erased-↝↔↝≡to-Erased-↝↝↝ {k = logical-equivalence} {k′ = logical-equivalence} _ _   = refl _
  to-Erased-↝↔↝≡to-Erased-↝↝↝ {k = logical-equivalence} {k′ = injection}           _ _   = refl _
  to-Erased-↝↔↝≡to-Erased-↝↝↝ {k = logical-equivalence} {k′ = embedding}           _ _   = refl _
  to-Erased-↝↔↝≡to-Erased-↝↝↝ {k = logical-equivalence} {k′ = surjection}          _ _   = refl _
  to-Erased-↝↔↝≡to-Erased-↝↝↝ {k = logical-equivalence} {k′ = bijection}           _ _   = refl _
  to-Erased-↝↔↝≡to-Erased-↝↝↝ {k = logical-equivalence} {k′ = equivalence}         _ _   = refl _
  to-Erased-↝↔↝≡to-Erased-↝↝↝ {k = logical-equivalence} {k′ = equivalenceᴱ}        _ _   = refl _
  to-Erased-↝↔↝≡to-Erased-↝↝↝ {k = injection}           {k′ = implication}         _ _   = refl _
  to-Erased-↝↔↝≡to-Erased-↝↝↝ {k = injection}           {k′ = logical-equivalence} _ _   = refl _
  to-Erased-↝↔↝≡to-Erased-↝↝↝ {k = injection}           {k′ = injection}           _ _   = refl _
  to-Erased-↝↔↝≡to-Erased-↝↝↝ {k = injection}           {k′ = embedding}           _ _   = refl _
  to-Erased-↝↔↝≡to-Erased-↝↝↝ {k = injection}           {k′ = surjection}          _ _   = refl _
  to-Erased-↝↔↝≡to-Erased-↝↝↝ {k = injection}           {k′ = bijection}           _ _   = refl _
  to-Erased-↝↔↝≡to-Erased-↝↝↝ {k = injection}           {k′ = equivalence}         _ _   = refl _
  to-Erased-↝↔↝≡to-Erased-↝↝↝ {k = injection}           {k′ = equivalenceᴱ}        _ _   = refl _
  to-Erased-↝↔↝≡to-Erased-↝↝↝ {k = surjection}          {k′ = implication}         _ _   = refl _
  to-Erased-↝↔↝≡to-Erased-↝↝↝ {k = surjection}          {k′ = logical-equivalence} _ _   = refl _
  to-Erased-↝↔↝≡to-Erased-↝↝↝ {k = surjection}          {k′ = injection}           _ _   = refl _
  to-Erased-↝↔↝≡to-Erased-↝↝↝ {k = surjection}          {k′ = embedding}           _ _   = refl _
  to-Erased-↝↔↝≡to-Erased-↝↝↝ {k = surjection}          {k′ = surjection}          _ _   = refl _
  to-Erased-↝↔↝≡to-Erased-↝↝↝ {k = surjection}          {k′ = bijection}           _ _   = refl _
  to-Erased-↝↔↝≡to-Erased-↝↝↝ {k = surjection}          {k′ = equivalence}         _ _   = refl _
  to-Erased-↝↔↝≡to-Erased-↝↝↝ {k = surjection}          {k′ = equivalenceᴱ}        _ _   = refl _
  to-Erased-↝↔↝≡to-Erased-↝↝↝ {k = bijection}           {k′ = implication}         _ _   = refl _
  to-Erased-↝↔↝≡to-Erased-↝↝↝ {k = bijection}           {k′ = logical-equivalence} _ _   = refl _
  to-Erased-↝↔↝≡to-Erased-↝↝↝ {k = bijection}           {k′ = injection}           _ _   = refl _
  to-Erased-↝↔↝≡to-Erased-↝↝↝ {k = bijection}           {k′ = embedding}           _ _   = refl _
  to-Erased-↝↔↝≡to-Erased-↝↝↝ {k = bijection}           {k′ = surjection}          _ _   = refl _
  to-Erased-↝↔↝≡to-Erased-↝↝↝ {k = bijection}           {k′ = bijection}           _ _   = refl _
  to-Erased-↝↔↝≡to-Erased-↝↝↝ {k = bijection}           {k′ = equivalence}         _ _   = refl _
  to-Erased-↝↔↝≡to-Erased-↝↝↝ {k = bijection}           {k′ = equivalenceᴱ}        _ _   = refl _
  to-Erased-↝↔↝≡to-Erased-↝↝↝ {k = equivalence}         {k′ = implication}         _ _   = refl _
  to-Erased-↝↔↝≡to-Erased-↝↝↝ {k = equivalence}         {k′ = logical-equivalence} _ _   = refl _
  to-Erased-↝↔↝≡to-Erased-↝↝↝ {k = equivalence}         {k′ = injection}           _ _   = refl _
  to-Erased-↝↔↝≡to-Erased-↝↝↝ {k = equivalence}         {k′ = embedding}           _ _   = refl _
  to-Erased-↝↔↝≡to-Erased-↝↝↝ {k = equivalence}         {k′ = surjection}          _ _   = refl _
  to-Erased-↝↔↝≡to-Erased-↝↝↝ {k = equivalence}         {k′ = bijection}           _ _   = refl _
  to-Erased-↝↔↝≡to-Erased-↝↝↝ {k = equivalence}         {k′ = equivalence}         _ _   = refl _
  to-Erased-↝↔↝≡to-Erased-↝↝↝ {k = equivalence}         {k′ = equivalenceᴱ}        _ _   = refl _
  to-Erased-↝↔↝≡to-Erased-↝↝↝ {k = equivalenceᴱ}        {k′ = implication}         _ _   = refl _
  to-Erased-↝↔↝≡to-Erased-↝↝↝ {k = equivalenceᴱ}        {k′ = logical-equivalence} _ _   = refl _
  to-Erased-↝↔↝≡to-Erased-↝↝↝ {k = equivalenceᴱ}        {k′ = injection}           _ ext = apply-ext ext λ _ → EEq′.to≡to→≡-Erased ext (refl _)
  to-Erased-↝↔↝≡to-Erased-↝↝↝ {k = equivalenceᴱ}        {k′ = embedding}           _ ext = apply-ext ext λ _ → EEq′.to≡to→≡-Erased ext (refl _)
  to-Erased-↝↔↝≡to-Erased-↝↝↝ {k = equivalenceᴱ}        {k′ = surjection}          _ ext = apply-ext ext λ _ → EEq′.to≡to→≡-Erased ext (refl _)
  to-Erased-↝↔↝≡to-Erased-↝↝↝ {k = equivalenceᴱ}        {k′ = bijection}           _ ext = apply-ext ext λ _ → EEq′.to≡to→≡-Erased ext (refl _)
  to-Erased-↝↔↝≡to-Erased-↝↝↝ {k = equivalenceᴱ}        {k′ = equivalence}         _ ext = apply-ext ext λ _ → EEq′.to≡to→≡-Erased ext (refl _)
  to-Erased-↝↔↝≡to-Erased-↝↝↝ {k = equivalenceᴱ}        {k′ = equivalenceᴱ}        _ _   = refl _
  to-Erased-↝↔↝≡to-Erased-↝↝↝ {k = embedding} {k′ = implication}         ext _ = apply-ext ext λ _ → _↔_.to (Embedding-to-≡↔≡ ext) λ _ → refl _
  to-Erased-↝↔↝≡to-Erased-↝↝↝ {k = embedding} {k′ = logical-equivalence} ext _ = apply-ext ext λ _ → _↔_.to (Embedding-to-≡↔≡ ext) λ _ → refl _
  to-Erased-↝↔↝≡to-Erased-↝↝↝ {k = embedding} {k′ = injection}           ext _ = apply-ext ext λ _ → _↔_.to (Embedding-to-≡↔≡ ext) λ _ → refl _
  to-Erased-↝↔↝≡to-Erased-↝↝↝ {k = embedding} {k′ = embedding}           ext _ = apply-ext ext λ _ → _↔_.to (Embedding-to-≡↔≡ ext) λ _ → refl _
  to-Erased-↝↔↝≡to-Erased-↝↝↝ {k = embedding} {k′ = surjection}          ext _ = apply-ext ext λ _ → _↔_.to (Embedding-to-≡↔≡ ext) λ _ → refl _
  to-Erased-↝↔↝≡to-Erased-↝↝↝ {k = embedding} {k′ = bijection}           ext _ = apply-ext ext λ _ → _↔_.to (Embedding-to-≡↔≡ ext) λ _ → refl _
  to-Erased-↝↔↝≡to-Erased-↝↝↝ {k = embedding} {k′ = equivalence}         ext _ = apply-ext ext λ _ → _↔_.to (Embedding-to-≡↔≡ ext) λ _ → refl _
  to-Erased-↝↔↝≡to-Erased-↝↝↝ {k = embedding} {k′ = equivalenceᴱ}        ext _ = apply-ext ext λ _ → _↔_.to (Embedding-to-≡↔≡ ext) λ _ → refl _

  -- Erased preserves all kinds of functions.

  Erased-cong :
    {@0 A : Type ℓ₁} {@0 B : Type ℓ₂} →
    @0 A ↝[ k ] B → Erased A ↝[ k ] Erased B
  Erased-cong A↝B = Erased-↝↝↝ _ [ A↝B ]

  -- Dec-Erased preserves symmetric kinds of functions (in some cases
  -- assuming extensionality).

  Dec-Erased-cong :
    {@0 A : Type ℓ₁} {@0 B : Type ℓ₂} →
    @0 Extensionality? ⌊ k ⌋-sym (ℓ₁ ⊔ ℓ₂) lzero →
    @0 A ↝[ ⌊ k ⌋-sym ] B →
    Dec-Erased A ↝[ ⌊ k ⌋-sym ] Dec-Erased B
  Dec-Erased-cong ext A↝B =
    Erased-cong A↝B ⊎-cong Erased-cong (→-cong ext A↝B F.id)

------------------------------------------------------------------------
-- Results that depend on three instances of the axiomatisation of
-- []-cong, all for the same universe level

module []-cong₁₃
  (ax₁ : E₁.[]-cong-axiomatisation ℓ)
  (ax₂ : E₁.[]-cong-axiomatisation ℓ)
  (ax  : E₁.[]-cong-axiomatisation ℓ)
  where

  -- Note that []-cong₂-⊔, which contains Erased-cong, is instantiated
  -- with all of the module parameters.

  open []-cong₂-⊔ ax₁ ax₂ ax

  private
    module BC₁ = E₁.[]-cong₁ ax₁
    module BC₂ = E₁.[]-cong₁ ax₂

  ----------------------------------------------------------------------
  -- Erased-cong maps F.id to F.id for all kinds of functions (in some
  -- cases assuming extensionality)

  private

    -- Lemmas used in the implementation of Erased-cong-id.

    Erased-cong-≃-id :
      {@0 A : Type ℓ} →
      Extensionality ℓ ℓ →
      Erased-cong {k = equivalence} F.id ≡ F.id {A = Erased A}
    Erased-cong-≃-id ext = Eq.lift-equality ext (refl _)

    Erased-cong-≃ᴱ-id :
      {@0 A : Type ℓ} →
      Erased (Extensionality ℓ ℓ) →
      Erased-cong {k = equivalenceᴱ} F.id ≡ F.id {A = Erased A}
    Erased-cong-≃ᴱ-id [ ext ] =
      EEq.[]-cong₂-⊔.to≡to→≡-Erased ax₁ ax₂ ax ext (refl _)

    Erased-cong-Embedding-id :
      {@0 A : Type ℓ} →
      Extensionality ℓ ℓ →
      Erased-cong {k = embedding} F.id ≡ F.id {A = Erased A}
    Erased-cong-Embedding-id ext =
      _↔_.to (Embedding-to-≡↔≡ ext) λ _ → refl _

    Erased-cong-↠-id :
      {@0 A : Type ℓ} →
      Extensionality ℓ ℓ →
      Erased-cong {k = surjection} F.id ≡ F.id {A = Erased A}
    Erased-cong-↠-id ext =                              $⟨ lemma ⟩
      _↔_.to ↠↔∃-Split-surjective (Erased-cong F.id) ≡
      _↔_.to ↠↔∃-Split-surjective F.id                  ↝⟨ Eq.≃-≡ (from-isomorphism ↠↔∃-Split-surjective) ⟩□

      Erased-cong F.id ≡ F.id                           □
      where
      lemma :
        (map id , λ x → [ erased x ] , BC₂.[]-cong [ refl _ ]) ≡
        (id , λ x → x , refl _)
      lemma =
        cong (_ ,_) $ apply-ext ext λ _ → cong (_ ,_) BC₂.[]-cong-[refl]

    Erased-cong-↔-id :
      {@0 A : Type ℓ} →
      Extensionality ℓ ℓ →
      Erased-cong {k = bijection} F.id ≡ F.id {A = Erased A}
    Erased-cong-↔-id ext =                          $⟨ lemma ⟩
      _↔_.to Bijection.↔-as-Σ (Erased-cong F.id) ≡
      _↔_.to Bijection.↔-as-Σ F.id                  ↝⟨ Eq.≃-≡ (from-isomorphism Bijection.↔-as-Σ) ⟩□

      Erased-cong F.id ≡ F.id                       □
      where
      lemma :
        ( map id
        , map id
        , (λ { [ x ] → BC₂.[]-cong [ refl x ] })
        , (λ { [ x ] → BC₁.[]-cong [ refl x ] })
        ) ≡
        (id , id , refl , refl)
      lemma = cong (λ p → id , id , p) $ cong₂ _,_
        (apply-ext ext λ _ → BC₂.[]-cong-[refl])
        (apply-ext ext λ _ → BC₁.[]-cong-[refl])

    Erased-cong-↣-id :
      {@0 A : Type ℓ} →
      Extensionality ℓ ℓ →
      Erased-cong {k = injection} F.id ≡ F.id {A = Erased A}
    Erased-cong-↣-id ext =                       $⟨ lemma ⟩
      _↔_.to ↣↔∃-Injective (Erased-cong F.id) ≡
      _↔_.to ↣↔∃-Injective F.id                  ↝⟨ Eq.≃-≡ (from-isomorphism ↣↔∃-Injective) ⟩□

      Erased-cong F.id ≡ F.id                    □
      where
      lemma :
        ( map id
        , λ {_ _} → _↣_.injective (Erased-cong F.id)
        ) ≡
        (id , λ {_ _} → _↣_.injective F.id)
      lemma =
        cong (_ ,_) $
        implicit-extensionality ext λ _ →
        implicit-extensionality ext λ _ →
        apply-ext ext λ eq →
          BC₁.[]-cong (BC₂.[]-cong⁻¹ eq)  ≡⟨ []-cong-unique ax₁ ax₂ ⟩
          BC₂.[]-cong (BC₂.[]-cong⁻¹ eq)  ≡⟨ _↔_.right-inverse-of BC₂.Erased-≡↔[]≡[] _ ⟩∎
          eq                              ∎

  -- Erased-cong maps F.id to F.id for all kinds of functions (in some
  -- cases assuming extensionality).

  Erased-cong-id :
    {@0 A : Type ℓ} →
    Extensionality? k ℓ ℓ →
    Erased-cong F.id ≡ F.id {k = k} {A = Erased A}
  Erased-cong-id {k = implication}         = λ _ → map-id
  Erased-cong-id {k = logical-equivalence} = λ _ → Erased-cong-⇔-id
  Erased-cong-id {k = injection}           = Erased-cong-↣-id
  Erased-cong-id {k = embedding}           = Erased-cong-Embedding-id
  Erased-cong-id {k = surjection}          = Erased-cong-↠-id
  Erased-cong-id {k = bijection}           = Erased-cong-↔-id
  Erased-cong-id {k = equivalence}         = Erased-cong-≃-id
  Erased-cong-id {k = equivalenceᴱ}        = Erased-cong-≃ᴱ-id

------------------------------------------------------------------------
-- Results that depend on instances of the axiomatisation of []-cong
-- for three universe levels, as well as for the maximum of each pair
-- drawn from these three levels

module []-cong₃-⊔
  (ax₁  : []-cong-axiomatisation ℓ₁)
  (ax₂  : []-cong-axiomatisation ℓ₂)
  (ax₃  : []-cong-axiomatisation ℓ₃)
  (ax₁₂ : []-cong-axiomatisation (ℓ₁ ⊔ ℓ₂))
  (ax₁₃ : []-cong-axiomatisation (ℓ₁ ⊔ ℓ₃))
  (ax₂₃ : []-cong-axiomatisation (ℓ₂ ⊔ ℓ₃))
  where

  private
    module EC₁ = []-cong₂-⊔ ax₁ ax₃ ax₁₃
    module EC₂ = []-cong₂-⊔ ax₂ ax₃ ax₂₃
    module EC₃ = []-cong₂-⊔ ax₁ ax₂ ax₁₂

  ----------------------------------------------------------------------
  -- Erased-cong commutes with F._∘_ for all kinds of functions (in
  -- some cases assuming extensionality)

  private

    -- Lemmas used in the implementation of Erased-cong-∘.

    Erased-cong-≃-∘ :
      {@0 A : Type ℓ₁} {@0 B : Type ℓ₂} {@0 C : Type ℓ₃} →
      Extensionality (ℓ₁ ⊔ ℓ₃) (ℓ₁ ⊔ ℓ₃) →
      (@0 f : B ≃ C) (@0 g : A ≃ B) →
      EC₁.Erased-cong {k = equivalence} (f F.∘ g) ≡
      EC₂.Erased-cong f F.∘ EC₃.Erased-cong g
    Erased-cong-≃-∘ ext _ _ = Eq.lift-equality ext (refl _)

    Erased-cong-≃ᴱ-∘ :
      {@0 A : Type ℓ₁} {@0 B : Type ℓ₂} {@0 C : Type ℓ₃} →
      Erased (Extensionality (ℓ₁ ⊔ ℓ₃) (ℓ₁ ⊔ ℓ₃)) →
      (@0 f : B ≃ᴱ C) (@0 g : A ≃ᴱ B) →
      EC₁.Erased-cong {k = equivalenceᴱ} (f F.∘ g) ≡
      EC₂.Erased-cong f F.∘ EC₃.Erased-cong g
    Erased-cong-≃ᴱ-∘ [ ext ] _ _ =
      EEq.[]-cong₂-⊔.to≡to→≡-Erased ax₁ ax₃ ax₁₃ ext (refl _)

    Erased-cong-Embedding-∘ :
      {@0 A : Type ℓ₁} {@0 B : Type ℓ₂} {@0 C : Type ℓ₃} →
      Extensionality (ℓ₁ ⊔ ℓ₃) (ℓ₁ ⊔ ℓ₃) →
      (@0 f : Embedding B C) (@0 g : Embedding A B) →
      EC₁.Erased-cong {k = embedding} (f F.∘ g) ≡
      EC₂.Erased-cong f F.∘ EC₃.Erased-cong g
    Erased-cong-Embedding-∘ ext _ _ =
      _↔_.to (Embedding-to-≡↔≡ ext) λ _ → refl _

    right-inverse-of-cong-∘ :
      ∀ {ℓ₁ ℓ₂ ℓ₃}
      (ax₁  : []-cong-axiomatisation ℓ₁)
      (ax₂  : []-cong-axiomatisation ℓ₂)
      (ax₃  : []-cong-axiomatisation ℓ₃)
      (ax₁₂ : []-cong-axiomatisation (ℓ₁ ⊔ ℓ₂))
      (ax₁₃ : []-cong-axiomatisation (ℓ₁ ⊔ ℓ₃))
      (ax₂₃ : []-cong-axiomatisation (ℓ₂ ⊔ ℓ₃)) →
      let module EC₁′ = []-cong₂-⊔ ax₁ ax₃ ax₁₃
          module EC₂′ = []-cong₂-⊔ ax₂ ax₃ ax₂₃
          module EC₃′ = []-cong₂-⊔ ax₁ ax₂ ax₁₂
      in
      ∀ {@0 A : Type ℓ₁} {@0 B : Type ℓ₂} {@0 C : Type ℓ₃} {x} →
      (@0 f : B ↠ C) (@0 g : A ↠ B) →
      _↠_.right-inverse-of (EC₁′.Erased-cong (f F.∘ g)) x ≡
      _↠_.right-inverse-of (EC₂′.Erased-cong f F.∘ EC₃′.Erased-cong g) x
    right-inverse-of-cong-∘ ax₁ ax₂ ax₃ _ _ _ {x = [ x ]} f g =
      BC₃.[]-cong [ trans (cong (_↠_.to f)
                                  (_↠_.right-inverse-of g
                                     (_↠_.from f x)))
                               (_↠_.right-inverse-of f x)
                  ]                                         ≡⟨ E₁.[]-cong₁.[]-cong-trans ax₃ ⟩

      trans (BC₃.[]-cong [ cong (_↠_.to f)
                             (_↠_.right-inverse-of g
                                (_↠_.from f x)) ])
        (BC₃.[]-cong [ _↠_.right-inverse-of f x ])          ≡⟨ cong (λ p → trans p _) (E₁.[]-cong₂.[]-cong-cong ax₂ ax₃) ⟩∎

      trans (cong (map (_↠_.to f))
                     (BC₂.[]-cong [ _↠_.right-inverse-of g
                                      (_↠_.from f x) ]))
        (BC₃.[]-cong [ _↠_.right-inverse-of f x ])          ∎
      where
      module BC₂ = E₁.[]-cong₁ ax₂
      module BC₃ = E₁.[]-cong₁ ax₃

    Erased-cong-↠-∘ :
      {@0 A : Type ℓ₁} {@0 B : Type ℓ₂} {@0 C : Type ℓ₃} →
      Extensionality ℓ₃ (ℓ₁ ⊔ ℓ₃) →
      (@0 f : B ↠ C) (@0 g : A ↠ B) →
      EC₁.Erased-cong {k = surjection} (f F.∘ g) ≡
      EC₂.Erased-cong f F.∘ EC₃.Erased-cong g
    Erased-cong-↠-∘ ext f g =                                    $⟨ lemma ⟩
      _↔_.to ↠↔∃-Split-surjective (EC₁.Erased-cong (f F.∘ g)) ≡
      _↔_.to ↠↔∃-Split-surjective
        (EC₂.Erased-cong f F.∘ EC₃.Erased-cong g)                ↝⟨ Eq.≃-≡ (from-isomorphism ↠↔∃-Split-surjective) ⟩□

      EC₁.Erased-cong (f F.∘ g) ≡
      EC₂.Erased-cong f F.∘ EC₃.Erased-cong g                    □
      where
      lemma :
        ( map (_↠_.to f ∘ _↠_.to g)
        , (λ x →
               [ _↠_.from g (_↠_.from f (erased x)) ]
             , _↠_.right-inverse-of (EC₁.Erased-cong (f F.∘ g)) x)
        )
        ≡
        ( (λ x → [ _↠_.to f (_↠_.to g (erased x)) ])
        , (λ x →
               [ _↠_.from g (_↠_.from f (erased x)) ]
             , _↠_.right-inverse-of
                 (EC₂.Erased-cong f F.∘ EC₃.Erased-cong g) x)
        )
      lemma =
        cong (_ ,_) $ apply-ext ext λ ([ x ]) →
          cong ([ _↠_.from g (_↠_.from f x) ] ,_)
            (right-inverse-of-cong-∘ ax₁ ax₂ ax₃ ax₁₂ ax₁₃ ax₂₃ f g)

    Erased-cong-↔-∘ :
      {@0 A : Type ℓ₁} {@0 B : Type ℓ₂} {@0 C : Type ℓ₃} →
      Extensionality (ℓ₁ ⊔ ℓ₃) (ℓ₁ ⊔ ℓ₃) →
      (@0 f : B ↔ C) (@0 g : A ↔ B) →
      EC₁.Erased-cong {k = bijection} (f F.∘ g) ≡
      EC₂.Erased-cong f F.∘ EC₃.Erased-cong g
    Erased-cong-↔-∘ ext f g =                                            $⟨ lemma ⟩
      _↔_.to Bijection.↔-as-Σ (EC₁.Erased-cong (f F.∘ g)) ≡
      _↔_.to Bijection.↔-as-Σ (EC₂.Erased-cong f F.∘ EC₃.Erased-cong g)  ↝⟨ Eq.≃-≡ (from-isomorphism Bijection.↔-as-Σ) ⟩□

      EC₁.Erased-cong (f F.∘ g) ≡
      EC₂.Erased-cong f F.∘ EC₃.Erased-cong g                            □
      where
      lemma :
        ( map (_↔_.to f ∘ _↔_.to g)
        , map (_↔_.from g ∘ _↔_.from f)
        , _↔_.right-inverse-of (EC₁.Erased-cong (f F.∘ g))
        , _↔_.left-inverse-of (EC₁.Erased-cong (f F.∘ g))
        )
        ≡
        ( (λ x → [ _↔_.to f (_↔_.to g (erased x)) ])
        , (λ x → [ _↔_.from g (_↔_.from f (erased x)) ])
        , _↔_.right-inverse-of (EC₂.Erased-cong f F.∘ EC₃.Erased-cong g)
        , _↔_.left-inverse-of (EC₂.Erased-cong f F.∘ EC₃.Erased-cong g)
        )
      lemma =
        cong (λ p → map (_↔_.to f ∘ _↔_.to g)
                  , map (_↔_.from g ∘ _↔_.from f) , p) $
        cong₂ _,_
          (apply-ext (lower-extensionality ℓ₁ ℓ₁ ext) λ _ →
             right-inverse-of-cong-∘ ax₁ ax₂ ax₃ ax₁₂ ax₁₃ ax₂₃
               (_↔_.surjection f) (_↔_.surjection g))
          (apply-ext (lower-extensionality ℓ₃ ℓ₃ ext) λ _ →
           right-inverse-of-cong-∘ ax₃ ax₂ ax₁ ax₂₃ ax₁₃ ax₁₂
              (_↔_.surjection $ inverse g)
              (_↔_.surjection $ inverse f))

    Erased-cong-↣-∘ :
      {@0 A : Type ℓ₁} {@0 B : Type ℓ₂} {@0 C : Type ℓ₃} →
      Extensionality (ℓ₁ ⊔ ℓ₃) (ℓ₁ ⊔ ℓ₃) →
      (@0 f : B ↣ C) (@0 g : A ↣ B) →
      EC₁.Erased-cong {k = injection} (f F.∘ g) ≡
      EC₂.Erased-cong f F.∘ EC₃.Erased-cong g
    Erased-cong-↣-∘ ext f g =                                         $⟨ lemma ⟩
      _↔_.to ↣↔∃-Injective (EC₁.Erased-cong (f F.∘ g)) ≡
      _↔_.to ↣↔∃-Injective (EC₂.Erased-cong f F.∘ EC₃.Erased-cong g)  ↝⟨ Eq.≃-≡ (from-isomorphism ↣↔∃-Injective) ⟩□

      EC₁.Erased-cong (f F.∘ g) ≡
      EC₂.Erased-cong f F.∘ EC₃.Erased-cong g                         □
      where
      module BC₁ = E₁.[]-cong₁ ax₁
      module BC₂ = E₁.[]-cong₁ ax₂
      module BC₃ = E₁.[]-cong₁ ax₃

      lemma :
        ( map (_↣_.to f ∘ _↣_.to g)
        , λ {_ _} → _↣_.injective (EC₁.Erased-cong (f F.∘ g))
        )
        ≡
        ( (λ x → [ _↣_.to f (_↣_.to g (erased x)) ])
        , λ {_ _} →
            _↣_.injective (EC₂.Erased-cong f F.∘ EC₃.Erased-cong g)
        )
      lemma =
        cong (_ ,_) $
        implicit-extensionality
          (lower-extensionality ℓ₃ lzero ext) λ _ →
        implicit-extensionality
          (lower-extensionality ℓ₃ lzero ext) λ _ →
        apply-ext (lower-extensionality ℓ₁ ℓ₃ ext) λ eq →
          let eq′ = [ _↣_.injective f (erased (BC₃.[]-cong⁻¹ eq)) ]
          in
          BC₁.[]-cong [ _↣_.injective g (erased eq′) ]                  ≡⟨ cong BC₁.[]-cong $
                                                                           BC₁.[]-cong [ cong (_↣_.injective g ∘ erased) $ sym $
                                                                                _↔_.left-inverse-of BC₂.Erased-≡↔[]≡[] _ ] ⟩∎
          BC₁.[]-cong [ _↣_.injective g
                          (erased (BC₂.[]-cong⁻¹ (BC₂.[]-cong eq′))) ]  ∎

  -- Erased-cong commutes with F._∘_ for all kinds of functions (in
  -- some cases assuming extensionality).

  Erased-cong-∘ :
    {@0 A : Type ℓ₁} {@0 B : Type ℓ₂} {@0 C : Type ℓ₃} →
    Extensionality? k (ℓ₁ ⊔ ℓ₃) (ℓ₁ ⊔ ℓ₃) →
    (@0 f : B ↝[ k ] C) (@0 g : A  ↝[ k ] B) →
    EC₁.Erased-cong (f F.∘ g) ≡ EC₂.Erased-cong f F.∘ EC₃.Erased-cong g
  Erased-cong-∘ {k = implication}         = λ _ f → map-∘ f
  Erased-cong-∘ {k = logical-equivalence} = λ _ → Erased-cong-⇔-∘
  Erased-cong-∘ {k = injection}           = Erased-cong-↣-∘
  Erased-cong-∘ {k = embedding}           = λ ext f g →
                                              Erased-cong-Embedding-∘
                                                ext f g
  Erased-cong-∘ {k = surjection}          = λ ext →
                                              Erased-cong-↠-∘
                                                (lower-extensionality ℓ₁ lzero ext)
  Erased-cong-∘ {k = bijection}           = Erased-cong-↔-∘
  Erased-cong-∘ {k = equivalence}         = Erased-cong-≃-∘
  Erased-cong-∘ {k = equivalenceᴱ}        = λ ext f g →
                                              Erased-cong-≃ᴱ-∘ ext f g

------------------------------------------------------------------------
-- Results that depend on instances of the axiomatisation of []-cong
-- for all universe levels

module []-cong (ax : ∀ {ℓ} → []-cong-axiomatisation ℓ) where

  private
    open module BC₂ {ℓ₁ ℓ₂} = []-cong₂-⊔ (ax {ℓ = ℓ₁}) (ax {ℓ = ℓ₂}) ax
      public
    open module BC₁₃ {ℓ} = []-cong₁₃ (ax {ℓ = ℓ}) ax ax
      public
    open module BC₃ {ℓ₁ ℓ₂ ℓ₃} =
      []-cong₃-⊔ (ax {ℓ = ℓ₁}) (ax {ℓ = ℓ₂}) (ax {ℓ = ℓ₃}) ax ax ax
      public


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

open import Cubical.Core.Everything
open import Cubical.Relation.Binary

module Cubical.Relation.Binary.Construct.NonStrictToStrict
  {a ℓ} {A : Type a} (_≤_ : Rel A ℓ) where

open import Cubical.Relation.Binary.Properties
open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Logic hiding (_⇒_; ¬_)

open import Cubical.Data.Sigma
open import Cubical.Data.Sum.Base using (inl; inr)
open import Cubical.Data.Empty
open import Cubical.Foundations.Function using (_∘_; flip; id)
open import Cubical.Relation.Nullary
import Cubical.HITs.PropositionalTruncation as PT

------------------------------------------------------------------------
-- _≤_ can be turned into _<_ as follows:

_<_ : Rel A _
x < y = x ≤ y ⊓ x ≢ₚ y

------------------------------------------------------------------------
-- Relationship between relations

<⇒≤ : _<_ ⇒ _≤_
<⇒≤ = fst

<⇒≢ : _<_ ⇒ _≢ₚ_
<⇒≢ = snd

≤∧≢⇒< : ∀ {x y} → ⟨ x ≤ y ⟩ → ⟨ x ≢ₚ y ⟩ → ⟨ x < y ⟩
≤∧≢⇒< = _,_

<⇒≱ : Antisymmetric _≤_ → ∀ {x y} → ⟨ x < y ⟩ → ¬ ⟨ y ≤ x ⟩
<⇒≱ antisym (x≤y , x≢y) y≤x = x≢y (antisym x≤y y≤x)

≤⇒≯ : Antisymmetric _≤_ → ∀ {x y} → ⟨ x ≤ y ⟩ → ¬ ⟨ y < x ⟩
≤⇒≯ antisym x≤y y<x = <⇒≱ antisym y<x x≤y

≰⇒> : Reflexive _≤_ → Total _≤_ →
      ∀ {x y} → ¬ ⟨ x ≤ y ⟩ → ⟨ y < x ⟩
≰⇒> rfl total {x} {y} x≰y = PT.rec ((y < x) .snd) (λ {
    (inl x≤y) → elim (x≰y x≤y)
  ; (inr y≤x) → y≤x , x≰y ∘ reflx→fromeq _≤_ rfl ∘ PT.map sym
  }) (total x y)

≮⇒≥ : Discrete A → Reflexive _≤_ → Total _≤_ →
      ∀ {x y} → ¬ ⟨ x < y ⟩ → ⟨ y ≤ x ⟩
≮⇒≥ _≟_ ≤-refl _≤?_ {x} {y} x≮y with x ≟ y
... | yes x≈y = reflx→fromeq _≤_ ≤-refl ∣ sym x≈y ∣
... | no x≢y = PT.rec ((y ≤ x) .snd) (λ {
        (inl y≤x) → y≤x
      ; (inr x≤y) → elim (x≮y (x≤y , x≢y ∘ PT.rec (Discrete→isSet _≟_ _ _) id))
      }) (y ≤? x)
------------------------------------------------------------------------
-- Relational properties

<-toNotEq : ToNotEq _<_
<-toNotEq (_ , x≢y) x≡y = x≢y x≡y

<-irrefl : Irreflexive _<_
<-irrefl = tonoteq→irrefl _<_ <-toNotEq

<-transitive : IsPartialOrder _≤_ → Transitive _<_
<-transitive po (x≤y , x≢y) (y≤z , y≉z) =
  (transitive x≤y y≤z , x≢y ∘ antisym x≤y ∘ transitive y≤z ∘ fromEq ∘ PT.map sym)
  where open IsPartialOrder po

<-≤-trans : Transitive _≤_ → Antisymmetric _≤_ →
           Trans _<_ _≤_ _<_
<-≤-trans transitive antisym (x≤y , x≢y) y≤z =
  transitive x≤y y≤z , (λ x≡z → x≢y (antisym x≤y (Respectsʳ≡ₚ _≤_ (PT.map sym x≡z) y≤z)))

≤-<-trans : Transitive _≤_ → Antisymmetric _≤_ →
           Trans _≤_ _<_ _<_
≤-<-trans trans antisym x≤y (y≤z , y≢z) =
  trans x≤y y≤z , (λ x≡z → y≢z (antisym y≤z (Respectsˡ≡ₚ _≤_ x≡z x≤y)))

<-asym : Antisymmetric _≤_ → Asymmetric _<_
<-asym antisym (x≤y , x≢y) (y≤x , _) = x≢y (antisym x≤y y≤x)
{-
<-trichotomous : Discrete A → Antisymmetric _≤_ → Total _≤_ → Trichotomous _<_
<-trichotomous _≟_ antisym total x y with x ≟ y
... | yes x≡y = tri≡ (λ x<y → ?) x≡y (λ y<x → <-toNotEq y<x (PT.map sym x≡y))
... | no  x≢y with total x y
...   | inl x≤y = tri< (x≤y , x≢y) x≢y (x≢y ∘ antisym x≤y ∘ proj₁)
...   | inr y≤x = tri> (x≢y ∘ flip antisym y≤x ∘ proj₁) x≢y (y≤x , x≢y ∘ sym)
-}
<-decidable : Discrete A → Decidable _≤_ → Decidable _<_
<-decidable _≟_ _≤?_ x y with x ≤? y
... | no ¬p = no (¬p ∘ fst)
... | yes p with x ≟ y
...   | yes q = no (λ x<y → snd x<y ∣ q ∣)
...   | no ¬q = yes (p , ¬q ∘ PT.rec (Discrete→isSet _≟_ _ _) id)

------------------------------------------------------------------------
-- Structures
{-
isStrictPartialOrder : IsPartialOrder _≤_ → IsStrictPartialOrder _<_
isStrictPartialOrder po = record
  { irrefl     = <-irrefl
  ; transitive = <-transitive po
  } where open IsPartialOrder po

isStrictTotalOrder₁ : Discrete A → IsTotalOrder _≤_ →
                        IsStrictTotalOrder _<_
isStrictTotalOrder₁ ≟ tot = record
  { transitive = <-transitive isPartialOrder
  ; compare    = <-trichotomous ≟ antisym total
  } where open IsTotalOrder tot

isStrictTotalOrder₂ : IsDecTotalOrder _≤_ → IsStrictTotalOrder _<_
isStrictTotalOrder₂ dtot = isStrictTotalOrder₁ _≟_ isTotalOrder
  where open IsDecTotalOrder dtot
-}


-- Andreas, 2012-11-22 issue #729, abstract aliases
-- Andreas, 2016-07-19 issue #2102, better fix of #418 helps!

module Issue729 where

abstract
  B = Set
  B₁ = B
  B₂ = Set

abstract
  foo : Set₁
  foo = x
    where x = B

mutual
  abstract
    D = C
    C = B

abstract
  mutual
    F = E
    E = D

-- other stuff

private
  A = Set

Y = let X = Set in Set


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

open import Definition.Typed.EqualityRelation

module Definition.LogicalRelation.Substitution.Irrelevance {{eqrel : EqRelSet}} where
open EqRelSet {{...}}

open import Definition.Untyped
open import Definition.Typed
open import Definition.LogicalRelation
import Definition.LogicalRelation.Irrelevance as LR
open import Definition.LogicalRelation.Substitution

open import Tools.Product
open import Tools.Unit
import Tools.PropositionalEquality as PE

-- Irrelevance of valid substitutions with different derivations of contexts
irrelevanceSubst : ∀ {σ Γ Δ}
                   ([Γ] [Γ]′ : ⊩ᵛ Γ)
                   (⊢Δ ⊢Δ′ : ⊢ Δ)
                 → Δ ⊩ˢ σ ∷ Γ / [Γ]  / ⊢Δ
                 → Δ ⊩ˢ σ ∷ Γ / [Γ]′ / ⊢Δ′
irrelevanceSubst ε′ ε′ ⊢Δ ⊢Δ′ [σ] = tt
irrelevanceSubst ([Γ] ∙′ [A]) ([Γ]′ ∙′ [A]′) ⊢Δ ⊢Δ′ ([tailσ] , [headσ]) =
  let [tailσ]′ = irrelevanceSubst [Γ] [Γ]′ ⊢Δ ⊢Δ′ [tailσ]
  in  [tailσ]′
  ,   LR.irrelevanceTerm (proj₁ ([A] ⊢Δ [tailσ]))
                            (proj₁ ([A]′ ⊢Δ′ [tailσ]′))
                            [headσ]

-- Irrelevance of valid substitutions with different contexts
-- that are propositionally equal
irrelevanceSubst′ : ∀ {σ Γ Δ Δ′}
                    (eq : Δ PE.≡ Δ′)
                    ([Γ] [Γ]′ : ⊩ᵛ Γ)
                    (⊢Δ  : ⊢ Δ)
                    (⊢Δ′ : ⊢ Δ′)
                  → Δ  ⊩ˢ σ ∷ Γ / [Γ]  / ⊢Δ
                  → Δ′ ⊩ˢ σ ∷ Γ / [Γ]′ / ⊢Δ′
irrelevanceSubst′ PE.refl [Γ] [Γ]′ ⊢Δ ⊢Δ′ [σ] = irrelevanceSubst [Γ] [Γ]′ ⊢Δ ⊢Δ′ [σ]

-- Irrelevance of valid substitution equality
-- with different derivations of contexts
irrelevanceSubstEq : ∀ {σ σ′ Γ Δ}
                     ([Γ] [Γ]′ : ⊩ᵛ Γ)
                     (⊢Δ ⊢Δ′ : ⊢ Δ)
                     ([σ]  : Δ ⊩ˢ σ ∷ Γ / [Γ]  / ⊢Δ)
                     ([σ]′ : Δ ⊩ˢ σ ∷ Γ / [Γ]′ / ⊢Δ′)
                   → Δ ⊩ˢ σ ≡ σ′ ∷ Γ / [Γ]  / ⊢Δ  / [σ]
                   → Δ ⊩ˢ σ ≡ σ′ ∷ Γ / [Γ]′ / ⊢Δ′ / [σ]′
irrelevanceSubstEq ε′ ε′ ⊢Δ ⊢Δ′ [σ] [σ]′ [σ≡σ′] = tt
irrelevanceSubstEq ([Γ] ∙′ [A]) ([Γ]′ ∙′ [A]′) ⊢Δ ⊢Δ′ [σ] [σ]′ [σ≡σ′] =
  irrelevanceSubstEq [Γ] [Γ]′ ⊢Δ ⊢Δ′ (proj₁ [σ]) (proj₁ [σ]′) (proj₁ [σ≡σ′])
  , LR.irrelevanceEqTerm (proj₁ ([A] ⊢Δ  (proj₁ [σ])))
                            (proj₁ ([A]′ ⊢Δ′ (proj₁ [σ]′)))
                            (proj₂ [σ≡σ′])

-- Irrelevance of valid types with different derivations of contexts
irrelevance : ∀ {l A Γ}
              ([Γ] [Γ]′ : ⊩ᵛ Γ)
            → Γ ⊩ᵛ⟨ l ⟩ A / [Γ]
            → Γ ⊩ᵛ⟨ l ⟩ A / [Γ]′
irrelevance [Γ] [Γ]′ [A] ⊢Δ [σ] =
  let [σ]′ = irrelevanceSubst [Γ]′ [Γ] ⊢Δ ⊢Δ [σ]
  in  proj₁ ([A] ⊢Δ [σ]′)
   ,  λ [σ′] [σ≡σ′] → proj₂ ([A] ⊢Δ [σ]′)
                       (irrelevanceSubst [Γ]′ [Γ] ⊢Δ ⊢Δ [σ′])
                       (irrelevanceSubstEq [Γ]′ [Γ] ⊢Δ ⊢Δ [σ] [σ]′ [σ≡σ′])

open import Definition.LogicalRelation.Properties

-- Irrelevance of valid types with different derivations of contexts
-- with lifting of eqaul types
irrelevanceLift : ∀ {l A F H Γ}
              ([Γ] : ⊩ᵛ Γ)
              ([F] : Γ ⊩ᵛ⟨ l ⟩ F / [Γ])
              ([H] : Γ ⊩ᵛ⟨ l ⟩ H / [Γ])
              ([F≡H] : Γ ⊩ᵛ⟨ l ⟩ F ≡ H / [Γ] / [F])
            → Γ ∙ F ⊩ᵛ⟨ l ⟩ A / (VPack _ _ (V∙ [Γ] [F]))
            → Γ ∙ H ⊩ᵛ⟨ l ⟩ A / (VPack _ _ (V∙ [Γ] [H]))
irrelevanceLift [Γ] [F] [H] [F≡H] [A] ⊢Δ ([tailσ] , [headσ]) =
  let [σ]′ = [tailσ] , convTerm₂ (proj₁ ([F] ⊢Δ [tailσ]))
                                 (proj₁ ([H] ⊢Δ [tailσ]))
                                 ([F≡H] ⊢Δ [tailσ]) [headσ]
  in  proj₁ ([A] ⊢Δ [σ]′)
  ,   (λ [σ′] x →
         let [σ′]′ = proj₁ [σ′] , convTerm₂ (proj₁ ([F] ⊢Δ (proj₁ [σ′])))
                                            (proj₁ ([H] ⊢Δ (proj₁ [σ′])))
                                            ([F≡H] ⊢Δ (proj₁ [σ′]))
                                            (proj₂ [σ′])
             [tailσ′] = proj₁ [σ′]
         in  proj₂ ([A] ⊢Δ [σ]′) [σ′]′
                   (proj₁ x , convEqTerm₂ (proj₁ ([F] ⊢Δ [tailσ]))
                                          (proj₁ ([H] ⊢Δ [tailσ]))
                                          ([F≡H] ⊢Δ [tailσ])
                                          (proj₂ x)))

-- Irrelevance of valid type equality with different derivations of
-- contexts and types
irrelevanceEq : ∀ {l l′ A B Γ}
                ([Γ] [Γ]′ : ⊩ᵛ Γ)
                ([A]  : Γ ⊩ᵛ⟨ l  ⟩ A / [Γ])
                ([A]′ : Γ ⊩ᵛ⟨ l′ ⟩ A / [Γ]′)
              → Γ ⊩ᵛ⟨ l  ⟩ A ≡ B / [Γ]  / [A]
              → Γ ⊩ᵛ⟨ l′ ⟩ A ≡ B / [Γ]′ / [A]′
irrelevanceEq [Γ] [Γ]′ [A] [A]′ [A≡B] ⊢Δ [σ] =
  let [σ]′ = irrelevanceSubst [Γ]′ [Γ] ⊢Δ ⊢Δ [σ]
  in  LR.irrelevanceEq (proj₁ ([A] ⊢Δ [σ]′))
                       (proj₁ ([A]′ ⊢Δ [σ]))
                       ([A≡B] ⊢Δ [σ]′)

-- Irrelevance of valid terms with different derivations of contexts and types
irrelevanceTerm : ∀ {l l′ A t Γ}
                  ([Γ] [Γ]′ : ⊩ᵛ Γ)
                  ([A]  : Γ ⊩ᵛ⟨ l  ⟩ A / [Γ])
                  ([A]′ : Γ ⊩ᵛ⟨ l′ ⟩ A / [Γ]′)
                → Γ ⊩ᵛ⟨ l  ⟩ t ∷ A / [Γ]  / [A]
                → Γ ⊩ᵛ⟨ l′ ⟩ t ∷ A / [Γ]′ / [A]′
irrelevanceTerm [Γ] [Γ]′ [A] [A]′ [t] ⊢Δ [σ]′ =
  let [σ]   = irrelevanceSubst [Γ]′ [Γ] ⊢Δ ⊢Δ [σ]′
      [σA]  = proj₁ ([A] ⊢Δ [σ])
      [σA]′ = proj₁ ([A]′ ⊢Δ [σ]′)
  in  LR.irrelevanceTerm [σA] [σA]′ (proj₁ ([t] ⊢Δ [σ]))
   ,  (λ [σ′] x → LR.irrelevanceEqTerm [σA] [σA]′ ((proj₂ ([t] ⊢Δ [σ]))
                    (irrelevanceSubst [Γ]′ [Γ] ⊢Δ ⊢Δ [σ′])
                    (irrelevanceSubstEq [Γ]′ [Γ] ⊢Δ ⊢Δ [σ]′ [σ] x)))

-- Irrelevance of valid terms with different derivations of
-- contexts and types which are propositionally equal
irrelevanceTerm′ : ∀ {l l′ A A′ t Γ}
                   (eq : A PE.≡ A′)
                   ([Γ] [Γ]′ : ⊩ᵛ Γ)
                   ([A]  : Γ ⊩ᵛ⟨ l  ⟩ A / [Γ])
                   ([A′] : Γ ⊩ᵛ⟨ l′ ⟩ A′ / [Γ]′)
                 → Γ ⊩ᵛ⟨ l  ⟩ t ∷ A / [Γ]  / [A]
                 → Γ ⊩ᵛ⟨ l′ ⟩ t ∷ A′ / [Γ]′ / [A′]
irrelevanceTerm′ {A = A} {t = t} PE.refl [Γ] [Γ]′ [A] [A]′ [t] =
  irrelevanceTerm {A = A} {t = t} [Γ] [Γ]′ [A] [A]′ [t]

-- Irrelevance of valid terms with different derivations of
-- contexts and types with a lifting of equal types
irrelevanceTermLift : ∀ {l A F H t Γ}
              ([Γ] : ⊩ᵛ Γ)
              ([F] : Γ ⊩ᵛ⟨ l ⟩ F / [Γ])
              ([H] : Γ ⊩ᵛ⟨ l ⟩ H / [Γ])
              ([F≡H] : Γ ⊩ᵛ⟨ l ⟩ F ≡ H / [Γ] / [F])
              ([A] : Γ ∙ F ⊩ᵛ⟨ l ⟩ A / (VPack _ _ (V∙ [Γ] [F])))
            → Γ ∙ F ⊩ᵛ⟨ l ⟩ t ∷ A / (VPack _ _ (V∙ [Γ] [F])) / [A]
            → Γ ∙ H ⊩ᵛ⟨ l ⟩ t ∷ A / (VPack _ _ (V∙ [Γ] [H]))
                           / irrelevanceLift {A = A} {F = F} {H = H}
                                             [Γ] [F] [H] [F≡H] [A]
irrelevanceTermLift [Γ] [F] [H] [F≡H] [A] [t] ⊢Δ ([tailσ] , [headσ]) =
  let [σ]′ = [tailσ] , convTerm₂ (proj₁ ([F] ⊢Δ [tailσ]))
                                 (proj₁ ([H] ⊢Δ [tailσ]))
                                 ([F≡H] ⊢Δ [tailσ]) [headσ]
  in  proj₁ ([t] ⊢Δ [σ]′)
  , (λ [σ′] x →
       let [σ′]′ = proj₁ [σ′] , convTerm₂ (proj₁ ([F] ⊢Δ (proj₁ [σ′])))
                                          (proj₁ ([H] ⊢Δ (proj₁ [σ′])))
                                          ([F≡H] ⊢Δ (proj₁ [σ′]))
                                          (proj₂ [σ′])
           [tailσ′] = proj₁ [σ′]
       in  proj₂ ([t] ⊢Δ [σ]′) [σ′]′
                 (proj₁ x , convEqTerm₂ (proj₁ ([F] ⊢Δ [tailσ]))
                                        (proj₁ ([H] ⊢Δ [tailσ]))
                                        ([F≡H] ⊢Δ [tailσ])
                                        (proj₂ x)))

-- Irrelevance of valid term equality with different derivations of
-- contexts and types
irrelevanceEqTerm : ∀ {l l′ A t u Γ}
                  ([Γ] [Γ]′ : ⊩ᵛ Γ)
                  ([A]  : Γ ⊩ᵛ⟨ l  ⟩ A / [Γ])
                  ([A]′ : Γ ⊩ᵛ⟨ l′ ⟩ A / [Γ]′)
                → Γ ⊩ᵛ⟨ l  ⟩ t ≡ u ∷ A / [Γ]  / [A]
                → Γ ⊩ᵛ⟨ l′ ⟩ t ≡ u ∷ A / [Γ]′ / [A]′
irrelevanceEqTerm {A = A} {t = t} {u = u} [Γ] [Γ]′ [A] [A]′ [t≡u] ⊢Δ [σ] =
  let [σ]′ = irrelevanceSubst [Γ]′ [Γ] ⊢Δ ⊢Δ [σ]
  in  LR.irrelevanceEqTerm (proj₁ ([A] ⊢Δ [σ]′))
                           (proj₁ ([A]′ ⊢Δ [σ]))
                           ([t≡u] ⊢Δ [σ]′)


module MLib.Prelude where

open import MLib.Prelude.FromStdlib public

module Fin where
  open import MLib.Prelude.Fin public
open Fin using (Fin; zero; suc) hiding (module Fin) public


module TelescopingLet2 where

f : (let ★ = Set) (A : ★) → A → Set₁
f A x = ★
-- should fail, since ★ is not in scope in the definition


------------------------------------------------------------------------
-- A definitional interpreter
------------------------------------------------------------------------

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

module Lambda.Simplified.Delay-monad.Interpreter where

open import Equality.Propositional
open import Prelude

open import Monad equality-with-J
open import Vec.Function equality-with-J

open import Delay-monad
open import Delay-monad.Bisimilarity
open import Delay-monad.Monad

open import Lambda.Simplified.Syntax

open Closure Tm

------------------------------------------------------------------------
-- The interpreter

infix 10 _∙_

mutual

  ⟦_⟧ : ∀ {i n} → Tm n → Env n → Delay Value i
  ⟦ var x ⟧   ρ = return (ρ x)
  ⟦ ƛ t ⟧     ρ = return (ƛ t ρ)
  ⟦ t₁ · t₂ ⟧ ρ = ⟦ t₁ ⟧ ρ >>= λ v₁ →
                  ⟦ t₂ ⟧ ρ >>= λ v₂ →
                  v₁ ∙ v₂

  _∙_ : ∀ {i} → Value → Value → Delay Value i
  ƛ t₁ ρ ∙ v₂ = later λ { .force → ⟦ t₁ ⟧ (cons v₂ ρ) }

------------------------------------------------------------------------
-- An example

-- The semantics of Ω is the non-terminating computation never.

Ω-loops : ∀ {i} → [ i ] ⟦ Ω ⟧ nil ∼ never
Ω-loops = later λ { .force → Ω-loops }


module SameName where

data Stuff : Set where
  mkStuff : Stuff

stuffFunc : Stuff -> (Stuff : Set) -> Stuff
stuffFunc = {!   !}


------------------------------------------------------------------------
-- The Agda standard library
--
-- Strings: builtin type and basic operations
------------------------------------------------------------------------

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

module Data.String.Base where

open import Level using (zero)
open import Data.Bool using (true; false)
open import Data.Nat.Base as ℕ using (ℕ; _∸_; ⌊_/2⌋; ⌈_/2⌉)
import Data.Nat.Properties as ℕₚ
open import Data.List.Base as List using (List; [_])
open import Data.List.NonEmpty as NE using (List⁺)
open import Data.List.Extrema ℕₚ.≤-totalOrder
open import Data.List.Relation.Binary.Pointwise using (Pointwise)
open import Data.List.Relation.Binary.Lex.Strict using (Lex-<)
open import Data.Vec.Base as Vec using (Vec)
open import Data.Char.Base as Char using (Char)
import Data.Char.Properties as Char using (_≟_)
open import Function
open import Relation.Binary using (Rel)
open import Relation.Nullary using (does)

open import Data.List.Membership.DecPropositional Char._≟_

------------------------------------------------------------------------
-- From Agda.Builtin: type and renamed primitives

-- Note that we do not re-export primStringAppend because we want to
-- give it an infix definition and be able to assign it a level.

import Agda.Builtin.String as String

open String public using ( String )
  renaming
  ( primStringToList   to toList
  ; primStringFromList to fromList
  ; primShowString     to show
  )

------------------------------------------------------------------------
-- Relations

-- Pointwise equality on Strings

infix 4 _≈_
_≈_ : Rel String zero
_≈_ = Pointwise Char._≈_ on toList

-- Lexicographic ordering on Strings

infix 4 _<_
_<_ : Rel String zero
_<_ = Lex-< Char._≈_ Char._<_ on toList

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

-- Additional conversion functions

fromChar : Char → String
fromChar = fromList ∘′ [_]

fromList⁺ : List⁺ Char → String
fromList⁺ = fromList ∘′ NE.toList

-- List-like functions

infixr 5 _++_
_++_ : String → String → String
_++_ = String.primStringAppend

length : String → ℕ
length = List.length ∘ toList

replicate : ℕ → Char → String
replicate n = fromList ∘ List.replicate n

concat : List String → String
concat = List.foldr _++_ ""

intersperse : String → List String → String
intersperse sep = concat ∘′ (List.intersperse sep)

-- String-specific functions

unlines : List String → String
unlines = intersperse "\n"

unwords : List String → String
unwords = intersperse " "

parens : String → String
parens s = "(" ++ s ++ ")"

-- enclose string with parens if it contains a space character
parensIfSpace : String → String
parensIfSpace s with does (' ' ∈? toList s)
... | true  = parens s
... | false = s

braces : String → String
braces s = "{" ++ s ++ "}"

-- append that also introduces spaces, if necessary
infixr 5 _<+>_
_<+>_ : String → String → String
"" <+> b = b
a <+> "" = a
a <+> b = a ++ " " ++ b

------------------------------------------------------------------------
-- Padding

-- Each one of the padding functions should verify the following
-- invariant:
--   If length str ≤ n then length (padLeft c n str) ≡ n
--   and otherwise padLeft c n str ≡ str.

-- Appending an empty string is expensive (append for Haskell's
-- Text creates a fresh Text value in which both contents are
-- copied) so we precompute `n ∸ length str` and check whether
-- it is equal to 0.

padLeft : Char → ℕ → String → String
padLeft c n str with n ∸ length str
... | 0 = str
... | l = replicate l c ++ str

padRight : Char → ℕ → String → String
padRight c n str with n ∸ length str
... | 0 = str
... | l = str ++ replicate l c

padBoth : Char → Char → ℕ → String → String
padBoth cₗ cᵣ n str with n ∸ length str
... | 0 = str
... | l = replicate ⌊ l /2⌋ cₗ ++ str ++ replicate ⌈ l /2⌉ cᵣ

------------------------------------------------------------------------
-- Alignment

-- We can align a String left, center or right in a column of a given
-- width by padding it with whitespace.

data Alignment : Set where
  Left Center Right : Alignment

fromAlignment : Alignment → ℕ → String → String
fromAlignment Left   = padRight ' '
fromAlignment Center = padBoth ' ' ' '
fromAlignment Right  = padLeft ' '

------------------------------------------------------------------------
-- Rectangle

-- Build a rectangular column by:
-- Given a vector of cells and a padding function for each one
-- Compute the max of the widths, and pad the strings accordingly.

rectangle : ∀ {n} → Vec (ℕ → String → String) n →
            Vec String n → Vec String n
rectangle pads cells = Vec.zipWith (λ p c → p width c) pads cells where

  sizes = List.map length (Vec.toList cells)
  width = max 0 sizes

-- Special cases for left, center, and right alignment

rectangleˡ : ∀ {n} → Char → Vec String n → Vec String n
rectangleˡ c = rectangle (Vec.replicate $ padLeft c)

rectangleʳ : ∀ {n} → Char → Vec String n → Vec String n
rectangleʳ c = rectangle (Vec.replicate $ padRight c)

rectangleᶜ : ∀ {n} → Char → Char → Vec String n → Vec String n
rectangleᶜ cₗ cᵣ = rectangle (Vec.replicate $ padBoth cₗ cᵣ)


------------------------------------------------------------------------
-- Brzozowski-style derivatives of parsers
------------------------------------------------------------------------

module TotalParserCombinators.Derivative.Definition where

open import Category.Monad
open import Codata.Musical.Notation
open import Data.List using (List; map)
import Data.List.Categorical
import Data.Maybe; open Data.Maybe.Maybe
open import Level

open RawMonadPlus {f = zero} Data.List.Categorical.monadPlus
  using ()
  renaming ( return to return′
           ; ∅      to fail′
           ; _∣_    to _∣′_
           ; _⊛_    to _⊛′_
           ; _>>=_  to _>>=′_
           )

open import TotalParserCombinators.Lib
open import TotalParserCombinators.Parser

-- A function which calculates the index of the derivative.

D-bag : ∀ {Tok R xs} → Tok → Parser Tok R xs → List R
D-bag t (return x)   = fail′
D-bag t fail         = fail′
D-bag t token        = return′ t
D-bag t (p₁ ∣ p₂)    = D-bag t p₁ ∣′ D-bag t p₂
D-bag t (nonempty p) = D-bag t p
D-bag t (cast eq p)  = D-bag t p
D-bag t (f <$> p)    = map f (D-bag t p)
D-bag t (p₁ ⊛ p₂)    with forced? p₁ | forced? p₂
... | just xs | nothing = D-bag t p₁ ⊛′ xs
... | just xs | just fs = D-bag t p₁ ⊛′ xs ∣′ fs ⊛′ D-bag t p₂
... | nothing | nothing = fail′
... | nothing | just fs =                     fs ⊛′ D-bag t p₂
D-bag t (p₁ >>= p₂)  with forced? p₁ | forced?′ p₂
... | just f  | nothing =  D-bag t p₁ >>=′ f
... | just f  | just xs = (D-bag t p₁ >>=′ f) ∣′ (xs >>=′ λ x → D-bag t (p₂ x))
... | nothing | nothing = fail′
... | nothing | just xs =                         xs >>=′ λ x → D-bag t (p₂ x)

-- "Derivative": x ∈ D t p · s  iff  x ∈ p · t ∷ s.

D : ∀ {Tok R xs}
    (t : Tok) (p : Parser Tok R xs) → Parser Tok R (D-bag t p)
D t (return x)   = fail
D t fail         = fail
D t token        = return t
D t (p₁ ∣ p₂)    = D t p₁ ∣ D t p₂
D t (nonempty p) = D t p
D t (cast eq p)  = D t p
D t (f <$> p)    = f <$> D t p
D t (p₁ ⊛ p₂)    with forced? p₁ | forced? p₂
... | just xs | nothing =   D t    p₁  ⊛ ♭ p₂
... | just xs | just fs =   D t    p₁  ⊛   p₂ ∣ return⋆ fs ⊛ D t p₂
... | nothing | nothing = ♯ D t (♭ p₁) ⊛ ♭ p₂
... | nothing | just fs = ♯ D t (♭ p₁) ⊛   p₂ ∣ return⋆ fs ⊛ D t p₂
D t (p₁ >>= p₂)  with forced? p₁ | forced?′ p₂
... | just f  | nothing = D t p₁ >>= (λ x → ♭ (p₂ x))
... | just f  | just xs = D t p₁ >>= (λ x →    p₂ x)
                        ∣ return⋆ xs >>= λ x → D t (p₂ x)
... | nothing | nothing = ♯ D t (♭ p₁) >>= (λ x → ♭ (p₂ x))
... | nothing | just xs = ♯ D t (♭ p₁) >>= (λ x →    p₂ x)
                        ∣ return⋆ xs >>= λ x → D t (p₂ x)


module Issue641 where
Foo : Set
Foo = Set


{-# OPTIONS --no-positivity-check --no-termination-check #-}
module Homogenous.Base where
-- module Homogenous.Base(Arity, Sig, T, Intro) where

import TYPE
import PolyDepPrelude

open PolyDepPrelude using
  ( Absurd
  ; Unit; unit
  ; Nat; zero; suc
  ; List; nil; _::_
  ; Either; left; right
  ; Pair; pair)

-- A homogenous algebra can be represented by a list of arities
--   (natural numbers)

Arity : Set
Arity = Nat

Sig   : Set
Sig   = List Arity

-- Many definitions below come in pairs - one for Arity and one for
-- Sig - where name of the first one ends in a (as in Arity) :
--   funa : Arity -> ...
--   fun  : Sig -> ...

-- (Fa n,Fa1 n) is the functor "n-tuple of same type" or
--                 "vector of length n" or "(^n)"

Fa : (n : Arity) -> Set -> Set
Fa (zero)  X = Unit
Fa (suc m) X = Pair X (Fa m X)

 ----------------------------------------------------------------
Fa1 : (n : Arity) -> {a b : Set} -> (a -> b) -> Fa n a -> Fa n b
Fa1 (zero)  f (unit)         = unit
Fa1 (suc m) f (pair fst snd) = pair (f fst) (Fa1 m f snd)

-- (F fi, F1 fi) is the pattern functor for a homogenous algebra

F : (fi : Sig)(X : Set) -> Set
F (nil)      X = Absurd
F (n :: fi') X = Either (Fa n X) (F fi' X)

F1 : (fi : Sig){a b : Set}(f : a -> b)(x : F fi a) -> F fi b
F1 (nil)      f ()        -- empty
F1 (n :: ns)  f (left  t) = left  (Fa1 n f t)
F1 (n :: ns)  f (right y) = right (F1 ns f y)

-- For the definition of the recursor R we need family-level
-- variants of F and F1 : FIH and Fmap. As usual we define these first
-- for arities (with a postfix 'a' in the name) and then for signatures.

FIHa : (n : Arity){X : Set}(C : X -> Set)(x : Fa n X) -> Set
FIHa (zero)  C unit           = Unit
FIHa (suc m) C (pair fst snd) = Pair (C fst) (FIHa m C snd)

FIH : (fi : Sig){X : Set}(C : X -> Set)(x : F fi X) -> Set
FIH (nil)      C ()      -- empty
FIH (n :: ns)  C (left  t) = FIHa n C t
FIH (n :: ns)  C (right y) = FIH ns C y

Fmapa : (n : Arity){X : Set}{C : X -> Set}(h : (x : X) -> C x)(u : Fa n X)
      -> FIHa n C u
Fmapa (zero)  h (unit)         = unit
Fmapa (suc m) h (pair fst snd) = pair (h fst) (Fmapa m h snd)

Fmap : (fi : Sig){X : Set}{C : X -> Set}(h : (x : X) -> C x)(u : F fi X)
     -> FIH fi C u
Fmap (nil)      h () -- empty
Fmap (n :: ns)  h (left  x) = Fmapa n h x
Fmap (n :: ns)  h (right y) = Fmap ns h y

-- Finally the homogenous algebra construction itself - for each code
-- fi there is a datatype T fi and an iterator It fi

data T (fi : Sig) : Set where
  Intro : F fi (T fi) -> T fi

It : (fi : Sig){C : Set}(d : F fi C -> C) -> T fi -> C
It fi d (Intro i) = d (F1 fi (It fi d) i)

-- Mendler style iterator is also straight forward

MIt : (fi : Sig){C : Set}(s : {X : Set} -> (X -> C) -> F fi X -> C)
    -> T fi -> C
MIt fi s (Intro i) = s (MIt fi s) i

R : (fi : Sig)
    {C : T fi -> Set}
    (d : (y : F fi (T fi)) -> FIH fi C y -> C (Intro y))
    (x : T fi) -> C x
R fi d (Intro i) = d i (Fmap fi (R fi d) i)

-- Special case of FIH

FIHs : (fi : Sig) -> (T fi -> Set) -> F fi (T fi) -> Set
FIHs fi = FIH fi

-- A simple example : the inverse of Intro

out : (fi : Sig) -> T fi -> F fi (T fi)
out fi = R fi (\y p -> y)

----------------------------------------------------------------
-- Now for the Type level : define FIHa, FIH, Fmapa, Fmap again
--   (universe polymorphism, please!)

FIHaT : (n : Arity)(X : Set)(C : X -> Set1)(x : Fa n X) -> Set1
FIHaT (zero)  X C (unit)         = TYPE.Unit
FIHaT (suc m) X C (pair fst snd) = TYPE.Pair (C fst) (FIHaT m X C snd)

FIHT : (fi : Sig)(X : Set)(C : X -> Set1)(x : F fi X) -> Set1
FIHT (nil)      X C () -- empty
FIHT (n :: ns)  X C (left  t) = FIHaT n X C t
FIHT (n :: ns)  X C (right y) = FIHT ns X C y

FIHsT : (fi : Sig)(C : T fi -> Set1)(x : F fi (T fi)) -> Set1
FIHsT fi C x = FIHT fi (T fi) C x

FmapaT : (n : Arity){X : Set}{C : X -> Set1}(h : (x : X) -> C x)(u : Fa n X)
  -> FIHaT n X C u
FmapaT (zero)  h (unit)         = TYPE.unit
FmapaT (suc m) h (pair fst snd) = TYPE.pair (h fst) (FmapaT m h snd)

FmapT : (fi : Sig){X : Set}{C : X -> Set1}(h : (x : X) -> C x)(u : F fi X)
      -> FIHT fi X C u
FmapT (nil)      h () -- empty
FmapT (n :: ns)  h (left  x') = FmapaT n h x'
FmapT (n :: ns)  h (right y)  = FmapT ns h y

RT : (fi : Sig)
     {C : T fi -> Set1}
     (d : (y : F fi (T fi)) -> FIHT fi (T fi) C y -> C (Intro y))
     (x : T fi) -> C x
RT fi d (Intro i) = d i (FmapT fi (RT fi d) i)


-- Like Leftovers.Examples, but more meant to stress-test the library
-- than to be clear/readable
module Leftovers.Tests where

open import Leftovers.Leftovers
open import Leftovers.ByRefl

open import Level
open import Reflection
open import Data.Nat
open import Relation.Binary.PropositionalEquality

open import Data.Unit
open import Data.List

--Make sure findLeftovers works with

data Foo : Set(Level.suc Level.zero) where
  Bar : Set → ℕ → ((n : ℕ) → n ≡ n + 0) → Foo

makePair : Term → TC ⊤
makePair = λ goal →
    do
      hole1 <- newMeta (quoteTerm Set)
      hole2 <- newMeta (quoteTerm ℕ)
      hole3 <- newMeta (quoteTerm ((n : ℕ) → n ≡ n + 0))
      body <- extendContext (vArg (quoteTerm ℕ)) do
        tyHole ← newMeta (quoteTerm Set)
        newHole ← newMeta tyHole
        return (def (quote sym) (vArg newHole ∷ []))
      unify hole3 (lam visible (abs "arg" body))
      unify hole2 (quoteTerm 4)
      unify goal (con (quote Bar) (vArg hole1 ∷ vArg hole2 ∷ vArg hole3 ∷ []))

p0 : ∀ n → n + 0 ≡ n
p0 zero = refl
p0 (suc n) rewrite p0 n = refl

f : Foo
f =
  by
    makePair
  andAlso
    p0
    ℕ


-- Andreas, 2018-10-18, issue #3289 reported by Ulf
-- Andreas, 2021-02-10, fix rhs occurrence
--
-- For postfix projections, we have no hiding info
-- for the eliminated record value.

-- Thus, contrary to the prefix case, it cannot be
-- taken into account (e.g. for projection disambiguation).

open import Agda.Builtin.Nat

record R : Set where
  field
    p : Nat

open R {{...}}

lhs : R
lhs .p = 0

rhs : R → Nat
rhs r = r .p

-- Error WAS:  Wrong hiding used for projection  R.p

-- Should work now.


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

module Cubical.Categories.Functor where

open import Cubical.Categories.Functor.Base public
open import Cubical.Categories.Functor.Properties public
open import Cubical.Categories.Functor.Compose public