------------------------------------------------------------------------
-- The Agda standard library
--
-- Core lemmas for division and modulus operations
------------------------------------------------------------------------

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

module Data.Nat.DivMod.Core where

open import Agda.Builtin.Nat using ()
  renaming (div-helper to divₕ; mod-helper to modₕ)

open import Data.Nat.Base
open import Data.Nat.Properties
open import Data.Sum.Base using (_⊎_; inj₁; inj₂)
open import Data.Product using (_×_; _,_)
open import Relation.Binary.PropositionalEquality
open import Relation.Nullary using (yes; no)
open import Relation.Nullary.Negation using (contradiction)

open ≤-Reasoning

-------------------------------------------------------------------------
-- Helper lemmas that have no interpretation for _%_, only for modₕ

private

  mod-cong₃ : ∀ {c n a₁ a₂ b} → a₁ ≡ a₂ → modₕ c n a₁ b ≡ modₕ c n a₂ b
  mod-cong₃ refl = refl

  modₕ-skipTo0 : ∀ acc n a b → modₕ acc n (b + a) a ≡ modₕ (a + acc) n b 0
  modₕ-skipTo0 acc n zero    b = cong (λ v → modₕ acc n v 0) (+-identityʳ b)
  modₕ-skipTo0 acc n (suc a) b = begin-equality
    modₕ acc n (b + suc a) (suc a) ≡⟨ mod-cong₃ (+-suc b a) ⟩
    modₕ acc n (suc b + a) (suc a) ≡⟨⟩
    modₕ (suc acc) n (b + a) a     ≡⟨ modₕ-skipTo0 (suc acc) n a b ⟩
    modₕ (a + suc acc) n b 0       ≡⟨ cong (λ v → modₕ v n b 0) (+-suc a acc) ⟩
    modₕ (suc a + acc) n b 0       ∎

-------------------------------------------------------------------------
-- Lemmas for modₕ that also have an interpretation for _%_

a[modₕ]1≡0 : ∀ a → modₕ 0 0 a 0 ≡ 0
a[modₕ]1≡0 zero    = refl
a[modₕ]1≡0 (suc a) = a[modₕ]1≡0 a

n[modₕ]n≡0 : ∀ acc v → modₕ acc (acc + v) (suc v) v ≡ 0
n[modₕ]n≡0 acc v = modₕ-skipTo0 acc (acc + v) v 1

a[modₕ]n<n : ∀ acc d n → modₕ acc (acc + n) d n ≤ acc + n
a[modₕ]n<n acc zero    n       = m≤m+n acc n
a[modₕ]n<n acc (suc d) zero    = a[modₕ]n<n zero d (acc + 0)
a[modₕ]n<n acc (suc d) (suc n) rewrite +-suc acc n = a[modₕ]n<n (suc acc) d n

a[modₕ]n≤a : ∀ acc a n → modₕ acc (acc + n) a n ≤ acc + a
a[modₕ]n≤a acc zero    n       = ≤-reflexive (sym (+-identityʳ acc))
a[modₕ]n≤a acc (suc a) (suc n) = begin
  modₕ acc (acc + suc n) (suc a) (suc n) ≡⟨ cong (λ v → modₕ acc v (suc a) (suc n)) (+-suc acc n) ⟩
  modₕ acc (suc acc + n) (suc a) (suc n) ≤⟨ a[modₕ]n≤a (suc acc) a n ⟩
  suc acc + a                            ≡⟨ sym (+-suc acc a) ⟩
  acc + suc a                            ∎
a[modₕ]n≤a acc (suc a) zero    = begin
  modₕ acc (acc + 0) (suc a) 0 ≡⟨ cong (λ v → modₕ acc v (suc a) 0) (+-identityʳ acc) ⟩
  modₕ acc acc (suc a) 0       ≤⟨ a[modₕ]n≤a 0 a acc ⟩
  a                            ≤⟨ n≤1+n a ⟩
  suc a                        ≤⟨ m≤n+m (suc a) acc ⟩
  acc + suc a                  ∎

a≤n⇒a[modₕ]n≡a : ∀ acc n a b → modₕ acc n a (a + b) ≡ acc + a
a≤n⇒a[modₕ]n≡a acc n zero    b = sym (+-identityʳ acc)
a≤n⇒a[modₕ]n≡a acc n (suc a) b = begin-equality
  modₕ (suc acc) n a (a + b) ≡⟨ a≤n⇒a[modₕ]n≡a (suc acc) n a b ⟩
  suc acc + a                ≡⟨ sym (+-suc acc a) ⟩
  acc + suc a                ∎

modₕ-idem : ∀ acc a n → modₕ 0 (acc + n) (modₕ acc (acc + n) a n) (acc + n) ≡ modₕ acc (acc + n) a n
modₕ-idem acc zero    n       = a≤n⇒a[modₕ]n≡a 0 (acc + n) acc n
modₕ-idem acc (suc a) zero    rewrite +-identityʳ acc = modₕ-idem 0 a acc
modₕ-idem acc (suc a) (suc n) rewrite +-suc acc n = modₕ-idem (suc acc) a n

a+1[modₕ]n≡0⇒a[modₕ]n≡n-1 : ∀ acc l n → modₕ acc (acc + l) (suc n) l ≡ 0 → modₕ acc (acc + l) n l ≡ acc + l
a+1[modₕ]n≡0⇒a[modₕ]n≡n-1 acc zero    zero    eq rewrite +-identityʳ acc = refl
a+1[modₕ]n≡0⇒a[modₕ]n≡n-1 acc zero    (suc n) eq rewrite +-identityʳ acc = a+1[modₕ]n≡0⇒a[modₕ]n≡n-1 0 acc n eq
a+1[modₕ]n≡0⇒a[modₕ]n≡n-1 acc (suc l) (suc n) eq rewrite +-suc acc l     = a+1[modₕ]n≡0⇒a[modₕ]n≡n-1 (suc acc) l n eq

k<1+a[modₕ]n⇒k≤a[modₕ]n  : ∀ acc k n l → suc k ≤ modₕ acc (acc + l) (suc n) l → k ≤ modₕ acc (acc + l) n l
k<1+a[modₕ]n⇒k≤a[modₕ]n acc k zero    (suc l) (s≤s leq) = leq
k<1+a[modₕ]n⇒k≤a[modₕ]n acc k (suc n) zero    leq rewrite +-identityʳ acc = k<1+a[modₕ]n⇒k≤a[modₕ]n 0 k n acc leq
k<1+a[modₕ]n⇒k≤a[modₕ]n acc k (suc n) (suc l) leq rewrite +-suc acc l     = k<1+a[modₕ]n⇒k≤a[modₕ]n (suc acc) k n l leq

1+a[modₕ]n≤1+k⇒a[modₕ]n≤k : ∀ acc k n l → 0 < modₕ acc (acc + l) (suc n) l →
                            modₕ acc (acc + l) (suc n) l ≤ suc k → modₕ acc (acc + l) n l ≤ k
1+a[modₕ]n≤1+k⇒a[modₕ]n≤k acc k zero    (suc l) 0<mod (s≤s leq) = leq
1+a[modₕ]n≤1+k⇒a[modₕ]n≤k acc k (suc n) zero    0<mod leq rewrite +-identityʳ acc = 1+a[modₕ]n≤1+k⇒a[modₕ]n≤k 0 k n acc 0<mod leq
1+a[modₕ]n≤1+k⇒a[modₕ]n≤k acc k (suc n) (suc l) 0<mod leq rewrite +-suc acc l = 1+a[modₕ]n≤1+k⇒a[modₕ]n≤k (suc acc) k n l 0<mod leq

a+n[modₕ]n≡a[modₕ]n : ∀ acc a n → modₕ acc (acc + n) (acc + a + suc n) n ≡ modₕ acc (acc + n) a n
a+n[modₕ]n≡a[modₕ]n acc zero n rewrite +-identityʳ acc = begin-equality
  modₕ acc (acc + n) (acc + suc n) n   ≡⟨ mod-cong₃ (+-suc acc n) ⟩
  modₕ acc (acc + n) (suc acc + n) n   ≡⟨ modₕ-skipTo0 acc (acc + n) n (suc acc) ⟩
  modₕ (acc + n) (acc + n) (suc acc) 0 ≡⟨⟩
  modₕ 0 (acc + n) acc (acc + n)       ≡⟨ a≤n⇒a[modₕ]n≡a 0 (acc + n) acc n ⟩
  acc                                  ∎
a+n[modₕ]n≡a[modₕ]n acc (suc a) zero rewrite +-identityʳ acc = begin-equality
  modₕ acc acc (acc + suc a + 1)   0   ≡⟨ mod-cong₃ (+-comm (acc + suc a) 1) ⟩
  modₕ acc acc (1 + (acc + suc a)) 0   ≡⟨⟩
  modₕ 0   acc (acc + suc a)       acc ≡⟨ mod-cong₃ (+-comm acc (suc a)) ⟩
  modₕ 0   acc (suc a + acc)       acc ≡⟨ mod-cong₃ (sym (+-suc a acc)) ⟩
  modₕ 0   acc (a + suc acc)       acc ≡⟨ a+n[modₕ]n≡a[modₕ]n 0 a acc ⟩
  modₕ 0   acc a                   acc ∎
a+n[modₕ]n≡a[modₕ]n acc (suc a) (suc n) rewrite +-suc acc n = begin-equality
  mod₁ (acc + suc a + (2 + n)) (suc n) ≡⟨ cong (λ v → mod₁ (v + suc (suc n)) (suc n)) (+-suc acc a) ⟩
  mod₁ (suc acc + a + (2 + n)) (suc n) ≡⟨⟩
  mod₂ (acc + a + (2 + n))     n       ≡⟨ mod-cong₃ (sym (+-assoc (acc + a) 1 (suc n))) ⟩
  mod₂ (acc + a + 1 + suc n)   n       ≡⟨ mod-cong₃ (cong (_+ suc n) (+-comm (acc + a) 1)) ⟩
  mod₂ (suc acc + a + suc n)   n       ≡⟨ a+n[modₕ]n≡a[modₕ]n (suc acc) a n ⟩
  mod₂ a                       n       ∎
  where
  mod₁ = modₕ acc       (suc acc + n)
  mod₂ = modₕ (suc acc) (suc acc + n)

-------------------------------------------------------------------------
-- Helper lemmas that have no interpretation for `_/_`, only for `divₕ`

private

  div-cong₃ : ∀ {c n a₁ a₂ b} → a₁ ≡ a₂ → divₕ c n a₁ b ≡ divₕ c n a₂ b
  div-cong₃ refl = refl

  divₕ-restart : ∀ {acc} d n j → j < n → divₕ acc d n j ≡ divₕ (suc acc) d (n ∸ suc j) d
  divₕ-restart d (suc n) zero    j<n       = refl
  divₕ-restart d (suc n) (suc j) (s≤s j<n) = divₕ-restart d n j j<n

  divₕ-finish : ∀ {acc} d n j → j ≥ n → divₕ acc d n j ≡ acc
  divₕ-finish d zero    j       j≥n       = refl
  divₕ-finish d (suc n) (suc j) (s≤s j≥n) = divₕ-finish d n j j≥n

  acc≤divₕ[acc] : ∀ {acc} d n j → acc ≤ divₕ acc d n j
  acc≤divₕ[acc] {acc} d zero    j       = ≤-refl
  acc≤divₕ[acc] {acc} d (suc n) zero    = ≤-trans (n≤1+n acc) (acc≤divₕ[acc] d n d)
  acc≤divₕ[acc] {acc} d (suc n) (suc j) = acc≤divₕ[acc] d n j

  divₕ-extractAcc : ∀ acc d n j → divₕ acc d n j ≡ acc + divₕ 0 d n j
  divₕ-extractAcc acc d zero j          = sym (+-identityʳ acc)
  divₕ-extractAcc acc d (suc n) (suc j) = divₕ-extractAcc acc d n j
  divₕ-extractAcc acc d (suc n) zero = begin-equality
    divₕ (suc acc)    d n d  ≡⟨ divₕ-extractAcc (suc acc) d n d ⟩
    suc acc +  divₕ 0 d n d  ≡⟨ sym (+-suc acc _) ⟩
    acc + suc (divₕ 0 d n d) ≡⟨ cong (acc +_) (sym (divₕ-extractAcc 1 d n d)) ⟩
    acc +      divₕ 1 d n d  ∎

  pattern inj₂′ x = inj₂ (inj₁ x)
  pattern inj₃  x = inj₂ (inj₂ x)

  -- This hideous lemma details the conditions needed for two divisions to
  -- be equal when the two offsets (i.e. the 4ᵗʰ parameters) are different.
  -- It may be that this triple sum has an elegant simplification to a
  -- set of inequalities involving the modulus but I can't find it.
  divₕ-offsetEq : ∀ {acc₁ acc₂} d n j k → j ≤ d → k ≤ d →
                  (acc₁ ≡ acc₂     × j ≤ k × k < modₕ 0 d n d) ⊎
                  (acc₁ ≡ acc₂     × modₕ 0 d n d ≤ j × j ≤ k) ⊎
                  (acc₁ ≡ suc acc₂ × k < modₕ 0 d n d × modₕ 0 d n d ≤ j) →
                  divₕ acc₁ d n j ≡ divₕ acc₂ d n k
  divₕ-offsetEq d zero    j       k       j≤d k≤d (inj₁  (refl , _)) = refl
  divₕ-offsetEq d zero    j       k       j≤d k≤d (inj₂′ (refl , _)) = refl
  divₕ-offsetEq d zero    j       k       j≤d k≤d (inj₃ (eq , () , _))
  -- (0 , 0) cases
  divₕ-offsetEq d (suc n) zero    zero    j≤d k≤d (inj₁ (refl , _)) =
    divₕ-offsetEq d n d d ≤-refl ≤-refl (inj₂′ (refl , a[modₕ]n<n 0 n d , ≤-refl))
  divₕ-offsetEq d (suc n) zero    zero    j≤d k≤d (inj₂′ (refl , _)) =
    divₕ-offsetEq d n d d ≤-refl ≤-refl (inj₂′ (refl , a[modₕ]n<n 0 n d , ≤-refl))
  divₕ-offsetEq d (suc n) zero    zero    j≤d k≤d (inj₃ (_ , 0<mod , mod≤0)) =
    contradiction (<-transˡ 0<mod mod≤0) λ()
  -- (0 , suc) cases
  divₕ-offsetEq d (suc n) zero (suc k)    j≤d k≤d (inj₁  (refl , _ , 1+k<mod)) =
    divₕ-offsetEq d n d k ≤-refl (<⇒≤ k≤d) (inj₃ (refl , k<1+a[modₕ]n⇒k≤a[modₕ]n 0 (suc k) n d 1+k<mod , a[modₕ]n<n 0 n d))
  divₕ-offsetEq d (suc n) zero (suc k)    j≤d k≤d (inj₂′ (refl , mod≤0 , _)) =
    divₕ-offsetEq d n d k ≤-refl (<⇒≤ k≤d) (inj₃ (refl , subst (k <_) (sym (a+1[modₕ]n≡0⇒a[modₕ]n≡n-1 0 d n (n≤0⇒n≡0 mod≤0))) k≤d , a[modₕ]n<n 0 n d))
  divₕ-offsetEq d (suc n) zero (suc k)    j≤d k≤d (inj₃  (_ , 1+k<mod , mod≤0)) =
    contradiction (<-transˡ 1+k<mod mod≤0) λ()
  -- (suc , 0) cases
  divₕ-offsetEq d (suc n) (suc j) zero j≤d k≤d (inj₁  (_ , () , _))
  divₕ-offsetEq d (suc n) (suc j) zero j≤d k≤d (inj₂′ (_ , _ , ()))
  divₕ-offsetEq d (suc n) (suc j) zero j≤d k≤d (inj₃  (eq , 0<mod , mod≤1+j)) =
    divₕ-offsetEq d n j d (<⇒≤ j≤d) ≤-refl (inj₂′ (eq , 1+a[modₕ]n≤1+k⇒a[modₕ]n≤k 0 j n d 0<mod mod≤1+j , <⇒≤ j≤d))
  -- (suc , suc) cases
  divₕ-offsetEq d (suc n) (suc j) (suc k) j≤d k≤d (inj₁ (eq , s≤s j≤k , 1+k<mod)) =
    divₕ-offsetEq d n j k (<⇒≤ j≤d) (<⇒≤ k≤d) (inj₁ (eq , j≤k , k<1+a[modₕ]n⇒k≤a[modₕ]n 0 (suc k) n d 1+k<mod))
  divₕ-offsetEq d (suc n) (suc j) (suc k) j≤d k≤d (inj₂′ (eq , mod≤1+j , (s≤s j≤k))) with modₕ 0 d (suc n) d ≟ 0
  ... | yes mod≡0 = divₕ-offsetEq d n j k (<⇒≤ j≤d) (<⇒≤ k≤d) (inj₁ (eq , j≤k , subst (k <_) (sym (a+1[modₕ]n≡0⇒a[modₕ]n≡n-1 0 d n mod≡0)) k≤d))
  ... | no  mod≢0 = divₕ-offsetEq d n j k (<⇒≤ j≤d) (<⇒≤ k≤d) (inj₂′ (eq , 1+a[modₕ]n≤1+k⇒a[modₕ]n≤k 0 j n d (n≢0⇒n>0 mod≢0) mod≤1+j , j≤k))
  divₕ-offsetEq d (suc n) (suc j) (suc k) j≤d k≤d (inj₃  (eq , k<mod , mod≤1+j)) =
    divₕ-offsetEq d n j k (<⇒≤ j≤d) (<⇒≤ k≤d) (inj₃ (eq , k<1+a[modₕ]n⇒k≤a[modₕ]n 0 (suc k) n d k<mod , 1+a[modₕ]n≤1+k⇒a[modₕ]n≤k 0 j n d (<-transʳ z≤n k<mod) mod≤1+j))

-------------------------------------------------------------------------
-- Lemmas for divₕ that also have an interpretation for _/_

-- The quotient and remainder are related to the dividend and
-- divisor in the right way.

div-mod-lemma : ∀ accᵐ accᵈ d n →
    accᵐ + accᵈ * suc (accᵐ + n) + d ≡
    modₕ accᵐ (accᵐ + n) d n + divₕ accᵈ (accᵐ + n) d n * suc (accᵐ + n)
div-mod-lemma accᵐ accᵈ zero    n    = +-identityʳ _
div-mod-lemma accᵐ accᵈ (suc d) zero rewrite +-identityʳ accᵐ = begin-equality
  accᵐ + accᵈ * suc accᵐ + suc d          ≡⟨ +-suc _ d ⟩
  suc accᵈ * suc accᵐ + d                 ≡⟨ div-mod-lemma zero (suc accᵈ) d accᵐ ⟩
  modₕ 0          accᵐ d accᵐ +
  divₕ (suc accᵈ) accᵐ d accᵐ * suc accᵐ  ≡⟨⟩
  modₕ accᵐ accᵐ (suc d) 0 +
  divₕ accᵈ accᵐ (suc d) 0 * suc accᵐ     ∎
div-mod-lemma accᵐ accᵈ (suc d) (suc n) rewrite +-suc accᵐ n = begin-equality
  accᵐ + accᵈ * m + suc d             ≡⟨ +-suc _ d ⟩
  suc (accᵐ + accᵈ * m + d)           ≡⟨ div-mod-lemma (suc accᵐ) accᵈ d n ⟩
  modₕ _ _ d n + divₕ accᵈ _ d n * m  ∎
  where
  m = 2 + accᵐ + n

n[divₕ]n≡1 : ∀ n m → divₕ 0 n (suc m) m ≡ 1
n[divₕ]n≡1 n zero    = refl
n[divₕ]n≡1 n (suc m) = n[divₕ]n≡1 n m

a[divₕ]1≡a : ∀ acc a → divₕ acc 0 a 0 ≡ acc + a
a[divₕ]1≡a acc zero    = sym (+-identityʳ acc)
a[divₕ]1≡a acc (suc a) = trans (a[divₕ]1≡a (suc acc) a) (sym (+-suc acc a))

a*n[divₕ]n≡a : ∀ acc a n → divₕ acc n (a * suc n) n ≡ acc + a
a*n[divₕ]n≡a acc zero    n = sym (+-identityʳ acc)
a*n[divₕ]n≡a acc (suc a) n = begin-equality
  divₕ acc       n (suc a * suc n)             n ≡⟨ divₕ-restart n (suc a * suc n) n (m≤m+n (suc n) _) ⟩
  divₕ (suc acc) n (suc a * suc n ∸ suc n)     n ≡⟨⟩
  divₕ (suc acc) n (suc n + a * suc n ∸ suc n) n ≡⟨ div-cong₃ (m+n∸m≡n (suc n) (a * suc n)) ⟩
  divₕ (suc acc) n (a * suc n)                 n ≡⟨ a*n[divₕ]n≡a (suc acc) a n ⟩
  suc acc + a                                    ≡⟨ sym (+-suc acc a) ⟩
  acc + suc a                                    ∎

+-distrib-divₕ : ∀ acc k m n j → modₕ k (k + j) m j + modₕ 0 (k + j) n (k + j) < suc (k + j) →
                 divₕ acc (k + j) (m + n) j ≡ divₕ acc (k + j) m j + divₕ 0 (k + j) n (k + j)
+-distrib-divₕ acc k (suc m) n zero leq rewrite +-identityʳ k = +-distrib-divₕ (suc acc) 0 m n k leq
+-distrib-divₕ acc k (suc m) n (suc j) leq rewrite +-suc k j = +-distrib-divₕ acc (suc k) m n j leq
+-distrib-divₕ acc k zero n j leq = begin-equality
  divₕ acc (k + j) n j           ≡⟨ divₕ-extractAcc acc (k + j) n j ⟩
  acc + divₕ 0 (k + j) n j       ≡⟨ cong (acc +_) (divₕ-offsetEq _ n j _ (m≤n+m j k) ≤-refl case) ⟩
  acc + divₕ 0 (k + j) n (k + j) ∎
  where
  case = inj₂′ (refl , +-cancelˡ-≤ (suc k) leq , m≤n+m j k)

divₕ-mono-≤ : ∀ {acc} k {m n o p} → m ≤ n → p ≤ o → divₕ acc (k + o) m o ≤ divₕ acc (k + p) n p
divₕ-mono-≤ {acc} k {0} {n} {_} {p} z≤n p≤o = acc≤divₕ[acc] (k + p) n p
divₕ-mono-≤ {acc} k {_} {_} {suc o} {suc p} (s≤s m≤n) (s≤s p≤o)
  rewrite +-suc k o | +-suc k p = divₕ-mono-≤ (suc k) m≤n p≤o
divₕ-mono-≤ {acc} k {suc m} {suc n} {o} {0}      (s≤s m≤n) z≤n with o <? suc m
... | no  o≮1+m rewrite +-identityʳ k = begin
  divₕ acc (k + o) (suc m) o ≡⟨ divₕ-finish (k + o) (suc m) o (≮⇒≥ o≮1+m) ⟩
  acc                        ≤⟨ n≤1+n acc ⟩
  suc acc                    ≤⟨ acc≤divₕ[acc] k n k ⟩
  divₕ (suc acc) k n k       ∎
... | yes o<1+m rewrite +-identityʳ k = begin
  divₕ acc       (k + o) (suc m) o       ≡⟨ divₕ-restart (k + o) (suc m) o o<1+m ⟩
  divₕ (suc acc) (k + o) (m ∸ o) (k + o) ≤⟨ divₕ-mono-≤ 0 (≤-trans (m∸n≤m m o) m≤n) (m≤m+n k o) ⟩
  divₕ (suc acc) k       n       k       ∎


------------------------------------------------------------------------------
-- Totality properties respect to Bool
------------------------------------------------------------------------------

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

module FOTC.Program.SortList.Properties.Totality.BoolATP where

open import FOTC.Base
open import FOTC.Base.List
open import FOTC.Data.Bool.PropertiesATP
open import FOTC.Data.Bool.Type
open import FOTC.Data.Nat.List.Type
open import FOTC.Data.Nat.Type
open import FOTC.Program.SortList.SortList

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

le-ItemList-Bool : ∀ {item is} → N item → ListN is → Bool (le-ItemList item is)
le-ItemList-Bool {item} Nitem lnnil = prf
  where postulate prf : Bool (le-ItemList item [])
        {-# ATP prove prf #-}

le-ItemList-Bool {item} Nitem (lncons {i} {is} Ni Lis) =
  prf (le-ItemList-Bool Nitem Lis)
  where postulate prf : Bool (le-ItemList item is) →
                        Bool (le-ItemList item (i ∷ is))
        {-# ATP prove prf &&-Bool le-Bool #-}

le-Lists-Bool : ∀ {is js} → ListN is → ListN js → Bool (le-Lists is js)
le-Lists-Bool {js = js} lnnil LNjs = prf
  where postulate prf : Bool (le-Lists [] js)
        {-# ATP prove prf #-}
le-Lists-Bool {js = js} (lncons {i} {is} Ni LNis) LNjs =
  prf (le-Lists-Bool LNis LNjs)
  where postulate prf : Bool (le-Lists is js) → Bool (le-Lists (i ∷ is) js)
        {-# ATP prove prf &&-Bool le-ItemList-Bool #-}

ordList-Bool : ∀ {is} → ListN is → Bool (ordList is)
ordList-Bool lnnil = prf
  where postulate prf : Bool (ordList [])
        {-# ATP prove prf #-}

ordList-Bool (lncons {i} {is} Ni LNis) = prf (ordList-Bool LNis)
  where postulate prf : Bool (ordList is) → Bool (ordList (i ∷ is))
        {-# ATP prove prf &&-Bool le-ItemList-Bool #-}

le-ItemTree-Bool : ∀ {item t} → N item → Tree t → Bool (le-ItemTree item t)
le-ItemTree-Bool {item} Nt tnil = prf
  where postulate prf : Bool (le-ItemTree item nil)
        {-# ATP prove prf #-}
le-ItemTree-Bool {item} Nitem (ttip {i} Ni) = prf
  where postulate prf : Bool (le-ItemTree item (tip i))
        {-# ATP prove prf le-Bool #-}
le-ItemTree-Bool {item} Nitem  (tnode {t₁} {i} {t₂} Tt₁ Ni Tt₂) =
  prf (le-ItemTree-Bool Nitem Tt₁) (le-ItemTree-Bool Nitem Tt₂)
  where postulate prf : Bool (le-ItemTree item t₁) →
                        Bool (le-ItemTree item t₂) →
                        Bool (le-ItemTree item (node t₁ i t₂))
        {-# ATP prove prf &&-Bool #-}

le-TreeItem-Bool : ∀ {t item} → Tree t → N item → Bool (le-TreeItem t item)
le-TreeItem-Bool {item = item } tnil Nt = prf
  where postulate prf : Bool (le-TreeItem nil item)
        {-# ATP prove prf #-}
le-TreeItem-Bool {item = item} (ttip {i} Ni) Nitem = prf
  where postulate prf : Bool (le-TreeItem (tip i) item)
        {-# ATP prove prf le-Bool #-}
le-TreeItem-Bool {item = item} (tnode {t₁} {i} {t₂} Tt₁ Ni Tt₂) Nitem =
  prf (le-TreeItem-Bool Tt₁ Nitem) (le-TreeItem-Bool Tt₂ Nitem)
  where postulate prf : Bool (le-TreeItem t₁ item) →
                        Bool (le-TreeItem t₂ item) →
                        Bool (le-TreeItem (node t₁ i t₂) item)
        {-# ATP prove prf &&-Bool #-}

ordTree-Bool : ∀ {t} → Tree t → Bool (ordTree t)
ordTree-Bool tnil = prf
  where postulate prf : Bool (ordTree nil)
        {-# ATP prove prf #-}

ordTree-Bool (ttip {i} Ni) = prf
  where postulate prf : Bool (ordTree (tip i))
        {-# ATP prove prf #-}

ordTree-Bool (tnode {t₁} {i} {t₂} Tt₁ Ni Tt₂) =
  prf (ordTree-Bool Tt₁) (ordTree-Bool Tt₂)
  where postulate prf : Bool (ordTree t₁) →
                        Bool (ordTree t₂) →
                        Bool (ordTree (node t₁ i t₂))
        {-# ATP prove prf &&-Bool le-TreeItem-Bool le-ItemTree-Bool #-}


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

module Generalize where

data _≡_ {ℓ}{A : Set ℓ} (x : A) : A → Set ℓ where
  refl : x ≡ x

infix 4 _≡_

{-# BUILTIN REWRITE _≡_ #-}

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

postulate   Con     :                       Set
postulate   Ty      : (Γ : Con) →           Set
postulate   Tms     : (Γ Δ : Con) →         Set
postulate   Tm      : (Γ : Con)(A : Ty Γ) → Set

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

variable    {Γ Δ Θ} :              Con
postulate   •       :              Con       -- • is \bub
postulate   _▹_     : ∀ Γ → Ty Γ → Con       -- ▹ is \tw2
infixl 5    _▹_

variable    {A B C} :                  Ty _
postulate   _∘ᵀ_    : Ty Δ → Tms Γ Δ → Ty Γ
infixl 6    _∘ᵀ_

variable    {σ δ ν} :                                 Tms _ _
postulate   _∘_     : Tms Θ Δ → Tms Γ Θ →             Tms Γ Δ
infixr 7    _∘_
postulate   id      :                                 Tms Γ Γ
postulate   ε       :                                 Tms Γ •
postulate   _,_     : (σ : Tms Γ Δ) → Tm Γ (A ∘ᵀ σ) → Tms Γ (Δ ▹ A)
infixl 5    _,_
postulate   π₁      : Tms Γ (Δ ▹ A) →                 Tms Γ Δ

variable    {t u v} :                          Tm _ _
postulate   π₂      : (σ : Tms Γ (Δ ▹ A)) →    Tm Γ (A ∘ᵀ π₁ σ)
postulate   _∘ᵗ_    : Tm Δ A → (σ : Tms Γ Δ) → Tm Γ (A ∘ᵀ σ)
infixl 6    _∘ᵗ_

postulate   ass     :   (σ ∘ δ) ∘ ν ≡ σ ∘ δ ∘ ν
{-# REWRITE ass #-}
postulate   idl     :        id ∘ δ ≡ δ
{-# REWRITE idl #-}
postulate   idr     :        δ ∘ id ≡ δ
{-# REWRITE idr #-}
postulate   εη      :             δ ≡ ε  -- can't rewrite, so we specialize this in the next two cases
postulate   εηid    :            id ≡ ε
{-# REWRITE εηid #-}
postulate   εη∘     :         ε ∘ δ ≡ ε
{-# REWRITE εη∘ #-}
postulate   ,β₁     :    π₁ (δ , t) ≡ δ
{-# REWRITE ,β₁ #-}
postulate   ,β₂     :    π₂ (δ , t) ≡ t
{-# REWRITE ,β₂ #-}
postulate   ,η      : (π₁ δ , π₂ δ) ≡ δ
{-# REWRITE ,η #-}
postulate   [id]ᵀ   :       A ∘ᵀ id ≡ A
{-# REWRITE [id]ᵀ #-}
postulate   [∘]ᵀ    :   A ∘ᵀ δ ∘ᵀ σ ≡ A ∘ᵀ δ ∘ σ
{-# REWRITE [∘]ᵀ #-}
postulate   ,∘      :   (δ , t) ∘ σ ≡ δ ∘ σ , t ∘ᵗ σ
{-# REWRITE ,∘ #-}

postulate   [∘]ᵗ    :   t ∘ᵗ σ ∘ᵗ δ ≡ t ∘ᵗ σ ∘ δ
{-# REWRITE [∘]ᵗ #-}
postulate   π₁∘     :      π₁ δ ∘ σ ≡ π₁ (δ ∘ σ)
{-# REWRITE π₁∘ #-}
postulate   π₂∘     :     π₂ δ ∘ᵗ σ ≡ π₂ (δ ∘ σ)
{-# REWRITE π₂∘ #-}
postulate   ∘id     :       t ∘ᵗ id ≡ t
{-# REWRITE ∘id #-}

_↑_ : ∀ σ A → Tms (Γ ▹ A ∘ᵀ σ) (Δ ▹ A)
σ ↑ A = σ ∘ π₁ id , π₂ id

⟨_⟩ : Tm Γ A → Tms Γ (Γ ▹ A)
⟨ t ⟩ = id , t

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

postulate   U       : Ty Γ
variable    {a b c} : Tm _ U
postulate   El      : Tm Γ U → Ty Γ
postulate   U[]     : U ∘ᵀ σ ≡ U
{-# REWRITE U[] #-}
postulate   El[]    : El a ∘ᵀ σ ≡ El (a ∘ᵗ σ)
{-# REWRITE El[] #-}

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

postulate   Π       : (a : Tm Γ U) → Ty (Γ ▹ El a) → Ty Γ
postulate   Π[]     : Π a B ∘ᵀ σ ≡ Π (a ∘ᵗ σ) (B ∘ᵀ σ ↑ El a)
{-# REWRITE Π[] #-}
postulate   app     : Tm Γ (Π a B) → Tm (Γ ▹ El a) B
postulate   app[]   : app t ∘ᵗ (σ ↑ El a) ≡ app (t ∘ᵗ σ)
{-# REWRITE app[] #-}


------------------------------------------------------------------------
-- Some code suggesting that types used in "programs" might not
-- necessarily be sets
------------------------------------------------------------------------

-- If lenses are only used in programs, and types used in programs are
-- always sets, then higher lenses might be pointless.

-- This module uses univalence without tracking such uses in the types
-- of functions.

{-# OPTIONS --cubical #-}

open import Equality.Path as P hiding (Is-proposition; Is-set)

module README.Not-a-set
  {e⁺} (eq : ∀ {a p} → Equality-with-paths a p e⁺) where

private
  open module D = Derived-definitions-and-properties eq
    using (Is-proposition; Is-set)

open import Equality.Path.Univalence
open import Prelude

open import Bijection equality-with-J as Bijection using (_↔_)
import Bijection D.equality-with-J as DB
import Bool equality-with-J as B
open import Equality.Decision-procedures equality-with-J
import Equality.Path.Isomorphisms eq as I
open import Equivalence equality-with-J as Eq using (_≃_)
open import Function-universe equality-with-J as F hiding (id; _∘_)
import H-level D.equality-with-J as H-level
open import H-level.Closure D.equality-with-J
open import Surjection D.equality-with-J using (_↠_)

private
  variable
    A B C : Type

------------------------------------------------------------------------
-- Dynamic types

-- Values of arbitrary type that can be turned into strings.

Printable : Type₁
Printable = ∃ λ (A : Type) → A × (A → String)

-- Printable is not a set.

¬-Printable-set : ¬ Is-set Printable
¬-Printable-set =
  Is-set Printable        ↝⟨ DB._↔_.to (I.H-level↔H-level 2) ⟩
  P.Is-set Printable      ↝⟨ (λ h → h _ _) ⟩
  refl ≡ q                ↝⟨ cong (cong proj₁) ⟩
  refl ≡ cong proj₁ q     ↝⟨ flip trans (proj₁-Σ-≡,≡→≡ {B = λ A → A × (A → String)} {y₁ = proj₂ x} _ refl) ⟩
  refl ≡ q′               ↝⟨ cong (λ eq → subst id eq (just true)) ⟩
  just true ≡ just false  ↝⟨ Bool.true≢false ∘ ⊎.cancel-inj₂ ⟩□
  ⊥                       □
  where
  x : Printable
  x = Maybe Bool , nothing , λ _ → ""

  q′ : Maybe Bool ≡ Maybe Bool
  q′ = ≃⇒≡ (F.id ⊎-cong Eq.↔⇒≃ B.swap)

  q : x ≡ x
  q = Σ-≡,≡→≡ q′ refl

------------------------------------------------------------------------
-- Streams

-- Streams, based on the definition given by Coutts et al. in "Stream
-- Fusion: From Lists to Streams to Nothing at All".

data Step (A S : Type) : Type where
  done  : Step A S
  yield : A → S → Step A S
  skip  : S → Step A S

Stream : Type → Type₁
Stream A = ∃ λ (S : Type) → (S → Step A S) × S

-- Stream A is not a set.

¬-Stream-set : ¬ Is-set (Stream A)
¬-Stream-set {A = A} =
  Is-set (Stream A)       ↝⟨ DB._↔_.to (I.H-level↔H-level 2) ⟩
  P.Is-set (Stream A)     ↝⟨ (λ h → h _ _) ⟩
  refl ≡ p                ↝⟨ cong (cong proj₁) ⟩
  refl ≡ cong proj₁ p     ↝⟨ flip trans (proj₁-Σ-≡,≡→≡ {B = F} {y₁ = proj₂ t} _ refl) ⟩
  refl ≡ q                ↝⟨ cong (λ eq → subst id eq (just true)) ⟩
  just true ≡ just false  ↝⟨ Bool.true≢false ∘ ⊎.cancel-inj₂ ⟩□
  ⊥                       □
  where
  F : Type → Type
  F S = (S → Step A S) × S

  t : Stream A
  t = Maybe Bool
    , const done
    , nothing

  q : Maybe Bool ≡ Maybe Bool
  q = ≃⇒≡ (F.id ⊎-cong Eq.↔⇒≃ B.swap)

  p : t ≡ t
  p = Σ-≡,≡→≡ q refl

-- Streams, with the added requirement that the state type must be a
-- set.

Streamˢ : Type → Type₁
Streamˢ A = ∃ λ (S : Type) → Is-set S × (S → Step A S) × S

-- Streamˢ A is not a set.

¬-Streamˢ-set : ¬ Is-set (Streamˢ A)
¬-Streamˢ-set {A = A} =
  Is-set (Streamˢ A)      ↝⟨ DB._↔_.to (I.H-level↔H-level 2) ⟩
  P.Is-set (Streamˢ A)    ↝⟨ (λ h → h _ _) ⟩
  refl ≡ p                ↝⟨ cong (cong proj₁) ⟩
  refl ≡ cong proj₁ p     ↝⟨ flip trans (proj₁-Σ-≡,≡→≡ {B = F} {y₁ = proj₂ t} _ refl) ⟩
  refl ≡ q                ↝⟨ cong (λ eq → subst id eq (inj₂ true)) ⟩
  just true ≡ just false  ↝⟨ Bool.true≢false ∘ ⊎.cancel-inj₂ ⟩□
  ⊥                       □
  where
  F : Type → Type
  F S = Is-set S × (S → Step A S) × S

  t : Streamˢ A
  t = Maybe Bool
    , Maybe-closure 0 Bool-set
    , const done
    , nothing

  q : Maybe Bool ≡ Maybe Bool
  q = ≃⇒≡ (F.id ⊎-cong Eq.↔⇒≃ B.swap)

  p : t ≡ t
  p =
    Σ-≡,≡→≡ q $
    cong₂ _,_
      (DB._↔_.to D.≡↔≡ (H-level-propositional I.ext 2 _ _))
      refl

------------------------------------------------------------------------
-- Some deep embeddings

-- The module is parametrised by a predicate P that satisfies some
-- properties.

module Tm-with-predicate
  (P : Type → Type)
  (P-Maybe-Bool : P (Maybe Bool))
  (P-Maybe-Bool-propositional : Is-proposition (P (Maybe Bool)))
  where

  -- A deep embedding of a simple programming language. Note the
  -- requirement that P B must hold.

  data Tm (A : Type) : Type₁ where
    literal : A → Tm A
    map     : {B : Type} → P B → Tm (B → A) → Tm B → Tm A

  -- An unfolding lemma.

  Tm≃ : Tm A ≃ (A ⊎ ∃ λ (B : Type) → P B × Tm (B → A) × Tm B)
  Tm≃ = Eq.↔→≃
    (λ where
       (literal x) → inj₁ x
       (map p f t) → inj₂ (_ , p , f , t))
    [ literal , (λ (_ , p , f , t) → map p f t) ]
    [ (λ _ → refl) , (λ _ → refl) ]
    (λ where
       (literal _) → refl
       (map _ _ _) → refl)

  -- If A is inhabited, then Tm A is not a set.

  ¬-Tm-set : A → ¬ Is-set (Tm A)
  ¬-Tm-set {A = A} a =
    Is-set (Tm A)           ↝⟨ DB._↔_.to (I.H-level↔H-level 2) ⟩
    P.Is-set (Tm A)         ↝⟨ (λ h → h _ _) ⟩
    refl ≡ p                ↝⟨ cong map-injective ⟩
    refl ≡ map-injective p  ↝⟨ flip trans lemma ⟩
    refl ≡ p₁               ↝⟨ cong (λ eq → subst id eq (just true)) ⟩
    just true ≡ just false  ↝⟨ Bool.true≢false ∘ ⊎.cancel-inj₂ ⟩□
    ⊥                       □
    where
    F : Type → Type₁
    F B = P B × Tm (B → A) × Tm B

    t : Tm A
    t = map P-Maybe-Bool (literal λ _ → a) (literal nothing)

    t′ : F (Maybe Bool)
    t′ = P-Maybe-Bool
       , literal (const a)
       , literal nothing

    p₁ : Maybe Bool ≡ Maybe Bool
    p₁ = ≃⇒≡ (F.id ⊎-cong Eq.↔⇒≃ B.swap)

    p₂ : subst F p₁ t′ ≡ t′
    p₂ =
      cong₂ _,_
        (DB._↔_.to (I.H-level↔H-level 1) P-Maybe-Bool-propositional _ _)
        (cong (_, literal nothing)
           (subst (λ B → Tm (B → A)) p₁ (literal (const a))  ≡⟨⟩
            literal (subst (λ B → B → A) p₁ (const a))       ≡⟨ (cong literal $ ⟨ext⟩ λ b → subst-→-domain id p₁ {u = b}) ⟩∎
            literal (const a)                                ∎))

    p : t ≡ t
    p = _≃_.to (Eq.≃-≡ Tm≃) $ cong inj₂ $ Σ-≡,≡→≡ p₁ p₂

    map-injective :
      {p : P B} {f : Tm (B → C)} {t : Tm B} →
      map p f t ≡ map p f t → B ≡ B
    map-injective {B = B} {p = p} {f = f} {t = t} =
      map p f t ≡ map p f t                            ↔⟨ inverse $ Eq.≃-≡ Tm≃ ⟩
      _≃_.to Tm≃ (map p f t) ≡ _≃_.to Tm≃ (map p f t)  ↔⟨⟩
      inj₂ (B , p , f , t) ≡ inj₂ (B , p , f , t)      ↔⟨ inverse Bijection.≡↔inj₂≡inj₂ ⟩
      (B , p , f , t) ≡ (B , p , f , t)                ↝⟨ cong proj₁ ⟩□
      B ≡ B                                            □

    lemma : map-injective p ≡ p₁
    lemma =
      map-injective p                                ≡⟨⟩

      cong proj₁ (⊎.cancel-inj₂
        (_≃_.from (Eq.≃-≡ Tm≃) (_≃_.to (Eq.≃-≡ Tm≃)
           (cong inj₂ (Σ-≡,≡→≡ p₁ p₂)))))            ≡⟨ cong (cong proj₁ ∘ ⊎.cancel-inj₂) $
                                                        _≃_.left-inverse-of (Eq.≃-≡ Tm≃) (cong inj₂ (Σ-≡,≡→≡ p₁ p₂)) ⟩
      cong (proj₁ {B = F})
        (⊎.cancel-inj₂ {A = ⊤ ⊎ ⊤} (cong inj₂
           (Σ-≡,≡→≡ {p₁ = _ , t′} p₁ p₂)))           ≡⟨ cong (cong (proj₁ {B = F})) $
                                                        _↔_.left-inverse-of (Bijection.≡↔inj₂≡inj₂ {A = ⊤ ⊎ ⊤}) (Σ-≡,≡→≡ {p₁ = _ , t′} _ refl) ⟩
      cong (proj₁ {B = F})
        (Σ-≡,≡→≡ {p₁ = _ , t′} p₁ p₂)                ≡⟨ proj₁-Σ-≡,≡→≡ {B = F} {y₁ = t′} _ refl ⟩∎

      p₁                                             ∎

-- A deep embedding of a simple programming language.

data Tm (A : Type) : Type₁ where
  literal : A → Tm A
  map     : {B : Type} → Tm (B → A) → Tm B → Tm A

-- If A is inhabited, then Tm A is not a set.

¬-Tm-set : A → ¬ Is-set (Tm A)
¬-Tm-set {A = A} a =
  Is-set (Tm A)    ↝⟨ H-level.respects-surjection Tm↠Tm 2 ⟩
  Is-set (T.Tm A)  ↝⟨ T.¬-Tm-set a ⟩□
  ⊥                □
  where
  module T = Tm-with-predicate (λ _ → ⊤) _ (λ _ _ → D.refl _)

  to : Tm B → T.Tm B
  to (literal x) = T.literal x
  to (map f t)   = T.map _ (to f) (to t)

  from : T.Tm B → Tm B
  from (T.literal x) = literal x
  from (T.map _ f t) = map (from f) (from t)

  to-from : (t : T.Tm B) → to (from t) D.≡ t
  to-from (T.literal x) = D.refl _
  to-from (T.map _ f t) = D.cong₂ (T.map _) (to-from f) (to-from t)

  Tm↠Tm : Tm B ↠ T.Tm B
  Tm↠Tm = record
    { logical-equivalence = record
      { to   = to
      ; from = from
      }
    ; right-inverse-of = to-from
    }

-- A deep embedding of a simple programming language. Note the
-- requirement that "B" must be a set.

data Tmˢ (A : Type) : Type₁ where
  literal : A → Tmˢ A
  map     : {B : Type} → Is-set B → Tmˢ (B → A) → Tmˢ B → Tmˢ A

-- If A is inhabited, then Tmˢ A is not a set.

¬-Tmˢ-set : A → ¬ Is-set (Tmˢ A)
¬-Tmˢ-set {A = A} a =
  Is-set (Tmˢ A)   ↝⟨ H-level.respects-surjection Tmˢ↠Tm 2 ⟩
  Is-set (T.Tm A)  ↝⟨ T.¬-Tm-set a ⟩□
  ⊥                □
  where
  module T = Tm-with-predicate
    Is-set
    (Maybe-closure 0 Bool-set)
    (H-level-propositional I.ext 2)

  to : Tmˢ B → T.Tm B
  to (literal x) = T.literal x
  to (map s f t) = T.map s (to f) (to t)

  from : T.Tm B → Tmˢ B
  from (T.literal x) = literal x
  from (T.map s f t) = map s (from f) (from t)

  to-from : (t : T.Tm B) → to (from t) D.≡ t
  to-from (T.literal x) = D.refl _
  to-from (T.map s f t) = D.cong₂ (T.map s) (to-from f) (to-from t)

  Tmˢ↠Tm : Tmˢ B ↠ T.Tm B
  Tmˢ↠Tm = record
    { logical-equivalence = record
      { to   = to
      ; from = from
      }
    ; right-inverse-of = to-from
    }


module Luau.Run where

open import Agda.Builtin.Equality using (_≡_; refl)
open import Luau.Heap using (Heap; ∅)
open import Luau.Syntax using (Block; return; _∙_; done)
open import Luau.OpSem using (_⊢_⟶*_⊣_; refl; step)
open import Luau.Value using (val)
open import Properties.Step using (stepᴮ; step; return; done; error)
open import Luau.RuntimeError using (RuntimeErrorᴮ)

data RunResult {a} (H : Heap a) (B : Block a) : Set where
  return : ∀ V {B′ H′} → (H ⊢ B ⟶* (return (val V) ∙ B′) ⊣ H′) → RunResult H B
  done : ∀ {H′} → (H ⊢ B ⟶* done ⊣ H′) → RunResult H B
  error : ∀ {B′ H′} → (RuntimeErrorᴮ H′ B′) → (H ⊢ B ⟶* B′ ⊣ H′) → RunResult H B

{-# TERMINATING #-}
run′ : ∀ {a} H B → RunResult {a} H B
run′ H B with stepᴮ H B
run′ H B | step H′ B′ D with run′ H′ B′
run′ H B | step H′ B′ D | return V D′  = return V (step D D′)
run′ H B | step H′ B′ D | done D′ = done (step D D′)
run′ H B | step H′ B′ D | error E D′ = error E (step D D′)
run′ H _ | return V refl = return V refl
run′ H _ | done refl = done refl
run′ H B | error E = error E refl

run : ∀ {a} B → RunResult {a} ∅ B
run = run′ ∅


{-# OPTIONS --allow-unsolved-metas #-}
module ExtractFunction where
open import Agda.Builtin.Nat
open import Agda.Builtin.Bool

plus : Nat -> Nat -> Nat
plus = {!   !}

function1 : (x : Nat) -> (y : Nat) -> Nat
function1 x y = plus x y

pickTheFirst :  Nat -> Bool -> Nat
pickTheFirst x y = x

function2 :  Nat -> Bool -> Nat
function2 x y = pickTheFirst x y


-- Reasoning with both a strict and non-strict relation.
{-# OPTIONS --cubical --no-import-sorts --safe #-}

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

module Cubical.Relation.Binary.Reasoning.Base.Double {a ℓ₁ ℓ₂} {A : Type a}
  {_≤_ : RawRel A ℓ₁} {_<_ : RawRel A ℓ₂}
  (≤-isPreorder : IsPreorder _≤_)
  (<-transitive : Transitive _<_) (<⇒≤ : _<_ ⇒ _≤_)
  (<-≤-transitive : Trans _<_ _≤_ _<_) (≤-<-transitive : Trans _≤_ _<_ _<_)
  where

open import Cubical.Foundations.Prelude

open import Cubical.Data.Prod using (proj₁; proj₂)
open import Cubical.Foundations.Function using (case_of_; id)
open import Cubical.Relation.Nullary using (Dec; yes; no; IsYes; toWitness)

open IsPreorder ≤-isPreorder
  renaming
  ( reflexive  to ≤-reflexive
  ; transitive to ≤-transitive
  )

------------------------------------------------------------------------
-- A datatype to abstract over the current relation

infix 4 _IsRelatedTo_

data _IsRelatedTo_ (x y : A) : Type (ℓ-max a (ℓ-max ℓ₁ ℓ₂)) where
  strict    : (x<y : x < y) → x IsRelatedTo y
  nonstrict : (x≤y : x ≤ y) → x IsRelatedTo y

------------------------------------------------------------------------
-- Types that are used to ensure that the final relation proved by the
-- chain of reasoning can be converted into the required relation.

data IsStrict {x y} : x IsRelatedTo y → Type (ℓ-max a (ℓ-max ℓ₁ ℓ₂)) where
  isStrict : ∀ x<y → IsStrict (strict x<y)

IsStrict? : ∀ {x y} (x≲y : x IsRelatedTo y) → Dec (IsStrict x≲y)
IsStrict? (strict    x<y) = yes (isStrict x<y)
IsStrict? (nonstrict _)   = no λ()

extractStrict : ∀ {x y} {x≲y : x IsRelatedTo y} → IsStrict x≲y → x < y
extractStrict (isStrict x<y) = x<y

------------------------------------------------------------------------
-- Reasoning combinators

infix  0 begin_ begin-strict_
infixr 1 _<⟨_⟩_ _≤⟨_⟩_ _≡⟨_⟩_ _≡˘⟨_⟩_ _≡⟨⟩_
infix  2 _∎

-- Beginnings of various types of proofs

begin_ : ∀ {x y} → x IsRelatedTo y → x ≤ y
begin strict    x<y = <⇒≤ x<y
begin nonstrict x≤y = x≤y

begin-strict_ : ∀ {x y} (r : x IsRelatedTo y) → {s : IsYes (IsStrict? r)} → x < y
begin-strict_ r {s} = extractStrict (toWitness s)

-- Step with the strict relation

_<⟨_⟩_ : ∀ (x : A) {y z} → x < y → y IsRelatedTo z → x IsRelatedTo z
x <⟨ x<y ⟩ strict    y<z = strict (<-transitive x<y y<z)
x <⟨ x<y ⟩ nonstrict y≤z = strict (<-≤-transitive x<y y≤z)

-- Step with the non-strict relation

_≤⟨_⟩_ : ∀ (x : A) {y z} → x ≤ y → y IsRelatedTo z → x IsRelatedTo z
x ≤⟨ x≤y ⟩ strict    y<z = strict    (≤-<-transitive x≤y y<z)
x ≤⟨ x≤y ⟩ nonstrict y≤z = nonstrict (≤-transitive x≤y y≤z)

-- Step with non-trivial propositional equality

_≡⟨_⟩_ : ∀ (x : A) {y z} → x ≡ y → y IsRelatedTo z → x IsRelatedTo z
_≡⟨_⟩_ x {_} {z} x≡y y≲z = J (λ w _ → w IsRelatedTo z) y≲z (sym x≡y)

-- Flipped step with non-trivial propositional equality

_≡˘⟨_⟩_ : ∀ x {y z} → y ≡ x → y IsRelatedTo z → x IsRelatedTo z
x ≡˘⟨ y≡x ⟩ y≲z = x ≡⟨ sym y≡x ⟩ y≲z

-- Step with trivial propositional equality

_≡⟨⟩_ : ∀ (x : A) {y} → x IsRelatedTo y → x IsRelatedTo y
x ≡⟨⟩ x≲y = x≲y

-- Syntax for path definition

≡⟨⟩-syntax : ∀ x {y z : A} → x ≡ y → y IsRelatedTo z → x IsRelatedTo z
≡⟨⟩-syntax = _≡⟨_⟩_
infixr 1 ≡⟨⟩-syntax
syntax ≡⟨⟩-syntax x (λ i → B) y = x ≡[ i ]⟨ B ⟩ y

≡˘⟨⟩-syntax : ∀ x {y z : A} → y ≡ x → y IsRelatedTo z → x IsRelatedTo z
≡˘⟨⟩-syntax = _≡˘⟨_⟩_
infixr 1 ≡˘⟨⟩-syntax
syntax ≡˘⟨⟩-syntax x (λ i → B) y = x ≡˘[ i ]⟨ B ⟩ y

-- Termination step

_∎ : ∀ x → x IsRelatedTo x
x ∎ = nonstrict ≤-reflexive


-- Andreas, May-July 2016, implementing postfix projections

{-# OPTIONS --postfix-projections #-}

open import Common.Product
open import Common.Bool

pair : ∀{A : Set}(a : A) → A × A
pair a = {!!} -- C-c C-c here outputs postfix projections

record BoolFun : Set where
  field out : Bool → Bool
open BoolFun

neg : BoolFun
neg .out x = {!x!} -- splitting here should preserve postfix proj

neg2 : BoolFun
out neg2 x = {!x!} -- splitting here should preserve prefix proj

module ExtendedLambda where

  neg3 : BoolFun
  neg3 = λ{ .out → {!!} }

  pair2 : ∀{A : Set}(a : A) → A × A
  pair2 = λ{ a → {!!} }

  neg4 : BoolFun
  neg4 = λ{ .out b → {!b!} }

-- DOES NOT WORK DUE TO ISSUE #2020

-- module LambdaWhere where

--   neg3 : BoolFun
--   neg3 = λ where
--     .out → {!!} -- splitting on result here crashes

--   pair2 : ∀{A : Set}(a : A) → A × A
--   pair2 = λ where
--     a → {!!}

--   extlam-where : Bool → Bool
--   extlam-where = λ where
--     b → {!b!}

-- -- extlam : Bool → Bool
-- -- extlam = λ
-- --   { b → {!b!}
-- --   }


module GUIgeneric.GUIFeaturesPart4 where

open import GUIgeneric.Prelude renaming (addButton to addButton')

open import GUIgeneric.GUIDefinitions renaming (add to add'; add' to add)
open import GUIgeneric.GUI
open import GUIgeneric.GUIExampleLib
open import StateSizedIO.GUI.WxGraphicsLibLevel3 renaming (addButton to addButton')
open import GUIgeneric.GUIFeatures
open import GUIgeneric.GUIFeaturesPart2 hiding ( main )
open import GUIgeneric.GUIFeaturesPart3 hiding ( main )
open import GUIgeneric.GUIExample hiding (main )

open import Data.Product
open import Data.Fin

addStateFMachine  : {BaseState : Set}
                          (vm : FMachine BaseState)
                          (Snew : Set)
                          (newSM : (s : Snew) →
                            SMachineState (BaseState ⊎ vm .AddStateF ⊎ Snew) (inj₂ (inj₂ s)))
                         → FMachine BaseState
addStateFMachine {BaseState} vm Snew newSM .Features = vm .Features
addStateFMachine {BaseState} vm Snew newSM .AddStateF = vm .AddStateF ⊎ Snew
addStateFMachine {BaseState} vm Snew newSM .GUIF f (inj₁ s) =
                mapFMachineHandle (inj₁ s) (vm .GUIF f (inj₁ s))
addStateFMachine {BaseState} vm Snew newSM .GUIF f (inj₂ (inj₁ s)) =
                mapFMachineHandle (inj₂ s) (vm .GUIF f (inj₂ s))
addStateFMachine {BaseState} vm Snew newSM .GUIF f (inj₂ (inj₂ s)) .fSM = newSM s .fSM
addStateFMachine {BaseState} vm Snew newSM .GUIF f (inj₂ (inj₂ s)) .propSM = newSM s .propSM
addStateFMachine {BaseState} vm Snew newSM .GUIF f (inj₂ (inj₂ s)) .handlSM = newSM s .handlSM

addOneStateFMachine  : {BaseState : Set}
                          (vm : FMachine BaseState)
                          (newSM : SMachineState (BaseState ⊎ vm .AddStateF ⊎ ⊤) (inj₂ (inj₂ _)))
                         → FMachine BaseState
addOneStateFMachine vm newSM = addStateFMachine vm ⊤ λ _ → newSM

addDummyFeatures  : {BaseState : Set}
                                  (vm : FMachine BaseState)
                                  (FeatureNew : Set)
                                   → FMachine BaseState
addDummyFeatures vm FeatureNew .Features = vm .Features × FeatureNew
addDummyFeatures vm FeatureNew .AddStateF = vm .AddStateF
addDummyFeatures vm FeatureNew .GUIF (f , _) s = vm .GUIF f s

{- handler for the new state to be added to the cancel machine -}
cancelNewStateSM : (vm : FMachine StateV) →
                    SMachineState (StateV ⊎ vm .AddStateF ⊎ ⊤) (inj₂ (inj₂ tt))
cancelNewStateSM vm = simpleSMState "Intermediate" (inj₁ s0)

{- add the state to the old feature machine -}
cancelStateAdded : FMachine StateV → FMachine StateV
cancelStateAdded vm = addOneStateFMachine vm (cancelNewStateSM vm)

{- add a dummy feature "FeatureCancel" to the feature machine -}
cancelFeatureAdded : FMachine StateV → FMachine StateV
cancelFeatureAdded vm = addDummyFeatures
                         (cancelStateAdded vm)
                         FeatureCancel

{- redefine in the feature machine one button -}
Cancel' : FMachine StateV → FMachine StateV
Cancel' vm .Features = cancelFeatureAdded vm .Features
Cancel' vm .AddStateF  = cancelFeatureAdded vm .AddStateF
Cancel' vm .GUIF (f , yesCancel) (inj₁ s1) =
      addBtn2StateMachine (cancelFeatureAdded vm .GUIF (f , yesCancel) (inj₁ s1))
                          "Cancel" (inj₂ (inj₂ _))
Cancel' vm .GUIF f  s = cancelFeatureAdded vm .GUIF f s

main : NativeIO Unit
main = compileFeatureVM (Cancel' baseF) (_ , yesCancel) (inj₁ s0) --


open import Agda.Builtin.Equality

record Box (B : Set) : Set₁ where
  constructor box
  field
    unbox   : B

-- here: .unbox is a valid forced pattern

=box : {B : Set} {Γ₀ Γ₁ : Box B} → Box.unbox Γ₀ ≡ Box.unbox Γ₁ → Γ₀ ≡ Γ₁
=box {Γ₀ = box unbox} {box r} p = ?

open Box public

-- here: .unbox is now the name of a projection and should therefore
-- not be generated

=box' : {B : Set} {Γ₀ Γ₁ : Box B} → unbox Γ₀ ≡ unbox Γ₁ → Γ₀ ≡ Γ₁
=box' {Γ₀ = box unbox} {box r} p = ?


-- Partly based on code due to Andrea Vezzosi.

open import Common.Prelude

data D : Set where
  run-time        : Bool → D
  @0 compile-time : Bool → D

f : D → @0 D → Bool
f (run-time x)     _                = x
f (compile-time x) (run-time y)     = x
f (compile-time x) (compile-time y) = y

main : IO Unit
main =
  putStrLn (if f (run-time true) (compile-time false)
            then "ok" else "bad")


-- Andreas, 2020-02-06, issue #906, and #942 #2068 #3136 #3431 #4391 #4418
--
-- Termination checker now tries to reduce calls away
-- using non-recursive clauses.
--
-- This fixes the problem that for dependent copattern definitions
-- the earlier, non-recursive clauses get into non-guarded positions
-- in later clauses via Agda's constraint solver, and there confuse
-- the termination checker.

module Issue906EtAl where

module Issue906 where

  {- Globular types as a coinductive record -}
  record Glob : Set1 where
    coinductive
    field
      Ob : Set
      Hom : (a b : Ob) → Glob
  open Glob

  record Unit : Set where

  data _==_ {A : Set} (a : A) : A → Set where
    refl : a == a

  {- The terminal globular type -}
  Unit-glob : Glob
  Ob Unit-glob = Unit
  Hom Unit-glob _ _ = Unit-glob

  {- The tower of identity types -}
  Id-glob : (A : Set) → Glob
  Ob (Id-glob A) = A
  Hom (Id-glob A) a b = Id-glob (a == b)

module Issue907 where

  data _==_ {A : Set} (a : A) : A → Set where
    idp : a == a

  -- Coinductive equivalences
  record CoEq (A B : Set) : Set where
    coinductive
    constructor coEq
    field to : A → B
          from : B → A
          eq : (a : A) (b : B) → CoEq (a == from b) (to a == b)

  open CoEq public

  id-CoEq : (A : Set) → CoEq A A
  to   (id-CoEq A) a   = a
  from (id-CoEq A) b   = b
  eq   (id-CoEq A) a b = id-CoEq _ -- Keep underscore!
    -- Solution: (a == from (id-CoEq A) b)
    -- contains recursive call

module Issue942 where

  record Sigma (A : Set)(P : A → Set) : Set where
    constructor _,_
    field
      fst : A
      snd : P fst
  open Sigma

  postulate
    A : Set
    x : A
    P Q : A → Set
    Px : P x
    f  : ∀ {x} → P x → Q x

  ex : Sigma A Q
  ex = record
         { fst = x
         ; snd = f Px -- goal: P x
         }

  ex' : Sigma A Q
  ex' = x , f Px -- goal: P x

  ex'' : Sigma A Q
  fst ex'' = x
  snd ex'' = f Px -- goal: P (fst ex'')

module Issue2068-OP where

  data _==_ {A : Set} : A → A → Set where
    refl : {a : A} → a == a

  data Bool : Set where
    tt : Bool
    ff : Bool

  record TwoEqualFunctions : Set₁ where
    field
      A : Set
      B : Set
      f : A → B
      g : A → B
      p : f == g

  postulate
    funext : {A B : Set} {f g : A → B} → ((a : A) → f a == g a) → f == g

  identities : TwoEqualFunctions
  TwoEqualFunctions.A identities = Bool
  TwoEqualFunctions.B identities = Bool
  TwoEqualFunctions.f identities x = x
  TwoEqualFunctions.g identities = λ{tt → tt ; ff → ff}
  TwoEqualFunctions.p identities = funext (λ{tt → refl ; ff → refl})

module Issue2068b where

  data _==_ {A : Set} : (a : A) → A → Set where
    refl : (a : A) → a == a

  data Unit : Set where
    unit : Unit

  record R : Set₁ where
    field
      f : Unit → Unit
      p : f == λ x → x

  postulate
    extId : (f : Unit → Unit) → (∀ a → f a == a) → f == λ x → x

  test : R
  R.f test = λ{ unit → unit }
  R.p test = extId _ λ{ unit → refl _ }
  -- R.p test = extId {! R.f test !} λ{unit → refl {! R.f test unit !}}

module Issue2068c where

  record _×_ (A B : Set) : Set where
    field fst : A
          snd : B
  open _×_

  test : ∀{A} (a : A) → (A → A) × (A → A)
  fst (test a) x = a
  snd (test a) x = fst (test a) (snd (test a) x)

module Issue3136 (A : Set) where

  -- Andreas, 2018-07-22, issue #3136
  -- WAS: Internal error when printing termination errors

  postulate
    any : {X : Set} → X
    x : A
    P : A → Set

  record C : Set where
    field
      a : A
      b : P a

  c : C
  c = λ where
    .C.a → x
    .C.b → λ where
      → any

  -- NOW: succeeds

module Issue3413 where

  open import Agda.Builtin.Sigma
  open import Agda.Builtin.Equality

  postulate
    A : Set
    P : ∀{X : Set} → X → Set

  record Bob : Set₁ where
    field
      RE : Set
      resp : RE → Set

  open Bob

  bob : Bob
  bob .RE     = A
  bob .resp e = Σ (P e) λ {x → A}

module Issue4391 where

  record GlobSet : Set₁ where
    coinductive
    field
      cells : Set
      morphisms : cells → cells → GlobSet

  open GlobSet public

  record GlobSetMorphism (G H : GlobSet) : Set where
    coinductive
    field
      func : cells G → cells H
      funcMorphisms : (x y : cells G)
                    → GlobSetMorphism (morphisms G x y)
                                      (morphisms H (func x) (func y))

  open GlobSetMorphism public

  gComp : {G H I : GlobSet} → GlobSetMorphism H I → GlobSetMorphism G H → GlobSetMorphism G I
  func (gComp ϕ ψ) x = func ϕ (func ψ x)
  funcMorphisms (gComp ϕ ψ) x y = gComp (funcMorphisms ϕ (func ψ x) (func ψ y)) (funcMorphisms ψ x y)

module Issue4391Nisse where

  record GlobSet : Set₁ where
    coinductive
    field
      cells     : Set
      morphisms : cells → cells → GlobSet

  open GlobSet public

  mutual

    record GlobSetMorphism (G H : GlobSet) : Set where
      inductive
      field
        func          : cells G → cells H
        funcMorphisms : (x y : cells G) →
                        GlobSetMorphism′
                          (morphisms G x y)
                          (morphisms H (func x) (func y))

    record GlobSetMorphism′ (G H : GlobSet) : Set where
      coinductive
      field
        force : GlobSetMorphism G H

  open GlobSetMorphism  public
  open GlobSetMorphism′ public

  works fails :
    {G H I : GlobSet} →
    GlobSetMorphism H I → GlobSetMorphism G H → GlobSetMorphism G I

  works ϕ ψ = record
    { func          = λ x → func ϕ (func ψ x)
    ; funcMorphisms = λ { x y .force →
        works (funcMorphisms ϕ (func ψ x) (func ψ y) .force)
              (funcMorphisms ψ x y .force) }
    }

  fails ϕ ψ .func          = λ x → func ϕ (func ψ x)
  fails ϕ ψ .funcMorphisms = λ { x y .force →
    fails (funcMorphisms ϕ (func ψ x) (func ψ y) .force)
          (funcMorphisms ψ x y .force) }

module Issue4418 {l}
  (Index : Set l)
  (Shape : Index → Set l)
  (Position : (i : Index) → Shape i → Set l)
  (index : (i : Index) → (s : Shape i) → Position i s → Index) where

  record M (i : Index) : Set l where
    coinductive
    field shape : Shape i
    field children : (p : Position i shape) → M (index i shape p)

  open M

  record MBase (Rec : Index → Set l) (i : Index) : Set l where
    coinductive
    field shapeB : Shape i
    field childrenB : (p : Position i shapeB) → Rec (index i shapeB p)

  open MBase

  module _ (S : Index → Set l) (u : ∀ {i} → S i → MBase S i) where

    unroll : ∀ i → S i → M i
    unroll i s .shape      = u s .shapeB
    unroll i s .children p = unroll _ (u s .childrenB p)
      -- Underscore solved as:  index i (u s .shapeB) p


{- Formal verification of authenticated append-only skiplists in Agda, version 1.0.

   Copyright (c) 2020 Oracle and/or its affiliates.
   Licensed under the Universal Permissive License v 1.0 as shown at https://opensource.oracle.com/licenses/upl
-}
open import Data.Empty
open import Data.Sum
open import Data.Fin using (Fin; toℕ ; fromℕ ; fromℕ≤)
open import Data.Fin.Properties using (toℕ<n; toℕ-injective)
open import Data.Nat renaming (_≟_ to _≟ℕ_; _≤?_ to _≤?ℕ_)
open import Data.Nat.Properties
open import Data.List renaming (map to List-map)
open import Data.List.Relation.Unary.Any
open import Function
open import Relation.Binary.PropositionalEquality
open import Relation.Nullary

-- This module pulls in the definitions from AAOSL.Hops and uses
-- them to construct a DepRel based on the dependency relation
-- defined there, showing that this concrete AAOSL enjoys the
-- properties we have proved for abstract ones

module AAOSL.Concrete where

 open import Data.Nat.Even
 open import Data.Nat.Encode
 open import AAOSL.Lemmas
 open import AAOSL.Hops
 open import AAOSL.Abstract.Hash
 open import AAOSL.Abstract.DepRel

 ---------------------------------------------------
 -- Translating the proofs about Hops into a DepRel,
 -- as required by AAOSL.Abstract.Advancement

 getHop : ∀{j}(h : Fin (lvlOf j)) → H (toℕ h) j (j ∸ 2 ^ toℕ h)
 getHop {j} h = h-correct j (toℕ h) (toℕ<n {lvlOf j} h)

 hop-prog : {m : ℕ} (h : Fin (lvlOf m)) → m ∸ (2 ^ toℕ h) ≢ m
 hop-prog {zero} ()
 hop-prog {suc m} h = ∸-≢ (2 ^ toℕ h) (1≤2^n (toℕ h)) (lvlOf-correct (toℕ<n h))

 hop-≤ : {m : ℕ} (h : Fin (lvlOf m)) → m ∸ (2 ^ toℕ h) ≤ m
 hop-≤ {zero} ()
 hop-≤ {suc m} h = m∸n≤m (suc m) (2 ^ toℕ h)

 lvlOfsuc : ∀ m → 0 < lvlOf (suc m)
 lvlOfsuc m with even? (suc m)
 ...| yes _ = s≤s z≤n
 ...| no  _ = s≤s z≤n

 -- This proves that ℕ makes a skiplog dependency relation
 -- by connecting the indexes by their largest power of two.
 skiplog-dep-rel : DepRel
 skiplog-dep-rel = record
   { lvlof          = lvlOf
   ; lvlof-z        = refl
   ; lvlof-s        = lvlOfsuc
   ; hop-tgt        = λ {m} h → m ∸ 2 ^ toℕ h
   ; hop-tgt-inj    = λ {m} {h} {h'} prf
                    → toℕ-injective (2^-injective {toℕ h} {toℕ h'}
                                      (∸-inj (2 ^ toℕ h) (2 ^ toℕ h')
                                             (lvlOf-correct (toℕ<n h))
                                             (lvlOf-correct (toℕ<n h'))
                                      prf))
   ; hop-<         = λ h → ≤∧≢⇒< (hop-≤ h) (hop-prog h)
   ; hops-nested-or-nonoverlapping
      = λ {h₁} {h₂} {h₃} {h₄} a b
        → no-overlap-< (getHop h₃) (getHop h₄) a b
  }

 -- This, in turn, enables us to bring the abstract module into
 -- scope with everything instantiated minus the hash functions.
 module _
    (hash    : ByteString → Hash)
    (hash-cr : ∀{x y} → hash x ≡ hash y → Collision hash x y ⊎ x ≡ y)
  where

  open import AAOSL.Abstract.Advancement hash hash-cr encodeℕ encodeℕ-inj skiplog-dep-rel
  open import AAOSL.Abstract.EvoCR hash hash-cr encodeℕ encodeℕ-inj skiplog-dep-rel


open import Data.Bool hiding (if_then_else_)
open import Data.Empty
open import Data.List
open import Data.List.Properties
open import Data.Maybe
open import Data.Product
open import Data.Sum
open import Data.Unit

open import Relation.Binary.PropositionalEquality hiding (Extensionality ; [_])
open import Relation.Nullary
open import Relation.Nullary.Negation

module EffectAnnotations where

open import Axiom.Extensionality.Propositional
open import Axiom.UniquenessOfIdentityProofs

-- ASSUMING FUNCTION EXTENSIONALITY

postulate
  fun-ext : ∀ {a b} → Extensionality a b
  ifun-ext : ∀ {a b} → ExtensionalityImplicit a b

-- SIGNAL AND INTERRUPT NAMES

postulate Σₛ : Set

-- SIGNAL AND INTERRUPT NAMES HAVE DECIDABLE EQUALITY

postulate decₛ : (op op' : Σₛ) → Dec (op ≡ op')

if_≡_then_else_ : {A : Set} → Σₛ → Σₛ → A → A → A
if op ≡ op' then x else y with decₛ op op'
... | yes p = x
... | no ¬p = y

ite-≡ : {A : Set}
        {op : Σₛ}
        {x y : A} →
        -----------------------------
        if op ≡ op then x else y ≡ x

ite-≡ {A} {op} with decₛ op op
ite-≡ {A} {op} | yes p =
  refl
ite-≡ {A} {op} | no ¬p =
  ⊥-elim (¬p refl)

ite-≢ : {A : Set}
        {op op' : Σₛ}
        {x y : A} →
        op ≢ op' →
        ------------------------------
        if op ≡ op' then x else y ≡ y

ite-≢ {A} {op} {op'} p with decₛ op op'
ite-≢ {A} {op} {op'} p | yes q =
  ⊥-elim (p q)
ite-≢ {A} {op} {op'} p | no ¬q =
  refl

-- EFFECT ANNOTATIONS FOR OUTGOING SIGNALS (O) AND INTERRUPT HANDLERS (I)

mutual
  data O : Set where
    omap : (Σₛ → Maybe ⊤) → O

  data I : Set where
    imap : (Σₛ → Maybe (O × I)) → I

-- EMPTY EFFECT ANNOTATIONS

∅ₒ : O
∅ₒ = omap (λ _ → nothing)

∅ᵢ : I
∅ᵢ = imap (λ _ → nothing)

-- UNION OF EFFECT ANNOTATIONS

∪ₒ-aux' : (o o' : Maybe ⊤) → Maybe ⊤
∪ₒ-aux' nothing o' = o'
∪ₒ-aux' (just tt) o' = just tt

∪ₒ-aux : (o o' : Σₛ → Maybe ⊤) → Σₛ → Maybe ⊤
∪ₒ-aux o o' op =
  ∪ₒ-aux' (o op) (o' op)

_∪ₒ_ : O → O → O
(omap o) ∪ₒ (omap o') =
  omap (∪ₒ-aux o o')

mutual
  ∪ᵢ-aux : (i i' : Σₛ → Maybe (O × I)) → Σₛ → Maybe (O × I)
  ∪ᵢ-aux i i' op =
    ∪ᵢ-aux' (i op) (i' op)

  ∪ᵢ-aux' : (oi oi' : Maybe (O × I)) → Maybe (O × I)
  ∪ᵢ-aux' nothing oi' =
    oi'
  ∪ᵢ-aux' (just oi'') nothing =
    just oi''
  ∪ᵢ-aux' (just (o'' , (imap i''))) (just (o''' , (imap i'''))) =
    just (o'' ∪ₒ o''' , imap (∪ᵢ-aux i'' i'''))

_∪ᵢ_ : I → I → I
(imap i) ∪ᵢ (imap i') =
  imap (∪ᵢ-aux i i')

-- SETTING THE VALUE OF EFFECT ANNOTATION AT A SPECIFIC INTERRUPT NAME

_[_↦_]ᵢ : I → Σₛ → Maybe (O × I) → I
(imap i) [ op ↦ v ]ᵢ =
  imap (λ op' → if op ≡ op' then v else i op')

-- ACTION OF INTERRUPTS ON EFFECT ANNOTATIONS

infix 40 _↓ₑ_

↓ₑ-auxₒ : Σₛ → Maybe (O × I) → O → O
↓ₑ-auxₒ op nothing o =
  o
↓ₑ-auxₒ op (just (o' , i')) o =
  o ∪ₒ o'

↓ₑ-auxᵢ : Σₛ → Maybe (O × I) → I → I
↓ₑ-auxᵢ op nothing i =
  i
↓ₑ-auxᵢ op (just (o' , i')) i =
  (i [ op ↦ nothing ]ᵢ) ∪ᵢ i'

_↓ₑ_ : Σₛ → O × I → O × I
op ↓ₑ (omap o , imap i) =
  (↓ₑ-auxₒ op (i op) (omap o) , ↓ₑ-auxᵢ op (i op) (imap i))

-- GENERALISED ACTION OF INTERRUPTS ON EFFECT ANNOTATIONS

_↓↓ₑ_ : List Σₛ → O × I → O × I
[] ↓↓ₑ (o , i) =
  (o , i)
(op ∷ ops) ↓↓ₑ (o , i) =
  op ↓ₑ (ops ↓↓ₑ (o , i))

↓↓ₑ-act : {o : O}
          {i : I} →
          (ops ops' : List Σₛ) →
          ------------------------------------------------------
          (ops ++ ops') ↓↓ₑ (o , i) ≡ ops ↓↓ₑ (ops' ↓↓ₑ (o , i))

↓↓ₑ-act [] ops' =
  refl
↓↓ₑ-act (op ∷ ops) ops' =
  cong (λ oi → op ↓ₑ oi) (↓↓ₑ-act ops ops')

-- CHECKING THE CONTENTS OF EFFECT ANNOTATIONS

_∈ₒ_ : Σₛ → O → Set
op ∈ₒ (omap o) =
  o op ≡ just tt

lkpᵢ : Σₛ → I → Maybe (O × I)
lkpᵢ op (imap i) = i op

-- SUBTYPING RELATIONS FOR EFFECT ANNOTATIONS

_⊑ₒ_ : O → O → Set
o ⊑ₒ o' = (op : Σₛ) → op ∈ₒ o → op ∈ₒ o'

data _⊑ᵢ_ (i i' : I) : Set where
  rel : ((op : Σₛ) → {o : O} → {i'' : I} → lkpᵢ op i ≡ just (o , i'') →
          Σ[ o' ∈ O ] Σ[ i''' ∈ I ] (lkpᵢ op i' ≡ just (o' , i''') × o ⊑ₒ o' × i'' ⊑ᵢ i''')) →
        i ⊑ᵢ i'

-- SUBTYPING RELATIONS ARE PREORDERS

⊑ₒ-refl : {o : O} →
          ---------
          o ⊑ₒ o

⊑ₒ-refl =
  λ op p → p

⊑ₒ-trans : {o o' o'' : O} →
           o ⊑ₒ o' →
           o' ⊑ₒ o'' →
           ----------------
           o ⊑ₒ o''

⊑ₒ-trans p q =
  λ op r → q op (p op r)

⊑ᵢ-refl : {i : I} →
          ---------
          i ⊑ᵢ i

⊑ᵢ-refl {imap i} =
  rel (λ op {o'} → λ { {imap i'} → λ p → ⊑ᵢ-refl-aux (i op) p })

  where
    ⊑ᵢ-refl-aux : (oi : Maybe (O × I)) →
                  ----------------------------------------------------------------------------------
                  {o' : O} {i' : Σₛ → Maybe (O × I)} →
                  oi ≡ just (o' , imap i') →
                  Σ[ o'' ∈ O ] Σ[ i'' ∈ I ] (oi ≡ just (o'' , i'') × (o' ⊑ₒ o'') × (imap i' ⊑ᵢ i''))

    ⊑ᵢ-refl-aux (just .(o' , imap i')) {o'} {i'} refl =
      o' , (imap i' , (refl , (⊑ₒ-refl , ⊑ᵢ-refl {imap i'})))

⊑ᵢ-trans : {i i' i'' : I} →
           i ⊑ᵢ i' →
           i' ⊑ᵢ i'' →
           -----------------
           i ⊑ᵢ i''

⊑ᵢ-trans {i} {i'} {i''} (rel p) (rel q) =
  rel (λ op {o} {j} r → ⊑ᵢ-trans-aux o j op (p op r))

  where
    ⊑ᵢ-trans-aux' : (o : O) → (j : I) → (op : Σₛ) →
                    (o' : O) → (j' : I) → lkpᵢ op i' ≡ just (o' , j') → (o ⊑ₒ o') → (j ⊑ᵢ j') →
                    Σ[ o'' ∈ O ] Σ[ j'' ∈ I ] (lkpᵢ op i'' ≡ just (o'' , j'') × (o' ⊑ₒ o'') × (j' ⊑ᵢ j'')) →
                    Σ[ o'' ∈ O ] Σ[ j'' ∈ I ] (lkpᵢ op i'' ≡ just (o'' , j'') × (o ⊑ₒ o'') × (j ⊑ᵢ j''))

    ⊑ᵢ-trans-aux' o j op o' j' r' s t (o'' , j'' , r'' , s' , t') =
      o'' , j'' , r'' , ⊑ₒ-trans s s' , ⊑ᵢ-trans t t'

    ⊑ᵢ-trans-aux : (o : O) → (j : I) → (op : Σₛ) →
                    Σ[ o' ∈ O ] Σ[ j' ∈ I ] (lkpᵢ op i' ≡ just (o' , j') × (o ⊑ₒ o') × (j ⊑ᵢ j')) →
                    Σ[ o'' ∈ O ] Σ[ j'' ∈ I ] (lkpᵢ op i'' ≡ just (o'' , j'') × (o ⊑ₒ o'') × (j ⊑ᵢ j''))

    ⊑ᵢ-trans-aux o j op (o' , j' , r' , s , t) =
      ⊑ᵢ-trans-aux' o j op o' j' r' s t (q op r')

-- SUBTYPING RELATIONS ARE PROOF-IRRELEVANT

≡-uip : {X : Set}
        {x x' : X} →
        (p q : x ≡ x') →
        ----------------
        p ≡ q

≡-uip refl refl = refl

⊑ₒ-irrelevant : {o o' : O}
                (p q : o ⊑ₒ o') →
                -----------------
                p ≡ q

⊑ₒ-irrelevant {omap o} {omap o'} p q =
  fun-ext (λ op → fun-ext (λ r → ⊑ₒ-irrelevant-aux r))

  where

    ⊑ₒ-irrelevant-aux : {op : Σₛ} →
                        (r : op ∈ₒ (omap o)) →
                        ----------------------
                        p op r ≡ q op r

    ⊑ₒ-irrelevant-aux {op} r with p op r | q op r
    ... | s | t = ≡-uip s t

⊑ᵢ-irrelevant : {i i' : I}
                (p q : i ⊑ᵢ i') →
                -----------------
                p ≡ q

⊑ᵢ-irrelevant {imap i} {imap i'} (rel p) (rel q) =
  cong (λ r → rel r) (fun-ext (λ op → ifun-ext (λ {o''} → ifun-ext (λ {i''} → fun-ext (λ r → ⊑ᵢ-irrelevant-aux r)))))

  where

    ⊑ᵢ-irrelevant-aux : {op : Σₛ}
                        {o'' : O}
                        {i'' : I} →
                        (r : i op ≡ just (o'' , i'')) →
                        -------------------------------
                        p op r ≡ q op r

    ⊑ᵢ-irrelevant-aux {op} r with p op r | q op r
    ... | o''' , i''' , s , s' , s'' | o'''' , i'''' , t , t' , t'' with trans (sym s) t
    ... | refl with ⊑ₒ-irrelevant s' t'
    ... | refl with ⊑ᵢ-irrelevant s'' t''
    ... | refl with ≡-uip s t
    ... | refl = refl

-- LEFT UNIT FOR UNIONS OF EFFECT ANNOTATIONS

∪ₒ-lunit : (o : O) →
           -----------
           ∅ₒ ∪ₒ o ≡ o

∪ₒ-lunit (omap o) =
  cong omap (fun-ext ∪ₒ-lunit-aux)

  where
    ∪ₒ-lunit-aux : (op : Σₛ) →
                   ----------------------------------
                   ∪ₒ-aux (λ _ → nothing) o op ≡ o op

    ∪ₒ-lunit-aux op with o op
    ... | nothing =
      refl
    ... | just _ =
      refl

∪ᵢ-lunit : (i : I) →
           -----------
           ∅ᵢ ∪ᵢ i ≡ i

∪ᵢ-lunit (imap i) = cong imap (fun-ext ∪ᵢ-lunit-aux)

  where
    ∪ᵢ-lunit-aux : (op : Σₛ) →
                   ----------------------------------
                   ∪ᵢ-aux (λ _ → nothing) i op ≡ i op

    ∪ᵢ-lunit-aux op with i op
    ... | nothing =
      refl
    ... | just _ =
      refl

-- LEFT AND RIGHT INCLUSIONS INTO UNIONS OF EFFECT ANNOTATIONS

∪ₒ-inl : {o o' : O} →
         -------------
         o ⊑ₒ (o ∪ₒ o')

∪ₒ-inl {omap o} {omap o'} op with o op | o' op
... | nothing | nothing = λ p → p
... | nothing | just tt = λ _ → refl
... | just tt | nothing = λ p → p
... | just tt | just tt = λ p → p

∪ₒ-inr : {o o' : O} →
         -------------
         o' ⊑ₒ (o ∪ₒ o')

∪ₒ-inr {omap o} {omap o'} op with o op | o' op
... | nothing | nothing = λ p → p
... | nothing | just tt = λ p → p
... | just tt | nothing = λ _ → refl
... | just tt | just tt = λ p → p

∪ᵢ-inl : {i i' : I} →
        -------------
        i ⊑ᵢ (i ∪ᵢ i')

∪ᵢ-inl {imap i} {imap i'} =
  rel (λ op → ∪ᵢ-inl-aux (i op) (i' op))

  where
    ∪ᵢ-inl-aux : (oi oi' : Maybe (O × I)) →
                 {o : O} {i'' : I} →
                 oi ≡ just (o , i'') →
                 Σ[ o' ∈ O ] Σ[ i''' ∈ I ] (∪ᵢ-aux' oi oi' ≡ just (o' , i''') × (o ⊑ₒ o') × (i'' ⊑ᵢ i'''))

    ∪ᵢ-inl-aux (just .(o , i'')) nothing {o} {i''} refl =
      o , i'' , refl , ⊑ₒ-refl , ⊑ᵢ-refl
    ∪ᵢ-inl-aux (just .(o , imap i'')) (just (o' , imap i''')) {o} {imap i''} refl =
      o ∪ₒ o' , imap (∪ᵢ-aux i'' i''') , refl , ∪ₒ-inl , ∪ᵢ-inl

∪ᵢ-inr : {i i' : I} →
        -------------
        i' ⊑ᵢ (i ∪ᵢ i')

∪ᵢ-inr {imap i} {imap i'} =
  rel (λ op → ∪ᵢ-inr-aux (i op) (i' op))

  where
    ∪ᵢ-inr-aux : (oi oi' : Maybe (O × I)) →
                 {o : O} {i'' : I} →
                 oi' ≡ just (o , i'') →
                 Σ[ o' ∈ O ] Σ[ i''' ∈ I ] (∪ᵢ-aux' oi oi' ≡ just (o' , i''') × (o ⊑ₒ o') × (i'' ⊑ᵢ i'''))

    ∪ᵢ-inr-aux nothing (just .(o , i'')) {o} {i''} refl =
      o , i'' , refl , ⊑ₒ-refl , ⊑ᵢ-refl
    ∪ᵢ-inr-aux (just (o' , imap i''')) (just .(o , imap i'')) {o} {imap i''} refl =
      o' ∪ₒ o , imap (∪ᵢ-aux i''' i'') , refl , ∪ₒ-inr , ∪ᵢ-inr

-- COPAIRING FOR UNIONS OF EFFECT ANNOTATIONS

∪ₒ-copair : {o o' o'' : O} →
            o ⊑ₒ o'' →
            o' ⊑ₒ o'' →
            ----------------
            (o ∪ₒ o') ⊑ₒ o''

∪ₒ-copair {omap o} {omap o'} {omap o''} p q op =
  ∪ₒ-copair-aux (p op) (q op)

  where
    ∪ₒ-copair-aux : (p : op ∈ₒ (omap o) → op ∈ₒ (omap o'')) →
                    (q : op ∈ₒ (omap o') → op ∈ₒ (omap o'')) →
                    ---------------------------------------------
                    op ∈ₒ (omap (∪ₒ-aux o o')) → op ∈ₒ (omap o'')

    ∪ₒ-copair-aux p q with o op | o' op
    ... | nothing | nothing = q
    ... | nothing | just tt = q
    ... | just tt | nothing = p
    ... | just tt | just tt = p

inj-just : {X : Set} {x x' : X} → just x ≡ just x' → x ≡ x'
inj-just refl = refl

inj-pair₁ : {X Y : Set} {x x' : X} {y y' : Y} → (x , y) ≡ (x' , y') → x ≡ x'
inj-pair₁ refl = refl

inj-pair₂ : {X Y : Set} {x x' : X} {y y' : Y} → (x , y) ≡ (x' , y') → y ≡ y'
inj-pair₂ refl = refl

∪ᵢ-copair : {i i' i'' : I} →
            i ⊑ᵢ i'' →
            i' ⊑ᵢ i'' →
            ----------------
            (i ∪ᵢ i') ⊑ᵢ i''

∪ᵢ-copair {imap i} {imap i'} {imap i''} (rel p) (rel q) =
  rel (λ op {o'''} {i'''} r → ∪ᵢ-copair-aux op o''' i''' (i op) (i' op) (i'' op) refl refl refl r)

  where
    ∪ᵢ-copair-aux : (op : Σₛ) →
                    (o''' : O) →
                    (i''' : I)
                    (oi oi' oi'' : Maybe (O × I)) →
                    (oi ≡ i op) →
                    (oi' ≡ i' op) →
                    (oi'' ≡ i'' op) →
                    (r : ∪ᵢ-aux' oi oi' ≡ just (o''' , i''')) →
                    Σ[ o' ∈ O ] Σ[ i'''' ∈ I ] (oi'' ≡ just (o' , i'''') × (o''' ⊑ₒ o') × (i''' ⊑ᵢ i''''))

    ∪ᵢ-copair-aux op o''' i''' nothing (just oi') nothing r s t u with trans t (proj₁ (proj₂ (proj₂ (q op (trans (sym s) u)))))
    ... | ()
    ∪ᵢ-copair-aux op o''' i''' nothing (just oi') (just oi'') r s t u =
      proj₁ (q op (trans (sym s) u)) ,
      proj₁ (proj₂ (q op (trans (sym s) u))) ,
      trans t (proj₁ (proj₂ (proj₂ (q op (trans (sym s) u))))) ,
      proj₁ (proj₂ (proj₂ (proj₂ (q op (trans (sym s) u))))) ,
      proj₂ (proj₂ (proj₂ (proj₂ (q op (trans (sym s) u)))))
    ∪ᵢ-copair-aux op o''' i''' (just oi) nothing oi'' r s t u =
      proj₁ (p op (trans (sym r) u)) ,
      proj₁ (proj₂ (p op (trans (sym r) u))) ,
      trans t (proj₁ (proj₂ (proj₂ (p op (trans (sym r) u))))) ,
      proj₁ (proj₂ (proj₂ (proj₂ (p op (trans (sym r) u))))) ,
      proj₂ (proj₂ (proj₂ (proj₂ (p op (trans (sym r) u)))))
    ∪ᵢ-copair-aux op o''' i'''
                  (just (omap o'''' , imap i''''))
                  (just (omap o''''' , imap i'''''))
                  nothing r s t u
                  with trans t (proj₁ (proj₂ (proj₂ (p op (sym r)))))
    ... | ()
    ∪ᵢ-copair-aux op o''' i'''
                  (just (omap o'''' , imap i''''))
                  (just (omap o''''' , imap i'''''))
                  (just (omap o'''''' , imap i''''''))
                  r s t u =
      omap o'''''' ,
      imap i'''''' ,
      refl ,
      subst (λ o → o ⊑ₒ omap o'''''')
            (inj-pair₁ (inj-just u))
            (∪ₒ-copair (subst (λ o → omap o'''' ⊑ₒ o)
                              (inj-pair₁ (inj-just (sym (trans t (proj₁ (proj₂ (proj₂ (p op (sym r)))))))))
                              (proj₁ (proj₂ (proj₂ (proj₂ (p op (sym r)))))))
                       (subst (λ o → omap o''''' ⊑ₒ o)
                              (inj-pair₁ (inj-just (sym (trans t (proj₁ (proj₂ (proj₂ (q op (sym s)))))))))
                              (proj₁ (proj₂ (proj₂ (proj₂ (q op (sym s)))))))) ,
      subst (λ i → i ⊑ᵢ imap i'''''')
            (inj-pair₂ (inj-just u))
            (∪ᵢ-copair (subst (λ i → imap i'''' ⊑ᵢ i)
                               (inj-pair₂ (inj-just (sym (trans t (proj₁ (proj₂ (proj₂ (p op (sym r)))))))))
                               (proj₂ (proj₂ (proj₂ (proj₂ (p op (sym r)))))))
                       (subst (λ i → imap i''''' ⊑ᵢ i)
                               (inj-pair₂ (inj-just (sym (trans t (proj₁ (proj₂ (proj₂ (q op (sym s)))))))))
                               (proj₂ (proj₂ (proj₂ (proj₂ (q op (sym s))))))))

-- FUNCTORIALITY OF UNIONS OF EFFECT ANNOTATIONS

∪ₒ-fun : {o o' o'' o''' : O} →
         o ⊑ₒ o'' →
         o' ⊑ₒ o''' →
         --------------------------
         (o ∪ₒ o') ⊑ₒ (o'' ∪ₒ o''')

∪ₒ-fun p q =
  ∪ₒ-copair (⊑ₒ-trans p ∪ₒ-inl) (⊑ₒ-trans q ∪ₒ-inr)

∪ᵢ-fun : {i i' i'' i''' : I} →
         i ⊑ᵢ i'' →
         i' ⊑ᵢ i''' →
         --------------------------
         (i ∪ᵢ i') ⊑ᵢ (i'' ∪ᵢ i''')

∪ᵢ-fun p q =
  ∪ᵢ-copair (⊑ᵢ-trans p ∪ᵢ-inl) (⊑ᵢ-trans q ∪ᵢ-inr)

-- UNIONS OF INTERRUPT ANNOTATIONS ARE GIVEN BY POINTWISE UNIONS

∪ᵢ-∪ₒ : {op : Σₛ}
        {o'' o''' o'''' : O}
        {i i' i'' i''' i'''' : I} →
        lkpᵢ op (i ∪ᵢ i') ≡ just (o'' , i'') →
        lkpᵢ op i ≡ just (o''' , i''') →
        lkpᵢ op i' ≡ just (o'''' , i'''') →
        ---------------------------------------
        o'' ≡ o''' ∪ₒ o''''

∪ᵢ-∪ₒ {op} {o''} {o'''} {o''''} {imap i} {imap i'} p q r with i op | i' op
∪ᵢ-∪ₒ {op} {.(o''' ∪ₒ o'''')} {o'''} {o''''} {imap i} {imap i'} {_} {imap i'''} {imap i''''}
  refl refl refl | just .(o''' , imap i''') | just .(o'''' , imap i'''') =
    refl

∪ᵢ-∪ᵢ : {op : Σₛ}
        {o'' o''' o'''' : O}
        {i i' i'' i''' i'''' : I} →
        lkpᵢ op (i ∪ᵢ i') ≡ just (o'' , i'') →
        lkpᵢ op i ≡ just (o''' , i''') →
        lkpᵢ op i' ≡ just (o'''' , i'''') →
        ---------------------------------------
        i'' ≡ i''' ∪ᵢ i''''

∪ᵢ-∪ᵢ {op} {o''} {o'''} {o''''} {imap i} {imap i'} p q r with i op | i' op
∪ᵢ-∪ᵢ {op} {.(o''' ∪ₒ o'''')} {o'''} {o''''} {imap i} {imap i'} {_} {imap i'''} {imap i''''}
  refl refl refl | just .(o''' , imap i''') | just .(o'''' , imap i'''') =
    refl

-- INCLUSION INTO ACTED UPON EFFECT ANNOTATION

{- LEMMA 3.1 (1) -}

↓ₑ-⊑ₒ : {o : O}
        {i : I}
        {op : Σₛ} →
        --------------------------
        o ⊑ₒ proj₁ (op ↓ₑ (o , i))

↓ₑ-⊑ₒ {omap o} {imap i} {op} op' p with i (op)
... | nothing = p
... | just (o' , i') = ∪ₒ-inl op' p

{- LEMMA 3.1 (2) - the O part -}

↓ₑ-⊑ₒ-o' : {o o' : O}
           {i i' : I}
           {op : Σₛ} →
           lkpᵢ op i ≡ just (o' , i') →
           ---------------------------
           o' ⊑ₒ proj₁ (op ↓ₑ (o , i))

↓ₑ-⊑ₒ-o' {omap o} {omap o'} {imap i} {imap i'} {op} p with i (op)
↓ₑ-⊑ₒ-o' {omap o} {omap o'} {imap i} {imap i'} {op} refl | just .(omap o' , imap i') =
  ↓ₑ-⊑ₒ-o'-aux

  where
    ↓ₑ-⊑ₒ-o'-aux : (op' : Σₛ) → o' op' ≡ just tt → ∪ₒ-aux o o' op' ≡ just tt
    ↓ₑ-⊑ₒ-o'-aux op' p with o op'
    ↓ₑ-⊑ₒ-o'-aux op' p | nothing = p
    ↓ₑ-⊑ₒ-o'-aux op' p | just tt = refl

{- LEMMA 3.1 (2) - the I part -}

↓ₑ-⊑ₒ-i' : {o o' : O}
           {i i' : I}
           {op : Σₛ} →
           lkpᵢ op i ≡ just (o' , i') →
           ---------------------------
           i' ⊑ᵢ proj₂ (op ↓ₑ (o , i))

↓ₑ-⊑ₒ-i' {omap o} {omap o'} {imap i} {imap i'} {op} p with i (op)
↓ₑ-⊑ₒ-i' {omap o} {omap o'} {imap i} {imap i'} {op} refl | just .(omap o' , imap i') =
  rel ↓ₑ-⊑ₒ-i'-aux

  where
    ↓ₑ-⊑ₒ-i'-aux : (op' : Σₛ) {o'' : O} {i'' : I} →
      i' op' ≡ just (o'' , i'') →
      Σ[ o''' ∈ O ] Σ[ i''' ∈ I ] (∪ᵢ-aux (λ op' → if op ≡ op' then nothing else i op') i' op' ≡ just (o''' , i''') ×
                                  (o'' ⊑ₒ o''') × (i'' ⊑ᵢ i'''))
    ↓ₑ-⊑ₒ-i'-aux op' {o''} {i''} p with decₛ op op'
    ↓ₑ-⊑ₒ-i'-aux op' {o''} {i''} p | yes refl with i' (op)
    ↓ₑ-⊑ₒ-i'-aux op' {o''} {i''} refl | yes refl | just .(o'' , i'') =
      o'' , (i'' , refl , (⊑ₒ-refl , ⊑ᵢ-refl))
    ↓ₑ-⊑ₒ-i'-aux op' {o''} {i''} p | no ¬q with i (op') | i' (op')
    ↓ₑ-⊑ₒ-i'-aux op' {o''} {i''} refl | no ¬q | nothing | just .(o'' , i'') =
      o'' , (i'' , refl , (⊑ₒ-refl , ⊑ᵢ-refl))
    ↓ₑ-⊑ₒ-i'-aux op' {o''} {imap i''} refl | no ¬q | just (o''' , (imap i''')) | just .(o'' , (imap i'')) =
      (o''' ∪ₒ o'') , (imap (∪ᵢ-aux i''' i'') , (refl , (∪ₒ-inr , ∪ᵢ-inr)))

-- EFFECT ANNOTATION OF AN INTERRUPT THAT WAS NOT ACTED WITH

{- LEMMA 3.1 (3) -}

lkpᵢ-↓ₑ-neq : {o o' : O}
              {i i' : I} {op op' : Σₛ} →
              ¬ op ≡ op' →
              lkpᵢ op' i ≡ just (o' , i') →
              -------------------------------------------------------------------------------------------------------
              Σ[ o'' ∈ O ] Σ[ i'' ∈ I ] (lkpᵢ op' (proj₂ (op ↓ₑ (o , i))) ≡ just (o'' , i'') × o' ⊑ₒ o'' × i' ⊑ᵢ i'')

lkpᵢ-↓ₑ-neq {omap o} {o'} {imap i} {imap i'} {op} {op'} p q with i (op)
... | nothing =
  o' , imap i' , q , ⊑ₒ-refl , ⊑ᵢ-refl
lkpᵢ-↓ₑ-neq {omap o} {o'} {imap i} {imap i'} {op} {op'} p q | just (o'' , imap i'') with decₛ op op'
... | yes r with p r
... | ()
lkpᵢ-↓ₑ-neq {omap o} {o'} {imap i} {imap i'} {op} {op'} p q | just (o'' , imap i'') | no ¬r with i (op') | i'' (op')
lkpᵢ-↓ₑ-neq {omap o} {.o'''} {imap i} {imap i'} {op} {op'} p refl |
  just (o'' , imap i'') | no ¬r | just (o''' , .(imap i')) | nothing =
    o''' , imap i' , refl , ⊑ₒ-refl , ⊑ᵢ-refl
... | just (o''' , imap i''') | just (o'''' , imap i'''') with q
lkpᵢ-↓ₑ-neq {omap o} {.o'''} {imap i} {imap .i'''} {op} {op'} p q |
  just (o'' , imap i'') | no ¬r | just (o''' , imap i''') | just (o'''' , imap i'''') | refl =
    (o''' ∪ₒ o'''') , (imap i''') ∪ᵢ (imap i'''') , refl , ∪ₒ-inl , ∪ᵢ-inl

-- NEXT DEFINED EFFECT ANNOTATION UNDER SUBTYPING EFFECT ANNOTATIONS

lkpᵢ-nextₒ : {o'' : O} {i i' i'' : I} {op : Σₛ} →
            i ⊑ᵢ i' → lkpᵢ op i ≡ just (o'' , i'') → O

lkpᵢ-nextₒ {o''} {i} {i'} {i''} {op} (rel p) q =
  proj₁ (p op q)

lkpᵢ-nextᵢ : {o'' : O} {i i' i'' : I} {op : Σₛ} →
            i ⊑ᵢ i' → lkpᵢ op i ≡ just (o'' , i'') → I

lkpᵢ-nextᵢ {o''} {i} {i'} {i''} {op} (rel p) q =
  proj₁ (proj₂ (p op q))

lkpᵢ-next-eq : {o'' : O} {i i' i'' : I} {op : Σₛ} →
              (p : i ⊑ᵢ i') →
              (q : lkpᵢ op i ≡ just (o'' , i'')) →
              ------------------------------------------------
              lkpᵢ op i' ≡ just (lkpᵢ-nextₒ p q , lkpᵢ-nextᵢ p q)

lkpᵢ-next-eq {o''} {i} {i'} {i''} {op} (rel p) q =
  proj₁ (proj₂ (proj₂ (p op q)))

lkpᵢ-next-⊑ₒ : {o'' : O} {i i' i'' : I} {op : Σₛ} →
              (p : i ⊑ᵢ i') →
              (q : lkpᵢ op i ≡ just (o'' , i'')) →
              -----------------------------------
              o'' ⊑ₒ lkpᵢ-nextₒ p q

lkpᵢ-next-⊑ₒ {o''} {i} {i'} {i''} {op} (rel p) q =
  proj₁ (proj₂ (proj₂ (proj₂ (p op q))))

lkpᵢ-next-⊑ᵢ : {o'' : O} {i i' i'' : I} {op : Σₛ} →
              (p : i ⊑ᵢ i') →
              (q : lkpᵢ op i ≡ just (o'' , i'')) →
              -----------------------------------
              i'' ⊑ᵢ lkpᵢ-nextᵢ p q

lkpᵢ-next-⊑ᵢ {o''} {i} {i'} {i''} {op} (rel p) q =
  proj₂ (proj₂ (proj₂ (proj₂ (p op q))))

-- ACTION OF INTERRUPTS ON EFFECT ANNOTATIONS IS MONOTONIC

mutual
  ↓ₑ-monotonicₒ : {o o' : O}
                  {i i' : I}
                  {op : Σₛ} →
                  o ⊑ₒ o' →
                  i ⊑ᵢ i' →
                  ------------------------------------------------
                  proj₁ (op ↓ₑ (o , i)) ⊑ₒ proj₁ (op ↓ₑ (o' , i'))

  ↓ₑ-monotonicₒ {omap o} {omap o'} {imap i} {imap i'} {op} p (rel q) =
    ↓ₑ-monotonicₒ-aux (i op) (i' op) refl refl

    where
      ↓ₑ-monotonicₒ-aux : (oi oi' : Maybe (O × I)) →
                          i op ≡ oi →
                          i' op ≡ oi' →
                          ----------------------------
                          ↓ₑ-auxₒ op oi (omap o)
                          ⊑ₒ
                          ↓ₑ-auxₒ op oi' (omap o')

      ↓ₑ-monotonicₒ-aux nothing nothing r s =
        p
      ↓ₑ-monotonicₒ-aux nothing (just (omap o''' , imap i''')) r s =
        ⊑ₒ-trans p ∪ₒ-inl
      ↓ₑ-monotonicₒ-aux (just (omap o'' , imap i'')) nothing r s with trans (sym s) (proj₁ (proj₂ (proj₂ (q op r))))
      ... | ()
      ↓ₑ-monotonicₒ-aux (just (omap o'' , imap i'')) (just (omap o''' , imap i''')) r s with trans (sym s) (proj₁ (proj₂ (proj₂ (q op r))))
      ... | t =
        ∪ₒ-fun p (⊑ₒ-trans (proj₁ (proj₂ (proj₂ (proj₂ (q op r)))))
                           (subst (λ o → o ⊑ₒ omap o''') (inj-pair₁ (inj-just t)) ⊑ₒ-refl))

  ↓ₑ-monotonicᵢ : {o o' : O}
                {i i' : I}
                {op : Σₛ} →
                o ⊑ₒ o' →
                i ⊑ᵢ i' →
                ------------------------------------------------
                proj₂ (op ↓ₑ (o , i)) ⊑ᵢ proj₂ (op ↓ₑ (o' , i'))

  ↓ₑ-monotonicᵢ {omap o} {omap o'} {imap i} {imap i'} {op} p (rel q) =
    ↓ₑ-monotonicᵢ-aux (i op) (i' op) refl refl

    where
      ↓ₑ-monotonicᵢ-aux : (oi oi' : Maybe (O × I)) →
                          oi ≡ i op →
                          oi' ≡ i' op →
                          -----------------------------------------
                          ↓ₑ-auxᵢ op oi (imap i)
                          ⊑ᵢ
                          ↓ₑ-auxᵢ op oi' (imap i')

      ↓ₑ-monotonicᵢ-aux nothing nothing r s =
        rel q
      ↓ₑ-monotonicᵢ-aux nothing (just (omap o''' , imap i''')) r s =
        ⊑ᵢ-trans (rel (λ op' {o''''} {i''''} t → ↓ₑ-monotonicᵢ-aux' op' o'''' i'''' t))
                 (∪ᵢ-inl {(imap i') [ op ↦ nothing ]ᵢ} {imap i'''})

        where
          ↓ₑ-monotonicᵢ-aux' : (op' : Σₛ) →
                               (o'''' : O) →
                               (i'''' : I) →
                               i op' ≡ just (o'''' , i'''') →
                               --------------------------------------------------------------------
                               Σ[ o''''' ∈ O ] Σ[ i''''' ∈ I ]
                                 ((if op ≡ op' then nothing else i' op') ≡ just (o''''' , i''''') ×
                                  (o'''' ⊑ₒ o''''') × (i'''' ⊑ᵢ i'''''))

          ↓ₑ-monotonicᵢ-aux' op' o'''' i'''' t with decₛ op op'
          ↓ₑ-monotonicᵢ-aux' op' o'''' i'''' t | yes refl with trans r t
          ... | ()
          ↓ₑ-monotonicᵢ-aux' op' o'''' i'''' t | no ¬u =
            lkpᵢ-nextₒ (rel q) t ,
            lkpᵢ-nextᵢ (rel q) t ,
            lkpᵢ-next-eq (rel q) t ,
            lkpᵢ-next-⊑ₒ (rel q) t ,
            lkpᵢ-next-⊑ᵢ (rel q) t

      ↓ₑ-monotonicᵢ-aux (just (omap o'' , imap i'')) nothing r s with trans s (proj₁ (proj₂ (proj₂ (q op (sym r)))))
      ... | ()

      ↓ₑ-monotonicᵢ-aux (just (omap o'' , imap i'')) (just (omap o''' , imap i''')) r s =
        ∪ᵢ-fun {_}
               {imap i''}
               {_}
               {imap i'''}
               (rel λ op' {o''''} {i''''} t → ↓ₑ-monotonicᵢ-aux' op' o'''' i'''' t)
               (subst (λ i → imap i'' ⊑ᵢ i)
                      (sym (inj-pair₂ (inj-just (trans s (proj₁ (proj₂ (proj₂ (q op (sym r)))))))))
                      (proj₂ (proj₂ (proj₂ (proj₂ (q op (sym r)))))))

        where
          ↓ₑ-monotonicᵢ-aux' : (op' : Σₛ) →
                               (o'''' : O) →
                               (i'''' : I) →
                               lkpᵢ op' (imap i [ op ↦ nothing ]ᵢ)  ≡ just (o'''' , i'''') →
                               --------------------------
                               Σ[ o''''' ∈ O ] Σ[ i''''' ∈ I ]
                                 (lkpᵢ op' (imap i' [ op ↦ nothing ]ᵢ)
                                  ≡ just (o''''' , i''''') ×
                                  (o'''' ⊑ₒ o''''') × (i'''' ⊑ᵢ i'''''))

          ↓ₑ-monotonicᵢ-aux' op' o'''' i'''' t with decₛ op op'
          ↓ₑ-monotonicᵢ-aux' op' o'''' i'''' t | no ¬u =
            lkpᵢ-nextₒ (rel q) t ,
            lkpᵢ-nextᵢ (rel q) t ,
            lkpᵢ-next-eq (rel q) t ,
            lkpᵢ-next-⊑ₒ (rel q) t ,
            lkpᵢ-next-⊑ᵢ (rel q) t

-- GENERALISED ACTION OF INTERRUPTS ON EFFECT ANNOTATIONS IS MONOTONIC

mutual
  ↓↓ₑ-monotonicₒ : {o o' : O}
                   {i i' : I} →
                   (ops : List Σₛ) →
                   o ⊑ₒ o' →
                   i ⊑ᵢ i' →
                   ----------------------------------------------------
                   proj₁ (ops ↓↓ₑ (o , i)) ⊑ₒ proj₁ (ops ↓↓ₑ (o' , i'))

  ↓↓ₑ-monotonicₒ {omap o} {omap o'} {imap i} {imap i'} [] p q =
    p
  ↓↓ₑ-monotonicₒ (op ∷ ops) p q =
    ↓ₑ-monotonicₒ (↓↓ₑ-monotonicₒ ops p q) (↓↓ₑ-monotonicᵢ ops p q)

  ↓↓ₑ-monotonicᵢ : {o o' : O}
                   {i i' : I} →
                   (ops : List Σₛ) →
                   o ⊑ₒ o' →
                   i ⊑ᵢ i' →
                   ----------------------------------------------------
                   proj₂ (ops ↓↓ₑ (o , i)) ⊑ᵢ proj₂ (ops ↓↓ₑ (o' , i'))

  ↓↓ₑ-monotonicᵢ [] p q = q
  ↓↓ₑ-monotonicᵢ (op ∷ ops) p q =
    ↓ₑ-monotonicᵢ (↓↓ₑ-monotonicₒ ops p q) (↓↓ₑ-monotonicᵢ ops p q)

-- INCLUSION INTO GENERALLY ACTED UPON EFFECT ANNOTATION

↓↓ₑ-⊑ₒ : {o : O}
         {i : I} →
         (ops : List Σₛ) →
         --------------------------
         o ⊑ₒ proj₁ (ops ↓↓ₑ (o , i))

↓↓ₑ-⊑ₒ [] =
  ⊑ₒ-refl
↓↓ₑ-⊑ₒ (op ∷ ops) =
  ⊑ₒ-trans (↓↓ₑ-⊑ₒ ops) (↓ₑ-⊑ₒ {op = op})

-- A PATH OF INTERRUPT NAMES THAT REVEALS THE GIVEN SIGNAL IN AN EFFECT ANNOTATION

data _`at_`in_,_ (op : Σₛ) : List Σₛ → O → I → Set where

  stop : {o : O}
         {i : I} →
         op ∈ₒ o →
         -------------------
         op `at [] `in o , i

  next : {o o' : O}
         {i i' : I}
         {op' : Σₛ}
         {ops : List Σₛ} →
         lkpᵢ op' i ≡ just (o' , i') →
         op `at ops `in o' , i' →
         -----------------------------
         op `at (op' ∷ ops) `in o , i

-- ACTING ON AN ANNOTATION WITH EMPTY SIGNALS PART JUST REVEALS THE INNER LAYER IF THE INTERRUPTS MATCH

↓ₑ-∅-↦-≡ : {op : Σₛ}
           {o : O}
           {i : I} →
           -----------------------------
           op ↓ₑ (∅ₒ , imap (λ op' → if op' ≡ op then just (o , i) else nothing))
           ≡
           (o , i)

↓ₑ-∅-↦-≡ {op} {o} {i} with decₛ op op
↓ₑ-∅-↦-≡ {op} {omap o} {i} | yes refl =
  cong₂ (λ x y → x , y)
        (∪ₒ-lunit (omap o))
        (trans (cong (λ i' → i' ∪ᵢ i) ↓ₑ-∅-↦-≡-aux) (∪ᵢ-lunit i))

  where
    ↓ₑ-∅-↦-≡-aux : imap (λ op' → if op ≡ op' then nothing else (if op' ≡ op then just (omap o , i) else nothing))
                   ≡
                   ∅ᵢ

    ↓ₑ-∅-↦-≡-aux = cong imap (fun-ext ↓ₑ-∅-↦-≡-aux-aux)

      where
        ↓ₑ-∅-↦-≡-aux-aux : (op' : Σₛ) →
                           ---------------------------------------------------------------------------------
                           (if op ≡ op' then nothing else (if op' ≡ op then just (omap o , i) else nothing))
                           ≡
                           nothing

        ↓ₑ-∅-↦-≡-aux-aux op' with decₛ op op'
        ... | yes refl =
          refl
        ... | no ¬p =
          ite-≢ (λ q → ¬p (sym q))

↓ₑ-∅-↦-≡ {op} {o} {i} | no ¬p =
  ⊥-elim (¬p refl)

-- ACTING ON AN ANNOTATION WITH EMPTY SIGNALS IS IDEMPOTENT IF THE INTERRUPTS DO NOT MATCH

↓ₑ-∅-↦-≢ : {op op' : Σₛ}
           {o : O}
           {i : I} →
           op ≢ op' →
           -----------------------------
           op' ↓ₑ (∅ₒ , imap (λ op'' → if op'' ≡ op then just (o , i) else nothing))
           ≡
           (∅ₒ , imap (λ op'' → if op'' ≡ op then just (o , i) else nothing))

↓ₑ-∅-↦-≢ {op} {op'} p with decₛ op' op
↓ₑ-∅-↦-≢ {op} {.op} p | yes refl =
  ⊥-elim (p refl)
↓ₑ-∅-↦-≢ {op} {op'} p | no ¬q =
  refl

-- A MINIMAL EFFECT ANNOTATION SUCH THAT A GIVEN PATH OF INTERRUPTS REVEALS THE GIVEN SIGNAL NAME

mutual
  ⦃⦃_↦_⦄⦄ₒ : List Σₛ → Σₛ → O
  ⦃⦃ [] ↦ op ⦄⦄ₒ =
    omap (λ op' → if op ≡ op' then just tt else nothing)
  ⦃⦃ op' ∷ ops ↦ op ⦄⦄ₒ =
    ∅ₒ

  ⦃⦃_↦_⦄⦄ᵢ : List Σₛ → Σₛ → I
  ⦃⦃ [] ↦ op ⦄⦄ᵢ =
    ∅ᵢ
  ⦃⦃ op' ∷ ops ↦ op ⦄⦄ᵢ =
    imap (λ op'' → if op'' ≡ op' then just (⦃⦃ ops ↦ op ⦄⦄ₒ , ⦃⦃ ops ↦ op ⦄⦄ᵢ) else nothing)

-- IF THERE IS A PATH TO A SIGNAL IN AN EFFECT ANNOTATION, THE MINIMAL EFFECT ANNOTATION IS INCLUDED IN IT

mutual
  `at-minₒ : {op : Σₛ}
             {ops : List Σₛ}
             {o : O}
             {i : I} →
             op `at ops `in o , i →
             ----------------------
             ⦃⦃ ops ↦ op ⦄⦄ₒ ⊑ₒ o

  `at-minₒ {op} {_} {omap o} (stop p) op' with decₛ op op'
  `at-minₒ {.op'} {.[]} {omap o} (stop p) op' | yes refl =
    λ _ → p
  `at-minₒ {op} {.[]} {omap o} (stop p) op'' | no ¬q =
    λ ()
  `at-minₒ (next p q) op'' =
    λ ()

  `at-minᵢ : {op : Σₛ}
             {ops : List Σₛ}
             {o : O}
             {i : I} →
             op `at ops `in o , i →
             ----------------------
             ⦃⦃ ops ↦ op ⦄⦄ᵢ ⊑ᵢ i

  `at-minᵢ (stop p) =
    rel (λ op'' → λ ())
  `at-minᵢ {op} (next {o} {o'} {i} {i'} {op'} {ops} p q) =
    rel (λ op'' {o''} {i''} r → `at-minᵢ-aux r)

    where
      `at-minᵢ-aux : {op'' : Σₛ}
                     {o'' : O}
                     {i'' : I} →
                     lkpᵢ op'' ⦃⦃ op' ∷ ops ↦ op ⦄⦄ᵢ ≡ just (o'' , i'') →
                     ---------------------------------------------------
                     Σ[ o''' ∈ O ]
                     Σ[ i''' ∈ I ]
                     (lkpᵢ op'' i ≡ just (o''' , i''') ×
                      (o'' ⊑ₒ o''') ×
                      (i'' ⊑ᵢ i'''))

      `at-minᵢ-aux {op''} p with decₛ op'' op'
      `at-minᵢ-aux {op'} refl | yes refl =
        o' , i' , p , `at-minₒ q , `at-minᵢ q

-- SUBPATHS OF (INTERRUPT) NAMES

data _⊆_ : List Σₛ → List Σₛ → Set where

  [] : {ops' : List Σₛ} →
         ----------------
         [] ⊆ ops'

  ∷-≡  : {op : Σₛ}
         {ops ops' : List Σₛ} →
         ops ⊆ ops' →
         ------------------------
         (op ∷ ops) ⊆ (op ∷ ops')

  ∷-≢  : {op op' : Σₛ}
         {ops ops' : List Σₛ} →
         op ≢ op' →
         (op ∷ ops) ⊆ ops' →
         -------------------------
         (op ∷ ops) ⊆ (op' ∷ ops')

mutual
  ∷-≢-swap : {op op' : Σₛ}
             {ops ops' : List Σₛ} →
             op ≢ op' →
             (op ∷ ops) ⊆ (op' ∷ op ∷ ops') →
             --------------------------------
             (op ∷ ops) ⊆ (op ∷ op' ∷ ops')

  ∷-≢-swap {op} {.op} {ops} {ops'} p (∷-≡ q) =
    ∷-≡ q
  ∷-≢-swap {op} {op'} {ops} {ops'} p (∷-≢ q (∷-≡ r)) =
    ∷-≡ (∷-∷ r)
  ∷-≢-swap {op} {op'} {ops} {ops'} p (∷-≢ q (∷-≢ r s)) =
    ⊥-elim (r refl)

  ∷-∷ : {op' : Σₛ}
        {ops : List Σₛ} →
        {ops' : List Σₛ} →
        ops ⊆ ops' →
        -------------------
        ops ⊆ (op' ∷ ops')

  ∷-∷ [] = []
  ∷-∷ {op'} (∷-≡ {op} p) with decₛ op op'
  ∷-∷ {.op} (∷-≡ {op} p) | yes refl =
    ∷-≡ (∷-∷ p)
  ∷-∷ {op'} (∷-≡ {op} p) | no ¬q =
    ∷-≢ ¬q (∷-≡ p)
  ∷-∷ {op'} (∷-≢ {op} {op''} p q) with decₛ op op'
  ∷-∷ {.op} (∷-≢ {op} {op''} p q) | yes refl = ∷-≢-swap p (∷-≢ p (∷-∷ q))
  ∷-∷ {op'} (∷-≢ {op} {op''} p q) | no ¬r = ∷-≢ ¬r (∷-≢ p q)

-- IF A SUBPATH OF INTERRUPTS REVEALS A SIGNAL, THEN ACTING WITH THE WHOLE PATH ALSO REVEALS IT

⊆-↓↓ : {op : Σₛ}
       {ops ops' : List Σₛ} →
       ops ⊆ ops' →
       ---------------------------------------------------------------
       op ∈ₒ proj₁ (reverse ops' ↓↓ₑ (⦃⦃ ops ↦ op ⦄⦄ₒ , ⦃⦃ ops ↦ op ⦄⦄ᵢ))

⊆-↓↓ {op} {ops} {ops'} [] =
  (↓↓ₑ-⊑ₒ (reverse ops')) op ⊆-↓↓-aux

  where
    ⊆-↓↓-aux : (if op ≡ op then just tt else nothing) ≡ just tt
    ⊆-↓↓-aux with decₛ op op
    ⊆-↓↓-aux | yes refl =
      refl
    ⊆-↓↓-aux | no ¬p =
      ⊥-elim (¬p refl)

⊆-↓↓ {op} (∷-≡ {op'} {ops} {ops'} p) =
  subst (λ ops'' → op ∈ₒ proj₁ (ops'' ↓↓ₑ (⦃⦃ (op' ∷ ops) ↦ op ⦄⦄ₒ , ⦃⦃ (op' ∷ ops) ↦ op ⦄⦄ᵢ)))
        (sym (unfold-reverse op' ops'))
        (subst (λ oi → op ∈ₒ proj₁ oi)
               (sym (↓↓ₑ-act (reverse ops') [ op' ]))
               (subst (λ oi → op ∈ₒ proj₁ (reverse ops' ↓↓ₑ oi))
                      (sym ↓ₑ-∅-↦-≡)
                      (⊆-↓↓ p)))

⊆-↓↓ {op} (∷-≢ {op'} {op''} {ops} {ops'} p q) =
  subst (λ ops'' → op ∈ₒ proj₁ (ops'' ↓↓ₑ (⦃⦃ (op' ∷ ops) ↦ op ⦄⦄ₒ , ⦃⦃ (op' ∷ ops) ↦ op ⦄⦄ᵢ)))
        (sym (unfold-reverse op'' ops'))
        (subst (λ oi → op ∈ₒ proj₁ oi)
               (sym (↓↓ₑ-act (reverse ops') [ op'' ]))
               (subst (λ oi → op ∈ₒ proj₁ (reverse ops' ↓↓ₑ oi))
                      (sym (↓ₑ-∅-↦-≢ p))
                      (⊆-↓↓ q)))

-- IF A PATH REVEALS A SIGNAL IN A UNION OF EFFECT ANNOTATIONS, THE PATH REVEALS THE SIGNAL IN ONE OF THE SUMMANDS

`at-⊎ : {op : Σₛ}
        {ops : List Σₛ}
        {o o' : O}
        {i i' : I} →
        op `at ops `in (o ∪ₒ o') , (i ∪ᵢ i') →
        -------------------------------------------------
        (op `at ops `in o , i) ⊎ (op `at ops `in o' , i')

`at-⊎ {op} {ops} {omap o} {omap o'} {i} {i'} (stop p) =
  `at-⊎-aux p (o op) (o' op) refl refl

  where
    `at-⊎-aux : (∪ₒ-aux o o' op ≡ just tt) →
                (t t' : Maybe ⊤) →
                o op ≡ t →
                o' op ≡ t' →
                -----------------------------------------------------------
                (op `at ops `in omap o , i) ⊎ (op `at ops `in omap o' , i')

    `at-⊎-aux p nothing nothing q r with o op | o' op
    `at-⊎-aux () nothing nothing q r | nothing | nothing
    `at-⊎-aux p nothing nothing q () | nothing | just tt
    `at-⊎-aux p nothing (just tt) q r =
      inj₂ (stop r)
    `at-⊎-aux p (just tt) t' q r =
      inj₁ (stop q)

`at-⊎ {op} {_} {o} {o'} {imap i} {imap i'} (next {o''} {o'''} {i''} {i'''} {op'} {ops} p q) =
  `at-⊎-aux p q (i op') (i' op') refl refl

  where
    `at-⊎-aux : ∪ᵢ-aux i i' op' ≡ just (o''' , i''') →
                op `at ops `in o''' , i''' →
                (oi oi' : Maybe (O × I)) →
                i op' ≡ oi →
                i' op' ≡ oi' →
                ---------------------------------------------------------------------------
                (op `at (op' ∷ ops) `in o , imap i) ⊎ (op `at (op' ∷ ops) `in o' , imap i')

    `at-⊎-aux p q nothing nothing r s with i op' | i' op'
    `at-⊎-aux () q nothing nothing r s | nothing | nothing
    `at-⊎-aux p q nothing nothing r () | nothing | just _
    `at-⊎-aux p q nothing (just (o'''' , i'''')) r s =
      inj₂ (next (trans (sym (`at-⊎-aux-aux r s)) p) q)

      where
        `at-⊎-aux-aux : i op' ≡ nothing →
                        i' op' ≡ just (o'''' , i'''') →
                        -------------------------------
                        ∪ᵢ-aux i i' op' ≡ i' op'

        `at-⊎-aux-aux r s with i op' | i' op'
        `at-⊎-aux-aux r s | nothing | just _ =
          refl

    `at-⊎-aux p q (just (o'''' , i'''')) nothing r s =
      inj₁ (next (trans (sym (`at-⊎-aux-aux r s)) p) q)

      where
        `at-⊎-aux-aux : i op' ≡ just (o'''' , i'''') →
                        i' op' ≡ nothing →
                        -------------------------------
                        ∪ᵢ-aux i i' op' ≡ i op'

        `at-⊎-aux-aux r s with i op' | i' op'
        `at-⊎-aux-aux r s | just _ | nothing =
          refl

    `at-⊎-aux p q (just (o'''' , i'''')) (just (o''''' , i''''')) r s
      with ∪ᵢ-∪ₒ {i = imap i} {i' = imap i'} p r s | ∪ᵢ-∪ᵢ {i = imap i} {i' = imap i'} p r s
    ... | refl | refl with `at-⊎ q
    ... | inj₁ t =
      inj₁ (next r t)
    ... | inj₂ t =
      inj₂ (next s t)

-- IF ACTING WITH A PATH REVEALS A SIGNAL, THEN THERE IS A SUBPATH TO THAT SIGNAL

↓↓-⊆-rw : (o : O)
          (i : I)
          (op : Σₛ)
          (ops : List Σₛ) →
          ----------------------------------------------------------------
          reverse (op ∷ ops) ↓↓ₑ (o , i) ≡ reverse ops ↓↓ₑ (op ↓ₑ (o , i))

↓↓-⊆-rw o i op ops =
  trans (cong (λ ops' → ops' ↓↓ₑ (o , i)) (unfold-reverse op ops))
        (↓↓ₑ-act (reverse ops) [ op ])

↓↓-⊆ : {op : Σₛ} →
       (ops : List Σₛ) →
       {o : O}
       {i : I} →
       op ∈ₒ proj₁ (reverse ops ↓↓ₑ (o , i)) →
       ----------------------------------------------------------
       Σ[ ops' ∈ List Σₛ ] (ops' ⊆ ops × (op `at ops' `in o , i))

↓↓-⊆ [] p =
  [] , [] , stop p
↓↓-⊆ {op} (op' ∷ ops) {omap o} {imap i} p rewrite ↓↓-⊆-rw (omap o) (imap i) op' ops =
  ↓↓-⊆-aux (i op') refl

  where
    ↓↓-⊆-aux : (oi : Maybe (O × I)) →
               i op' ≡ oi →
               ----------------------------------------------------------------------------
               Σ[ ops' ∈ List Σₛ ] (ops' ⊆ (op' ∷ ops) × (op `at ops' `in omap o , imap i))

    ↓↓-⊆-aux nothing q with ↓↓-⊆ ops p
    ... | ops' , r , s rewrite q =
      ops' , ∷-∷ r , s
    ↓↓-⊆-aux (just (omap o' , imap i')) q with ↓↓-⊆ ops p
    ... | ops' , r , s rewrite q with `at-⊎ {o = omap o} {o' = omap o'} {i' = imap i'} s
    ... | inj₁ t =
      ↓↓-⊆-aux-aux ops' r t

      where
        ↓↓-⊆-aux-aux : (ops' : List Σₛ) →
                       ops' ⊆ ops →
                       (op `at ops' `in omap o , ((imap i) [ op' ↦ nothing ]ᵢ)) →
                       -------------------------------------------------------------------------------
                       Σ[ ops'' ∈ List Σₛ ] (ops'' ⊆ (op' ∷ ops) × (op `at ops'' `in omap o , imap i))

        ↓↓-⊆-aux-aux [] r (stop t) =
          [] , [] , stop t
        ↓↓-⊆-aux-aux (op'' ∷ ops'') r (next t u) with decₛ op' op''
        ... | no ¬v =
          op'' ∷ ops'' , ∷-≢ (λ w → ¬v (sym w)) r , next t u

    ... | inj₂ t =
      op' ∷ ops' , ∷-≡ r , next q t

-- ENVELOPING THE EFFECT ANNOTATION REDUCTION WITH MLTIPLE INTERRUPT ACTIONS

{- LEMMA 4.5 -}

↓↓ₑ-⊑ₒ-act : {o : O}
             {i : I} →
             (ops : List Σₛ) →
             (op : Σₛ) →
             ----------------------------------------------------------
             proj₁ (ops ↓↓ₑ (o , i)) ⊑ₒ proj₁ (ops ↓↓ₑ (op ↓ₑ (o , i)))

↓↓ₑ-⊑ₒ-act {o} {i} ops op op' p rewrite sym (reverse-involutive ops) with ↓↓-⊆ (reverse ops) p
... | ops' , q , r with ⊆-↓↓ {op'} (∷-∷ {op} q)
... | s with ↓↓ₑ-monotonicₒ (reverse (op ∷ reverse ops)) (`at-minₒ r) (`at-minᵢ r) op' s
... | t rewrite ↓↓-⊆-rw o i op (reverse ops) | reverse-involutive ops = t


open import Formalization.PredicateLogic.Signature

module Formalization.PredicateLogic.Minimal.NaturalDeduction.Tree (𝔏 : Signature) where
open Signature(𝔏)

open import Data.DependentWidthTree as Tree hiding (height)
import      Lvl
open import Formalization.PredicateLogic.Minimal.NaturalDeduction (𝔏)
open import Formalization.PredicateLogic.Syntax(𝔏)
open import Functional using (_∘_ ; _∘₂_ ; _∘₃_ ; _∘₄_ ; swap ; _←_)
open import Numeral.Finite
open import Numeral.Natural.Relation.Order
open import Numeral.Natural
open import Sets.PredicateSet using (PredSet ; _∈_ ; _∉_ ; _∪_ ; _∪•_ ; _∖_ ; _⊆_ ; _⊇_ ; ∅ ; [≡]-to-[⊆] ; [≡]-to-[⊇] ; map ; unmap) renaming (•_ to · ; _≡_ to _≡ₛ_)
open import Structure.Relator
open import Type.Properties.Inhabited
open import Type

module _ {vars} ⦃ pos-term : ◊(Term(vars)) ⦄ where
  private variable ℓ : Lvl.Level
  private variable Γ Γ₁ Γ₂ : PredSet{ℓ}(Formula(vars))
  private variable φ ψ γ φ₁ ψ₁ γ₁ φ₂ ψ₂ γ₂ φ₃ ψ₃ φ₄ ψ₄ φ₅ ψ₅ δ₁ δ₂ : Formula(vars)

  {-
  height : Term(_) → (Γ ⊢ φ) → ℕ
  height t (direct p)         = 𝟎
  height t [⊤]-intro          = 𝟎
  height t ([∧]-intro  p q)   = 𝐒((height t p) ⦗ max ⦘ᵣ (height t q))
  height t ([∧]-elimₗ  p)     = 𝐒(height t p)
  height t ([∧]-elimᵣ  p)     = 𝐒(height t p)
  height t ([∨]-introₗ p)     = 𝐒(height t p)
  height t ([∨]-introᵣ p)     = 𝐒(height t p)
  height t ([∨]-elim   p q r) = 𝐒((height t p) ⦗ max ⦘ᵣ (height t q) ⦗ max ⦘ᵣ (height t r))
  height t ([⟶]-intro  p)     = 𝐒(height t p)
  height t ([⟶]-elim   p q)   = 𝐒((height t p) ⦗ max ⦘ᵣ (height t q))
  height t ([Ɐ]-intro  p)     = 𝐒(height t (p{t}))
  height t ([Ɐ]-elim   p)     = 𝐒(height t p)
  height t ([∃]-intro  p)     = 𝐒(height t p)
  height t ([∃]-elim   p q)   = 𝐒((height t (p{t})) ⦗ max ⦘ᵣ (height t q))

  test : ∀{t : Term(n)}{p q : Γ ⊢ φ} → (height t p ≤ height t ([∧]-intro p q))
  test = [≤]-successor max-orderₗ
  -}

  tree : (Γ ⊢ φ) → FiniteTreeStructure
  tree(direct x)         = Node 0 \()
  tree [⊤]-intro         = Node 0 \()
  tree([∧]-intro  p q)   = Node 2 \{𝟎 → tree p; (𝐒 𝟎) → tree q}
  tree([∧]-elimₗ  p)     = Node 1 \{𝟎 → tree p}
  tree([∧]-elimᵣ  p)     = Node 1 \{𝟎 → tree p}
  tree([∨]-introₗ p)     = Node 1 \{𝟎 → tree p}
  tree([∨]-introᵣ p)     = Node 1 \{𝟎 → tree p}
  tree([∨]-elim   p q r) = Node 3 \{𝟎 → tree p ; (𝐒 𝟎) → tree q ; (𝐒(𝐒 𝟎)) → tree r}
  tree([⟶]-intro  p)     = Node 1 \{𝟎 → tree p}
  tree([⟶]-elim   p q)   = Node 2 \{𝟎 → tree p ; (𝐒 𝟎) → tree q}
  tree([Ɐ]-intro  p)     = Node 1 \{𝟎 → tree (p{[◊]-existence})}
  tree([Ɐ]-elim   p)     = Node 1 \{𝟎 → tree p}
  tree([∃]-intro  p)     = Node 1 \{𝟎 → tree p}
  tree([∃]-elim   p q)   = Node 2 \{𝟎 → tree (p{[◊]-existence}) ; (𝐒 𝟎) → tree q}

  height : (Γ ⊢ φ) → ℕ
  height = Tree.height ∘ tree

  open import Data.Tuple as Tuple using (_⨯_ ; _,_)
  import      Functional.Dependent
  open        Functional using (_on₂_)
  open import Numeral.Natural.Induction
  open import Numeral.Natural.Inductions
  open import Numeral.Natural.Relation.Order.Proofs
  open import Structure.Relator.Ordering
  open import Structure.Relator.Ordering.Proofs
  open import Type.Dependent

  -- Ordering of natural deduction proofs on height.
  _<⊢↑_ : Σ(PredSet{ℓ}(Formula(vars)) ⨯ Formula(vars))(Tuple.uncurry(_⊢_)) → Σ(PredSet(Formula(vars)) ⨯ Formula(vars))(Tuple.uncurry(_⊢_)) → Type
  _<⊢↑_ = (_<_) on₂ (height Functional.Dependent.∘ Σ.right)

  instance
    [<⊢↑]-wellfounded : Strict.Properties.WellFounded(_<⊢↑_ {ℓ})
    [<⊢↑]-wellfounded = wellfounded-image-by-trans {f = height Functional.Dependent.∘ Σ.right}

  -- induction-on-height : ∀{P : ∀{Γ : PredSet{ℓₚ}(Formula(vars))}{φ} → (Γ ⊢ φ) → Type{ℓ}} → (∀{x : Prop(vars)} → P(direct x)) → P([⊤]-intro) → (∀{p₂ : Γ ⊢ φ} → (∀{Γ₁}{φ₁}{p₁ : Γ₁ ⊢ φ₁} → (height p₁ < height p₂) → P(p₁)) → P(p₂)) → (∀{p : (Γ ⊢ φ)} → P(p))
  -- induction-on-height {Γ = Γ}{φ = φ} {P = P} dir top step {p} = Strict.Properties.wellfounded-induction(_<⊢↑_) {P = P Functional.Dependent.∘ Σ.right} {!!} {intro (Γ , φ) p}

  -- substitute0-height : ∀{t} → height(substitute0 t φ) ≡


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

{- INDEX: Some constructions with non-recursive HITs,
   and related results.

   This formalization covers the hardest results of my
   paper titled "Constructions with non-recursive HITs".
   To be precise: I have formalized the result that all
   functions in the sequence of approximations (see Section 6)
   are weakly constant, and that the colimit is thus
   propositional. This requires a lot of lemmas. Some of
   these lemmas are trivial on paper and only tedious in Agda,
   but many lemmas are (at least for me) even on paper far
   from trivial.

   Formalized are Section 2, Section 3 (without the example
   applications), especially the first main result; all of
   Section 4 except Lemma 4.9, the definitions and principles
   of Section 5, all of Section 6 expect the last corollaries.

   The parts of the paper that are not formalized are
   (A) the examples in Section 3
   (B) the statements of remarks
   (C) Lemma 4.9, 5.4, 5.5, and 5.6
   (D) Theorem 5.7, Corollary 5.8, Theorem 6.2
   (E) the discussions and results in the concluding Section 7

   All of these are relatively easy compared with the results
   that are formalized. The items in (C) could be implemented
   easily, but are not very interesting on their own.
   The same is true for the second and third item in (D),
   which however depend on Theorem 5.7.
   Theorem 5.7 itself could be interesting to formalize.
   However, it relies on the main result of
       Capriotti, Kraus, Vezzosi,
       "Functions out of Higher Truncations".
   This result is formalized, but unfortunately in another
   library; thus, we omit Theorem 5.7 (for now) in the current
   formalization. (E) would require (D) first.

   This development type-checks with Agda 2.4.2.5 and similar
   versions (I assume with 2.4.2.x in general; same as the
   HoTT library).
-}

module nicolai.pseudotruncations.NONRECURSIVE-INDEX where

{- Some preliminary definitions/lemmas, and an explanation
   why we need to work with the spheres defined by suspension-
   iteration of the form
   Σ¹⁺ⁿ :≡ Σⁿ ∘ Σ -}
open import nicolai.pseudotruncations.Preliminary-definitions
open import nicolai.pseudotruncations.Liblemmas

{- SECTION 2
   The Sequential colimit. I am aware that there is some
   overlap with lib/types/NatColim.agda -}
open import nicolai.pseudotruncations.SeqColim

{- Here is some prepartion for Section 3 -}
open import nicolai.pseudotruncations.wconst-preparation

{- The rather lengthy argument that some heptagon commutes;
   very tedious; this is still preparation for Section 3 -}
open import nicolai.pseudotruncations.heptagon

{- SECTION 3 (without the sample applications)
   One result of the paper: If we have a sequence of weakly
   constant functions, then the colimit is propositional -}
open import nicolai.pseudotruncations.wconstSequence

{- SECTION 4
   The correspondance between loops and maps from spheres:
   a lot of tedious technical content. This was hard work for me!
   The results are in two files; first, essentially the fact that
   the 'pointed' 0-sphere [i.e. (bool, true)] is "as good as"
   the unit type if we consider pointed maps out of it.
   Second, the main lemmas. -}
open import nicolai.pseudotruncations.pointed-O-Sphere
open import nicolai.pseudotruncations.LoopsAndSpheres

{- SECTION 5 (mainly the definition and some auxiliary lemmas)
   Definition of pseudo-truncations -}
open import nicolai.pseudotruncations.PseudoTruncs

{- SECTION 6
   The sequence of approximations with increasing "connectedness-
   level", and the proof that every map is weakly constant,
   and the corollary that its colimit is propositional. -}
open import nicolai.pseudotruncations.PseudoTruncs-wconst-seq