Agda: Отношение эквивалентности для суб-колистов

Я хотел бы определить равенство в CoList (Maybe Nat) s, который учитывает только just . Конечно, я не могу просто перейти из CoList (Maybe A) в CoList A , потому что это не обязательно будет продуктивным.

Таким образом, мой вопрос заключается в том, как я мог бы определить такое отношение эквивалентности (без взгляда на возможность определения)? Помогает ли это, если я могу считать бесконечные just хвосты неэквивалентными?

@gallais, ниже, предполагает, что я должен наивно определить это отношение:

open import Data.Colist
open import Data.Maybe
open import Coinduction
open import Relation.Binary

module _ where
  infix 4 _∼_

  data _∼_ {A : Set} : Colist (Maybe A) → Colist (Maybe A) → Set where
    end : [] ∼ []
    nothingˡ : ∀ {xs ys} → ∞ (♭ xs ∼ ys) → nothing ∷ xs ∼ ys
    nothingʳ : ∀ {xs ys} → ∞ (xs ∼ ♭ ys) → xs ∼ nothing ∷ ys
    justs : ∀ {x xs ys} → ∞ (♭ xs ∼ ♭ ys) → just x ∷ xs ∼ just x ∷ ys

но доказывая, что он переходный получает в (ожидаемые) проблемы от проверки завершения:

  refl : ∀ {A} → Reflexive (_∼_ {A})
  refl {A} {[]} = end
  refl {A} {just x ∷ xs} = justs (♯ refl)
  refl {A} {nothing ∷ xs} = nothingˡ (♯ nothingʳ (♯ refl)) -- note how I could have defined this the other way round as well...

  drop-nothingˡ : ∀ {A xs} {ys : Colist (Maybe A)} → nothing ∷ xs ∼ ys → ♭ xs ∼ ys
  drop-nothingˡ (nothingˡ x) = ♭ x
  drop-nothingˡ (nothingʳ x) = nothingʳ (♯ drop-nothingˡ (♭ x))

  trans : ∀ {A} → Transitive (_∼_ {A})
  trans end end = end
  trans end (nothingʳ e2) = nothingʳ e2
  trans (nothingˡ e1) e2 = nothingˡ (♯ trans (♭ e1) e2)
  trans (nothingʳ e1) (nothingˡ e2) = trans (♭ e1) (♭ e2) -- This is where the problem is
  trans (nothingʳ e1) (nothingʳ e2) = nothingʳ (♯ trans (♭ e1) (drop-nothingˡ (♭ e2)))
  trans (justs e1) (nothingʳ e2) = nothingʳ (♯ trans (justs e1) (♭ e2))
  trans (justs e1) (justs e2) = justs (♯ (trans (♭ e1) (♭ e2)))

Поэтому я попытался сделать случай, когда обе стороны nothing менее неоднозначны (например, как предлагал @Vitus):

module _ where
  infix 4 _∼_

  data _∼_ {A : Set} : Colist (Maybe A) → Colist (Maybe A) → Set where
    end : [] ∼ []
    nothings : ∀ {xs ys} → ∞ (♭ xs ∼ ♭ ys) → nothing ∷ xs ∼ nothing ∷ ys
    nothingˡ : ∀ {xs y ys} → ∞ (♭ xs ∼ just y ∷ ys) → nothing ∷ xs ∼ just y ∷ ys
    nothingʳ : ∀ {x xs ys} → ∞ (just x ∷ xs ∼ ♭ ys) → just x ∷ xs ∼ nothing ∷ ys
    justs : ∀ {x xs ys} → ∞ (♭ xs ∼ ♭ ys) → just x ∷ xs ∼ just x ∷ ys

  refl : ∀ {A} → Reflexive (_∼_ {A})
  refl {A} {[]} = end
  refl {A} {just x ∷ xs} = justs (♯ refl)
  refl {A} {nothing ∷ xs} = nothings (♯ refl)

  sym : ∀ {A} → Symmetric (_∼_ {A})
  sym end = end
  sym (nothings xs∼ys) = nothings (♯ sym (♭ xs∼ys))
  sym (nothingˡ xs∼ys) = nothingʳ (♯ sym (♭ xs∼ys))
  sym (nothingʳ xs∼ys) = nothingˡ (♯ sym (♭ xs∼ys))
  sym (justs xs∼ys) = justs (♯ sym (♭ xs∼ys))

  trans : ∀ {A} → Transitive (_∼_ {A})
  trans end ys∼zs = ys∼zs
  trans (nothings xs∼ys) (nothings ys∼zs) = nothings (♯ trans (♭ xs∼ys) (♭ ys∼zs))
  trans (nothings xs∼ys) (nothingˡ ys∼zs) = nothingˡ (♯ trans (♭ xs∼ys) (♭ ys∼zs))
  trans (nothingˡ xs∼ys) (nothingʳ ys∼zs) = nothings (♯ trans (♭ xs∼ys) (♭ ys∼zs))
  trans (nothingˡ xs∼ys) (justs ys∼zs) = nothingˡ (♯ trans (♭ xs∼ys) (justs ys∼zs))
  trans (nothingʳ xs∼ys) (nothings ys∼zs) = nothingʳ (♯ trans (♭ xs∼ys) (♭ ys∼zs))
  trans {A} {just x ∷ xs} {nothing ∷ ys} {just z ∷ zs} (nothingʳ xs∼ys) (nothingˡ ys∼zs) = ?
  trans (justs xs∼ys) (nothingʳ ys∼zs) = nothingʳ (♯ trans (justs xs∼ys) (♭ ys∼zs))
  trans (justs xs∼ys) (justs ys∼zs) = justs (♯ trans (♭ xs∼ys) (♭ ys∼zs))

но теперь я не знаю, как определить проблемный случай trans (тот, где я оставил отверстие)

3
nl ja de
@copumpkin: Если нет определения субколизма, о котором я не знаю, я не понимаю, что вы говорите ...
добавлено автор Cactus, источник
Если это симметрично, как это отношение к субколисту?
добавлено автор copumpkin, источник
Я говорю, что понятие «под» что-то предлагает упорядочение, которое не является отношением эквивалентности. Я думаю о таких вещах, как 3 <5 или {1,2,3} <{1,2,3,4,5} или 5 | 10 . Ни одно из них не является симметричным, поскольку симметричное упорядочение превращается в отношение эквивалентности. Я ожидаю, что подколист будет означать, что колисты используют одни и те же элементы в одном порядке, возможно, с дополнительным материалом в середине. Читая ваш вопрос более тщательно (я был в спешке раньше), я понимаю, что я полностью неправильно понял, что вы хотели, и просто отреагировал на приведенное выше симметричное доказательство. Извините за беспорядок!
добавлено автор copumpkin, источник
Это сложнее, чем кажется. Я думаю, что ключ должен определить, что вы хотите, чтобы это означало, когда вы получаете бесконечный поток nothing s. И типы gallais, и Vitus легко позволяют, например, доказать, что не повторяют ничего ~ <любой бесконечный Colist> , и я думаю, что наличие такого «коллапсирующего элемента», как это, будет препятствовать определению отношения эквивалентности (поскольку транзитивность через этот элемент будет невозможна). Вопрос заключается в том, чтобы найти то, чего нам не хватает в определении. Мы могли бы использовать смешанную индукцию-coinduction и требовать конечные nothings , но это слишком ограничивает? Только вариант?
добавлено автор copumpkin, источник
Я думаю, что это может немного упростить рассуждение, чтобы забыть о возможной конечности Colist и работать исключительно с Stream s, так как именно здесь возникает проблема. Я еще подумаю об этом, а потом, возможно, напишу ответ, если что-нибудь придумаю.
добавлено автор copumpkin, источник
Чтобы уточнить, я имел в виду, что если у вас есть симметрия, вы не можете иметь «наименьший элемент», потому что это нарушит отношение эквивалентности. Конечно, вы можете иметь наименьший элемент и транзитивность, потому что это всего лишь ограниченный порядок :) Относительно смешанного решения индукционной индукции я предложил, я думаю, правильный ответ - пойти с ответом Витуса, но только разрешить coinduction на ничего . Другие два случая nothing не должны допускать бесконечный поток nothing s.
добавлено автор copumpkin, источник
Извините за спам. Я думаю, что смешанная индукционная индукция - это правильный путь для этого (это более точное изложение того, что мы хотим, и изгоняет случаи плохой связи), но попытка написать trans все еще не завершается завершением в неочевидным способом. Условия завершения в смешанных сценариях могут быть сложными, и в то время как каждый случай выглядит либо структурно снижающимся, либо продуктивным, у нас нет общего порядка завершения и, следовательно, не выполняется. Очень сложно :)
добавлено автор copumpkin, источник

3 ответы

После долгих обсуждений и спама в разделе комментариев вопроса (и откладывая обновление моей локальной Agda до версии с реальной проверкой завершения), я придумал следующее:

module Subcolist where

open import Data.Colist
open import Data.Maybe
open import Coinduction
open import Relation.Binary

module _ {a} {A : Set a} where
  infix 4 _∼_

  data _∼_ : Colist (Maybe A) → Colist (Maybe A) → Set a where
    end      : [] ∼ []
    nothings : ∀ {  xs ys} (r : ∞ (♭ xs ∼ ♭ ys)) → nothing ∷ xs ∼ nothing ∷ ys
    nothingˡ : ∀ {  xs ys} (r :   (♭ xs ∼   ys)) → nothing ∷ xs ∼           ys
    nothingʳ : ∀ {  xs ys} (r :   (  xs ∼ ♭ ys)) →           xs ∼ nothing ∷ ys
    justs    : ∀ {x xs ys} (r : ∞ (♭ xs ∼ ♭ ys)) → just x  ∷ xs ∼ just x  ∷ ys


  refl : Reflexive _∼_
  refl {[]} = end
  refl {just x ∷ xs} = justs (♯ refl)
  refl {nothing ∷ xs} = nothings (♯ refl)

  sym : Symmetric _∼_
  sym end = end
  sym (nothings xs∼ys) = nothings (♯ sym (♭ xs∼ys))
  sym (nothingˡ xs∼ys) = nothingʳ   (sym   xs∼ys)
  sym (nothingʳ xs∼ys) = nothingˡ   (sym   xs∼ys)
  sym (justs    xs∼ys) = justs    (♯ sym (♭ xs∼ys))

  drop-nothingˡ : ∀ {xs} {ys : Colist (Maybe A)} → nothing ∷ xs ∼ ys → ♭ xs ∼ ys
  drop-nothingˡ (nothings r) = nothingʳ (♭ r)
  drop-nothingˡ (nothingˡ r) = r
  drop-nothingˡ (nothingʳ r) = nothingʳ (drop-nothingˡ r)

  drop-nothingʳ : ∀ {xs : Colist (Maybe A)} {ys} → xs ∼ nothing ∷ ys → xs ∼ ♭ ys
  drop-nothingʳ (nothings r) = nothingˡ (♭ r)
  drop-nothingʳ (nothingˡ r) = nothingˡ (drop-nothingʳ r)
  drop-nothingʳ (nothingʳ r) = r

  drop-nothings : ∀ {xs ys : ∞ (Colist (Maybe A))} → nothing ∷ xs ∼ nothing ∷ ys → ♭ xs ∼ ♭ ys
  drop-nothings (nothings r) = ♭ r
  drop-nothings (nothingˡ r) = drop-nothingʳ r
  drop-nothings (nothingʳ r) = drop-nothingˡ r

  []-trans : ∀ {xs ys : Colist (Maybe A)} → xs ∼ ys → ys ∼ [] → xs ∼ []
  []-trans xs∼ys end = xs∼ys
  []-trans xs∼ys (nothingˡ ys∼[]) = []-trans (drop-nothingʳ xs∼ys) ys∼[]

  mutual    
    just-trans : ∀ {xs ys zs} {z : A} → xs ∼ ys → ys ∼ just z ∷ zs → xs ∼ just z ∷ zs
    just-trans (justs r) (justs r₁) = justs (♯ (trans (♭ r) (♭ r₁)))
    just-trans (nothingˡ xs∼ys) ys∼zs = nothingˡ (just-trans xs∼ys ys∼zs)
    just-trans xs∼ys (nothingˡ ys∼zs) = just-trans (drop-nothingʳ xs∼ys) ys∼zs

    nothing-trans : ∀ {xs ys : Colist (Maybe A)} {zs} → xs ∼ ys → ys ∼ nothing ∷ zs → xs ∼ nothing ∷ zs
    nothing-trans (nothings xs∼ys) ys∼zs = nothings (♯ trans (♭ xs∼ys) (drop-nothings ys∼zs))
    nothing-trans (nothingˡ xs∼ys) ys∼zs = nothings (♯ (trans xs∼ys (drop-nothingʳ ys∼zs)))
    nothing-trans (nothingʳ xs∼ys) ys∼zs = nothing-trans xs∼ys (drop-nothingˡ ys∼zs)
    nothing-trans {xs = just x  ∷ xs} xs∼ys (nothingʳ ys∼zs) = nothingʳ (trans xs∼ys ys∼zs)
    nothing-trans end xs∼ys = xs∼ys

    trans : Transitive _∼_
    trans {k = []}           xs∼ys ys∼zs = []-trans      xs∼ys ys∼zs
    trans {k = nothing ∷ ks} xs∼ys ys∼zs = nothing-trans xs∼ys ys∼zs
    trans {k = just k  ∷ ks} xs∼ys ys∼zs = just-trans    xs∼ys ys∼zs

  equivalence : Setoid a a
  equivalence = record 
    { _≈_ = _∼_
    ; isEquivalence = record 
      { refl  = refl
      ; sym   = sym
      ; trans = trans
      }
    }

Я использую смешанную индукционную индукцию, и я считаю, что она захватывает идею, которую вы хотите. Мне нужно было пройти через некоторые обручи, чтобы пройти проверку завершения/производительности, поскольку наивная версия trans не передает ее, но это, похоже, работает. Это было частично вдохновлено тем, что я узнал из реализации Нильса Андерса Даниэльссона монархии пристрастности, в которой есть аналогичное определение отношения. Это не так сложно, как эта, но работа, чтобы заставить Агду принять ее, во многом схожа. Чтобы обобщить его немного, было бы более дружелюбно относиться к этому как к сетдеистому трансформатору, а не только к определению равенства/пропозиционального равенства для случая justs , но это тривиальное изменение.

Я заметил, что два других предложения вне закона ничего ∷ ничего ∷ [] ~ [] , что казалось противоречивым исходному вопросу, поэтому я отредактировал тип, чтобы снова это подтвердить. Я думаю, что при этом останавливается _~ _ от того, чтобы быть уникальным, но исправление, которое, вероятно, приведет к нескольким конструкторам в типе отношений, и это было бы больше усилий, чем казалось бы целесообразным.

Стоит отметить, что в то время, когда я пишу это, у Agda есть открытая ошибка (# 787) в ее контроле завершения, применимая к моей версии. Я не уверен, что вызывает эту ошибку, поэтому я не могу гарантировать, что моя версия полностью звучит, но это имеет смысл для меня.

3
добавлено

Чтобы попробовать другой подход, я решил пойти с типом данных для семантики списка:

data Sem (A : Set) : Set where
  [] : Sem A
  ⊥ : Sem A
  _∷_ : A → ∞ (Sem A) → Sem A

вместе с неразрешимой бинарной связью между списками и их семантикой:

data _HasSem_ {A : Set} : Colist (Maybe A) → Sem A → Set where
  [] : [] HasSem []
  ⊥ : ∀ {l} → ∞ (♭ l HasSem ⊥) → (nothing ∷ l) HasSem ⊥
  n∷_ : ∀ {l s} → ♭ l HasSem s → (nothing ∷ l) HasSem s
  _∷_ : ∀ {l s} x → ∞ (♭ l HasSem ♭ s) → (just x ∷ l) HasSem (x ∷ s)

Тогда определение равенства списка с семантикой легко:

a ≈ b = ∀ s → a HasSem s → b HasSem s

isEquivalence в основном тривиально, за исключением sym , где, похоже, вам нужно сделать эту стрелку двунаправленной (HasSem s ⇔ b HasSem s), чтобы доказать это конструктивно.

Затем я попытался доказать свое представление о равенстве, эквивалентном совокупности, где у меня были проблемы. Я смог доказать одно направление конструктивно:

from : ∀ {a b} → a ∼ b → a ≈ b

Тем не менее, я был в состоянии идти в другом направлении после того, как постулировал Исключенный Средний:

LEM = (A : Set) → Dec A
to : LEM → ∀ {a b} → a ≈ b → a ∼ b

Я не смог доказать более хорошую конструктивную версию для :

nicer-to : ∀ {a b} → a ≈ b → ¬ ¬ a ∼ b -- Not proven

Далее следует полный код. Существуют и доказательства некоторых других свойств, например доказательство существования и единственности семантики, предполагая LEM.

module colists where

open import Coinduction
open import Data.Colist hiding (_≈_)

data Sem (A : Set) : Set where
  [] : Sem A
  ⊥ : Sem A
  _∷_ : A → ∞ (Sem A) → Sem A

open import Data.Maybe

data _HasSem_ {A : Set} : Colist (Maybe A) → Sem A → Set where
  [] : [] HasSem []
  ⊥ : ∀ {l} → ∞ (♭ l HasSem ⊥) → (nothing ∷ l) HasSem ⊥
  n∷_ : ∀ {l s} → ♭ l HasSem s → (nothing ∷ l) HasSem s
  _∷_ : ∀ {l s} x → ∞ (♭ l HasSem ♭ s) → (just x ∷ l) HasSem (x ∷ s)

open import Function.Equivalence

_≈_ : ∀ {A : Set} → Colist (Maybe A) → Colist (Maybe A) → Set
a ≈ b = ∀ s → a HasSem s → b HasSem s

data _∼_  {A : Set} : Colist (Maybe A) → Colist (Maybe A) → Set where
    end      : [] ∼ []
    nothings : ∀ {  xs ys} (r : ∞ (♭ xs ∼ ♭ ys)) → (nothing ∷ xs) ∼ (nothing ∷ ys)
    nothingˡ : ∀ {  xs ys} (r :   (♭ xs ∼   ys)) → (nothing ∷ xs) ∼           ys
    nothingʳ : ∀ {  xs ys} (r :   (  xs ∼ ♭ ys)) →           xs ∼ (nothing ∷ ys)
    justs    : ∀ {x xs ys} (r : ∞ (♭ xs ∼ ♭ ys)) → (just x  ∷ xs) ∼ (just x  ∷ ys)

module WithA (A : Set) where

  CLMA = Colist (Maybe A)

  from-[] : ∀ {a b : CLMA} → a ∼ b → a HasSem [] → b HasSem []
  from-[] end [] = []
  from-[] (nothingʳ r) a-has = n∷ (from-[] r a-has)
  from-[] (nothings r) (n∷ y) = n∷ (from-[] (♭ r) y)
  from-[] (nothingˡ r) (n∷ y) = from-[] r y
  from-[] (justs _) ()

  from-⊥ : ∀ {a b : CLMA} → a ∼ b → a HasSem ⊥ → b HasSem ⊥
  from-⊥ (nothings r) (⊥ y) = ⊥ (♯ (from-⊥ (♭ r) (♭ y)))
  from-⊥ (nothingˡ r) (⊥ y) = from-⊥ r (♭ y)
  from-⊥ (nothingʳ r) (⊥ y) = ⊥ (♯ (from-⊥ r (⊥ y)))
  from-⊥ (nothings r) (n∷ y) = ⊥ (♯ (from-⊥ (♭ r) y))
  from-⊥ (nothingˡ r) (n∷ y) = from-⊥ r y
  from-⊥ (nothingʳ r) (n∷ y) = ⊥ (♯ (from-⊥ r (⊥ (♯ y))))
  from-⊥ (justs _) ()
  from-⊥ end ()

  from' : ∀ {a b : CLMA} {s} → a ∼ b → a HasSem s → b HasSem s
  from-∷ : ∀ {a b : CLMA} {x s} → a ∼ b → a HasSem (x ∷ s) → b HasSem (x ∷ s)
  from' {a} {b} {[]} eq sem = from-[] eq sem
  from' {a} {b} {⊥} eq sem = from-⊥ eq sem
  from' {a} {b} {y ∷ y'} eq sem = from-∷ eq sem

  from-∷ (nothings r) (n∷ y) = n∷ from-∷ (♭ r) y
  from-∷ (nothingˡ r) (n∷ y) = from-∷ r y
  from-∷ (nothingʳ r) (n∷ y) = n∷ from-∷ r (n∷ y)
  from-∷ (nothingʳ r) (x ∷ y) = n∷ (from-∷ r (x ∷ y))
  from-∷ (justs r) (x ∷ y) = x ∷ ♯ from' (♭ r) (♭ y)
  from-∷ end ()

  from : ∀ {a b : CLMA} → a ∼ b → a ≈ b
  from eq sem has = from' eq has

  refl : ∀ (a : CLMA) → a ≈ a
  refl a = λ s z → z

  trans : ∀ (a b c : CLMA) → a ≈ b → b ≈ c → a ≈ c
  trans a b c ab bc s as = bc s (ab s as)

  open import Relation.Nullary
  open import Data.Product

  data AllNothing : CLMA → Set where
   allNothing : ∀ {l} → ∞ (AllNothing (♭ l)) → AllNothing (nothing ∷ l)
   [] : AllNothing []

  data HasJust : CLMA → Set where
   just : ∀ x l → HasJust (just x ∷ l)
   nothing : ∀ l → HasJust (♭ l) → HasJust (nothing ∷ l)

  import Data.Empty

  notSomeMeansAll : ∀ {x} → ¬ HasJust x → AllNothing x
  notSomeMeansAll {[]} ns = []
  notSomeMeansAll {just x ∷ xs} ns with ns (just x xs)
  ... | ()
  notSomeMeansAll {nothing ∷ xs} ns = allNothing {xs} ( ♯ notSomeMeansAll {♭ xs} (λ z → ns (nothing xs z)) )

  data HasBot : CLMA → Set where
    ⊥ : ∀ l → ∞ (HasBot (♭ l)) → HasBot (nothing ∷ l)
    _∷_ : ∀ x l → HasBot (♭ l) → HasBot (x ∷ l)

  data IsBot : CLMA → Set where
    ⊥ : ∀ {l} → ∞ (IsBot (♭ l)) → IsBot (nothing ∷ l)

  data IsEmpty : CLMA → Set where
    [] : IsEmpty []
    n∷_ : ∀ {l} → IsEmpty (♭ l) → IsEmpty (nothing ∷ l)

  getAfterJust : {a : CLMA} → HasJust a → A × CLMA
  getAfterJust (just x l) = x , ♭ l
  getAfterJust (nothing l y) = getAfterJust y

  data SemStream : Colist (Maybe A) → Set where
    [] : ∀ {l} → IsEmpty l → SemStream l
    ⊥ : ∀ {l} → IsBot l → SemStream l
    _∷_ : ∀ {l} → (hj : HasJust l) → ∞ (SemStream (proj₂ (getAfterJust hj))) → SemStream l

  getSem : ∀ {a} → SemStream a → Sem A
  go : ∀ {a} → SemStream a → ∞ (Sem A)
  go rec = ♯ getSem rec
  getSem ([] _) = []
  getSem (⊥ _) = ⊥
  getSem {a} (hj ∷ rec) = proj₁ (getAfterJust hj) ∷ go (♭ rec)

  getSem-empty-good : ∀ {a} → IsEmpty a → a HasSem []
  getSem-empty-good [] = []
  getSem-empty-good (n∷ y) = n∷ getSem-empty-good y

  getSem-good : ∀ {a} (s : SemStream a) → a HasSem getSem s
  getSem-good ([] emp) = getSem-empty-good emp
  getSem-good (⊥ (⊥ y)) = ⊥ (♯ getSem-good (⊥ (♭ y)))
  getSem-good (just x l ∷ y) = x ∷ (♯ getSem-good (♭ y))
  getSem-good (nothing l y ∷ y') = n∷ getSem-good (y ∷ y')

  allNothing-variants' : ∀ {a} → ¬ IsEmpty a → AllNothing a → IsBot a
  allNothing-variants' nie (allNothing y) = ⊥ (♯  allNothing-variants' (λ z → nie (n∷ z)) (♭ y))
  allNothing-variants' nie [] with nie []
  ... | ()

  open import Data.Sum

  module WithEM (EM : (A : Set) → Dec A) where

    allNothing-variants : ∀ {a} → AllNothing a → IsEmpty a ⊎ IsBot a
    allNothing-variants {a} an with EM (IsEmpty a)
    ... | yes ie = inj₁ ie
    ... | no nie = inj₂ (allNothing-variants' nie an)

    mustbe : ∀ (a : CLMA) → SemStream a
    mustbe a with EM (HasJust a)
    mustbe a | yes p = p ∷ (♯ mustbe _)
    mustbe a | no ¬p with notSomeMeansAll ¬p
    ... | all with allNothing-variants all
    ... | inj₁ x = [] x
    ... | inj₂ y = ⊥ y

    mustbe' : ∀ (a : CLMA) → ∃ (λ s → a HasSem s)
    mustbe' a = getSem (mustbe a) , getSem-good (mustbe a)

    data Sem-Eq : Sem A → Sem A → Set where
      [] : Sem-Eq [] []
      ⊥ : Sem-Eq ⊥ ⊥
      _∷_ : ∀ x {a b} → ∞ (Sem-Eq (♭ a) (♭ b)) → Sem-Eq (x ∷ a) (x ∷ b)

    sem-unique⊥ : ∀ {x b} → x HasSem ⊥ → x HasSem b → Sem-Eq ⊥ b
    sem-unique⊥() []
    sem-unique⊥ s⊥ (⊥ y) = ⊥
    sem-unique⊥ (⊥ y) (n∷ y') = sem-unique⊥ (♭ y) y'
    sem-unique⊥ (n∷ y) (n∷ y') = sem-unique⊥ y y'

    sem-unique' : ∀ {x a b} → x HasSem a → x HasSem b → Sem-Eq a b
    sem-unique' [] [] = []
    sem-unique' (⊥ y) hasb = sem-unique⊥ (⊥ y) hasb
    sem-unique' (n∷ y) (⊥ y') = sem-unique' y (♭ y')
    sem-unique' (n∷ y) (n∷ y') = sem-unique' y y'
    sem-unique' (x ∷ y) (.x ∷ y') = x ∷ (♯ sem-unique' (♭ y) (♭ y'))

    to' : ∀ {a b : Colist (Maybe A)} {s} → a HasSem s → b HasSem s → a ∼ b
    to' [] [] = end
    to' [] (n∷ y) = nothingʳ (to' [] y)
    to' (⊥ y) (⊥ y') = nothings (♯ to' (♭ y) (♭ y'))
    to' (⊥ y) (n∷ y') = nothings (♯ to' (♭ y) y')
    to' (n∷ y) [] = nothingˡ (to' y [])
    to' (n∷ y) (⊥ y') = nothings (♯ to' y (♭ y'))
    to' (n∷ y) (n∷ y') = nothings (♯ to' y y')
    to' (n∷ y) (x ∷ y') = nothingˡ (to' y (x ∷ y'))
    to' (x ∷ y) (n∷ y') = nothingʳ (to' (x ∷ y) y')
    to' (x ∷ y) (.x ∷ y') = justs (♯ to' (♭ y) (♭ y'))

    to : ∀ (a b : Colist (Maybe A)) → a ≈ b → a ∼ b
    to a b eq with mustbe' a
    ... | s , a-s with eq s a-s
    ... | b-s = to' a-s b-s

    hasSem-respects : ∀ {x s1 s2} → x HasSem s1 → Sem-Eq s1 s2 → x HasSem s2
    hasSem-respects [] [] = []
    hasSem-respects (⊥ y) ⊥ = ⊥ y
    hasSem-respects (n∷ y) eq = n∷ hasSem-respects y eq
    hasSem-respects (x ∷ y) (.x ∷ y') = x ∷ ♯ hasSem-respects (♭ y) (♭ y')

    sym' : ∀ (a b : CLMA) → a ≈ b → b ≈ a
    sym' a b eq s b-s with mustbe' a
    ... | s' , a-s' = hasSem-respects a-s' (sem-unique' (eq s' a-s') b-s)
3
добавлено
Еще одно возможное определение: a ~~ b = ∃ λ s → a HasSem s × b HasSem s . Это кажется наиболее конструктивным, то есть я могу преобразовать его в любой из двух других, но не наоборот (если я не предполагаю, что LEM и все они станут эквивалентными).
добавлено автор Rotsor, источник
О, подождите, это не является конструктивно рефлексивным. :-(
добавлено автор Rotsor, источник

Просто напишите, что вы хотите, как коиндуктивное отношение!

module colist where

open import Coinduction
open import Data.Maybe

data CoList (A : Set) : Set where
  ■ : CoList A
  _∷_ : A → ∞ (CoList A) → CoList A

data EqCoList {A : Set} : CoList (Maybe A) → CoList (Maybe A) → Set where
-- two empty lists are equal
  conil : EqCoList ■ ■
-- nothings do not matter equality-wise
  nonel : ∀ xs ys → ∞ (EqCoList (♭ xs) ys) → EqCoList (nothing ∷ xs) ys
  noner : ∀ xs ys → ∞ (EqCoList xs (♭ ys)) → EqCoList xs (nothing ∷ ys)
-- justs have to agree
  justs : ∀ x xs ys → ∞ (EqCoList (♭ xs) (♭ ys)) → EqCoList (just x ∷ xs) (just x ∷ ys)
1
добавлено
Я разберу свой вопрос, как только я буду химе, но проблема с этим подходом доказывает транзитивность для случая nonel vs noner . Интересно, добавляет ли отдельный случай, когда оба являются nothing , и требует, чтобы другая сторона была just в nonel / noner поможет.
добавлено автор Cactus, источник
@Cactus: Это то, что я получил: hpaste.org/79967 Проблема заключается в том, что x ≡ x₁ .
добавлено автор Vitus, источник