{-# OPTIONS --cubical --safe --postfix-projections #-}

module Data.List.Relation.Binary.Permutation where

open import Prelude
open import Data.List
open import Data.Fin
open import Data.Fin.Properties
open import Data.List.Membership
open import Cubical.Foundations.Equiv
import Function.Isomorphism as Isomorphism
open import Relation.Binary
open import Cubical.Foundations.Prelude using (J; _∧_)
open import Cubical.Foundations.Transport using (isSet-subst)
open import Cubical.Data.Sigma.Properties
open import Data.Nat.Properties using (znots; snotz)

infixr 0 _↝_
_↝_ : {A : Type a} (xs ys : List A) → Type a
xs ↝ ys = ∀ x → x ∈ xs → x ∈ ys

infix 4 _↭_
_↭_ : {A : Type a} (xs ys : List A) → Type a
xs ↭ ys = ∀ x → (x ∈ xs) ⇔ (x ∈ ys)

reflₚ : ∀ {xs : List A} → xs ↭ xs
reflₚ _ = Isomorphism.refl-⇔

symₚ : {xs ys : List A} → xs ↭ ys → ys ↭ xs
symₚ xs↭ys x = Isomorphism.sym-⇔ (xs↭ys x)

transₚ : {xs ys zs : List A} → xs ↭ ys → ys ↭ zs → xs ↭ zs
transₚ xs↭ys ys↭zs x = Isomorphism.trans-⇔ (xs↭ys x) (ys↭zs x)

consₚ : ∀ x {xs ys : List A} → xs ↭ ys → x ∷ xs ↭ x ∷ ys
consₚ _ xs↭ys _ .fun       (f0   , x≡x )    = f0 , x≡x
consₚ _ xs↭ys _ .fun       (fs n  , x∈xs)    = push (xs↭ys _ .fun (n , x∈xs))
consₚ _ xs↭ys _ .inv       (f0   , x≡x )    = f0 , x≡x
consₚ _ xs↭ys _ .inv       (fs n  , x∈xs)    = push (xs↭ys _ .inv (n , x∈xs))
consₚ _ xs↭ys _ .leftInv   (f0   , x≡x)     = refl
consₚ _ xs↭ys _ .leftInv   (fs n  , x∈xs) i  = push (xs↭ys _ .leftInv (n , x∈xs) i)
consₚ _ xs↭ys _ .rightInv  (f0   , x≡x)     = refl
consₚ _ xs↭ys _ .rightInv  (fs n  , x∈xs) i  = push (xs↭ys _ .rightInv (n , x∈xs) i)

swapₚ-to : ∀ (x₁ x₂ : A) xs → x₁ ∷ x₂ ∷ xs ↝ x₂ ∷ x₁ ∷ xs
swapₚ-to _ _ _ _ (f0 , x≡x₁) = fs f0 , x≡x₁
swapₚ-to _ _ _ _ (fs f0 , x≡x₂) = f0 , x≡x₂
swapₚ-to _ _ _ _ (fs (fs n) , x∈xs) = fs (fs n) , x∈xs

swapₚ-inv : ∀ (x₁ x₂ : A) xs x x∈xs → swapₚ-to x₂ x₁ xs x (swapₚ-to x₁ x₂ xs x x∈xs) ≡ x∈xs
swapₚ-inv _ _ _ _ (f0 , x≡x₁) = refl
swapₚ-inv _ _ _ _ (fs f0 , x≡x₂) = refl
swapₚ-inv _ _ _ _ (fs (fs n) , x∈xs) = refl

swapₚ : ∀ x₁ x₂ (xs : List A) → x₁ ∷ x₂ ∷ xs ↭ x₂ ∷ x₁ ∷ xs
swapₚ x₁ x₂ xs x .fun = swapₚ-to x₁ x₂ xs x
swapₚ x₁ x₂ xs x .inv = swapₚ-to x₂ x₁ xs x
swapₚ x₁ x₂ xs x .leftInv  = swapₚ-inv x₁ x₂ xs x
swapₚ x₁ x₂ xs x .rightInv = swapₚ-inv x₂ x₁ xs x

Fin-length : (xs : List A) → ∃ x × (x ∈ xs) ⇔ Fin (length xs)
Fin-length xs .inv n = xs ! n , n , refl
Fin-length xs .fun (x , n , p) = n
Fin-length xs .leftInv (x , n , p) i .fst = p i
Fin-length xs .leftInv (x , n , p) i .snd .fst = n
Fin-length xs .leftInv (x , n , p) i .snd .snd j = p (i ∧ j)
Fin-length xs .rightInv n = refl

Fin-length-cong : (xs ys : List A) →
                xs ↭ ys →
                Fin (length xs) ⇔ Fin (length ys)
Fin-length-cong xs ys xs↭ys =
  sym-⇔ (Fin-length xs) ⟨ trans-⇔ ⟩ iso-Σ xs↭ys ⟨ trans-⇔ ⟩ Fin-length ys

index-commutes : ∀ (x : A) xs ys →
                 (xs↭ys : xs ↭ ys) (x∈xs : x ∈ xs) →
                 fst (xs↭ys x .fun x∈xs) ≡ Fin-length-cong xs ys xs↭ys .fun (x∈xs .fst)
index-commutes x xs ys xs↭ys (n , p) =
  J (λ y y∈xs → xs↭ys y .fun (n , y∈xs) .fst ≡ xs↭ys (xs ! n) .fun (n , refl) .fst) refl p

index-equality-preserved : ∀ (x : A) xs ys (p q : x ∈ xs) →
                           (xs↭ys : xs ↭ ys) →
                           fst p ≡ fst q →
                           xs↭ys x .fun p .fst ≡ xs↭ys x .fun q .fst
index-equality-preserved x xs ys p q xs↭ys ip≡iq =
  xs↭ys x .fun p .fst ≡⟨ index-commutes x xs ys xs↭ys p ⟩
  Fin-length-cong xs ys xs↭ys .fun (p .fst) ≡⟨ cong (Fin-length-cong xs ys xs↭ys .fun) ip≡iq ⟩
  Fin-length-cong xs ys xs↭ys .fun (q .fst) ≡˘⟨ index-commutes x xs ys xs↭ys q ⟩
  xs↭ys x .fun q .fst ∎
  where open import Path.Reasoning

perm-inj : ∀ (x : A) xs ys n →
         (xs↭ys : x ∷ xs ↭ x ∷ ys) →
         ∀ z
         (z∈ys : x ≡ z)
         (x∈ys : x ≡ z)
         (z∈xs : xs ! n ≡ z)
         (p₁ : xs↭ys z .fun (fs n , z∈xs) ≡ (f0 , z∈ys))
         (p₂ : xs↭ys z .fun (f0 , z∈ys) ≡ (f0 , x∈ys)) →
         ⊥
perm-inj x xs ys n xs↭ys z z∈ys x∈ys z∈xs p₁ p₂ = znots (cong FinToℕ p₆)
  where
  open import Path.Reasoning

  p₃ = fs n , z∈xs ≡˘⟨ xs↭ys z .leftInv (fs n , z∈xs) ⟩
       xs↭ys z .inv (xs↭ys z .fun (fs n , z∈xs)) ≡⟨ cong (xs↭ys z .inv) p₁ ⟩
       xs↭ys z .inv (f0 , z∈ys) ∎

  p₄ = f0 , z∈ys ≡˘⟨ xs↭ys z .leftInv (f0 , z∈ys) ⟩
       xs↭ys z .inv (xs↭ys z .fun (f0 , z∈ys)) ≡⟨ cong (xs↭ys z .inv) p₂ ⟩
       xs↭ys z .inv (f0 , x∈ys) ∎

  p₅ = index-equality-preserved z (x ∷ ys) (x ∷ xs) (f0 , x∈ys) (f0 , z∈ys) (sym-⇔ ∘ xs↭ys) refl

  p₆ = f0 ≡⟨ cong fst p₄ ⟩
       xs↭ys z .inv (f0 , x∈ys) .fst ≡⟨ p₅ ⟩
       xs↭ys z .inv (f0 , z∈ys) .fst ≡˘⟨ cong fst p₃ ⟩
       fs n ∎

tailₚ-to : ∀ x (xs ys : List A) → x ∷ xs ↭ x ∷ ys → ∀ z → z ∈ xs → z ∈ ys
tailₚ-to x xs ys xs↭ys z (n , z∈xs) with xs↭ys z .fun (fs n , z∈xs) | inspect (xs↭ys z .fun) (fs n , z∈xs)
... | fs m , z∈ys | _ = m , z∈ys
... | f0 , z∈ys | 〖 p₁ 〗 with xs↭ys z .fun (f0 , z∈ys) | inspect (xs↭ys z .fun) (f0 , z∈ys)
... | fs o , x∈ys | _ = o , x∈ys
... | f0 , x∈ys | 〖 p₂ 〗 = ⊥-elim (perm-inj x xs ys n xs↭ys z z∈ys x∈ys z∈xs p₁ p₂)

pred-∈-eq : ∀ (x y : A) xs i j →
          (x∈xs₁ : xs ! i ≡ x) →
          (x∈xs₂ : xs ! j ≡ x) →
          Path (x ∈ y ∷ xs) (fs i , x∈xs₁) (fs j , x∈xs₂) →
          (i , x∈xs₁) ≡ (j , x∈xs₂)
pred-∈-eq x y xs i j x∈xs₁ x∈xs₂ =
  J (λ { (fs n , x∈xs₃) _ → (i , x∈xs₁) ≡ (n , x∈xs₃)
       ; (f0     , x∈xs₃) → ⊥-elim ∘ snotz ∘ cong FinToℕ ∘ cong fst })
  refl

open import Path.Reasoning

tailₚ-inv : ∀ x (xs ys : List A) →
            (xs↭ys : x ∷ xs ↭ x ∷ ys) →
            ∀ z (i : z ∈ ys) →
            tailₚ-to x xs ys xs↭ys z (tailₚ-to x ys xs (sym-⇔ ∘ xs↭ys) z i)  ≡ i
tailₚ-inv x xs ys xs↭ys z (n , z∈ys) with xs↭ys z .inv (fs n , z∈ys) | inspect (xs↭ys z .inv) (fs n , z∈ys)
... | fs m , z∈xs  | 〖 p₁ 〗 with xs↭ys z .fun (fs m , z∈xs) | inspect (xs↭ys z .fun) (fs m , z∈xs)
... | fs o , z∈ys₂ | 〖 p₂ 〗 = pred-∈-eq z x ys o n z∈ys₂ z∈ys p₃

  where p₃ = fs o , z∈ys₂ ≡˘⟨ p₂ ⟩
             xs↭ys z .fun (fs m , z∈xs) ≡˘⟨ cong (xs↭ys z .fun) p₁ ⟩
             xs↭ys z .fun (xs↭ys z .inv (fs n , z∈ys)) ≡⟨ xs↭ys z .rightInv (fs n , z∈ys) ⟩
             fs n , z∈ys ∎

... | f0     , z∈ys₂ | 〖 p₂ 〗 with xs↭ys z .fun (f0 , z∈ys₂) | inspect (xs↭ys z .fun) (f0 , z∈ys₂)
... | f0     , x∈ys₃ | 〖 p₃ 〗 = ⊥-elim (perm-inj x xs ys m xs↭ys z z∈ys₂ x∈ys₃ z∈xs p₂ p₃)
... | fs o , x∈ys₃ | 〖 p₃ 〗 = ⊥-elim (snotz (cong (FinToℕ ∘ fst) p₄))

  where p₄ = fs n , z∈ys ≡˘⟨ xs↭ys z .rightInv (fs n , z∈ys) ⟩
             xs↭ys z .fun (xs↭ys z .inv (fs n , z∈ys)) ≡⟨ cong (xs↭ys z .fun) p₁ ⟩
             xs↭ys z .fun (fs m , z∈xs) ≡⟨ p₂ ⟩
             f0 , z∈ys₂ ∎

tailₚ-inv x xs ys xs↭ys z (n , z∈ys) | f0 , z∈xs | 〖 p₁ 〗
  with xs↭ys z .inv (f0 , z∈xs) | inspect (xs↭ys z .inv) (f0 , z∈xs)
... | f0     , z∈ys₂ | 〖 p₂ 〗 = ⊥-elim (perm-inj x ys xs n (sym-⇔ ∘ xs↭ys) z z∈xs z∈ys₂ z∈ys p₁ p₂)
... | fs o , z∈ys₂ | 〖 p₂ 〗 with xs↭ys z .fun (fs o , z∈ys₂) | inspect (xs↭ys z .fun) (fs o , z∈ys₂)
... | fs m , z∈ys₃ | 〖 p₃ 〗 = ⊥-elim (snotz (cong (FinToℕ ∘ fst) p₄))

  where p₄ = fs m , z∈ys₃ ≡˘⟨ p₃ ⟩
             xs↭ys z .fun (fs o , z∈ys₂) ≡˘⟨ cong (xs↭ys z .fun) p₂ ⟩
             xs↭ys z .fun (xs↭ys z .inv (f0 , z∈xs)) ≡⟨ xs↭ys z .rightInv (f0 , z∈xs) ⟩
             f0 , z∈xs ∎

... | f0     , z∈ys₃ | 〖 p₃ 〗 with xs↭ys z .fun (f0 , z∈ys₃) | inspect (xs↭ys z .fun) (f0 , z∈ys₃)
... | f0     , z∈ys₄ | 〖 p₄ 〗 = ⊥-elim (perm-inj x xs ys o xs↭ys z z∈ys₃ z∈ys₄ z∈ys₂ p₃ p₄)
... | fs l , z∈ys₄ | 〖 p₄ 〗 = pred-∈-eq z x ys l n z∈ys₄ z∈ys p₇
  where

  p₅ : Path (z ∈ x ∷ ys) (f0 , z∈xs) (f0 , z∈ys₃)
  p₅ = (f0 , z∈xs) ≡˘⟨ xs↭ys z .rightInv (f0 , z∈xs) ⟩
       xs↭ys z .fun (xs↭ys z .inv (f0 , z∈xs)) ≡⟨ cong (xs↭ys z .fun) p₂ ⟩
       xs↭ys z .fun (fs o , z∈ys₂) ≡⟨ p₃ ⟩
       (f0 , z∈ys₃) ∎

  p₆ = z∈xs ≡˘⟨ isSet-subst {B = λ n → (x ∷ ys) ! n ≡ z} (Discrete→isSet discreteFin) (cong fst p₅) z∈xs ⟩
       subst (λ n → (x ∷ ys) ! n ≡ z) (cong fst p₅) z∈xs
     ≡⟨ PathΣ→ΣPathTransport (f0 , z∈xs) (f0 , z∈ys₃) p₅ .snd ⟩
       z∈ys₃ ∎

  p₇ = fs l , z∈ys₄ ≡˘⟨ p₄ ⟩
       xs↭ys z .fun (f0 , z∈ys₃) ≡˘⟨ cong (xs↭ys z .fun ∘ _,_ f0) p₆ ⟩
       xs↭ys z .fun (f0 , z∈xs) ≡˘⟨ cong (xs↭ys z .fun) p₁ ⟩
       xs↭ys z .fun (xs↭ys z .inv (fs n , z∈ys)) ≡⟨ xs↭ys z .rightInv (fs n , z∈ys) ⟩
       fs n , z∈ys ∎

tailₚ : ∀ x (xs ys : List A) →
        x ∷ xs ↭ x ∷ ys →
        xs ↭ ys
tailₚ x xs ys x∷xs↭x∷ys k .fun = tailₚ-to x xs ys x∷xs↭x∷ys k
tailₚ x xs ys x∷xs↭x∷ys k .inv = tailₚ-to x ys xs (sym-⇔ ∘ x∷xs↭x∷ys) k
tailₚ x xs ys x∷xs↭x∷ys k .rightInv = tailₚ-inv x xs ys x∷xs↭x∷ys k
tailₚ x xs ys x∷xs↭x∷ys k .leftInv  v = cong (λ z → tailₚ-to x ys xs (sym-⇔ ∘ x∷xs↭x∷ys) k (tailₚ-to x xs ys z k v)) (funExt (λ h → sym (sym-sym-iso (x∷xs↭x∷ys h)) ))  ; tailₚ-inv x ys xs (sym-⇔ ∘ x∷xs↭x∷ys) k v


module UnifyTerm where

open import Data.Fin using (Fin; suc; zero)
open import Data.Nat using (ℕ; suc; zero)
open import Relation.Binary.PropositionalEquality using (_≡_; refl; cong₂; cong; sym; trans)
open import Function using (_∘_)
open import Relation.Nullary using (¬_; Dec; yes; no)
open import Data.Product using (∃; _,_; _×_)
open import Data.Empty using (⊥-elim)

data Term (n : ℕ) : Set where
  i : (x : Fin n) -> Term n
  leaf : Term n
  _fork_ : (s t : Term n) -> Term n

_~>_ : (m n : ℕ) -> Set
m ~> n = Fin m -> Term n

▹ : ∀ {m n} -> (r : Fin m -> Fin n) -> Fin m -> Term n
▹ r = i ∘ r

_◃_ : ∀ {m n} -> (f : m ~> n) -> Term m -> Term n
f ◃ i x = f x
f ◃ leaf = leaf
f ◃ (s fork t) = (f ◃ s) fork (f ◃ t)

_≐_ : {m n : ℕ} -> (Fin m -> Term n) -> (Fin m -> Term n) -> Set
f ≐ g = ∀ x -> f x ≡ g x

◃ext : ∀ {m n} {f g : Fin m -> Term n} -> f ≐ g -> ∀ t -> f ◃ t ≡ g ◃ t
◃ext p (i x) = p x
◃ext p leaf = refl
◃ext p (s fork t) = cong₂ _fork_ (◃ext p s) (◃ext p t)

_◇_ : ∀ {l m n : ℕ } -> (f : Fin m -> Term n) (g : Fin l -> Term m) -> Fin l -> Term n
f ◇ g = (f ◃_) ∘ g

≐-cong : ∀ {m n o} {f : m ~> n} {g} (h : _ ~> o) -> f ≐ g -> (h ◇ f) ≐ (h ◇ g)
≐-cong h f≐g t = cong (h ◃_) (f≐g t)

≐-sym : ∀ {m n} {f : m ~> n} {g} -> f ≐ g -> g ≐ f
≐-sym f≐g = sym ∘ f≐g

module Sub where
  fact1 : ∀ {n} -> (t : Term n) -> i ◃ t ≡ t
  fact1 (i x) = refl
  fact1 leaf = refl
  fact1 (s fork t) = cong₂ _fork_ (fact1 s) (fact1 t)

  fact2 : ∀ {l m n} -> (f : Fin m -> Term n) (g : _) (t : Term l)
    -> (f ◇ g) ◃ t ≡ f ◃ (g ◃ t)
  fact2 f g (i x) = refl
  fact2 f g leaf = refl
  fact2 f g (s fork t) = cong₂ _fork_ (fact2 f g s) (fact2 f g t)

  fact3 : ∀ {l m n} (f : Fin m -> Term n) (r : Fin l -> Fin m) -> (f ◇ (▹ r)) ≡ (f ∘ r)
  fact3 f r = refl -- ext (λ _ -> refl)

◃ext' : ∀ {m n o} {f : Fin m -> Term n}{g : Fin m -> Term o}{h} -> f ≐ (h ◇ g) -> ∀ t -> f ◃ t ≡ h ◃ (g ◃ t)
◃ext' p t = trans (◃ext p t) (Sub.fact2 _ _ t)
s : ℕ -> ℕ
s = suc

thin : ∀ {n} -> (x : Fin (s n)) (y : Fin n) -> Fin (s n)
thin zero y = suc y
thin (suc x) zero = zero
thin (suc x) (suc y) = suc (thin x y)

p : ∀ {n} -> Fin (suc (suc n)) -> Fin (suc n)
p (suc x) = x
p zero = zero

module Thin where
  fact1 : ∀ {n} x y z -> thin {n} x y ≡ thin x z -> y ≡ z
  fact1 zero y .y refl = refl
  fact1 (suc x) zero zero r = refl
  fact1 (suc x) zero (suc z) ()
  fact1 (suc x) (suc y) zero ()
  fact1 (suc x) (suc y) (suc z) r = cong suc (fact1 x y z (cong p r))

  fact2 : ∀ {n} x y -> ¬ thin {n} x y ≡ x
  fact2 zero y ()
  fact2 (suc x) zero ()
  fact2 (suc x) (suc y) r = fact2 x y (cong p r)

  fact3 : ∀{n} x y -> ¬ x ≡ y -> ∃ λ y' -> thin {n} x y' ≡ y
  fact3 zero zero ne = ⊥-elim (ne refl)
  fact3 zero (suc y) _ = y , refl
  fact3 {zero} (suc ()) _ _
  fact3 {suc n} (suc x) zero ne = zero , refl
  fact3 {suc n} (suc x) (suc y) ne with y | fact3 x y (ne ∘ cong suc)
  ... | .(thin x y') | y' , refl = suc y' , refl

open import Data.Maybe
open import Category.Functor
open import Category.Monad
import Level
open RawMonad (Data.Maybe.monad {Level.zero})

thick : ∀ {n} -> (x y : Fin (suc n)) -> Maybe (Fin n)
thick zero zero = nothing
thick zero (suc y) = just y
thick {zero} (suc ()) _
thick {suc _} (suc x) zero = just zero
thick {suc _} (suc x) (suc y) = suc <$> (thick x y)

open import Data.Sum

_≡Fin_ : ∀ {n} -> (x y : Fin n) -> Dec (x ≡ y)
zero ≡Fin zero = yes refl
zero ≡Fin suc y = no λ ()
suc x ≡Fin zero = no λ ()
suc {suc _} x ≡Fin suc y with x ≡Fin y
...              | yes r = yes (cong suc r)
...              | no r = no λ e -> r (cong p e)
suc {zero} () ≡Fin _

module Thick where
  half1 : ∀ {n} (x : Fin (suc n)) -> thick x x ≡ nothing
  half1 zero = refl
  half1 {suc _} (suc x) = cong (_<$>_ suc) (half1 x)
  half1 {zero} (suc ())

  half2 : ∀ {n} (x : Fin (suc n)) y -> ∀ y' -> thin x y' ≡ y -> thick x y ≡ just y'
  half2 zero zero y' ()
  half2 zero (suc y) .y refl = refl
  half2 {suc n} (suc x) zero zero refl = refl
  half2 {suc _} (suc _) zero (suc _) ()
  half2 {suc n} (suc x) (suc y) zero ()
  half2 {suc n} (suc x) (suc .(thin x y')) (suc y') refl with thick x (thin x y') | half2 x (thin x y') y' refl
  ...                                                       | .(just y')          | refl = refl
  half2 {zero} (suc ()) _ _ _

  fact1 : ∀ {n} (x : Fin (suc n)) y r
    -> thick x y ≡ r
    -> x ≡ y × r ≡ nothing ⊎ ∃ λ y' -> thin x y' ≡ y × r ≡ just y'
  fact1 x y .(thick x y) refl with x ≡Fin y
  fact1 x .x ._ refl | yes refl = inj₁ (refl , half1 x)
  ... | no el with Thin.fact3 x y el
  ...            | y' , thinxy'=y = inj₂ (y' , ( thinxy'=y , half2 x y y' thinxy'=y ))

check : ∀{n} (x : Fin (suc n)) (t : Term (suc n)) -> Maybe (Term n)
check x (i y) = i <$> thick x y
check x leaf = just leaf
check x (s fork t) = _fork_ <$> check x s ⊛ check x t

_for_ : ∀ {n} (t' : Term n) (x : Fin (suc n)) -> Fin (suc n) -> Term n
(t' for x) y = maybe′ i t' (thick x y)

data AList : ℕ -> ℕ -> Set where
  anil : ∀ {n} -> AList n n
  _asnoc_/_ : ∀ {m n} (σ : AList m n) (t' : Term m) (x : Fin (suc m))
               -> AList (suc m) n

sub : ∀ {m n} (σ : AList m n) -> Fin m -> Term n
sub anil = i
sub (σ asnoc t' / x) = sub σ ◇ (t' for x)

_++_ : ∀ {l m n} (ρ : AList m n) (σ : AList l m) -> AList l n
ρ ++ anil = ρ
ρ ++ (σ asnoc t' / x) = (ρ ++ σ) asnoc t' / x

++-assoc : ∀ {l m n o} (ρ : AList l m) (σ : AList n _) (τ : AList o _) -> ρ ++ (σ ++ τ) ≡ (ρ ++ σ) ++ τ
++-assoc ρ σ anil = refl
++-assoc ρ σ (τ asnoc t / x) = cong (λ s -> s asnoc t / x) (++-assoc ρ σ τ)

module SubList where
  anil-id-l : ∀ {m n} (σ : AList m n) -> anil ++ σ ≡ σ
  anil-id-l anil = refl
  anil-id-l (σ asnoc t' / x) = cong (λ σ -> σ asnoc t' / x) (anil-id-l σ)

  fact1 : ∀ {l m n} (ρ : AList m n) (σ : AList l m) -> sub (ρ ++ σ) ≐ (sub ρ ◇ sub σ)
  fact1 ρ anil v = refl
  fact1 {suc l} {m} {n} r (s asnoc t' / x) v = trans hyp-on-terms ◃-assoc
    where
      t = (t' for x) v
      hyp-on-terms = ◃ext (fact1 r s) t
      ◃-assoc = Sub.fact2 (sub r) (sub s) t

_∃asnoc_/_ : ∀ {m} (a : ∃ (AList m)) (t' : Term m) (x : Fin (suc m))
  -> ∃ (AList (suc m))
(n , σ) ∃asnoc t' / x = n , σ asnoc t' / x

flexFlex : ∀ {m} (x y : Fin m) -> ∃ (AList m)
flexFlex {suc m} x y with thick x y
...              | just y' = m , anil asnoc i y' / x
...              | nothing = suc m , anil
flexFlex {zero} () _

flexRigid : ∀ {m} (x : Fin m) (t : Term m) -> Maybe (∃(AList m))
flexRigid {suc m} x t with check x t
...                   | just t' = just (m , anil asnoc t' / x)
...                   | nothing = nothing
flexRigid {zero} () _


record R (X : Set) : Set₁ where
  field
    P : X → Set
    f : ∀ {x : X} → P x → P x

open R {{…}}

test : ∀ {X} {{r : R X}} {x : X} → P x → P x
test p = f p

-- WAS: instance search fails with several candidates left
-- SHOULD: succeed


module Data.Word32 where

open import Data.Bool
open import Data.Char

{-#
  FOREIGN GHC

  import Data.Bits
  import Data.Word

  data Byte = Byte Bool Bool Bool Bool Bool Bool Bool Bool
  data Bytes = Bytes Byte Byte Byte Byte

  byteToWord8 :: Byte -> Word8
  byteToWord8 (Byte b0 b1 b2 b3 b4 b5 b6 b7) =
    boolToBit b0 0 + boolToBit b1 1 + boolToBit b2 2 + boolToBit b3 3 +
    boolToBit b4 4 + boolToBit b5 5 + boolToBit b6 6 + boolToBit b7 7
    where
      boolToBit b i = if b then bit i else 0

  word8ToByte :: Word8 -> Byte
  word8ToByte w =
    Byte
      (testBit w 0) (testBit w 1) (testBit w 2) (testBit w 3)
      (testBit w 4) (testBit w 5) (testBit w 6) (testBit w 7)

  bytesToWord32 :: Bytes -> Word32
  bytesToWord32 (Bytes b0 b1 b2 b3) =
    byteToWordShifted b0 0 + byteToWordShifted b1 1 + byteToWordShifted b2 2 + byteToWordShifted b3 3
    where
      byteToWordShifted :: Byte -> Int -> Word32
      byteToWordShifted b i = shift (fromIntegral $ byteToWord8 b) (i * 8)

  word32ToBytes :: Word32 -> Bytes
  word32ToBytes w = Bytes (getByte w 0) (getByte w 1) (getByte w 2) (getByte w 3)
    where
      getByte :: Word32 -> Int -> Byte
      getByte w i = word8ToByte $ fromIntegral (shift w (-i * 8))

  bytesToChar :: Bytes -> Char
  bytesToChar = toEnum . fromIntegral . bytesToWord32

  charToBytes :: Char -> Bytes
  charToBytes = word32ToBytes . fromIntegral . fromEnum
#-}

data Byte : Set where
  mkByte : Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Byte

data Word32 : Set where
  mkWord32 : Byte -> Byte -> Byte -> Byte -> Word32

{-# COMPILE GHC Byte = data Byte (Byte) #-}
{-# COMPILE GHC Word32 = data Bytes (Bytes) #-}

postulate
  bytesToChar : Word32 -> Char
  charToBytes : Char -> Word32

{-# COMPILE GHC bytesToChar = bytesToChar #-}
{-# COMPILE GHC charToBytes = charToBytes #-}

word32ToChar : Word32 -> Char
word32ToChar = bytesToChar

charToWord32 : Char -> Word32
charToWord32 = charToBytes


module Thesis.ANormalCTerm where

open import Thesis.ANormalDTerm

-- OK, this is all cool, but let's drop all this typing.
data CType : Set where
  cache : CType
  input : Type → CType

open import Data.Product

⟦_⟧CType : CType → Set
-- This is a lie, since we might need to store more complex values in there,
-- including caches...
⟦ cache ⟧CType = Σ[ τ ∈ Type ] ⟦ τ ⟧Type
-- However, this is more correct but is not recognized as terminating.
-- ⟦ cache ⟧CType = Σ[ τ ∈ CType ] ⟦ τ ⟧CType
-- Finally, this definition is too impredicative for Agda to accept it. If
-- ⟦_⟧CType lived in Set₁, it could still not contain values of itself.
-- ⟦ cache ⟧CType = Σ[ S ∈ Set ] S
⟦ input τ ⟧CType = ⟦ τ ⟧Type

-- Maybe step-indexing to the rescue. Really not sure how to step-index the theorems?
-- Maybe compute the needed index while running the base program?
open import Data.Nat
⟦_⟧CTypeN : CType → ℕ → Set
⟦ input τ ⟧CTypeN n = ⟦ τ ⟧Type
⟦ cache ⟧CTypeN 0 = ⊤
⟦ cache ⟧CTypeN (suc n) = Σ[ τ ∈ CType ] ⟦ τ ⟧CTypeN n

-- To top it off, maybe add constructor tcache : CType × ℕ → Type t? Hm, guess
-- that would loop. Just use big-step semantics then.

open import Base.Syntax.Context CType using () renaming (Context to CCtx)
open import Base.Denotation.Environment CType ⟦_⟧CType using () renaming (⟦_⟧Context to ⟦_⟧CCtx)

-- I must merge caches and normal types. So I must step-index types?
data CTerm : (C CFin : CCtx) (Δ : Context) (τ : Type) → Set where
  cvar : ∀ {CFin Δ τ} (x : Var Δ τ) →
    CTerm CFin CFin Δ τ
  clett : ∀ {C CFin Δ τ σ τ₁} →
    (f : Var Δ (σ ⇒ τ₁)) →
     -- XXX: (f : Var Δ (σ ⇒ (pair τ₁ cache))) →
    (x : Var Δ σ) →
    -- XXX pretend we only store integers. We should instead use a separate type of caches.
    (ct : CTerm (cache • C) CFin (τ₁ • Δ) τ) →
    CTerm C CFin Δ τ

-- Rather bogus: the contexts are unchanged. Our functions have a different type here!
⟦_⟧CTerm : ∀ {C CFin Δ τ} → CTerm C CFin Δ τ → ⟦ Δ ⟧Context → ⟦ C ⟧CCtx → (⟦ τ ⟧Type × ⟦ CFin ⟧CCtx)
⟦ cvar x ⟧CTerm ρ c = ⟦ x ⟧Var ρ , c
⟦ clett f x ct ⟧CTerm ρ c =
  let v = ⟦ f ⟧Var ρ (⟦ x ⟧Var ρ)
  in ⟦ ct ⟧CTerm (v • ρ) ((_ , v) • c)

cache-term-cps : ∀ {Δ σ} {Z : Set} → (t : Term Δ σ) → ∀ C → (∀ CFin → CTerm C CFin Δ σ → Z) → Z
cache-term-cps (var x) C k = k C (cvar x)
cache-term-cps (lett f x t) C k = cache-term-cps t (cache • C) (λ CFin ct → k CFin (clett f x ct))

cache-term-Σ : ∀ {Δ σ} → (t : Term Δ σ) → ∀ C → Σ[ CFin ∈ CCtx ] CTerm C CFin Δ σ
cache-term-Σ (var x) CFin = CFin , cvar x
cache-term-Σ (lett f x t) C =
  let CFin , ct = cache-term-Σ t (cache • C)
  in CFin , clett f x ct
-- clett f x (cache-term t)
-- -- ⟦_⟧CType : Type → Context → Set
-- -- ⟦ σ ⇒ τ ⟧CType C = {!!}
-- -- ⟦ pair σ τ ⟧CType C = {!!}
-- -- ⟦ sum σ τ ⟧CType C = {!!}
-- -- ⟦ unit ⟧CType C = ⟦ unit ⟧Type × ⟦ C ⟧Context
-- -- ⟦ int ⟧CType C = {!!}

-- data CFun (C CFin : Context) : (Δ : Context) (τ : Type) → Set where
--   cabs : ∀ {σ τ Δ} → CFun (σ • C) CFin (σ • Δ) τ → CFun C CFin Δ (σ ⇒ τ)
--   cterm : ∀ {τ Δ} → CTerm C CFin Δ τ → CFun C CFin Δ τ

-- -- Ouch, this is a lie.... We'd need a different type structure.
-- ⟦_⟧CFun : ∀ {C CFin Δ τ} → CFun C CFin Δ τ → ⟦ Δ ⟧Context → ⟦ C ⟧Context → (⟦ τ ⟧Type × ⟦ CFin ⟧Context)
-- ⟦ cabs cf ⟧CFun ρ c = (λ v → proj₁ (⟦ cf ⟧CFun (v • ρ) (v • c))) , {!!}
-- ⟦ cterm ct ⟧CFun ρ c = ⟦ ct ⟧CTerm ρ c

-- ⟦_⟧CFun2 : ∀ {C CFin Δ σ τ} → CFun C CFin Δ (σ ⇒ τ) → ⟦ Δ ⟧Context → ⟦ C ⟧Context → ⟦ σ ⟧Type → (⟦ τ ⟧Type × ⟦ CFin ⟧Context)
-- ⟦ cabs cf ⟧CFun2 ρ c = λ v → (⟦ cf ⟧CFun (v • ρ) (v • c))
-- -- (λ v → proj₁ (⟦ cf ⟧CFun (v • ρ) (v • c))) , {!!}
-- ⟦ cterm ct ⟧CFun2 ρ c = {! ⟦ ct ⟧CTerm ρ c!}

-- Above we run into the usual problems with nested caching.
data CFunR (C CFin : CCtx) : (Δ : Context) (τ : Type) → Set where
  cabsterm : ∀ {σ τ Δ} → CTerm (input σ • C) CFin (σ • Δ) τ → CFunR C CFin Δ (σ ⇒ τ)

⟦_⟧CFunR : ∀ {C CFin Δ σ τ} → CFunR C CFin Δ (σ ⇒ τ) → ⟦ Δ ⟧Context → ⟦ C ⟧CCtx → ⟦ σ ⟧Type → (⟦ τ ⟧Type × ⟦ CFin ⟧CCtx)
⟦ cabsterm ct ⟧CFunR ρ c v = ⟦ ct ⟧CTerm (v • ρ) (v • c)

-- IMPORTANT: Here we need different change types:
ΔτC : Type → Type
ΔτC (σ ⇒ τ) = ΔτC σ ⇒ ΔτC τ
ΔτC unit = unit
ΔτC int = int
ΔτC (pair σ τ) = pair (ΔτC σ) (ΔτC τ)
ΔτC (sum σ τ) = sum (sum (ΔτC σ) (ΔτC τ)) (sum σ τ)

ΔΔC : Context → Context
ΔΔC ∅ = ∅
ΔΔC (τ • Γ) = ΔτC τ • ΔΔC Γ

derive-dcvar : ∀ {Δ σ} → (x : Var Δ σ) → Var (ΔΔC Δ) (ΔτC σ)
derive-dcvar this = this
derive-dcvar (that x) = that (derive-dcvar x)

-- REAL BULLSHIT
-- XXX Not accounted for: derivatives also take caches!
-- C: accumulated caches. CFin: the ones we have at the end.
data CDTerm : (C CFin : CCtx) (Δ : Context) (τ : Type) → Set where
  cdvar : ∀ {CFin Δ τ} (x : Var (ΔΔC Δ) (ΔτC τ)) →
    CDTerm CFin CFin Δ τ
  cdlett : ∀ {C CFin Δ τ σ τ₁} →
    -- Here, we also need to pass (and update) the RIGHT cache. Otherwise
    -- there's no point.
    (df : Var (ΔΔC Δ) (ΔτC (σ ⇒ τ₁))) →
    (dx : Var (ΔΔC Δ) (ΔτC σ)) →
    (dt : CDTerm (cache • C) CFin (τ₁ • Δ) τ) →
    CDTerm C CFin Δ τ

der-cache-term-Σ : ∀ {Δ σ} → (t : Term Δ σ) → ∀ C → Σ[ CFin ∈ CCtx ] CDTerm C CFin Δ σ
der-cache-term-Σ (var x) CFin = CFin , cdvar (derive-dcvar x)
der-cache-term-Σ (lett f x t) C =
  let CFin , cdt = der-cache-term-Σ t (cache • C)
  in CFin , cdlett (derive-dcvar f) (derive-dcvar x) cdt

--⟦_⟧DTerm : ∀ {Δ τ} → DTerm Δ τ → ⟦ Δ ⟧Context → ⟦ ΔΔ Δ ⟧Context → ⟦ Δt τ ⟧Type
⟦_⟧CDTerm : ∀ {C CFin Δ τ} → CDTerm C CFin Δ τ → ⟦ ΔΔC Δ ⟧Context → ⟦ C ⟧CCtx → (⟦ ΔτC τ ⟧Type × ⟦ CFin ⟧CCtx)
⟦ cdvar x ⟧CDTerm dρ c = ⟦ x ⟧Var dρ , c
⟦ cdlett df dx cdt ⟧CDTerm dρ c =
  let dv = ⟦ df ⟧Var dρ (⟦ dx ⟧Var dρ)
  in ⟦ cdt ⟧CDTerm (dv • dρ) ((_ , dv) • c)

-- ⟦ cvar x ⟧CTerm ρ c = ⟦ x ⟧Var ρ , c
-- ⟦ clett f x ct ⟧CTerm ρ c =
--   let v = ⟦ f ⟧Var ρ (⟦ x ⟧Var ρ)
--   in ⟦ ct ⟧CTerm (v • ρ) ((_ , v) • c)

-- At the top, C is empty.
data CDFun (C CFin : CCtx) : (Δ : Context) (τ : Type) → Set where
  cdabs : ∀ {σ τ Δ} → CDFun (input σ • C) CFin (σ • Δ) τ → CDFun C CFin Δ (σ ⇒ τ)
  cdterm : ∀ {τ Δ} → CDTerm C CFin Δ τ → CDFun C CFin Δ τ

data CDFunR (C CFin : CCtx) : (Δ : Context) (τ : Type) → Set where
  cdabsterm : ∀ {σ τ Δ} → CDTerm (input σ • C) CFin (σ • Δ) τ → CDFunR C CFin Δ (σ ⇒ τ)


open import Agda.Primitive using (lzero; lsuc; _⊔_)
open import Relation.Binary.PropositionalEquality using (_≡_; refl; sym; trans; cong; cong₂; subst; setoid)
open import Data.Product using (_×_; Σ; _,_; proj₁; proj₂; zip; map; <_,_>; swap)
import Function.Equality
open import Relation.Binary using (Setoid)
import Relation.Binary.Reasoning.Setoid as SetoidR

import Categories.Category
import Categories.Functor
import Categories.Category.Instance.Setoids
import Categories.Monad.Relative
import Categories.Category.Equivalence
import Categories.Category.Cocartesian
import Categories.Category.Construction.Functors
import Categories.Category.Product
import Categories.NaturalTransformation
import Categories.NaturalTransformation.NaturalIsomorphism

import SecondOrder.Arity
import SecondOrder.Signature
import SecondOrder.Metavariable
import SecondOrder.VRenaming
import SecondOrder.MRenaming
import SecondOrder.Term
import SecondOrder.Substitution
import SecondOrder.RelativeMonadMorphism
import SecondOrder.Instantiation
import SecondOrder.IndexedCategory
import SecondOrder.RelativeKleisli
import SecondOrder.Mslot
import SecondOrder.MRelativeMonad
import SecondOrder.VRelativeMonad

module SecondOrder.VRelMonMorphism
  {ℓ}
  {𝔸 : SecondOrder.Arity.Arity}
  (Σ : SecondOrder.Signature.Signature ℓ 𝔸)
  where

  open SecondOrder.RelativeMonadMorphism
  open SecondOrder.Metavariable Σ
  open SecondOrder.VRelativeMonad Σ
  open SecondOrder.Instantiation Σ
  open SecondOrder.MRenaming Σ
  open SecondOrder.VRenaming Σ
  open SecondOrder.Term Σ
  open SecondOrder.Substitution Σ

  -- In this file, the goal is to show that given two variable relative monads
  -- on different metacontexts, metarenaming from one of the metacontexts to the other
  -- we can define a relative monad morphism between the two variable relative monads

  Fⱽ : ∀ (Θ Θ′ : MContext) (μ : Θ ⇒ᵐ Θ′) →  RMonadMorph (VMonad {Θ}) (VMonad {Θ′})
  Fⱽ Θ Θ′ μ = record
            { morph = λ A →
                        record
                          { _⟨$⟩_ = [ μ ]ᵐ_
                          ; cong = λ s≈t → []ᵐ-resp-≈ s≈t
                          }
            ; law-unit = λ A x≡y → ≈-≡ (σ-resp-≡ {σ = tm-var} x≡y)
            ; law-extend = λ {Γ} {Δ} {k} A {s} {t} s≈t →
                                           ≈-trans
                                             (≈-sym ([ᵐ∘ˢ] s))
                                             (≈-trans
                                               ([]ˢ-resp-≈ˢ ([ μ ]ᵐ s)   λ x → ≈-refl  )
                                               ([]ˢ-resp-≈ (λ {B} x → [ μ ]ᵐ (k B Function.Equality.⟨$⟩ x)) ([]ᵐ-resp-≈ s≈t)))
            }


module Avionics.Real where

open import Algebra.Definitions using (LeftIdentity; RightIdentity; Commutative)
open import Data.Bool using (Bool; _∧_)
open import Data.Float using (Float)
open import Data.Maybe using (Maybe; just; nothing)
open import Data.Nat using (ℕ)
open import Level using (0ℓ; _⊔_) renaming (suc to lsuc)
open import Relation.Binary using (Decidable; _Preserves_⟶_)
open import Relation.Binary.Definitions using (Transitive; Trans)
open import Relation.Binary.PropositionalEquality using (_≡_; refl)
open import Relation.Nullary using (Dec; yes; no)
open import Relation.Nullary.Decidable using (False; ⌊_⌋)
open import Relation.Unary using (Pred; _∈_)

infix  4 _<_ _≤_ _<ᵇ_ _≤ᵇ_
infixl 6 _+_ _-_
infixl 7 _*_

infix 4 _≟_

postulate
  ℝ : Set
  -- TODO: `fromFloat` should return `Maybe ℝ`
  fromFloat : Float → ℝ
  toFloat : ℝ → Float
  fromℕ : ℕ → ℝ

  _+_ _*_ _^_ : ℝ → ℝ → ℝ
  -_ abs _^2 : ℝ → ℝ
  e π 0ℝ 1ℝ -1/2 1/2 2ℝ : ℝ

  -- This was inspired on how the standard library handles things.
  -- See: https://plfa.github.io/Decidable/
  _<_ _≤_ : ℝ → ℝ → Set

  _≟_ : Decidable {A = ℝ} _≡_
  _≤?_ : (m n : ℝ) → Dec (m ≤ n)
  _<?_ : (m n : ℝ) → Dec (m < n)

_<ᵇ_ _≤ᵇ_ _≡ᵇ_ : ℝ → ℝ → Bool
p <ᵇ q = ⌊ p <? q ⌋
p ≤ᵇ q = ⌊ p ≤? q ⌋
p ≡ᵇ q = ⌊ p ≟ q ⌋

_≢0 : ℝ → Set
p ≢0 = False (p ≟ 0ℝ)

Subset : Set → Set _
Subset A = Pred A 0ℓ

-- Dangerous definitions, but necessary!
postulate
  ⟨0,∞⟩ [0,∞⟩ [0,1] : Subset ℝ

  1/_ : (p : ℝ) → ℝ
  √_ : (x : ℝ) → ℝ

_÷_ : (p q : ℝ) → ℝ
(p ÷ q) = p * (1/ q)

-- Dangerous definitions, but necessary!
postulate
  m÷n<o≡m<o*n : ∀ m n o → (m ÷ n <ᵇ o) ≡ (m <ᵇ o * n)
  m<o÷n≡m*n<o : ∀ m n o → (m <ᵇ o ÷ n) ≡ (m * n <ᵇ o)

_-_ : ℝ → ℝ → ℝ
p - q = p + (- q)

postulate
  double-neg : ∀ (x y : ℝ) → y - (y - x) ≡ x
  neg-involutive : ∀ x → -(- x) ≡ x
  neg-distrib-+ : ∀ m n → - (m + n) ≡ (- m) + (- n)
  neg-def : ∀ m → 0ℝ - m ≡ - m
  m-m≡0 : ∀ m → m - m ≡ 0ℝ
  neg-distribˡ-* : ∀ x y → - (x * y) ≡ (- x) * y
  √x^2≡absx : ∀ x → √ (x ^2) ≡ abs x

  >0→≢0 : ∀ {x : ℝ} → x ∈ ⟨0,∞⟩ → x ≢0
  >0→≥0 : ∀ {x : ℝ} → x ∈ ⟨0,∞⟩ → x ∈ [0,∞⟩
  >0*>0→>0 : ∀ {p q : ℝ} → p ∈ ⟨0,∞⟩ → q ∈ ⟨0,∞⟩ → (p * q) ∈ ⟨0,∞⟩
  ≢0*≢0→≢0 : ∀ {p q : ℝ} → p ≢0 → q ≢0 → (p * q) ≢0

  2>0 : 2ℝ ∈ ⟨0,∞⟩
  π>0 : π ∈ ⟨0,∞⟩

  e^x>0 : (x : ℝ) → (e ^ x) ∈ ⟨0,∞⟩
  x*x≡x^2 : ∀ x → x * x ≡ x ^2
  x^2*y^2≡⟨xy⟩^2 : ∀ x y → (x ^2) * (y ^2) ≡ (x * y)^2
  1/x^2≡⟨1/x⟩^2 : ∀ x → 1/ (x ^2) ≡ (1/ x)^2
  --√q≥0 : (q : ℝ) → (0≤q : q ∈ [0,∞⟩) → (√ q) {0≤q} ∈ [0,∞⟩
  --q>0→√q>0 : {q : ℝ} → (0<q : q ∈ ⟨0,∞⟩) → (√ q) {>0→≥0 0<q} ∈ ⟨0,∞⟩

  0≤→[0,∞⟩ : {n : ℝ} → 0ℝ ≤ n → n ∈ [0,∞⟩
  0<→⟨0,∞⟩ : {n : ℝ} → 0ℝ < n → n ∈ ⟨0,∞⟩
  [0,∞⟩→0≤ : {n : ℝ} → n ∈ [0,∞⟩ → 0ℝ ≤ n
  ⟨0,∞⟩→0< : {n : ℝ} → n ∈ ⟨0,∞⟩ → 0ℝ < n

  m≤n→m-p≤n-p : {m n p : ℝ} → m ≤ n → m - p ≤ n - p
  m<n→m-p<n-p : {m n p : ℝ} → m < n → m - p < n - p

  -- trans-≤ reduces to: {i j k : ℝ} → i ≤ j → j ≤ k → i ≤ k
  trans-≤ : Transitive _≤_
  <-transˡ : Trans _<_ _≤_ _<_

  --+-identityˡ : LeftIdentity 0ℝ _+_
  --+-identityʳ : RightIdentity 0ℝ _+_
  +-identityˡ : ∀ x → 0ℝ + x ≡ x
  +-identityʳ : ∀ x → x + 0ℝ ≡ x
  --+-comm : Commutative _+_
  +-comm : ∀ m n → m + n ≡ n + m
  --+-assoc : Associative _+_
  +-assoc : ∀ m n o → m + (n + o) ≡ (m + n) + o

  *-comm : ∀ m n → m * n ≡ n * m
  *-assoc : ∀ m n o → m * (n * o) ≡ (m * n) * o

  --0ℝ ≟_
  0≟0≡yes0≡0 : (0ℝ ≟ 0ℝ) ≡ yes refl

  -- TODO: These properties should be written for _<_ instead of _<ᵇ_
  abs<x→<x∧-x< : ∀ {u x} → (abs u <ᵇ x) ≡ ((u <ᵇ x) ∧ (- x <ᵇ u))
  --neg-mono-<-> : -_ Preserves _<_ ⟶ (λ a b -> b < a)
  neg-mono-<-> : ∀ m n → (m <ᵇ n) ≡ (- n <ᵇ - m)
  --+-monoˡ-< : ∀ n → (_+ n) Preserves _<_ ⟶ _<_
  +-monoˡ-< : ∀ n o p → (o <ᵇ p) ≡ (n + o <ᵇ n + p)

-- One of the weakest points in the whole library architecture!!!
-- This is wrong, really wrong, but useful
{-# COMPILE GHC ℝ = type Double #-}
{-# COMPILE GHC fromFloat = \x -> x #-}
{-# COMPILE GHC toFloat = \x -> x #-}
{-# COMPILE GHC fromℕ = fromIntegral #-}

{-# COMPILE GHC _<ᵇ_ = (<) #-}
{-# COMPILE GHC _≤ᵇ_ = (<=) #-}
{-# COMPILE GHC _≡ᵇ_ = (==) #-}

{-# COMPILE GHC _+_ = (+) #-}
{-# COMPILE GHC _-_ = (-) #-}
{-# COMPILE GHC _*_ = (*) #-}
{-# COMPILE GHC _^_ = (**) #-}

{-# COMPILE GHC _^2 = (**2) #-}

{-# COMPILE GHC e = 2.71828182845904523536 #-}
{-# COMPILE GHC π = 3.14159265358979323846 #-}
{-# COMPILE GHC 0ℝ = 0 #-}
{-# COMPILE GHC 1ℝ = 1 #-}
{-# COMPILE GHC 2ℝ = 2 #-}
{-# COMPILE GHC -1/2 = -1/2 #-}

-- REAAALY CAREFUL WITH THIS!
-- TODO: Add some runtime checking to this. Fail hard if divisor is zero
{-# COMPILE GHC 1/_ = \x -> (1/x) #-}
{-# COMPILE GHC _÷_ = \x y -> (x/y) #-}
{-# COMPILE GHC √_  = \x -> sqrt x #-}


{-# OPTIONS --prop --rewriting #-}

module Examples.Queue where

open import Calf.CostMonoid
open import Calf.CostMonoids using (ℕ-CostMonoid)

costMonoid = ℕ-CostMonoid
open CostMonoid costMonoid using (ℂ)

open import Calf costMonoid
open import Calf.Types.Nat
open import Calf.Types.Unit
open import Calf.Types.Sum
open import Calf.Types.Bounded costMonoid

open import Function
open import Data.Nat
open import Data.Nat.Properties
import Data.Integer as Int
import Data.Integer.Properties as IntP
open import Data.List renaming (sum to lsum)
open import Data.Product
open import Relation.Binary.PropositionalEquality as P

record Queue (A : tp pos) : Set where
  field
    Q : tp pos
    emp : val Q
    enq : cmp (Π Q λ _ → Π A λ _ → F Q)
    deq : cmp (Π Q λ _ → F (sum unit (Σ++ Q λ _ → A)))

module CostList (A : tp pos) (n : ℕ) where
  -- Suppose we want to implement the Queue signature above using lists.
  -- One cost model is to count the number of times a cons node is inspected.
  -- This is implemented by the following annotated list type:
  -- destructing a cons node of type list n A consumes n steps.
  postulate
    list : tp pos
    nil : val list
    cons : val A → val list → val list

    list/ind : (l : val list) → (X : val list → tp neg) → cmp (X nil) →
      ((a : val A) → (l : val list) → (r : val (U (X l))) →
        cmp (X (cons a l))) →
      cmp (X l)
    list/ind/nil : ∀ {X} → (e0 : cmp (X nil)) →
        (e1 : (a : val A) → (l : val list) → (r : val (U (X l))) →
        cmp (X (cons a l))) →
      list/ind nil X e0 e1 ≡ e0
    {-# REWRITE list/ind/nil #-}
    list/ind/cons : ∀ {X} → (a : val A) → (l : val list) → (e0 : cmp (X nil)) →
        (e1 : (a : val A) → (l : val list) → (r : val (U (X l))) →
        cmp (X (cons a l))) →
      list/ind (cons a l) X e0 e1 ≡ step (X (cons a l)) n (e1 a l (list/ind l X e0 e1))
    {-# REWRITE list/ind/cons #-}

  list/match : (l : val list) → (X : val list → tp neg) → cmp (X nil) →
    ((a : val A) → (l : val list) → cmp (X (cons a l))) →
    cmp (X l)
  list/match l X e0 e1 = list/ind l X e0 (λ a l _ → e1 a l)

  bound/list/match : ∀ (l : val list) (X : val list → tp pos)
    {e0 : val (U (F (X nil)))} {e1 : (a : val A) → (l : val list) → val (U (F (X (cons a l))))}
    {p0 : val (U cost)} {p1 : (a : val A) → (l : val list) → val (U cost)} →
    IsBounded (X nil) e0 p0 →
    ((a : val A) → (l : val list) → IsBounded (X (cons a l)) (e1 a l) (p1 a l)) →
    IsBounded (X l) (list/match l (F ∘ X) e0 e1) (list/match l (λ _ → cost) p0 (λ a l → n + p1 a l))
  bound/list/match l X {e0} {e1} {p0} {p1} ub0 ub1 =
    list/match l (λ l → meta (IsBounded (X l) (list/match l (F ∘ X) e0 e1) (list/match l (λ _ → cost) p0 (λ a l → n + p1 a l))))
      ub0
      λ a l → bound/circ n (bound/step n (p1 a l) (ub1 a l))

  len : val list → ℕ
  len l = list/ind l (λ _ → meta ℕ) 0 λ a l r → 1 + r

module Ex/CostList where
  open CostList nat 0

  ex : val list
  ex = cons 0 (cons 1 nil)

module Rev (A : tp pos) where
  open CostList A 1

  revAppend : cmp (Π list λ _ → Π list λ _ → F list)
  revAppend l =
    list/ind l (λ _ → Π list λ _ → F list)
      (λ l' → ret l')
      λ x _ r → λ l' → r (cons x l')

  revAppend/lemma/cons : ∀ x xs l' → ◯ (∃ λ y → ∃ λ ys → (len ys ≡ len xs + len l') × revAppend (cons x xs) l' ≡ ret (cons y ys))
  revAppend/lemma/cons x xs =
    list/ind xs (λ xs → meta (∀ x l' → ◯ (∃ λ y → ∃ λ ys → (len ys ≡ len xs + len l') × revAppend (cons x xs) l' ≡ ret (cons y ys))))
      (λ x l' u → (x , l' , refl , step/ext (F list) (ret (cons x l')) 1 u))
      (λ x' xs' ih x l' u →
        let (y , ys , h , ≡) = ih x' (cons x l') u in
        let open ≡-Reasoning in
        y , ys , (
          begin
            len ys
          ≡⟨ h ⟩
            len xs' + len (cons x l')
          ≡⟨⟩
            len xs' + step (meta ℕ) 1 (suc (len l'))
          ≡⟨ cong (len xs' +_) (step/ext (meta ℕ) (suc (len l')) 1 u) ⟩
            len xs' + suc (len l')
          ≡⟨ +-suc (len xs') (len l') ⟩
            suc (len xs' + len l')
          ≡⟨⟩
            suc (len xs') + len l'
          ≡˘⟨ cong (_+ len l') (step/ext (meta ℕ) (suc (len xs')) 1 u) ⟩
            step (meta ℕ) 1 (suc (len xs')) + len l'
          ≡⟨⟩
            len (cons x' xs') + len l'
          ∎
        ) , (
          begin
            revAppend (cons x (cons x' xs')) l'
          ≡⟨⟩
            step (F list) 1 (revAppend (cons x' xs') (cons x l'))
          ≡⟨ step/ext (F list) _ 1 u ⟩
            revAppend (cons x' xs') (cons x l')
          ≡⟨ (≡) ⟩
            ret (cons y ys)
          ∎
        ))
      x

  revAppend/cost : cmp (Π list λ _ → Π list λ _ → cost)
  revAppend/cost l l' = len l

  revAppend≤revAppend/cost : ∀ l l' → IsBounded list (revAppend l l') (revAppend/cost l l')
  revAppend≤revAppend/cost l =
    list/ind l (λ l → meta (∀ l' → IsBounded list (revAppend l l') (revAppend/cost l l')))
      (λ l' → bound/ret)
      (λ a l r → λ l' → bound/circ 1 (bound/step 1 (len l) (r (cons a l'))))

  rev : cmp (Π list λ _ → F list)
  rev l = revAppend l nil

  rev/lemma/cons : ∀ x xs → ◯ (∃ λ y → ∃ λ ys → len ys ≡ len xs × rev (cons x xs) ≡ ret (cons y ys))
  rev/lemma/cons x xs =
    subst (λ n → ◯ (∃ λ y → ∃ λ ys → len ys ≡ n × rev (cons x xs) ≡ ret (cons y ys)))
      (+-identityʳ _)
      (revAppend/lemma/cons x xs nil)

  rev/cost : cmp (Π list λ _ → cost)
  rev/cost l = len l

  rev≤rev/cost : ∀ l → IsBounded list (rev l) (rev/cost l)
  rev≤rev/cost l = revAppend≤revAppend/cost l nil

-- Implement Queue with a pair of lists; (f , b) represents the queue f :: rev b.
module FrontBack (A : tp pos) where
  -- For simplicity, we charge 1 step for each cons node destruction.
  open CostList A 1
  open Rev A

  Q : tp pos
  Q = Σ++ list λ _ → list

  emp : val Q
  emp = (nil , nil)

  enq : cmp (Π Q λ _ → Π A λ _ → F Q)
  enq (f , b) x = ret (f , cons x b)

  enq/cost : cmp (Π Q λ _ → Π A λ _ → cost)
  enq/cost (f , b) x = 0

  enq≤enq/cost : ∀ q x → IsBounded Q (enq q x) (enq/cost q x)
  enq≤enq/cost q x = bound/ret

  deq-tp = sum unit (Σ++ Q λ _ → A)

  deq/emp : cmp (Π list λ _ → F deq-tp)
  deq/emp l =
    list/match l (λ _ → F deq-tp)
      (ret (inj₁ triv))
      λ a l' → ret (inj₂ ((l' , nil) , a))

  deq/emp/cost : cmp (Π list λ _ → cost)
  deq/emp/cost l =
    list/match l (λ _ → cost)
      0
      λ a l' → 1 + 0

  deq/emp≤deq/emp/cost : ∀ l → IsBounded deq-tp (deq/emp l) (deq/emp/cost l)
  deq/emp≤deq/emp/cost l =
    bound/list/match l (λ _ → deq-tp)
      bound/ret
      λ a l' → bound/ret

  deq : cmp (Π Q λ _ → F deq-tp)
  deq (f , b) =
    list/match f (λ _ → F deq-tp)
      (bind (F deq-tp) (rev b) (λ b' → deq/emp b'))
      λ a l → ret (inj₂ ((l , b) , a))

  deq/cost : cmp (Π Q λ _ → cost)
  deq/cost (f , b) =
    list/match f (λ _ → cost)
      (bind cost (rev b) (λ b' → rev/cost b + deq/emp/cost b'))
      λ a l → 1 + 0

  deq/cost/closed : cmp (Π Q λ _ → cost)
  deq/cost/closed (f , b) =
    list/match f (λ _ → cost)
      (list/match b (λ _ → cost) 0 (λ _ b' → 1 + len b))
      λ _ _ → 1

  deq/cost≤deq/cost/closed : ∀ q → ◯ (deq/cost q ≤ deq/cost/closed q)
  deq/cost≤deq/cost/closed (f , b) u =
    list/match f (λ f → meta (deq/cost (f , b) ≤ deq/cost/closed (f , b)))
      (list/match b (λ b → meta (deq/cost (nil , b) ≤ deq/cost/closed (nil , b)))
        ≤-refl
        λ x xs →
          let open ≤-Reasoning in
          let (y , ys , _ , ≡) = rev/lemma/cons x xs u in
          begin
            deq/cost (nil , cons x xs)
          ≡⟨⟩
            bind cost (rev (cons x xs)) (λ b' → rev/cost (cons x xs) + deq/emp/cost b')
          ≡⟨⟩
            bind cost (rev (cons x xs)) (λ b' → rev/cost (cons x xs) + deq/emp/cost b')
          ≡⟨ cong (λ e → bind cost e (λ b' → rev/cost (cons x xs) + deq/emp/cost b')) (≡) ⟩
            rev/cost (cons x xs) + deq/emp/cost (cons y ys)
          ≡⟨⟩
            step cost 1 (suc (len xs)) + step cost 1 1
          ≡⟨ cong₂ _+_ (step/ext cost (suc (len xs)) 1 u) (step/ext cost 1 1 u) ⟩
            suc (len xs) + 1
          ≡⟨ +-comm (suc (len xs)) 1 ⟩
            suc (suc (len xs))
          ≡˘⟨ cong suc (step/ext cost _ 1 u) ⟩
            suc (step cost 1 (suc (len xs)))
          ≡⟨⟩
            suc (len (cons x xs))
          ≡˘⟨ step/ext cost _ 1 u ⟩
            step cost 1 (suc (len (cons x xs)))
          ≡⟨⟩
            list/match (cons x xs) (λ _ → cost) 0 (λ _ b' → 1 + len (cons x xs))
          ≡⟨⟩
            deq/cost/closed (nil , cons x xs)
          ∎
      )
      λ _ _ → ≤-refl

  deq≤deq/cost : ∀ q → IsBounded deq-tp (deq q) (deq/cost q)
  deq≤deq/cost (f , b) =
    bound/list/match f (λ _ → deq-tp)
      (bound/bind (rev/cost b) _ (rev≤rev/cost b) λ b' → deq/emp≤deq/emp/cost b')
      λ a l → bound/ret

  deq≤deq/cost/closed : ∀ q → IsBounded deq-tp (deq q) (deq/cost/closed q)
  deq≤deq/cost/closed q = bound/relax (deq/cost≤deq/cost/closed q) (deq≤deq/cost q)

  -- Amortized analysis for front-back queue.
  -- The goal is to bound the cost of a single-thread sequence of queue operations staring with an initial queue q0,
  -- where an operation is either an enqueue or a dequeue.
  data op : Set where
    op/enq : (x : val A) → op
    op/deq : op

  -- Potential function
  ϕ : val Q → ℕ
  ϕ (f , b) = len f + 2 * len b

  -- o operate q is the computation induced by operation o on queue q.
  -- Needed because deq doesn't always return a queue (e.g., deq emp).
  -- In these cases we just return the empty queue.
  _operate_ : op → val Q → cmp (F Q)
  (op/enq x) operate q = enq q x
  (op/deq) operate q =
    bind (F Q) (deq q) λ s → (sum/case unit (Σ++ Q λ _ → A) (λ _ → F Q) s
    (λ _ → ret (nil , nil))
    (λ (q , x) → ret q))

  -- o operateϕ q is morally ϕ (o operate q), which doesn't type-check since o operate q is a computation.
  -- Easier to work with than bind cost (o operate q) ϕ (but they are equivalent, as shown below).
  _operateϕ_ : op → val Q → ℂ
  (op/enq x) operateϕ (f , b) = len f + 2 * (1 + len b)
  (op/deq) operateϕ (f , b) = list/match f (λ _ → cost) (list/match b (λ _ → cost) 0 (λ _ b' → len b')) (λ _ f' → len f' + 2 * len b)

  operateϕ≡ϕ∘operate : ∀ o q → ◯ (o operateϕ q ≡ bind cost (o operate q) ϕ)
  operateϕ≡ϕ∘operate (op/enq x) (f , b) u =
    begin
      len f + 2 * (1 + len b)
    ≡˘⟨ cong (λ n → len f + 2 * n) (step/ext cost (1 + len b) 1 u) ⟩
      len f + 2 * step cost 1 (1 + len b)
    ≡⟨⟩
      bind cost (enq (f , b) x) ϕ
    ∎
      where open ≡-Reasoning
  operateϕ≡ϕ∘operate op/deq (f , b) u = list/match f
        (λ f →
          meta
          ((op/deq operateϕ (f , b)) ≡
            bind cost (op/deq operate (f , b)) ϕ))
        (list/ind b (λ b → meta ((op/deq operateϕ (nil , b)) ≡ bind cost (op/deq operate (nil , b)) ϕ))
        refl
        λ a l ih → emp/cons a l)
        λ a l → refl

    where
    emp/cons : ∀ a l → op/deq operateϕ (nil , cons a l) ≡ bind cost (op/deq operate (nil , cons a l)) ϕ
    emp/cons a l with rev/lemma/cons a l u
    ... | (x' , l' , eqn1 , eqn2) =
      begin
        op/deq operateϕ (nil , cons a l)
      ≡⟨⟩
        step cost 1 (len l)
      ≡⟨ step/ext cost (len l) 1 u ⟩
        len l
      ≡⟨ P.sym eqn1 ⟩
        len l'
      ≡⟨ P.sym (+-identityʳ (len l')) ⟩
        len l' + 0
      ≡⟨⟩
        len l' + 2 * len nil
      ≡⟨⟩
        ϕ (l' , nil)
      ≡˘⟨ step/ext cost (ϕ (l' , nil)) 1 u ⟩
        step cost 1 (ϕ (l' , nil))
      ≡⟨⟩
        bind cost
          (step (F Q) 1 (ret (l' , nil)))
          ϕ
      ≡⟨⟩
        bind cost
          (bind (F Q) (step (F deq-tp) 1 (ret (inj₂ ((l' , nil) , x')))) λ s → (sum/case unit (Σ++ Q λ _ → A) (λ _ → F Q) s
            (λ _ → ret (nil , nil))
            (λ (q , x) → ret q)))
          ϕ
      ≡⟨⟩
        bind cost
          (bind (F Q) (deq/emp (cons x' l')) λ s → (sum/case unit (Σ++ Q λ _ → A) (λ _ → F Q) s
            (λ _ → ret (nil , nil))
            (λ (q , x) → ret q)))
          ϕ
      ≡˘⟨
        cong
          (λ e →
            bind cost
              (bind (F Q) e λ l' →
                bind (F Q) (deq/emp l') λ s → (sum/case unit (Σ++ Q λ _ → A) (λ _ → F Q) s
                  (λ _ → ret (nil , nil))
                  (λ (q , x) → ret q)))
              ϕ
          )
          eqn2
      ⟩
        bind cost
          (bind (F Q) (rev (cons a l)) λ l' →
            bind (F Q) (deq/emp l') λ s → (sum/case unit (Σ++ Q λ _ → A) (λ _ → F Q) s
              (λ _ → ret (nil , nil))
              (λ (q , x) → ret q)))
          ϕ
      ≡⟨⟩
        bind cost
          (bind (F Q) (deq (nil , cons a l)) λ s → (sum/case unit (Σ++ Q λ _ → A) (λ _ → F Q) s
            (λ _ → ret (nil , nil))
            (λ (q , x) → ret q)))
          ϕ
      ≡⟨⟩
        bind cost (op/deq operate (nil , cons a l)) ϕ
      ∎
      where open ≡-Reasoning

  -- op/cost o q is the cost of o operate q.
  op/cost : op → val Q → ℕ
  op/cost (op/enq x) q = 0
  op/cost (op/deq) (f , b) = list/match f (λ _ → cost) (list/match b (λ _ → cost) 0 (λ _ b' → 2 + len b')) (λ _ _ → 1)

  deq/cost≡cost/deq : ∀ q → ◯ (deq/cost/closed q ≡ op/cost op/deq q)
  deq/cost≡cost/deq (f , b) u =
    P.cong (λ x → list/match f (λ _ → cost) x (λ _ _ → 1)) (
      list/match b
        (λ b →
          meta
            (list/match b (λ _ → cost) 0 (λ _ b' → 1 + len b) ≡
              list/match b (λ _ → cost) 0 (λ _ b' → 2 + len b')))
        refl
        (λ a l →
          let open ≡-Reasoning in
          begin
            list/match (cons a l) (λ _ → cost) 0 (λ _ b' → 1 + len (cons a l))
          ≡⟨⟩
            step cost 1 (1 + len (cons a l))
          ≡⟨ step/ext cost (1 + len (cons a l)) 1 u ⟩
            1 + len (cons a l)
          ≡⟨⟩
            1 + step cost 1 (suc (len l))
          ≡⟨ cong (1 +_) (step/ext cost (suc (len l)) 1 u) ⟩
            2 + len l
          ≡˘⟨ step/ext cost (2 + len l) 1 u ⟩
            step cost 1 (2 + len l)
          ≡⟨⟩
            list/match (cons a l) (λ _ → cost) 0 (λ _ b' → 2 + len b')
          ∎
        )
    )

  -- cost o q upperbounds the cost of o operate q.
  op≤op/cost : ∀ o q → IsBounded Q (o operate q) (op/cost o q)
  op≤op/cost (op/enq x) q = enq≤enq/cost q x
  op≤op/cost op/deq q rewrite P.sym (+-identityʳ (op/cost (op/deq) q)) =
    bound/bind/const {A = deq-tp} {e = deq q} {f = λ s → (sum/case unit (Σ++ Q λ _ → A) (λ _ → F Q) s (λ _ → ret (nil , nil)) (λ (q , x) → ret q))}
      (op/cost op/deq q) 0
      (bound/relax (λ u → ≤-reflexive (deq/cost≡cost/deq q u)) (deq≤deq/cost/closed q))
      λ a →
        bound/sum/case/const/const unit ((Σ++ Q λ _ → A)) (λ _ → Q) a ((λ _ → ret (nil , nil))) (λ (q , x) → ret q) 0
          (λ _ → bound/ret)
          (λ _ → bound/ret)

  -- is/acost o k when for any state q, k suffices for the cost of o on q and the difference in the potential.
  is/acost :  op → ℕ → Set
  is/acost o k = ∀ q → (Int.+ (op/cost o q)) Int.+ ((o operateϕ q) Int.⊖ (ϕ q)) Int.≤ Int.+ k

  acost/weaken : ∀ {m n o} → m ≤ n → is/acost o m → is/acost o n
  acost/weaken h1 h2 = λ q → IntP.≤-trans (h2 q) (Int.+≤+ h1)

  -- A sequence of operations induces a single computation by threading through the initial state q0.
  _op/seq_ : List op → val Q → cmp (F Q)
  [] op/seq q0 = ret q0
  (o ∷ os) op/seq q = bind (F Q) (o operate q) λ q' → os op/seq q'

  op/seq/cost : ∀ (l : List op) → val Q → ℂ
  op/seq/cost [] q0 = 0
  op/seq/cost (o ∷ os) q = bind cost (o operate q) λ q' → op/cost o q + op/seq/cost os q'

  -- Cost of a sequence computation is bounded by the sum of cost of the constituents.
  op/seq≤op/seq/cost : ∀ l q → IsBounded Q (l op/seq q) (op/seq/cost l q)
  op/seq≤op/seq/cost [] q0 = bound/ret
  op/seq≤op/seq/cost (o ∷ os) q = bound/bind {A = Q} {e = o operate q} {f = λ q → os op/seq q}
   (op/cost o q) (op/seq/cost os) (op≤op/cost o q) λ q → op/seq≤op/seq/cost os q

  -- Telescoping the potential.
  op/seq/cost/tele : ∀ (l : List op) → val Q → Int.ℤ
  op/seq/cost/tele [] q0 = Int.0ℤ
  op/seq/cost/tele (o ∷ os) q = bind (meta Int.ℤ) (o operate q) λ q' → (Int.+ (op/cost o q)) Int.+ (o operateϕ q Int.⊖ ϕ q) Int.+ (op/seq/cost/tele os q')

  ϕn : ℕ → List op → val Q → ℕ
  ϕn zero l q0 = ϕ q0
  ϕn (suc n) (o ∷ os) q = bind cost (o operate q) λ q' → ϕn n os q'
  ϕn (suc n) [] q = 0

  -- Potential of the initial state
  ϕ/0 : List op → val Q → ℕ
  ϕ/0 l = ϕn 0 l

  -- Potential of the final state
  ϕ/-1 : List op → val Q → ℕ
  ϕ/-1 l = ϕn (length l) l

  bind/dup : ∀ A 𝕊 𝕋 e f (g : val A → 𝕊 → 𝕋) → bind {A} (meta 𝕋) e (λ a → g a (bind {A} (meta 𝕊) e f)) ≡ bind {A} (meta 𝕋) e (λ a → g a (f a))
  bind/dup A 𝕊 𝕋 e f g =
    begin
    bind (meta 𝕋) e (λ a → g a (bind (meta 𝕊) e f)) ≡⟨ P.cong (λ h → bind (meta 𝕋) e h) (funext (λ a → bind/meta A 𝕊 𝕋 e f (λ s → g a s))) ⟩
    bind (meta 𝕋) e (λ a → bind (meta 𝕋) e (λ a' → g a (f a'))) ≡⟨ bind/idem A 𝕋 e (λ a a' → g a (f a')) ⟩
    bind (meta 𝕋) e (λ a → g a (f a)) ≡⟨ refl ⟩
    bind (meta 𝕋) e (λ a → g a (f a))
    ∎
    where open ≡-Reasoning

  -- Telescoping sum:
  -- Σᵢⁿ op/cost oᵢ + ϕ qᵢ - ϕ qᵢ₋₁ = ϕ q_{n-1} - ϕ q_0 + Σᵢ costᵢ
  cost≡cost/tele : ∀ l q → ◯ (op/seq/cost/tele l q ≡ (ϕ/-1 l q Int.⊖ ϕ/0 l q) Int.+ (Int.+ (op/seq/cost l q)))
  cost≡cost/tele [] q u =
    P.sym
    (
      begin
      (ϕ q Int.⊖ ϕ q) Int.+ (Int.+ 0) ≡⟨ IntP.+-identityʳ (ϕ q Int.⊖ ϕ q) ⟩
      ϕ q Int.⊖ ϕ q ≡⟨ IntP.n⊖n≡0 (ϕ q) ⟩
      Int.+ 0 ≡⟨ refl ⟩
      Int.+ 0
      ∎
    )
    where open ≡-Reasoning
  cost≡cost/tele (o ∷ os) q u rewrite operateϕ≡ϕ∘operate o q u
                                  | bind/meta Q ℕ Int.ℤ
                                    (o operate q)
                                    (λ q' → op/cost o q + op/seq/cost os q')
                                    (λ x → (ϕ/-1 (o ∷ os) q Int.⊖ ϕ/0 (o ∷ os) q) Int.+ (Int.+ x))
                                  | bind/dup Q ℕ Int.ℤ (o operate q) (ϕ/-1 os) (λ q' x → (x Int.⊖ ϕ q) Int.+ (Int.+ (op/cost o q + op/seq/cost os q')))
                                  | bind/dup Q ℕ Int.ℤ (o operate q) ϕ (λ q' x → Int.+ (op/cost o q) Int.+ (x Int.⊖ ϕ q) Int.+ (op/seq/cost/tele os q')) =
    P.cong (λ f → bind (meta Int.ℤ) (o operate q) f)
    (funext (λ q' →
    (
      begin
      (Int.+ (op/cost o q)) Int.+ (ϕ q' Int.⊖ ϕ q) Int.+ (op/seq/cost/tele os q') ≡⟨ P.cong (λ x → (Int.+ (op/cost o q)) Int.+ (ϕ q' Int.⊖ ϕ q) Int.+ x) (cost≡cost/tele os q' u) ⟩
      Int.+ op/cost o q Int.+ (ϕ q' Int.⊖ ϕ q) Int.+ (ϕ/-1 os q' Int.⊖ ϕ/0 os q' Int.+ Int.+ op/seq/cost os q') ≡⟨ P.cong (λ x → x Int.+ (ϕ/-1 os q' Int.⊖ ϕ/0 os q' Int.+ Int.+ op/seq/cost os q')) (IntP.+-comm (Int.+ op/cost o q) (ϕ q' Int.⊖ ϕ q)) ⟩
      ϕ q' Int.⊖ ϕ q Int.+ Int.+ op/cost o q Int.+ (ϕ/-1 os q' Int.⊖ ϕ/0 os q' Int.+ Int.+ op/seq/cost os q') ≡⟨ IntP.+-assoc (ϕ q' Int.⊖ ϕ q) (Int.+ op/cost o q) (ϕ/-1 os q' Int.⊖ ϕ/0 os q' Int.+ Int.+ op/seq/cost os q') ⟩
      ϕ q' Int.⊖ ϕ q Int.+ (Int.+ op/cost o q Int.+ (ϕ/-1 os q' Int.⊖ ϕ/0 os q' Int.+ Int.+ op/seq/cost os q')) ≡⟨ P.cong (λ x → ϕ q' Int.⊖ ϕ q Int.+ x) (P.sym (IntP.+-assoc (Int.+ op/cost o q) (ϕ/-1 os q' Int.⊖ ϕ/0 os q') (Int.+ op/seq/cost os q'))) ⟩
      ϕ q' Int.⊖ ϕ q Int.+ (Int.+ op/cost o q Int.+ (ϕ/-1 os q' Int.⊖ ϕ/0 os q') Int.+ Int.+ op/seq/cost os q') ≡⟨ P.cong (λ x → ϕ q' Int.⊖ ϕ q Int.+ (x Int.+ Int.+ op/seq/cost os q')) (IntP.+-comm (Int.+ op/cost o q) (ϕ/-1 os q' Int.⊖ ϕ/0 os q')) ⟩
      ϕ q' Int.⊖ ϕ q Int.+ (ϕ/-1 os q' Int.⊖ ϕ/0 os q' Int.+ Int.+ op/cost o q Int.+ Int.+ op/seq/cost os q') ≡⟨ P.cong (λ x → ϕ q' Int.⊖ ϕ q Int.+ x) (IntP.+-assoc (ϕ/-1 os q' Int.⊖ ϕ/0 os q') (Int.+ op/cost o q) (Int.+ op/seq/cost os q')) ⟩
      ϕ q' Int.⊖ ϕ q Int.+ (ϕ/-1 os q' Int.⊖ ϕ/0 os q' Int.+ (Int.+ op/cost o q Int.+ Int.+ op/seq/cost os q')) ≡⟨ P.sym (IntP.+-assoc (ϕ q' Int.⊖ ϕ q) (ϕ/-1 os q' Int.⊖ ϕ/0 os q') (Int.+ op/cost o q Int.+ Int.+ op/seq/cost os q')) ⟩
      ϕ q' Int.⊖ ϕ q Int.+ (ϕ/-1 os q' Int.⊖ ϕ/0 os q') Int.+ (Int.+ op/cost o q Int.+ Int.+ op/seq/cost os q') ≡⟨ P.cong (λ x → x Int.+ (ϕ/-1 os q' Int.⊖ ϕ/0 os q') Int.+ (Int.+ op/cost o q Int.+ Int.+ op/seq/cost os q')) (P.sym (IntP.m-n≡m⊖n (ϕ q') (ϕ q))) ⟩
      Int.+ ϕ q' Int.- (Int.+ ϕ q) Int.+ (ϕ/-1 os q' Int.⊖ ϕ/0 os q') Int.+ (Int.+ op/cost o q Int.+ Int.+ op/seq/cost os q') ≡⟨ P.cong (λ x → Int.+ ϕ q' Int.- (Int.+ ϕ q) Int.+ x Int.+ (Int.+ op/cost o q Int.+ Int.+ op/seq/cost os q')) (P.sym (IntP.m-n≡m⊖n (ϕ/-1 os q') (ϕ/0 os q'))) ⟩
      Int.+ ϕ q' Int.- Int.+ ϕ q Int.+ (Int.+ ϕ/-1 os q' Int.- (Int.+ ϕ/0 os q')) Int.+ (Int.+ op/cost o q Int.+ Int.+ op/seq/cost os q') ≡⟨ P.cong (λ x → x Int.+ (Int.+ op/cost o q Int.+ Int.+ op/seq/cost os q')) (IntP.+-comm (Int.+ ϕ q' Int.- Int.+ ϕ q) (Int.+ ϕ/-1 os q' Int.- (Int.+ ϕ/0 os q'))) ⟩
      Int.+ ϕ/-1 os q' Int.- Int.+ ϕ/0 os q' Int.+ (Int.+ ϕ q' Int.- Int.+ ϕ q) Int.+ (Int.+ op/cost o q Int.+ Int.+ op/seq/cost os q') ≡⟨ P.cong (λ x → x Int.+ (Int.+ op/cost o q Int.+ Int.+ op/seq/cost os q')) (IntP.+-minus-telescope (Int.+ ϕ/-1 os q') (Int.+ ϕ q') (Int.+ ϕ q)) ⟩
      Int.+ ϕ/-1 os q' Int.- Int.+ ϕ q Int.+ (Int.+ op/cost o q Int.+ Int.+ op/seq/cost os q') ≡⟨ P.cong (λ x → x Int.+ (Int.+ op/cost o q Int.+ Int.+ op/seq/cost os q')) (IntP.m-n≡m⊖n (ϕ/-1 os q') (ϕ q )) ⟩
      ϕ/-1 os q' Int.⊖ ϕ q Int.+ (Int.+ op/cost o q Int.+ Int.+ op/seq/cost os q') ≡⟨ refl ⟩
      ϕ/-1 os q' Int.⊖ ϕ q Int.+ (Int.+ op/cost o q Int.+ Int.+ op/seq/cost os q')
      ∎
    )
    ))
    where open ≡-Reasoning

  data Amortized : List op → List ℕ → Set where
    a/emp : Amortized [] []
    a/cons : ∀ o k l l' → is/acost o k → Amortized l l' → Amortized (o ∷ l) (k ∷ l')

  amortized≥cost/tele : ∀ q0 l l' → Amortized l l' → Int.+ (lsum l') Int.≥ op/seq/cost/tele l q0
  amortized≥cost/tele q .[] .[] a/emp = IntP.≤-refl
  amortized≥cost/tele q .(o ∷ os) .(k ∷ l') (a/cons o k os l' x h) rewrite tbind/meta Q Int.ℤ (o operate q) (λ q' → (Int.+ (op/cost o q)) Int.+ (o operateϕ q Int.⊖ ϕ q) Int.+ (op/seq/cost/tele os q')) (λ z → z Int.≤ Int.+ lsum (k ∷ l')) =
    dbind (λ q' → meta ((Int.+ (op/cost o q)) Int.+ (o operateϕ q Int.⊖ ϕ q) Int.+ (op/seq/cost/tele os q') Int.≤ Int.+ lsum (k ∷ l'))) (o operate q)
    λ q' →
    begin
    Int.+ op/cost o q Int.+ ((o operateϕ q) Int.⊖ ϕ q) Int.+ op/seq/cost/tele os q' ≤⟨ IntP.+-monoˡ-≤ (op/seq/cost/tele os q') (x q) ⟩
    Int.+ k Int.+ op/seq/cost/tele os q' ≤⟨ IntP.+-monoʳ-≤ (Int.+ k) (amortized≥cost/tele q' os l' h) ⟩
    Int.+ k Int.+ Int.+ lsum l' ≤⟨ IntP.≤-refl ⟩
    Int.+ k Int.+ Int.+ lsum l'
    ∎
   where open IntP.≤-Reasoning

  -- Sum of a sequence of amortized costs (plus the initial potential) bounds the sum of the sequence of actual costs
  amortized≥cost : ∀ q l l' → Amortized l l' → ◯ (Int.+ (ϕ q + lsum l') Int.≥ Int.+ (op/seq/cost l q))
  amortized≥cost q l l' h u =
    begin
    Int.+ (op/seq/cost l q) ≤⟨ IntP.n≤m+n (0 + ϕ/-1 l q) ⟩
    Int.0ℤ Int.+ (Int.+ ϕ/-1 l q) Int.+ Int.+ op/seq/cost l q ≡⟨ P.cong (λ x → x Int.+ (Int.+ ϕ/-1 l q) Int.+ Int.+ op/seq/cost l q) (P.sym (IntP.n⊖n≡0 (ϕ q))) ⟩
    ϕ q Int.⊖ ϕ q Int.+ Int.+ ϕ/-1 l q Int.+ Int.+ op/seq/cost l q ≡⟨ P.cong (λ x → x Int.+ (Int.+ ϕ/-1 l q) Int.+ Int.+ op/seq/cost l q) (P.sym (IntP.m-n≡m⊖n (ϕ q) (ϕ q))) ⟩
    Int.+ ϕ q Int.+ Int.- (Int.+ ϕ q) Int.+ Int.+ ϕ/-1 l q Int.+ Int.+ op/seq/cost l q ≡⟨ P.cong (λ x → x Int.+ Int.+ op/seq/cost l q) (IntP.+-assoc (Int.+ ϕ q) (Int.- (Int.+ ϕ q)) (Int.+ ϕ/-1 l q)) ⟩
    Int.+ ϕ q Int.+ (Int.- (Int.+ ϕ q) Int.+ Int.+ ϕ/-1 l q) Int.+ Int.+ op/seq/cost l q ≡⟨ P.cong (λ x → Int.+ ϕ q Int.+ x Int.+ Int.+ op/seq/cost l q) (IntP.+-comm (Int.- (Int.+ ϕ q)) (Int.+ ϕ/-1 l q)) ⟩
    Int.+ ϕ q Int.+ (Int.+ ϕ/-1 l q Int.- (Int.+ ϕ q)) Int.+ Int.+ op/seq/cost l q ≡⟨ IntP.+-assoc (Int.+ ϕ q) (Int.+ ϕ/-1 l q Int.- (Int.+ ϕ q)) (Int.+ op/seq/cost l q) ⟩
    Int.+ ϕ q Int.+ (Int.+ ϕ/-1 l q Int.- Int.+ ϕ q Int.+ Int.+ op/seq/cost l q) ≡⟨ P.cong (λ x → Int.+ ϕ q Int.+ (x Int.+ Int.+ op/seq/cost l q)) (IntP.m-n≡m⊖n (ϕ/-1 l q) (ϕ q)) ⟩
    Int.+ ϕ q Int.+ (ϕ/-1 l q Int.⊖ ϕ q Int.+ Int.+ op/seq/cost l q) ≡⟨ P.cong (λ x → Int.+ ϕ q Int.+ x) (P.sym (cost≡cost/tele l q u)) ⟩
    Int.+ ϕ q Int.+ op/seq/cost/tele l q ≤⟨ IntP.+-monoʳ-≤ (Int.+ ϕ q) (amortized≥cost/tele q l l' h) ⟩
    Int.+ ϕ q Int.+ Int.+ lsum l' ≤⟨ IntP.≤-refl ⟩
    Int.+ ϕ q Int.+ Int.+ lsum l'
    ∎
   where open IntP.≤-Reasoning

  -- Amortized cost for enq and deq on a front-back queue
  enq/acost : ∀ x → ◯ (is/acost (op/enq x) 2)
  enq/acost x u (f , b) =
    begin
      (Int.+ (op/cost (op/enq x) (f , b))) Int.+ (((op/enq x) operateϕ (f , b)) Int.⊖ (ϕ (f , b)))
    ≡⟨⟩
      Int.0ℤ Int.+ ((len f + 2 * (1 + len b)) Int.⊖ (ϕ (f , b)))
    ≡⟨ IntP.+-identityˡ ((len f + 2 * (1 + len b)) Int.⊖ (ϕ (f , b))) ⟩
      len f + 2 * (1 + len b) Int.⊖ ϕ (f , b)
    ≡⟨ P.cong (λ x → (len f + x) Int.⊖ (ϕ (f , b))) (*-distribˡ-+ 2 1 (len b)) ⟩
      len f + (2 * 1 + 2 * len b) Int.⊖ ϕ (f , b)
    ≡⟨ P.cong (λ x → (len f + x) Int.⊖ (ϕ (f , b)) ) (+-comm 2 (2 * len b)) ⟩
      len f + (2 * len b + 2) Int.⊖ ϕ (f , b)
    ≡⟨ P.cong (λ x → x Int.⊖ (ϕ (f , b))) (P.sym (+-assoc (len f) (2 * len b) 2)) ⟩
      len f + 2 * len b + 2 Int.⊖ ϕ (f , b)
    ≡⟨ P.cong (λ x → (len f + 2 * len b + 2) Int.⊖ x) (P.sym (+-identityʳ (ϕ (f , b)))) ⟩
      len f + 2 * len b + 2 Int.⊖ (ϕ (f , b) + 0)
    ≡⟨ IntP.+-cancelˡ-⊖ (len f + 2 * len b) 2 0 ⟩
      Int.+ 2
    ∎
    where open IntP.≤-Reasoning

  n+n≡2*n : ∀ n → n + n ≡ 2 * n
  n+n≡2*n n =
    begin
    n + n ≡⟨ P.cong (λ x → n + x) (P.sym (+-identityʳ n)) ⟩
    2 * n ∎
    where open ≡-Reasoning

  deq/acost : ◯ (is/acost op/deq 0)
  deq/acost u (f , b) =
    list/match f (λ f → meta ((Int.+ (op/cost op/deq (f , b))) Int.+ ((op/deq operateϕ (f , b)) Int.⊖ (ϕ (f , b))) Int.≤ Int.0ℤ))
    (
    list/match b (λ b → meta ((Int.+ (op/cost op/deq (nil , b))) Int.+ ((op/deq operateϕ (nil , b)) Int.⊖ (ϕ (nil , b))) Int.≤ Int.0ℤ))
    IntP.≤-refl
    λ a b' →
      begin
        (Int.+ (op/cost op/deq (nil , cons a b'))) Int.+ ((op/deq operateϕ (nil , cons a b')) Int.⊖ (ϕ (nil , cons a b')))
      ≡⟨⟩
        Int.+ (step cost 1 (2 + len b')) Int.+ (step cost 1 (len b') Int.⊖ (2 * (step cost 1 (1 + len b'))))
      ≡⟨
        cong₂ Int._+_
          (cong Int.+_ (step/ext cost (2 + len b') 1 u))
          (cong₂ Int._⊖_
            (step/ext cost (len b') 1 u)
            (cong (2 *_) (step/ext cost (1 + len b') 1 u))
          )
      ⟩
        Int.+ (2 + len b') Int.+ (len b' Int.⊖ (2 * (1 + len b')))
      ≡⟨ IntP.distribʳ-⊖-+-pos (2 + len b') (len b') (2 * (1 + len b')) ⟩
        2 + len b' + len b' Int.⊖ 2 * (1 + len b')
      ≡⟨ P.cong (λ x → x Int.⊖ 2 * (1 + len b')) (+-assoc 2 (len b') (len b')) ⟩
        2 + (len b' + len b') Int.⊖ 2 * (1 + len b')
      ≡⟨ P.cong (λ x → 2 + (len b'  + len b') Int.⊖ x) (*-distribˡ-+ 2 1 (len b')) ⟩
        2 + (len b' + len b') Int.⊖ (2 * 1 + 2 * len b')
      ≡⟨ P.cong (λ x → 2 + x Int.⊖ (2 + 2 * len b')) (n+n≡2*n (len b')) ⟩
        2 + 2 * len b' Int.⊖ (2 + 2 * len b')
      ≡⟨ IntP.n⊖n≡0 (2 + 2 * len b') ⟩
        Int.0ℤ
      ∎
    )
    λ a f' →
      begin
        (Int.+ (op/cost op/deq (cons a f' , b))) Int.+ ((op/deq operateϕ (cons a f' , b)) Int.⊖ (ϕ (cons a f' , b)))
      ≡⟨⟩
        Int.+ (step cost 1 1) Int.+ (step cost 1 (len f' + 2 * len b) Int.⊖ (step cost 1 (1 + len f') + 2 * len b))
      ≡⟨
        cong₂ Int._+_
          (cong Int.+_ (step/ext cost 1 1 u))
          (cong₂ Int._⊖_
            (step/ext cost (len f' + 2 * len b) 1 u)
            (cong (_+ 2 * len b) (step/ext cost (1 + len f') 1 u))
          )
      ⟩
        Int.+ 1 Int.+ ((len f' + 2 * len b) Int.⊖ (1 + len f' + 2 * len b))
      ≡⟨ IntP.distribʳ-⊖-+-pos 1 (len f' + 2 * len b) (1 + len f' + 2 * len b) ⟩
        1 + (len f' + 2 * len b) Int.⊖ (1 + len f' + 2 * len b)
      ≡⟨ P.cong (λ x → x Int.⊖ (1 + len f' + 2 * len b)) (P.sym (+-assoc 1 (len f') (2 * len b))) ⟩
        1 + len f' + 2 * len b Int.⊖ (1 + len f' + 2 * len b)
      ≡⟨ IntP.n⊖n≡0 (1 + len f' + 2 * len b) ⟩
        Int.0ℤ
      ∎
    where open IntP.≤-Reasoning

  all2s : ℕ → List ℕ
  all2s n = tabulate {n = n} (λ _ → 2)

  sum2s : ∀ n → lsum (all2s n) ≡ 2 * n
  sum2s zero = refl
  sum2s (suc n) =
    begin
    2 + lsum (all2s n) ≡⟨ P.cong (λ x → 2 + x) (sum2s n) ⟩
    2 + 2 * n ≡⟨ P.cong (λ x → x + 2 * n) (*-identityʳ 2) ⟩
    2 * 1 + 2 * n ≡⟨ P.sym (*-distribˡ-+ 2 1 n) ⟩
    2 * (1 + n)
    ∎
   where open ≡-Reasoning

  all2s/is/acost : ∀ l → ◯ (Amortized l (all2s (length l)))
  all2s/is/acost [] u = a/emp
  all2s/is/acost ((op/enq x) ∷ os) u = a/cons (op/enq x) 2 os (all2s (length os)) (enq/acost x u) (all2s/is/acost os u)
  all2s/is/acost (op/deq ∷ os) u = a/cons op/deq 2 os (all2s (length os)) (acost/weaken z≤n (deq/acost u)) (all2s/is/acost os u)

  op/seq/cost≤ϕ₀+2*|l| : ∀ q l → ◯ (Int.+ (op/seq/cost l q) Int.≤  Int.+ (ϕ q + 2 * length l))
  op/seq/cost≤ϕ₀+2*|l| q l u =
    begin
    Int.+ (op/seq/cost l q) ≤⟨ amortized≥cost q l (all2s (length l)) (all2s/is/acost l u) u ⟩
    Int.+ (ϕ q + lsum (all2s (length l))) ≡⟨ P.cong (λ x → Int.+ (ϕ q + x)) (sum2s (length l)) ⟩
    Int.+ (ϕ q + 2 * length l) ≤⟨ IntP.≤-refl ⟩
    Int.+ (ϕ q + 2 * length l)
    ∎
   where open IntP.≤-Reasoning

  -- Starting with an empty queue, a sequence of n operations costs at most 2 * n
  op/seq≤2*|l| : ∀ l → IsBounded Q (l op/seq emp) (2 * length l)
  op/seq≤2*|l| l = bound/relax (λ u → IntP.drop‿+≤+ (op/seq/cost≤ϕ₀+2*|l| emp l u)) (op/seq≤op/seq/cost l emp)


open import Nat
open import Prelude
open import core
open import judgemental-erase
open import aasubsume-min

module determinism where
  -- the same action applied to the same type makes the same type
  actdet-type : {t t' t'' : τ̂} {α : action} →
            (t + α +> t') →
            (t + α +> t'') →
            (t' == t'')
  actdet-type TMArrChild1 TMArrChild1 = refl
  actdet-type TMArrChild2 TMArrChild2 = refl
  actdet-type TMArrParent1 TMArrParent1 = refl
  actdet-type TMArrParent1 (TMArrZip1 ())
  actdet-type TMArrParent2 TMArrParent2 = refl
  actdet-type TMArrParent2 (TMArrZip2 ())
  actdet-type TMDel TMDel = refl
  actdet-type TMConArrow TMConArrow = refl
  actdet-type TMConNum TMConNum = refl
  actdet-type (TMArrZip1 ()) TMArrParent1
  actdet-type (TMArrZip1 p1) (TMArrZip1 p2) with actdet-type p1 p2
  ... | refl = refl
  actdet-type (TMArrZip2 ()) TMArrParent2
  actdet-type (TMArrZip2 p1) (TMArrZip2 p2) with actdet-type p1 p2
  ... | refl = refl

  -- all expressions only move to one other expression
  movedet : {e e' e'' : ê} {δ : direction} →
            (e + move δ +>e e') →
            (e + move δ +>e e'') →
            e' == e''
  movedet EMAscChild1 EMAscChild1 = refl
  movedet EMAscChild2 EMAscChild2 = refl
  movedet EMAscParent1 EMAscParent1 = refl
  movedet EMAscParent2 EMAscParent2 = refl
  movedet EMLamChild1 EMLamChild1 = refl
  movedet EMLamParent EMLamParent = refl
  movedet EMPlusChild1 EMPlusChild1 = refl
  movedet EMPlusChild2 EMPlusChild2 = refl
  movedet EMPlusParent1 EMPlusParent1 = refl
  movedet EMPlusParent2 EMPlusParent2 = refl
  movedet EMApChild1 EMApChild1 = refl
  movedet EMApChild2 EMApChild2 = refl
  movedet EMApParent1 EMApParent1 = refl
  movedet EMApParent2 EMApParent2 = refl
  movedet EMNEHoleChild1 EMNEHoleChild1 = refl
  movedet EMNEHoleParent EMNEHoleParent = refl

  -- non-movement lemmas; theses show up pervasively throughout and save a
  -- lot of pattern matching.
  lem-nomove-part : ∀ {t t'} → ▹ t ◃ + move parent +> t' → ⊥
  lem-nomove-part ()

  lem-nomove-pars : ∀{Γ e t e' t'} → Γ ⊢ ▹ e ◃ => t ~ move parent ~> e' => t' → ⊥
  lem-nomove-pars (SAMove ())

  lem-nomove-para : ∀{Γ e t e'} → Γ ⊢ ▹ e ◃ ~ move parent ~> e' ⇐ t → ⊥
  lem-nomove-para (AASubsume e x x₁ x₂) = lem-nomove-pars x₁
  lem-nomove-para (AAMove ())

  -- if a move action on a synthetic action makes a new form, it's unique
  synthmovedet : {Γ : ·ctx} {e e' e'' : ê} {t' t'' : τ̇} {δ : direction} →
         (Γ ⊢ e => t' ~ move δ ~> e'' => t'') →
         (e + move δ +>e e') →
         e'' == e'
  synthmovedet (SAMove m1) m2 = movedet m1 m2
  -- all these cases lead to absurdities based on movement
  synthmovedet (SAZipAsc1 x) EMAscParent1         = abort (lem-nomove-para x)
  synthmovedet (SAZipAsc2 x _ _ _) EMAscParent2   = abort (lem-nomove-part x)
  synthmovedet (SAZipApArr _ _ _ x _) EMApParent1 = abort (lem-nomove-pars x)
  synthmovedet (SAZipApAna _ _ x) EMApParent2     = abort (lem-nomove-para x)
  synthmovedet (SAZipPlus1 x) EMPlusParent1       = abort (lem-nomove-para x)
  synthmovedet (SAZipPlus2 x) EMPlusParent2       = abort (lem-nomove-para x)
  synthmovedet (SAZipHole _ _ x) EMNEHoleParent   = abort (lem-nomove-pars x)

  anamovedet : {Γ : ·ctx} {e e' e'' : ê} {t : τ̇} {δ : direction} →
         (Γ ⊢ e ~ move δ ~> e'' ⇐ t) →
         (e + move δ +>e e') →
         e'' == e'
  anamovedet (AASubsume x₂ x x₃ x₁) m = synthmovedet x₃ m
  anamovedet (AAMove x) m = movedet x m
  anamovedet (AAZipLam x₁ x₂ d) EMLamParent = abort (lem-nomove-para d)

  mutual
    -- an action on an expression in a synthetic position produces one
    -- resultant expression and type.
    actdet-synth : {Γ : ·ctx} {e e' e'' : ê} {e◆ : ė} {t t' t'' : τ̇} {α : action} →
              (E : erase-e e e◆) →
              (Γ ⊢ e◆ => t) →
              (d1 : Γ ⊢ e => t ~ α ~> e'  => t') →
              (d2 : Γ ⊢ e => t ~ α ~> e'' => t'') →
              {p1 : aasubmin-synth d1} →
              {p2 : aasubmin-synth d2} →
              (e' == e'' × t' == t'')
    actdet-synth EETop (SAsc x) (SAMove x₁) (SAMove x₂) = movedet x₁ x₂ , refl
    actdet-synth EETop (SAsc x) SADel SADel = refl , refl
    actdet-synth EETop (SAsc x) SAConAsc SAConAsc = refl , refl
    actdet-synth EETop (SAsc x) (SAConPlus1 x₁) (SAConPlus1 x₂) = refl , refl
    actdet-synth EETop (SAsc x) (SAConPlus1 x₁) (SAConPlus2 x₂) = abort (x₂ x₁)
    actdet-synth EETop (SAsc x) (SAConPlus2 x₁) (SAConPlus1 x₂) = abort (x₁ x₂)
    actdet-synth EETop (SAsc x) (SAConPlus2 x₁) (SAConPlus2 x₂) = refl , refl
    actdet-synth EETop (SAsc x) (SAConApArr x₁) (SAConApArr x₂) with matcharrunicity x₁ x₂
    ... | refl = refl , refl
    actdet-synth EETop (SAsc x) (SAConApArr x₁) (SAConApOtw x₂) = abort (x₂ (matchconsist x₁))
    actdet-synth EETop (SAsc x) (SAConApOtw x₁) (SAConApArr x₂) = abort (x₁ (matchconsist x₂))
    actdet-synth EETop (SAsc x) (SAConApOtw x₁) (SAConApOtw x₂) = refl , refl
    actdet-synth EETop (SAsc x) SAConNEHole SAConNEHole = refl , refl

    actdet-synth (EEAscL E) (SAsc x) (SAMove x₁) (SAMove x₂) = movedet x₁ x₂ , refl
    actdet-synth (EEAscL E) (SAsc x) (SAMove EMAscParent1) (SAZipAsc1 x₂) = abort (lem-nomove-para x₂)
    actdet-synth (EEAscL E) (SAsc x) (SAZipAsc1 x₁) (SAMove EMAscParent1) = abort (lem-nomove-para x₁)
    actdet-synth (EEAscL E) (SAsc x) (SAZipAsc1 x₁) (SAZipAsc1 x₂) {p1} {p2}
     with actdet-ana E x x₁ x₂ {p1} {p2}
    ... | refl = refl , refl

    actdet-synth (EEAscR x) (SAsc x₁) (SAMove x₂) (SAMove x₃) = movedet x₂ x₃ , refl
    actdet-synth (EEAscR x) (SAsc x₁) (SAMove EMAscParent2) (SAZipAsc2 a _ _ _) = abort (lem-nomove-part a)
    actdet-synth (EEAscR x) (SAsc x₁) (SAZipAsc2 a _ _ _) (SAMove EMAscParent2) = abort (lem-nomove-part a)
    actdet-synth (EEAscR x) (SAsc x₂) (SAZipAsc2 a e1 _ _) (SAZipAsc2 b e2 _ _)
      with actdet-type a b
    ... | refl = refl , eraset-det e1 e2

    actdet-synth EETop (SVar x) (SAMove x₁) (SAMove x₂) = movedet x₁ x₂ , refl
    actdet-synth EETop (SVar x) SADel SADel = refl , refl
    actdet-synth EETop (SVar x) SAConAsc SAConAsc = refl , refl
    actdet-synth EETop (SVar x) (SAConPlus1 x₁) (SAConPlus1 x₂) = refl , refl
    actdet-synth EETop (SVar x) (SAConPlus1 x₁) (SAConPlus2 x₂) = abort (x₂ x₁)
    actdet-synth EETop (SVar x) (SAConPlus2 x₁) (SAConPlus1 x₂) = abort (x₁ x₂)
    actdet-synth EETop (SVar x) (SAConPlus2 x₁) (SAConPlus2 x₂) = refl , refl
    actdet-synth EETop (SVar x) (SAConApArr x₁) (SAConApArr x₂) with matcharrunicity x₁ x₂
    ... | refl = refl , refl
    actdet-synth EETop (SVar x) (SAConApArr x₁) (SAConApOtw x₂) = abort (x₂ (matchconsist x₁))
    actdet-synth EETop (SVar x) (SAConApOtw x₁) (SAConApArr x₂) = abort (x₁ (matchconsist x₂))
    actdet-synth EETop (SVar x) (SAConApOtw x₁) (SAConApOtw x₂) = refl , refl
    actdet-synth EETop (SVar x) SAConNEHole SAConNEHole = refl , refl

    actdet-synth EETop (SAp m wt x) (SAMove x₁) (SAMove x₂) = movedet x₁ x₂ , refl
    actdet-synth EETop (SAp m wt x) SADel SADel = refl , refl
    actdet-synth EETop (SAp m wt x) SAConAsc SAConAsc = refl , refl
    actdet-synth EETop (SAp m wt x) (SAConPlus1 x₁) (SAConPlus1 x₂) = refl , refl
    actdet-synth EETop (SAp m wt x) (SAConPlus1 x₁) (SAConPlus2 x₂) = abort (x₂ x₁)
    actdet-synth EETop (SAp m wt x) (SAConPlus2 x₁) (SAConPlus1 x₂) = abort (x₁ x₂)
    actdet-synth EETop (SAp m wt x) (SAConPlus2 x₁) (SAConPlus2 x₂) = refl , refl
    actdet-synth EETop (SAp m wt x) (SAConApArr x₁) (SAConApArr x₂) with matcharrunicity x₁ x₂
    ... | refl = refl , refl
    actdet-synth EETop (SAp m wt x) (SAConApArr x₁) (SAConApOtw x₂) = abort (x₂ (matchconsist x₁))
    actdet-synth EETop (SAp m wt x) (SAConApOtw x₁) (SAConApArr x₂) = abort (x₁ (matchconsist x₂))
    actdet-synth EETop (SAp m wt x) (SAConApOtw x₁) (SAConApOtw x₂) = refl , refl
    actdet-synth EETop (SAp m wt x) SAConNEHole SAConNEHole = refl , refl

    actdet-synth (EEApL E) (SAp m wt x) (SAMove x₁) (SAMove x₂) = movedet x₁ x₂ , refl
    actdet-synth (EEApL E) (SAp m wt x) (SAMove EMApParent1) (SAZipApArr _ x₂ x₃ d2 x₄) = abort (lem-nomove-pars d2)
    actdet-synth (EEApL E) (SAp m wt x) (SAZipApArr _ x₁ x₂ d1 x₃) (SAMove EMApParent1) = abort (lem-nomove-pars d1)
    actdet-synth (EEApL E) (SAp m wt x) (SAZipApArr a x₁ x₂ d1 x₃) (SAZipApArr b x₄ x₅ d2 x₆) {p1} {p2}
      with erasee-det x₁ x₄
    ... | refl with synthunicity x₂ x₅
    ... | refl with erasee-det E x₁
    ... | refl with actdet-synth E x₅ d1 d2 {p1} {p2}
    ... | refl , refl with matcharrunicity a b
    ... | refl = refl , refl

    actdet-synth (EEApR E) (SAp m wt x) (SAMove x₁) (SAMove x₂) = movedet x₁ x₂ , refl
    actdet-synth (EEApR E) (SAp m wt x) (SAMove EMApParent2) (SAZipApAna x₂ x₃ x₄) = abort (lem-nomove-para x₄)
    actdet-synth (EEApR E) (SAp m wt x) (SAZipApAna x₁ x₂ x₃) (SAMove EMApParent2) = abort (lem-nomove-para x₃)
    actdet-synth (EEApR E) (SAp m wt x) (SAZipApAna x₁ x₂ d1) (SAZipApAna x₄ x₅ d2)  {p1} {p2}
     with synthunicity m x₂
    ... | refl with matcharrunicity x₁ wt
    ... | refl with synthunicity m x₅
    ... | refl with matcharrunicity x₄ wt
    ... | refl with actdet-ana E x d1 d2  {p1} {p2}
    ... | refl = refl , refl

    actdet-synth EETop SNum (SAMove x) (SAMove x₁) = movedet x x₁ , refl
    actdet-synth EETop SNum SADel SADel = refl , refl
    actdet-synth EETop SNum SAConAsc SAConAsc = refl , refl
    actdet-synth EETop SNum (SAConPlus1 x) (SAConPlus1 x₁) = refl , refl
    actdet-synth EETop SNum (SAConPlus1 x) (SAConPlus2 x₁) = abort (x₁ x)
    actdet-synth EETop SNum (SAConPlus2 x) (SAConPlus1 x₁) = abort (x x₁)
    actdet-synth EETop SNum (SAConPlus2 x) (SAConPlus2 x₁) = refl , refl
    actdet-synth EETop SNum (SAConApArr x) (SAConApArr x₁) with matcharrunicity x x₁
    ... | refl = refl , refl
    actdet-synth EETop SNum (SAConApArr x) (SAConApOtw x₁) = abort (x₁ (matchconsist x))
    actdet-synth EETop SNum (SAConApOtw x) (SAConApArr x₁) = abort (x (matchconsist x₁))
    actdet-synth EETop SNum (SAConApOtw x) (SAConApOtw x₁) = refl , refl
    actdet-synth EETop SNum SAConNEHole SAConNEHole = refl , refl

    actdet-synth EETop (SPlus x x₁) (SAMove x₂) (SAMove x₃) = movedet x₂ x₃ , refl
    actdet-synth EETop (SPlus x x₁) SADel SADel = refl , refl
    actdet-synth EETop (SPlus x x₁) SAConAsc SAConAsc = refl , refl
    actdet-synth EETop (SPlus x x₁) (SAConPlus1 x₂) (SAConPlus1 x₃) = refl , refl
    actdet-synth EETop (SPlus x x₁) (SAConPlus1 x₂) (SAConPlus2 x₃) = abort (x₃ x₂)
    actdet-synth EETop (SPlus x x₁) (SAConPlus2 x₂) (SAConPlus1 x₃) = abort (x₂ x₃)
    actdet-synth EETop (SPlus x x₁) (SAConPlus2 x₂) (SAConPlus2 x₃) = refl , refl
    actdet-synth EETop (SPlus x x₁) (SAConApArr x₂) (SAConApArr x₃) with matcharrunicity x₂ x₃
    ... | refl = refl , refl
    actdet-synth EETop (SPlus x x₁) (SAConApArr x₂) (SAConApOtw x₃) = abort (matchnotnum x₂)
    actdet-synth EETop (SPlus x x₁) (SAConApOtw x₂) (SAConApArr x₃) = abort (matchnotnum x₃)
    actdet-synth EETop (SPlus x x₁) (SAConApOtw x₂) (SAConApOtw x₃) = refl , refl
    actdet-synth EETop (SPlus x x₁) SAConNEHole SAConNEHole = refl , refl

    actdet-synth (EEPlusL E) (SPlus x x₁) (SAMove x₂) (SAMove x₃) = movedet x₂ x₃ , refl
    actdet-synth (EEPlusL E) (SPlus x x₁) (SAMove EMPlusParent1) (SAZipPlus1 d2) = abort (lem-nomove-para d2)
    actdet-synth (EEPlusL E) (SPlus x x₁) (SAZipPlus1 x₂) (SAMove EMPlusParent1) = abort (lem-nomove-para x₂)
    actdet-synth (EEPlusL E) (SPlus x x₁) (SAZipPlus1 x₂) (SAZipPlus1 x₃) {p1} {p2}
      = ap1 (λ x₄ → x₄ ·+₁ _) (actdet-ana E x x₂ x₃  {p1} {p2}) , refl

    actdet-synth (EEPlusR E) (SPlus x x₁) (SAMove x₂) (SAMove x₃) = movedet x₂ x₃ , refl
    actdet-synth (EEPlusR E) (SPlus x x₁) (SAMove EMPlusParent2) (SAZipPlus2 x₃) = abort (lem-nomove-para x₃)
    actdet-synth (EEPlusR E) (SPlus x x₁) (SAZipPlus2 x₂) (SAMove EMPlusParent2) = abort (lem-nomove-para x₂)
    actdet-synth (EEPlusR E) (SPlus x x₁) (SAZipPlus2 x₂) (SAZipPlus2 x₃) {p1} {p2}
      = ap1 (_·+₂_ _) (actdet-ana E x₁ x₂ x₃ {p1} {p2}) , refl

    actdet-synth EETop SEHole (SAMove x) (SAMove x₁) = movedet x x₁ , refl
    actdet-synth EETop SEHole SADel SADel = refl , refl
    actdet-synth EETop SEHole SAConAsc SAConAsc = refl , refl
    actdet-synth EETop SEHole (SAConVar {Γ = G} p) (SAConVar p₁) = refl , (ctxunicity {Γ = G} p p₁)
    actdet-synth EETop SEHole (SAConLam x₁) (SAConLam x₂) = refl , refl
    actdet-synth EETop SEHole SAConNumlit SAConNumlit = refl , refl
    actdet-synth EETop SEHole (SAConPlus1 x) (SAConPlus1 x₁) = refl , refl
    actdet-synth EETop SEHole (SAConPlus1 x) (SAConPlus2 x₁) = abort (x₁ x)
    actdet-synth EETop SEHole (SAConPlus2 x) (SAConPlus1 x₁) = abort (x x₁)
    actdet-synth EETop SEHole (SAConPlus2 x) (SAConPlus2 x₁) = refl , refl
    actdet-synth EETop SEHole (SAConApArr x) (SAConApArr x₁) with matcharrunicity x x₁
    ... | refl = refl , refl
    actdet-synth EETop SEHole (SAConApArr x) (SAConApOtw x₁) = abort (x₁ TCHole2)
    actdet-synth EETop SEHole (SAConApOtw x) (SAConApArr x₁) = abort (x TCHole2)
    actdet-synth EETop SEHole (SAConApOtw x) (SAConApOtw x₁) = refl , refl
    actdet-synth EETop SEHole SAConNEHole SAConNEHole = refl , refl

    actdet-synth EETop (SNEHole wt) (SAMove x) (SAMove x₁) = movedet x x₁ , refl
    actdet-synth EETop (SNEHole wt) SADel SADel = refl , refl
    actdet-synth EETop (SNEHole wt) SAConAsc SAConAsc = refl , refl
    actdet-synth EETop (SNEHole wt) (SAConPlus1 x) (SAConPlus1 x₁) = refl , refl
    actdet-synth EETop (SNEHole wt) (SAConPlus1 x) (SAConPlus2 x₁) = abort (x₁ x)
    actdet-synth EETop (SNEHole wt) (SAConPlus2 x) (SAConPlus1 x₁) = abort (x x₁)
    actdet-synth EETop (SNEHole wt) (SAConPlus2 x) (SAConPlus2 x₁) = refl , refl
    actdet-synth EETop (SNEHole wt) (SAFinish x) (SAFinish x₁) = refl , synthunicity x x₁
    actdet-synth EETop (SNEHole wt) (SAConApArr x) (SAConApArr x₁) with matcharrunicity x x₁
    ... | refl = refl , refl
    actdet-synth EETop (SNEHole wt) (SAConApArr x) (SAConApOtw x₁) = abort (x₁ TCHole2)
    actdet-synth EETop (SNEHole wt) (SAConApOtw x) (SAConApArr x₁) = abort (x TCHole2)
    actdet-synth EETop (SNEHole wt) (SAConApOtw x) (SAConApOtw x₁) = refl , refl
    actdet-synth EETop (SNEHole wt) SAConNEHole SAConNEHole = refl , refl

    actdet-synth (EENEHole E) (SNEHole wt) (SAMove x) (SAMove x₁) = movedet x x₁ , refl
    actdet-synth (EENEHole E) (SNEHole wt) (SAMove EMNEHoleParent) (SAZipHole _ x₁ d2) = abort (lem-nomove-pars d2)
    actdet-synth (EENEHole E) (SNEHole wt) (SAZipHole _ x d1) (SAMove EMNEHoleParent) = abort (lem-nomove-pars d1)
    actdet-synth (EENEHole E) (SNEHole wt) (SAZipHole a x d1) (SAZipHole b x₁ d2) {p1} {p2}
      with erasee-det a b
    ... | refl with synthunicity x x₁
    ... | refl with actdet-synth a x d1 d2  {p1} {p2}
    ... | refl , refl = refl , refl

    -- an action on an expression in an analytic position produces one
    -- resultant expression and type.
    actdet-ana : {Γ : ·ctx} {e e' e'' : ê} {e◆ : ė} {t : τ̇} {α : action} →
              (erase-e e e◆) →
              (Γ ⊢ e◆ <= t) →
              (d1 : Γ ⊢ e ~ α ~> e' ⇐ t) →
              (d2 : Γ ⊢ e ~ α ~> e'' ⇐ t) →
              {p1 : aasubmin-ana d1} →
              {p2 : aasubmin-ana d2} →
              e' == e''
    ---- lambda cases first
    -- an erased lambda can't be typechecked with subsume
    actdet-ana (EELam _) (ASubsume () _) _ _

    -- for things paired with movements, punt to the move determinism case
    actdet-ana _ _ D (AAMove y) = anamovedet D y
    actdet-ana _ _ (AAMove y) D =  ! (anamovedet D y)

    -- lambdas never match with subsumption actions, because it won't be well typed.
    actdet-ana EETop      (ALam x₁ x₂ wt) (AASubsume EETop () x₅ x₆) _
    actdet-ana (EELam _) (ALam x₁ x₂ wt) (AASubsume (EELam x₃) () x₅ x₆) _
    actdet-ana EETop      (ALam x₁ x₂ wt) _ (AASubsume EETop () x₅ x₆)
    actdet-ana (EELam _) (ALam x₁ x₂ wt) _ (AASubsume (EELam x₃) () x₅ x₆)

    -- with the cursor at the top, there are only two possible actions
    actdet-ana EETop (ALam x₁ x₂ wt) AADel AADel = refl
    actdet-ana EETop (ALam x₁ x₂ wt) AAConAsc AAConAsc = refl

    -- and for the remaining case, recurr on the smaller derivations
    actdet-ana (EELam er) (ALam x₁ x₂ wt) (AAZipLam x₃ x₄ d1) (AAZipLam x₅ x₆ d2) {p1} {p2}
       with matcharrunicity x₄ x₆
    ... | refl with matcharrunicity x₄ x₂
    ... | refl with actdet-ana er wt d1 d2  {p1} {p2}
    ... | refl = refl

    ---- now the subsumption cases
      -- subsume / subsume, so pin things down then recurr
    actdet-ana er (ASubsume a b) (AASubsume x x₁ x₂ x₃) (AASubsume x₄ x₅ x₆ x₇) {p1} {p2}
      with erasee-det x₄ x
    ... | refl with erasee-det er x₄
    ... | refl with synthunicity x₅ x₁
    ... | refl = π1 (actdet-synth x x₅ x₂ x₆ {min-ana-lem x₂ p1} {min-ana-lem x₆ p2})

    -- (these are all repeated below, irritatingly.)
    actdet-ana EETop (ASubsume a b) (AASubsume EETop x SADel x₁) AADel = refl
    actdet-ana EETop (ASubsume a b) (AASubsume EETop x SAConAsc x₁) AAConAsc {p1} = abort p1
    actdet-ana EETop (ASubsume SEHole b) (AASubsume EETop SEHole (SAConVar {Γ = Γ} p) x₂) (AAConVar x₅ p₁)
      with ctxunicity {Γ = Γ} p p₁
    ... | refl = abort (x₅ x₂)
    actdet-ana EETop (ASubsume SEHole b) (AASubsume EETop SEHole (SAConLam x₄) x₂) (AAConLam1 x₅ m) {p1} = abort p1
    actdet-ana EETop (ASubsume a b) (AASubsume EETop x₁ (SAConLam x₃) x₂) (AAConLam2 x₅ x₆) = abort (x₆ x₂)
    actdet-ana EETop (ASubsume a b) (AASubsume EETop x₁ SAConNumlit x₂) (AAConNumlit x₄) = abort (x₄ x₂)
    actdet-ana EETop (ASubsume a b) (AASubsume EETop x (SAFinish x₂) x₁) (AAFinish x₄) = refl

      -- subsume / del
    actdet-ana er (ASubsume a b) AADel (AASubsume x x₁ SADel x₃) = refl
    actdet-ana er (ASubsume a b) AADel AADel = refl

      -- subsume / conasc
    actdet-ana EETop (ASubsume a b) AAConAsc (AASubsume EETop x₁ SAConAsc x₃) {p2 = p2} = abort p2
    actdet-ana er (ASubsume a b) AAConAsc AAConAsc = refl

      -- subsume / convar
    actdet-ana EETop (ASubsume SEHole b) (AAConVar x₁ p) (AASubsume EETop SEHole (SAConVar {Γ = Γ} p₁) x₅)
      with ctxunicity {Γ = Γ} p p₁
    ... | refl = abort (x₁ x₅)
    actdet-ana er (ASubsume a b) (AAConVar x₁ p) (AAConVar x₂ p₁) = refl

      -- subsume / conlam1
    actdet-ana EETop (ASubsume SEHole b) (AAConLam1 x₁ x₂) (AASubsume EETop SEHole (SAConLam x₃) x₆) {p2 = p2} = abort p2
    actdet-ana er (ASubsume a b) (AAConLam1 x₁ MAHole) (AAConLam2 x₃ x₄) = abort (x₄ TCHole2)
    actdet-ana er (ASubsume a b) (AAConLam1 x₁ MAArr) (AAConLam2 x₃ x₄) = abort (x₄ (TCArr TCHole1 TCHole1))
    actdet-ana er (ASubsume a b) (AAConLam1 x₁ x₂) (AAConLam1 x₃ x₄) = refl

      -- subsume / conlam2
    actdet-ana EETop (ASubsume SEHole TCRefl) (AAConLam2 x₁ x₂) (AASubsume EETop SEHole x₅ x₆) = abort (x₂ TCHole2)
    actdet-ana EETop (ASubsume SEHole TCHole1) (AAConLam2 x₁ x₂) (AASubsume EETop SEHole (SAConLam x₃) x₆) = abort (x₂ x₆)
    actdet-ana EETop (ASubsume SEHole TCHole2) (AAConLam2 x₁ x₂) (AASubsume EETop SEHole x₅ x₆) = abort (x₂ TCHole2)
    actdet-ana EETop (ASubsume a b) (AAConLam2 x₂ x₁) (AAConLam1 x₃ MAHole) = abort (x₁ TCHole2)
    actdet-ana EETop (ASubsume a b) (AAConLam2 x₂ x₁) (AAConLam1 x₃ MAArr) = abort (x₁ (TCArr TCHole1 TCHole1))
    actdet-ana er (ASubsume a b) (AAConLam2 x₂ x) (AAConLam2 x₃ x₄) = refl

      -- subsume / numlit
    actdet-ana er (ASubsume a b) (AAConNumlit x) (AASubsume x₁ x₂ SAConNumlit x₄) = abort (x x₄)
    actdet-ana er (ASubsume a b) (AAConNumlit x) (AAConNumlit x₁) = refl

      -- subsume / finish
    actdet-ana er (ASubsume a b) (AAFinish x) (AASubsume x₁ x₂ (SAFinish x₃) x₄) = refl
    actdet-ana er (ASubsume a b) (AAFinish x) (AAFinish x₁) = refl


module _ where

module A where

  infix 2 _↑
  infix 1 c

  data D : Set where
    ●  : D
    _↑ : D → D
    c  : {x y : D} → D

  syntax c {x = x} {y = y} = x ↓ y

module B where

  infix 1 c

  data D : Set where
    c : {y x : D} → D

  syntax c {y = y} {x = x} = y ↓ x

open A
open B

rejected : A.D
rejected = ● ↑ ↓ ●


open import Agda.Primitive

variable
  @0 ℓ : Level
  A : Set ℓ

levelOf : A → Level
levelOf {a} _ = a