{-# OPTIONS --safe #-}

module Definition.Typed.Consequences.PiNorm where

open import Definition.Untyped
open import Definition.Untyped.Properties
open import Definition.Typed
open import Definition.Typed.Properties
open import Definition.Typed.Weakening
open import Definition.Typed.EqRelInstance
open import Definition.LogicalRelation
open import Definition.LogicalRelation.Properties
open import Definition.LogicalRelation.Irrelevance
open import Definition.LogicalRelation.Fundamental.Reducibility
open import Definition.Typed.Consequences.Inversion
open import Definition.Typed.Consequences.Injectivity
open import Definition.Typed.Consequences.Syntactic
open import Definition.Conversion.Stability

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

-- reduction including in the codomain of Pis
-- useful to get unicity of relevance

-- there are 2 kinds of fat arrows!!!
-- the constructor for transitivity closure is closed on the left ⇨
-- the ones in types aren't ⇒

data ΠNorm : Term → Set where
  Uₙ : ∀ {r l} → ΠNorm (Univ r l)
  Πₙ : ∀ {F rF lF G lG lΠ} → ΠNorm G → ΠNorm (Π F ^ rF ° lF ▹ G ° lG ° lΠ)
  ∃ₙ : ∀ {F G} → ΠNorm F → ΠNorm (∃ F ▹ G)
  ℕₙ : ΠNorm ℕ
  Emptyₙ : ∀ {lEmpty} → ΠNorm (Empty lEmpty)
  ne   : ∀ {n} → Neutral n → ΠNorm n

ΠNorm-Π : ∀ {F rF lF G lG lΠ} → ΠNorm (Π F ^ rF ° lF ▹ G ° lG ° lΠ) → ΠNorm G
ΠNorm-Π (Πₙ x) = x
ΠNorm-Π (ne ())

data _⊢_⇒Π_∷_^_ (Γ : Con Term) : Term → Term → Term → TypeLevel → Set where
  regular : ∀ {t u A l} → Γ ⊢ t ⇒ u ∷ A ^ l → Γ ⊢ t ⇒Π u ∷ A ^ l
  deepΠ : ∀ {F rF lF G G′ lG rG lΠ}
       → Γ ∙ F ^ [ rF , ι lF ] ⊢ G ⇒Π G′ ∷ Univ rG lG ^ next lG
       → Γ ⊢ Π F ^ rF ° lF ▹ G ° lG ° lΠ ⇒Π Π F ^ rF ° lF ▹ G′ ° lG ° lΠ ∷ Univ rG lΠ ^ next lΠ
  deep∃ : ∀ {F G F′ l∃}
       → Γ ⊢ F ⇒Π F′ ∷ Univ % l∃ ^ next l∃
       → Γ ⊢ ∃ F ▹ G ⇒Π ∃ F′ ▹ G ∷ Univ % l∃ ^ next l∃

data _⊢_⇒Π_^_ (Γ : Con Term) : Term → Term → TypeInfo → Set where
  univ : ∀ {A B r l}
       → Γ ⊢ A ⇒Π B ∷ (Univ r l) ^ next l
       → Γ ⊢ A ⇒Π B ^ [ r , ι l ]

data _⊢_⇒*Π_∷_^_ (Γ : Con Term) : Term → Term → Term → TypeLevel → Set where
  id : ∀ {t T l} → Γ ⊢ t ⇒*Π t ∷ T ^ l
  _⇨_ : ∀ {t t' u T l}
      → Γ ⊢ t  ⇒Π t' ∷ T ^ l
      → Γ ⊢ t' ⇒*Π u ∷ T ^ l
      → Γ ⊢ t  ⇒*Π u ∷ T ^ l

data _⊢_⇒*Π_^_ (Γ : Con Term) : Term → Term → TypeInfo → Set where
  id : ∀ {A r} → Γ ⊢ A ⇒*Π A ^ r
  _⇨_ : ∀ {t t' u r}
      → Γ ⊢ t  ⇒Π t' ^ r
      → Γ ⊢ t' ⇒*Π u ^ r
      → Γ ⊢ t  ⇒*Π u ^ r

_⇨*_ : ∀ {Γ A B C r} → Γ ⊢ A ⇒*Π B ^ r → Γ ⊢ B ⇒*Π C ^ r → Γ ⊢ A ⇒*Π C ^ r
id ⇨* y = y
(x ⇨ x₁) ⇨* y = x ⇨ (x₁ ⇨* y)

regular* : ∀ {Γ t u r} → Γ ⊢ t ⇒* u ^ r → Γ ⊢ t ⇒*Π u ^ r
regular* (id _) = id
regular* (univ x ⇨ x₁) = univ (regular x) ⇨ regular* x₁

deep* : ∀ {Γ F rF lF G G′ lG rG lΠ}
      → Γ ∙ F ^ [ rF , ι lF ] ⊢ G ⇒*Π G′ ^ [ rG , ι lG ]
      → Γ ⊢ Π F ^ rF ° lF ▹ G ° lG ° lΠ ⇒*Π Π F ^ rF ° lF ▹ G′ ° lG ° lΠ ^ [ rG , ι lΠ ]
deep* id = id
deep* (univ (regular x) ⇨ x₁) = univ (deepΠ (regular x)) ⇨ deep* x₁
deep* (univ (deepΠ x) ⇨ x₁) = univ (deepΠ (deepΠ x)) ⇨ deep* x₁
deep* (univ (deep∃ x) ⇨ x₁) = univ (deepΠ (deep∃ x)) ⇨ deep* x₁

deep∃* : ∀ {Γ F G F′ l∃}
      → Γ ⊢ F ⇒*Π F′ ^ [ % , ι l∃ ]
      → Γ ⊢ ∃ F ▹ G ⇒*Π ∃ F′ ▹ G ^ [ % , ι l∃ ]
deep∃* id = id
deep∃* (univ (regular x) ⇨ x₁) = univ (deep∃ (regular x)) ⇨ deep∃* x₁
deep∃* (univ (deepΠ x) ⇨ x₁) = univ (deep∃ (deepΠ x)) ⇨ deep∃* x₁
deep∃* (univ (deep∃ x) ⇨ x₁) = univ (deep∃ (deep∃ x)) ⇨ deep∃* x₁

deep-correct-term : ∀ {Γ t u T l} → Γ ⊢ t ∷ T ^ [ ! , l ] → Γ ⊢ t ⇒Π u ∷ T ^ l → Γ ⊢ u ∷ T ^ [ ! , l ] × Γ ⊢ t ≡ u ∷ T ^ [ ! , l ]
deep-correct-term ⊢t (regular x) =
  let t≡u = subsetTerm x
      _ , _ , ⊢u = syntacticEqTerm t≡u
  in ⊢u , t≡u
deep-correct-term ⊢t (deepΠ X) =
  let _ , l< , l<' , ⊢F , ⊢G , e , _ = inversion-Π ⊢t
      erG , _ = Uinjectivity e
      ⊢G' , G≡G' = deep-correct-term (PE.subst (λ rr → _ ⊢ _ ∷ Univ rr _ ^ _ ) (PE.sym erG) ⊢G) X
  in Πⱼ l< ▹ l<' ▹ ⊢F ▹ ⊢G' , Π-cong l< l<' (univ ⊢F) (refl ⊢F) G≡G'
deep-correct-term ⊢t (deep∃ X) =
  let l , ⊢F , ⊢G , e , _ = inversion-∃ ⊢t
      _ , el = Uinjectivity e
      ⊢Fl = PE.subst (λ ll → _ ⊢ _ ∷ SProp ll ^ [ ! , next ll ] ) (PE.sym el) ⊢F
      ⊢F' , F≡F' = deep-correct-term ⊢Fl X
      ⊢Gl = PE.subst (λ ll → _ ∙ _ ^ [ % , ι ll ] ⊢ _ ∷ SProp ll ^ [ ! , next ll ] ) (PE.sym el) ⊢G
  in ∃ⱼ ⊢F' ▹ stabilityTerm (reflConEq (wfTerm ⊢F) ∙ (univ F≡F')) ⊢Gl , ∃-cong (univ ⊢Fl) F≡F' (refl ⊢Gl)

deep-correct : ∀ {Γ A B r} → Γ ⊢ A ^ r → Γ ⊢ A ⇒Π B ^ r → Γ ⊢ B ^ r × Γ ⊢ A ≡ B ^ r
deep-correct ⊢A (univ x) =
  let ⊢B , A≡B = deep-correct-term (un-univ ⊢A) x
  in univ ⊢B , univ A≡B

deep*-correct-term : ∀ {Γ t u T l} → Γ ⊢ t ∷ T ^ [ ! , l ] → Γ ⊢ t ⇒*Π u ∷ T ^ l → Γ ⊢ t ≡ u ∷ T ^ [ ! , l ]
deep*-correct-term ⊢t id = refl ⊢t
deep*-correct-term ⊢t (x ⇨ X) =
  let ⊢u , t≡u = deep-correct-term ⊢t x
  in trans t≡u (deep*-correct-term ⊢u X)

deep*-correct : ∀ {Γ A B r} → Γ ⊢ A ^ r → Γ ⊢ A ⇒*Π B ^ r → Γ ⊢ A ≡ B ^ r
deep*-correct ⊢A id = refl ⊢A
deep*-correct ⊢A (x ⇨ X) =
  let ⊢B , A≡B = deep-correct ⊢A x
  in trans A≡B (deep*-correct ⊢B X)

doΠNorm′ : ∀ {A rA Γ l} ([A] : Γ ⊩⟨ l ⟩ A ^ rA)
         → ∃ λ B → ΠNorm B × Γ ⊢ B ^ rA × Γ ⊢ A ⇒*Π B ^ rA
doΠNorm′ (Uᵣ (Uᵣ r l′ l< PE.refl [[ A , U , d ]])) = Univ r l′ , Uₙ , Ugenⱼ (wf A) , regular* d
doΠNorm′ (ℕᵣ [[ ⊢A , ⊢B , D ]]) = ℕ , ℕₙ , ⊢B , regular* D
doΠNorm′ (Emptyᵣ {l = l} [[ ⊢A , ⊢B , D ]]) = Empty l , Emptyₙ , ⊢B , regular* D
doΠNorm′ (ne′ K [[ ⊢A , ⊢B , D ]] neK K≡K) = K , ne neK , ⊢B , regular* D
doΠNorm′ (Πᵣ′ rF lF lG lF≤ lG≤ F G [[ ⊢A , ⊢B , D ]] ⊢F ⊢G A≡A [F] [G] G-ext) =
  let redF₀ , red₀ = reducibleTerm (var (wf ⊢G) here)
      [F]′ = irrelevanceTerm redF₀ ([F] (step id) (wf ⊢G)) red₀
      G′ , nG′ , ⊢G′ , D′ = PE.subst (λ G′ → ∃ λ B → ΠNorm B × _ ⊢ B ^ _ × _ ⊢ G′ ⇒*Π B ^ _)
                              (wkSingleSubstId _)
                              (doΠNorm′ ([G] (step id) (wf ⊢G) [F]′))
  in Π F ^ rF ° lF ▹ G′ ° lG ° _ , Πₙ nG′ , univ (Πⱼ lF≤ ▹ lG≤ ▹ (un-univ ⊢F) ▹ (un-univ ⊢G′)) , regular* D ⇨* deep* D′
doΠNorm′ (∃ᵣ′ F G D ⊢F ⊢G A≡A [F] [G] G-ext) =
  let F′ , nF′ ,  ⊢F′ , D′ = doΠNorm′ ([F] id (wf ⊢F))
      DD = (PE.subst (λ FF → _ ⊢ FF ⇒*Π F′ ^ _ ) (wk-id _) D′)
      F≡F′ = deep*-correct ⊢F DD
  in ∃ F′ ▹ G , ∃ₙ nF′ , univ (∃ⱼ un-univ ⊢F′ ▹ un-univ (stability (reflConEq (wf ⊢F) ∙ F≡F′) ⊢G)) ,
     regular* (red D) ⇨* deep∃* DD
doΠNorm′ (emb emb< [A]) = doΠNorm′ [A]
doΠNorm′ (emb ∞< [A]) = doΠNorm′ [A]

doΠNorm : ∀ {A rA Γ} → Γ ⊢ A ^ rA
        → ∃ λ B → ΠNorm B × Γ ⊢ B ^ rA × Γ ⊢ A ⇒*Π B ^ rA
doΠNorm ⊢A = doΠNorm′ (reducible ⊢A)

ΠNorm-whnf : ∀ {A} → ΠNorm A → Whnf A
ΠNorm-whnf Uₙ = Uₙ
ΠNorm-whnf (Πₙ _) = Πₙ
ΠNorm-whnf (∃ₙ _) = ∃ₙ
ΠNorm-whnf ℕₙ = ℕₙ
ΠNorm-whnf Emptyₙ = Emptyₙ
ΠNorm-whnf (ne x) = ne x

ΠNorm-noredTerm : ∀ {Γ A B T r} → Γ ⊢ A ⇒Π B ∷ T ^ r  → ΠNorm A → ⊥
ΠNorm-noredTerm (regular x) w = whnfRedTerm x (ΠNorm-whnf w)
ΠNorm-noredTerm (deepΠ x) (Πₙ w) = ΠNorm-noredTerm x w
ΠNorm-noredTerm (deepΠ x) (ne ())
ΠNorm-noredTerm (deep∃ x) (∃ₙ w) = ΠNorm-noredTerm x w
ΠNorm-noredTerm (deep∃ x) (ne ())

ΠNorm-nored : ∀ {Γ A B r} → Γ ⊢ A ⇒Π B ^ r → ΠNorm A → ⊥
ΠNorm-nored (univ x) w = ΠNorm-noredTerm x w

detΠRedTerm : ∀ {Γ A B B′ T T′ r r'} → Γ ⊢ A ⇒Π B ∷ T ^ r  → Γ ⊢ A ⇒Π B′ ∷ T′ ^ r' → B PE.≡ B′
detΠRedTerm (regular x) (regular x₁) = whrDetTerm x x₁
detΠRedTerm (regular x) (deepΠ y) = ⊥-elim (whnfRedTerm x Πₙ)
detΠRedTerm (deepΠ x) (regular x₁) = ⊥-elim (whnfRedTerm x₁ Πₙ)
detΠRedTerm (deepΠ x) (deepΠ y) = PE.cong _ (detΠRedTerm x y)
detΠRedTerm (regular x) (deep∃ y) = ⊥-elim (whnfRedTerm x ∃ₙ)
detΠRedTerm (deep∃ x) (regular x₁) = ⊥-elim (whnfRedTerm x₁ ∃ₙ)
detΠRedTerm (deep∃ x) (deep∃ y) = PE.cong _ (detΠRedTerm x y)

detΠRed : ∀ {Γ A B B′ r r′} → Γ ⊢ A ⇒Π B ^ r → Γ ⊢ A ⇒Π B′ ^ r′ → B PE.≡ B′
detΠRed (univ x) (univ y) = detΠRedTerm x y

detΠNorm* : ∀ {Γ A B B′ r r′} → ΠNorm B → ΠNorm B′ → Γ ⊢ A ⇒*Π B ^ r → Γ ⊢ A ⇒*Π B′ ^ r′ → B PE.≡ B′
detΠNorm* w w′ id id = PE.refl
detΠNorm* w w′ id (x ⇨ b) = ⊥-elim (ΠNorm-nored x w)
detΠNorm* w w′ (x ⇨ a) id = ⊥-elim (ΠNorm-nored x w′)
detΠNorm* w w′ (x ⇨ a) (x₁ ⇨ b) =
  detΠNorm* w w′ a (PE.subst (λ t → _ ⊢ t ⇒*Π _ ^ _) (detΠRed x₁ x) b)


module src.Data.Zipper where

open import Agda.Builtin.Equality
open import Data.Nat
open import Data.Nat.Properties
open import Induction.WellFounded
open import Haskell.Prelude
open import Relation.Binary.PropositionalEquality

-- language extensions
{-# FOREIGN AGDA2HS
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE ViewPatterns #-}
#-}

-- imports
{-# FOREIGN AGDA2HS
import Control.Arrow (first)
import Control.Comonad
import Control.Lens hiding ((<.>))
import Control.Monad
import Data.Foldable
import Data.Functor.Apply
import Data.Functor.Extend
import Data.Function
import Data.List (unfoldr)
import Data.List.NonEmpty (NonEmpty ((:|)))
import Data.Semigroup.Foldable
import GHC.Generics
#-}

record Zipper (a : Set) : Set where
  constructor MkZipper
  field
    prefix : List a
    focus  : a
    suffix : List a
{-# COMPILE AGDA2HS Zipper #-}

open Zipper public

{-# FOREIGN AGDA2HS
deriving instance Show a => Show (Zipper a)
deriving instance Eq a => Eq (Zipper a)
deriving instance Generic a => Generic (Zipper a)
deriving instance Functor Zipper
deriving instance Foldable Zipper
deriving instance Traversable Zipper

makeLenses ''Zipper
#-}

{-# TERMINATING #-}
repeat : a → List a
repeat x = x ∷ repeat x

instance
  isFunctorZipper : Functor Zipper
  isFunctorZipper .fmap k
    record { prefix = p ; focus = f ; suffix = s } =
    record { prefix = map k p ; focus = k f ; suffix = map k s }

  isApplicativeZipper : Applicative Zipper
  isApplicativeZipper .pure a =
    record { prefix = repeat a ; focus = a ; suffix = repeat a }
  isApplicativeZipper ._<*>_
    record { prefix = p1 ; focus = f1 ; suffix = s1 }
    record { prefix = p2 ; focus = f2 ; suffix = s2 } =
      record { prefix = zipWith id p1 p2 ; focus = f1 f2 ; suffix = zipWith id s1 s2 }
  {-# COMPILE AGDA2HS isApplicativeZipper #-}

  isFoldableZipper : Foldable Zipper
  isFoldableZipper .foldMap k
    record { prefix = p ; focus = f ; suffix = s } =
      foldMap k p <> k f <> foldMap k s

  isTraversableZipper : Traversable Zipper
  isTraversableZipper .traverse k
    record { prefix = p ; focus = f ; suffix = s } =
    ⦇ MkZipper (traverse k p) (k f) (traverse k s) ⦈

  isSemigroupZipper : ∀ {a : Set} → ⦃ Semigroup a ⦄ → Semigroup (Zipper a)
  isSemigroupZipper ._<>_
    record { prefix = p1 ; focus = f1 ; suffix = s1 }
    record { prefix = p2 ; focus = f2 ; suffix = s2 } =
    record { prefix = zipWith (_<>_) p1 p2
           ; focus = f1 <> f2
           ; suffix = zipWith (_<>_) s1 s2 }
  {-# COMPILE AGDA2HS isSemigroupZipper #-}

{-# FOREIGN AGDA2HS
-- | Many of these instances are from Tony Morris's package, list-zipper
instance Apply Zipper where
  MkZipper l1 x1 r1 <.> MkZipper l2 x2 r2 =
    MkZipper (zipWith id l1 l2) (x1 x2) (zipWith id r1 r2)

instance Foldable1 Zipper where
  foldMap1 f (MkZipper [] x []) =
    f x
  foldMap1 f (MkZipper [] x (rh : rt)) =
    f x <> foldMap1 f (rh :| rt)
  foldMap1 f (MkZipper (lh : lt) x []) =
    foldMap1 f (lh :| lt) <> f x
  foldMap1 f (MkZipper (lh : lt) x (rh : rt)) =
    foldMap1 f (lh :| lt) <> f x <> foldMap1 f (rh :| rt)

instance Traversable1 Zipper where
  traverse1 f (MkZipper [] x []) =
    (\x' -> MkZipper [] x' []) <$> f x
  traverse1 f (MkZipper (lh : lt) x []) =
    (\l' x' -> MkZipper (toList l') x' []) <$> traverse1 f (lh :| lt) <.> f x
  traverse1 f (MkZipper [] x (rh : rt)) =
    (\x' r' -> MkZipper [] x' (toList r')) <$> f x <.> traverse1 f (rh :| rt)
  traverse1 f (MkZipper (lh : lt) x (rh : rt)) =
    (\l' x' r' -> MkZipper (toList l') x' (toList r'))
      <$> traverse1 f (lh :| lt) <.> f x <.> traverse1 f (rh :| rt)

instance Extend Zipper where
  duplicated z =
    let dup x = (x, x)
        unf f = unfoldr (fmap dup . f) z
     in MkZipper (unf left) z (unf right)

instance Comonad Zipper where
  duplicate = duplicated
  extract (MkZipper _ x _) = x
#-}

left : ∀ {a : Set} → Zipper a → Maybe (Zipper a)
left record { prefix = [] ; focus = f ; suffix = s } = Nothing
left record { prefix = x ∷ p ; focus = f ; suffix = s } =
  Just record { prefix = p ; focus = x ; suffix = f ∷ s }
{-# COMPILE AGDA2HS left #-}

right : ∀ {a : Set} → Zipper a → Maybe (Zipper a)
right record { prefix = p ; focus = f ; suffix = [] } = Nothing
right record { prefix = p ; focus = f ; suffix = x ∷ s } =
  Just record { prefix = f ∷ p ; focus = x ; suffix = s }
{-# COMPILE AGDA2HS right #-}

left-right : ∀ {a : Set} (z r : Zipper a) → right z ≡ Just r → left r ≡ Just z
left-right record { prefix = p ; focus = f ; suffix = (x ∷ s) }
         .(record { prefix = f ∷ p ; focus = x ; suffix = s }) refl = refl

right-left : ∀ {a : Set} (z r : Zipper a) → left z ≡ Just r → right r ≡ Just z
right-left record { prefix = (x ∷ p) ; focus = f ; suffix = s }
         .(record { prefix = p ; focus = x ; suffix = f ∷ s }) refl = refl

fromList : List a → Maybe (Zipper a)
fromList [] = Nothing
fromList (x ∷ xs) = Just record { prefix = [] ; focus = x ; suffix = xs }
{-# COMPILE AGDA2HS fromList #-}

unzipper : Zipper a → List a
unzipper record { prefix = p ; focus = f ; suffix = s } = reverse p ++ f ∷ s
{-# COMPILE AGDA2HS unzipper #-}

overlay : Zipper a → List a → Maybe (Zipper a)
overlay record { prefix = p ; focus = _ ; suffix = [] } [] = Nothing
overlay record { prefix = xs ; focus = _ ; suffix = (z ∷ zs) } [] =
  Just record { prefix = xs ; focus = z ; suffix = zs }
overlay record { prefix = xs ; focus = _ ; suffix = zs } (w ∷ ws) =
  Just record { prefix = xs ; focus = w ; suffix = ws ++ zs }
{-# COMPILE AGDA2HS overlay #-}

record MonadPlus (m : Set → Set) : Set₁ where
  field
    mzero : m a
    mplus : m a → m a → m a
    overlap ⦃ super ⦄ : Monad m

open MonadPlus ⦃ ... ⦄ public

{-# COMPILE AGDA2HS MonadPlus existing-class #-}

instance
  isListMonadPlus : MonadPlus List
  isListMonadPlus = record { mzero = [] ; mplus = _++_ }

zipper : ⦃ MonadPlus f ⦄ → (a → Bool) → List a → f (Zipper a)
zipper f xs = case break f xs of λ where
  (ys , z ∷ zs) →
    return record { prefix = reverse ys ; focus = z ; suffix = zs }
  _ → mzero
{-# COMPILE AGDA2HS zipper #-}

spanM : ⦃ Monad m ⦄ → ⦃ MonadPlus f ⦄ → (a → m Bool) → List a → m (f a × List a)
spanM _ [] = return (mzero , [])
spanM {m} {f} {a} {{M}} p (x ∷ xs) = do
  true <- p x
    where
      false → return (mzero , x ∷ xs)
  (ys , zs) <- spanM {m} {f} {a} {{M}} p xs
  return (mplus (return x) ys , zs)
{-# COMPILE AGDA2HS spanM #-}

infixr 1 _>=>_
_>=>_ : ⦃ Monad m ⦄ → (a → m b) → (b → m c) → a → m c
f >=> g = λ x → f x >>= g

infixr 1 _<=<_
_<=<_ : ⦃ Monad m ⦄ → (b → m c) → (a → m b) → a → m c
f <=< g = g >=> f

breakM : ⦃ Monad m ⦄ → ⦃ MonadPlus f ⦄ → (a → m Bool) → List a → m (f a × List a)
breakM p = spanM $ return ∘ not <=< p
{-# COMPILE AGDA2HS breakM #-}

zipperM
  : {a : Set}
  → {m : Set → Set}
  → {f : Set → Set}
  → ⦃ Monad m ⦄
  → ⦃ MonadPlus f ⦄
  → (a → m Bool)
  → List a
  → m (f (Zipper a))
zipperM {a} {_} {f} {{M}} k xs =
  breakM {{M}} {{isListMonadPlus}} k xs <&> λ where
    (ys , z ∷ zs) →
      return record { prefix = reverse ys ; focus = z ; suffix = zs }
    _ → mzero
{-# COMPILE AGDA2HS zipperM #-}

Traversal' : Set → Set → Set₁
Traversal' s a =
  ∀ {f : Set → Set} → ⦃ Applicative f ⦄ → (a → f a) → (s → f s)

items : Traversal' (Zipper a) a
items k z =
  ⦇ MkZipper (reverse <$> traverse k (reverse (prefix z)))
             (k (focus z))
             (traverse k (suffix z)) ⦈
{-# COMPILE AGDA2HS items #-}

scanPreState : {s : Set} → (a → s → (b × s)) → s → List a → List (b × s)
scanPreState f _ [] = []
scanPreState f s (x ∷ xs) =
  case f x s of λ where
    (b , s') → (b , s) ∷ scanPreState f s' xs
{-# COMPILE AGDA2HS scanPreState #-}

forward : {A : Set} → Zipper A → List A
forward z = focus z ∷ suffix z

measure : {A : Set}(f : A → ℕ) → Zipper A → ℕ
measure f z = sum (map (suc ∘ f) (forward z))

just-inj : {A : Set} {x y : A}
  → Just x ≡ Just y
  → x ≡ y
just-inj refl = refl

suffix-forward : {A : Set} {z z' : Zipper A}
  → right z ≡ Just z'
  → suffix z ≡ forward z'
suffix-forward {z = MkZipper prefix₁ focus₁ (x ∷ suffix₁)} H
  rewrite sym (just-inj H) = refl

measure-right-< : {A : Set} (m : A → ℕ) {z z' : Zipper A}
  → right z ≡ Just z'
  → measure m z' Data.Nat.< measure m z
measure-right-< m {z} {z'} H
  rewrite suffix-forward H = s≤s (m≤n+m _ _)

record ZipperMono (A : Set)(m : A → ℕ) : Set where
  constructor zippermono
  field
    func : Zipper A → Zipper A
    mono : ∀ z → measure m z ≡ measure m (func z)

open import Induction.WellFounded
open import Data.Nat.Induction

-- This version of survey shows that it terminates, but only if the function
-- passed is monotonic with respect to a measure on its input and output.
survey′ : {a : Set} (m : a → ℕ) → ZipperMono a m -> List a -> List a
survey′ {a} m (zippermono f mono) =
  maybe [] (λ z → go z (<-wellFounded _)) ∘ fromList
  where
    go : (z : Zipper a) → Acc Data.Nat._<_ (measure m z) → List a
    go z (acc rs) with f z | inspect f z
    ...| z' | [ eq ] with right z' | inspect right z'
    ...| Nothing | _ = unzipper z'
    ...| Just z''  | [ eq' ] =
      go z'' (rs (measure m z'')
         (≤-trans (measure-right-< m eq')
                  (≤-reflexive (trans (cong (measure m) (sym eq))
                               (sym (mono z))))))

{-# TERMINATING #-}
survey : {a : Set} → (Zipper a -> Zipper a) -> List a -> List a
survey {a} f = maybe [] go ∘ fromList
  where
    go : Zipper a → List a
    go z = let z' = f z in maybe (unzipper z') go (right z')
{-# COMPILE AGDA2HS survey #-}

{-# TERMINATING #-}
surveyM
  : {a : Set}
  → {m : Set → Set}
  → ⦃ Monad m ⦄
  → (Zipper a → m (Zipper a))
  → List a
  → m (List a)
surveyM {a} {m} f = maybe (return []) go ∘ fromList
  where
    go : Zipper a → m (List a)
    go z = do
      z' <- f z
      maybe (return (unzipper z')) go (right z')
{-# COMPILE AGDA2HS surveyM #-}

first : (a → b) → (a × c) → (b × c)
first f (a , c) = (f a , c)

mapUntils
  : (List a → List a)
  → (a → Maybe (List a × b))
  → List a
  → Maybe (List a × b)
mapUntils rev k [] = Nothing
mapUntils rev k (x ∷ xs) = case k x of λ where
  (Just (xs' , b)) → Just (rev xs' ++ xs , b)
  Nothing → first (λ xs → x ∷ xs) <$> mapUntils rev k xs
{-# COMPILE AGDA2HS mapUntils #-}

-- | Given a zipper list, attempt to locate an element first in the prefix,
--   then in the suffix, and allow for a transformation of that sub-zipper
--   list within the parent list, plus the generation of some datum.
mapLeftThenRightUntils :
  Zipper a → (Bool → a → Maybe (List a × b)) → Maybe (Zipper a × b)
mapLeftThenRightUntils {a} {b} z f =
  case mapUntils reverse (f true) (prefix z) of λ where
    (Just (p' , b)) → Just (record z { prefix = p' } , b)
    Nothing →
      case mapUntils id (f false) (suffix z) of λ where
        (Just (s' , b)) → Just (record z { suffix = s' } , b)
        Nothing → Nothing
{-# COMPILE AGDA2HS mapLeftThenRightUntils #-}


------------------------------------------------------------------------
-- Soundness and completeness
------------------------------------------------------------------------

module TotalParserCombinators.Derivative.SoundComplete where

open import Category.Monad
open import Codata.Musical.Notation
open import Data.List
import Data.List.Categorical
open import Data.Maybe hiding (_>>=_)
open import Data.Product
open import Level
open import Relation.Binary.PropositionalEquality

open RawMonad {f = zero} Data.List.Categorical.monad
  using () renaming (_>>=_ to _>>=′_; _⊛_ to _⊛′_)

open import TotalParserCombinators.Derivative.Definition
import TotalParserCombinators.InitialBag as I
open import TotalParserCombinators.Lib
open import TotalParserCombinators.Parser
open import TotalParserCombinators.Semantics

------------------------------------------------------------------------
-- Soundness

sound : ∀ {Tok R xs x s} {t} (p : Parser Tok R xs) →
        x ∈ D t p · s → x ∈ p · t ∷ s
sound token                   return            = token
sound (p₁ ∣ p₂)               (∣-left     x∈p₁) = ∣-left      (sound p₁ x∈p₁)
sound (_∣_ {xs₁ = xs₁} p₁ p₂) (∣-right ._ x∈p₂) = ∣-right xs₁ (sound p₂ x∈p₂)
sound (f <$> p)               (<$> x∈p)         = <$> sound p x∈p
sound (_⊛_ {fs = nothing} {xs = just _}  p₁ p₂)             (f∈p₁′  ⊛ x∈p₂)       = [ ○ - ◌ ] sound p₁ f∈p₁′ ⊛ x∈p₂
sound (_⊛_ {fs = just _}  {xs = just _}  p₁ p₂) (∣-left     (f∈p₁′  ⊛ x∈p₂))      = [ ○ - ○ ] sound p₁ f∈p₁′ ⊛ x∈p₂
sound (_⊛_ {fs = just fs} {xs = just _}  p₁ p₂) (∣-right ._ (f∈ret⋆ ⊛ x∈p₂′))     with Return⋆.sound fs f∈ret⋆
sound (_⊛_ {fs = just fs} {xs = just _}  p₁ p₂) (∣-right ._ (f∈ret⋆ ⊛ x∈p₂′))     | (refl , f∈fs) =
                                                                                [ ○ - ○ ] I.sound p₁ f∈fs ⊛ sound p₂ x∈p₂′
sound (_⊛_ {fs = nothing} {xs = nothing} p₁ p₂)             (f∈p₁′  ⊛ x∈p₂)       = [ ◌ - ◌ ] sound (♭ p₁) f∈p₁′ ⊛ x∈p₂
sound (_⊛_ {fs = just _}  {xs = nothing} p₁ p₂) (∣-left     (f∈p₁′  ⊛ x∈p₂))      = [ ◌ - ○ ] sound (♭ p₁) f∈p₁′ ⊛ x∈p₂
sound (_⊛_ {fs = just fs} {xs = nothing} p₁ p₂) (∣-right ._ (f∈ret⋆ ⊛ x∈p₂′))     with Return⋆.sound fs f∈ret⋆
sound (_⊛_ {fs = just fs} {xs = nothing} p₁ p₂) (∣-right ._ (f∈ret⋆ ⊛ x∈p₂′))     | (refl , f∈fs) =
                                                                                [ ◌ - ○ ] I.sound (♭ p₁) f∈fs ⊛ sound p₂ x∈p₂′
sound (_>>=_ {xs = nothing} {f = just _}  p₁ p₂)             (x∈p₁′  >>= y∈p₂x)   = [ ○ - ◌ ] sound p₁ x∈p₁′ >>= y∈p₂x
sound (_>>=_ {xs = just xs} {f = just _}  p₁ p₂) (∣-right ._ (y∈ret⋆ >>= z∈p₂′y)) with Return⋆.sound xs y∈ret⋆
sound (_>>=_ {xs = just xs} {f = just _}  p₁ p₂) (∣-right ._ (y∈ret⋆ >>= z∈p₂′y)) | (refl , y∈xs) =
                                                                                [ ○ - ○ ] I.sound p₁ y∈xs >>= sound (p₂ _) z∈p₂′y
sound (_>>=_ {xs = just xs} {f = just _}  p₁ p₂) (∣-left     (x∈p₁′  >>= y∈p₂x))  = [ ○ - ○ ] sound p₁ x∈p₁′ >>= y∈p₂x
sound (_>>=_ {xs = nothing} {f = nothing} p₁ p₂)             (x∈p₁′  >>= y∈p₂x)   = [ ◌ - ◌ ] sound (♭ p₁) x∈p₁′ >>= y∈p₂x
sound (_>>=_ {xs = just xs} {f = nothing} p₁ p₂) (∣-right ._ (y∈ret⋆ >>= z∈p₂′y)) with Return⋆.sound xs y∈ret⋆
sound (_>>=_ {xs = just xs} {f = nothing} p₁ p₂) (∣-right ._ (y∈ret⋆ >>= z∈p₂′y)) | (refl , y∈xs) =
                                                                                [ ◌ - ○ ] I.sound (♭ p₁) y∈xs >>= sound (p₂ _) z∈p₂′y
sound (_>>=_ {xs = just xs} {f = nothing} p₁ p₂) (∣-left     (x∈p₁′  >>= y∈p₂x))  = [ ◌ - ○ ] sound (♭ p₁) x∈p₁′ >>= y∈p₂x
sound (nonempty p) x∈p = nonempty (sound p x∈p)
sound (cast _ p)   x∈p = cast (sound p x∈p)

sound (return _) ()
sound fail       ()

------------------------------------------------------------------------
-- Completeness

mutual

  complete : ∀ {Tok R xs x s t} {p : Parser Tok R xs} →
             x ∈ p · t ∷ s → x ∈ D t p · s
  complete x∈p = complete′ _ x∈p refl

  complete′ : ∀ {Tok R xs x s s′ t} (p : Parser Tok R xs) →
                x ∈ p · s′ → s′ ≡ t ∷ s → x ∈ D t p · s
  complete′ token     token       refl = return

  complete′ (p₁ ∣ p₂) (∣-left    x∈p₁) refl = ∣-left               (complete x∈p₁)
  complete′ (p₁ ∣ p₂) (∣-right _ x∈p₂) refl = ∣-right (D-bag _ p₁) (complete x∈p₂)

  complete′ (f <$> p) (<$> x∈p)   refl = <$> complete x∈p

  complete′ (_⊛_ {fs = nothing} {xs = just _}  p₁ p₂)
            (_⊛_ {s₁ = _ ∷ _} f∈p₁ x∈p₂) refl =         _⊛_ {fs = ○} {xs = ○}  (complete f∈p₁) x∈p₂
  complete′ (_⊛_ {fs = just _}  {xs = just _}  p₁ p₂)
            (_⊛_ {s₁ = _ ∷ _} f∈p₁ x∈p₂) refl = ∣-left (_⊛_ {fs = ○} {xs = ○}  (complete f∈p₁) x∈p₂)
  complete′ (_⊛_ {fs = just _}  {xs = just xs} p₁ p₂)
            (_⊛_ {s₁ = []}    f∈p₁ x∈p₂) refl = ∣-right (D-bag _ p₁ ⊛′ xs)
                                                   (_⊛_ {fs = ○} {xs = ○}
                                                        (Return⋆.complete (I.complete f∈p₁)) (complete x∈p₂))
  complete′ (_⊛_ {fs = nothing} {xs = nothing} p₁ p₂)
            (_⊛_ {s₁ = _ ∷ _} f∈p₁ x∈p₂) refl =         _⊛_ {fs = ○} {xs = ◌} (complete f∈p₁) x∈p₂
  complete′ (_⊛_ {fs = just _}  {xs = nothing} p₁ p₂)
            (_⊛_ {s₁ = _ ∷ _} f∈p₁ x∈p₂) refl = ∣-left (_⊛_ {fs = ○} {xs = ◌} (complete f∈p₁) x∈p₂)
  complete′ (_⊛_ {fs = just _}  {xs = nothing} p₁ p₂)
            (_⊛_ {s₁ = []}    f∈p₁ x∈p₂) refl = ∣-right []
                                                   (_⊛_ {fs = ○} {xs = ○}
                                                        (Return⋆.complete (I.complete f∈p₁)) (complete x∈p₂))

  complete′ (_>>=_ {xs = nothing} {f = just _}  p₁ p₂)
            (_>>=_ {s₁ = _ ∷ _} x∈p₁ y∈p₂x) refl =         _>>=_ {xs = ○} {f = ○} (complete x∈p₁) y∈p₂x
  complete′ (_>>=_ {xs = just _}  {f = just _}  p₁ p₂)
            (_>>=_ {s₁ = _ ∷ _} x∈p₁ y∈p₂x) refl = ∣-left (_>>=_ {xs = ○} {f = ○} (complete x∈p₁) y∈p₂x)
  complete′ (_>>=_ {xs = just _}  {f = just f}  p₁ p₂)
            (_>>=_ {s₁ = []}    x∈p₁ y∈p₂x) refl = ∣-right (D-bag _ p₁ >>=′ f)
                                                      (_>>=_ {xs = ○} {f = ○}
                                                             (Return⋆.complete (I.complete x∈p₁)) (complete y∈p₂x))

  complete′ (_>>=_ {xs = nothing} {f = nothing} p₁ p₂)
            (_>>=_ {s₁ = _ ∷ _} x∈p₁ y∈p₂x) refl =         _>>=_ {xs = ○} {f = ◌} (complete x∈p₁) y∈p₂x
  complete′ (_>>=_ {xs = just _}  {f = nothing} p₁ p₂)
            (_>>=_ {s₁ = _ ∷ _} x∈p₁ y∈p₂x) refl = ∣-left (_>>=_ {xs = ○} {f = ◌} (complete x∈p₁) y∈p₂x)
  complete′ (_>>=_ {xs = just _}  {f = nothing} p₁ p₂)
            (_>>=_ {s₁ = []}    x∈p₁ y∈p₂x) refl = ∣-right []
                                                      (_>>=_ {xs = ○} {f = ○}
                                                             (Return⋆.complete (I.complete x∈p₁)) (complete y∈p₂x))

  complete′ (nonempty p) (nonempty x∈p) refl = complete x∈p

  complete′ (cast _ p) (cast x∈p) refl = complete x∈p

  complete′ (return _) () refl
  complete′ fail       () refl
  complete′ (_⊛_   {fs = nothing} _ _) (_⊛_   {s₁ = []} f∈p₁ _) _ with I.complete f∈p₁
  ... | ()
  complete′ (_>>=_ {xs = nothing} _ _) (_>>=_ {s₁ = []} x∈p₁ _) _ with I.complete x∈p₁
  ... | ()


module Selective.Simulate where

open import Selective.ActorMonad public
open import Selective.SimulationEnvironment
open import Selective.EnvironmentOperations
open import Prelude

open import Data.List.All.Properties using (++⁺)
open import Data.Nat.Properties using (≤-reflexive ; ≤-step)
open import Data.Product using (Σ ; _,_ ; _×_ ; Σ-syntax)

open Actor
open ValidActor
open Env
open FoundReference
open LiftedReferences
open UpdatedInbox
open ValidMessageList
open NamedInbox
open _comp↦_∈_
open NameSupply
open NameSupplyStream

data Trace (i : Size) : Set₂

record ∞Trace (i : Size) : Set₂ where
  coinductive
  constructor delay_
  field force : {j : Size< i} → Trace j

data Trace (i : Size) where
  TraceStop : (env : Env) → Done env → Trace i
  _∷_ : (x : Env) (xs : ∞Trace i) → Trace i

reduce-unbound-return : {act : Actor} → (env : Env) → Focus act env →
                        ActorAtConstructor Return act →
                        ActorHasNoContinuation act →
                        Env
reduce-unbound-return env Focused AtReturn no-cont = block-focused env Focused (BlockedReturn AtReturn no-cont)

reduce-bound-return : {act : Actor} → (env : Env) → Focus act env →
                      ActorAtConstructor Return act →
                      ActorHasContinuation act →
                      Env
reduce-bound-return env@record {
  acts = actor@record { computation = Return v ⟶ (f ∷ cont) } ∷ rest
  ; actors-valid = actor-valid ∷ rest-valid
  } Focused AtReturn HasContinuation =
    let
      actor' : Actor
      actor' = replace-actorM actor ((f v .force) ⟶ cont)
      env' : Env
      env' = replace-focused
               env
               Focused
               actor'
               (rewrap-valid-actor AreSame actor-valid)
    in env'

reduce-bind : {act : Actor} → (env : Env) → Focus act env →
              ActorAtConstructor Bind act →
              Env
reduce-bind env@record { acts = actor@record { computation = (m ∞>>= f) ⟶ cont } ∷ rest ; actors-valid = actor-valid ∷ rest-valid } Focused AtBind =
  let
    actor' : Actor
    actor' = replace-actorM actor ((m .force) ⟶ (f ∷ cont))
    env' : Env
    env' = replace-focused
             env
             Focused
             actor'
             (rewrap-valid-actor AreSame actor-valid)
  in env'

reduce-spawn : {act : Actor} → (env : Env) → Focus act env →
               ActorAtConstructor Spawn act →
               Env
reduce-spawn env@record {
  acts = actor@record { computation = Spawn {NewIS} {B} act ⟶ cont } ∷ rest
  ; actors-valid = actor-valid ∷ rest-valid
  } Focused AtSpawn =
  let
    new-name : Name
    new-name = env .name-supply .supply .name
    new-store-entry : NamedInbox
    new-store-entry = inbox# new-name [ NewIS ]
    env' : Env
    env' = add-top (act ⟶ []) env
    valid' : ValidActor (env' .store) actor
    valid' = valid-actor-suc (env .name-supply .supply) actor-valid
    env'' : Env
    env'' = top-actor-to-back env'
    actor' : Actor
    actor' = add-reference actor new-store-entry (Return _ ⟶ cont)
    valid'' : ValidActor (env'' .store) actor'
    valid'' = add-reference-valid RefAdded valid' [p: zero ][handles: ⊆-refl ]
    env''' : Env
    env''' = replace-focused env'' Focused actor' valid''
  in env'''

reduce-send : {act : Actor} → (env : Env) → Focus act env →
              ActorAtConstructor Send act →
              Env
reduce-send env@record {
  acts = actor@record { computation = Send {ToIS = ToIS} canSendTo (SendM tag fields) ⟶ cont } ∷ rest
  ; actors-valid = actor-valid ∷ rest-valid
  } Focused AtSend =
  let
    to-reference : FoundReference (store env) ToIS
    to-reference = lookup-reference-act actor-valid canSendTo
    namedFields = name-fields-act (store env) actor fields actor-valid
    actor' : Actor
    actor' = replace-actorM actor (Return _ ⟶ cont)
    withM : Env
    withM = replace-focused
              env
              Focused
              actor'
              (rewrap-valid-actor AreSame actor-valid)
    message = NamedM
                (translate-message-pointer to-reference tag)
                namedFields
    message-is-valid : message-valid (env .store) message
    message-is-valid = make-pointers-compatible
                         (env .store)
                         (actor .pre)
                         (actor .references)
                         (actor .pre-eq-refs)
                         fields
                         (actor-valid .references-have-pointer)
    updater = add-message message message-is-valid
    withUpdatedInbox : Env
    withUpdatedInbox = update-inbox-env
                         withM
                         (underlying-pointer to-reference)
                         updater
  in withUpdatedInbox

reduce-receive-without-message : {act : Actor} → (env : Env) → Focus act env →
                              ActorAtConstructor Receive act →
                              (p : has-inbox (env .store) act) →
                              inbox-for-actor (env .env-inboxes) act p [] →
                              Env
reduce-receive-without-message env Focused AtReceive  p ifa = block-focused env Focused (BlockedReceive AtReceive p ifa)

reduce-receive-with-message : {act : Actor} → (env : Env) → Focus act env →
                              ActorAtConstructor Receive act →
                              (p : has-inbox (env .store) act) →
                              ∀ inbox →
                              all-messages-valid (env .store) inbox →
                              InboxInState NonEmpty inbox →
                              inbox-for-actor (env .env-inboxes) act p inbox →
                              Env
reduce-receive-with-message env@record {
  acts = actor@record { computation = (Receive ⟶ cont) } ∷ rest
  ; actors-valid = actor-valid ∷ rest-valid
  } Focused AtReceive p (nm ∷ messages) (nmv ∷ vms) HasMessage ifa =
  let
    inboxesAfter = update-inbox
                     (env .store)
                     (env .env-inboxes)
                     (env .messages-valid)
                     (actor-valid .actor-has-inbox)
                     remove-message
    actor' : Actor
    actor' = add-references-rewrite
               actor
               (named-inboxes nm)
               {unname-message nm}
               (add-references++
                 nm
                 nmv
                 (pre actor))
               (Return (unname-message nm) ⟶ cont)
    actor-valid' : ValidActor (env .store) actor'
    actor-valid' = record {
      actor-has-inbox = actor-valid .actor-has-inbox
      ; references-have-pointer = valid++ nm nmv (actor-valid .references-have-pointer)
      }
    env' : Env
    env' = let
      updated = update-inbox (env .store) (env .env-inboxes) (env .messages-valid) (actor-valid .actor-has-inbox) remove-message
      unblock-split = unblock-actors updated (env .blocked) (env .blocked-valid) (env .blocked-no-progress)
      open UnblockedActors
        in record
             { acts = actor' ∷ unblock-split .unblocked ++ rest
             ; blocked = unblock-split .still-blocked
             ; store = env .store
             ; env-inboxes = updated .updated-inboxes
             ; name-supply = env .name-supply
             ; actors-valid = actor-valid' ∷ ++⁺ (unblock-split .unblocked-valid) rest-valid
             ; blocked-valid = unblock-split .blocked-valid
             ; messages-valid = updated .inboxes-valid
             ; blocked-no-progress = unblock-split .blocked-no-prog
             }
  in env'

reduce-receive : {act : Actor} → (env : Env) → Focus act env →
                 ActorAtConstructor Receive act →
                 Env
reduce-receive env@record { acts = actor ∷ rest ; actors-valid = actor-valid ∷ _ } Focused AtReceive = choose-reduction (get-inbox env (actor-valid .actor-has-inbox))
  where
    open GetInbox
    choose-reduction : (gi : GetInbox (env .store) (env .env-inboxes) (actor-valid .actor-has-inbox)) → Env
    choose-reduction gi@record { messages = [] } =
      reduce-receive-without-message env Focused AtReceive _ (gi .right-inbox)
    choose-reduction gi@record { messages = _ ∷ _ } =
      reduce-receive-with-message env Focused AtReceive _ (gi .messages) (gi .valid) HasMessage (gi .right-inbox)

reduce-self : {act : Actor} → (env : Env) → Focus act env →
              ActorAtConstructor Self act →
              Env
reduce-self env@record { acts = actor@record {
  computation = Self ⟶ cont } ∷ _
  ; actors-valid = actor-valid ∷ _
  } Focused AtSelf =
  let
    actor' : Actor
    actor' = add-reference actor inbox# (actor .name) [ (actor .inbox-shape) ] ((Return _) ⟶ cont)
    actor-valid' : ValidActor (env .store) actor'
    actor-valid' = add-reference-valid RefAdded actor-valid [p: (actor-valid .actor-has-inbox) ][handles: ⊆-refl ]
    env' : Env
    env' = replace-focused
             env
             Focused
             actor'
             actor-valid'
  in env'

reduce-selective-with-message : {act : Actor} → (env : Env) → Focus act env →
                                (aac : ActorAtConstructor Selective act) →
                                (point : has-inbox (env .store) act) →
                                ∀ inbox →
                                all-messages-valid (env .store) inbox →
                                inbox-for-actor (env .env-inboxes) act point inbox →
                                {split : SplitList inbox} →
                                {p : (filter-named (selected-filter act aac)) (SplitList.el split) ≡ true} →
                                InboxInFilterState {filter = filter-named (selected-filter act aac)} inbox (Found split p) →
                                Env
reduce-selective-with-message env@record {
  acts = actor@record { computation = SelectiveReceive filter ⟶ cont } ∷ rest
  ; actors-valid = actor-valid ∷ rest-valid
  } Focused AtSelective point inb amv ifa (HasMessage split ok) =
  let updated = update-inbox (env .store) (env .env-inboxes) (env .messages-valid) (actor-valid .actor-has-inbox) (remove-found-message filter)
      unblock-split = unblock-actors updated (env .blocked) (env .blocked-valid) (env .blocked-no-progress)
      open SplitList
      received-nm = split .el
      added-references = named-inboxes received-nm
      received-message = unname-message received-nm
      received-valid : message-valid (env .store) received-nm
      received-valid = split-all-el inb amv split
      adds-correct-references : map shape added-references ++ (actor .pre) ≡ add-references (actor .pre) received-message
      adds-correct-references = add-references++ received-nm received-valid (actor .pre)
      new-continuation = Return sm: received-message [ ok ] ⟶ cont
      act' : Actor
      act' = add-references-rewrite actor added-references {received-message} adds-correct-references new-continuation
      act-valid' : ValidActor (env .store) act'
      act-valid' = record {
        actor-has-inbox = actor-valid .actor-has-inbox
        ; references-have-pointer = valid++ received-nm received-valid (actor-valid .references-have-pointer)
        }
      open UnblockedActors
  in record
       { acts = act' ∷ unblock-split .unblocked ++ rest
       ; blocked = unblock-split .still-blocked
       ; store = env .store
       ; env-inboxes = updated-inboxes updated
       ; name-supply = env .name-supply
       ; actors-valid = act-valid' ∷ ++⁺ (unblock-split .unblocked-valid) rest-valid
       ; blocked-valid = unblock-split .blocked-valid
       ; messages-valid = inboxes-valid updated
       ; blocked-no-progress = unblock-split .blocked-no-prog
       }

reduce-selective-without-message : {act : Actor} → (env : Env) → Focus act env →
                                 (aac : ActorAtConstructor Selective act) →
                                 (point : has-inbox (env .store) act) →
                                 ∀ inbox →
                                 {ps : All (misses-filter (filter-named (selected-filter act aac))) inbox} →
                                 inbox-for-actor (env .env-inboxes) act point inbox →
                                 InboxInFilterState inbox (Nothing ps) →
                                 Env
reduce-selective-without-message env Focused AtSelective point inbox ifa iifs =
  block-focused env Focused (BlockedSelective AtSelective point inbox ifa iifs)

reduce-selective : {act : Actor} → (env : Env) → Focus act env →
                 ActorAtConstructor Selective act →
                 Env
reduce-selective env@record {
  acts = actor@record { computation = SelectiveReceive filter ⟶ _  } ∷ _
  ; actors-valid = actor-valid ∷ _
  } Focused AtSelective =
  let inb = get-inbox env (actor-valid .actor-has-inbox)
  in choose-reduction inb (find-split (inb .messages) (filter-named filter))
  where
    open GetInbox
    choose-reduction : (gi : GetInbox (env .store) (env .env-inboxes) (actor-valid .actor-has-inbox)) → FoundInList (gi .messages) (filter-named filter) → Env
    choose-reduction gi (Found split x) = reduce-selective-with-message env Focused AtSelective _ (gi .messages) (gi .valid) (gi .right-inbox) (HasMessage split x)
    choose-reduction gi (Nothing ps) = reduce-selective-without-message env Focused AtSelective _ (gi .messages) (gi .right-inbox) (IsEmpty ps)

reduce-strengthen : {act : Actor} → (env : Env) → Focus act env →
                    ActorAtConstructor Strengthen act →
                    Env
reduce-strengthen env@record {
  acts = actor@record { computation = Strengthen {ys} inc ⟶ cont } ∷ _
  ; actors-valid = actor-valid ∷ _
  } Focused AtStrengthen =
  let
    lifted-references = lift-references inc (references actor) (pre-eq-refs actor)
    actor' : Actor
    actor' = lift-actor actor (lifted-references .contained) (lifted-references .contained-eq-inboxes) (Return _ ⟶ cont)
    actor-valid' : ValidActor (env .store) actor'
    actor-valid' = lift-valid-actor (CanBeLifted lifted-references) actor-valid
    env' : Env
    env' = replace-focused
             env
             Focused
             actor'
             actor-valid'
  in env'

reduce : {act : Actor} → (env : Env) → Focus act env → Env
reduce env@record { acts = record { computation = (Return val ⟶ []) } ∷ _ } Focused =
  reduce-unbound-return env Focused AtReturn (NoContinuation {v = val})
reduce env@record { acts = record { computation = (Return val ⟶ (_ ∷ _)) } ∷ _ } Focused =
  reduce-bound-return env Focused AtReturn (HasContinuation {v = val})
reduce env@record { acts = record { computation = ((m ∞>>= f) ⟶ _)} ∷ _ } Focused =
  reduce-bind env Focused AtBind
reduce env@record { acts = record { computation = (Spawn act ⟶ cont) } ∷ _ } Focused =
  reduce-spawn env Focused AtSpawn
reduce env@record { acts = record { computation = (Send canSendTo msg ⟶ cont) } ∷ _ } Focused =
  reduce-send env Focused AtSend
reduce env@record { acts = record { computation = (Receive ⟶ cont) } ∷ _ } Focused =
  reduce-receive env Focused AtReceive
reduce env@record { acts = record { computation = (SelectiveReceive filter ⟶ cont) } ∷ _ } Focused =
  reduce-selective env Focused AtSelective
reduce env@record { acts = record { computation = (Self ⟶ cont) } ∷ _ } Focused =
  reduce-self env Focused AtSelf
reduce env@record { acts = record { computation = (Strengthen inc ⟶ cont) } ∷ _ } Focused =
  reduce-strengthen env Focused AtStrengthen

simulate : Env → ∞Trace ∞
simulate env@record { acts = [] ; actors-valid = [] } = delay TraceStop env AllBlocked
simulate env@record { acts = _ ∷ _ ; actors-valid = _ ∷ _ } = keep-stepping (reduce env Focused)
  where
    open ∞Trace
    keep-stepping : Env → ∞Trace ∞
    keep-stepping env .force = env ∷ simulate env


{-# OPTIONS --rewriting #-}
module JVM.Transform.Assemble where

open import Agda.Builtin.Equality.Rewrite

open import Data.Nat using (ℕ)
open import Data.List as List
open import Data.List.Properties
open import Data.List.Relation.Unary.All as All
open import Data.List.Membership.Propositional
open import Data.List.Membership.Propositional.Properties
open import Data.List.Relation.Unary.Any
open import Data.Product hiding (swap)

open import Relation.Unary hiding (_∈_)
open import Relation.Binary.PropositionalEquality
open import Relation.Ternary.Core
open import Relation.Ternary.Structures.Syntax
open import Relation.Ternary.Data.Bigstar
open import Relation.Ternary.Data.ReflexiveTransitive as Star
open import Relation.Ternary.Data.IndexedMonoid
open import Relation.Ternary.Construct.Bag.Properties

open import JVM.Types
open import JVM.Syntax.Values
open import JVM.Model StackTy
open import JVM.Model.Properties
open import JVM.Syntax.Labeling StackTy
open import JVM.Syntax.Instructions hiding (⟨_↝_⟩; Instr)

{-# REWRITE ++-assoc #-}

Typing = List StackTy

variable
  J₁ J₂ J : Typing

module _ Γ where

  data Instr (J : Typing) : StackTy → StackTy → Set where
    goto  : ψ₁ ∈ J → Instr J ψ₁ ψ₂
    if    : ∀ {as} → Comparator as → ψ₁ ∈ J → Instr J (as ++ ψ₁) ψ₂

    nop   : Instr J ψ₁ ψ₁
    push  : Const a → Instr J ψ₁ (a ∷ ψ₁)
    pop   : Instr J (a ∷ ψ₁) ψ₁
    dup   : Instr J (a ∷ ψ₁) (a ∷ a ∷ ψ₁)
    swap  : Instr J (a ∷ b ∷ ψ₁) (b ∷ a ∷ ψ₁)
    bop   : NativeBinOp a b c → Instr J (b ∷ a ∷ ψ₁) (c ∷ ψ₁)
    load  : a ∈ Γ → Instr J ψ₁ (a ∷ ψ₁)
    store : a ∈ Γ → Instr J (a ∷ ψ₁) ψ₁
    ret   : Instr J (a ∷ ψ₁) ψ₂

  data Bytecode' (J : Typing) : Typing → StackTy → StackTy → Set where
    nil  : Bytecode' J [] ψ₁ ψ₁
    cons : ∀ {I} → Instr J ψ₁ ψ₂ → Bytecode' J I ψ₂ ψ₃ → Bytecode' J (ψ₁ ∷ I) ψ₁ ψ₃

  Bytecode : Typing → StackTy → StackTy → Set
  Bytecode J = Bytecode' J J

module _ where

  Addressing : Labels → Typing → Set
  Addressing lbs J = All (λ ψ → ψ ∈ J) lbs

  instr-tf : ∀ {Γ ℓs} → Addressing ℓs J → ⟨ Γ ∣ ψ₁ ↝ ψ₂ ⟩ ℓs → Instr Γ J ψ₁ ψ₂
  instr-tf ρ noop              = nop
  instr-tf ρ pop               = pop
  instr-tf ρ (push x)          = push x
  instr-tf ρ dup               = dup
  instr-tf ρ swap              = swap
  instr-tf ρ (bop x)           = bop x
  instr-tf ρ (load x)          = load x
  instr-tf ρ (store x)         = store x
  instr-tf (ℓ ∷ _) (goto refl) = goto ℓ
  instr-tf (ℓ ∷ _) (if x refl) = if x ℓ

  Extractor : ∀ Γ → StackTy → StackTy → Intf → Set
  Extractor Γ ψ₁ ψ₂ Φ = {J₁ : Typing} → Addressing (down Φ) J₁
                       → ∃ λ J₂ → Bytecode' Γ (J₁ ++ J₂) J₂ ψ₁ ψ₂ × Addressing (up Φ) (J₁ ++ J₂)

  exec-extractor : ∀ {Γ} → Extractor Γ ψ₁ ψ₂ ε → ∃ λ J → Bytecode Γ J ψ₁ ψ₂
  exec-extractor c = let _ , code , _ = c {[]} [] in -, code

  label-addresses : ∀ {x} → Labeling ψ₁ x → All (λ z → z ∈ J₁ ++ ψ₁ ∷ []) x
  label-addresses (refl ∙⟨ σ ⟩ qx) = joinAll (λ ()) σ (∈-++⁺ʳ _ (here refl) ∷ []) (addr' qx)
    where
      addr' : ∀ {x} → Bigstar (Own List.[ ψ₁ ]) x → All (λ z → z ∈ J₁ ++ ψ₁ ∷ []) x
      addr' emp = []
      addr' (cons (refl ∙⟨ σ ⟩ qx)) = joinAll (λ ()) σ (∈-++⁺ʳ _ (here refl) ∷ []) (addr' qx)

  -- We can extract bytecode that does absolute addressing from the fancy
  -- intrinsically-typed representation.
  -- We do this in a single recursive pass over the bytecode, collecting a global map of instruction typings,
  -- and also collecting indices into that map for every defined label on the forward pass, and
  -- eliminating labels on the backwards pass.
  --
  -- The interface compositions guide the way. The key lemma is `sinkᵣ`
  -- which says that in order to know what l imports in l ✴ r,
  -- it is sufficient to know what l ✴ r imports, *and* what r exports.
  --
  -- In this setting 'l' is the head of some suffix of bytecode.
  -- The imports of 'l ✴ r' have been collected from the labels defined in the prefix.
  -- We get the exports of the tail 'r' of the suffix from the recursive call.
  extract : ∀ {Γ} → ∀[ ⟪ Γ ∣ ψ₁ ↝ ψ₂ ⟫ ⇒ Extractor Γ ψ₁ ψ₂ ]
  extract {ψ₁ = ψ₁} nil ρ    = [] , nil , []

  extract {ψ₁ = ψ₁} (cons (labeled (↑ ls ∙⟨ σ₁ ⟩ ↓ i) ∙⟨ σ₂ ⟩ is)) ρ = let
      -- addressing from ↑ ls
      ρ₀ = label-addresses ls

      -- Addresses for the labels
      ρ₁ = source σ₁ ρ₀ []

      -- Compute addresses for the tail,
      -- by combining the addresses from the state with the addresses for the labels.
      -- We don't need everything, only what is imported in the head instruction.
      ρ₂ = sinkᵣ  σ₂ ρ₁ (All.map (∈-++⁺ˡ {ys = List.[ ψ₁ ]}) ρ)

      -- Recursively extract first to get addressing for forward jumps.
      -- These addresses are exported by the tail.
      k , code , ρ′ = extract is ρ₂

      -- Compute the addresses imported by i
      ρ₃ = sinkᵣ (∙-comm σ₂) ρ′ (All.map ∈-++⁺ˡ ρ)
      ρ₄ = sinkᵣ σ₁ (All.map ∈-++⁺ˡ ρ₀) ρ₃

      -- Compute the exported addresses
      ρ₅ = source σ₂ (All.map ∈-++⁺ˡ ρ₁) ρ′

    in ψ₁ ∷ k , cons (instr-tf ρ₄ i) code , ρ₅

  -- Same as above, but simpler
  extract {ψ₁ = ψ₁} (cons (instr   (↓ i) ∙⟨ σ ⟩ b)) ρ =  let
      ρ₂ = sinkᵣ σ [] (All.map (∈-++⁺ˡ {ys = List.[ ψ₁ ]}) ρ)
      k , code , ρ′ = extract b ρ₂
      ρ₃ = sinkᵣ (∙-comm σ) ρ′ (All.map ∈-++⁺ˡ ρ)
      ρ₄ = source σ [] ρ′
    in ψ₁ ∷ k , cons (instr-tf ρ₃ i) code , ρ₄

module Show where

  open import Data.String as S hiding (show)
  open import Data.Integer as I
  open import Data.Fin as Fin
  open import Data.Nat.Show as NS
  open import Data.Bool.Show as BS

  showInt : ℤ → String
  showInt (+ n) = NS.show n
  showInt (-[1+ n ]) = "-" S.++ NS.show (ℕ.suc n)

  showFin : ∀ {n} → Fin n → String
  showFin f = NS.show (Fin.toℕ f)

  showComp : Comparator as → String
  showComp eq = "eq"
  showComp ne = "ne"
  showComp lt = "lt"
  showComp ge = "ge"
  showComp gt = "gt"
  showComp le = "le"
  showComp icmpge = "icmpge"
  showComp icmpgt = "icmpgt"
  showComp icmpeq = "icmpeq"
  showComp icmpne = "icmpne"
  showComp icmplt = "icmplt"
  showComp icmple = "icmple"

  showOp : NativeBinOp a b c → String
  showOp add = "add"
  showOp sub = "sub"
  showOp mul = "mul"
  showOp div = "div"
  showOp xor = "xor"

  showConst : Const a → String
  showConst Const.null = "null"
  showConst (num x)    = showInt x
  showConst (bool x)   = BS.show x

  showReg : ∀ {Γ} → a ∈ Γ → String
  showReg e = showFin (index e)

  showLabel : ψ ∈ J → String
  showLabel = λ ℓ → showFin (index ℓ)

  showInstr : ∀ {Γ} → Instr Γ J ψ₁ ψ₂ → String
  showInstr (goto ℓ) = "goto " S.++ showLabel ℓ
  showInstr (if c ℓ) = "if " S.++ (showComp c S.++ " " S.++ showLabel ℓ)
  showInstr nop      = "noop"
  showInstr (push c) = "push " S.++ (showConst c)
  showInstr pop      = "pop"
  showInstr dup      = "dup"
  showInstr swap     = "swap"
  showInstr (bop o)  = "bop " S.++ (showOp o)
  showInstr (load r) = "load " S.++ (showReg r)
  showInstr (store r)= "store " S.++ (showReg r)
  showInstr ret      = "ret"

  showTy : Ty → String
  showTy boolean = "bool"
  showTy byte    = "byte"
  showTy short   = "short"
  showTy int     = "int"
  showTy long    = "long"
  showTy char    = "char"
  showTy (ref x) = "ref"
  showTy (array t) = "array"

  showStackTy : StackTy → String
  showStackTy []      = "[]"
  showStackTy (x ∷ ψ) = showTy x S.++ " : " S.++ showStackTy ψ

  showBytecode : ∀ {Γ J} → Bytecode Γ J ψ₁ ψ₂ → String
  showBytecode b = showBytecode' b 0
    where
      open import Data.Nat

      showBytecode' : ∀ {Γ J J'} → Bytecode' Γ J J' ψ₁ ψ₂ → ℕ → String
      showBytecode' nil n = ""
      showBytecode' (cons {ψ₁ = ψ₁} {ψ₂} i b) n =
        NS.show n S.++ ": "
          S.++ showInstr i
          S.++ "\t⟨ " S.++ showStackTy ψ₁ S.++ " ↝ " S.++ showStackTy ψ₂ S.++ " ⟩"
          S.++ "\n" S.++ showBytecode' b (ℕ.suc n)


------------------------------------------------------------------------
-- Support for reflection
------------------------------------------------------------------------

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

open import Equality

module TC-monad
  {reflexive} (eq : ∀ {a p} → Equality-with-J a p reflexive) where

import Agda.Builtin.Bool as B
open import Agda.Builtin.Char
open import Agda.Builtin.Float
import Agda.Builtin.Reflection
open import Agda.Builtin.Strict
open import Agda.Builtin.String

open import Logical-equivalence using (_⇔_)
open import Prelude as P hiding (Type)

import Maybe eq as _
open import Monad eq
open import Nat eq

-- Reflection primitives.

open Agda.Builtin.Reflection public hiding (isMacro; withNormalisation)

-- The TC monad is a "raw monad".

instance

  raw-monad : ∀ {d} → Raw-monad {d = d} TC
  Raw-monad.return raw-monad = returnTC
  Raw-monad._>>=_ raw-monad  = bindTC

-- Converts B.Bool to and from Bool.

Bool⇔Bool : B.Bool ⇔ Bool
Bool⇔Bool = record { to = to; from = from }
  where
  to : B.Bool → Bool
  to B.false = false
  to B.true  = true

  from : Bool → B.Bool
  from false = B.false
  from true  = B.true

-- Variants of some definitions from Agda.Builtin.Reflection.

isMacro : Name → TC Bool
isMacro x = _⇔_.to Bool⇔Bool ⟨$⟩ Agda.Builtin.Reflection.isMacro x

withNormalisation : ∀ {a} {A : P.Type a} → Bool → TC A → TC A
withNormalisation =
  Agda.Builtin.Reflection.withNormalisation ∘ _⇔_.from Bool⇔Bool

-- Constructs a visible, relevant argument that is not erased

pattern varg x = arg (arg-info visible (modality relevant quantity-ω)) x

-- Constructs a hidden, relevant argument that is not erased.

pattern harg x = arg (arg-info hidden (modality relevant quantity-ω)) x

-- An n-ary variant of pi.

pis : List (Abs (Arg Type)) → Type → Type
pis []             B = B
pis (abs x A ∷ As) B = pi A (abs x (pis As B))

mutual

  -- Checks if the terms are syntactically equal.
  --
  -- Pattern-matching lambdas and "unknown" are currently never seen
  -- as equal to anything.
  --
  -- Note that this function does not perform any kind of parameter
  -- reconstruction.

  eq-Term : Term → Term → Bool
  eq-Term (var x₁ ts₁)   (var x₂ ts₂)   = eq-ℕ x₁ x₂ ∧ eq-Args ts₁ ts₂
  eq-Term (con c₁ ts₁)   (con c₂ ts₂)   = eq-Name c₁ c₂ ∧ eq-Args ts₁ ts₂
  eq-Term (def f₁ ts₁)   (def f₂ ts₂)   = eq-Name f₁ f₂ ∧ eq-Args ts₁ ts₂
  eq-Term (lam v₁ t₁)    (lam v₂ t₂)    = eq-Visibility v₁ v₂ ∧ eq-Abs t₁ t₂
  eq-Term (pi a₁ b₁)     (pi a₂ b₂)     = eq-Arg a₁ a₁ ∧ eq-Abs b₁ b₂
  eq-Term (agda-sort s₁) (agda-sort s₂) = eq-Sort s₁ s₂
  eq-Term (lit l₁)       (lit l₂)       = eq-Literal l₁ l₂
  eq-Term (meta x₁ ts₁)  (meta x₂ ts₂)  = eq-Meta x₁ x₂ ∧ eq-Args ts₁ ts₂
  eq-Term _              _              = false

  eq-Name : Name → Name → Bool
  eq-Name x₁ x₂ = _⇔_.to Bool⇔Bool (primQNameEquality x₁ x₂)

  eq-ℕ : ℕ → ℕ → Bool
  eq-ℕ = _==_

  eq-Meta : Meta → Meta → Bool
  eq-Meta x₁ x₂ = _⇔_.to Bool⇔Bool (primMetaEquality x₁ x₂)

  eq-String : String → String → Bool
  eq-String x₁ x₂ = _⇔_.to Bool⇔Bool (primStringEquality x₁ x₂)

  eq-Sort : Sort → Sort → Bool
  eq-Sort (set t₁) (set t₂) = eq-Term t₁ t₂
  eq-Sort (lit n₁) (lit n₂) = eq-ℕ n₁ n₂
  eq-Sort _        _        = false

  eq-Literal : Literal → Literal → Bool
  eq-Literal (nat n₁)    (nat n₂)    = eq-ℕ n₁ n₂
  eq-Literal (float x₁)  (float x₂)  = _⇔_.to Bool⇔Bool
                                         (primFloatEquality x₁ x₂)
  eq-Literal (char c₁)   (char c₂)   = _⇔_.to Bool⇔Bool
                                         (primCharEquality c₁ c₂)
  eq-Literal (string s₁) (string s₂) = eq-String s₁ s₂
  eq-Literal (name x₁)   (name x₂)   = eq-Name x₁ x₂
  eq-Literal (meta x₁)   (meta x₂)   = eq-Meta x₁ x₂
  eq-Literal _           _           = false

  eq-Args : List (Arg Term) → List (Arg Term) → Bool
  eq-Args []         []         = true
  eq-Args (t₁ ∷ ts₁) (t₂ ∷ ts₂) = eq-Arg t₁ t₂ ∧ eq-Args ts₁ ts₂
  eq-Args _          _          = false

  eq-Abs : Abs Term → Abs Term → Bool
  eq-Abs (abs s₁ t₁) (abs s₂ t₂) =
    eq-String s₁ s₂ ∧ eq-Term t₁ t₂

  eq-ArgInfo : ArgInfo → ArgInfo → Bool
  eq-ArgInfo (arg-info v₁ m₁) (arg-info v₂ m₂) =
    eq-Visibility v₁ v₂ ∧ eq-Modality m₁ m₂

  eq-Arg : Arg Term → Arg Term → Bool
  eq-Arg (arg i₁ t₁) (arg i₂ t₂) =
    eq-ArgInfo i₁ i₂ ∧ eq-Term t₁ t₂

  eq-Visibility : Visibility → Visibility → Bool
  eq-Visibility visible   visible   = true
  eq-Visibility hidden    hidden    = true
  eq-Visibility instance′ instance′ = true
  eq-Visibility _         _         = false

  eq-Modality : Modality → Modality → Bool
  eq-Modality (modality r₁ q₁) (modality r₂ q₂) =
    eq-Relevance r₁ r₂ ∧ eq-Quantity q₁ q₂

  eq-Relevance : Relevance → Relevance → Bool
  eq-Relevance relevant   relevant   = true
  eq-Relevance irrelevant irrelevant = true
  eq-Relevance _          _          = false

  eq-Quantity : Quantity → Quantity → Bool
  eq-Quantity quantity-0 quantity-0 = true
  eq-Quantity quantity-ω quantity-ω = true
  eq-Quantity _          _          = false

-- Returns a fresh meta-variable of type Level.

fresh-level : TC Level
fresh-level =
  checkType unknown (def (quote Level) []) >>= λ ℓ →
  unquoteTC ℓ

-- Tries to apply the given term (of the given type) to the list of
-- arguments. The type of the resulting term is also returned.

apply : Type → Term → List (Arg Term) → TC (Type × Term)
apply A t []       = returnTC (A , t)
apply A t (a ∷ as) =
  reduce A      >>= λ A →
  apply₁ A t a  >>= λ { (A , t) →
  apply A t as        }
  where
  apply₁ : Type → Term → Arg Term → TC (Type × Term)
  apply₁ (pi (arg i₁@(arg-info k _) A) B) t₁ (arg i₂ t₂) =
    if not (eq-ArgInfo i₁ i₂)
    then typeError (strErr "apply: argument info mismatch" ∷ [])
    else
      bindTC fresh-level                   λ a →
      bindTC fresh-level                   λ b →
      bindTC (unquoteTC A)                 λ (A : P.Type a) →
      bindTC (unquoteTC (lam visible B))   λ (B : A → P.Type b) →
      bindTC (unquoteTC t₂)                λ (t₂ : A) →
      bindTC (quoteTC (B t₂))              λ Bt₂ →
      case k of λ where
        visible →
          bindTC (unquoteTC t₁)            λ (t₁ : (x : A) → B x) →
          bindTC (quoteTC (t₁ t₂))         λ t₁t₂ →
          return (Bt₂ , t₁t₂)
        hidden →
          bindTC (unquoteTC t₁)            λ (t₁ : {x : A} → B x) →
          bindTC (quoteTC (t₁ {x = t₂}))   λ t₁t₂ →
          return (Bt₂ , t₁t₂)
        instance′ →
          bindTC (unquoteTC t₁)            λ (t₁ : ⦃ x : A ⦄ → B x) →
          bindTC (quoteTC (t₁ ⦃ x = t₂ ⦄)) λ t₁t₂ →
          return (Bt₂ , t₁t₂)
  apply₁ (meta x _) _ _ = blockOnMeta x
  apply₁ A          _ _ =
    typeError (strErr "apply: not a pi" ∷ termErr A ∷ [])

mutual

  -- The number of variables bound in the pattern(s).

  bound-in-pattern : Pattern → ℕ
  bound-in-pattern (con _ ps) = bound-in-patterns ps
  bound-in-pattern (dot _)    = 0
  bound-in-pattern (var _)    = 1
  bound-in-pattern (lit _)    = 0
  bound-in-pattern (proj _)   = 0
  bound-in-pattern (absurd _) = 1

  bound-in-patterns : List (Arg Pattern) → ℕ
  bound-in-patterns []             = 0
  bound-in-patterns (arg _ p ∷ ps) =
    bound-in-pattern p + bound-in-patterns ps

mutual

  -- Renames the first variable to the second.
  --
  -- Pattern-matching lambdas are replaced by "unknown".

  rename-term : ℕ → ℕ → Term → Term
  rename-term old new = λ where
    (var x args)      → var (rename-var old new x)
                            (rename-args old new args)
    (con c args)      → con c (rename-args old new args)
    (def f args)      → def f (rename-args old new args)
    (lam v t)         → lam v (rename-abs old new t)
    (pat-lam cs args) → unknown
    (pi a b)          → pi (rename-arg old new a) (rename-abs old new b)
    (agda-sort s)     → agda-sort (rename-sort old new s)
    (lit l)           → lit l
    (meta x args)     → meta x (rename-args old new args)
    unknown           → unknown

  rename-var : ℕ → ℕ → ℕ → ℕ
  rename-var old new x = if eq-ℕ x old then new else old

  rename-abs : ℕ → ℕ → Abs Term → Abs Term
  rename-abs old new (abs s t) =
    abs s (rename-term (suc old) (suc new) t)

  rename-arg : ℕ → ℕ → Arg Term → Arg Term
  rename-arg old new (arg i t) = arg i (rename-term old new t)

  rename-args : ℕ → ℕ → List (Arg Term) → List (Arg Term)
  rename-args old new = λ where
    []       → []
    (a ∷ as) → rename-arg old new a ∷ rename-args old new as

  rename-sort : ℕ → ℕ → Sort → Sort
  rename-sort old new = λ where
    (set t)     → set (rename-term old new t)
    (prop t)    → prop (rename-term old new t)
    (lit n)     → lit n
    (propLit n) → propLit n
    (inf n)     → inf n
    unknown     → unknown

mutual

  -- Weakening: weaken-term from by increases variables "from" and
  -- higher by "by".
  --
  -- Pattern-matching lambdas are replaced by "unknown".

  weaken-term : ℕ → ℕ → Term → Term
  weaken-term from by = λ where
    (var x args)      → var (weaken-var from by x)
                            (weaken-args from by args)
    (con c args)      → con c (weaken-args from by args)
    (def f args)      → def f (weaken-args from by args)
    (lam v t)         → lam v (weaken-abs from by t)
    (pat-lam cs args) → unknown
    (pi a b)          → pi (weaken-arg from by a) (weaken-abs from by b)
    (agda-sort s)     → agda-sort (weaken-sort from by s)
    (lit l)           → lit l
    (meta x args)     → meta x (weaken-args from by args)
    unknown           → unknown

  weaken-var : ℕ → ℕ → ℕ → ℕ
  weaken-var from by x = if from <= x then x + by else x

  weaken-abs : ℕ → ℕ → Abs Term → Abs Term
  weaken-abs from by (abs s t) =
    abs s (weaken-term (suc from) by t)

  weaken-arg : ℕ → ℕ → Arg Term → Arg Term
  weaken-arg from by (arg i t) = arg i (weaken-term from by t)

  weaken-args : ℕ → ℕ → List (Arg Term) → List (Arg Term)
  weaken-args from by = λ where
    []       → []
    (a ∷ as) → weaken-arg from by a ∷ weaken-args from by as

  weaken-sort : ℕ → ℕ → Sort → Sort
  weaken-sort from by = λ where
    (set t)     → set (weaken-term from by t)
    (prop t)    → prop (weaken-term from by t)
    (lit n)     → lit n
    (propLit n) → propLit n
    (inf n)     → inf n
    unknown     → unknown

mutual

  -- Strengthening: strengthen-term from by subtracts "by" from
  -- variables "from" and higher. Applications of variable x, where
  -- from ≤ x and x < from + by, are replaced by "unknown".
  --
  -- Pattern-matching lambdas are replaced by "unknown".

  strengthen-term : ℕ → ℕ → Term → Term
  strengthen-term from by = λ where
    (var x args)      → let args′ = strengthen-args from by args in
                        if from + by <= x
                        then var (x ∸ by) args′
                        else if from <= x
                        then unknown
                        else var x args′
    (con c args)      → con c (strengthen-args from by args)
    (def f args)      → def f (strengthen-args from by args)
    (lam v t)         → lam v (strengthen-abs from by t)
    (pat-lam cs args) → unknown
    (pi a b)          → pi (strengthen-arg from by a)
                           (strengthen-abs from by b)
    (agda-sort s)     → agda-sort (strengthen-sort from by s)
    (lit l)           → lit l
    (meta x args)     → meta x (strengthen-args from by args)
    unknown           → unknown

  strengthen-abs : ℕ → ℕ → Abs Term → Abs Term
  strengthen-abs from by (abs s t) =
    abs s (strengthen-term (suc from) by t)

  strengthen-arg : ℕ → ℕ → Arg Term → Arg Term
  strengthen-arg from by (arg i t) = arg i (strengthen-term from by t)

  strengthen-args : ℕ → ℕ → List (Arg Term) → List (Arg Term)
  strengthen-args from by = λ where
    []       → []
    (a ∷ as) → strengthen-arg from by a ∷ strengthen-args from by as

  strengthen-sort : ℕ → ℕ → Sort → Sort
  strengthen-sort from by = λ where
    (set t)     → set (strengthen-term from by t)
    (prop t)    → prop (strengthen-term from by t)
    (lit n)     → lit n
    (propLit n) → propLit n
    (inf n)     → inf n
    unknown     → unknown

mutual

  -- The result of any-term and similar functions.
  --
  -- Note that "definitely true" can be returned even if the term
  -- contains meta-variables, the term unknown, the sort unknown, or
  -- pattern-matching lambdas.

  Any-result : P.Type
  Any-result = Any-result′ Bool

  -- A generalisation of Any-result. (Without the type parameter the
  -- raw monad instance below would not work.)

  data Any-result′ (A : P.Type) : P.Type where
    definitely : A → Any-result′ A
    -- The result is definitely true or false.
    meta : Meta → Any-result′ A
    -- There is no positive evidence that the result is true. At least
    -- one meta-variable (the given one) was encountered, and if this
    -- meta-variable is instantiated in a certain way, then the
    -- predicate might hold (depending on what the predicate is,
    -- any-term does not analyse the predicate).
    unknown : Any-result′ A
    -- There is no positive evidence that the result is true. The term
    -- contains the term unknown, the sort unknown, or a
    -- pattern-matching lambda (and pattern-matching lambdas are not
    -- analysed).

instance

  -- Any-result′ is a raw monad.

  Any-result-raw-monad : Raw-monad Any-result′
  Raw-monad.return Any-result-raw-monad = definitely
  Raw-monad._>>=_  Any-result-raw-monad = λ where
    (definitely x) f → f x
    (meta m)       f → meta m
    unknown        f → unknown

mutual

  -- Tries to figure out if the given predicate holds for some free
  -- variable in the given term. The predicate is adjusted when
  -- any-term goes under a binder.

  any-term : (ℕ → Bool) → Term → Any-result
  any-term p = λ where
    (var x args)      → (any-var p x ∨_) ⟨$⟩ any-args p args
    (con _ args)      → any-args p args
    (def _ args)      → any-args p args
    (lam _ t)         → any-abs p t
    (pat-lam cs args) → unknown
    (pi a b)          → _∨_ ⟨$⟩ any-arg p a ⊛ any-abs p b
    (agda-sort s)     → any-sort p s
    (lit l)           → definitely false
    (meta m args)     → case any-args p args of λ where
                          (definitely false) → meta m
                          r                  → r
    unknown           → unknown

  any-var : (ℕ → Bool) → ℕ → Bool
  any-var p x = p x

  any-abs : (ℕ → Bool) → Abs Term → Any-result
  any-abs p (abs _ t) =
    any-term (λ where
                zero    → false
                (suc n) → p n)
             t

  any-arg : (ℕ → Bool) → Arg Term → Any-result
  any-arg p (arg i t) = any-term p t

  any-args : (ℕ → Bool) → List (Arg Term) → Any-result
  any-args p = λ where
    []       → definitely false
    (a ∷ as) → _∨_ ⟨$⟩ any-arg p a ⊛ any-args p as

  any-sort : (ℕ → Bool) → Sort → Any-result
  any-sort p = λ where
    (set t)     → any-term p t
    (prop t)    → any-term p t
    (lit n)     → definitely false
    (propLit n) → definitely false
    (inf n)     → definitely false
    unknown     → unknown

-- Figures out if the given variable is bound in the given term.

bound? : ℕ → Term → Any-result
bound? x = any-term (eq-ℕ x)

-- Figures out if variables less than the given variable are bound
-- in the given term.

<bound? : ℕ → Term → Any-result
<bound? x = any-term (λ y → suc y <= x)


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

open import lib.Basics
open import lib.NType2
open import lib.types.Empty
open import lib.types.Sigma
open import lib.types.Pi
open import lib.types.Group
open import lib.types.Nat
open import lib.types.List
open import lib.types.Word
open import lib.types.SetQuotient
open import lib.groups.Homomorphism

module lib.groups.FreeGroup {i} where

-- [qwr-sym] is not needed, but it seems more principled to
-- make [QuotWordRel] an equivalence relation.
data QuotWordRel {A : Type i} : Word A → Word A → Type i where
  qwr-refl : ∀ {l₁ l₂} → l₁ == l₂ → QuotWordRel l₁ l₂
  qwr-trans : ∀ {l₁ l₂ l₃} → QuotWordRel l₁ l₂ → QuotWordRel l₂ l₃ → QuotWordRel l₁ l₃
  qwr-sym : ∀ {l₁ l₂} → QuotWordRel l₁ l₂ → QuotWordRel l₂ l₁
  qwr-cons : ∀ x {l₁ l₂} → QuotWordRel l₁ l₂ → QuotWordRel (x :: l₁) (x :: l₂)
  qwr-flip : ∀ x₁ l → QuotWordRel (x₁ :: flip x₁ :: l) l

-- The quotient
QuotWord : Type i → Type i
QuotWord A = SetQuot (QuotWordRel {A})

module _ {A : Type i} where

  qw[_] : Word A → QuotWord A
  qw[_] = q[_]

  module QuotWordElim {k} {P : QuotWord A → Type k}
    {{_ : {x : QuotWord A} → is-set (P x)}} (incl* : (a : Word A) → P qw[ a ])
    (rel* : ∀ {a₁ a₂} (r : QuotWordRel a₁ a₂) → incl* a₁ == incl* a₂ [ P ↓ quot-rel r ])
    = SetQuotElim incl* rel*
  open QuotWordElim public renaming (f to QuotWord-elim) hiding (quot-rel-β)

  module QuotWordRec {k} {B : Type k} {{_ : is-set B}} (incl* : Word A → B)
    (rel* : ∀ {a₁ a₂} (r : QuotWordRel a₁ a₂) → incl* a₁ == incl* a₂)
    = SetQuotRec incl* rel*
  open QuotWordRec public renaming (f to QuotWord-rec)

module _ (A : Type i) where
  private
    abstract
      QuotWordRel-cong-++-l :
        ∀ {l₁ l₁'} → QuotWordRel {A} l₁ l₁'
        → (l₂ : Word A)
        → QuotWordRel (l₁ ++ l₂) (l₁' ++ l₂)
      QuotWordRel-cong-++-l (qwr-refl idp) l₂ = qwr-refl idp
      QuotWordRel-cong-++-l (qwr-trans qwr₁ qwr₂) l₂ = qwr-trans (QuotWordRel-cong-++-l qwr₁ l₂) (QuotWordRel-cong-++-l qwr₂ l₂)
      QuotWordRel-cong-++-l (qwr-sym qwr) l₂ = qwr-sym (QuotWordRel-cong-++-l qwr l₂)
      QuotWordRel-cong-++-l (qwr-cons x qwr₁) l₂ = qwr-cons x (QuotWordRel-cong-++-l qwr₁ l₂)
      QuotWordRel-cong-++-l (qwr-flip x₁ l₁) l₂ = qwr-flip x₁ (l₁ ++ l₂)

      QuotWordRel-cong-++-r :
        ∀ (l₁ : Word A)
        → ∀ {l₂ l₂'} → QuotWordRel l₂ l₂'
        → QuotWordRel (l₁ ++ l₂) (l₁ ++ l₂')
      QuotWordRel-cong-++-r nil qwr₂ = qwr₂
      QuotWordRel-cong-++-r (x :: l₁) qwr₂ = qwr-cons x (QuotWordRel-cong-++-r l₁ qwr₂)

    infixl 80 _⊞_
    _⊞_ : QuotWord A → QuotWord A → QuotWord A
    _⊞_ = QuotWord-rec
      (λ l₁ → QuotWord-rec (λ l₂ → qw[ l₁ ++ l₂ ])
        (λ r → quot-rel $ QuotWordRel-cong-++-r l₁ r))
      (λ {l₁} {l₁'} r → λ= $ QuotWord-elim
        (λ l₂ → quot-rel $ QuotWordRel-cong-++-l r l₂)
        (λ _ → prop-has-all-paths-↓))

    abstract
      QuotWordRel-cong-flip : ∀ {l₁ l₂}
        → QuotWordRel {A} l₁ l₂ → QuotWordRel (Word-flip l₁) (Word-flip l₂)
      QuotWordRel-cong-flip (qwr-refl idp) = qwr-refl idp
      QuotWordRel-cong-flip (qwr-trans qwr₁ qwr₂) = qwr-trans (QuotWordRel-cong-flip qwr₁) (QuotWordRel-cong-flip qwr₂)
      QuotWordRel-cong-flip (qwr-sym qwr) = qwr-sym (QuotWordRel-cong-flip qwr)
      QuotWordRel-cong-flip (qwr-cons x qwr₁) = qwr-cons (flip x) (QuotWordRel-cong-flip qwr₁)
      QuotWordRel-cong-flip (qwr-flip (inl x) l) = qwr-flip (inr x) (Word-flip l)
      QuotWordRel-cong-flip (qwr-flip (inr x) l) = qwr-flip (inl x) (Word-flip l)

      QuotWordRel-cong-reverse : ∀ {l₁ l₂}
        → QuotWordRel {A} l₁ l₂ → QuotWordRel (reverse l₁) (reverse l₂)
      QuotWordRel-cong-reverse (qwr-refl x) = qwr-refl (ap reverse x)
      QuotWordRel-cong-reverse (qwr-trans qwr qwr₁) = qwr-trans (QuotWordRel-cong-reverse qwr) (QuotWordRel-cong-reverse qwr₁)
      QuotWordRel-cong-reverse (qwr-sym qwr) = qwr-sym (QuotWordRel-cong-reverse qwr)
      QuotWordRel-cong-reverse (qwr-cons x qwr) = QuotWordRel-cong-++-l (QuotWordRel-cong-reverse qwr) (x :: nil)
      QuotWordRel-cong-reverse (qwr-flip (inl x) l) =
        qwr-trans (qwr-refl (++-assoc (reverse l) (inr x :: nil) (inl x :: nil))) $
        qwr-trans (QuotWordRel-cong-++-r (reverse l) (qwr-flip (inr x) nil)) $
        qwr-refl (++-unit-r (reverse l))
      QuotWordRel-cong-reverse (qwr-flip (inr x) l) =
        qwr-trans (qwr-refl (++-assoc (reverse l) (inl x :: nil) (inr x :: nil))) $
        qwr-trans (QuotWordRel-cong-++-r (reverse l) (qwr-flip (inl x) nil)) $
        qwr-refl (++-unit-r (reverse l))

    ⊟ : QuotWord A → QuotWord A
    ⊟ = QuotWord-rec (qw[_] ∘ reverse ∘ Word-flip)
      (λ r → quot-rel $ QuotWordRel-cong-reverse $ QuotWordRel-cong-flip r)

    ⊞-unit : QuotWord A
    ⊞-unit = qw[ nil ]

    abstract
      ⊞-unit-l : ∀ g → ⊞-unit ⊞ g == g
      ⊞-unit-l = QuotWord-elim
        (λ _ → idp)
        (λ _ → prop-has-all-paths-↓)

      ⊞-assoc : ∀ g₁ g₂ g₃ → (g₁ ⊞ g₂) ⊞ g₃ == g₁ ⊞ (g₂ ⊞ g₃)
      ⊞-assoc = QuotWord-elim
        (λ l₁ → QuotWord-elim
          (λ l₂ → QuotWord-elim
            (λ l₃ → ap qw[_] $ ++-assoc l₁ l₂ l₃)
            (λ _ → prop-has-all-paths-↓))
          (λ _ → prop-has-all-paths-↓))
        (λ _ → prop-has-all-paths-↓)

      Word-inv-l : ∀ l → QuotWordRel {A} (reverse (Word-flip l) ++ l) nil
      Word-inv-l nil = qwr-refl idp
      Word-inv-l (inl x :: l) =
        qwr-trans (qwr-refl (++-assoc (reverse (Word-flip l)) (inr x :: nil) (inl x :: l))) $
        qwr-trans (QuotWordRel-cong-++-r (reverse (Word-flip l)) (qwr-flip (inr x) l)) $
        Word-inv-l l
      Word-inv-l (inr x :: l) =
        qwr-trans (qwr-refl (++-assoc (reverse (Word-flip l)) (inl x :: nil) (inr x :: l))) $
        qwr-trans (QuotWordRel-cong-++-r (reverse (Word-flip l)) (qwr-flip (inl x) l)) $
        Word-inv-l l

      ⊟-inv-l : ∀ g → (⊟ g) ⊞ g == ⊞-unit
      ⊟-inv-l = QuotWord-elim
        (λ l → quot-rel (Word-inv-l l))
        (λ _ → prop-has-all-paths-↓)

  QuotWord-group-structure : GroupStructure (QuotWord A)
  QuotWord-group-structure = record
    { ident = ⊞-unit
    ; inv = ⊟
    ; comp = _⊞_
    ; unit-l = ⊞-unit-l
    ; assoc = ⊞-assoc
    ; inv-l = ⊟-inv-l
    }

  FreeGroup : Group i
  FreeGroup = group _ QuotWord-group-structure

  module FreeGroup = Group FreeGroup

-- freeness
module _ {A : Type i} {j} (G : Group j) where

  private
    module G = Group G

    abstract
      Word-extendᴳ-emap : ∀ f {l₁ l₂}
        → QuotWordRel {A} l₁ l₂
        → Word-extendᴳ G f l₁ == Word-extendᴳ G f l₂
      Word-extendᴳ-emap f (qwr-refl idp) = idp
      Word-extendᴳ-emap f (qwr-trans qwr qwr₁) = (Word-extendᴳ-emap f qwr) ∙ (Word-extendᴳ-emap f qwr₁)
      Word-extendᴳ-emap f (qwr-sym qwr) = ! (Word-extendᴳ-emap f qwr)
      Word-extendᴳ-emap f (qwr-cons x qwr) = ap (G.comp (PlusMinus-extendᴳ G f x)) (Word-extendᴳ-emap f qwr)
      Word-extendᴳ-emap f (qwr-flip (inl x) l) =
          ! (G.assoc (f x) (G.inv (f x)) (Word-extendᴳ G f l))
        ∙ ap (λ g → G.comp g (Word-extendᴳ G f l)) (G.inv-r (f x)) ∙ G.unit-l _
      Word-extendᴳ-emap f (qwr-flip (inr x) l) =
          ! (G.assoc (G.inv (f x)) (f x) (Word-extendᴳ G f l))
        ∙ ap (λ g → G.comp g (Word-extendᴳ G f l)) (G.inv-l (f x)) ∙ G.unit-l _

  FreeGroup-extend : (A → G.El) → (FreeGroup A →ᴳ G)
  FreeGroup-extend f' = record {M} where
    module M where
      f : QuotWord A → G.El
      f = QuotWord-rec (Word-extendᴳ G f')
          (λ r → Word-extendᴳ-emap f' r)
      abstract
        pres-comp : preserves-comp (FreeGroup.comp A) G.comp f
        pres-comp =
          QuotWord-elim
            (λ l₁ → QuotWord-elim
              (λ l₂ → Word-extendᴳ-++ G f' l₁ l₂)
              (λ _ → prop-has-all-paths-↓))
            (λ _ → prop-has-all-paths-↓)

  private
    module Lemma (hom : FreeGroup A →ᴳ G) where
      open GroupHom hom
      f* : A → G.El
      f* a = f qw[ inl a :: nil ]

      abstract
        PlusMinus-extendᴳ-hom : ∀ x → PlusMinus-extendᴳ G f* x == f qw[ x :: nil ]
        PlusMinus-extendᴳ-hom (inl x) = idp
        PlusMinus-extendᴳ-hom (inr x) = ! $ pres-inv qw[ inl x :: nil ]

        Word-extendᴳ-hom : ∀ l → Word-extendᴳ G f* l == f qw[ l ]
        Word-extendᴳ-hom nil = ! pres-ident
        Word-extendᴳ-hom (x :: l) = ap2 G.comp (PlusMinus-extendᴳ-hom x) (Word-extendᴳ-hom l) ∙ ! (pres-comp _ _)
    open Lemma

  FreeGroup-extend-is-equiv : is-equiv FreeGroup-extend
  FreeGroup-extend-is-equiv = is-eq _ from to-from from-to where
    to = FreeGroup-extend
    from = f*

    abstract
      to-from : ∀ h → to (from h) == h
      to-from h = group-hom= $ λ= $ QuotWord-elim
        (λ l → Word-extendᴳ-hom h l)
        (λ _ → prop-has-all-paths-↓)

      from-to : ∀ f → from (to f) == f
      from-to f = λ= λ a → G.unit-r (f a)


module Implicits.Resolution.Embedding.Lemmas where

open import Prelude
open import Data.Fin.Substitution
open import Data.Vec hiding ([_]; _∈_)
open import Data.List as List hiding ([_]; map)
open import Data.List.Properties
open import Data.List.Any hiding (map)
open Membership-≡
open import Extensions.Vec
open import Data.Vec.Properties as VP using ()
open import Relation.Binary.HeterogeneousEquality as H using ()
module HR = H.≅-Reasoning

open import Implicits.Syntax
open import SystemF.Everything as F using ()
open import Implicits.Substitutions
open import Implicits.Substitutions.Lemmas
open import Implicits.Resolution.Embedding

open TypeSubst hiding (subst)
private
  module TS = TypeSubst

length-weaken-Δ : ∀ {ν} (Δ : ICtx ν) →
  (List.length (List.map ⟦_⟧tp→ (ictx-weaken Δ))) ≡ (List.length (List.map ⟦_⟧tp→ Δ))
length-weaken-Δ Δ = begin
  (List.length (List.map ⟦_⟧tp→ (List.map (λ s → s / wk) Δ)))
    ≡⟨ cong List.length (sym $ map-compose Δ) ⟩
  (List.length (List.map (⟦_⟧tp→ ∘ (λ s → s / wk)) Δ))
    ≡⟨ length-map _ Δ ⟩
  List.length Δ
    ≡⟨ sym $ length-map _ Δ ⟩
  (List.length (List.map ⟦_⟧tp→ Δ)) ∎

tp→← : ∀ {ν} (a : Type ν) → ⟦ ⟦ a ⟧tp→ ⟧tp← ≡ a
tp→← (simpl (tc x)) = refl
tp→← (simpl (tvar n)) = refl
tp→← (simpl (x →' x₁)) = cong₂ (λ u v → simpl (u →' v)) (tp→← x) (tp→← x₁)
tp→← (a ⇒ b) = cong₂ _⇒_ (tp→← a) (tp→← b)
tp→← (∀' a) = cong ∀' (tp→← a)

tp←→ : ∀ {ν} (a : F.Type ν) → ⟦ ⟦ a ⟧tp← ⟧tp→ ≡ a
tp←→ (F.tc x) = refl
tp←→ (F.tvar n) = refl
tp←→ (x F.→' x₁) = cong₂ F._→'_ (tp←→ x) (tp←→ x₁)
tp←→ (a F.⟶ b) = cong₂ F._⟶_ (tp←→ a) (tp←→ b)
tp←→ (F.∀' a) = cong F.∀' (tp←→ a)

ctx→← : ∀ {ν} (Δ : ICtx ν) → ⟦ ⟦ Δ ⟧ctx→ ⟧ctx← ≡ Δ
ctx→← [] = refl
ctx→← (x ∷ xs) = begin
  ⟦ ⟦ x ∷ xs ⟧ctx→ ⟧ctx←
    ≡⟨ refl ⟩
  toList (map ⟦_⟧tp← (fromList (List.map ⟦_⟧tp→ (x List.∷ xs))))
    ≡⟨ refl ⟩
  ⟦ ⟦ x ⟧tp→ ⟧tp← List.∷ (toList (map ⟦_⟧tp← (fromList (List.map ⟦_⟧tp→ xs))))
    ≡⟨ cong₂ List._∷_ (tp→← x) (ctx→← xs) ⟩
  (x List.∷ xs) ∎

Γ-cong₂ : ∀ {ν n n'} {x x' : F.Type ν} {xs : F.Ctx ν n} {xs' : F.Ctx ν n'} →
          n ≡ n' → x ≡ x' → xs H.≅ xs' → (x Vec.∷ xs) H.≅ (x' Vec.∷ xs')
Γ-cong₂ refl refl H.refl = H.refl

ctx←→ : ∀ {ν n} (Γ : F.Ctx ν n) → ⟦ ⟦ Γ ⟧ctx← ⟧ctx→ H.≅ Γ
ctx←→ [] = H.refl
ctx←→ {ν = ν} (x ∷ xs) = HR.begin
  ⟦ ⟦ x ∷ xs ⟧ctx← ⟧ctx→
    HR.≡⟨ refl ⟩
  ⟦ ⟦ x ⟧tp← ⟧tp→ ∷ ⟦ ⟦ xs ⟧ctx← ⟧ctx→
    HR.≅⟨ Γ-cong₂ (length-map-toList (map ⟦_⟧tp← xs)) (tp←→ x) (ctx←→ xs) ⟩
  (x ∷ xs) HR.∎

⟦a/var⟧tp← : ∀ {ν ν'} (a : F.Type ν) (s : Vec (Fin ν') ν) → ⟦ a F./Var s ⟧tp← ≡ ⟦ a ⟧tp← /Var s
⟦a/var⟧tp← (F.tc x) s = refl
⟦a/var⟧tp← (F.tvar n) s = refl
⟦a/var⟧tp← (a F.→' b) s = cong₂ _⇒_ (⟦a/var⟧tp← a s) (⟦a/var⟧tp← b s)
⟦a/var⟧tp← (a F.⟶ b) s = cong₂ (λ u v → simpl (u →' v)) (⟦a/var⟧tp← a s) (⟦a/var⟧tp← b s)
⟦a/var⟧tp← (F.∀' a) s = cong ∀' (⟦a/var⟧tp← a (s VarSubst.↑))

⟦a/var⟧tp→ : ∀ {ν ν'} (a : Type ν) (s : Vec (Fin ν') ν) → ⟦ a /Var s ⟧tp→ ≡ ⟦ a ⟧tp→ F./Var s
⟦a/var⟧tp→ (simpl (tc x)) s = refl
⟦a/var⟧tp→ (simpl (tvar n)) s = refl
⟦a/var⟧tp→ (simpl (a →' b)) s = cong₂ F._⟶_ (⟦a/var⟧tp→ a s) (⟦a/var⟧tp→ b s)
⟦a/var⟧tp→ (a ⇒ b) s = cong₂ F._→'_ (⟦a/var⟧tp→ a s) (⟦a/var⟧tp→ b s)
⟦a/var⟧tp→ (∀' a) s = cong F.∀' (⟦a/var⟧tp→ a (s VarSubst.↑))

⟦weaken⟧tp← : ∀ {ν} (a : F.Type ν) → ⟦ F.weaken a ⟧tp← ≡ weaken ⟦ a ⟧tp←
⟦weaken⟧tp← x = ⟦a/var⟧tp← x VarSubst.wk

⟦weaken⟧tp→ : ∀ {ν} (a : Type ν) → ⟦ weaken a ⟧tp→ ≡ F.weaken ⟦ a ⟧tp→
⟦weaken⟧tp→ x = ⟦a/var⟧tp→ x VarSubst.wk

-- helper lemma on mapping type-semantics over weakend substitutions
⟦⟧tps←⋆weaken : ∀ {ν n} (xs : Vec (F.Type ν) n) →
                ⟦ (map F.weaken xs) ⟧tps← ≡ (map weaken ⟦ xs ⟧tps←)
⟦⟧tps←⋆weaken xs = begin
  (map ⟦_⟧tp← ∘ map F.weaken) xs
    ≡⟨ sym $ (VP.map-∘ ⟦_⟧tp← F.weaken) xs ⟩
  map (⟦_⟧tp← ∘ F.weaken) xs
  ≡⟨ (VP.map-cong ⟦weaken⟧tp←) xs ⟩
  map (TS.weaken ∘ ⟦_⟧tp←) xs
    ≡⟨ (VP.map-∘ TS.weaken ⟦_⟧tp←) xs ⟩
  map TS.weaken (map ⟦_⟧tp← xs) ∎

-- helper lemma on mapping type-semantics over weakend substitutions
⟦⟧tps→⋆weaken : ∀ {ν n} (xs : Vec (Type ν) n) →
                ⟦ (map TS.weaken xs) ⟧tps→ ≡ (map F.weaken ⟦ xs ⟧tps→)
⟦⟧tps→⋆weaken xs = begin
  (map ⟦_⟧tp→ ∘ map TS.weaken) xs
    ≡⟨ sym $ (VP.map-∘ ⟦_⟧tp→ TS.weaken) xs ⟩
  map (⟦_⟧tp→ ∘ TS.weaken) xs
  ≡⟨ (VP.map-cong ⟦weaken⟧tp→) xs ⟩
  map (F.weaken ∘ ⟦_⟧tp→) xs
    ≡⟨ (VP.map-∘ F.weaken ⟦_⟧tp→) xs ⟩
  map F.weaken (map ⟦_⟧tp→ xs) ∎

-- the semantics of identity type-substitution is exactly
-- system-f's identity type substitution
⟦id⟧tp← : ∀ {n} → map ⟦_⟧tp← (F.id {n}) ≡ TS.id
⟦id⟧tp← {zero} = refl
⟦id⟧tp← {suc n} = begin
  map ⟦_⟧tp← (F.tvar zero ∷ map F.weaken (F.id {n}))
    ≡⟨ refl ⟩
  (simpl (tvar zero)) ∷ (map ⟦_⟧tp← (map F.weaken (F.id {n})))
    ≡⟨ cong (_∷_ (simpl (tvar zero))) (⟦⟧tps←⋆weaken (F.id {n})) ⟩
  (simpl (tvar zero)) ∷ (map TS.weaken (map ⟦_⟧tp← (F.id {n})))
    ≡⟨ cong (λ e → simpl (tvar zero) ∷ (map TS.weaken e)) ⟦id⟧tp← ⟩
  (simpl (tvar zero)) ∷ (map TS.weaken (TS.id {n}))
    ≡⟨ refl ⟩
  TS.id ∎

-- the semantics of identity type-substitution is exactly
-- system-f's identity type substitution
⟦id⟧tp→ : ∀ {n} → map ⟦_⟧tp→ (TS.id {n}) ≡ F.id
⟦id⟧tp→ {zero} = refl
⟦id⟧tp→ {suc n} = begin
  map ⟦_⟧tp→ (simpl (tvar zero) ∷ map TS.weaken (TS.id {n}))
    ≡⟨ refl ⟩
  F.tvar zero ∷ (map ⟦_⟧tp→ (map TS.weaken (TS.id {n})))
    ≡⟨ cong (_∷_ (F.tvar zero)) (⟦⟧tps→⋆weaken (TS.id {n})) ⟩
  F.tvar zero ∷ (map F.weaken (map ⟦_⟧tp→ (TS.id {n})))
    ≡⟨ cong (λ e → F.tvar zero ∷ (map F.weaken e)) ⟦id⟧tp→ ⟩
  F.tvar zero ∷ (map F.weaken (F.id {n}))
    ≡⟨ refl ⟩
  F.id ∎

-- the semantics of type weakening is exactly system-f's type weakening
⟦wk⟧tp← : ∀ {n} → map ⟦_⟧tp← (F.wk {n}) ≡ TS.wk {n}
⟦wk⟧tp← = begin
  map ⟦_⟧tp← F.wk
    ≡⟨ ⟦⟧tps←⋆weaken F.id ⟩
  map TS.weaken (map ⟦_⟧tp← F.id)
    ≡⟨ cong (map TS.weaken) ⟦id⟧tp← ⟩
  TS.wk ∎

-- the semantics of type weakening is exactly system-f's type weakening
⟦wk⟧tp→ : ∀ {n} → map ⟦_⟧tp→ (TS.wk {n}) ≡ F.wk {n}
⟦wk⟧tp→ = begin
  map ⟦_⟧tp→ TS.wk
    ≡⟨ ⟦⟧tps→⋆weaken TS.id ⟩
  map F.weaken (map ⟦_⟧tp→ TS.id)
    ≡⟨ cong (map F.weaken) ⟦id⟧tp→ ⟩
  F.wk ∎

⟦⟧tps←⋆↑ :  ∀ {ν n} (v : Vec (F.Type ν) n) → ⟦ v F.↑ ⟧tps← ≡ ⟦ v ⟧tps← TS.↑
⟦⟧tps←⋆↑ xs = begin
  (simpl (tvar zero)) ∷ (map ⟦_⟧tp← (map F.weaken xs))
    ≡⟨ cong (_∷_ (simpl (tvar zero))) (⟦⟧tps←⋆weaken xs) ⟩
  (simpl (tvar zero)) ∷ (map TS.weaken (map ⟦_⟧tp← xs))
    ≡⟨ refl ⟩
  (map ⟦_⟧tp← xs) TS.↑ ∎

⟦⟧tps→⋆↑ :  ∀ {ν n} (v : Vec (Type ν) n) → ⟦ v TS.↑ ⟧tps→ ≡ ⟦ v ⟧tps→ F.↑
⟦⟧tps→⋆↑ xs = begin
  F.tvar zero ∷ (map ⟦_⟧tp→ (map TS.weaken xs))
    ≡⟨ cong (_∷_ (F.tvar zero)) (⟦⟧tps→⋆weaken xs) ⟩
  F.tvar zero ∷ (map F.weaken (map ⟦_⟧tp→ xs))
    ≡⟨ refl ⟩
  (map ⟦_⟧tp→ xs) F.↑ ∎

-- type substitution commutes with interpreting types
/⋆⟦⟧tp← : ∀ {ν μ} (tp : F.Type ν) (σ : Sub F.Type ν μ) → ⟦ tp F./ σ ⟧tp← ≡ ⟦ tp ⟧tp← TS./ (map ⟦_⟧tp← σ)
/⋆⟦⟧tp← (F.tc c) σ = refl
/⋆⟦⟧tp← (F.tvar n) σ = begin
  ⟦ lookup n σ ⟧tp←
    ≡⟨ lookup⋆map σ ⟦_⟧tp← n ⟩
  ⟦ F.tvar n ⟧tp← TS./ (map ⟦_⟧tp← σ) ∎
/⋆⟦⟧tp← (l F.→' r) σ = cong₂ _⇒_ (/⋆⟦⟧tp← l σ) (/⋆⟦⟧tp← r σ)
/⋆⟦⟧tp← (l F.⟶ r) σ = cong₂ (λ u v → simpl (u →' v)) (/⋆⟦⟧tp← l σ) (/⋆⟦⟧tp← r σ)
/⋆⟦⟧tp← (F.∀' a) σ = begin
  ∀' ⟦ (a F./ σ F.↑) ⟧tp←
    ≡⟨ cong ∀' (/⋆⟦⟧tp← a (σ F.↑)) ⟩
  ∀' (⟦ a ⟧tp← / ⟦ σ F.↑ ⟧tps←)
    ≡⟨ cong (λ u → ∀' (⟦ a ⟧tp← TS./ u)) ((⟦⟧tps←⋆↑ σ)) ⟩
  ⟦ F.∀' a ⟧tp← / (map ⟦_⟧tp← σ) ∎

-- type substitution commutes with interpreting types
/⋆⟦⟧tp→ : ∀ {ν μ} (tp : Type ν) (σ : Sub Type ν μ) → ⟦ tp TS./ σ ⟧tp→ ≡ ⟦ tp ⟧tp→ F./ (map ⟦_⟧tp→ σ)
/⋆⟦⟧tp→ (simpl (tc c)) σ = refl
/⋆⟦⟧tp→ (simpl (tvar n)) σ = begin
  ⟦ lookup n σ ⟧tp→
    ≡⟨ lookup⋆map σ ⟦_⟧tp→ n ⟩
  ⟦ simpl (tvar n) ⟧tp→ F./ (map ⟦_⟧tp→ σ) ∎
/⋆⟦⟧tp→ (l ⇒ r) σ = cong₂ F._→'_ (/⋆⟦⟧tp→ l σ) (/⋆⟦⟧tp→ r σ)
/⋆⟦⟧tp→ (simpl (l →' r)) σ = cong₂ F._⟶_ (/⋆⟦⟧tp→ l σ) (/⋆⟦⟧tp→ r σ)
/⋆⟦⟧tp→ (∀' a) σ = begin
  F.∀' ⟦ (a TS./ σ TS.↑) ⟧tp→
    ≡⟨ cong F.∀' (/⋆⟦⟧tp→ a (σ TS.↑)) ⟩
  F.∀' (⟦ a ⟧tp→ F./ ⟦ σ TS.↑ ⟧tps→)
    ≡⟨ cong (λ u → F.∀' (⟦ a ⟧tp→ F./ u)) ((⟦⟧tps→⋆↑ σ)) ⟩
  ⟦ ∀' a ⟧tp→ F./ (map ⟦_⟧tp→ σ) ∎

⟦a/sub⟧tp← : ∀ {ν} (a : F.Type (suc ν)) b → ⟦ a F./ (F.sub b) ⟧tp← ≡ ⟦ a ⟧tp← TS./ (TS.sub ⟦ b ⟧tp←)
⟦a/sub⟧tp← a b = begin
  ⟦ a F./ (F.sub b) ⟧tp←
  ≡⟨ /⋆⟦⟧tp← a (b ∷ F.id) ⟩
  (⟦ a ⟧tp← TS./ (map ⟦_⟧tp← (b ∷ F.id)) )
  ≡⟨ refl ⟩
  (⟦ a ⟧tp← TS./ (⟦ b ⟧tp← ∷ (map ⟦_⟧tp← F.id)) )
  ≡⟨ cong (λ s → ⟦ a ⟧tp← TS./ (⟦ b ⟧tp← ∷ s)) ⟦id⟧tp← ⟩
  (⟦ a ⟧tp← TS./ (TS.sub ⟦ b ⟧tp←)) ∎

⟦a/wk⟧tp← : ∀ {ν} → (a : F.Type ν) → ⟦ a F./ F.wk ⟧tp← ≡ ⟦ a ⟧tp← / wk
⟦a/wk⟧tp← tp = begin
  ⟦ tp F./ F.wk ⟧tp←
    ≡⟨ /⋆⟦⟧tp← tp F.wk ⟩
  ⟦ tp ⟧tp← / (map ⟦_⟧tp← F.wk)
    ≡⟨ cong (λ e → ⟦ tp ⟧tp← / e) ⟦wk⟧tp← ⟩
  ⟦ tp ⟧tp← / wk ∎

⟦a/wk⟧tp→ : ∀ {ν} → (a : Type ν) → ⟦ a / wk ⟧tp→ ≡ ⟦ a ⟧tp→ F./ F.wk
⟦a/wk⟧tp→ tp = begin
  ⟦ tp TS./ TS.wk ⟧tp→
    ≡⟨ /⋆⟦⟧tp→ tp TS.wk ⟩
  ⟦ tp ⟧tp→ F./ (map ⟦_⟧tp→ TS.wk)
    ≡⟨ cong (λ e → ⟦ tp ⟧tp→ F./ e) ⟦wk⟧tp→ ⟩
  ⟦ tp ⟧tp→ F./ F.wk ∎

⟦weaken⟧ctx← : ∀ {ν n} (Γ : F.Ctx ν n) → ⟦ F.ctx-weaken Γ ⟧ctx← ≡ ictx-weaken ⟦ Γ ⟧ctx←
⟦weaken⟧ctx← [] = refl
⟦weaken⟧ctx← (x ∷ xs) = begin
  ⟦ F.ctx-weaken (x ∷ xs) ⟧ctx←
    ≡⟨ refl ⟩
  toList (map ⟦_⟧tp← (map (flip F._/_ F.wk) (x ∷ xs)))
    ≡⟨ cong toList (sym (VP.map-∘ _ _ (x ∷ xs))) ⟩
  (⟦ x F./ F.wk ⟧tp← List.∷ (toList (map (⟦_⟧tp← ∘ (flip F._/_ F.wk)) xs)))
    ≡⟨ cong (λ u → ⟦ F._/_ x F.wk ⟧tp← List.∷ toList u) (VP.map-∘ _ _ xs) ⟩
  (⟦ x F./ F.wk ⟧tp← List.∷ ⟦ F.ctx-weaken xs ⟧ctx←)
    ≡⟨ cong (λ u → ⟦ F._/_ x F.wk ⟧tp← List.∷ u) (⟦weaken⟧ctx← xs) ⟩
  (⟦ x F./ F.wk ⟧tp← List.∷ (ictx-weaken ⟦ xs ⟧ctx←))
    ≡⟨ cong (flip List._∷_ (ictx-weaken ⟦ xs ⟧ctx←)) (⟦a/wk⟧tp← x) ⟩
  ictx-weaken ⟦ x ∷ xs ⟧ctx← ∎

⟦weaken⟧ctx→ : ∀ {ν} (Δ : ICtx ν) → F.ctx-weaken ⟦ Δ ⟧ctx→ H.≅ ⟦ ictx-weaken Δ ⟧ctx→
⟦weaken⟧ctx→ List.[] = H.refl
⟦weaken⟧ctx→ (x List.∷ xs) = HR.begin
  F.ctx-weaken ⟦ x List.∷ xs ⟧ctx→
    HR.≅⟨ H.refl ⟩
  (⟦ x ⟧tp→ F./ F.wk) Vec.∷ F.ctx-weaken ⟦ xs ⟧ctx→
    HR.≅⟨ ∷-cong (sym (length-weaken-Δ xs)) (⟦weaken⟧ctx→ xs) ⟩
  (⟦ x ⟧tp→ F./ F.wk) Vec.∷ ⟦ ictx-weaken xs ⟧ctx→
    HR.≅⟨ H.cong (flip Vec._∷_ ⟦ ictx-weaken xs ⟧ctx→) (H.≡-to-≅ $ sym $ ⟦a/wk⟧tp→ x) ⟩
  ⟦ x / wk ⟧tp→ ∷ ⟦ ictx-weaken xs ⟧ctx→
    HR.≅⟨ H.cong (λ u → ⟦ x / wk ⟧tp→ Vec.∷ fromList u) (H.≡-to-≅ (sym (map-compose xs))) ⟩
  (fromList (List.map (⟦_⟧tp→ ∘ (λ s → s / wk)) (x List.∷ xs)))
    HR.≅⟨ H.cong fromList (H.≡-to-≅ (map-compose (x List.∷ xs))) ⟩
  ⟦ ictx-weaken (x List.∷ xs) ⟧ctx→ HR.∎

⟦a/sub⟧tp→ : ∀ {ν} (a : Type (suc ν)) b → ⟦ a TS./ (TS.sub b) ⟧tp→ ≡ ⟦ a ⟧tp→ F./ (F.sub ⟦ b ⟧tp→)
⟦a/sub⟧tp→ a b = begin
  ⟦ a TS./ (TS.sub b) ⟧tp→
  ≡⟨ /⋆⟦⟧tp→ a (b ∷ TS.id) ⟩
  (⟦ a ⟧tp→ F./ (map ⟦_⟧tp→ (b ∷ TS.id)) )
  ≡⟨ refl ⟩
  (⟦ a ⟧tp→ F./ (⟦ b ⟧tp→ ∷ (map ⟦_⟧tp→ TS.id)) )
  ≡⟨ cong (λ s → ⟦ a ⟧tp→ F./ (⟦ b ⟧tp→ ∷ s)) ⟦id⟧tp→ ⟩
  (⟦ a ⟧tp→ F./ (F.sub ⟦ b ⟧tp→)) ∎

⊢subst-n : ∀ {ν n n'} {Γ : F.Ctx ν n} {Γ' : F.Ctx ν n'} {t a} → (n-eq : n ≡ n') →
            Γ H.≅ Γ' → Γ F.⊢ t ∈ a →
            Γ' F.⊢ (subst (F.Term ν) n-eq t) ∈ a
⊢subst-n refl H.refl p = p

lookup-subst-n : ∀ {n n' l} {A : Set l} {v : Vec A n} {v' : Vec A n'} {i : Fin n} →
                  (n-eq : n ≡ n') →
                  (v H.≅ v') →
                  (lookup i v) ≡ (lookup (subst Fin n-eq i) v')
lookup-subst-n refl H.refl = refl

lookup⟦⟧ : ∀ {ν} (Δ : ICtx ν) {r} i → lookup i (fromList Δ) ≡ r →
            (lookup (subst Fin (sym $ length-map _ Δ) i) ⟦ Δ ⟧ctx→) ≡ ⟦ r ⟧tp→
lookup⟦⟧ Δ {r = r} i eq = begin
  (lookup (subst Fin (sym $ length-map _ Δ) i) ⟦ Δ ⟧ctx→)
    ≡⟨ refl ⟩
  (lookup (subst Fin (sym $ length-map _ Δ) i) (fromList $ (List.map ⟦_⟧tp→ Δ)))
    ≡⟨ sym $ lookup-subst-n (sym $ length-map _ Δ) (H.sym $ fromList-map _ Δ) ⟩
  (lookup i (map ⟦_⟧tp→ (fromList Δ)))
    ≡⟨ sym $ lookup⋆map (fromList Δ) ⟦_⟧tp→ i ⟩
  ⟦ lookup i (fromList Δ) ⟧tp→
    ≡⟨ cong ⟦_⟧tp→ eq ⟩
  ⟦ r ⟧tp→ ∎

lookup-∈ : ∀ {ν n} → (x : Fin n) → (v : F.Ctx ν n) → ⟦ lookup x v ⟧tp← ∈ ⟦ v ⟧ctx←
lookup-∈ zero (x ∷ xs) = here refl
lookup-∈ (suc x) (v ∷ vs) = there (lookup-∈ x vs)

⇑-subst-n : ∀ {ν n n'} {Γ : F.Ctx ν n} {Γ' : F.Ctx ν n'} {t a} → (n-eq : n ≡ n') →
            Γ H.≅ Γ' → Γ F.⊢ t ⇑ a →
            Γ' F.⊢ (subst (F.Term ν) n-eq t) ⇑ a
⇑-subst-n refl H.refl p = p

⟦base⟧tp← : ∀ {ν} {a : F.Type ν} → F.Base a → ∃ λ τ → ⟦ a ⟧tp← ≡ (simpl τ)
⟦base⟧tp← (F.tc n) = tc n , refl
⟦base⟧tp← (F.tvar n) = tvar n , refl
⟦base⟧tp← (a F.⟶ b) = ⟦ a ⟧tp← →' ⟦ b ⟧tp← , refl

⟦simpl⟧tp→ : ∀ {ν} (τ : SimpleType ν) → F.Base ⟦ simpl τ ⟧tp→
⟦simpl⟧tp→ (tc x) = F.tc x
⟦simpl⟧tp→ (tvar n) = F.tvar n
⟦simpl⟧tp→ (x →' x₁) = ⟦ x ⟧tp→ F.⟶ ⟦ x₁ ⟧tp→

open import Function.Inverse

tp-iso : ∀ {ν} → (→-to-⟶ (⟦_⟧tp→ {ν = ν})) InverseOf (→-to-⟶ (⟦_⟧tp← {ν = ν}))
tp-iso = record { left-inverse-of = tp←→ ; right-inverse-of = tp→← }


------------------------------------------------------------------------
-- Laws related to D
------------------------------------------------------------------------

module TotalParserCombinators.Laws.Derivative where

open import Algebra
open import Codata.Musical.Notation
open import Data.List
import Data.List.Categorical as List
import Data.List.Relation.Binary.BagAndSetEquality as BSEq
open import Data.Maybe using (Maybe); open Data.Maybe.Maybe
open import Function using (_∘_; _$_)

private
  module BagMonoid {k} {A : Set} =
    CommutativeMonoid (BSEq.commutativeMonoid k A)

open import TotalParserCombinators.Derivative
open import TotalParserCombinators.Congruence as Eq
  hiding (return; fail)
import TotalParserCombinators.Laws.AdditiveMonoid as AdditiveMonoid
open import TotalParserCombinators.Lib
open import TotalParserCombinators.Parser

-- Unfolding lemma for D applied to return⋆.

D-return⋆ : ∀ {Tok R t} (xs : List R) →
            D t (return⋆ xs) ≅P fail {Tok = Tok}
D-return⋆         []       = fail ∎
D-return⋆ {t = t} (x ∷ xs) =
  fail ∣ D t (return⋆ xs)  ≅⟨ AdditiveMonoid.left-identity (D t (return⋆ xs)) ⟩
  D t (return⋆ xs)         ≅⟨ D-return⋆ xs ⟩
  fail                     ∎

mutual

  -- Unfolding lemma for D applied to _⊛_.

  D-⊛ : ∀ {Tok R₁ R₂ fs xs t}
        (p₁ : ∞⟨ xs ⟩Parser Tok (R₁ → R₂) (flatten fs))
        (p₂ : ∞⟨ fs ⟩Parser Tok  R₁       (flatten xs)) →
        D t (p₁ ⊛ p₂) ≅P
        D t (♭? p₁) ⊛ ♭? p₂ ∣ return⋆ (flatten fs) ⊛ D t (♭? p₂)
  D-⊛ {fs = nothing} {xs = just _} {t = t} p₁ p₂ =
    D t p₁ ⊛ ♭ p₂                      ≅⟨ sym $ AdditiveMonoid.right-identity (D t p₁ ⊛ ♭ p₂) ⟩
    D t p₁ ⊛ ♭ p₂ ∣ fail               ≅⟨ (D t p₁ ⊛ ♭ p₂ ∎) ∣ sym (left-zero-⊛ (D t (♭ p₂))) ⟩
    D t p₁ ⊛ ♭ p₂ ∣ fail ⊛ D t (♭ p₂)  ∎
  D-⊛ {fs = nothing} {xs = nothing} {t = t} p₁ p₂ =
    D t (p₁ ⊛ p₂)                          ≅⟨ [ ◌ - ○ - ○ - ○ ] D t (♭ p₁) ∎ ⊛ (♭ p₂ ∎) ⟩
    D t (♭ p₁) ⊛ ♭ p₂                      ≅⟨ sym $ AdditiveMonoid.right-identity (D t (♭ p₁) ⊛ ♭ p₂) ⟩
    D t (♭ p₁) ⊛ ♭ p₂ ∣ fail               ≅⟨ (D t (♭ p₁) ⊛ ♭ p₂ ∎) ∣ sym (left-zero-⊛ (D t (♭ p₂))) ⟩
    D t (♭ p₁) ⊛ ♭ p₂ ∣ fail ⊛ D t (♭ p₂)  ∎
  D-⊛ {fs = just _} {xs = just _} {t = t} p₁ p₂ =
    D t (p₁ ⊛ p₂) ∎
  D-⊛ {fs = just fs} {xs = nothing} {t = t} p₁ p₂ =
    D t (p₁ ⊛ p₂)                          ≅⟨ [ ◌ - ○ - ○ - ○ ] D t (♭ p₁) ∎ ⊛ (p₂ ∎) ∣
                                              (return⋆ fs ⊛ D t p₂ ∎) ⟩
    D t (♭ p₁) ⊛ p₂ ∣ return⋆ fs ⊛ D t p₂  ∎

  -- fail is a left zero of ⊛.

  left-zero-⊛ : ∀ {Tok R₁ R₂ xs} (p : Parser Tok R₁ xs) →
                fail ⊛ p ≅P fail {R = R₂}
  left-zero-⊛ {xs = xs} p =
    BagMonoid.reflexive (List.Applicative.left-zero xs) ∷ λ t → ♯ (
      D t (fail ⊛ p)           ≅⟨ D-⊛ fail p ⟩
      fail ⊛ p ∣ fail ⊛ D t p  ≅⟨ left-zero-⊛ p ∣ left-zero-⊛ (D t p) ⟩
      fail ∣ fail              ≅⟨ AdditiveMonoid.right-identity fail ⟩
      fail                     ∎)

-- fail is a right zero of ⊛.

right-zero-⊛ : ∀ {Tok R₁ R₂ fs} (p : Parser Tok (R₁ → R₂) fs) →
               p ⊛ fail ≅P fail
right-zero-⊛ {fs = fs} p =
  BagMonoid.reflexive (List.Applicative.right-zero fs) ∷ λ t → ♯ (
    D t (p ⊛ fail)                    ≅⟨ D-⊛ p fail ⟩
    D t p ⊛ fail ∣ return⋆ fs ⊛ fail  ≅⟨ right-zero-⊛ (D t p) ∣ right-zero-⊛ (return⋆ fs) ⟩
    fail ∣ fail                       ≅⟨ AdditiveMonoid.left-identity fail ⟩
    fail                              ∎)

-- A simplified instance of D-⊛.

D-return-⊛ : ∀ {Tok R₁ R₂ xs t}
             (f : R₁ → R₂) (p : Parser Tok R₁ xs) →
             D t (return f ⊛ p) ≅P return f ⊛ D t p
D-return-⊛ {t = t} f p =
  D t (return f ⊛ p)                ≅⟨ D-⊛ (return f) p ⟩
  fail ⊛ p ∣ return⋆ [ f ] ⊛ D t p  ≅⟨ left-zero-⊛ p ∣
                                       [ ○ - ○ - ○ - ○ ] AdditiveMonoid.right-identity (return f) ⊛ (D t p ∎) ⟩
  fail ∣ return f ⊛ D t p           ≅⟨ AdditiveMonoid.left-identity (return f ⊛ D t p) ⟩
  return f ⊛ D t p                  ∎

mutual

  -- Unfolding lemma for D applied to _>>=_.

  D->>= : ∀ {Tok R₁ R₂ xs t} {f : Maybe (R₁ → List R₂)}
          (p₁ : ∞⟨ f ⟩Parser Tok R₁ (flatten xs))
          (p₂ : (x : R₁) → ∞⟨ xs ⟩Parser Tok R₂ (apply f x)) →
          D t (p₁ >>= p₂) ≅P
          D t (♭? p₁) >>= (♭? ∘ p₂) ∣
          return⋆ (flatten xs) >>= (λ x → D t (♭? (p₂ x)))
  D->>= {xs = nothing} {t = t} {f = just _} p₁ p₂ =
    D t p₁ >>= (♭ ∘ p₂)                                    ≅⟨ sym $ AdditiveMonoid.right-identity (D t p₁ >>= (♭ ∘ p₂)) ⟩
    D t p₁ >>= (♭ ∘ p₂) ∣ fail                             ≅⟨ (D t p₁ >>= (♭ ∘ p₂) ∎) ∣
                                                              sym (left-zero->>= (λ x → D t (♭ (p₂ x)))) ⟩
    D t p₁ >>= (♭ ∘ p₂) ∣ fail >>= (λ x → D t (♭ (p₂ x)))  ∎
  D->>= {xs = just xs} {t = t} {f = just _} p₁ p₂ =
    D t p₁ >>= p₂ ∣ return⋆ xs >>= (λ x → D t (p₂ x))  ∎
  D->>= {xs = nothing} {t = t} {f = nothing} p₁ p₂ =
    D t (p₁ >>= p₂)                                            ≅⟨ [ ◌ - ○ - ○ - ○ ] _ ∎ >>= (λ _ → _ ∎) ⟩
    D t (♭ p₁) >>= (♭ ∘ p₂)                                    ≅⟨ sym $ AdditiveMonoid.right-identity (D t (♭ p₁) >>= (♭ ∘ p₂)) ⟩
    D t (♭ p₁) >>= (♭ ∘ p₂) ∣ fail                             ≅⟨ (D t (♭ p₁) >>= (♭ ∘ p₂) ∎) ∣
                                                                  sym (left-zero->>= (λ x → D t (♭ (p₂ x)))) ⟩
    D t (♭ p₁) >>= (♭ ∘ p₂) ∣ fail >>= (λ x → D t (♭ (p₂ x)))  ∎
  D->>= {xs = just xs} {t = t} {f = nothing} p₁ p₂ =
    D t (p₁ >>= p₂)                                        ≅⟨ [ ◌ - ○ - ○ - ○ ] _ ∎ >>= (λ _ → _ ∎) ∣ (_ ∎) ⟩
    D t (♭ p₁) >>= p₂ ∣ return⋆ xs >>= (λ x → D t (p₂ x))  ∎

  -- fail is a left zero of _>>=_.

  left-zero->>= : ∀ {Tok R₁ R₂} {f : R₁ → List R₂}
                 (p : (x : R₁) → Parser Tok R₂ (f x)) →
                 fail >>= p ≅P fail
  left-zero->>= {f = f} p =
    BagMonoid.reflexive (List.MonadProperties.left-zero f) ∷ λ t → ♯ (
      D t (fail >>= p)                         ≅⟨ D->>= {t = t} fail p ⟩
      fail >>= p ∣ fail >>= (λ x → D t (p x))  ≅⟨ left-zero->>= p ∣ left-zero->>= (λ x → D t (p x)) ⟩
      fail ∣ fail                              ≅⟨ AdditiveMonoid.right-identity fail ⟩
      fail                                     ∎)

-- fail is a right zero of _>>=_.

right-zero->>= : ∀ {Tok R₁ R₂} {xs : List R₁}
                (p : Parser Tok R₁ xs) →
                p >>= (λ _ → fail) ≅P fail {Tok = Tok} {R = R₂}
right-zero->>= {xs = xs} p =
  BagMonoid.reflexive (List.MonadProperties.right-zero xs) ∷ λ t → ♯ (
    D t (p >>= λ _ → fail)                                ≅⟨ D->>= p (λ _ → fail) ⟩
    D t p >>= (λ _ → fail) ∣ return⋆ xs >>= (λ _ → fail)  ≅⟨ right-zero->>= (D t p) ∣ right-zero->>= (return⋆ xs) ⟩
    fail ∣ fail                                           ≅⟨ AdditiveMonoid.left-identity fail ⟩
    fail                                                  ∎)