------------------------------------------------------------------------
-- Grammars defined as functions from non-terminals to productions
------------------------------------------------------------------------

{-# OPTIONS --safe #-}

module Grammar.Non-terminal where

open import Algebra
open import Category.Monad
open import Data.Bool
open import Data.Bool.Properties
open import Data.Char
open import Data.Empty
open import Data.List hiding (unfold)
open import Data.List.Properties
open import Data.Maybe hiding (_>>=_)
open import Data.Maybe.Categorical as MaybeC
open import Data.Nat
open import Data.Product as Product
open import Data.Unit
open import Function
open import Level using (Lift; lift)
open import Relation.Binary.PropositionalEquality as P using (_≡_; _≢_)
open import Relation.Nullary
open import Tactic.MonoidSolver

private
  module LM {A : Set} = Monoid (++-monoid A)
  open module MM {f} = RawMonadPlus (MaybeC.monadPlus {f = f})
    using ()
    renaming (_<$>_ to _<$>M_; _⊛_ to _⊛M_;
              _>>=_ to _>>=M_; _∣_ to _∣M_)

open import Utilities

------------------------------------------------------------------------
-- Grammars

-- Productions. (Note that productions can contain choices.)

infix  30 _⋆
infixl 20 _⊛_ _<⊛_
infixl 15 _>>=_
infixl 10 _∣_

data Prod (NT : Set → Set₁) : Set → Set₁ where
  !      : ∀ {A} → NT A → Prod NT A
  fail   : ∀ {A} → Prod NT A
  return : ∀ {A} → A → Prod NT A
  token  : Prod NT Char
  tok    : Char → Prod NT Char
  _⊛_    : ∀ {A B} → Prod NT (A → B) → Prod NT A → Prod NT B
  _<⊛_   : ∀ {A B} → Prod NT A → Prod NT B → Prod NT A
  _>>=_  : ∀ {A B} → Prod NT A → (A → Prod NT B) → Prod NT B
  _∣_    : ∀ {A} → Prod NT A → Prod NT A → Prod NT A
  _⋆     : ∀ {A} → Prod NT A → Prod NT (List A)

-- Grammars.

Grammar : (Set → Set₁) → Set₁
Grammar NT = ∀ A → NT A → Prod NT A

-- An empty non-terminal type.

Empty-NT : Set → Set₁
Empty-NT _ = Lift _ ⊥

-- A corresponding grammar.

empty-grammar : Grammar Empty-NT
empty-grammar _ (lift ())

------------------------------------------------------------------------
-- Production combinators

-- Map.

infixl 20 _<$>_ _<$_

_<$>_ : ∀ {NT A B} → (A → B) → Prod NT A → Prod NT B
f <$> p = return f ⊛ p

_<$_ : ∀ {NT A B} → A → Prod NT B → Prod NT A
x <$ p = return x <⊛ p

-- Various sequencing operators.

infixl 20 _⊛>_
infixl 15 _>>_

_>>_ : ∀ {NT A B} → Prod NT A → Prod NT B → Prod NT B
p₁ >> p₂ = (λ _ x → x) <$> p₁ ⊛ p₂

_⊛>_ : ∀ {NT A B} → Prod NT A → Prod NT B → Prod NT B
_⊛>_ = _>>_

-- Kleene plus.

infix 30 _+

_+ : ∀ {NT A} → Prod NT A → Prod NT (List A)
p + = _∷_ <$> p ⊛ p ⋆

-- Elements separated by something.

infixl 18 _sep-by_

_sep-by_ : ∀ {NT A B} → Prod NT A → Prod NT B → Prod NT (List A)
g sep-by sep = _∷_ <$> g ⊛ (sep >> g) ⋆

-- A production for tokens satisfying a given predicate.

if-true : ∀ {NT} (b : Bool) → Prod NT (T b)
if-true true  = return tt
if-true false = fail

sat : ∀ {NT} (p : Char → Bool) → Prod NT (∃ λ t → T (p t))
sat p = token >>= λ t → _,_ t <$> if-true (p t)

-- A production for whitespace.

whitespace : ∀ {NT} → Prod NT Char
whitespace = tok ' ' ∣ tok '\n'

-- A production for a given string.

string : ∀ {NT} → List Char → Prod NT (List Char)
string []      = return []
string (t ∷ s) = _∷_ <$> tok t ⊛ string s

-- A production for the given string, possibly followed by some
-- whitespace.

symbol : ∀ {NT} → List Char → Prod NT (List Char)
symbol s = string s <⊛ whitespace ⋆

------------------------------------------------------------------------
-- Semantics

infix 4 [_]_∈_·_

data [_]_∈_·_ {NT : Set → Set₁} (g : Grammar NT) :
              ∀ {A} → A → Prod NT A → List Char → Set₁ where
  !-sem      : ∀ {A} {nt : NT A} {x s} →
               [ g ] x ∈ g A nt · s → [ g ] x ∈ ! nt · s
  return-sem : ∀ {A} {x : A} → [ g ] x ∈ return x · []
  token-sem  : ∀ {t} → [ g ] t ∈ token · [ t ]
  tok-sem    : ∀ {t} → [ g ] t ∈ tok t · [ t ]
  ⊛-sem      : ∀ {A B} {p₁ : Prod NT (A → B)} {p₂ : Prod NT A}
                 {f x s₁ s₂} →
               [ g ] f ∈ p₁ · s₁ → [ g ] x ∈ p₂ · s₂ →
               [ g ] f x ∈ p₁ ⊛ p₂ · s₁ ++ s₂
  <⊛-sem     : ∀ {A B} {p₁ : Prod NT A} {p₂ : Prod NT B} {x y s₁ s₂} →
               [ g ] x ∈ p₁ · s₁ → [ g ] y ∈ p₂ · s₂ →
               [ g ] x ∈ p₁ <⊛ p₂ · s₁ ++ s₂
  >>=-sem    : ∀ {A B} {p₁ : Prod NT A} {p₂ : A → Prod NT B}
                 {x y s₁ s₂} →
               [ g ] x ∈ p₁ · s₁ → [ g ] y ∈ p₂ x · s₂ →
               [ g ] y ∈ p₁ >>= p₂ · s₁ ++ s₂
  left-sem   : ∀ {A} {p₁ p₂ : Prod NT A} {x s} →
               [ g ] x ∈ p₁ · s → [ g ] x ∈ p₁ ∣ p₂ · s
  right-sem  : ∀ {A} {p₁ p₂ : Prod NT A} {x s} →
               [ g ] x ∈ p₂ · s → [ g ] x ∈ p₁ ∣ p₂ · s
  ⋆-[]-sem   : ∀ {A} {p : Prod NT A} →
               [ g ] [] ∈ p ⋆ · []
  ⋆-+-sem    : ∀ {A} {p : Prod NT A} {xs s} →
               [ g ] xs ∈ p + · s → [ g ] xs ∈ p ⋆ · s

-- Cast lemma.

cast : ∀ {NT g A} {p : Prod NT A} {x s₁ s₂} →
       s₁ ≡ s₂ → [ g ] x ∈ p · s₁ → [ g ] x ∈ p · s₂
cast P.refl = id

------------------------------------------------------------------------
-- Semantics combinators

<$>-sem : ∀ {NT} {g : Grammar NT} {A B} {f : A → B} {x p s} →
          [ g ] x ∈ p · s → [ g ] f x ∈ f <$> p · s
<$>-sem x∈ = ⊛-sem return-sem x∈

<$-sem : ∀ {NT g A B} {p : Prod NT B} {x : A} {y s} →
         [ g ] y ∈ p · s → [ g ] x ∈ x <$ p · s
<$-sem y∈ = <⊛-sem return-sem y∈

>>-sem : ∀ {NT g A B} {p₁ : Prod NT A} {p₂ : Prod NT B} {x y s₁ s₂} →
         [ g ] x ∈ p₁ · s₁ → [ g ] y ∈ p₂ · s₂ →
         [ g ] y ∈ p₁ >> p₂ · s₁ ++ s₂
>>-sem x∈ y∈ = ⊛-sem (⊛-sem return-sem x∈) y∈

⊛>-sem : ∀ {NT g A B} {p₁ : Prod NT A} {p₂ : Prod NT B} {x y s₁ s₂} →
         [ g ] x ∈ p₁ · s₁ → [ g ] y ∈ p₂ · s₂ →
         [ g ] y ∈ p₁ ⊛> p₂ · s₁ ++ s₂
⊛>-sem = >>-sem

+-sem : ∀ {NT g A} {p : Prod NT A} {x xs s₁ s₂} →
        [ g ] x ∈ p · s₁ → [ g ] xs ∈ p ⋆ · s₂ →
        [ g ] x ∷ xs ∈ p + · s₁ ++ s₂
+-sem x∈ xs∈ = ⊛-sem (⊛-sem return-sem x∈) xs∈

⋆-∷-sem : ∀ {NT g A} {p : Prod NT A} {x xs s₁ s₂} →
          [ g ] x ∈ p · s₁ → [ g ] xs ∈ p ⋆ · s₂ →
          [ g ] x ∷ xs ∈ p ⋆ · s₁ ++ s₂
⋆-∷-sem x∈ xs∈ = ⋆-+-sem (+-sem x∈ xs∈)

⋆-⋆-sem : ∀ {NT g A} {p : Prod NT A} {xs₁ xs₂ s₁ s₂} →
          [ g ] xs₁ ∈ p ⋆ · s₁ → [ g ] xs₂ ∈ p ⋆ · s₂ →
          [ g ] xs₁ ++ xs₂ ∈ p ⋆ · s₁ ++ s₂
⋆-⋆-sem ⋆-[]-sem xs₂∈ = xs₂∈
⋆-⋆-sem (⋆-+-sem (⊛-sem (⊛-sem {s₂ = s₁} return-sem x∈) xs₁∈)) xs₂∈ =
  cast (P.sym $ LM.assoc s₁ _ _)
       (⋆-∷-sem x∈ (⋆-⋆-sem xs₁∈ xs₂∈))

+-∷-sem : ∀ {NT g A} {p : Prod NT A} {x xs s₁ s₂} →
          [ g ] x ∈ p · s₁ → [ g ] xs ∈ p + · s₂ →
          [ g ] x ∷ xs ∈ p + · s₁ ++ s₂
+-∷-sem x∈ xs∈ = +-sem x∈ (⋆-+-sem xs∈)

+-⋆-sem : ∀ {NT g A} {p : Prod NT A} {xs₁ xs₂ s₁ s₂} →
          [ g ] xs₁ ∈ p + · s₁ → [ g ] xs₂ ∈ p ⋆ · s₂ →
          [ g ] xs₁ ++ xs₂ ∈ p + · s₁ ++ s₂
+-⋆-sem (⊛-sem (⊛-sem {s₂ = s₁} return-sem x∈) xs₁∈) xs₂∈ =
  cast (P.sym $ LM.assoc s₁ _ _)
       (+-sem x∈ (⋆-⋆-sem xs₁∈ xs₂∈))

sep-by-sem-singleton :
  ∀ {NT g A B} {p : Prod NT A} {sep : Prod NT B} {x s} →
  [ g ] x ∈ p · s → [ g ] [ x ] ∈ p sep-by sep · s
sep-by-sem-singleton x∈ =
  cast (proj₂ LM.identity _) (⊛-sem (<$>-sem x∈) ⋆-[]-sem)

sep-by-sem-∷ :
  ∀ {NT g A B} {p : Prod NT A} {sep : Prod NT B} {x y xs s₁ s₂ s₃} →
  [ g ] x ∈ p · s₁ → [ g ] y ∈ sep · s₂ → [ g ] xs ∈ p sep-by sep · s₃ →
  [ g ] x ∷ xs ∈ p sep-by sep · s₁ ++ s₂ ++ s₃
sep-by-sem-∷ {s₂ = s₂} x∈ y∈ (⊛-sem (⊛-sem return-sem x′∈) xs∈) =
  ⊛-sem (<$>-sem x∈)
        (cast (LM.assoc s₂ _ _) (⋆-∷-sem (>>-sem y∈ x′∈) xs∈))

if-true-sem : ∀ {NT} {g : Grammar NT} {b}
              (t : T b) → [ g ] t ∈ if-true b · []
if-true-sem {b = true}  _  = return-sem
if-true-sem {b = false} ()

sat-sem : ∀ {NT} {g : Grammar NT} {p t}
          (pt : T (p t)) → [ g ] (t , pt) ∈ sat p · [ t ]
sat-sem pt = >>=-sem token-sem (<$>-sem (if-true-sem pt))

whitespace-sem-space : ∀ {NT} {g : Grammar NT} →
                       [ g ] ' ' ∈ whitespace · [ ' ' ]
whitespace-sem-space = left-sem tok-sem

whitespace-sem-newline : ∀ {NT} {g : Grammar NT} →
                         [ g ] '\n' ∈ whitespace · [ '\n' ]
whitespace-sem-newline = right-sem tok-sem

string-sem : ∀ {NT} {g : Grammar NT} {s} →
             [ g ] s ∈ string s · s
string-sem {s = []}    = return-sem
string-sem {s = t ∷ s} = ⊛-sem (<$>-sem tok-sem) string-sem

symbol-sem : ∀ {NT} {g : Grammar NT} {s s′ s″} →
             [ g ] s″ ∈ whitespace ⋆ · s′ → [ g ] s ∈ symbol s · s ++ s′
symbol-sem s″∈ = <⊛-sem string-sem s″∈

------------------------------------------------------------------------
-- Some production transformers

-- Replaces all non-terminals with non-terminal-free productions.

replace : ∀ {NT A} → (∀ {A} → NT A → Prod Empty-NT A) →
          Prod NT A → Prod Empty-NT A
replace f (! nt)      = f nt
replace f fail        = fail
replace f (return x)  = return x
replace f token       = token
replace f (tok x)     = tok x
replace f (p₁ ⊛ p₂)   = replace f p₁ ⊛ replace f p₂
replace f (p₁ <⊛ p₂)  = replace f p₁ <⊛ replace f p₂
replace f (p₁ >>= p₂) = replace f p₁ >>= λ x → replace f (p₂ x)
replace f (p₁ ∣ p₂)   = replace f p₁ ∣ replace f p₂
replace f (p ⋆)       = replace f p ⋆

-- A lemma relating the resulting production with the original one in
-- case every non-terminal is replaced by fail.

replace-fail :
  ∀ {NT A g} (p : Prod NT A) {x s} →
  [ empty-grammar ] x ∈ replace (λ _ → fail) p · s →
  [ g             ] x ∈                      p · s
replace-fail (! nt)      ()
replace-fail fail        ()
replace-fail (return x)  return-sem      = return-sem
replace-fail token       token-sem       = token-sem
replace-fail (tok t)     tok-sem         = tok-sem
replace-fail (p₁ ⊛ p₂)   (⊛-sem f∈ x∈)   = ⊛-sem   (replace-fail p₁ f∈) (replace-fail p₂     x∈)
replace-fail (p₁ <⊛ p₂)  (<⊛-sem x∈ y∈)  = <⊛-sem  (replace-fail p₁ x∈) (replace-fail p₂     y∈)
replace-fail (p₁ >>= p₂) (>>=-sem x∈ y∈) = >>=-sem (replace-fail p₁ x∈) (replace-fail (p₂ _) y∈)
replace-fail (p₁ ∣ p₂)   (left-sem  x∈)  = left-sem  (replace-fail p₁ x∈)
replace-fail (p₁ ∣ p₂)   (right-sem x∈)  = right-sem (replace-fail p₂ x∈)
replace-fail (p ⋆)       ⋆-[]-sem        = ⋆-[]-sem
replace-fail (p ⋆)       (⋆-+-sem xs∈)   = ⋆-+-sem (replace-fail (p +) xs∈)

-- Unfolds every non-terminal. At most n /nested/ unfoldings are
-- performed.

unfold : ∀ {NT A} → (n : ℕ) → Grammar NT → Prod NT A → Prod NT A
unfold zero    g p           = p
unfold (suc n) g (! nt)      = unfold n g (g _ nt)
unfold n       g fail        = fail
unfold n       g (return x)  = return x
unfold n       g token       = token
unfold n       g (tok x)     = tok x
unfold n       g (p₁ ⊛ p₂)   = unfold n g p₁ ⊛ unfold n g p₂
unfold n       g (p₁ <⊛ p₂)  = unfold n g p₁ <⊛ unfold n g p₂
unfold n       g (p₁ >>= p₂) = unfold n g p₁ >>= λ x → unfold n g (p₂ x)
unfold n       g (p₁ ∣ p₂)   = unfold n g p₁ ∣ unfold n g p₂
unfold n       g (p ⋆)       = unfold n g p ⋆

-- Unfold is semantics-preserving.

unfold-to : ∀ {NT A} {g : Grammar NT} {x s} n (p : Prod NT A) →
            [ g ] x ∈ p · s → [ g ] x ∈ unfold n g p · s
unfold-to zero    p           x∈              = x∈
unfold-to (suc n) (! nt)      (!-sem x∈)      = unfold-to n _ x∈
unfold-to (suc n) fail        x∈              = x∈
unfold-to (suc n) (return x)  x∈              = x∈
unfold-to (suc n) token       x∈              = x∈
unfold-to (suc n) (tok x)     x∈              = x∈
unfold-to (suc n) (p₁ ⊛ p₂)   (⊛-sem f∈ x∈)   = ⊛-sem (unfold-to (suc n) p₁ f∈)
                                                      (unfold-to (suc n) p₂ x∈)
unfold-to (suc n) (p₁ <⊛ p₂)  (<⊛-sem x∈ y∈)  = <⊛-sem (unfold-to (suc n) p₁ x∈)
                                                       (unfold-to (suc n) p₂ y∈)
unfold-to (suc n) (p₁ >>= p₂) (>>=-sem x∈ y∈) = >>=-sem (unfold-to (suc n) p₁ x∈)
                                                        (unfold-to (suc n) (p₂ _) y∈)
unfold-to (suc n) (p₁ ∣ p₂)   (left-sem x∈)   = left-sem  (unfold-to (suc n) p₁ x∈)
unfold-to (suc n) (p₁ ∣ p₂)   (right-sem x∈)  = right-sem (unfold-to (suc n) p₂ x∈)
unfold-to (suc n) (p ⋆)       ⋆-[]-sem        = ⋆-[]-sem
unfold-to (suc n) (p ⋆)       (⋆-+-sem xs∈)   = ⋆-+-sem (unfold-to (suc n) (p +) xs∈)

unfold-from : ∀ {NT A} {g : Grammar NT} {x s} n (p : Prod NT A) →
              [ g ] x ∈ unfold n g p · s → [ g ] x ∈ p · s
unfold-from zero    p           x∈              = x∈
unfold-from (suc n) (! nt)      x∈              = !-sem (unfold-from n _ x∈)
unfold-from (suc n) fail        x∈              = x∈
unfold-from (suc n) (return x)  x∈              = x∈
unfold-from (suc n) token       x∈              = x∈
unfold-from (suc n) (tok x)     x∈              = x∈
unfold-from (suc n) (p₁ ⊛ p₂)   (⊛-sem f∈ x∈)   = ⊛-sem (unfold-from (suc n) p₁ f∈)
                                                        (unfold-from (suc n) p₂ x∈)
unfold-from (suc n) (p₁ <⊛ p₂)  (<⊛-sem x∈ y∈)  = <⊛-sem (unfold-from (suc n) p₁ x∈)
                                                         (unfold-from (suc n) p₂ y∈)
unfold-from (suc n) (p₁ >>= p₂) (>>=-sem x∈ y∈) = >>=-sem (unfold-from (suc n) p₁ x∈)
                                                          (unfold-from (suc n) (p₂ _) y∈)
unfold-from (suc n) (p₁ ∣ p₂)   (left-sem x∈)   = left-sem  (unfold-from (suc n) p₁ x∈)
unfold-from (suc n) (p₁ ∣ p₂)   (right-sem x∈)  = right-sem (unfold-from (suc n) p₂ x∈)
unfold-from (suc n) (p ⋆)       ⋆-[]-sem        = ⋆-[]-sem
unfold-from (suc n) (p ⋆)       (⋆-+-sem xs∈)   = ⋆-+-sem (unfold-from (suc n) (p +) xs∈)

------------------------------------------------------------------------
-- Nullability

-- A production is nullable (with respect to a given grammar) if the
-- empty string is a member of the language defined by the production.

Nullable : ∀ {NT A} → Grammar NT → Prod NT A → Set₁
Nullable g p = ∃ λ x → [ g ] x ∈ p · []

-- Nullability is not decidable, not even for productions without
-- non-terminals. If nullability were decidable, then we could decide
-- if a given function of type ℕ → Bool always returns false.

nullability-not-decidable :
  (∀ {A} (p : Prod Empty-NT A) → Dec (Nullable empty-grammar p)) →
  (f : ℕ → Bool) → Dec (∀ n → f n ≡ false)
nullability-not-decidable dec f = goal
  where
  p : Prod Empty-NT ℕ
  p = return tt ⋆ >>= λ tts →
      let n = length tts in
      if f n then return n else fail

  true-lemma : ∀ {n s} → [ empty-grammar ] n ∈ p · s → f n ≡ true
  true-lemma (>>=-sem {x = tts} _ _)
    with f (length tts) | P.inspect f (length tts)
  true-lemma (>>=-sem _ return-sem) | true  | P.[ fn≡true ] = fn≡true
  true-lemma (>>=-sem _ ())         | false | _

  no-lemma : ∀ {n} → f n ≡ true → ¬ (∀ n → f n ≡ false)
  no-lemma {n} ≡true ≡false with begin
    true   ≡⟨ P.sym ≡true ⟩
    f n    ≡⟨ ≡false n ⟩
    false  ∎
    where open P.≡-Reasoning
  ... | ()

  to-tts : ℕ → List ⊤
  to-tts n = replicate n tt

  n∈₁ : ∀ n → [ empty-grammar ] to-tts n ∈ return tt ⋆ · []
  n∈₁ zero    = ⋆-[]-sem
  n∈₁ (suc n) = ⋆-∷-sem return-sem (n∈₁ n)

  n∈₂ : ∀ n → f n ≡ true →
        let n′ = length (replicate n tt) in
        [ empty-grammar ] n ∈ if f n′ then return n′ else fail · []
  n∈₂ n fn≡true rewrite length-replicate n {x = tt} | fn≡true =
    return-sem

  yes-lemma : ∀ n → ¬ ([ empty-grammar ] n ∈ p · []) → f n ≢ true
  yes-lemma n n∉ fn≡true = n∉ (>>=-sem (n∈₁ n) (n∈₂ n fn≡true))

  goal : Dec (∀ n → f n ≡ false)
  goal with dec p
  ... | yes (_ , n∈) = no (no-lemma (true-lemma n∈))
  ... | no ¬[]∈      = yes λ n → ¬-not (yes-lemma n (¬[]∈ ∘ -,_))

-- However, we can implement a procedure that either proves that a
-- production is nullable, or returns "don't know" as the answer.
--
-- Note that, in the case of bind, the second argument is only applied
-- to one input—the first argument could give rise to infinitely many
-- results (as in the example above).
--
-- Note also that no attempt is made to memoise non-terminals—the
-- grammar could consist of an infinite number of non-terminals.
-- Instead the grammar is unfolded a certain number of times (n).
-- Memoisation still seems like a useful heuristic, but requires that
-- equality of non-terminals is decidable.

nullable? : ∀ {NT A} (n : ℕ) (g : Grammar NT) (p : Prod NT A) →
            Maybe (Nullable g p)
nullable? {NT} n g p =
  Product.map id (unfold-from n _) <$>M null? (unfold n g p)
  where
  null? : ∀ {A} (p : Prod NT A) → Maybe (Nullable g p)
  null? (! nt)        = nothing
  null? fail          = nothing
  null? token         = nothing
  null? (tok t)       = nothing
  null? (return x)    = just (x , return-sem)
  null? (p ⋆)         = just ([] , ⋆-[]-sem)
  null? (p₁ ⊛ p₂)     = Product.zip _$_   ⊛-sem  <$>M null? p₁ ⊛M null? p₂
  null? (p₁ <⊛ p₂)    = Product.zip const <⊛-sem <$>M null? p₁ ⊛M null? p₂
  null? (p₁ >>= p₂)   = null? p₁                  >>=M λ { (x , x∈) →
                        null? (p₂ x)              >>=M λ { (y , y∈) →
                        just (y , >>=-sem x∈ y∈)  }}
  null? (p₁ ∣ p₂)     = (Product.map id left-sem  <$>M null? p₁)
                          ∣M
                        (Product.map id right-sem <$>M null? p₂)

------------------------------------------------------------------------
-- Detecting the whitespace combinator

-- A predicate for the whitespace combinator.

data Is-whitespace {NT} : ∀ {A} → Prod NT A → Set₁ where
  is-whitespace : Is-whitespace whitespace

-- Detects the whitespace combinator.

is-whitespace? : ∀ {NT A} (p : Prod NT A) → Maybe (Is-whitespace p)
is-whitespace? {NT} (tok ' ' ∣ p) = helper p P.refl
  where
  helper : ∀ {A} (p : Prod NT A) (eq : A ≡ Char) →
           Maybe (Is-whitespace (tok ' ' ∣ P.subst (Prod NT) eq p))
  helper (tok '\n') P.refl = just is-whitespace
  helper _          _      = nothing

is-whitespace? _ = nothing

------------------------------------------------------------------------
-- Trailing whitespace

-- A predicate for productions that can "swallow" extra trailing
-- whitespace.

Trailing-whitespace : ∀ {NT A} → Grammar NT → Prod NT A → Set₁
Trailing-whitespace g p =
  ∀ {x s} → [ g ] x ∈ p <⊛ whitespace ⋆ · s → [ g ] x ∈ p · s

-- A heuristic procedure that either proves that a production can
-- swallow trailing whitespace, or returns "don't know" as the answer.

trailing-whitespace :
  ∀ {NT A} (n : ℕ) (g : Grammar NT) (p : Prod NT A) →
  Maybe (Trailing-whitespace g p)
trailing-whitespace {NT} n g p =
  convert ∘ unfold-lemma <$>M trailing? (unfold n g p)
  where
  -- An alternative formulation of Trailing-whitespace.

  Trailing-whitespace′ : ∀ {NT A} → Grammar NT → Prod NT A → Set₁
  Trailing-whitespace′ g p =
    ∀ {x s₁ s₂ s} →
    [ g ] x ∈ p · s₁ → [ g ] s ∈ whitespace ⋆ · s₂ →
    [ g ] x ∈ p · s₁ ++ s₂

  convert : ∀ {NT A} {g : Grammar NT} {p : Prod NT A} →
            Trailing-whitespace′ g p → Trailing-whitespace g p
  convert t (<⊛-sem x∈ w) = t x∈ w

  ++-lemma : ∀ s₁ {s₂} → (s₁ ++ s₂) ++ [] ≡ (s₁ ++ []) ++ s₂
  ++-lemma _ = solve (++-monoid Char)

  unfold-lemma : Trailing-whitespace′ g (unfold n g p) →
                 Trailing-whitespace′ g p
  unfold-lemma t x∈ white = unfold-from n _ (t (unfold-to n _ x∈) white)

  ⊛-return-lemma :
    ∀ {A B} {p : Prod NT (A → B)} {x} →
    Trailing-whitespace′ g p →
    Trailing-whitespace′ g (p ⊛ return x)
  ⊛-return-lemma t (⊛-sem {s₁ = s₁} f∈ return-sem) white =
    cast (++-lemma s₁) (⊛-sem (t f∈ white) return-sem)

  +-lemma :
    ∀ {A} {p : Prod NT A} →
    Trailing-whitespace′ g p →
    Trailing-whitespace′ g (p +)
  +-lemma t (⊛-sem (⊛-sem {s₂ = s₁} return-sem x∈) ⋆-[]-sem) white =
    cast (++-lemma s₁) (+-sem (t x∈ white) ⋆-[]-sem)
  +-lemma t (⊛-sem (⊛-sem {s₂ = s₁} return-sem x∈) (⋆-+-sem xs∈))
          white =
    cast (P.sym $ LM.assoc s₁ _ _)
         (+-∷-sem x∈ (+-lemma t xs∈ white))

  ⊛-⋆-lemma :
    ∀ {A B} {p₁ : Prod NT (List A → B)} {p₂ : Prod NT A} →
    Trailing-whitespace′ g p₁ →
    Trailing-whitespace′ g p₂ →
    Trailing-whitespace′ g (p₁ ⊛ p₂ ⋆)
  ⊛-⋆-lemma t₁ t₂ (⊛-sem {s₁ = s₁} f∈ ⋆-[]-sem) white =
    cast (++-lemma s₁) (⊛-sem (t₁ f∈ white) ⋆-[]-sem)
  ⊛-⋆-lemma t₁ t₂ (⊛-sem {s₁ = s₁} f∈ (⋆-+-sem xs∈)) white =
    cast (P.sym $ LM.assoc s₁ _ _)
         (⊛-sem f∈ (⋆-+-sem (+-lemma t₂ xs∈ white)))

  ⊛-∣-lemma : ∀ {A B} {p₁ : Prod NT (A → B)} {p₂ p₃ : Prod NT A} →
              Trailing-whitespace′ g (p₁ ⊛ p₂) →
              Trailing-whitespace′ g (p₁ ⊛ p₃) →
              Trailing-whitespace′ g (p₁ ⊛ (p₂ ∣ p₃))
  ⊛-∣-lemma t₁₂ t₁₃ {s₂ = s₃}
    (⊛-sem {f = f} {x = x} {s₁ = s₁} {s₂ = s₂} f∈ (left-sem x∈))
    white
    with f x | (s₁ ++ s₂) ++ s₃ | t₁₂ (⊛-sem f∈ x∈) white
  ... | ._ | ._ | ⊛-sem f∈′ x∈′ = ⊛-sem f∈′ (left-sem x∈′)
  ⊛-∣-lemma t₁₂ t₁₃ {s₂ = s₃}
    (⊛-sem {f = f} {x = x} {s₁ = s₁} {s₂ = s₂} f∈ (right-sem x∈))
    white
    with f x | (s₁ ++ s₂) ++ s₃ | t₁₃ (⊛-sem f∈ x∈) white
  ... | ._ | ._ | ⊛-sem f∈′ x∈′ = ⊛-sem f∈′ (right-sem x∈′)

  ⊛-lemma : ∀ {A B} {p₁ : Prod NT (A → B)} {p₂ : Prod NT A} →
            Trailing-whitespace′ g p₂ →
            Trailing-whitespace′ g (p₁ ⊛ p₂)
  ⊛-lemma t₂ (⊛-sem {s₁ = s₁} f∈ x∈) white =
    cast (P.sym $ LM.assoc s₁ _ _)
         (⊛-sem f∈ (t₂ x∈ white))

  <⊛-return-lemma :
    ∀ {A B} {p : Prod NT A} {x : B} →
    Trailing-whitespace′ g p →
    Trailing-whitespace′ g (p <⊛ return x)
  <⊛-return-lemma t (<⊛-sem {s₁ = s₁} f∈ return-sem) white =
    cast (++-lemma s₁) (<⊛-sem (t f∈ white) return-sem)

  <⊛-⋆-lemma :
    ∀ {A B} {p₁ : Prod NT A} {p₂ : Prod NT B} →
    Is-whitespace p₂ →
    Trailing-whitespace′ g (p₁ <⊛ p₂ ⋆)
  <⊛-⋆-lemma is-whitespace (<⊛-sem {s₁ = s₁} x∈ white₁) white₂ =
    cast (P.sym $ LM.assoc s₁ _ _)
         (<⊛-sem x∈ (⋆-⋆-sem white₁ white₂))

  <⊛-lemma : ∀ {A B} {p₁ : Prod NT A} {p₂ : Prod NT B} →
             Trailing-whitespace′ g p₂ →
             Trailing-whitespace′ g (p₁ <⊛ p₂)
  <⊛-lemma t₂ (<⊛-sem {s₁ = s₁} f∈ x∈) white =
    cast (P.sym $ LM.assoc s₁ _ _)
         (<⊛-sem f∈ (t₂ x∈ white))

  fail->>=-lemma : ∀ {A B} {p : A → Prod NT B} →
                   Trailing-whitespace′ g (fail >>= p)
  fail->>=-lemma (>>=-sem () _)

  return->>=-lemma : ∀ {A B} {p : A → Prod NT B} {x} →
                     Trailing-whitespace′ g (p x) →
                     Trailing-whitespace′ g (return x >>= p)
  return->>=-lemma t (>>=-sem return-sem y∈) white =
    >>=-sem return-sem (t y∈ white)

  tok->>=-lemma : ∀ {A} {p : Char → Prod NT A} {t} →
                  Trailing-whitespace′ g (p t) →
                  Trailing-whitespace′ g (tok t >>= p)
  tok->>=-lemma t (>>=-sem tok-sem y∈) white =
    >>=-sem tok-sem (t y∈ white)

  ∣-lemma : ∀ {A} {p₁ p₂ : Prod NT A} →
            Trailing-whitespace′ g p₁ →
            Trailing-whitespace′ g p₂ →
            Trailing-whitespace′ g (p₁ ∣ p₂)
  ∣-lemma t₁ t₂ (left-sem  x∈) white = left-sem  (t₁ x∈ white)
  ∣-lemma t₁ t₂ (right-sem x∈) white = right-sem (t₂ x∈ white)

  trailing? : ∀ {A} (p : Prod NT A) →
              Maybe (Trailing-whitespace′ g p)
  trailing? fail             = just (λ ())
  trailing? (p ⊛ return x)   = ⊛-return-lemma <$>M trailing? p
  trailing? (p₁ ⊛ p₂ ⋆)      = ⊛-⋆-lemma <$>M trailing? p₁ ⊛M trailing? p₂
  trailing? (p₁ ⊛ (p₂ ∣ p₃)) = ⊛-∣-lemma <$>M trailing? (p₁ ⊛ p₂)
                                           ⊛M trailing? (p₁ ⊛ p₃)
  trailing? (p₁ ⊛ p₂)        = ⊛-lemma <$>M trailing? p₂
  trailing? (p <⊛ return x)  = <⊛-return-lemma <$>M trailing? p
  trailing? (p₁ <⊛ p₂ ⋆)     = <⊛-⋆-lemma <$>M is-whitespace? p₂
  trailing? (p₁ <⊛ p₂)       = <⊛-lemma <$>M trailing? p₂
  trailing? (fail >>= p)     = just fail->>=-lemma
  trailing? (return x >>= p) = return->>=-lemma <$>M trailing? (p x)
  trailing? (tok t >>= p)    = tok->>=-lemma <$>M trailing? (p t)
  trailing? (p₁ ∣ p₂)        = ∣-lemma <$>M trailing? p₁ ⊛M trailing? p₂
  trailing? _                = nothing

private

  -- A unit test.

  test : T (is-just (trailing-whitespace
                       0 empty-grammar (tt <$ whitespace ⋆)))
  test = _


module Issue947 where

A : Set₁
A = Set
  where

B : Set₁
B = Set
  module _ where

C : Set₁
C = Set
  module M where


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

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

open import Optics.All
open import LibraBFT.Prelude
open import LibraBFT.Lemmas
open import LibraBFT.Base.PKCS

import      LibraBFT.Concrete.Properties.VotesOnce as VO

open import LibraBFT.Impl.Consensus.Types
open import LibraBFT.Impl.Util.Crypto
open import LibraBFT.Impl.Consensus.RoundManager.Properties
open import LibraBFT.Impl.Handle
open import LibraBFT.Impl.Handle.Properties
open import LibraBFT.Concrete.System
open import LibraBFT.Concrete.System.Parameters
open        EpochConfig
open import LibraBFT.Yasm.Types
open import LibraBFT.Yasm.Yasm ℓ-RoundManager ℓ-VSFP ConcSysParms PeerCanSignForPK (λ {st} {part} {pk} → PeerCanSignForPK-stable {st} {part} {pk})
open        WithSPS impl-sps-avp
open        Structural impl-sps-avp
open import LibraBFT.Impl.Properties.VotesOnce

-- This module proves the two "VotesOnce" proof obligations for our fake handler. Unlike the
-- LibraBFT.Impl.Properties.VotesOnce, which is based on unwind, this proof is done
-- inductively on the ReachableSystemState.

module LibraBFT.Impl.Properties.VotesOnceDirect where

  newVoteEpoch≡⇒Round≡ : ∀ {st : SystemState}{pid s' outs v m pk}
                       → ReachableSystemState st
                       → StepPeerState pid (msgPool st) (initialised st)
                                       (peerStates st pid) (s' , outs)
                       → v ⊂Msg m → send m ∈ outs → (sig : WithVerSig pk v)
                       → Meta-Honest-PK pk → ¬ (∈GenInfo (ver-signature sig))
                       → ¬ MsgWithSig∈ pk (ver-signature sig) (msgPool st)
                       → v ^∙ vEpoch ≡ (₋rmEC s') ^∙ rmEpoch
                       → v ^∙ vRound ≡ (₋rmEC s') ^∙ rmLastVotedRound
  newVoteEpoch≡⇒Round≡ r step@(step-msg {_ , P pm} _ pinit) v⊂m (here refl)
                       sig pkH ¬gen vnew ep≡
     with v⊂m
  ...| vote∈vm = refl
  ...| vote∈qc vs∈qc v≈rbld (inV qc∈m) rewrite cong ₋vSignature v≈rbld
       = let qc∈rm = VoteMsgQCsFromRoundManager r step pkH v⊂m (here refl) qc∈m
         in ⊥-elim (vnew (qcVotesSentB4 r pinit qc∈rm vs∈qc ¬gen))

  open PeerCanSignForPK

  peerCanSignSameS : ∀ {pid v pk s s'}
                   → PeerCanSignForPK s v pid pk
                   → s' ≡ s
                   → PeerCanSignForPK s' v pid pk
  peerCanSignSameS pcs refl = pcs

  peerCanSignEp≡ : ∀ {pid v v' pk s'}
                 → PeerCanSignForPK s' v pid pk
                 → v ^∙ vEpoch ≡ v' ^∙ vEpoch
                 → PeerCanSignForPK s' v' pid pk
  peerCanSignEp≡ (mkPCS4PK 𝓔₁ 𝓔id≡₁ 𝓔inSys₁ mbr₁ nid≡₁ pk≡₁) refl
    = (mkPCS4PK 𝓔₁ 𝓔id≡₁ 𝓔inSys₁ mbr₁ nid≡₁ pk≡₁)

  MsgWithSig⇒ValidSenderInitialised : ∀ {st v pk}
                                    → ReachableSystemState st
                                    → Meta-Honest-PK pk → (sig : WithVerSig pk v)
                                    → ¬ (∈GenInfo (ver-signature sig))
                                    → MsgWithSig∈ pk (ver-signature sig) (msgPool st)
                                    → ∃[ pid ] ( initialised st pid ≡ initd
                                               × PeerCanSignForPK st v pid pk )
  MsgWithSig⇒ValidSenderInitialised {st} {v} (step-s r step@(step-peer (step-honest {pid} stP))) pkH sig ¬gen msv
     with msgSameSig msv
  ...| refl
     with newMsg⊎msgSentB4 r stP pkH (msgSigned msv) ¬gen (msg⊆ msv) (msg∈pool msv)
  ...| inj₁ (m∈outs , pcsN , newV)
     with stP
  ...| step-msg _ initP
      with PerState.sameSig⇒sameVoteDataNoCol st (step-s r step) (msgSigned msv) sig (msgSameSig msv)
  ...| refl = pid , peersRemainInitialized step initP , peerCanSignEp≡ pcsN refl
  MsgWithSig⇒ValidSenderInitialised {st} {v} (step-s r step@(step-peer (step-honest stP))) pkH sig ¬gen msv
     | refl
     | inj₂ msb4
     with MsgWithSig⇒ValidSenderInitialised {v = v} r pkH sig ¬gen msb4
  ...| pid , initP , pcsPre = pid ,
                              peersRemainInitialized step initP ,
                              PeerCanSignForPK-stable r step pcsPre
  MsgWithSig⇒ValidSenderInitialised {st} {v} (step-s r step@(step-peer cheat@(step-cheat x))) pkH sig ¬gen msv
     with msgSameSig msv
  ...| refl
     with ¬cheatForgeNew cheat refl unit pkH msv ¬gen
  ...| msb4
     with MsgWithSig⇒ValidSenderInitialised {v = v} r pkH sig ¬gen msb4
  ...| pid , initP , pcsPre = pid ,
                              peersRemainInitialized step initP ,
                              PeerCanSignForPK-stable r step pcsPre

  peerCanSign-Msb4 : ∀ {pid v pk}{pre post : SystemState}
                   → ReachableSystemState pre
                   → Step pre post
                   → PeerCanSignForPK post v pid pk
                   → Meta-Honest-PK pk → (sig : WithVerSig pk v)
                   → MsgWithSig∈ pk (ver-signature sig) (msgPool pre)
                   → PeerCanSignForPK pre v pid pk
  peerCanSign-Msb4 r step (mkPCS4PK 𝓔₁ 𝓔id≡₁ (inGenInfo refl) mbr₁ nid≡₁ pk≡₁) pkH sig msv
    = mkPCS4PK 𝓔₁ 𝓔id≡₁ (inGenInfo refl) mbr₁ nid≡₁ pk≡₁

  peerCanSignPK-Inj :  ∀ {pid pid' pk v v'}{st : SystemState}
                    → ReachableSystemState st
                    → Meta-Honest-PK pk
                    → PeerCanSignForPK st v' pid' pk
                    → PeerCanSignForPK st v pid pk
                    → v ^∙ vEpoch ≡ v' ^∙ vEpoch
                    → pid ≡ pid'
  peerCanSignPK-Inj {pid} {pid'} r pkH pcs' pcs eid≡
     with availEpochsConsistent r pcs' pcs
  ...| refl
     with NodeId-PK-OK-injective (𝓔 pcs) (PCS4PK⇒NodeId-PK-OK pcs) (PCS4PK⇒NodeId-PK-OK pcs')
  ...| refl = refl

  msg∈pool⇒initd : ∀ {pid pk v}{st : SystemState}
                 → ReachableSystemState st
                 → PeerCanSignForPK st v pid pk
                 → Meta-Honest-PK pk → (sig : WithVerSig pk v)
                 → ¬ (∈GenInfo (ver-signature sig))
                 → MsgWithSig∈ pk (ver-signature sig) (msgPool st)
                 → initialised st pid ≡ initd
  msg∈pool⇒initd {pid'} {st = st} step@(step-s r (step-peer {pid} (step-honest stPeer))) pcs pkH sig ¬gen msv
     with msgSameSig msv
  ...| refl
     with newMsg⊎msgSentB4 r stPeer pkH (msgSigned msv) ¬gen (msg⊆ msv) (msg∈pool msv)
  ...| inj₁ (m∈outs , pcsN , newV)
     with sameSig⇒sameVoteData (msgSigned msv) sig (msgSameSig msv)
  ...| inj₁ hb = ⊥-elim (PerState.meta-sha256-cr st step hb)
  ...| inj₂ refl
     with stPeer
  ...| step-msg _ initP
     with pid ≟ pid'
  ...| yes refl = refl
  ...| no  pid≢ = ⊥-elim (pid≢ (peerCanSignPK-Inj step pkH pcs pcsN refl))
  msg∈pool⇒initd {pid'} (step-s r step@(step-peer {pid} (step-honest stPeer))) pcs pkH sig ¬gen msv
     | refl
     | inj₂ msb4
     with pid ≟ pid'
  ...| yes refl = refl
  ...| no  pid≢ = let pcsmsb4 = peerCanSign-Msb4 r step pcs pkH sig msb4
                  in msg∈pool⇒initd r pcsmsb4 pkH sig ¬gen msb4
  msg∈pool⇒initd {pid'} (step-s r step@(step-peer {pid} cheat@(step-cheat c))) pcs pkH sig ¬gen msv
     with msgSameSig msv
  ...| refl
     with ¬cheatForgeNew cheat refl unit pkH msv ¬gen
  ...| msb4
       = let pcsmsb4 = peerCanSign-Msb4 r step pcs pkH sig msb4
             initPre = msg∈pool⇒initd r pcsmsb4  pkH sig ¬gen msb4
         in peersRemainInitialized (step-peer cheat) initPre

  noEpochChange : ∀ {pid s' outs v pk}{st : SystemState}
                → ReachableSystemState st
                → (stP : StepPeerState pid (msgPool st) (initialised st)
                                       (peerStates st pid) (s' , outs))
                → PeerCanSignForPK st v pid pk
                → Meta-Honest-PK pk → (sig : WithVerSig pk v)
                → ¬ ∈GenInfo (ver-signature sig)
                → MsgWithSig∈ pk (ver-signature sig) (msgPool st)
                → (₋rmEC s') ^∙ rmEpoch ≡ (v ^∙ vEpoch)
                → (₋rmEC (peerStates st pid)) ^∙ rmEpoch ≡ (v ^∙ vEpoch)
  noEpochChange r (step-init uni) pcs pkH sig ∉gen msv eid≡
    = ⊥-elim (uninitd≢initd (trans (sym uni) (msg∈pool⇒initd r pcs pkH sig ∉gen msv)))
  noEpochChange r sm@(step-msg _ ini) pcs pkH sig ∉gen msv eid≡
    rewrite noEpochIdChangeYet r refl sm ini = eid≡

  oldVoteRound≤lvr : ∀ {pid pk v}{pre : SystemState}
                   → (r : ReachableSystemState pre)
                   → Meta-Honest-PK pk → (sig : WithVerSig pk v)
                   → ¬ (∈GenInfo (ver-signature sig))
                   → MsgWithSig∈ pk (ver-signature sig) (msgPool pre)
                   → PeerCanSignForPK pre v pid pk
                   → (₋rmEC (peerStates pre pid)) ^∙ rmEpoch ≡ (v ^∙ vEpoch)
                   → v ^∙ vRound ≤ (₋rmEC (peerStates pre pid)) ^∙ rmLastVotedRound
  oldVoteRound≤lvr {pid'} (step-s r step@(step-peer {pid = pid} cheat@(step-cheat c)))
                   pkH sig ¬gen msv vspk eid≡
     with ¬cheatForgeNew cheat refl unit pkH msv (¬subst ¬gen (msgSameSig msv))
  ...| msb4 rewrite cheatStepDNMPeerStates₁ {pid = pid} {pid' = pid'} cheat unit
       = let pcsmsb4 = peerCanSign-Msb4 r step vspk pkH sig msb4
         in oldVoteRound≤lvr r pkH sig ¬gen msb4 pcsmsb4 eid≡
  oldVoteRound≤lvr {pid'} step@(step-s r stP@(step-peer {pid} (step-honest stPeer)))
                   pkH sig ¬gen msv vspk eid≡
     with msgSameSig msv
  ...| refl
     with newMsg⊎msgSentB4 r stPeer pkH (msgSigned msv) ¬gen (msg⊆ msv) (msg∈pool msv)
  ...| inj₂ msb4 rewrite msgSameSig msv
     with peerCanSign-Msb4 r stP vspk pkH sig msb4
  ...| pcsmsb4
     with pid ≟ pid'
  ...| no  pid≢ = oldVoteRound≤lvr r  pkH sig ¬gen msb4 pcsmsb4 eid≡
  ...| yes refl = let  initP = msg∈pool⇒initd r pcsmsb4 pkH sig ¬gen msb4
                       ep≡   = noEpochChange r stPeer pcsmsb4 pkH sig ¬gen msb4 eid≡
                       lvr≤  = lastVoteRound-mono r refl stPeer initP (trans ep≡ (sym eid≡))
                   in ≤-trans (oldVoteRound≤lvr r pkH sig ¬gen msb4 pcsmsb4 ep≡) lvr≤
  oldVoteRound≤lvr {pid = pid'} {pre = pre}
                   step@(step-s r (step-peer {pid} (step-honest stPeer)))
                   pkH sig ¬gen msv vspk eid≡
     | refl
     | inj₁ (m∈outs , vspkN , newV)
     with sameSig⇒sameVoteData (msgSigned msv) sig (msgSameSig msv)
  ...| inj₁ hb = ⊥-elim (PerState.meta-sha256-cr pre step hb)
  ...| inj₂ refl
     with pid ≟ pid'
  ...| yes refl = ≡⇒≤ (newVoteEpoch≡⇒Round≡ r stPeer (msg⊆ msv) m∈outs (msgSigned msv)
                                            pkH ¬gen newV (sym eid≡))
  ...| no  pid≢ = ⊥-elim (pid≢ (peerCanSignPK-Inj step pkH vspk vspkN refl))

  votesOnce₁ : VO.ImplObligation₁
  votesOnce₁ {pid' = pid'} r stMsg@(step-msg {_ , P m} m∈pool psI) {v' = v'} {m' = m'}
             pkH v⊂m (here refl) sv ¬gen ¬msb vspkv v'⊂m' m'∈pool sv' ¬gen' eid≡ r≡
     with v⊂m
  ...| vote∈vm = let m'mwsb = mkMsgWithSig∈ m' v' v'⊂m' pid' m'∈pool sv' refl
                     vspkv' = peerCanSignEp≡ {v' = v'} vspkv eid≡
                     step   = step-peer (step-honest stMsg)
                     vspre' = peerCanSign-Msb4 r step vspkv' pkH sv' m'mwsb
                     rv'<rv = oldVoteRound≤lvr r pkH sv' ¬gen' m'mwsb vspre' eid≡
                 in ⊥-elim (<⇒≢ (s≤s rv'<rv) (sym r≡))
  ...| vote∈qc vs∈qc v≈rbld (inV qc∈m) rewrite cong ₋vSignature v≈rbld
     = let qc∈rm = VoteMsgQCsFromRoundManager r stMsg pkH v⊂m (here refl) qc∈m
       in ⊥-elim (¬msb (qcVotesSentB4 r psI qc∈rm vs∈qc ¬gen))

  votesOnce₂ : VO.ImplObligation₂
  votesOnce₂ {pk = pk} {st} r stMsg@(step-msg {_ , P m} m∈pool psI) pkH v⊂m m∈outs sig ¬gen vnew
             vpk v'⊂m' m'∈outs sig' ¬gen' v'new vpk' es≡ rnds≡
     with m∈outs | m'∈outs
  ...| here refl | here refl
     with v⊂m                          | v'⊂m'
  ...| vote∈vm                         | vote∈vm = refl
  ...| vote∈vm                         | vote∈qc vs∈qc' v≈rbld' (inV qc∈m')
       rewrite cong ₋vSignature v≈rbld'
       = let qc∈rm' = VoteMsgQCsFromRoundManager r stMsg pkH v'⊂m' (here refl) qc∈m'
         in ⊥-elim (v'new (qcVotesSentB4 r psI qc∈rm' vs∈qc' ¬gen'))
  ...| vote∈qc vs∈qc v≈rbld (inV qc∈m) | _
       rewrite cong ₋vSignature v≈rbld
       = let qc∈rm = VoteMsgQCsFromRoundManager r stMsg pkH v⊂m (here refl) qc∈m
         in ⊥-elim (vnew (qcVotesSentB4 r psI qc∈rm vs∈qc ¬gen))


open import Syntax
import Renaming
import Instantiation

module Theory (𝕊 : Signature) where

  open Expression 𝕊
  open Instantiation
  open Renaming

  infix 5 □⦂_
  infix 5 _≡_⦂type-by□
  infix 5 _≡_⦂_by□

  data BoundaryThesis : ∀ (cl : Class) (𝕄 : MShape) (γ : VShape) → Set where
    □⦂type : ∀ {𝕄 γ} → BoundaryThesis (obj Ty) 𝕄 γ
    □⦂_ : ∀ {𝕄 γ} (A : ExprTy 𝕄 γ) → BoundaryThesis (obj Tm) 𝕄 γ
    _≡_⦂type-by□ : ∀ {𝕄 γ} (A B : ExprTy 𝕄 γ) → BoundaryThesis EqTy 𝕄 γ
    _≡_⦂_by□ : ∀ {𝕄 γ} (u v : ExprTm 𝕄 γ) (A : ExprTy 𝕄 γ) → BoundaryThesis EqTm 𝕄 γ

  rename-boundary-thesis : ∀ {cl 𝕄 γ δ} → (γ →ʳ δ) → BoundaryThesis cl 𝕄 γ → BoundaryThesis cl 𝕄 δ
  rename-boundary-thesis ρ □⦂type = □⦂type
  rename-boundary-thesis ρ (□⦂ A) = □⦂ [ ρ ]ʳ A
  rename-boundary-thesis ρ (A ≡ B ⦂type-by□) = [ ρ ]ʳ A ≡ [ ρ ]ʳ B ⦂type-by□
  rename-boundary-thesis ρ (u ≡ v ⦂ A by□) = [ ρ ]ʳ u ≡ [ ρ ]ʳ v ⦂ [ ρ ]ʳ A by□

  instantiate-boundary-thesis : ∀ {cl 𝕂 𝕄 γ} → (𝕊 % 𝕂 →ⁱ 𝕄 ∥ γ) → BoundaryThesis cl 𝕂 γ → BoundaryThesis cl 𝕄 γ
  instantiate-boundary-thesis I □⦂type = □⦂type
  instantiate-boundary-thesis I (□⦂ A) = □⦂ [ I ]ⁱ A
  instantiate-boundary-thesis I (A ≡ B ⦂type-by□) = [ I ]ⁱ A ≡ [ I ]ⁱ B ⦂type-by□
  instantiate-boundary-thesis I (u ≡ v ⦂ A by□) = [ I ]ⁱ u ≡ [ I ]ⁱ v ⦂ [ I ]ⁱ A by□

  VContext : ∀ (𝕄 : MShape) (γ : VShape) → Set
  VContext 𝕄 γ = ∀ (x : var γ) → ExprTy 𝕄 γ

  instantiate-vcontext : ∀ {𝕂 𝕄 γ} (I : 𝕊 % 𝕂 →ⁱ 𝕄 ∥ γ) (Γ : VContext 𝕂 γ) → VContext 𝕄 γ
  instantiate-vcontext I Γ x = [ I ]ⁱ Γ x

  VExtension : ∀ (𝕄 : MShape) (γ δ : VShape) → Set
  VExtension 𝕄 γ δ = ∀ (x : var δ) → ExprTy 𝕄 (γ ⊕ δ)

  empty-vextension : ∀ {𝕄 γ} → VExtension 𝕄 γ 𝟘
  empty-vextension ()

  -- variable context extension
  infixl 6 _⊕ᶜ_

  _⊕ᶜ_ : ∀ {𝕄 γ δ} → VContext 𝕄 γ → VExtension 𝕄 γ δ → VContext 𝕄 (γ ⊕ δ)
  (Γ ⊕ᶜ Δ) (var-left x) = [ var-left ]ʳ (Γ x)
  (Γ ⊕ᶜ Δ) (var-right y) = Δ y

  rename-vextension : ∀ {𝕄 β γ δ} → (β →ʳ γ) → VExtension 𝕄 β δ → VExtension 𝕄 γ δ
  rename-vextension ρ Δ x =  [ [ (var-left ∘ʳ ρ) , var-right ]ʳ ]ʳ Δ x

  instantiate-vextension : ∀ {𝕂 𝕄 γ δ} → (I : 𝕊 % 𝕂 →ⁱ 𝕄 ∥ γ) → VExtension 𝕂 γ δ → VExtension 𝕄 γ δ
  instantiate-vextension I Δ x = [ ⇑ⁱ I ]ⁱ (Δ x)

  record JudgementThesis (cl : Class) (𝕄 : MShape) (γ : VShape) : Set where
    constructor _⟦_⟧
    field
      jdg-bdry : BoundaryThesis cl 𝕄 γ
      jdg-head : Expr cl 𝕄 γ

  presupposition : ∀ {cl 𝕄 γ} → JudgementThesis cl 𝕄 γ → BoundaryThesis cl 𝕄 γ
  presupposition (𝒷 ⟦ _ ⟧) = 𝒷

  -- shorthands for the four judgement forms

  infix 5 _⦂type
  _⦂type : ∀ {𝕄 γ} (A : ExprTy 𝕄 γ) → JudgementThesis (obj Ty) 𝕄 γ
  A ⦂type = □⦂type ⟦ A ⟧

  infix 5 _⦂_
  _⦂_ : ∀ {𝕄 γ} (e : ExprTm 𝕄 γ) (A : ExprTy 𝕄 γ) → JudgementThesis (obj Tm) 𝕄 γ
  e ⦂ A = (□⦂ A) ⟦ e ⟧

  infix 5 _≡_by_
  _≡_by_ : ∀ {𝕄 γ} (A B : ExprTy 𝕄 γ) (ξ : Expr EqTy 𝕄 γ) → JudgementThesis (EqTy) 𝕄 γ
  A ≡ B by ξ = (A ≡ B ⦂type-by□) ⟦ ξ ⟧

  infix 5 _≡_⦂_by_
  _≡_⦂_by_ : ∀ {𝕄 γ} (d e : ExprTm 𝕄 γ) (A : ExprTy 𝕄 γ) (ξ : Expr EqTm 𝕄 γ) → JudgementThesis (EqTm) 𝕄 γ
  d ≡ e ⦂ A by ξ = (d ≡ e ⦂ A by□) ⟦ ξ ⟧

  rename-judgement-thesis : ∀ {cl 𝕄 γ δ} → (γ →ʳ δ) → JudgementThesis cl 𝕄 γ → JudgementThesis cl 𝕄 δ
  rename-judgement-thesis ρ (b ⟦ e ⟧) = (rename-boundary-thesis ρ b) ⟦ [ ρ ]ʳ e ⟧

  instantiate-judgement-thesis : ∀ {cl 𝕂 𝕄 γ} → (𝕊 % 𝕂 →ⁱ 𝕄 ∥ γ) → JudgementThesis cl 𝕂 γ → JudgementThesis cl 𝕄 γ
  instantiate-judgement-thesis I (B ⟦ e ⟧) = (instantiate-boundary-thesis I B) ⟦ [ I ]ⁱ e ⟧

  infix 4 ⟪_⟫_

  record Abstracted (F : MShape → VShape → Set) (𝕄 : MShape) (γ δ : VShape) : Set where
    constructor ⟪_⟫_
    field
      abstr-vextenson : VExtension 𝕄 γ δ
      abstr-body : F 𝕄 (γ ⊕ δ)

  non-abstracted : ∀ (F : MShape → VShape → Set) (r : ∀ {𝕄 β γ} → (β →ʳ γ) → F 𝕄 β → F 𝕄 γ)
                     {𝕄 : MShape} {γ : VShape} (t : F 𝕄 γ) → Abstracted F 𝕄 γ 𝟘
  non-abstracted F r t = ⟪ empty-vextension ⟫ (r var-left t)

  rename-abstracted : ∀ (F : MShape → VShape → Set) (r : ∀ {𝕄 β γ} → (β →ʳ γ) → F 𝕄 β → F 𝕄 γ) {𝕄 β γ δ} (ρ : β →ʳ γ) →
                        Abstracted F 𝕄 β δ → Abstracted F 𝕄 γ δ
  rename-abstracted F r ρ (⟪ Δ ⟫ t) = ⟪ rename-vextension ρ Δ ⟫ (r (⇑ʳ ρ) t)

  instantiate-abstracted : ∀ (F : MShape → VShape → Set) (ι : ∀ {𝕂 𝕄 γ} → (𝕊 % 𝕂 →ⁱ 𝕄 ∥ γ) → F 𝕂 γ → F 𝕄 γ)
                             {𝕂 𝕄 γ δ} (I : 𝕊 % 𝕂 →ⁱ 𝕄 ∥ γ) → Abstracted F 𝕂 γ δ → Abstracted F 𝕄 γ δ
  instantiate-abstracted F ι I (⟪ Δ ⟫ t) = ⟪ (instantiate-vextension I Δ) ⟫ ι (⇑ⁱ I) t

  AbstractedBoundary : ∀ cl 𝕄 γ δ → Set
  AbstractedBoundary cl 𝕄 γ δ = Abstracted (BoundaryThesis cl) 𝕄 γ δ

  infix 4 ⟪⟫ᵇ_
  ⟪⟫ᵇ_ : ∀ {cl 𝕄 γ} → BoundaryThesis cl 𝕄 γ → AbstractedBoundary cl 𝕄 γ 𝟘
  ⟪⟫ᵇ_ {cl = cl} 𝒷 = non-abstracted (BoundaryThesis cl) rename-boundary-thesis 𝒷

  rename-abstracted-boundary : ∀ {cl 𝕄 β γ δ} (ρ : β →ʳ γ) →
                                 AbstractedBoundary cl 𝕄 β δ → AbstractedBoundary cl 𝕄 γ δ
  rename-abstracted-boundary {cl = cl} = rename-abstracted (BoundaryThesis cl) rename-boundary-thesis

  instantiate-abstracted-boundary : ∀ {cl 𝕂 𝕄 γ δ} (I : 𝕊 % 𝕂 →ⁱ 𝕄 ∥ γ) →
                                      AbstractedBoundary cl 𝕂 γ δ → AbstractedBoundary cl 𝕄 γ δ
  instantiate-abstracted-boundary {cl = cl} = instantiate-abstracted (BoundaryThesis cl) instantiate-boundary-thesis

  AbstractedJudgement : ∀ cl 𝕄 γ δ → Set
  AbstractedJudgement cl 𝕄 γ δ = Abstracted (JudgementThesis cl) 𝕄 γ δ

  infix 4 ⟪⟫ʲ_
  ⟪⟫ʲ_ : ∀ {cl 𝕄 γ} → JudgementThesis cl 𝕄 γ → AbstractedJudgement cl 𝕄 γ 𝟘
  ⟪⟫ʲ_ {cl = cl} 𝒷 = non-abstracted (JudgementThesis cl) rename-judgement-thesis 𝒷

  fill-abstraction : ∀ {cl 𝕄 γ δ} (ℬ : AbstractedBoundary cl 𝕄 γ δ) → Arg cl 𝕄 γ δ → AbstractedJudgement cl 𝕄 γ δ
  fill-abstraction (⟪ Δ ⟫ 𝒷) e = ⟪ Δ ⟫ (𝒷 ⟦ e ⟧)

  rename-abstracted-judgement : ∀ {cl 𝕄 β γ δ} (ρ : β →ʳ γ) →
                                  AbstractedJudgement cl 𝕄 β δ → AbstractedJudgement cl 𝕄 γ δ
  rename-abstracted-judgement {cl = cl} = rename-abstracted (JudgementThesis cl) rename-judgement-thesis

  instantiate-abstracted-judgement : ∀ {cl 𝕂 𝕄 γ δ} (I : 𝕊 % 𝕂 →ⁱ 𝕄 ∥ γ) →
                                       AbstractedJudgement cl 𝕂 γ δ → AbstractedJudgement cl 𝕄 γ δ
  instantiate-abstracted-judgement {cl = cl} = instantiate-abstracted (JudgementThesis cl) instantiate-judgement-thesis

  MContext : ∀ (𝕄 : MShape) → Set
  MContext 𝕄 = ∀ {clᴹ : Class} {γᴹ : VShape} (M : [ clᴹ , γᴹ ]∈ 𝕄) → AbstractedBoundary clᴹ 𝕄 𝟘 γᴹ

  HypotheticalBoundary : ∀ cl {𝕄 : MShape} {γ} (Θ : MContext 𝕄) (Γ : VContext 𝕄 γ) δ → Set
  HypotheticalBoundary cl {𝕄 = 𝕄} {γ = γ} Θ Γ δ = Abstracted (BoundaryThesis cl) 𝕄 γ δ

  instantiate-hypothetical-boundary :
    ∀ {cl 𝕂 𝕄 γ δ} (I : 𝕊 % 𝕂 →ⁱ 𝕄 ∥ γ) {Ξ : MContext 𝕂} {Γ : VContext 𝕂 γ} {Θ : MContext 𝕄} →
      HypotheticalBoundary cl Ξ Γ δ → HypotheticalBoundary cl Θ (instantiate-vcontext I Γ) δ
  instantiate-hypothetical-boundary I B = instantiate-abstracted-boundary I B

  HypotheticalJudgement : ∀ cl {𝕄 : MShape} {γ} (Θ : MContext 𝕄) (Γ : VContext 𝕄 γ) δ → Set
  HypotheticalJudgement cl {𝕄 = 𝕄} {γ = γ} Θ Γ δ = Abstracted (JudgementThesis cl) 𝕄 γ δ

  instantiate-hypothetical-judgement :
    ∀ {cl 𝕂 𝕄 γ δ} (I : 𝕊 % 𝕂 →ⁱ 𝕄 ∥ γ) {Ξ : MContext 𝕂} {Γ : VContext 𝕂 γ} {Θ : MContext 𝕄} →
      HypotheticalJudgement cl Ξ Γ δ → HypotheticalJudgement cl Θ (instantiate-vcontext I Γ) δ
  instantiate-hypothetical-judgement I B = instantiate-abstracted-judgement I B

  infix 6 _⇛_

  record Rule (cl : Class) (𝕄 : MShape) : Set where
    constructor _⇛_

    field
      premises : MContext 𝕄
      conclusion : JudgementThesis cl 𝕄 𝟘

  Theory = ∀ {cl} {𝕄} → Rule cl 𝕄 → Set

  instantiate-conclusion : ∀ {cl 𝕂 𝕄 γ} (I : 𝕊 % 𝕂 →ⁱ 𝕄 ∥ γ) → JudgementThesis cl 𝕂 𝟘 → JudgementThesis cl 𝕄 γ
  instantiate-conclusion I 𝒿 = instantiate-judgement-thesis I (rename-judgement-thesis 𝟘-initial 𝒿)

  module Derivation (𝒯 : Theory) where

    open Rule

    infix 3 _,_⊢ʲ_
    infix 3 _,_⊢ᵇ_

    data _,_⊢ʲ_ :
      ∀ {cl 𝕄 γ δ} (Θ : MContext 𝕄) (Γ : VContext 𝕄 γ) (𝒥 : HypotheticalJudgement cl Θ Γ δ) → Set

    data _,_⊢ᵇ_ :
      ∀ {cl 𝕄 γ δ} (Θ : MContext 𝕄) (Γ : VContext 𝕄 γ) (ℬ : HypotheticalBoundary cl Θ Γ δ) → Set

    -- derivable instantiation
    is-derivable : ∀ {𝕂 𝕄 γ} (I : 𝕊 % 𝕂 →ⁱ 𝕄 ∥ γ) (Ξ : MContext 𝕂) (Θ : MContext 𝕄) (Γ : VContext 𝕄 γ) → Set
    is-derivable {𝕂 = 𝕂} I Ξ Θ Γ =
       ∀ {clᴷ γᴷ} (M : [ clᴷ , γᴷ ]∈ 𝕂) →
         Θ , Γ ⊢ʲ fill-abstraction (instantiate-abstracted-boundary I (rename-abstracted-boundary 𝟘-initial (Ξ M))) (I M)

    data _,_⊢ʲ_ where

      TT-VAR :
        ∀ {𝕄 γ} {Θ : MContext 𝕄} {Γ : VContext 𝕄 γ} (x : var γ) → Θ , Γ ⊢ʲ (⟪⟫ʲ (expr-var x ⦂ Γ x))

      TT-RULE :
        ∀ {cl 𝕂 𝕄 γ} {Ξ : MContext 𝕂} {Θ : MContext 𝕄} {Γ : VContext 𝕄 γ}
          (I : 𝕊 % 𝕂 →ⁱ 𝕄 ∥ γ) {𝒿 : JudgementThesis cl 𝕂 𝟘} (R : 𝒯 (Ξ ⇛ 𝒿)) →
          Θ , Γ ⊢ᵇ ⟪⟫ᵇ instantiate-boundary-thesis I (rename-boundary-thesis 𝟘-initial (presupposition 𝒿)) →
          is-derivable I Ξ Θ Γ →
          Θ , Γ ⊢ʲ ⟪⟫ʲ instantiate-conclusion I 𝒿

      TT-ABSTR :
        ∀ {cl 𝕄 γ δ} {Θ : MContext 𝕄} {Γ : VContext 𝕄 γ} {Δ : VExtension 𝕄 γ δ} {𝒿 : JudgementThesis cl 𝕄 (γ ⊕ δ) } →
          Θ , Γ ⊕ᶜ Δ ⊢ʲ ⟪⟫ʲ 𝒿 →
          Θ , Γ ⊢ʲ ⟪ Δ ⟫ 𝒿

      TT-META :
        {!!}

      TT-META-CONGR :
        {!!}

      TT-EQTY-REFL :
        {!!}
      TT-EQTY-SYM :
        {!!}
      TT-EQTY-TRANS :
        {!!}
      TT-EQTM-REFL :
        {!!}
      TT-EQTM-SYM :
        {!!}
      TT-EQTM-TRANS :
        {!!}
      TT-CONV-TM :
        {!!}
      TT-CONV-EQTM :
        {!!}

    data _,_⊢ᵇ_ where

      TT-BDRY-TY :
        ∀ {𝕄 γ} {Θ : MContext 𝕄} {Γ : VContext 𝕄 γ} →
          Θ , Γ ⊢ᵇ ⟪⟫ᵇ □⦂type

      TT-BDRY-TM :
        ∀ {𝕄 γ} {Θ : MContext 𝕄} {Γ : VContext 𝕄 γ} {A} →
          Θ , Γ ⊢ʲ ⟪⟫ʲ A ⦂type →
          Θ , Γ ⊢ᵇ ⟪⟫ᵇ □⦂ A

      TT-BDRY-EQTY :
        ∀ {𝕄 γ} {Θ : MContext 𝕄} {Γ : VContext 𝕄 γ} {A B} →
          Θ , Γ ⊢ʲ ⟪⟫ʲ A ⦂type →
          Θ , Γ ⊢ʲ ⟪⟫ʲ B ⦂type →
          Θ , Γ ⊢ᵇ ⟪⟫ᵇ A ≡ B ⦂type-by□

      TT-BDRY-EQTM :
        ∀ {𝕄 γ} {Θ : MContext 𝕄} {Γ : VContext 𝕄 γ} {u v A} →
          Θ , Γ ⊢ʲ ⟪⟫ʲ A ⦂type →
          Θ , Γ ⊢ʲ ⟪⟫ʲ u ⦂ A →
          Θ , Γ ⊢ʲ ⟪⟫ʲ v ⦂ A →
          Θ , Γ ⊢ᵇ ⟪⟫ᵇ u ≡ v ⦂ A by□

      TT-BDRY-ABSTR :
        ∀ {cl 𝕄 γ δ} {Θ : MContext 𝕄} {Γ : VContext 𝕄 γ} {Δ : VExtension 𝕄 γ δ} {𝒷 : BoundaryThesis cl 𝕄 (γ ⊕ δ) } →
          Θ , Γ ⊕ᶜ Δ ⊢ᵇ ⟪⟫ᵇ 𝒷 →
          Θ , Γ ⊢ᵇ ⟪ Δ ⟫ 𝒷

    -- Missing: well-formed extensions and contexts


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

open import HoTT
open import homotopy.EilenbergMacLane
open import homotopy.EilenbergMacLaneFunctor
open import cohomology.CupProduct.OnEM.CommutativityInLowDegrees

module cohomology.CupProduct.OnEM.CommutativityInLowDegrees2 {i} {j} (G : AbGroup i) (H : AbGroup j) where

private
  module G = AbGroup G
  module H = AbGroup H
  module G⊗H = TensorProduct G H
  module H⊗G = TensorProduct H G
  module GHc = CP₁₁-comm G H
  module HGc = CP₁₁-comm H G

import cohomology.CupProduct.OnEM.InLowDegrees2 G H as GH
import cohomology.CupProduct.OnEM.InLowDegrees2 H G as HG

private
  ∧-cp₁₁-comm-smgluel : ∀ (x : EM₁ G.grp)
    → Square (GHc.CP₁₁Comm.f x embase)
             (ap GH.∧-cp₁₁ (smgluel x))
             (ap (GHc.− ∘ HG.∧-cp₁₁ ∘ ∧-swap (⊙EM₁ G.grp) (⊙EM₁ H.grp)) (smgluel x))
             idp
  ∧-cp₁₁-comm-smgluel x =
    GH.∧-cp₁₁-Rec.smgluel-β x ∙v⊡
    lt-square (GH.cp₁₁-embase-r x) ⊡v∙
    ! bottom-path
    where
    bottom-path : ap (GHc.− ∘ HG.∧-cp₁₁ ∘ ∧-swap (⊙EM₁ G.grp) (⊙EM₁ H.grp)) (smgluel x) == idp
    bottom-path =
      ap (GHc.− ∘ HG.∧-cp₁₁ ∘ ∧-swap (⊙EM₁ G.grp) (⊙EM₁ H.grp)) (smgluel x)
        =⟨ ap-∘ (GHc.− ∘ HG.∧-cp₁₁) (∧-swap (⊙EM₁ G.grp) (⊙EM₁ H.grp)) (smgluel x) ⟩
      ap (GHc.− ∘ HG.∧-cp₁₁) (ap (∧-swap (⊙EM₁ G.grp) (⊙EM₁ H.grp)) (smgluel x))
        =⟨ ap (ap (GHc.− ∘ HG.∧-cp₁₁)) (SmashSwap.smgluel-β (⊙EM₁ G.grp) (⊙EM₁ H.grp) x) ⟩
      ap (GHc.− ∘ HG.∧-cp₁₁) (∧-norm-r x)
        =⟨ ap-∘ GHc.− HG.∧-cp₁₁ (∧-norm-r x) ⟩
      ap GHc.− (ap HG.∧-cp₁₁ (∧-norm-r x))
        =⟨ ap (ap GHc.−) (HG.∧-cp₁₁-Rec.∧-norm-r-β x) ⟩
      idp =∎

  cp₁₁-comm-sym : ∀ (y : EM₁ H.grp)
    → ! (GHc.CP₁₁Comm.f embase y) == ap GHc.− (HGc.CP₁₁Comm.f y embase)
  cp₁₁-comm-sym =
    EM₁-set-elim
      {P = λ y → ! (GHc.CP₁₁Comm.f embase y) == ap GHc.− (HGc.CP₁₁Comm.f y embase)}
      {{λ y → has-level-apply (has-level-apply (Trunc-level {n = 2}) _ _) _ _}}
      idp $ λ h →
    ↓-=-in $
    idp ◃ apd (λ y → ap GHc.− (HGc.CP₁₁Comm.f y embase)) (emloop h)
      =⟨ idp◃ (apd (λ y → ap GHc.− (HGc.CP₁₁Comm.f y embase)) (emloop h)) ⟩
    apd (λ y → ap GHc.− (HGc.CP₁₁Comm.f y embase)) (emloop h)
      =⟨ apd-∘' (ap GHc.−) (λ y → HGc.CP₁₁Comm.f y embase) (emloop h) ⟩
    ap↓ (ap GHc.−) (apd (λ y → HGc.CP₁₁Comm.f y embase) (emloop h))
      =⟨ ap (ap↓ (ap GHc.−)) (HGc.CP₁₁Comm.emloop-embase-β h) ⟩
    ap↓ (ap GHc.−) (↓-='-from-square (HGc.comm-emloop-embase h))
      =⟨ ↓-='-from-square-post-∘ {h = GHc.−} (HGc.comm-emloop-embase h) ⟩
    ↓-='-from-square (ap-∘ GHc.− (λ y → HG.cp₁₁ y embase) (emloop h) ∙v⊡
                      ap-square GHc.− (HGc.comm-emloop-embase h) ⊡v∙
                      ∘-ap GHc.− (λ y → HGc.− (GH.cp₁₁ embase y)) (emloop h))
      =⟨ ap ↓-='-from-square (square-path h) ⟩
    ↓-='-from-square (!□v (GHc.comm-embase-emloop h))
      =⟨ ! (↓-='-from-square-! (GHc.comm-embase-emloop h)) ⟩
    ap↓ ! (↓-='-from-square (GHc.comm-embase-emloop h))
      =⟨ ap (ap↓ !) (! (GHc.CP₁₁Comm.embase-emloop-β h)) ⟩
    ap↓ ! (apd (λ y → GHc.CP₁₁Comm.f embase y) (emloop h))
      =⟨ ! (apd-∘' ! (λ y → GHc.CP₁₁Comm.f embase y) (emloop h)) ⟩
    apd (λ y → ! (GHc.CP₁₁Comm.f embase y)) (emloop h)
      =⟨ ! (▹idp (apd (λ y → ! (GHc.CP₁₁Comm.f embase y)) (emloop h))) ⟩
    apd (λ y → ! (GHc.CP₁₁Comm.f embase y)) (emloop h) ▹ idp =∎
    where
    =ₛ-path : ∀ (h : H.El) →
      ap-∘ GHc.− (λ y → HG.cp₁₁ y embase) (emloop h) ◃∙
      ap (ap GHc.−) (HGc.comm-emloop-embase' h) ◃∙
      ∘-ap GHc.− (λ y → HGc.− (GH.cp₁₁ embase y)) (emloop h) ◃∎
      =ₛ
      ! (GHc.comm-embase-emloop' h) ◃∎
    =ₛ-path h = !ₛ $
      ! (GHc.comm-embase-emloop' h) ◃∎
        =ₛ⟨ !-∙-seq (GHc.comm-embase-emloop-seq h) ⟩
      ! (∘-ap GHc.− (λ y → HG.cp₁₁ y embase) (emloop h)) ◃∙
      ! (! (ap (ap GHc.−) (HG.ap-cp₁₁-embase h))) ◃∙
      ! (ap-cst [ north ] (emloop h)) ◃∎
        =ₛ₁⟨ 0 & 1 & ap ! (! (!ap-∘=∘-ap GHc.− (λ y → HG.cp₁₁ y embase) (emloop h))) ∙
                     !-! (ap-∘ GHc.− (λ y → HG.cp₁₁ y embase) (emloop h)) ⟩
      ap-∘ GHc.− (λ y → HG.cp₁₁ y embase) (emloop h) ◃∙
      ! (! (ap (ap GHc.−) (HG.ap-cp₁₁-embase h))) ◃∙
      ! (ap-cst [ north ] (emloop h)) ◃∎
        =ₛ₁⟨ 1 & 1 & !-! (ap (ap GHc.−) (HG.ap-cp₁₁-embase h)) ⟩
      ap-∘ GHc.− (λ y → HG.cp₁₁ y embase) (emloop h) ◃∙
      ap (ap GHc.−) (HG.ap-cp₁₁-embase h) ◃∙
      ! (ap-cst [ north ]₂ (emloop h)) ◃∎
        =ₛ⟨ 2 & 2 & !ₛ $
            post-rotate-in {p = _ ◃∙ _ ◃∎} $
            pre-rotate'-in $
            ap-∘-cst-coh GHc.− [ north ]₂ (emloop h) ⟩
      ap-∘ GHc.− (λ y → HG.cp₁₁ y embase) (emloop h) ◃∙
      ap (ap GHc.−) (HG.ap-cp₁₁-embase h) ◃∙
      ! (ap (ap GHc.−) (ap-cst [ north ] (emloop h))) ◃∙
      ∘-ap GHc.− (λ y → HGc.− (GH.cp₁₁ embase y)) (emloop h) ◃∎
        =ₛ₁⟨ 2 & 1 & !-ap (ap GHc.−) (ap-cst [ north ]₂ (emloop h)) ⟩
      ap-∘ GHc.− (λ y → HG.cp₁₁ y embase) (emloop h) ◃∙
      ap (ap GHc.−) (HG.ap-cp₁₁-embase h) ◃∙
      ap (ap GHc.−) (! (ap-cst [ north ]₂ (emloop h))) ◃∙
      ∘-ap GHc.− (λ y → HGc.− (GH.cp₁₁ embase y)) (emloop h) ◃∎
        =ₛ⟨ 1 & 2 & ∙-ap-seq (ap GHc.−) (HGc.comm-emloop-embase-seq h) ⟩
      ap-∘ GHc.− (λ y → HG.cp₁₁ y embase) (emloop h) ◃∙
      ap (ap GHc.−) (HGc.comm-emloop-embase' h) ◃∙
      ∘-ap GHc.− (λ y → HGc.− (GH.cp₁₁ embase y)) (emloop h) ◃∎ ∎ₛ
    square-path : ∀ (h : H.El) →
      ap-∘ GHc.− (λ y → HG.cp₁₁ y embase) (emloop h) ∙v⊡
      ap-square GHc.− (HGc.comm-emloop-embase h) ⊡v∙
      ∘-ap GHc.− (λ y → HGc.− (GH.cp₁₁ embase y)) (emloop h)
      ==
      !□v (GHc.comm-embase-emloop h)
    square-path h =
      ap-∘ GHc.− (λ y → HG.cp₁₁ y embase) (emloop h) ∙v⊡
      ap-square GHc.− (HGc.comm-emloop-embase h) ⊡v∙
      ∘-ap GHc.− (λ y → HGc.− (GH.cp₁₁ embase y)) (emloop h)
        =⟨ ap (λ u → ap-∘ GHc.− (λ y → HG.cp₁₁ y embase) (emloop h) ∙v⊡
                     u ⊡v∙
                     ∘-ap GHc.− (λ y → HGc.− (GH.cp₁₁ embase y)) (emloop h)) $
           ap-vert-degen-square GHc.− (HGc.comm-emloop-embase' h) ⟩
      ap-∘ GHc.− (λ y → HG.cp₁₁ y embase) (emloop h) ∙v⊡
      vert-degen-square (ap (ap GHc.−) (HGc.comm-emloop-embase' h))
      ⊡v∙ ∘-ap GHc.− (λ y → HGc.− (GH.cp₁₁ embase y)) (emloop h)
        =⟨ ap (ap-∘ GHc.− (λ y → HG.cp₁₁ y embase) (emloop h) ∙v⊡_) $
           vert-degen-square-⊡v∙ (ap (ap GHc.−) (HGc.comm-emloop-embase' h))
                                 (∘-ap GHc.− (λ y → HGc.− (GH.cp₁₁ embase y)) (emloop h)) ⟩
      ap-∘ GHc.− (λ y → HG.cp₁₁ y embase) (emloop h) ∙v⊡
      vert-degen-square (ap (ap GHc.−) (HGc.comm-emloop-embase' h) ∙
                         ∘-ap GHc.− (λ y → HGc.− (GH.cp₁₁ embase y)) (emloop h))
        =⟨ vert-degen-square-∙v⊡
             (ap-∘ GHc.− (λ y → HG.cp₁₁ y embase) (emloop h))
             (ap (ap GHc.−) (HGc.comm-emloop-embase' h) ∙
              ∘-ap GHc.− (λ y → HGc.− (GH.cp₁₁ embase y)) (emloop h)) ⟩
      vert-degen-square (ap-∘ GHc.− (λ y → HG.cp₁₁ y embase) (emloop h) ∙
                         ap (ap GHc.−) (HGc.comm-emloop-embase' h) ∙
                         ∘-ap GHc.− (λ y → HGc.− (GH.cp₁₁ embase y)) (emloop h))
        =⟨ ap vert-degen-square (=ₛ-out (=ₛ-path h)) ⟩
      vert-degen-square (! (GHc.comm-embase-emloop' h))
        =⟨ ! (!□v-vert-degen-square (GHc.comm-embase-emloop' h)) ⟩
      !□v (GHc.comm-embase-emloop h) =∎

  ∧-cp₁₁-comm-smgluer : ∀ (y : EM₁ H.grp)
    → Square (GHc.CP₁₁Comm.f embase y)
             (ap GH.∧-cp₁₁ (smgluer y))
             (ap (GHc.− ∘ HG.∧-cp₁₁ ∘ ∧-swap (⊙EM₁ G.grp) (⊙EM₁ H.grp)) (smgluer y))
             idp
  ∧-cp₁₁-comm-smgluer y =
    GH.∧-cp₁₁-Rec.smgluer-β y ∙v⊡
    lb-square (GHc.CP₁₁Comm.f embase y) ⊡v∙
    (cp₁₁-comm-sym y ∙ ! bottom-path)
    where
    bottom-path : ap (GHc.− ∘ HG.∧-cp₁₁ ∘ ∧-swap (⊙EM₁ G.grp) (⊙EM₁ H.grp)) (smgluer y) == ap GHc.− (HG.cp₁₁-embase-r y)
    bottom-path =
      ap (GHc.− ∘ HG.∧-cp₁₁ ∘ ∧-swap (⊙EM₁ G.grp) (⊙EM₁ H.grp)) (smgluer y)
        =⟨ ap-∘ (GHc.− ∘ HG.∧-cp₁₁) (∧-swap (⊙EM₁ G.grp) (⊙EM₁ H.grp)) (smgluer y) ⟩
      ap (GHc.− ∘ HG.∧-cp₁₁) (ap (∧-swap (⊙EM₁ G.grp) (⊙EM₁ H.grp)) (smgluer y))
        =⟨ ap (ap (GHc.− ∘ HG.∧-cp₁₁)) (SmashSwap.smgluer-β (⊙EM₁ G.grp) (⊙EM₁ H.grp) y) ⟩
      ap (GHc.− ∘ HG.∧-cp₁₁) (∧-norm-l y)
        =⟨ ap-∘ GHc.− HG.∧-cp₁₁ (∧-norm-l y) ⟩
      ap GHc.− (ap HG.∧-cp₁₁ (∧-norm-l y))
        =⟨ ap (ap GHc.−) (HG.∧-cp₁₁-Rec.∧-norm-l-β y) ⟩
      ap GHc.− (HG.cp₁₁-embase-r y ∙ idp)
        =⟨ ap (ap GHc.−) (∙-unit-r (HG.cp₁₁-embase-r y)) ⟩
      ap GHc.− (HG.cp₁₁-embase-r y) =∎

private
  ∧-cp₁₁-comm' : GH.∧-cp₁₁ ∼ GHc.− ∘ HG.∧-cp₁₁ ∘ ∧-swap (⊙EM₁ G.grp) (⊙EM₁ H.grp)
  ∧-cp₁₁-comm' =
    Smash-Path-elim
      GH.∧-cp₁₁
      (GHc.− ∘ HG.∧-cp₁₁ ∘ ∧-swap (⊙EM₁ G.grp) (⊙EM₁ H.grp))
      GHc.CP₁₁Comm.f
      idp
      idp
      ∧-cp₁₁-comm-smgluel
      ∧-cp₁₁-comm-smgluer

  ⊙∧-cp₁₁-comm' : GH.⊙∧-cp₁₁ ◃⊙idf
                  =⊙∘
                  GHc.⊙− ◃⊙∘
                  HG.⊙∧-cp₁₁ ◃⊙∘
                  ⊙∧-swap (⊙EM₁ G.grp) (⊙EM₁ H.grp) ◃⊙idf
  ⊙∧-cp₁₁-comm' = =⊙∘-in (⊙λ=' ∧-cp₁₁-comm' idp)

⊙∧-cp₁₁-comm : ⊙EM-fmap G⊗H.abgroup H⊗G.abgroup G⊗H.swap 2 ◃⊙∘
               GH.⊙∧-cp₁₁ ◃⊙idf
               =⊙∘
               ⊙EM-neg H⊗G.abgroup 2 ◃⊙∘
               HG.⊙∧-cp₁₁ ◃⊙∘
               ⊙∧-swap (⊙EM₁ G.grp) (⊙EM₁ H.grp) ◃⊙idf
⊙∧-cp₁₁-comm =
  ⊙EM-fmap G⊗H.abgroup H⊗G.abgroup G⊗H.swap 2 ◃⊙∘
  GH.⊙∧-cp₁₁ ◃⊙idf
    =⊙∘⟨ 1 & 1 & ⊙∧-cp₁₁-comm' ⟩
  ⊙EM-fmap G⊗H.abgroup H⊗G.abgroup G⊗H.swap 2 ◃⊙∘
  GHc.⊙− ◃⊙∘
  HG.⊙∧-cp₁₁ ◃⊙∘
  ⊙∧-swap (⊙EM₁ G.grp) (⊙EM₁ H.grp) ◃⊙idf
    =⊙∘⟨ 1 & 1 & minus ⟩
  ⊙EM-fmap G⊗H.abgroup H⊗G.abgroup G⊗H.swap 2 ◃⊙∘
  ⊙EM-fmap H⊗G.abgroup G⊗H.abgroup H⊗G.swap 2 ◃⊙∘
  ⊙EM-neg H⊗G.abgroup 2 ◃⊙∘
  HG.⊙∧-cp₁₁ ◃⊙∘ ⊙∧-swap (⊙EM₁ G.grp) (⊙EM₁ H.grp) ◃⊙idf
    =⊙∘⟨ 0 & 2 & =⊙∘-in {gs = ⊙idf-seq} $
         ! (⊙EM-fmap-∘ H⊗G.abgroup G⊗H.abgroup H⊗G.abgroup G⊗H.swap H⊗G.swap 2) ∙
         ap (λ φ → ⊙EM-fmap H⊗G.abgroup H⊗G.abgroup φ 2) H⊗G.swap-swap-idhom ∙
         ⊙EM-fmap-idhom H⊗G.abgroup 2 ⟩
  ⊙EM-neg H⊗G.abgroup 2 ◃⊙∘
  HG.⊙∧-cp₁₁ ◃⊙∘ ⊙∧-swap (⊙EM₁ G.grp) (⊙EM₁ H.grp) ◃⊙idf ∎⊙∘
  where
  minus : GHc.⊙− ◃⊙idf
          =⊙∘
          ⊙EM-fmap H⊗G.abgroup G⊗H.abgroup H⊗G.swap 2 ◃⊙∘
          ⊙EM-neg H⊗G.abgroup 2 ◃⊙idf
  minus = =⊙∘-in $
    ⊙Trunc-fmap (⊙Susp-fmap (EM₁-fmap (inv-hom G⊗H.abgroup) ∘ EM₁-fmap H⊗G.swap))
      =⟨ ap (⊙Trunc-fmap ∘ ⊙Susp-fmap) $ ! $
         λ= (EM₁-fmap-∘ (inv-hom G⊗H.abgroup) H⊗G.swap) ⟩
    ⊙EM-fmap H⊗G.abgroup G⊗H.abgroup (inv-hom G⊗H.abgroup ∘ᴳ H⊗G.swap) 2
      =⟨ ap (λ φ → ⊙EM-fmap H⊗G.abgroup G⊗H.abgroup φ 2) $
         ! $ inv-hom-natural H⊗G.abgroup G⊗H.abgroup H⊗G.swap ⟩
    ⊙EM-fmap H⊗G.abgroup G⊗H.abgroup (H⊗G.swap ∘ᴳ inv-hom H⊗G.abgroup) 2
      =⟨ ⊙EM-fmap-∘ H⊗G.abgroup H⊗G.abgroup G⊗H.abgroup (H⊗G.swap) (inv-hom H⊗G.abgroup) 2 ⟩
    ⊙EM-fmap H⊗G.abgroup G⊗H.abgroup H⊗G.swap 2 ⊙∘ ⊙EM-neg H⊗G.abgroup 2 =∎


test = forall _let_ → Set


module Control.SimplePar where

open import Prelude
open import Builtin.Float
open import Builtin.Coinduction

Val : Set
Val = Float

data IVar (A : Set) : Set where
  ivar : Int → IVar A

data Trace : Set where
  Get  : IVar Val → (Val -> Trace) → Trace
  Put  : IVar Val → Val → Trace → Trace
  New  : (IVar Val -> Trace) → Trace
  Fork : Trace → Trace → Trace
  Done : Trace

record Par (A : Set) : Set where
  constructor par
  field
    runCont : (A → Trace) → Trace

instance
  FunctorPar : Functor Par
  fmap {{FunctorPar}} f (par runCont) = par λ c → runCont (c ∘ f)

  ApplicativePar : Applicative Par
  pure  {{ApplicativePar}} a = par λ c → c a
  _<*>_ {{ApplicativePar}} (par runCont₁) (par runCont₂) =
    par λ bcont → runCont₁ λ a → runCont₂ λ ab → bcont (a ab)

  MonadPar : Monad Par
  _>>=_ {{MonadPar}} (par runCont') k =
    par λ c → runCont' λ a → Par.runCont (k a) c

data Stream (A : Set) : Set where
  _∷_ : (a : A) (as : ∞ (Stream A)) → Stream A

instance
  FunctorStream : Functor Stream
  fmap {{FunctorStream}} f (a ∷ as) = f a ∷ ♯ fmap f (♭ as)

data IntMap (A : Set) : Set where
  ε      : IntMap A
  _↦_,_ : Int → A → IntMap A → IntMap A

find : {A : Set} → Int → IntMap A → Maybe A
find x ε = nothing
find x (y ↦ a , m) =
  ifYes x == y then just a else find x m

remove : {A : Set} → Int → IntMap A → IntMap A
remove x ε = ε
remove x (y ↦ a , m) =
  ifYes x == y
    then remove x m
    else y ↦ a , remove x m

insertWith : {A : Set} → (A → A → A) → Int → A → IntMap A → IntMap A
insertWith f x a ε = x ↦ a , ε
insertWith f x a (y ↦ b , m) =
  ifYes x == y
    then y ↦ f a b , insertWith f x a m
    else x ↦ a     , insertWith f x a m

infix 2 _∌_
infix 3 _↦ε,_ _↦_,_

data Heap : Set
data _∌_ : Heap → Int → Set

data Heap where
  ∅ : Heap
  _↦ε,_ : (ix : Int) → (h : Heap) → ⦃ p : h ∌ ix ⦄ → Heap
  _↦_,_ : (ix : Int) → (v : Val) → (h : Heap) → ⦃ p : h ∌ ix ⦄ → Heap

data _∌_ where
  ∅∌ : {ix : Int} → ∅ ∌ ix
  ε∌ : {ix ix' : Int} {h : Heap}
     → ⦃ p : h ∌ ix ⦄ → ¬ (ix' ≡ ix) → ix ↦ε, h ∌ ix'
  v∌ : {ix ix' : Int} {h : Heap} {v : Val}
     → ⦃ p : h ∌ ix ⦄ → ¬ (ix' ≡ ix) → ix ↦ v , h ∌ ix'

-- data Lookup (ix : Int) (h : Heap) : Maybe Val → Dec (h ∌ ix) → Set where
--   isn : ⦃ p : h ∌ ix ⦄ → Lookup ix h nothing (yes p)
--   isε : ⦃ p : ¬ (h ∌ ix) ⦄ → Lookup ix h nothing (no p)
--   isval : (v : Val) → ⦃ p : ¬ (h ∌ ix) ⦄ → Lookup ix h (just v) (no p)

-- lookupHeap : (ix : Int) → (h : Heap) → Σ (Maybe Val) (λ v → Σ (Dec (h ∌ ix)) (λ p → Lookup ix h v p))
-- lookupHeap ix ∅ = nothing , yes ∅∌ , isn
-- lookupHeap ix (ix' ↦ε, h) with ix == ix'
-- ... | yes refl = nothing , no (λ { (ε∌ p) → p refl }) , isε
-- ... | no p with lookupHeap ix h
-- ... | (.nothing , .(yes _) , isn) = nothing , yes (ε∌ p) , isn
-- ... | (.nothing , .(no _) , isε) = nothing , yes (ε∌ p) , isn
-- ... | (.(just v) , .(no _) , isval v) = just v , no (λ { (ε∌ q) → {!!} }) , {!isval!}
-- lookupHeap ix (ix' ↦ v , h) = {!!}

lookupHeap : (ix : Int) → (h : Heap) → Maybe Val × Dec (h ∌ ix)
lookupHeap ix ∅ = nothing , yes ∅∌
lookupHeap ix (ix' ↦ε, h) with ix == ix'
... | yes refl = nothing , no λ { (ε∌ p) → p refl }
... | no p = fst (lookupHeap ix h) , yes (ε∌ p)
lookupHeap ix (ix' ↦ v , h) with ix == ix'
... | yes refl = just v , no λ { (v∌ p) → p refl }
... | no p = fst (lookupHeap ix h) , yes (v∌ p)

infix 2 _≤ₕ_

data _≤ₕ_ : Heap → Heap → Set where
  h≤h : {h : Heap} → h ≤ₕ h
  h≤ε : {h : Heap} {ix : Int} ⦃ p : h ∌ ix ⦄
      → h ≤ₕ ix ↦ε, h
  h≤v : {h : Heap} {ix : Int} {v : Val} ⦃ p : h ∌ ix ⦄
      → h ≤ₕ ix ↦ v , h
  ε≤v : {h : Heap} {ix : Int} {v : Val} ⦃ p : h ∌ ix ⦄
      → ix ↦ε, h ≤ₕ ix ↦ v , h
  h≤s : {h₁ h₂ : Heap} {ix : Int} {v w : Val} ⦃ p₁ : h₁ ∌ ix ⦄ ⦃ p₂ : h₂ ∌ ix ⦄
      → h₁ ≤ₕ h₂ → v ≤ w → ix ↦ v , h₁ ≤ₕ ix ↦ w , h₂

Blkd = IntMap (List (Val → Trace))

data Exn : Set where
  Deadlock : Blkd → Exn
  MultiplePut : Val → Int → Val → Exn

yank : {A : Set} → Nat → A → List A → A × List A
yank n x xs =
  case splitAt (natMod (length (x ∷ xs)) n) (x ∷ xs) of
    λ { (hd , []) → x , hd
      ; (hd , x ∷ tl) → x , hd ++ tl
      }

step : (Trace × List Trace) → Blkd → Int → Heap → Either Exn (List Trace × Blkd × Int × Heap)
sched : Stream Nat → List Trace → Blkd → Int → Heap → Either Exn Heap

{-# TERMINATING #-}
sched randoms [] ε cntr heap =
  return heap
sched randoms [] blkd cntr heap =
  left (Deadlock blkd)
sched (rnd ∷ rs) (t ∷ ts) blkd cntr heap =
  caseM step (yank rnd t ts) blkd cntr heap of
    λ { (threads' , blkd' , cntr' , heap') →
          sched (♭ rs) threads' blkd' cntr' heap' }
step (Get (ivar ix) k , others) blkd cntr heap =
  case lookupHeap ix heap of
    λ { (nothing , p) → return (others , insertWith _++_ ix [ k ] blkd , cntr , heap)
      ; (just v  , p) → return (k v ∷ others , blkd , cntr , heap) }
step (Put (ivar ix) v t₂ , others) blkd cntr heap =
  case lookupHeap ix heap of
    λ { (nothing , yes p) → case find ix blkd of
        λ { nothing → return (t₂ ∷ others , blkd , cntr , (ix ↦ v , heap) ⦃ p = p ⦄)
          ; (just ls) → return (t₂ ∷ map (λ k → k v) ls ++ others , remove ix blkd , cntr , heap) }
      ; (nothing , no p) → case find ix blkd of
        λ { nothing → return {!!}
          ; (just ls) → return (t₂ ∷ map (λ k → k v) ls ++ others , remove ix blkd , cntr , heap) }
      ; (just v₀ , _) → left (MultiplePut v ix v₀) }

    -- λ { nothing → case find ix blkd of
    --     λ { nothing → return (t₂ ∷ others , blkd , cntr , ix ↦ v , {!!})
    --       ; (just ls) → {!!} }
    --   ; (just v) → {!!} }
  -- let heap' = ix ↦ v , heap
  -- in case (lookupHeap ix heap) of
  --     λ { nothing → case find ix blkd of
  --       λ { nothing → return (t₂ ∷ others , blkd , cntr , heap')
  --         ; (just ls) → return (t₂ ∷ map (λ k → k v) ls ++ others , remove ix blkd , cntr , heap) }
  --       ; (just v₀) → left (MultiplePut v ix v₀) }
step (New k , others) blkd cntr heap =
  return (k (ivar cntr) ∷ others , blkd , cntr + 1 , {!!})
  -- return (k (ivar cntr) ∷ others , blkd , cntr + 1 , cntr ↦ε, heap)
step (Fork t₁ t₂ , others) blkd cntr heap =
  return (t₁ ∷ t₂ ∷ others , blkd , cntr , heap)
step (Done , others) blkd cntr heap =
  return (others , blkd , cntr , heap)

monotonicity : ∀ {threads} {blkd} {cntr} {heap}
             → ∀ {threads'} {blkd'} {cntr'} {heap'}
             → step threads blkd cntr heap ≡ right (threads' , blkd' , cntr' , heap')
             → heap ≤ₕ heap'
monotonicity {Get (ivar ix) k , others} {heap = heap} p with (lookupHeap ix heap)
monotonicity {Get (ivar ix) k , others} p | q = {!!}
monotonicity {Put (ivar ix) v t₂ , others} {heap = heap} p with (lookupHeap ix heap)
monotonicity {Put (ivar ix) v t₂ , others} {blkd = blkd} p | q = {!!}
monotonicity {New k , others} p = {!!}
monotonicity {Fork t₁ t₂ , others} p = {!!}
monotonicity {Done , others} p = {!!}


-- Abstract constructors
module Issue476c where

module M where
  data D : Set

  abstract
    data D where
      c : D

x : M.D
x = M.c


{-# OPTIONS --no-qualified-instances #-}

postulate
  A : Set
  f : {{A}} → A

module M where postulate instance a : A

test : A
test = f


--{-# OPTIONS -v tc.data:100 #-}
module Issue830 where

_⟶_ : Set₁ → Set → Set₁
A ⟶ B = A → B

data ⟨Set⟩ : Set where
  [_] : Set ⟶ ⟨Set⟩

-- should fail


{-# OPTIONS --no-termination-check
  #-}

------------------------------------------------------------------------
-- A library of parser combinators
------------------------------------------------------------------------

module Parallel.Lib where

open import Utilities
open import Parallel
open import Parallel.Index

open import Data.Bool hiding (_≟_)
open import Data.Nat  hiding (_≟_)
open import Data.Product.Record using (_,_)
open import Data.Product renaming (_,_ to pair)
open import Data.List
open import Data.Function
open import Data.Maybe
import Data.Char as C
open import Relation.Nullary
open import Relation.Binary

------------------------------------------------------------------------
-- Applicative functor parsers

-- We could get these for free with better library support.

infixl 4 _⊛_ _<⊛_ _⊛>_ _<$>_ _<$_

-- Parser together with return and _⊛_ form a (generalised)
-- applicative functor. (Warning: I have not checked that the laws are
-- actually satisfied.)

-- Note that all the resulting indices can be inferred.

_⊛_ : forall {tok r₁ r₂ i₁ i₂} ->
      Parser tok i₁ (r₁ -> r₂) -> Parser tok i₂ r₁ ->
      Parser tok _ r₂ -- (i₁ ·I (i₂ ·I 1I))
f ⊛ x = f >>= \f' -> x >>= \x' -> return (f' x')

_<$>_ : forall {tok r₁ r₂ i} ->
        (r₁ -> r₂) -> Parser tok i r₁ -> Parser tok _ r₂ -- (i ·I 1I)
f <$> x = return f ⊛ x

_<⊛_ : forall {tok i₁ i₂ r₁ r₂} ->
       Parser tok i₁ r₁ -> Parser tok i₂ r₂ -> Parser tok _ r₁
x <⊛ y = const <$> x ⊛ y

_⊛>_ : forall {tok i₁ i₂ r₁ r₂} ->
       Parser tok i₁ r₁ -> Parser tok i₂ r₂ -> Parser tok _ r₂
x ⊛> y = flip const <$> x ⊛ y

_<$_ : forall {tok r₁ r₂ i} ->
       r₁ -> Parser tok i r₂ -> Parser tok _ r₁
x <$ y = const x <$> y

------------------------------------------------------------------------
-- Parsers for sequences

mutual

  _⋆ : forall {tok r d} ->
       Parser tok (false , d) r     ->
       Parser tok _           (List r)
  p ⋆ ~ return [] ∣ p +

  _+ : forall {tok r d} ->
       Parser tok (false , d) r     ->
       Parser tok (false , d) (List r)
  p + ~ _∷_ <$> p ⊛ p ⋆

  -- Are these definitions productive? _∣_ and _⊛_ are not
  -- constructors... Unfolding (and ignoring some casts) we get
  -- (unless I've made some mistake)
  --
  --   p ⋆ ~ parser \k -> Base._∣_ (k []) (unP (p +) k)
  --
  -- and
  --
  --   p + ~ parser (\k -> unP p     (\x  ->
  --                       unP (p ⋆) (\xs -> k (x ∷ xs))))
  --       ~ parser (\k -> unP p     (\x  -> Base._∣_ (k (x ∷ []))
  --                      (unP (p +) (\xs -> k (x ∷ xs))))).
  --
  -- Assume that p + is applied to the continuation k =
  -- const Base.fail. We get
  --
  --   unP (p +) k ~ unP p (\x -> unP (p +) (\xs -> k (x ∷ xs))).
  --
  -- This implies that the definitions above are not /obviously/
  -- productive. Note now that when p is defined the function unP p
  -- has type
  --
  --   forall {i' r'} ->
  --   (r -> Base.Parser tok r' i') ->
  --   Base.Parser tok r' (i ·I i')
  --
  -- for arbitrary i' and r', and with i = (false , d) as above this
  -- specialises to
  --
  --   forall {i' r'} ->
  --   (r -> Base.Parser tok r' i') ->
  --   Base.Parser tok r' (false , d).
  --
  -- Note that in some cases it is actually possible for p to
  -- immediately return its input (by first checking that i' =
  -- (false, d)). Furthermore, if p can pattern match on the result of
  -- the continuation (like in Parallel.problematic), then unP (p +)
  -- is not productive. In this case the module system prevents p from
  -- performing such pattern matching /directly/, but ensuring that
  -- this is not possible /indirectly/ seems overly difficult,
  -- considering that there are definitions (other than
  -- Parallel.problematic) which pattern match on Base.Parser.
  --
  -- As an example the type checking of the following definition does
  -- not terminate:
  --
  --   loops : parse-complete (problematic false + >>= \_ -> fail) ('a' ∷ [])
  --           ≡ []
  --   loops = ≡-refl
  --
  -- Furthermore the definition of number below, which uses _+, is
  -- rather fragile, and the type checking of some definitions in
  -- Parallel.Examples which use number fail to terminate (at least
  -- with the version of Agda which is current at the time of
  -- writing).

-- p sepBy sep parses one or more ps separated by seps.

_sepBy_ : forall {tok r r' i d} ->
          Parser tok i r -> Parser tok (false , d) r' ->
          Parser tok _ (List r)
p sepBy sep = _∷_ <$> p ⊛ (sep ⊛> p) ⋆

chain₁ :  forall {tok d₁ i₂ r}
       -> Assoc
       -> Parser tok (false , d₁) r
       -> Parser tok i₂ (r -> r -> r)
       -> Parser tok _ r
chain₁ a p op = chain₁-combine a <$> (pair <$> p ⊛ op) ⋆ ⊛ p

chain :  forall {tok d₁ i₂ r}
      -> Assoc
      -> Parser tok (false , d₁) r
      -> Parser tok i₂ (r -> r -> r)
      -> r
      -> Parser tok _ r
chain a p op x = return x ∣ chain₁ a p op

------------------------------------------------------------------------
-- Parsing a given token (symbol)

module Sym (a : DecSetoid) where

  open DecSetoid a using (_≟_) renaming (carrier to tok)

  sym : tok -> Parser tok _ tok
  sym x = sat p
    where
    p : tok -> Maybe tok
    p y with x ≟ y
    ... | yes _ = just y
    ... | no  _ = nothing

------------------------------------------------------------------------
-- Character parsers

digit : Parser C.Char _ ℕ
digit = 0 <$ sym '0'
      ∣ 1 <$ sym '1'
      ∣ 2 <$ sym '2'
      ∣ 3 <$ sym '3'
      ∣ 4 <$ sym '4'
      ∣ 5 <$ sym '5'
      ∣ 6 <$ sym '6'
      ∣ 7 <$ sym '7'
      ∣ 8 <$ sym '8'
      ∣ 9 <$ sym '9'
  where open Sym C.decSetoid

number : Parser C.Char _ ℕ
number = toNum <$> ds
  where
  -- Inlining ds makes the type checker loop.
  ds = digit +

  toNum = foldr (\n x -> 10 * x + n) 0 ∘ reverse


{-# OPTIONS --rewriting #-}

open import Agda.Builtin.Equality

{-# BUILTIN REWRITE _≡_ #-}

postulate
  X   : Set₁
  rew : X ≡ Set

{-# REWRITE rew #-}
{-# REWRITE rew #-}


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

   Copyright (c) 2020, 2021, Oracle and/or its affiliates.
   Licensed under the Universal Permissive License v 1.0 as shown at https://opensource.oracle.com/licenses/upl
-}
{-# OPTIONS --allow-unsolved-metas #-}
open import LibraBFT.Prelude
open import LibraBFT.Base.PKCS
open import LibraBFT.Concrete.Obligations
open import LibraBFT.Concrete.System.Parameters
open import LibraBFT.Impl.Consensus.Types
open import LibraBFT.Impl.NetworkMsg
open import LibraBFT.Impl.Util.Crypto
open        EpochConfig
open import LibraBFT.Yasm.Yasm (ℓ+1 0ℓ) EpochConfig epochId authorsN ConcSysParms NodeId-PK-OK

-- In this module, we will prove a structural property that any new signed message produced by an
-- honest handler from a reachable state correctly identifies the sender, and is for a valid epoch
-- of which that sender is a member.  It is postulated for now, because the property does not yet
-- hold for our fake implementation that does not actually comply.  A proof outline and notes are
-- included below, which we can finish once we do have a compliant implementation.

module LibraBFT.Impl.Properties.Aux where
  -- This proof is complete except for pieces that are directly about the handlers.  Our
  -- fake/simple handler does not yet obey the needed properties, so we can't finish this yet.
  impl-sps-avp : StepPeerState-AllValidParts
  -- In our fake/simple implementation, init and handling V and C msgs do not send any messages
  impl-sps-avp _ hpk (step-init ix) m∈outs part⊂m ver      = ⊥-elim (¬Any[] m∈outs)
  impl-sps-avp _ hpk (step-msg {sndr , V vm} _ _) m∈outs _ _ = ⊥-elim (¬Any[] m∈outs)
  impl-sps-avp _ hpk (step-msg {sndr , C cm} _ _) m∈outs _ _ = ⊥-elim (¬Any[] m∈outs)
  -- These aren't true yet, because processProposalMsgM sends fake votes that don't follow the rules for ValidPartForPK
  impl-sps-avp preach hpk (step-msg {sndr , P pm} m∈pool ps≡) m∈outs v⊂m ver
     with m∈outs
     -- Handler sends at most one vote, so it can't be "there"
  ...| there {xs = xs} imp = ⊥-elim (¬Any[] imp)
  ...| here refl
     with v⊂m
  ...| vote∈qc vs∈qc rbld≈ qc∈m
     with qc∈m
  ...| xxx = {!x!}                -- We will prove that votes represented in the SyncInfo of a
                                  -- proposal message were sent before, so these will be inj₂.
                                  -- This will be based on an invariant of the implementation, for
                                  -- example that the QCs included in the SyncInfo of a VoteMsg have
                                  -- been sent before.  We will need to use hash injectivity and
                                  -- signature injectivity to ensure a different vote was not sent
                                  -- previously with the same signature.

  impl-sps-avp {pk = pk} {α = α} {st = st} preach hpk (step-msg {sndr , P pm} m∈pool ps≡) m∈outs v⊂m ver
     | here refl
     | vote∈vm {si}
     with MsgWithSig∈? {pk} {ver-signature ver} {msgPool st}
  ...| yes msg∈ = inj₂ msg∈
  ...| no  msg∉ = inj₁ ((mkValidSenderForPK      {! epoch !} -- We will need an invariant that says the epoch
                                                             -- used by a voter is "in range".
                                                 (EC-lookup' (availEpochs st) {!!})
                                                 refl
                                                 {! !}       -- The implementation will need to check that the voter is a member of
                                                             -- the epoch of the message it's sending.
                                                 )
                        , msg∉)


-- Reported by Christian Sattler on 2019-12-7

postulate
  A B : Set

barb : Set
barb = (A → (_ : B) → _) _

-- WAS: unsolved constraints.
-- SHOULD: throw an error that A → ... is not a function.