{-# OPTIONS --allow-unsolved-metas #-}
open import Data.Nat -- using (ℕ; suc; zero; s≤s ; z≤n )
module FLComm (n : ℕ) where

open import Level renaming ( suc to Suc ; zero to Zero ) hiding (lift)
open import Data.Fin hiding ( _<_  ; _≤_ ; _-_ ; _+_ ; _≟_)
open import Data.Fin.Properties hiding ( <-trans ; ≤-refl ; ≤-trans ; ≤-irrelevant ; _≟_ ) renaming ( <-cmp to <-fcmp )
open import Data.Fin.Permutation
open import Data.Nat.Properties
open import Relation.Binary.PropositionalEquality hiding ( [_] ) renaming ( sym to ≡-sym )
open import Data.List using (List; []; _∷_ ; length ; _++_ ; tail ) renaming (reverse to rev )
open import Data.Product hiding (_,_ )
open import Relation.Nullary
open import Data.Unit hiding (_≤_)
open import Data.Empty
open import  Relation.Binary.Core
open import  Relation.Binary.Definitions hiding (Symmetric )
open import logic
open import nat

open import FLutil
open import Putil
import Solvable
open import Symmetric

-- infixr  100 _::_

open import Relation.Nary using (⌊_⌋)
open import Data.List.Fresh hiding ([_])
open import Data.List.Fresh.Relation.Unary.Any

open import Algebra
open Group (Symmetric n) hiding (refl)
open Solvable (Symmetric n)
open _∧_
-- open import Relation.Nary using (⌊_⌋)
open import Relation.Nullary.Decidable hiding (⌊_⌋)

open import fin

-- all cobmbination in P and Q (could be more general)
record AnyComm {n m l : ℕ}  (P : FList n) (Q : FList m) (fpq : (p : FL n) (q : FL m) → FL l) : Set where
   field
     commList : FList l
     commAny : (p : FL n) (q : FL m)
         → Any ( p ≡_ ) P →  Any ( q ≡_ ) Q
         → Any (fpq p q ≡_) commList

-------------
--    (p,q)   (p,qn) ....           (p,q0)
--    pn,q
--     :        AnyComm FL0 FL0 P  Q
--    p0,q

open AnyComm
anyComm : {n m l : ℕ } → (P : FList n) (Q : FList m) → (fpq : (p : FL n) (q : FL m) → FL l)  → AnyComm P Q fpq
anyComm [] [] _ = record { commList = [] ; commAny = λ _ _ () }
anyComm [] (cons q Q qr) _ = record { commList = [] ; commAny = λ _ _ () }
anyComm (cons p P pr) [] _ = record { commList = [] ; commAny = λ _ _ _ () }
anyComm {n} {m} {l} (cons p P pr) (cons q Q qr) fpq = record { commList = FLinsert (fpq p q) (commListQ Q)  ; commAny = anyc0n } where
  commListP : (P1 : FList n) → FList l
  commListP [] = commList (anyComm P Q fpq)
  commListP (cons p₁ P1 x) =  FLinsert (fpq p₁ q) (commListP P1)
  commListQ : (Q1 : FList m) → FList l
  commListQ [] = commListP P
  commListQ (cons q₁ Q1 qr₁) = FLinsert (fpq p q₁) (commListQ Q1)
  anyc0n : (p₁ : FL n) (q₁ : FL m) → Any (_≡_ p₁) (cons p P pr) → Any (_≡_ q₁) (cons q Q qr)
    → Any (_≡_ (fpq p₁ q₁)) (FLinsert (fpq p q) (commListQ Q))
  anyc0n p₁ q₁ (here refl) (here refl) = x∈FLins _ (commListQ Q )
  anyc0n p₁ q₁ (here refl) (there anyq) = insAny (commListQ Q) (anyc01 Q anyq) where
     anyc01 : (Q1 : FList m) → Any (_≡_ q₁) Q1 → Any (_≡_ (fpq p₁ q₁)) (commListQ Q1)
     anyc01 (cons q Q1 qr₂) (here refl) = x∈FLins _ _
     anyc01 (cons q₂ Q1 qr₂) (there any) = insAny _ (anyc01 Q1 any)
  anyc0n p₁ q₁ (there anyp) (here refl) = insAny _ (anyc02 Q) where
     anyc03 : (P1 : FList n) → Any (_≡_ p₁) P1  → Any (_≡_ (fpq p₁ q₁)) (commListP P1)
     anyc03 (cons a P1 x) (here refl) = x∈FLins _ _
     anyc03 (cons a P1 x) (there any) = insAny _ ( anyc03 P1 any)
     anyc02 : (Q1 : FList m) → Any (_≡_ (fpq p₁ q₁)) (commListQ Q1)
     anyc02 [] = anyc03 P anyp
     anyc02 (cons a Q1 x) = insAny _ (anyc02 Q1)
  anyc0n p₁ q₁ (there anyp) (there anyq) = insAny (commListQ Q) (anyc04 Q) where
     anyc05 : (P1 : FList n) → Any (_≡_ (fpq p₁ q₁)) (commListP P1)
     anyc05 [] = commAny (anyComm P Q fpq) p₁ q₁ anyp anyq
     anyc05 (cons a P1 x) = insAny _ (anyc05 P1)
     anyc04 : (Q1 : FList m) → Any (_≡_ (fpq p₁ q₁)) (commListQ Q1)
     anyc04 [] = anyc05 P
     anyc04 (cons a Q1 x) = insAny _ (anyc04 Q1)

-------------
--    # 0 :: # 0 :: # 0 : # 0 :: f0
--    # 0 :: # 0 :: # 1 : # 0 :: f0
--    # 0 :: # 1 :: # 0 : # 0 :: f0
--    # 0 :: # 1 :: # 1 : # 0 :: f0
--    # 0 :: # 2 :: # 0 : # 0 :: f0
--       ...
--    # 3 :: # 2 :: # 0 : # 0 :: f0
--    # 3 :: # 2 :: # 1 : # 0 :: f0

-- all FL
record AnyFL (n : ℕ) : Set where
   field
     allFL : FList n
     anyP : (x : FL n) → Any (x ≡_ ) allFL

open AnyFL

--   all FL as all combination
--      anyComm ( #0 :: FL0 ... # n :: FL0 ) (all n) (λ p q → FLpos p :: q ) = all (suc n)

anyFL01 :  (n : ℕ) → AnyFL (suc n)
anyFL01 zero    = record { allFL = (zero :: f0) ∷# [] ; anyP = λ x → anyFL2 x ((zero :: f0) ∷# []) refl }  where
     anyFL2 : (x : FL 1) → (y : FList 1) → y ≡ ((zero :: f0) ∷# []) → Any (_≡_ x) y
     anyFL2 (zero :: f0) .(cons (zero :: f0) [] (Level.lift tt)) refl = here refl
anyFL01 (suc n) = record { allFL = commList anyC ;  anyP =  anyFL02 } where
     anyFL05 : {n i : ℕ} → (i < suc n) → FList (suc n)
     anyFL05 {_} {0} (s≤s z≤n) = zero :: FL0 ∷# []
     anyFL05 {n} {suc i} (s≤s i<n) = FLinsert (fromℕ< (s≤s i<n) :: FL0) (anyFL05 {n} {i} (<-trans i<n a<sa))
     anyFL08 : {n i : ℕ} {x : Fin (suc n)} {i<n : suc i < suc n}  → toℕ x ≡ suc i → x ≡ suc (fromℕ< (≤-pred i<n))
     anyFL08 {n} {i} {x} {i<n} eq = toℕ-injective ( begin
                toℕ x                               ≡⟨ eq ⟩
                suc i                               ≡⟨ cong suc (≡-sym (toℕ-fromℕ< _ )) ⟩
                suc (toℕ (fromℕ< (≤-pred i<n)) )
          ∎ ) where open ≡-Reasoning
     anyFL06 : {n i : ℕ} → (i<n : i < suc n) → (x : Fin (suc n)) → toℕ x < suc i → Any (_≡_ (x :: FL0)) (anyFL05 i<n)
     anyFL06 (s≤s z≤n) zero (s≤s lt) = here refl
     anyFL06 {n} {suc i} (s≤s (s≤s i<n)) x (s≤s lt) with <-cmp (toℕ x) (suc i)
     ... | tri< a ¬b ¬c = insAny _ (anyFL06 (<-trans (s≤s i<n) a<sa) x a)
     ... | tri≈ ¬a b ¬c = subst (λ k →  Any (_≡_ (x :: FL0)) (FLinsert (k :: FL0) (anyFL05 {n} {i} (<-trans (s≤s i<n) a<sa))))
                  (anyFL08 {n} {i} {x} {s≤s (s≤s i<n)} b) (x∈FLins (x :: FL0)  (anyFL05 {n} {i} (<-trans (s≤s i<n) a<sa)))
     ... | tri> ¬a ¬b c = ⊥-elim ( nat-≤> c (s≤s lt) )
     anyC = anyComm (anyFL05 a<sa) (allFL (anyFL01 n)) (λ p q → FLpos p :: q )
     anyFL02 : (x : FL (suc (suc n))) → Any (_≡_ x) (commList anyC)
     anyFL02 (x :: y) = commAny anyC (x :: FL0) y
                       (subst (λ k → Any (_≡_ (k :: FL0) ) _) (fromℕ<-toℕ _ _) (anyFL06 a<sa (fromℕ< x≤n) fin<n) ) (anyP (anyFL01 n) y) where
         x≤n : suc (toℕ x)  ≤ suc (suc n)
         x≤n = toℕ<n x

anyFL :  (n : ℕ) → AnyFL n
anyFL zero = record { allFL = f0 ∷# [] ; anyP = anyFL4 } where
    anyFL4 : (x : FL zero) → Any (_≡_ x) ( f0 ∷# [] )
    anyFL4 f0 = here refl
anyFL (suc n) = anyFL01 n

at1 = proj₁ (toList (allFL (anyFL 1)))
at2 = proj₁ (toList (allFL (anyFL 2)))
at3 = proj₁ (toList (allFL (anyFL 3)))
at4 = proj₁ (toList (allFL (anyFL 4)))

CommFListN  : ℕ →  FList n
CommFListN  zero = allFL (anyFL n)
CommFListN (suc i ) = commList (anyComm ( CommFListN i ) ( CommFListN i ) (λ p q →  perm→FL [ FL→perm p , FL→perm q ] ))

CommStage→ : (i : ℕ) → (x : Permutation n n ) → deriving i x → Any (perm→FL x ≡_) (CommFListN i)
CommStage→ zero x (Level.lift tt) = anyP (anyFL n) (perm→FL x)
CommStage→ (suc i) .( [ g , h ] ) (comm {g} {h} p q) = comm2 where
  G = perm→FL g
  H = perm→FL h
  comm3 :  perm→FL [ FL→perm G , FL→perm H ] ≡ perm→FL [ g , h ]
  comm3 = begin
              perm→FL [ FL→perm G , FL→perm H ]
           ≡⟨ pcong-pF (comm-resp (FL←iso _) (FL←iso _)) ⟩
              perm→FL [ g , h ]
          ∎  where open ≡-Reasoning
  comm2 : Any (_≡_ (perm→FL [ g , h ])) (CommFListN (suc i))
  comm2 = subst (λ k → Any (_≡_ k) (CommFListN (suc i)) ) comm3
     ( commAny ( anyComm (CommFListN i) (CommFListN i) (λ p q →  perm→FL [ FL→perm p , FL→perm q ] )) G H (CommStage→ i g p) (CommStage→ i h q) )
CommStage→ (suc i) x (ccong {f} {x} eq p) =
      subst (λ k → Any (k ≡_) (commList (anyComm ( CommFListN i ) ( CommFListN i ) (λ p q →  perm→FL [ FL→perm p , FL→perm q ] ))))
          (comm4 eq) (CommStage→ (suc i) f p ) where
   comm4 : f =p= x →  perm→FL f ≡ perm→FL x
   comm4 = pcong-pF

CommSolved : (x : Permutation n n) → (y : FList n) → y ≡ FL0 ∷# [] → (FL→perm (FL0 {n}) =p= pid ) → Any (perm→FL x ≡_) y → x =p= pid
CommSolved x .(cons FL0 [] (Level.lift tt)) refl eq0 (here eq) = FLpid _ eq eq0


module _ where

open import Common.Prelude hiding (_>>=_)
open import Common.Reflection

pattern `Nat = def (quote Nat) []

unquoteDecl f =
  declareDef (vArg f) `Nat >>= λ _ →
  freshName "aux" >>= λ aux →
  declareDef (vArg aux) `Nat >>= λ _ →
  defineFun f (clause [] (def aux []) ∷ [])


-- Andreas, 2016-08-08, issue #2132 reported by effectfully
-- Pattern synonyms in lhss of display form definitions

-- {-# OPTIONS -v scope:50 -v tc.decl:10 #-}

open import Common.Equality

data D : Set where
  C c : D
  g : D → D

pattern C′ = C

{-# DISPLAY C′ = C′ #-}
{-# DISPLAY g C′ = c #-}

-- Since pattern synonyms are now expanded on lhs of DISPLAY,
-- this behaves as
-- {-# DISPLAY C = C′ #-}
-- {-# DISPLAY g C = c #-}

test : C ≡ g C
test = refl

-- Expected error:
-- C′ != c of type D
-- when checking that the expression refl has type C′ ≡ c


open import Data.Bool using (Bool; true; false)
open import Data.Float using (Float)
open import Avionics.Maybe using (Maybe; just; nothing; _>>=_; map)
--open import Data.Maybe using (Maybe; just; nothing; _>>=_; map)
open import Data.Nat using (ℕ)
open import Function using (_∘_)
open import Level using (0ℓ; _⊔_) renaming (suc to lsuc)
open import Relation.Binary using (Decidable)
open import Relation.Binary.Definitions using (Transitive; Trans)
open import Relation.Binary.PropositionalEquality using (_≡_)
open import Relation.Nullary using (Dec; yes; no)
open import Relation.Nullary.Decidable using (False; ⌊_⌋; True)
open import Relation.Unary using (Pred; _∈_)

-- stack exec -- agda -c --ghc-dont-call-ghc --no-main code.agda

infix  4 _≤_ _≤ᵇ_ _≤?_

postulate
  ℝ : Set

  fromFloat : Float → Maybe ℝ
  toFloat : ℝ → Float

  0ℝ : ℝ

  _≤_ : ℝ → ℝ → Set
  _≤?_ : (m n : ℝ) → Dec (m ≤ n)

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

postulate
  √_ : (x : ℝ) → .{0≤x : True (0ℝ ≤? x)} → ℝ

--Subset : Set → Set _
--Subset A = Pred A 0ℓ
--
--postulate
--  [0,∞⟩ : Subset ℝ
--
--  √_ : (x : ℝ) → .{0≤x : x ∈ [0,∞⟩} → ℝ

{-# COMPILE GHC ℝ = type Double #-}

-- `fromFloat` should check whether it is a valid floating point
-- number
{-# COMPILE GHC fromFloat = \x -> Just x #-}
{-# COMPILE GHC toFloat = \x -> x #-}

{-# COMPILE GHC 0ℝ = 0 #-}

{-# FOREIGN GHC type UnitErase a b = () #-}
{-# COMPILE GHC _≤_ = type UnitErase #-}
--{-# COMPILE GHC _≤_ = \ _ _ -> () #-}
{-# COMPILE GHC _≤ᵇ_ = (<=) #-}

--{-# FOREIGN GHC type UnitErase erase = () #-}
--{-# COMPILE GHC [0,∞⟩ = type UnitErase #-}

-- TODO: Find out how to perform the `sqrt` of a value!!
--       Here lies the main problem of compilation failure!
{-# COMPILE GHC √_  = \x _ -> sqrt x #-}
-- Agda is actually doing the right thing not accepting dubious
-- translations of code into Haskell

export√ : Float → Maybe Float
export√ x = fromFloat x >>= sqrt >>= just ∘ toFloat
  where
    sqrt : ℝ → Maybe ℝ
    sqrt y with 0ℝ ≤ᵇ y
    ... | false = nothing
    ... | true = just ((√ y) {y≥0})
      where postulate y≥0 : True (0ℝ ≤? y)
      --where postulate y≥0 : y ∈ [0,∞⟩
{-# COMPILE GHC export√ as exportSqrt #-}


-- Issue reported by Sergei Meshvelliani
-- Simplified example by Guillaume Allais

-- When adding missing absurd clauses, dot patterns were accidentally
-- turned into variable patterns.

{-# OPTIONS --allow-unsolved-metas #-}

open import Agda.Builtin.List

open import Agda.Builtin.Equality

data Var (T : Set₂) (σ : T) : List T → Set₂ where
  z : ∀ Γ → Var T σ (σ ∷ Γ)
  s : ∀ τ Γ → Var T σ Γ → Var T σ (τ ∷ Γ)

eq : ∀ Γ (b c : Var _ Set Γ) → b ≡ c → Set
eq .(Set ∷ Γ) (z Γ) (z .Γ) _ = {!!}
eq .(τ ∷ Γ) (s τ Γ m) (s .τ .Γ n) _ = {!!}

-- WAS: Internal error in CompiledClause.Compile
-- SHOULD: Succeed


module PiQ.Everything where
open import PiQ.Syntax     -- Syntax of PiQ
open import PiQ.Opsem      -- Abstract machine semantics of PiQ
open import PiQ.AuxLemmas  -- Some auxiliary lemmas about opsem for forward/backward deterministic proof
open import PiQ.NoRepeat   -- Forward/backward deterministic lemmas and Non-repeating lemma
open import PiQ.Invariants -- Some invariants about abstract machine semantics
open import PiQ.Eval       -- Evaluator for PiQ
open import PiQ.Interp     -- Big-step intepreter
open import PiQ.Properties -- Properties of PiQ
open import PiQ.Examples   -- Examples
open import PiQ.SAT        -- SAT solver


postulate A : Set

module _ {{a : A}} (f : A → A) where

  g : {{a : A}} → A
  g {{a}} = a

  t : A
  t = g


module UpTo where

open import Level
open import Relation.Binary using (Rel; IsEquivalence)
open import Data.Product
open import Categories.Support.Equivalence
open import Categories.Category
open import Categories.2-Category
open import Categories.Functor
open import Categories.NaturalTransformation
  renaming (id to natId; _≡_ to _≡N_; setoid to natSetoid)
  hiding (_∘ˡ_; _∘ʳ_)
open import Categories.Support.EqReasoning

open import NaturalTransFacts

Cat₀ = Category zero zero zero

EndoFunctor : Cat₀ → Set zero
EndoFunctor C = Functor C C

record Endo⇒ (C₁ : Cat₀) (F₁ : EndoFunctor C₁)
             (C₂ : Cat₀) (F₂ : EndoFunctor C₂)
             : Set zero where
  field
    T : Functor C₁ C₂
    ρ : NaturalTransformation (T ∘ F₁) (F₂ ∘ T)

record UpTo⇒ {C₁ : Cat₀} {F : EndoFunctor C₁}
             {C₂ : Cat₀} {G : EndoFunctor C₂}
             (S₁ S₂ : Endo⇒ C₁ F C₂ G)
             : Set zero where
  module S₁ = Endo⇒ S₁
  module S₂ = Endo⇒ S₂
  field
    γ : NaturalTransformation S₁.T S₂.T
    -- The following diagram must commute
    -- T₁F - ρ₁ -> GT₁
    --  |            |
    --  γF         Gγ
    --  |            |
    --  v            v
    -- T₂G - ρ₂ -> GT₂
    .square : S₂.ρ ∘₁ (γ ∘ʳ F) ≡N (G ∘ˡ γ) ∘₁ S₁.ρ

record _≡U_ {C₁ : Cat₀} {C₂ : Cat₀}
            {F : EndoFunctor C₁} {G : EndoFunctor C₂}
            {T₁ T₂ : Endo⇒ C₁ F C₂ G}
            (A : UpTo⇒ T₁ T₂) (B : UpTo⇒ T₁ T₂) : Set where
  field
    ≡U-proof : UpTo⇒.γ A ≡N UpTo⇒.γ B

open _≡U_
infix 4 _≡U_

.≡U-equiv : {C₁ : Cat₀} {C₂ : Cat₀}
            {F : EndoFunctor C₁} {G : EndoFunctor C₂} →
            {A B : Endo⇒ C₁ F C₂ G} →
            IsEquivalence {A = UpTo⇒ A B} (_≡U_ {C₁} {C₂} {F} {G})
≡U-equiv =
  record
  { refl = λ {A} → record { ≡U-proof = Setoid.refl natSetoid {UpTo⇒.γ A} }
  ; sym = λ {A} {B} p → record {
        ≡U-proof = Setoid.sym natSetoid {UpTo⇒.γ A} {UpTo⇒.γ B} (≡U-proof p) }
  ; trans = λ {A} {B} {C} p₁ p₂ → record {
          ≡U-proof = Setoid.trans natSetoid {UpTo⇒.γ A} {UpTo⇒.γ B} {UpTo⇒.γ C}
                     (≡U-proof p₁) (≡U-proof p₂) }
  }

id-UpTo⇒ : {C₁ : Cat₀} {F : EndoFunctor C₁}
           {C₂ : Cat₀} {G : EndoFunctor C₂}
           {A : Endo⇒ C₁ F C₂ G} → UpTo⇒ A A
id-UpTo⇒ {C₁} {F} {C₂} {G} {A} =
  record
      { γ = natId
      ; square =
        begin
          Endo⇒.ρ A ∘₁ (natId {F = Endo⇒.T A} ∘ʳ F)
        ↓⟨ ∘₁-resp-≡
           {f = Endo⇒.ρ A} {h = Endo⇒.ρ A}
           {g = natId {F = Endo⇒.T A} ∘ʳ F}
           {i = natId {F = Endo⇒.T A ∘ F}}
           (Setoid.refl natSetoid {Endo⇒.ρ A})
           (identityNatʳ {F = Endo⇒.T A} F)
         ⟩
          Endo⇒.ρ A ∘₁ (natId {F = Endo⇒.T A ∘ F})
        ↓⟨ identity₁ʳ {X = Endo⇒.ρ A} ⟩
          Endo⇒.ρ A
        ↑⟨ identity₁ˡ {X = Endo⇒.ρ A} ⟩
          natId {F = G ∘ Endo⇒.T A} ∘₁ Endo⇒.ρ A
        ↑⟨ ∘₁-resp-≡
           {f = G ∘ˡ natId {F = Endo⇒.T A}}
           {h = natId {F = G ∘ Endo⇒.T A}}
           {g = Endo⇒.ρ A} {i = Endo⇒.ρ A}
           (identityNatˡ {F = Endo⇒.T A} G)
           (Setoid.refl natSetoid {Endo⇒.ρ A})
         ⟩
          (G ∘ˡ natId {F = Endo⇒.T A}) ∘₁ Endo⇒.ρ A
        ∎
      }
        where
          open SetoidReasoning (natSetoid {F = Endo⇒.T A ∘ F} {G ∘ Endo⇒.T A})

_•_ : {C₁ : Cat₀} {F : EndoFunctor C₁}
             {C₂ : Cat₀} {G : EndoFunctor C₂}
             {A B C : Endo⇒ C₁ F C₂ G} →
             UpTo⇒ B C → UpTo⇒ A B → UpTo⇒ A C
_•_ {F = F} {G = G} {A = A} {B} {C} g f =
  record
  { γ = γ ∘₁ φ
  ; square =
    --     AF - A.ρ -> GA
    --     |           |
    --    φF          Gφ
    --     |           |
    --     v           v
    --    BF - B.ρ -> GB
    --     |           |
    --     γF         Gγ
    --     |           |
    --     v           v
    --    CF - C.ρ -> GC
    begin
      C.ρ ∘₁ ((γ ∘₁ φ) ∘ʳ F)
    ↓⟨ ∘₁-resp-≡ʳ
       {f = C.ρ} {(γ ∘₁ φ) ∘ʳ F} {(γ ∘ʳ F) ∘₁ (φ ∘ʳ F)}
       (∘ʳ-distr-∘₁ γ φ F)
     ⟩
      C.ρ ∘₁ ((γ ∘ʳ F) ∘₁ (φ ∘ʳ F))
    ↑⟨ assoc₁ {X = (φ ∘ʳ F)} {(γ ∘ʳ F)} {C.ρ} ⟩
      (C.ρ ∘₁ (γ ∘ʳ F)) ∘₁ (φ ∘ʳ F)
    ↓⟨ ∘₁-resp-≡ˡ
       {f = C.ρ ∘₁ (γ ∘ʳ F)} {G ∘ˡ γ ∘₁ B.ρ} {φ ∘ʳ F}
       (UpTo⇒.square g)
     ⟩
      (G ∘ˡ γ ∘₁ B.ρ) ∘₁ (φ ∘ʳ F)
    ↓⟨ assoc₁ {X = (φ ∘ʳ F)} {B.ρ} {G ∘ˡ γ} ⟩
      (G ∘ˡ γ) ∘₁ (B.ρ ∘₁ (φ ∘ʳ F))
    ↓⟨ ∘₁-resp-≡ʳ
       {f = G ∘ˡ γ} {B.ρ ∘₁ (φ ∘ʳ F)} {(G ∘ˡ φ) ∘₁ A.ρ}
       (UpTo⇒.square f)
     ⟩
      (G ∘ˡ γ) ∘₁ ((G ∘ˡ φ) ∘₁ A.ρ)
    ↑⟨ assoc₁ {X = A.ρ} {G ∘ˡ φ} {G ∘ˡ γ} ⟩
      ((G ∘ˡ γ) ∘₁ (G ∘ˡ φ)) ∘₁ A.ρ
    ↑⟨ ∘₁-resp-≡ˡ
       {f = G ∘ˡ (γ ∘₁ φ)} {(G ∘ˡ γ) ∘₁ (G ∘ˡ φ)}  {A.ρ}
       (∘ˡ-distr-∘₁ G γ φ)
     ⟩
      (G ∘ˡ (γ ∘₁ φ)) ∘₁ A.ρ
    ∎
  }
  where
    module A = Endo⇒ A
    module B = Endo⇒ B
    module C = Endo⇒ C
    open SetoidReasoning (natSetoid {F = A.T ∘ F} {G ∘ C.T})
    φ : A.T ⇒ B.T
    φ = UpTo⇒.γ f
    γ : B.T ⇒ C.T
    γ = UpTo⇒.γ g

-- | Category of morphisms between endofunctors, where the morphisms
-- are certain natural transformations (see UpTo⇒).
-- This category will be the the setting in which we can talk about
-- properties of up-to techniques.
EndoMor : Σ Cat₀ (λ C → Functor C C) →
          Σ Cat₀ (λ C → Functor C C) →
          Cat₀
EndoMor (C₁ , F) (C₂ , G) =
  record
  { Obj = Endo⇒ C₁ F C₂ G
  ; _⇒_ = UpTo⇒
  ; _≡_ = _≡U_
  ; id = id-UpTo⇒
  ; _∘_ = _•_
  ; assoc = λ {_} {_} {_} {_} {f} {g} {h} →
          record { ≡U-proof = assoc₁ {X = UpTo⇒.γ f} {UpTo⇒.γ g} {UpTo⇒.γ h} }
  ; identityˡ = λ {_} {_} {f} →
              record { ≡U-proof = identity₁ˡ {X = UpTo⇒.γ f} }
  ; identityʳ = λ {_} {_} {f} →
              record { ≡U-proof = identity₁ʳ {X = UpTo⇒.γ f} }
  ; equiv = ≡U-equiv
  ; ∘-resp-≡ = λ {_} {_} {_} {f} {h} {g} {i} f≡h g≡i → record {
             ≡U-proof = ∘₁-resp-≡ {f = UpTo⇒.γ f} {UpTo⇒.γ h}
                                  {UpTo⇒.γ g} {UpTo⇒.γ i}
                                  (≡U-proof f≡h) (≡U-proof g≡i) }
  }

-- | The 2-category of endofunctors, their morphisms and UpTo⇒ as 2-cells.
-- This is the 2-category of endofunctors defined by Lenisa, Power and Watanabe.
{-
Endo : 2-Category (suc zero) zero zero zero
Endo = record
         { Obj = Σ Cat₀ (λ C → Functor C C)
         ; _⇒_ = EndoMor
         ; id = record
                { F₀ = λ _ → record { T = id ; ρ = natId }
                ; F₁ = λ _ → id-UpTo⇒
                ; identity = IsEquivalence.refl ≡U-equiv
                ; homomorphism = λ {_} {_} {_} {_} {F} → {!!}
                ; F-resp-≡ = {!!}
                }
         ; —∘— = {!!}
         ; assoc = {!!}
         ; identityˡ = {!!}
         ; identityʳ = {!!}
         }
-}


------------------------------------------------------------------------
-- INCREMENTAL λ-CALCULUS
--
-- Connecting Parametric.Change.Term and Parametric.Change.Value.
------------------------------------------------------------------------

import Parametric.Syntax.Type as Type
import Parametric.Syntax.Term as Term
import Parametric.Denotation.Value as Value
import Parametric.Denotation.Evaluation as Evaluation
import Parametric.Change.Type as ChangeType
import Parametric.Change.Term as ChangeTerm
import Parametric.Change.Value as ChangeValue

module Parametric.Change.Evaluation
    {Base : Type.Structure}
    {Const : Term.Structure Base}
    (⟦_⟧Base : Value.Structure Base)
    (⟦_⟧Const : Evaluation.Structure Const ⟦_⟧Base)
    (ΔBase : ChangeType.Structure Base)
    (apply-base : ChangeTerm.ApplyStructure Const ΔBase)
    (diff-base : ChangeTerm.DiffStructure Const ΔBase)
    (nil-base : ChangeTerm.NilStructure Const ΔBase)
    (⟦apply-base⟧ : ChangeValue.ApplyStructure Const ⟦_⟧Base ΔBase)
    (⟦diff-base⟧ : ChangeValue.DiffStructure Const ⟦_⟧Base ΔBase)
    (⟦nil-base⟧ : ChangeValue.NilStructure Const ⟦_⟧Base ΔBase)
  where

open Type.Structure Base
open Term.Structure Base Const
open Value.Structure Base ⟦_⟧Base
open Evaluation.Structure Const ⟦_⟧Base ⟦_⟧Const
open ChangeType.Structure Base ΔBase
open ChangeTerm.Structure Const ΔBase apply-base diff-base nil-base
open ChangeValue.Structure Const ⟦_⟧Base ΔBase ⟦apply-base⟧ ⟦diff-base⟧ ⟦nil-base⟧

open import Relation.Binary.PropositionalEquality
open import Base.Denotation.Notation
open import Postulate.Extensionality

-- Extension point 1: Relating ⊕ and its value on base types
ApplyStructure : Set
ApplyStructure = ∀ ι {Γ} →
  {t : Term Γ (base ι)} {Δt : Term Γ (ΔType (base ι))} {ρ : ⟦ Γ ⟧} →
  ⟦ t ⟧ ρ ⟦⊕₍ base ι ₎⟧ ⟦ Δt ⟧ ρ ≡ ⟦ t ⊕₍ base ι ₎ Δt ⟧ ρ

-- Extension point 2: Relating ⊝ and its value on base types
DiffStructure : Set
DiffStructure = ∀ ι {Γ} →
  {s : Term Γ (base ι)} {t : Term Γ (base ι)} {ρ : ⟦ Γ ⟧} →
  ⟦ s ⟧ ρ ⟦⊝₍ base ι ₎⟧ ⟦ t ⟧ ρ ≡ ⟦ s ⊝₍ base ι ₎ t ⟧ ρ

-- Extension point 3: Relating nil-term and its value on base types
NilStructure : Set
NilStructure = ∀ ι {Γ} →
  {t : Term Γ (base ι)} {ρ : ⟦ Γ ⟧} →
  ⟦nil₍ base ι ₎⟧ (⟦ t ⟧ ρ) ≡ ⟦ onil₍ base ι ₎ t ⟧ ρ

module Structure
    (meaning-⊕-base    : ApplyStructure)
    (meaning-⊝-base    : DiffStructure)
    (meaning-onil-base : NilStructure)
  where

  -- unique names with unambiguous types
  -- to help type inference figure things out
  private
    module Disambiguation where
      infixr 9 _⋆_
      _⋆_ : Type → Context → Context
      _⋆_ = _•_

  -- We provide: Relating ⊕ and ⊝ and their values on arbitrary types.
  meaning-⊕ : ∀ {τ Γ}
    {t : Term Γ τ} {Δt : Term Γ (ΔType τ)} {ρ : ⟦ Γ ⟧} →
    ⟦ t ⟧ ρ ⟦⊕₍ τ ₎⟧ ⟦ Δt ⟧ ρ ≡ ⟦ t ⊕₍ τ ₎ Δt ⟧ ρ

  meaning-⊝ : ∀ {τ Γ}
    {s : Term Γ τ} {t : Term Γ τ} {ρ : ⟦ Γ ⟧} →
    ⟦ s ⟧ ρ ⟦⊝₍ τ ₎⟧ ⟦ t ⟧ ρ ≡ ⟦ s ⊝₍ τ ₎ t ⟧ ρ

  meaning-onil : ∀ {τ Γ}
    {t : Term Γ τ} {ρ : ⟦ Γ ⟧} →
    ⟦nil₍ τ ₎⟧ (⟦ t ⟧ ρ) ≡ ⟦ onil₍ τ ₎ t ⟧ ρ

  meaning-⊕ {base ι} {Γ} {τ} {Δt} {ρ} = meaning-⊕-base ι {Γ} {τ} {Δt} {ρ}
  meaning-⊕ {σ ⇒ τ} {Γ} {t} {Δt} {ρ} = ext (λ v →
    let
      Γ′ = σ ⋆ (σ ⇒ τ) ⋆ ΔType (σ ⇒ τ) ⋆ Γ
      ρ′ : ⟦ Γ′ ⟧
      ρ′ = v • (⟦ t ⟧ ρ) • (⟦ Δt ⟧ ρ) • ρ
      x  : Term Γ′ σ
      x  = var this
      f  : Term Γ′ (σ ⇒ τ)
      f  = var (that this)
      Δf : Term Γ′ (ΔType (σ ⇒ τ))
      Δf = var (that (that this))
      y  = app f x
      Δy = app (app Δf x) (onil x)
    in
      begin
        ⟦ t ⟧ ρ v ⟦⊕₍ τ ₎⟧ ⟦ Δt ⟧ ρ v (⟦nil₍ σ ₎⟧ v)
      ≡⟨ cong (λ hole → ⟦ t ⟧ ρ v ⟦⊕₍ τ ₎⟧ ⟦ Δt ⟧ ρ v hole)
           (meaning-onil {t = x} {ρ′}) ⟩
        ⟦ t ⟧ ρ v ⟦⊕₍ τ ₎⟧ ⟦ Δt ⟧ ρ v (⟦ onil x ⟧ ρ′)
      ≡⟨ meaning-⊕ {t = y} {Δt = Δy} {ρ′} ⟩
        ⟦ y ⊕₍ τ ₎ Δy ⟧ ρ′
      ∎)
    where
      open ≡-Reasoning
      open Disambiguation

  meaning-⊝ {base ι} {Γ} {s} {t} {ρ} = meaning-⊝-base ι {Γ} {s} {t} {ρ}
  meaning-⊝ {σ ⇒ τ} {Γ} {s} {t} {ρ} =
    ext (λ v → ext (λ Δv →
    let
      Γ′ = ΔType σ ⋆ σ ⋆ (σ ⇒ τ) ⋆ (σ ⇒ τ) ⋆ Γ
      ρ′ : ⟦ Γ′ ⟧Context
      ρ′ = Δv • v • ⟦ t ⟧Term ρ • ⟦ s ⟧Term ρ • ρ
      Δx : Term Γ′ (ΔType σ)
      Δx = var this
      x  : Term Γ′ σ
      x  = var (that this)
      f  : Term Γ′ (σ ⇒ τ)
      f  = var (that (that this))
      g  : Term Γ′ (σ ⇒ τ)
      g  = var (that (that (that this)))
      y  = app f x
      y′ = app g (x ⊕₍ σ ₎ Δx)
    in
      begin
        ⟦ s ⟧ ρ (v ⟦⊕₍ σ ₎⟧ Δv) ⟦⊝₍ τ ₎⟧ ⟦ t ⟧ ρ v
      ≡⟨ cong (λ hole → ⟦ s ⟧ ρ hole ⟦⊝₍ τ ₎⟧ ⟦ t ⟧ ρ v)
           (meaning-⊕ {t = x} {Δt = Δx} {ρ′}) ⟩
        ⟦ s ⟧ ρ (⟦ x ⊕₍ σ ₎ Δx ⟧ ρ′) ⟦⊝₍ τ ₎⟧ ⟦ t ⟧ ρ v
      ≡⟨ meaning-⊝ {s = y′} {y} {ρ′} ⟩
        ⟦ y′ ⊝ y ⟧ ρ′
      ∎))
    where
      open ≡-Reasoning
      open Disambiguation

  meaning-onil {base ι} {Γ} {t} {ρ} = meaning-onil-base ι {Γ} {t} {ρ}
  meaning-onil {σ ⇒ τ} {Γ} {t} {ρ} = meaning-⊝ {σ ⇒ τ} {Γ} {t} {t} {ρ}
  -- Ideally, this proof should simply be:
  -- meaning-⊝ {σ ⇒ τ} {Γ} {t} {t} {ρ}
  --
  -- However, the types of the results don't match because using onil constructs
  -- different environments.


open import Oscar.Prelude

module Oscar.Class.Injectivity where

module _ where

  module _ -- Arity=1
    {𝔬₁} {𝔒₁ : Ø 𝔬₁}
    {𝔬₂} (𝔒₂ : 𝔒₁ → Ø 𝔬₂)
    where
    𝓲njection₁ = (x : 𝔒₁) → 𝔒₂ x
    record 𝓘njection₁ : Ø 𝔬₁ ∙̂ 𝔬₂ where field injection₁ : 𝓲njection₁
    open 𝓘njection₁ ⦃ … ⦄ public
    module _
      {ℓ₂} (_∼₂_ : ∀ {x₁ x₂} → 𝔒₂ x₁ → 𝔒₂ x₂ → Ø ℓ₂)
      {ℓ₁} (_∼₁_ : 𝔒₁ → 𝔒₁ → Ø ℓ₁)
      where
      record [𝓘njectivity₁] : Ø₀ where
        no-eta-equality
        constructor ∁
      module _
        ⦃ _ : 𝓘njection₁ ⦄
        where
        𝓲njectivity₁ = ∀ {x₁ x₂} → injection₁ x₁ ∼₂ injection₁ x₂ → x₁ ∼₁ x₂
        record 𝓘njectivity₁ ⦃ _ : [𝓘njectivity₁] ⦄ : Ø 𝔬₁ ∙̂ 𝔬₂ ∙̂ ℓ₁ ∙̂ ℓ₂ where field injectivity₁ : 𝓲njectivity₁
        open 𝓘njectivity₁ ⦃ … ⦄ public

  injectivity₁[_] : ∀
    {𝔬₁} {𝔒₁ : Ø 𝔬₁}
    {𝔬₂} {𝔒₂ : 𝔒₁ → Ø 𝔬₂}
    {ℓ₂} {_∼₂_ : ∀ {x₁ x₂} → 𝔒₂ x₁ → 𝔒₂ x₂ → Ø ℓ₂}
    {ℓ₁} (_∼₁_ : 𝔒₁ → 𝔒₁ → Ø ℓ₁)
    ⦃ _ : 𝓘njection₁ (λ (x : 𝔒₁) → 𝔒₂ x) ⦄
    ⦃ _ : [𝓘njectivity₁] (λ (x : 𝔒₁) → 𝔒₂ x) _∼₂_ _∼₁_ ⦄
    ⦃ _ : 𝓘njectivity₁ (λ (x : 𝔒₁) → 𝔒₂ x) _∼₂_ _∼₁_ ⦄
    → 𝓲njectivity₁ (λ (x : 𝔒₁) → 𝔒₂ x) _∼₂_ _∼₁_
  injectivity₁[ _ ] = injectivity₁

  module _ -- Arity=2
    {𝔬₁} {𝔒₁ : Ø 𝔬₁}
    {𝔬₂} {𝔒₂ : 𝔒₁ → Ø 𝔬₂}
    {𝔬₃} (𝔒₃ : ∀ x₁ → 𝔒₂ x₁ → Ø 𝔬₃)
    where
    𝓲njection₂ = ∀ x₁ → (x₂ : 𝔒₂ x₁) → 𝔒₃ _ x₂
    record 𝓘njection₂ : Ø 𝔬₁ ∙̂ 𝔬₂ ∙̂ 𝔬₃ where
      constructor ∁
      field injection₂ : 𝓲njection₂
    open 𝓘njection₂ ⦃ … ⦄ public
    module _ -- Fixed=0
      {ℓ₃} (_∼₃_ : ∀ {x₁ x₂} {y₁ : 𝔒₂ x₁} {y₂ : 𝔒₂ x₂} → 𝔒₃ _ y₁ → 𝔒₃ _ y₂ → Ø ℓ₃)
      where
      module _ -- Var=1
        {ℓ₁} (_∼₁_ : 𝔒₁ → 𝔒₁ → Ø ℓ₁)
        where
        record [𝓘njectivity₂,₀,₁] : Ø₀ where
          no-eta-equality
          constructor ∁
        module _
          ⦃ _ : 𝓘njection₂ ⦄
          where
          𝓲njectivity₂,₀,₁ = ∀ {x₁ x₂} {y₁ : 𝔒₂ x₁} {y₂ : 𝔒₂ x₂} → injection₂ _ y₁ ∼₃ injection₂ _ y₂ → x₁ ∼₁ x₂
          record 𝓘njectivity₂,₀,₁ ⦃ _ : [𝓘njectivity₂,₀,₁] ⦄ : Ø 𝔬₁ ∙̂ 𝔬₂ ∙̂ 𝔬₃ ∙̂ ℓ₁ ∙̂ ℓ₃ where field injectivity₂,₀,₁ : 𝓲njectivity₂,₀,₁
          open 𝓘njectivity₂,₀,₁ ⦃ … ⦄ public
      module _ -- Var=2
        {ℓ₂} (_∼₂_ : ∀ {x₁ x₂} → 𝔒₂ x₁ → 𝔒₂ x₂ → Ø ℓ₂)
        where
        record [𝓘njectivity₂,₀,₂] : Ø₀ where
          no-eta-equality
          constructor ∁
        module _
          ⦃ _ : 𝓘njection₂ ⦄
          where
          𝓲njectivity₂,₀,₂ = ∀ {x₁ x₂ : 𝔒₁} {y₁ : 𝔒₂ x₁} {y₂ : 𝔒₂ x₂} → injection₂ _ y₁ ∼₃ injection₂ _ y₂ → y₁ ∼₂ y₂
          record 𝓘njectivity₂,₀,₂ ⦃ _ : [𝓘njectivity₂,₀,₂] ⦄ : Ø 𝔬₁ ∙̂ 𝔬₂ ∙̂ 𝔬₃ ∙̂ ℓ₂ ∙̂ ℓ₃ where field injectivity₂,₀,₂ : 𝓲njectivity₂,₀,₂
          open 𝓘njectivity₂,₀,₂ ⦃ … ⦄ public
    module _ -- Fixed=1
      {ℓ₃} (_∼₃_ : ∀ {x} {y₁ y₂ : 𝔒₂ x} → 𝔒₃ _ y₁ → 𝔒₃ _ y₂ → Ø ℓ₃)
      {ℓ₂} (_∼₂_ : ∀ {x} → 𝔒₂ x → 𝔒₂ x → Ø ℓ₂)
      where
      record [𝓘njectivity₂,₁] : Ø₀ where
        no-eta-equality
        constructor ∁
      module _
        ⦃ _ : 𝓘njection₂ ⦄
        where
        𝓲njectivity₂,₁ = ∀ (x : 𝔒₁) {y₁ y₂ : 𝔒₂ x} → injection₂ _ y₁ ∼₃ injection₂ _ y₂ → y₁ ∼₂ y₂
        record 𝓘njectivity₂,₁ ⦃ _ : [𝓘njectivity₂,₁] ⦄ : Ø 𝔬₁ ∙̂ 𝔬₂ ∙̂ 𝔬₃ ∙̂ ℓ₂ ∙̂ ℓ₃ where field injectivity₂,₁ : 𝓲njectivity₂,₁
        open 𝓘njectivity₂,₁ ⦃ … ⦄ public

  injectivity₂,₀,₁[_] : ∀
    {𝔬₁} {𝔒₁ : Ø 𝔬₁}
    {𝔬₂} {𝔒₂ : 𝔒₁ → Ø 𝔬₂}
    {𝔬₃} {𝔒₃ : ∀ x₁ → 𝔒₂ x₁ → Ø 𝔬₃}
    {ℓ₃} {_∼₃_ : ∀ {x₁ x₂} {y₁ : 𝔒₂ x₁} {y₂ : 𝔒₂ x₂} → 𝔒₃ _ y₁ → 𝔒₃ _ y₂ → Ø ℓ₃}
    {ℓ₁} (_∼₁_ : 𝔒₁ → 𝔒₁ → Ø ℓ₁)
    ⦃ _ : 𝓘njection₂ 𝔒₃ ⦄
    ⦃ _ : [𝓘njectivity₂,₀,₁] 𝔒₃ _∼₃_ _∼₁_ ⦄
    ⦃ _ : 𝓘njectivity₂,₀,₁ 𝔒₃ _∼₃_ _∼₁_ ⦄
    → 𝓲njectivity₂,₀,₁ 𝔒₃ _∼₃_ _∼₁_
  injectivity₂,₀,₁[ _ ] = injectivity₂,₀,₁

  injectivity₂,₀,₂[_] : ∀
    {𝔬₁} {𝔒₁ : Ø 𝔬₁}
    {𝔬₂} {𝔒₂ : 𝔒₁ → Ø 𝔬₂}
    {𝔬₃} {𝔒₃ : ∀ x₁ → 𝔒₂ x₁ → Ø 𝔬₃}
    {ℓ₃} {_∼₃_ : ∀ {x₁ x₂} {y₁ : 𝔒₂ x₁} {y₂ : 𝔒₂ x₂} → 𝔒₃ _ y₁ → 𝔒₃ _ y₂ → Ø ℓ₃}
    {ℓ₂} (_∼₂_ : ∀ {x₁ x₂} → 𝔒₂ x₁ → 𝔒₂ x₂ → Ø ℓ₂)
    ⦃ _ : 𝓘njection₂ 𝔒₃ ⦄
    ⦃ _ : [𝓘njectivity₂,₀,₂] 𝔒₃ _∼₃_ _∼₂_ ⦄
    ⦃ _ : 𝓘njectivity₂,₀,₂ 𝔒₃ _∼₃_ _∼₂_ ⦄
    → 𝓲njectivity₂,₀,₂ 𝔒₃ _∼₃_ _∼₂_
  injectivity₂,₀,₂[ _ ] = injectivity₂,₀,₂

  injectivity₂,₁[_] : ∀
    {𝔬₁} {𝔒₁ : Ø 𝔬₁}
    {𝔬₂} {𝔒₂ : 𝔒₁ → Ø 𝔬₂}
    {𝔬₃} {𝔒₃ : ∀ x₁ → 𝔒₂ x₁ → Ø 𝔬₃}
    {ℓ₃} {_∼₃_ : ∀ {x} {y₁ y₂ : 𝔒₂ x} → 𝔒₃ _ y₁ → 𝔒₃ _ y₂ → Ø ℓ₃}
    {ℓ₂} (_∼₂_ : ∀ {x} → 𝔒₂ x → 𝔒₂ x → Ø ℓ₂)
    ⦃ _ : [𝓘njectivity₂,₁] 𝔒₃ _∼₃_ _∼₂_ ⦄
    ⦃ _ : 𝓘njection₂ 𝔒₃ ⦄
    ⦃ _ : 𝓘njectivity₂,₁ 𝔒₃ _∼₃_ _∼₂_ ⦄
    → 𝓲njectivity₂,₁ 𝔒₃ _∼₃_ _∼₂_
  injectivity₂,₁[ _ ] = injectivity₂,₁

  module _ -- Arity=3
    {𝔬₁} {𝔒₁ : Ø 𝔬₁}
    {𝔬₂} {𝔒₂ : 𝔒₁ → Ø 𝔬₂}
    {𝔬₃} {𝔒₃ : ∀ x₁ → 𝔒₂ x₁ → Ø 𝔬₃}
    {𝔬₄} (𝔒₄ : ∀ x₁ → (x₂ : 𝔒₂ x₁) → 𝔒₃ _ x₂ → Ø 𝔬₄)
    where
    𝓲njection₃ = ∀ x₁ → (x₂ : 𝔒₂ x₁) → (x₃ : 𝔒₃ _ x₂) → 𝔒₄ _ _ x₃
    record 𝓘njection₃ : Ø 𝔬₁ ∙̂ 𝔬₂ ∙̂ 𝔬₃ ∙̂ 𝔬₄ where
      constructor ∁
      field injection₃ : 𝓲njection₃
    open 𝓘njection₃ ⦃ … ⦄ public
    module _ -- Fixed=0
      {ℓ₄} (_∼₄_ : ∀ {x₁ x₂} {y₁ : 𝔒₂ x₁} {y₂ : 𝔒₂ x₂} {z₁ : 𝔒₃ _ y₁} {z₂ : 𝔒₃ _ y₂} → 𝔒₄ _ _ z₁ → 𝔒₄ _ _ z₂ → Ø ℓ₄)
      where
      module _ -- Var=1
        {ℓ₁} (_∼₁_ : 𝔒₁ → 𝔒₁ → Ø ℓ₁)
        where
        record [𝓘njectivity₃,₀,₁] : Ø₀ where
          no-eta-equality
          constructor ∁
        module _
          ⦃ _ : 𝓘njection₃ ⦄
          where
          𝓲njectivity₃,₀,₁ = ∀ {x₁ x₂} {y₁ : 𝔒₂ x₁} {y₂ : 𝔒₂ x₂} {z₁ : 𝔒₃ _ y₁} {z₂ : 𝔒₃ _ y₂} → injection₃ _ _ z₁ ∼₄ injection₃ _ _ z₂ → x₁ ∼₁ x₂
          record 𝓘njectivity₃,₀,₁ ⦃ _ : [𝓘njectivity₃,₀,₁] ⦄ : Ø 𝔬₁ ∙̂ 𝔬₂ ∙̂ 𝔬₃ ∙̂ 𝔬₄ ∙̂ ℓ₁ ∙̂ ℓ₄ where field injectivity₃,₀,₁ : 𝓲njectivity₃,₀,₁
          open 𝓘njectivity₃,₀,₁ ⦃ … ⦄ public
      module _ -- Var=2
        {ℓ₂} (_∼₂_ : ∀ {x₁ x₂} → 𝔒₂ x₁ → 𝔒₂ x₂ → Ø ℓ₂)
        where
        record [𝓘njectivity₃,₀,₂] : Ø₀ where
          no-eta-equality
          constructor ∁
        module _
          ⦃ _ : 𝓘njection₃ ⦄
          where
          𝓲njectivity₃,₀,₂ = ∀ {x₁ x₂ : 𝔒₁} {y₁ : 𝔒₂ x₁} {y₂ : 𝔒₂ x₂} {z₁ : 𝔒₃ _ y₁} {z₂ : 𝔒₃ _ y₂} → injection₃ _ _ z₁ ∼₄ injection₃ _ _ z₂ → y₁ ∼₂ y₂
          record 𝓘njectivity₃,₀,₂ ⦃ _ : [𝓘njectivity₃,₀,₂] ⦄ : Ø 𝔬₁ ∙̂ 𝔬₂ ∙̂ 𝔬₃ ∙̂ ℓ₂ ∙̂ ℓ₄ where field injectivity₃,₀,₂ : 𝓲njectivity₃,₀,₂
          open 𝓘njectivity₃,₀,₂ ⦃ … ⦄ public

  injectivity₃,₀,₁[_] : ∀
    {𝔬₁} {𝔒₁ : Ø 𝔬₁}
    {𝔬₂} {𝔒₂ : 𝔒₁ → Ø 𝔬₂}
    {𝔬₃} {𝔒₃ : ∀ x₁ → 𝔒₂ x₁ → Ø 𝔬₃}
    {𝔬₄} {𝔒₄ : ∀ x₁ → (x₂ : 𝔒₂ x₁) → 𝔒₃ _ x₂ → Ø 𝔬₄}
    {ℓ₄} {_∼₄_ : ∀ {x₁ x₂} {y₁ : 𝔒₂ x₁} {y₂ : 𝔒₂ x₂} {z₁ : 𝔒₃ _ y₁} {z₂ : 𝔒₃ _ y₂} → 𝔒₄ _ _ z₁ → 𝔒₄ _ _ z₂ → Ø ℓ₄}
    {ℓ₁} (_∼₁_ : 𝔒₁ → 𝔒₁ → Ø ℓ₁)
    ⦃ _ : [𝓘njectivity₃,₀,₁] 𝔒₄ _∼₄_ _∼₁_ ⦄
    ⦃ _ : 𝓘njection₃ 𝔒₄ ⦄
    ⦃ _ : 𝓘njectivity₃,₀,₁ 𝔒₄ _∼₄_ _∼₁_ ⦄
    → 𝓲njectivity₃,₀,₁ 𝔒₄ _∼₄_ _∼₁_
  injectivity₃,₀,₁[ _ ] = injectivity₃,₀,₁

  injectivity₃,₀,₂[_] : ∀
    {𝔬₁} {𝔒₁ : Ø 𝔬₁}
    {𝔬₂} {𝔒₂ : 𝔒₁ → Ø 𝔬₂}
    {𝔬₃} {𝔒₃ : ∀ x₁ → 𝔒₂ x₁ → Ø 𝔬₃}
    {𝔬₄} {𝔒₄ : ∀ x₁ → (x₂ : 𝔒₂ x₁) → 𝔒₃ _ x₂ → Ø 𝔬₄}
    {ℓ₄} {_∼₄_ : ∀ {x₁ x₂} {y₁ : 𝔒₂ x₁} {y₂ : 𝔒₂ x₂} {z₁ : 𝔒₃ _ y₁} {z₂ : 𝔒₃ _ y₂} → 𝔒₄ _ _ z₁ → 𝔒₄ _ _ z₂ → Ø ℓ₄}
    {ℓ₂} (_∼₂_ : ∀ {x₁ x₂} → 𝔒₂ x₁ → 𝔒₂ x₂ → Ø ℓ₂)
    ⦃ _ : [𝓘njectivity₃,₀,₂] 𝔒₄ _∼₄_ _∼₂_ ⦄
    ⦃ _ : 𝓘njection₃ 𝔒₄ ⦄
    ⦃ _ : 𝓘njectivity₃,₀,₂ 𝔒₄ _∼₄_ _∼₂_ ⦄
    → 𝓲njectivity₃,₀,₂ 𝔒₄ _∼₄_ _∼₂_
  injectivity₃,₀,₂[ _ ] = injectivity₃,₀,₂


data ⊥ : Set where

data Maybe : Set where
  just : ⊥ → Maybe
  nothing : Maybe

test : Set → Set
test x with nothing
test x | just ()
test x | nothing = test x


open import Oscar.Prelude
open import Oscar.Class
open import Oscar.Class.SimilaritySingleton
open import Oscar.Class.SimilarityM

module Oscar.Class.Similarity where

module Similarity
  {𝔞} {𝔄 : Ø 𝔞}
  {𝔟} {𝔅 : Ø 𝔟}
  {𝔣} {𝔉 : Ø 𝔣}
  {𝔞̇ 𝔟̇}
  (_∼₁_ : 𝔄 → 𝔄 → Ø 𝔞̇)
  (_∼₂_ : 𝔅 → 𝔅 → Ø 𝔟̇) (let _∼₂_ = _∼₂_; infix 4 _∼₂_)
  (_◃_ : 𝔉 → 𝔄 → 𝔅) (let _◃_ = _◃_; infix 16 _◃_)
  = ℭLASS (_◃_ , _∼₂_) (∀ {x y} f → x ∼₁ y → f ◃ x ∼₂ f ◃ y)

module _
  {𝔞} {𝔄 : Ø 𝔞}
  {𝔟} {𝔅 : Ø 𝔟}
  {𝔣} {𝔉 : Ø 𝔣}
  {𝔞̇ 𝔟̇}
  {_∼₁_ : 𝔄 → 𝔄 → Ø 𝔞̇}
  {_∼₂_ : 𝔅 → 𝔅 → Ø 𝔟̇}
  {_◃_ : 𝔉 → 𝔄 → 𝔅}
  where
  similarity = Similarity.method _∼₁_ _∼₂_ _◃_
  module _ ⦃ _ : Similarity.class _∼₁_ _∼₂_ _◃_ ⦄ where
    instance
      toSimilaritySingleton : ∀ {x y f} → SimilaritySingleton.class (x ∼₁ y) _∼₂_ _◃_ x y f
      toSimilaritySingleton .⋆ = similarity _
      toSimilarityM : ∀ {x y} → SimilarityM.class _∼₁_ _∼₂_ _◃_ x y
      toSimilarityM .⋆ = similarity

open import Oscar.Class.Smap
open import Oscar.Class.Surjection

module Similarity,cosmaparrow
  {𝔵₁} {𝔛₁ : Ø 𝔵₁}
  {𝔵₂} {𝔛₂ : Ø 𝔵₂}
  (surjection : Surjection.type 𝔛₁ 𝔛₂)
  {𝔯} (ℜ : 𝔛₁ → 𝔛₁ → Ø 𝔯)
  {𝔭₁} (𝔓₁ : 𝔛₂ → Ø 𝔭₁)
  {𝔭₂} (𝔓₂ : 𝔛₂ → Ø 𝔭₂)
  (smaparrow : Smaparrow.type ℜ 𝔓₁ 𝔓₂ surjection surjection)
  {𝔯̇} (ℜ̇ : ∀ {x y} → ℜ x y → ℜ x y → Ø 𝔯̇)
  {𝔭̇₂} (𝔓̇₂ : ∀ {x} → 𝔓₂ x → 𝔓₂ x → Ø 𝔭̇₂)
  where
  class = ∀ {m n} → Similarity.class (ℜ̇ {m} {n}) (𝔓̇₂ {surjection n}) (flip smaparrow)
  type = ∀ {m n} → Similarity.type (ℜ̇ {m} {n}) (𝔓̇₂ {surjection n}) (flip smaparrow)

module Similarity,cosmaparrow!
  {𝔵₁} {𝔛₁ : Ø 𝔵₁}
  {𝔵₂} {𝔛₂ : Ø 𝔵₂}
  ⦃ _ : Surjection.class 𝔛₁ 𝔛₂ ⦄
  {𝔯} (ℜ : 𝔛₁ → 𝔛₁ → Ø 𝔯)
  {𝔭₁} (𝔓₁ : 𝔛₂ → Ø 𝔭₁)
  {𝔭₂} (𝔓₂ : 𝔛₂ → Ø 𝔭₂)
  ⦃ _ : Smaparrow!.class ℜ 𝔓₁ 𝔓₂ ⦄
  {𝔯̇} (ℜ̇ : ∀ {x y} → ℜ x y → ℜ x y → Ø 𝔯̇)
  {𝔭̇₂} (𝔓̇₂ : ∀ {x} → 𝔓₂ x → 𝔓₂ x → Ø 𝔭̇₂)
  = Similarity,cosmaparrow surjection ℜ 𝔓₁ 𝔓₂ smaparrow ℜ̇ 𝔓̇₂

module Similarity,cosmaphomarrow
  {𝔵₁} {𝔛₁ : Ø 𝔵₁}
  {𝔵₂} {𝔛₂ : Ø 𝔵₂}
  (surjection : Surjection.type 𝔛₁ 𝔛₂)
  {𝔯} (ℜ : 𝔛₁ → 𝔛₁ → Ø 𝔯)
  {𝔭} (𝔓 : 𝔛₂ → Ø 𝔭)
  (smaparrow : Smaphomarrow.type ℜ 𝔓 surjection)
  {𝔯̇} (ℜ̇ : ∀ {x y} → ℜ x y → ℜ x y → Ø 𝔯̇)
  {𝔭̇} (𝔓̇ : ∀ {x} → 𝔓 x → 𝔓 x → Ø 𝔭̇)
  = Similarity,cosmaparrow surjection ℜ 𝔓 𝔓 smaparrow ℜ̇ 𝔓̇

module Similarity,cosmaphomarrow!
  {𝔵₁} {𝔛₁ : Ø 𝔵₁}
  {𝔵₂} {𝔛₂ : Ø 𝔵₂}
  ⦃ _ : Surjection.class 𝔛₁ 𝔛₂ ⦄
  {𝔯} (ℜ : 𝔛₁ → 𝔛₁ → Ø 𝔯)
  {𝔭} (𝔓 : 𝔛₂ → Ø 𝔭)
  ⦃ _ : Smaphomarrow!.class ℜ 𝔓 ⦄
  {𝔯̇} (ℜ̇ : ∀ {x y} → ℜ x y → ℜ x y → Ø 𝔯̇)
  {𝔭̇} (𝔓̇ : ∀ {x} → 𝔓 x → 𝔓 x → Ø 𝔭̇)
  = Similarity,cosmaphomarrow surjection ℜ 𝔓 smaparrow ℜ̇ 𝔓̇

module Similarity,smaparrow
  {𝔵₁} {𝔛₁ : Ø 𝔵₁}
  {𝔵₂} {𝔛₂ : Ø 𝔵₂}
  (surjection : Surjection.type 𝔛₁ 𝔛₂)
  {𝔯} (ℜ : π̂² 𝔯 𝔛₁)
  {𝔭₁} (𝔓₁ : π̂ 𝔭₁ 𝔛₂)
  {𝔭₂} (𝔓₂ : π̂ 𝔭₂ 𝔛₂)
  (smaparrow : Smaparrow.type ℜ 𝔓₁ 𝔓₂ surjection surjection)
  {𝔭̇₁} (𝔓̇₁ : ∀̇ π̂² 𝔭̇₁ (𝔓₁ ∘ surjection))
  {𝔭̇₂} (𝔓̇₂ : ∀̇ π̂² 𝔭̇₂ (𝔓₂ ∘ surjection))
  where
  class = ∀ {m n} → Similarity.class (𝔓̇₁ {m}) (𝔓̇₂ {n}) smaparrow
  type = ∀ {m n} → Similarity.type (𝔓̇₁ {m}) (𝔓̇₂ {n}) smaparrow

module Similarity,smaparrow!
  {𝔵₁} {𝔛₁ : Ø 𝔵₁}
  {𝔵₂} {𝔛₂ : Ø 𝔵₂}
  ⦃ _ : Surjection.class 𝔛₁ 𝔛₂ ⦄
  {𝔯} (ℜ : π̂² 𝔯 𝔛₁)
  {𝔭₁} (𝔓₁ : π̂ 𝔭₁ 𝔛₂)
  {𝔭₂} (𝔓₂ : π̂ 𝔭₂ 𝔛₂)
  ⦃ _ : Smaparrow!.class ℜ 𝔓₁ 𝔓₂ ⦄
  {𝔭̇₁} (𝔓̇₁ : ∀̇ π̂² 𝔭̇₁ (𝔓₁ ∘ surjection))
  {𝔭̇₂} (𝔓̇₂ : ∀̇ π̂² 𝔭̇₂ (𝔓₂ ∘ surjection))
  = Similarity,smaparrow surjection ℜ 𝔓₁ 𝔓₂ smaparrow 𝔓̇₁ 𝔓̇₂

module Similarity,smaphomarrow
  {𝔵₁} {𝔛₁ : Ø 𝔵₁}
  {𝔵₂} {𝔛₂ : Ø 𝔵₂}
  (surjection : Surjection.type 𝔛₁ 𝔛₂)
  {𝔯} (ℜ : π̂² 𝔯 𝔛₁)
  {𝔭} (𝔓 : π̂ 𝔭 𝔛₂)
  (smaparrow : Smaphomarrow.type ℜ 𝔓 surjection)
  {𝔭̇} (𝔓̇ : ∀̇ π̂² 𝔭̇ (𝔓 ∘ surjection))
  = Similarity,smaparrow surjection ℜ 𝔓 𝔓 smaparrow 𝔓̇ 𝔓̇

module Similarity,smaphomarrow!
  {𝔵₁} {𝔛₁ : Ø 𝔵₁}
  {𝔵₂} {𝔛₂ : Ø 𝔵₂}
  ⦃ _ : Surjection.class 𝔛₁ 𝔛₂ ⦄
  {𝔯} (ℜ : π̂² 𝔯 𝔛₁)
  {𝔭} (𝔓 : π̂ 𝔭 𝔛₂)
  ⦃ _ : Smaphomarrow!.class ℜ 𝔓 ⦄
  {𝔭̇} (𝔓̇ : ∀̇ π̂² 𝔭̇ (𝔓 ∘ surjection))
  = Similarity,smaphomarrow surjection ℜ 𝔓 smaparrow 𝔓̇


{-# FOREIGN GHC import qualified Issue223 #-}

data A : Set
data B : Set

data A where
  BA : B → A

data B where
  AB : A → B
  BB : B

{-# COMPILE GHC A = data Issue223.A (Issue223.BA) #-}
{-# COMPILE GHC B = data Issue223.B (Issue223.AB | Issue223.BB) #-}


-- Andreas, 2016-07-26, issue 2215, reported by effectfully

data Term : Set where
  abs : Term → Term

Type = Term

f : Type → Term
f (abs b@(abs _)) = b

-- WAS: Panic: Pattern match failure in AsPatterns.conPattern
-- due to a missing reduce

-- Should work.


module RW.Data.RTrie where

  open import RW.Data.RTrie.Decl public
  open import RW.Data.RTrie.Insert
    using (insertTerm) public
  open import RW.Data.RTrie.Lookup
    renaming (lookup to lookupTerm) public


-- Currently primitive functions are not allowed in mutual blocks.
-- This might change.
module PrimitiveInMutual where

postulate String : Set
{-# BUILTIN STRING String #-}

mutual
  primitive primStringAppend : String -> String -> String

  _++_ : String -> String -> String
  x ++ y = primStringAppend x y


module Thesis.Contexts where

open import Thesis.Types

-- Instantiate generic Context support
open import Base.Syntax.Context Type public


------------------------------------------------------------------------------
-- Streams properties
------------------------------------------------------------------------------

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

module FOTC.Data.Stream.PropertiesI where

open import FOTC.Base
open import FOTC.Base.List
open import FOTC.Base.List.PropertiesI
open import FOTC.Data.Conat
open import FOTC.Data.Conat.Equality.Type
open import FOTC.Data.Colist
open import FOTC.Data.Colist.PropertiesI
open import FOTC.Data.List
open import FOTC.Data.List.PropertiesI
open import FOTC.Data.Stream

-----------------------------------------------------------------------------
-- Because a greatest post-fixed point is a fixed-point, then the
-- Stream predicate is also a pre-fixed point of the functional
-- StreamF, i.e.
--
-- StreamF Stream ≤ Stream (see FOTC.Data.Stream.Type).
Stream-in : ∀ {xs} →
            ∃[ x' ] ∃[ xs' ] xs ≡ x' ∷ xs' ∧ Stream xs' →
            Stream xs
Stream-in h = Stream-coind A h' h
  where
  A : D → Set
  A xs = ∃[ x' ] ∃[ xs' ] xs ≡ x' ∷ xs' ∧ Stream xs'

  h' : ∀ {xs} → A xs → ∃[ x' ] ∃[ xs' ] xs ≡ x' ∷ xs' ∧ A xs'
  h' (x' , xs' , prf , Sxs') = x' , xs' , prf , Stream-out Sxs'

zeros-Stream : Stream zeros
zeros-Stream = Stream-coind A h refl
  where
  A : D → Set
  A xs = xs ≡ zeros

  h : ∀ {xs} → A xs → ∃[ x' ] ∃[ xs' ] xs ≡ x' ∷ xs' ∧ A xs'
  h Axs = zero , zeros , trans Axs zeros-eq , refl

ones-Stream : Stream ones
ones-Stream = Stream-coind A h refl
  where
  A : D → Set
  A xs = xs ≡ ones

  h : ∀ {xs} → A xs → ∃[ x' ] ∃[ xs' ] xs ≡ x' ∷ xs' ∧ A xs'
  h Axs = succ₁ zero , ones , trans Axs ones-eq , refl

∷-Stream : ∀ {x xs} → Stream (x ∷ xs) → Stream xs
∷-Stream {x} {xs} h = ∷-Stream-helper (Stream-out h)
  where
  ∷-Stream-helper : ∃[ x' ] ∃[ xs' ] x ∷ xs ≡ x' ∷ xs' ∧ Stream xs' →
                    Stream xs
  ∷-Stream-helper (x' , xs' , prf , Sxs') =
    subst Stream (sym (∧-proj₂ (∷-injective prf))) Sxs'

-- Version using Agda with constructor.
∷-Stream' : ∀ {x xs} → Stream (x ∷ xs) → Stream xs
∷-Stream' h with Stream-out h
... | x' , xs' , prf , Sxs' =
  subst Stream (sym (∧-proj₂ (∷-injective prf))) Sxs'

Stream→Colist : ∀ {xs} → Stream xs → Colist xs
Stream→Colist {xs} Sxs = Colist-coind A h₁ h₂
  where
  A : D → Set
  A ys = Stream ys

  h₁ : ∀ {xs} → A xs → xs ≡ [] ∨ (∃[ x' ] ∃[ xs' ] xs ≡ x' ∷ xs' ∧ A xs')
  h₁ Axs with Stream-out Axs
  ... | x' , xs' , prf , Sxs' = inj₂ (x' , xs' , prf , Sxs')

  h₂ : A xs
  h₂ = Sxs

-- Adapted from (Sander 1992, p. 59).
streamLength : ∀ {xs} → Stream xs → length xs ≈ ∞
streamLength {xs} Sxs = ≈-coind R h₁ h₂
  where
  R : D → D → Set
  R m n = ∃[ xs ] Stream xs ∧ m ≡ length xs ∧ n ≡ ∞

  h₁ : ∀ {m n} → R m n →
       m ≡ zero ∧ n ≡ zero
         ∨ (∃[ m' ] ∃[ n' ] m ≡ succ₁ m' ∧ n ≡ succ₁ n' ∧ R m' n')
  h₁ {m} {n} (xs , Sxs , m=lxs , n≡∞) = helper₁ (Stream-out Sxs)
    where
    helper₁ : (∃[ x' ] ∃[ xs' ] xs ≡ x' ∷ xs' ∧ Stream xs') →
              m ≡ zero ∧ n ≡ zero
                ∨ (∃[ m' ] ∃[ n' ] m ≡ succ₁ m' ∧ n ≡ succ₁ n' ∧ R m' n')
    helper₁ (x' , xs' , xs≡x'∷xs' , Sxs') =
      inj₂ (length xs'
           , ∞
           , helper₂
           , trans n≡∞ ∞-eq
           , (xs' , Sxs' , refl , refl))
        where
        helper₂ : m ≡ succ₁ (length xs')
        helper₂ = trans m=lxs (trans (lengthCong xs≡x'∷xs') (length-∷ x' xs'))

  h₂ : R (length xs) ∞
  h₂ = xs , Sxs , refl , refl

-- Adapted from (Sander 1992, p. 59). Version using Agda with
-- constructor.
streamLength' : ∀ {xs} → Stream xs → length xs ≈ ∞
streamLength' {xs} Sxs = ≈-coind R h₁ h₂
  where
  R : D → D → Set
  R m n = ∃[ xs ] Stream xs ∧ m ≡ length xs ∧ n ≡ ∞

  h₁ : ∀ {m n} → R m n →
       m ≡ zero ∧ n ≡ zero
         ∨ (∃[ m' ] ∃[ n' ] m ≡ succ₁ m' ∧ n ≡ succ₁ n' ∧ R m' n')
  h₁ {m} (xs , Sxs , m=lxs , n≡∞) with Stream-out Sxs
  ... | x' , xs' , xs≡x'∷xs' , Sxs' =
    inj₂ (length xs' , ∞ , helper , trans n≡∞ ∞-eq , (xs' , Sxs' , refl , refl))
    where
    helper : m ≡ succ₁ (length xs')
    helper = trans m=lxs (trans (lengthCong xs≡x'∷xs') (length-∷ x' xs'))

  h₂ : R (length xs) ∞
  h₂ = xs , Sxs , refl , refl

------------------------------------------------------------------------------
-- References
--
-- Sander, Herbert P. (1992). A Logic of Functional Programs with an
-- Application to Concurrency. PhD thesis. Department of Computer
-- Sciences: Chalmers University of Technology and University of
-- Gothenburg.


-- Interpretation of partial weakenings as partial finite maps.

module Dimension.PartialWeakening.Model (E : Set) where

import Level

open import Data.Nat using (ℕ; zero; suc; _+_)
open import Data.Fin using (Fin; zero; suc)
open import Relation.Binary.PropositionalEquality
open ≡-Reasoning

open import Axiom.FunctionExtensionality

open import Control.Category
open import Control.Category.Functor

open import Control.Kleisli
open import Control.Monad using (IsMonad; module IsMonad)
import Control.Monad.Error as Err
open module Error = Err E using (Error; fail; return; errorIsMonad)

-- open import Dimension.PartialWeakening E  -- horrible names
import Dimension.PartialWeakening as PW
open module PWeak = PW E

open IsMonad errorIsMonad hiding (return)
module Kl = IsCategory (kleisliIsCategory errorIsMonad)

-- Semantics given by application to a name in Fin n

apply : ∀ {n m} (f : PWeak n m) (i : Fin n) → Error (Fin m)
apply []       ()
apply (e ∷ f)  zero    = fail e
apply (e ∷ f)  (suc i) = apply f i
apply (lift f) zero    = return zero
apply (lift f) (suc i) = suc <$> apply f i
apply (weak f) i       = suc <$> apply f i

-- Soundness of id

abstract
  apply-id : ∀ n (i : Fin n) → apply id i ≡ return i
  apply-id 0       ()
  apply-id (suc n) zero    = refl
  apply-id (suc n) (suc i) with (apply id i) | (apply-id n i)
  apply-id (suc n) (suc i) | .(return i) | refl = refl

-- Lemma: one inductive step

abstract
  lift-lift-suc : ∀ {n m l} (f : PWeak n m) {g : PWeak m l} {i : Fin n} →

    (ih : apply (comp f g) i ≡ apply f i >>= apply g) →

    apply (comp (lift f) (lift g)) (suc i)  ≡
    apply (lift f) (suc i) >>= apply (lift g)

  lift-lift-suc f {g = g} {i = i} ih = begin

      apply (comp (lift f) (lift g)) (suc i)

    ≡⟨⟩                                      -- definition of comp

      apply (lift (comp f g)) (suc i)

    ≡⟨⟩                                      -- definition of apply

      suc <$> apply (comp f g) i

    ≡⟨ cong (_<$>_ suc) ih ⟩                 -- induction hypothesis

      suc <$> (apply f i >>= apply g)

    ≡⟨ map-after-bind (apply f i) ⟩          -- map commutes with bind I

      (apply f i >>= λ j → suc <$> apply g j)

    ≡⟨⟩                                      -- definition of apply

      (apply f i >>= λ j → apply (lift g) (suc j))

    ≡⟨ sym (bind-after-map (apply f i)) ⟩    -- map commutes with bind II

      (suc <$> apply f i) >>= apply (lift g)

    ≡⟨⟩                                      -- definition of apply

      apply (lift f) (suc i) >>= apply (lift g)
    ∎

-- Soundness of comp

abstract
  apply-comp : ∀ {n m l} (f : PWeak n m) (g : PWeak m l) (i : Fin n) →

   apply (comp f g) i ≡ apply f i >>= apply g

  apply-comp [] g ()
  apply-comp (e ∷ f) g zero = refl
  apply-comp (e ∷ f) g (suc i) = apply-comp f g i
  apply-comp (lift f) (e ∷ g) zero = refl
  apply-comp (lift f) (e ∷ g) (suc i) rewrite apply-comp f g i with apply f i
  ... | fail e′  = refl
  ... | return j = refl
  apply-comp (lift f) (lift g) zero = refl
  apply-comp (lift f) (lift g) (suc i) = lift-lift-suc f (apply-comp f g i)
  apply-comp (lift f) (weak g) i = begin

      suc <$> apply (comp (lift f) g) i

    ≡⟨ cong (_<$>_ suc) (apply-comp (lift f) g i) ⟩  -- ind. hyp.

      suc <$> (apply (lift f) i >>= apply g)

    ≡⟨ map-after-bind (apply (lift f) i) ⟩           -- move map

      apply (lift f) i >>= (λ j → suc <$> apply g j)
    ∎

  apply-comp (weak f) (e ∷ g) i rewrite apply-comp f g i = sym (bind-after-map (apply f i))

  apply-comp (weak f) (lift g) i rewrite apply-comp f g i = begin

      suc <$> (apply f i >>= apply g)

    ≡⟨ map-after-bind (apply f i) ⟩

      apply f i >>= (λ j → suc <$> apply g j)

    ≡⟨⟩

      apply f i >>= (λ j → apply (lift g) (suc j))

    ≡⟨ sym (bind-after-map (apply f i)) ⟩

      (suc <$> apply f i) >>= apply (lift g)
    ∎

  apply-comp (weak f) (weak g) i rewrite apply-comp (weak f) g i =
    map-after-bind (apply (weak f) i)

-- The Kleisli category of partial finite maps  Fin n → Error (Fin m)

PFin : (n m : ℕ) → Set
PFin n m = Fin n → Error (Fin m)

SPFin = λ n m → setoid (PFin n m)

pFinIsCategory : IsCategory SPFin
pFinIsCategory = record
  { ops = record
    { id  = return
    ; _⟫_ = λ f g a → f a >>= g
    }
  ; laws = record
    { id-first = fun-ext (bind-β _)
    ; id-last  = fun-ext (λ a → bind-η _)
    ; ∘-assoc  = λ f → fun-ext (λ a → bind-assoc (f a))
    ; ∘-cong   = λ{ refl refl → refl }
    }
  }

PFIN : Category _ _ _
PFIN = record { Hom = SPFin; isCategory = pFinIsCategory }

-- The evaluation functor

-- ⟦_⟧ : ∀ {n m} → PWeak n m → PFin n m
-- ⟦ f ⟧ = apply f

applyIsFunctor : IsFunctor {C = PWEAK} {D = PFIN} (λ n → n)
applyIsFunctor = record
  { ops  = record
    { map = apply
    }
  ; laws = record
    { map-id = fun-ext (apply-id _)
    ; map-∘  = λ f → fun-ext (apply-comp f _)
    }
  }


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

module Pitch where

open import Data.Bool       using (Bool; false; true)
open import Data.Integer    using (ℤ; +_; -[1+_])
open import Data.Fin        using (Fin; toℕ; #_; _≟_) renaming (zero to fz; suc to fs)
open import Data.Maybe      using (Maybe; just; nothing) renaming (map to mmap)
open import Data.Nat        using (ℕ; suc; _+_; _*_; _∸_; _≡ᵇ_)
open import Data.Nat.DivMod using (_mod_; _div_)
open import Data.Product    using (_×_; _,_; proj₁)
open import Data.Vec        using (Vec; []; _∷_; map; lookup; replicate; _[_]%=_; toList)
open import Function        using (_∘_)

open import Relation.Nullary using (yes; no)

open import BitVec          using (BitVec; insert)
open import Lemmas          using (revMod; -_mod_; -_div_)
open import Util            using (findIndex)

-- Position of a pitch on an absolute scale
-- 0 is C(-1) on the international scale (where C4 is middle C)
-- or C0 on the Midi scale (where C5 is middle C)
-- Pitch is intentially set to match Midi pitch.
-- However it is fine to let 0 represent some other note and
-- translate appropriately at the end.
data Pitch : Set where
  pitch : ℕ → Pitch

unpitch : Pitch → ℕ
unpitch (pitch p) = p

-- Number of notes in the chromatic scale.
chromaticScaleSize : ℕ
chromaticScaleSize = 12

-- Number of notes in the diatonic scale.
diatonicScaleSize : ℕ
diatonicScaleSize = 7

-- Position of a pitch within an octave, in the range [0..chromaticScaleSize-1].
data PitchClass : Set where
  pitchClass : Fin chromaticScaleSize → PitchClass

unPitchClass : PitchClass → Fin chromaticScaleSize
unPitchClass (pitchClass p) = p

Scale : ℕ → Set
Scale = Vec PitchClass

-- Which octave one is in.
data Octave : Set where
  octave : ℕ → Octave

unoctave : Octave → ℕ
unoctave (octave n) = n

PitchOctave : Set
PitchOctave = PitchClass × Octave

relativeToAbsolute : PitchOctave → Pitch
relativeToAbsolute (pitchClass n , octave o) =
  pitch (o * chromaticScaleSize + (toℕ n))

absoluteToRelative : Pitch → PitchOctave
absoluteToRelative (pitch  n) =
  (pitchClass (n mod chromaticScaleSize) , octave (n div chromaticScaleSize))

pitchToClass : Pitch → PitchClass
pitchToClass = proj₁ ∘ absoluteToRelative

majorScale harmonicMinorScale : Scale diatonicScaleSize
majorScale         = map pitchClass (# 0 ∷ # 2 ∷ # 4 ∷ # 5 ∷ # 7 ∷ # 9 ∷ # 11 ∷ [])
harmonicMinorScale = map pitchClass (# 0 ∷ # 2 ∷ # 3 ∷ # 5 ∷ # 7 ∷ # 8 ∷ # 11 ∷ [])

indexInScale : {n : ℕ} → Vec PitchClass n → Fin chromaticScaleSize → Maybe (Fin n)
indexInScale []         p = nothing
indexInScale (pc ∷ pcs) p with (unPitchClass pc ≟ p)
... | yes _ = just fz
... | no  _ = mmap fs (indexInScale pcs p)

data DiatonicDegree : Set where
  diatonicDegree : Fin diatonicScaleSize → DiatonicDegree

undd : DiatonicDegree → Fin diatonicScaleSize
undd (diatonicDegree d) = d

infix 4 _≡ᵈ_
_≡ᵈ_ : DiatonicDegree → DiatonicDegree → Bool
diatonicDegree d ≡ᵈ diatonicDegree e = toℕ d ≡ᵇ toℕ e

-- round down
pitchClassToDegreeMajor : PitchClass → DiatonicDegree
pitchClassToDegreeMajor (pitchClass fz)                                                        = diatonicDegree (# 0)
pitchClassToDegreeMajor (pitchClass (fs fz))                                                   = diatonicDegree (# 0)
pitchClassToDegreeMajor (pitchClass (fs (fs fz)))                                              = diatonicDegree (# 1)
pitchClassToDegreeMajor (pitchClass (fs (fs (fs fz))))                                         = diatonicDegree (# 1)
pitchClassToDegreeMajor (pitchClass (fs (fs (fs (fs fz)))))                                    = diatonicDegree (# 2)
pitchClassToDegreeMajor (pitchClass (fs (fs (fs (fs (fs fz))))))                               = diatonicDegree (# 3)
pitchClassToDegreeMajor (pitchClass (fs (fs (fs (fs (fs (fs fz)))))))                          = diatonicDegree (# 3)
pitchClassToDegreeMajor (pitchClass (fs (fs (fs (fs (fs (fs (fs fz))))))))                     = diatonicDegree (# 4)
pitchClassToDegreeMajor (pitchClass (fs (fs (fs (fs (fs (fs (fs (fs fz)))))))))                = diatonicDegree (# 4)
pitchClassToDegreeMajor (pitchClass (fs (fs (fs (fs (fs (fs (fs (fs (fs fz))))))))))           = diatonicDegree (# 5)
pitchClassToDegreeMajor (pitchClass (fs (fs (fs (fs (fs (fs (fs (fs (fs (fs fz)))))))))))      = diatonicDegree (# 5)
pitchClassToDegreeMajor (pitchClass (fs (fs (fs (fs (fs (fs (fs (fs (fs (fs (fs fz)))))))))))) = diatonicDegree (# 6)

degreeToPitchClassMajor : DiatonicDegree → PitchClass
degreeToPitchClassMajor (diatonicDegree fz)                               = pitchClass (# 0)
degreeToPitchClassMajor (diatonicDegree (fs fz))                          = pitchClass (# 2)
degreeToPitchClassMajor (diatonicDegree (fs (fs fz)))                     = pitchClass (# 4)
degreeToPitchClassMajor (diatonicDegree (fs (fs (fs fz))))                = pitchClass (# 5)
degreeToPitchClassMajor (diatonicDegree (fs (fs (fs (fs fz)))))           = pitchClass (# 7)
degreeToPitchClassMajor (diatonicDegree (fs (fs (fs (fs (fs fz))))))      = pitchClass (# 9)
degreeToPitchClassMajor (diatonicDegree (fs (fs (fs (fs (fs (fs fz))))))) = pitchClass (# 11)

pitchToDegreeCMajor : Pitch → DiatonicDegree
pitchToDegreeCMajor = pitchClassToDegreeMajor ∘ pitchToClass

d1 d2 d3 d4 d5 d6 d7 : DiatonicDegree
d1 = diatonicDegree (# 0)
d2 = diatonicDegree (# 1)
d3 = diatonicDegree (# 2)
d4 = diatonicDegree (# 3)
d5 = diatonicDegree (# 4)
d6 = diatonicDegree (# 5)
d7 = diatonicDegree (# 6)

thirdUp : DiatonicDegree → DiatonicDegree
thirdUp (diatonicDegree d) = diatonicDegree ((toℕ d + 2) mod diatonicScaleSize)

scaleSize : {n : ℕ} → Scale n → ℕ
scaleSize {n} _ = n

transposePitch : ℤ → Pitch → Pitch
transposePitch (+_     k) (pitch n) = pitch (n + k)
transposePitch (-[1+_] k) (pitch n) = pitch (n ∸ suc k)

-- Set of pitch classes represented as a bit vector.
PitchClassSet : Set
PitchClassSet = BitVec chromaticScaleSize

addToPitchClassSet : PitchClass → PitchClassSet → PitchClassSet
addToPitchClassSet (pitchClass p) ps = insert p ps

-- Standard Midi pitches

-- first argument is relative pitch within octave
-- second argument is octave (C5 = middle C for Midi)
standardMidiPitch : Fin chromaticScaleSize → ℕ → Pitch
standardMidiPitch p o = relativeToAbsolute (pitchClass p , octave o)

c c♯ d d♯ e f f♯ g g♯ a b♭ b : ℕ → Pitch
c  = standardMidiPitch (# 0)
c♯ = standardMidiPitch (# 1)
d  = standardMidiPitch (# 2)
d♯ = standardMidiPitch (# 3)
e  = standardMidiPitch (# 4)
f  = standardMidiPitch (# 5)
f♯ = standardMidiPitch (# 6)
g  = standardMidiPitch (# 7)
g♯ = standardMidiPitch (# 8)
a  = standardMidiPitch (# 9)
b♭ = standardMidiPitch (# 10)
b  = standardMidiPitch (# 11)


module Everything where

open import Oscar.Prelude public

-- meta-class
open import Oscar.Class public

-- classes
open import Oscar.Class.Amgu                                        public
open import Oscar.Class.Apply                                       public
open import Oscar.Class.Bind                                        public
open import Oscar.Class.Category                                    public
open import Oscar.Class.Congruity                                   public
open import Oscar.Class.Fmap                                        public
open import Oscar.Class.Functor                                     public
open import Oscar.Class.HasEquivalence                              public
open import Oscar.Class.Hmap                                        public
open import Oscar.Class.Injectivity                                 public
open import Oscar.Class.IsCategory                                  public
open import Oscar.Class.IsDecidable                                 public
open import Oscar.Class.IsEquivalence                               public
open import Oscar.Class.IsFunctor                                   public
open import Oscar.Class.IsPrecategory                               public
open import Oscar.Class.IsPrefunctor                                public
open import Oscar.Class.Leftstar                                    public
open import Oscar.Class.Leftunit                                    public
open import Oscar.Class.Map                                         public
open import Oscar.Class.Precategory                                 public
open import Oscar.Class.Prefunctor                                  public
open import Oscar.Class.Properthing                                 public
open import Oscar.Class.Pure                                        public
open import Oscar.Class.Quadricity                                  public
open import Oscar.Class.Reflexivity                                 public
open import Oscar.Class.Setoid                                      public
open import Oscar.Class.Similarity                                  public
open import Oscar.Class.SimilarityM                                 public
open import Oscar.Class.SimilaritySingleton                         public
open import Oscar.Class.Smap                                        public
open import Oscar.Class.Smapoid                                     public
open import Oscar.Class.Successor₀                                  public
open import Oscar.Class.Successor₁                                  public
open import Oscar.Class.Surjection                                  public
open import Oscar.Class.Surjextensionality                          public
open import Oscar.Class.Surjidentity                                public
open import Oscar.Class.Surjtranscommutativity                      public
open import Oscar.Class.Symmetrical                                 public
open import Oscar.Class.Symmetry                                    public
open import Oscar.Class.Thickandthin                                public
open import Oscar.Class.Transassociativity                          public
open import Oscar.Class.Transextensionality                         public
open import Oscar.Class.Transitivity                                public
open import Oscar.Class.Transleftidentity                           public
open import Oscar.Class.Transrightidentity                          public
open import Oscar.Class.Unit                                        public
open import Oscar.Class.[ExtensibleType]                            public
open import Oscar.Class.[IsExtensionB]                              public

-- individual instances
open import Oscar.Class.Amgu.Term∃SubstitistMaybe                   public
open import Oscar.Class.Congruity.Proposequality                    public
open import Oscar.Class.Congruity.Proposextensequality              public
open import Oscar.Class.HasEquivalence.ExtensionṖroperty            public
open import Oscar.Class.HasEquivalence.Ṗroperty                     public
open import Oscar.Class.HasEquivalence.Substitunction               public
open import Oscar.Class.Hmap.Transleftidentity                      public
open import Oscar.Class.Injectivity.Vec                             public
open import Oscar.Class.IsDecidable.Fin                             public
open import Oscar.Class.IsDecidable.¶                               public
open import Oscar.Class.Properthing.ExtensionṖroperty               public
open import Oscar.Class.Properthing.Ṗroperty                        public
open import Oscar.Class.Reflexivity.Function                        public
open import Oscar.Class.Smap.ExtensionFinExtensionTerm              public
open import Oscar.Class.Smap.ExtensionṖroperty                      public
open import Oscar.Class.Smap.TransitiveExtensionLeftṖroperty        public
open import Oscar.Class.Surjection.⋆                                public
open import Oscar.Class.Symmetrical.ExtensionalUnifies              public
open import Oscar.Class.Symmetrical.Symmetry                        public
open import Oscar.Class.Symmetrical.Unifies                         public
open import Oscar.Class.Transextensionality.Proposequality          public
open import Oscar.Class.Transitivity.Function                       public
open import Oscar.Class.[ExtensibleType].Proposequality             public

-- instance bundles
open import Oscar.Property.Category.AListProposequality                                         public
open import Oscar.Property.Category.ExtensionProposextensequality                               public
open import Oscar.Property.Category.Function                                                    public
open import Oscar.Property.Functor.SubstitistProposequalitySubstitunctionProposextensequality   public
open import Oscar.Property.Functor.SubstitunctionExtensionTerm                                  public
open import Oscar.Property.Monad.Maybe                                                          public
open import Oscar.Property.Propergroup.Substitunction                                           public
open import Oscar.Property.Setoid.ProductIndexEquivalence                                       public
open import Oscar.Property.Setoid.Proposequality                                                public
open import Oscar.Property.Setoid.Proposextensequality                                          public
open import Oscar.Property.Setoid.ṖropertyEquivalence                                           public
open import Oscar.Property.Thickandthin.FinFinProposequalityMaybeProposequality                 public
open import Oscar.Property.Thickandthin.FinTermProposequalityMaybeProposequality                public

-- data
open import Oscar.Data.Constraint                        public
open import Oscar.Data.Decidable                         public
open import Oscar.Data.Descender                         public
open import Oscar.Data.ExtensionṖroperty                 public
open import Oscar.Data.Fin                               public
open import Oscar.Data.List                              public
open import Oscar.Data.Maybe                             public
open import Oscar.Data.ProductIndexEquivalence           public
open import Oscar.Data.ProperlyExtensionNothing          public
open import Oscar.Data.Proposequality                    public
open import Oscar.Data.ṖropertyEquivalence               public
open import Oscar.Data.Substitist                        public
open import Oscar.Data.Substitunction                    public
open import Oscar.Data.Surjcollation                     public
open import Oscar.Data.Surjextenscollation               public
open import Oscar.Data.Term                              public
open import Oscar.Data.Vec                               public
open import Oscar.Data.¶                                 public
open import Oscar.Data.𝟘                                 public
open import Oscar.Data.𝟙                                 public
open import Oscar.Data.𝟚                                 public

-- class derivations
open import Oscar.Class.Leftunit.ToUnit                  public
open import Oscar.Class.Symmetry.ToSym                   public
open import Oscar.Class.Transleftidentity.ToLeftunit     public


-- TODO
-- Gentzen-style formalisation of syntax.
-- Simple terms.

module BasicT.Syntax.Gentzen where

open import BasicT.Syntax.Common public

-- Derivations.

infix 3 _⊢_
data _⊢_ (Γ : Cx Ty) : Ty → Set where
  var   : ∀ {A}   → A ∈ Γ → Γ ⊢ A
  lam   : ∀ {A B} → Γ , A ⊢ B → Γ ⊢ A ▻ B
  app   : ∀ {A B} → Γ ⊢ A ▻ B → Γ ⊢ A → Γ ⊢ B
  pair  : ∀ {A B} → Γ ⊢ A → Γ ⊢ B → Γ ⊢ A ∧ B
  fst   : ∀ {A B} → Γ ⊢ A ∧ B → Γ ⊢ A
  snd   : ∀ {A B} → Γ ⊢ A ∧ B → Γ ⊢ B
  unit  : Γ ⊢ ⊤
  true  : Γ ⊢ BOOL
  false : Γ ⊢ BOOL
  if    : ∀ {C}   → Γ ⊢ BOOL → Γ ⊢ C → Γ ⊢ C → Γ ⊢ C
  zero  : Γ ⊢ NAT
  suc   : Γ ⊢ NAT → Γ ⊢ NAT
  it    : ∀ {C}   → Γ ⊢ NAT → Γ ⊢ C ▻ C → Γ ⊢ C → Γ ⊢ C
  rec   : ∀ {C}   → Γ ⊢ NAT → Γ ⊢ NAT ▻ C ▻ C → Γ ⊢ C → Γ ⊢ C

infix 3 _⊢⋆_
_⊢⋆_ : Cx Ty → Cx Ty → Set
Γ ⊢⋆ ∅     = 𝟙
Γ ⊢⋆ Ξ , A = Γ ⊢⋆ Ξ × Γ ⊢ A

-- Monotonicity with respect to context inclusion.

mono⊢ : ∀ {A Γ Γ′} → Γ ⊆ Γ′ → Γ ⊢ A → Γ′ ⊢ A
mono⊢ η (var i)     = var (mono∈ η i)
mono⊢ η (lam t)     = lam (mono⊢ (keep η) t)
mono⊢ η (app t u)   = app (mono⊢ η t) (mono⊢ η u)
mono⊢ η (pair t u)  = pair (mono⊢ η t) (mono⊢ η u)
mono⊢ η (fst t)     = fst (mono⊢ η t)
mono⊢ η (snd t)     = snd (mono⊢ η t)
mono⊢ η unit        = unit
mono⊢ η true        = true
mono⊢ η false       = false
mono⊢ η (if t u v)  = if (mono⊢ η t) (mono⊢ η u) (mono⊢ η v)
mono⊢ η zero        = zero
mono⊢ η (suc t)     = suc (mono⊢ η t)
mono⊢ η (it t u v)  = it (mono⊢ η t) (mono⊢ η u) (mono⊢ η v)
mono⊢ η (rec t u v) = rec (mono⊢ η t) (mono⊢ η u) (mono⊢ η v)

mono⊢⋆ : ∀ {Ξ Γ Γ′} → Γ ⊆ Γ′ → Γ ⊢⋆ Ξ → Γ′ ⊢⋆ Ξ
mono⊢⋆ {∅}     η ∙        = ∙
mono⊢⋆ {Ξ , A} η (ts , t) = mono⊢⋆ η ts , mono⊢ η t

-- Shorthand for variables.

v₀ : ∀ {A Γ} → Γ , A ⊢ A
v₀ = var i₀

v₁ : ∀ {A B Γ} → Γ , A , B ⊢ A
v₁ = var i₁

v₂ : ∀ {A B C Γ} → Γ , A , B , C ⊢ A
v₂ = var i₂

-- Reflexivity.

refl⊢⋆ : ∀ {Γ} → Γ ⊢⋆ Γ
refl⊢⋆ {∅}     = ∙
refl⊢⋆ {Γ , A} = mono⊢⋆ weak⊆ refl⊢⋆ , v₀

-- Deduction theorem is built-in.

lam⋆ : ∀ {Ξ Γ A} → Γ ⧺ Ξ ⊢ A → Γ ⊢ Ξ ▻⋯▻ A
lam⋆ {∅}     = I
lam⋆ {Ξ , B} = lam⋆ {Ξ} ∘ lam

lam⋆₀ : ∀ {Γ A} → Γ ⊢ A → ∅ ⊢ Γ ▻⋯▻ A
lam⋆₀ {∅}     = I
lam⋆₀ {Γ , B} = lam⋆₀ ∘ lam

-- Detachment theorem.

det : ∀ {A B Γ} → Γ ⊢ A ▻ B → Γ , A ⊢ B
det t = app (mono⊢ weak⊆ t) v₀

det⋆ : ∀ {Ξ Γ A} → Γ ⊢ Ξ ▻⋯▻ A → Γ ⧺ Ξ ⊢ A
det⋆ {∅}     = I
det⋆ {Ξ , B} = det ∘ det⋆ {Ξ}

det⋆₀ : ∀ {Γ A} → ∅ ⊢ Γ ▻⋯▻ A → Γ ⊢ A
det⋆₀ {∅}     = I
det⋆₀ {Γ , B} = det ∘ det⋆₀

-- Cut and multicut.

cut : ∀ {A B Γ} → Γ ⊢ A → Γ , A ⊢ B → Γ ⊢ B
cut t u = app (lam u) t

multicut : ∀ {Ξ A Γ} → Γ ⊢⋆ Ξ → Ξ ⊢ A → Γ ⊢ A
multicut {∅}     ∙        u = mono⊢ bot⊆ u
multicut {Ξ , B} (ts , t) u = app (multicut ts (lam u)) t

-- Transitivity.

trans⊢⋆ : ∀ {Γ″ Γ′ Γ} → Γ ⊢⋆ Γ′ → Γ′ ⊢⋆ Γ″ → Γ ⊢⋆ Γ″
trans⊢⋆ {∅}      ts ∙        = ∙
trans⊢⋆ {Γ″ , A} ts (us , u) = trans⊢⋆ ts us , multicut ts u

-- Contraction.

ccont : ∀ {A B Γ} → Γ ⊢ (A ▻ A ▻ B) ▻ A ▻ B
ccont = lam (lam (app (app v₁ v₀) v₀))

cont : ∀ {A B Γ} → Γ , A , A ⊢ B → Γ , A ⊢ B
cont t = det (app ccont (lam (lam t)))

-- Exchange, or Schönfinkel’s C combinator.

cexch : ∀ {A B C Γ} → Γ ⊢ (A ▻ B ▻ C) ▻ B ▻ A ▻ C
cexch = lam (lam (lam (app (app v₂ v₀) v₁)))

exch : ∀ {A B C Γ} → Γ , A , B ⊢ C → Γ , B , A ⊢ C
exch t = det (det (app cexch (lam (lam t))))

-- Composition, or Schönfinkel’s B combinator.

ccomp : ∀ {A B C Γ} → Γ ⊢ (B ▻ C) ▻ (A ▻ B) ▻ A ▻ C
ccomp = lam (lam (lam (app v₂ (app v₁ v₀))))

comp : ∀ {A B C Γ} → Γ , B ⊢ C → Γ , A ⊢ B → Γ , A ⊢ C
comp t u = det (app (app ccomp (lam t)) (lam u))

-- Useful theorems in combinatory form.

ci : ∀ {A Γ} → Γ ⊢ A ▻ A
ci = lam v₀

ck : ∀ {A B Γ} → Γ ⊢ A ▻ B ▻ A
ck = lam (lam v₁)

cs : ∀ {A B C Γ} → Γ ⊢ (A ▻ B ▻ C) ▻ (A ▻ B) ▻ A ▻ C
cs = lam (lam (lam (app (app v₂ v₀) (app v₁ v₀))))

cpair : ∀ {A B Γ} → Γ ⊢ A ▻ B ▻ A ∧ B
cpair = lam (lam (pair v₁ v₀))

cfst : ∀ {A B Γ} → Γ ⊢ A ∧ B ▻ A
cfst = lam (fst v₀)

csnd : ∀ {A B Γ} → Γ ⊢ A ∧ B ▻ B
csnd = lam (snd v₀)

-- Closure under context concatenation.

concat : ∀ {A B Γ} Γ′ → Γ , A ⊢ B → Γ′ ⊢ A → Γ ⧺ Γ′ ⊢ B
concat Γ′ t u = app (mono⊢ (weak⊆⧺₁ Γ′) (lam t)) (mono⊢ weak⊆⧺₂ u)

-- Substitution.

[_≔_]_ : ∀ {A B Γ} → (i : A ∈ Γ) → Γ ∖ i ⊢ A → Γ ⊢ B → Γ ∖ i ⊢ B
[ i ≔ s ] var j     with i ≟∈ j
[ i ≔ s ] var .i    | same   = s
[ i ≔ s ] var ._    | diff j = var j
[ i ≔ s ] lam t     = lam ([ pop i ≔ mono⊢ weak⊆ s ] t)
[ i ≔ s ] app t u   = app ([ i ≔ s ] t) ([ i ≔ s ] u)
[ i ≔ s ] pair t u  = pair ([ i ≔ s ] t) ([ i ≔ s ] u)
[ i ≔ s ] fst t     = fst ([ i ≔ s ] t)
[ i ≔ s ] snd t     = snd ([ i ≔ s ] t)
[ i ≔ s ] unit      = unit
[ i ≔ s ] true      = true
[ i ≔ s ] false     = false
[ i ≔ s ] if t u v  = if ([ i ≔ s ] t) ([ i ≔ s ] u) ([ i ≔ s ] v)
[ i ≔ s ] zero      = zero
[ i ≔ s ] suc t     = suc ([ i ≔ s ] t)
[ i ≔ s ] it t u v  = it ([ i ≔ s ] t) ([ i ≔ s ] u) ([ i ≔ s ] v)
[ i ≔ s ] rec t u v = rec ([ i ≔ s ] t) ([ i ≔ s ] u) ([ i ≔ s ] v)

[_≔_]⋆_ : ∀ {Ξ A Γ} → (i : A ∈ Γ) → Γ ∖ i ⊢ A → Γ ⊢⋆ Ξ → Γ ∖ i ⊢⋆ Ξ
[_≔_]⋆_ {∅}     i s ∙        = ∙
[_≔_]⋆_ {Ξ , B} i s (ts , t) = [ i ≔ s ]⋆ ts , [ i ≔ s ] t

-- Convertibility.

data _⋙_ {Γ : Cx Ty} : ∀ {A} → Γ ⊢ A → Γ ⊢ A → Set where
  refl⋙        : ∀ {A} → {t : Γ ⊢ A}
                        → t ⋙ t

  trans⋙       : ∀ {A} → {t t′ t″ : Γ ⊢ A}
                        → t ⋙ t′ → t′ ⋙ t″
                        → t ⋙ t″

  sym⋙         : ∀ {A} → {t t′ : Γ ⊢ A}
                        → t ⋙ t′
                        → t′ ⋙ t

  conglam⋙     : ∀ {A B} → {t t′ : Γ , A ⊢ B}
                          → t ⋙ t′
                          → lam t ⋙ lam t′

  congapp⋙     : ∀ {A B} → {t t′ : Γ ⊢ A ▻ B} → {u u′ : Γ ⊢ A}
                          → t ⋙ t′ → u ⋙ u′
                          → app t u ⋙ app t′ u′

  congpair⋙    : ∀ {A B} → {t t′ : Γ ⊢ A} → {u u′ : Γ ⊢ B}
                          → t ⋙ t′ → u ⋙ u′
                          → pair t u ⋙ pair t′ u′

  congfst⋙     : ∀ {A B} → {t t′ : Γ ⊢ A ∧ B}
                          → t ⋙ t′
                          → fst t ⋙ fst t′

  congsnd⋙     : ∀ {A B} → {t t′ : Γ ⊢ A ∧ B}
                          → t ⋙ t′
                          → snd t ⋙ snd t′

  congsuc⋙     : ∀ {t t′ : Γ ⊢ NAT} → t ⋙ t′
                                      → suc t ⋙ suc t′

  congif⋙      : ∀ {C} → {t t′ : Γ ⊢ BOOL} → {u u′ : Γ ⊢ C} → {v v′ : Γ ⊢ C}
                        → t ⋙ t′
                        → if t u v ⋙ if t′ u′ v′

  congit⋙      : ∀ {C} → {t t′ : Γ ⊢ NAT} → {u u′ : Γ ⊢ C ▻ C} → {v v′ : Γ ⊢ C}
                        → t ⋙ t′
                        → it t u v ⋙ it t′ u′ v′

  congrec⋙     : ∀ {C} → {t t′ : Γ ⊢ NAT} → {u u′ : Γ ⊢ NAT ▻ C ▻ C} → {v v′ : Γ ⊢ C}
                        → t ⋙ t′
                        → rec t u v ⋙ rec t′ u′ v′

  beta▻⋙       : ∀ {A B} → {t : Γ , A ⊢ B} → {u : Γ ⊢ A}
                          → app (lam t) u ⋙ ([ top ≔ u ] t)

  eta▻⋙        : ∀ {A B} → {t : Γ ⊢ A ▻ B}
                          → t ⋙ lam (app (mono⊢ weak⊆ t) v₀)

  beta∧₁⋙      : ∀ {A B} → {t : Γ ⊢ A} → {u : Γ ⊢ B}
                          → fst (pair t u) ⋙ t

  beta∧₂⋙      : ∀ {A B} → {t : Γ ⊢ A} → {u : Γ ⊢ B}
                          → snd (pair t u) ⋙ u

  eta∧⋙        : ∀ {A B} → {t : Γ ⊢ A ∧ B}
                          → t ⋙ pair (fst t) (snd t)

  eta⊤⋙       : ∀ {t : Γ ⊢ ⊤} → t ⋙ unit

  betaBOOL₁⋙   : ∀ {C} → {u v : Γ ⊢ C}
                        → if true u v ⋙ u

  betaBOOL₂⋙   : ∀ {C} → {u v : Γ ⊢ C}
                        → if false u v ⋙ v

  betaNATit₁⋙  : ∀ {C} → {u : Γ ⊢ C ▻ C} → {v : Γ ⊢ C}
                        → it zero u v ⋙ v

  -- TODO: Verify this.
  betaNATit₂⋙  : ∀ {C} → {t : Γ ⊢ NAT} → {u : Γ ⊢ C ▻ C} → {v : Γ ⊢ C}
                        → it (suc t) u v ⋙ app u (it t u v)

  betaNATrec₁⋙ : ∀ {C} → {u : Γ ⊢ NAT ▻ C ▻ C} → {v : Γ ⊢ C}
                        → rec zero u v ⋙ v

  -- TODO: Verify this.
  betaNATrec₂⋙ : ∀ {C} → {t : Γ ⊢ NAT} → {u : Γ ⊢ NAT ▻ C ▻ C} → {v : Γ ⊢ C}
                        → rec (suc t) u v ⋙ app (app u t) (rec t u v)

  -- TODO: What about eta for BOOL and NAT?


module Esterel.Lang.Properties where

open import Esterel.Lang
open import Relation.Binary.PropositionalEquality
open import Relation.Unary
open import Relation.Nullary using (¬_ ; Dec ; yes ; no)
open import Esterel.Environment
open import Esterel.Variable.Signal as Signal
open import Esterel.Variable.Shared as SharedVar
open import Esterel.Context
  using (EvaluationContext ; EvaluationContext1 ; _⟦_⟧e ; _≐_⟦_⟧e ;
         Context ; Context1 ; _⟦_⟧c ; _≐_⟦_⟧c)
open import Esterel.Context.Properties

open import Data.Empty
  using (⊥ ; ⊥-elim)
open import Data.Nat
  using (ℕ ; zero ; suc) renaming (_⊔_ to _⊔ℕ_)
open import Data.MoreNatProp
  using (⊔-sym)
open import Data.Product
  using (Σ-syntax ; Σ ; _,_ ; _,′_ ; proj₁ ; proj₂ ; _×_)
open import Data.Sum
  using (_⊎_ ; inj₁ ; inj₂)
open import Data.List
open import Data.Maybe
open import Data.List.Any
open import Data.List.All
open import Data.OrderedListMap
open import Function using (_$_)

import Data.OrderedListMap(Signal)(Signal.unwrap)(Signal.Status) as SigOMap
import Data.OrderedListMap(SharedVar)(SharedVar.unwrap)(SharedVar.Status × ℕ) as ShrOMap

open ≡-Reasoning using (begin_ ; _≡⟨_⟩_ ; _∎)

open EvaluationContext1
open _≐_⟦_⟧e
open Context1
open _≐_⟦_⟧c

data halted : Term → Set where
  hnothin :           halted nothin
  hexit   : (n : ℕ) → halted (exit n)

data paused : Term → Set where
  ppause   :                     paused pause
  pseq     : ∀{p q} → paused p → paused (p >> q)
  ploopˢ   : ∀{p q} → paused p → paused (loopˢ p q)
  ppar     : ∀{p q} → paused p → paused q → paused (p ∥ q)
  psuspend : ∀{p S} → paused p → paused (suspend p S)
  ptrap    : ∀{p}   → paused p → paused (trap p)

data done : Term → Set where
  dhalted : ∀{p} → (p/halted : halted p) → done p
  dpaused : ∀{p} → (p/paused : paused p) → done p

data complete-θ : Env → Set where
  θcomplete : ∀{θ} →
                (∀ S → (S∈ : isSig∈ S θ) → ((sig-stats{S} θ S∈ ≡ Signal.absent) ⊎ (sig-stats{S} θ S∈ ≡ Signal.present))) →
                (∀ s → (s∈ : isShr∈ s θ) → (shr-stats{s} θ s∈ ≡ SharedVar.ready)) →
                ---------------
                complete-θ θ

data complete : Term → Set where
  codone : ∀{p} → done p → complete p
  coenv : ∀{θ A p} → complete-θ θ → done p → complete (ρ⟨ θ , A ⟩· p)

-- Halted and paused programs are disjoint
halted-paused-disjoint : ∀{p} → halted p → paused p → ⊥
halted-paused-disjoint hnothin   ()
halted-paused-disjoint (hexit _) ()

↓_ : ∀ {p} → halted p → Term
↓ hnothin = nothin
↓ hexit zero = nothin
↓ hexit (suc n) = exit n

↓-well-behaved : ∀ p -> (haltedp : halted p) -> halted (↓ haltedp)
↓-well-behaved .nothin hnothin = hnothin
↓-well-behaved .(exit 0) (hexit zero) = hnothin
↓-well-behaved .(exit (suc n)) (hexit (suc n)) = hexit n

A-max : Ctrl → Ctrl → Ctrl
A-max GO   GO   = GO
A-max GO   WAIT = GO
A-max WAIT GO   = GO
A-max WAIT WAIT = WAIT

value-max : ∀{p q} → done p → done q → (halted p ⊎ halted q) →  Term
value-max {q = q} (dhalted hnothin)   done-q              h⊎h = q
value-max {p = p} done-p              (dhalted hnothin)   h⊎h = p
value-max         (dhalted (hexit n)) (dhalted (hexit m)) h⊎h = exit (n ⊔ℕ m)
value-max         (dhalted (hexit n)) (dpaused _)         h⊎h = exit n
value-max         (dpaused _)         (dhalted (hexit m)) h⊎h = exit m
value-max         (dpaused paused-p)  (dpaused paused-q)  (inj₁ halted-p) =
  ⊥-elim (halted-paused-disjoint halted-p paused-p)
value-max         (dpaused paused-p)  (dpaused paused-q)  (inj₂ halted-q) =
  ⊥-elim (halted-paused-disjoint halted-q paused-q)

value-max-unique : ∀{p q d1 d2 d3 d4 ij1 ij2} → value-max{p}{q} d1 d2 ij1 ≡ value-max{p}{q} d3 d4 ij2
value-max-unique {d1 = dhalted hnothin}   {d2}                {dhalted hnothin}    {d4}                 {ij1} {ij2} = refl
value-max-unique {d1 = dhalted (hexit n)} {dhalted hnothin}   {dhalted (hexit .n)} {dhalted hnothin}    {ij1} {ij2} = refl
value-max-unique {d1 = dpaused p/paused}  {dhalted hnothin}   {dpaused p/paused'}  {dhalted hnothin}    {ij1} {ij2} = refl
value-max-unique {d1 = dhalted (hexit n)} {dhalted (hexit m)} {dhalted (hexit .n)} {dhalted (hexit .m)} {ij1} {ij2} = refl
value-max-unique {d1 = dhalted (hexit n)} {dpaused q/paused}  {dhalted (hexit .n)} {dpaused q/paused'}  {ij1} {ij2} = refl
value-max-unique {d1 = dpaused p/paused}  {dhalted (hexit n)} {dpaused p/paused'}  {dhalted (hexit .n)} {ij1} {ij2} = refl
value-max-unique {d1 = dpaused p/paused}  {dpaused q/paused}  {dpaused p/paused'}  {dpaused q/paused'} {inj₁ p/halted} {ij2} =
  ⊥-elim (halted-paused-disjoint p/halted p/paused')
value-max-unique {d1 = dpaused p/paused} {dpaused q/paused}   {dpaused p/paused'}  {dpaused q/paused'} {inj₂ q/halted} {ij2} =
  ⊥-elim (halted-paused-disjoint q/halted q/paused')
value-max-unique {d1 = dhalted p/halted} {d2} {dpaused p/paused'} {d4} {ij1} {ij2} =
  ⊥-elim (halted-paused-disjoint p/halted p/paused')
value-max-unique {d1 = dpaused p/paused} {d2} {dhalted p/halted'} {d4} {ij1} {ij2} =
  ⊥-elim (halted-paused-disjoint p/halted' p/paused)
value-max-unique {d1 = d1} {dhalted q/halted} {d3} {dpaused q/paused} {ij1} {ij2} =
  ⊥-elim (halted-paused-disjoint q/halted q/paused)
value-max-unique {d1 = d1} {dpaused q/paused}  {d3} {dhalted q/halted} {ij1} {ij2} =
  ⊥-elim (halted-paused-disjoint q/halted q/paused)

value-max-sym : ∀ {p q} ->
  (donep : done p) ->
  (haltedq : halted q) ->
  value-max donep (dhalted haltedq) (inj₂ haltedq) ≡
  value-max (dhalted haltedq) donep (inj₁ haltedq)
value-max-sym (dhalted hnothin) hnothin = refl
value-max-sym (dhalted hnothin) (hexit n) = refl
value-max-sym (dhalted (hexit n)) hnothin = refl
value-max-sym (dhalted (hexit n)) (hexit m)
  rewrite ⊔-sym n m = refl
value-max-sym (dpaused p/paused) hnothin = refl
value-max-sym (dpaused p/paused) (hexit n) = refl

value-max-done : ∀ {p q} →
  (p/done : done p) →
  (q/done : done q) →
  (p/halted⊎q/halted : halted p ⊎ halted q) →
  done (value-max p/done q/done p/halted⊎q/halted)
value-max-done (dhalted hnothin)   q/done              ⟨p⊎q⟩/halted = q/done
value-max-done (dhalted (hexit n)) (dhalted hnothin)   ⟨p⊎q⟩/halted = dhalted (hexit n)
value-max-done (dhalted (hexit n)) (dhalted (hexit m)) ⟨p⊎q⟩/halted = dhalted (hexit (n ⊔ℕ m))
value-max-done (dhalted (hexit n)) (dpaused q/paused)  ⟨p⊎q⟩/halted = dhalted (hexit n)
value-max-done (dpaused p/paused)  (dhalted hnothin)   ⟨p⊎q⟩/halted = dpaused p/paused
value-max-done (dpaused p/paused)  (dhalted (hexit m)) ⟨p⊎q⟩/halted = dhalted (hexit m)
value-max-done (dpaused p/paused)  (dpaused q/paused)  (inj₁ p/halted) =
  ⊥-elim (halted-paused-disjoint p/halted p/paused)
value-max-done (dpaused p/paused)  (dpaused q/paused)  (inj₂ q/halted) =
  ⊥-elim (halted-paused-disjoint q/halted q/paused)

{-
Properties relating halted, paused, done programs and the contexts. There's no way to
decompose halted programs, so the result must remain halted. The decomposition of paused
programs under the evaluation context must result in paused programs.

    halted-⟦⟧c : ∀{p p' C} → halted p → p ≐ C ⟦ p' ⟧c → halted p'
    paused-⟦⟧e : ∀{p p' E} → paused p → p ≐ E ⟦ p' ⟧e → paused p'
-}
halted-⟦⟧c : ∀{p p' C} → halted p → p ≐ C ⟦ p' ⟧c → halted p'
halted-⟦⟧c hnothin dchole = hnothin
halted-⟦⟧c (hexit n) dchole = hexit n

-- In fact, the only valid case would be E ≡ [] and p ≡ p'
halted-⟦⟧e : ∀{p p' E} → halted p → p ≐ E ⟦ p' ⟧e → halted p'
halted-⟦⟧e p/halted p≐E⟦p'⟧ = halted-⟦⟧c p/halted (⟦⟧e-to-⟦⟧c p≐E⟦p'⟧)

paused-⟦⟧e : ∀{p p' E} → paused p → p ≐ E ⟦ p' ⟧e → paused p'
paused-⟦⟧e ppause dehole = ppause
paused-⟦⟧e (pseq paused) dehole = pseq paused
paused-⟦⟧e (pseq paused) (deseq d) = paused-⟦⟧e paused d
paused-⟦⟧e (ploopˢ paused) dehole = ploopˢ paused
paused-⟦⟧e (ploopˢ paused) (deloopˢ d) = paused-⟦⟧e paused d
paused-⟦⟧e (ppar paused₁ paused₂) dehole = ppar paused₁ paused₂
paused-⟦⟧e (ppar paused₁ paused₂) (depar₁ d) = paused-⟦⟧e paused₁ d
paused-⟦⟧e (ppar paused₁ paused₂) (depar₂ d) = paused-⟦⟧e paused₂ d
paused-⟦⟧e (psuspend paused) dehole = psuspend paused
paused-⟦⟧e (psuspend paused) (desuspend d) = paused-⟦⟧e paused d
paused-⟦⟧e (ptrap paused) dehole = ptrap paused
paused-⟦⟧e (ptrap paused) (detrap d) = paused-⟦⟧e paused d

done-⟦⟧e : ∀ {p p' E} → done p → p ≐ E ⟦ p' ⟧e → done p'
done-⟦⟧e (dhalted p/halted) p≐E⟦p'⟧ = dhalted (halted-⟦⟧e p/halted p≐E⟦p'⟧)
done-⟦⟧e (dpaused p/paused) p≐E⟦p'⟧ = dpaused (paused-⟦⟧e p/paused p≐E⟦p'⟧)

halted-dec : ∀ p -> Dec (halted p)
halted-dec nothin = yes hnothin
halted-dec pause = no (λ ())
halted-dec (signl S p) = no (λ ())
halted-dec (present S ∣⇒ p ∣⇒ p₁) = no (λ ())
halted-dec (emit S) = no (λ ())
halted-dec (p ∥ q) = no (λ ())
halted-dec (loop p) = no (λ ())
halted-dec (loopˢ p q) = no (λ ())
halted-dec (p >> q) = no (λ ())
halted-dec (suspend p S) = no (λ ())
halted-dec (trap p) = no (λ ())
halted-dec (exit x) = yes (hexit x)
halted-dec (shared s ≔ e in: p) = no (λ ())
halted-dec (s ⇐ e) = no (λ ())
halted-dec (var x ≔ e in: p) = no (λ ())
halted-dec (x ≔ e) = no (λ ())
halted-dec (if x ∣⇒ p ∣⇒ q) = no (λ ())
halted-dec (ρ⟨ θ , A ⟩· p) = no (λ ())

paused-dec : ∀ p -> Dec (paused p)
paused-dec nothin = no (λ ())
paused-dec pause = yes ppause
paused-dec (signl S p) = no (λ ())
paused-dec (present S ∣⇒ p ∣⇒ p₁) = no (λ ())
paused-dec (emit S) = no (λ ())
paused-dec (p ∥ q) with paused-dec p | paused-dec q
paused-dec (p ∥ q) | yes pausedp | yes pausedq = yes (ppar pausedp pausedq)
paused-dec (p ∥ q) | _ | no ¬pausedq = no (λ { (ppar _ pausedq) → ¬pausedq pausedq } )
paused-dec (p ∥ q) | no ¬pausedp | _ = no (λ { (ppar pausedp _) → ¬pausedp pausedp } )
paused-dec (loop p) = no (λ ())
paused-dec (loopˢ p q) with paused-dec p
paused-dec (loopˢ p q) | yes pausedp = yes (ploopˢ pausedp)
paused-dec (loopˢ p q) | no ¬pausedp = no (λ { (ploopˢ pausedp) → ¬pausedp pausedp })
paused-dec (p >> q) with paused-dec p
paused-dec (p >> q) | yes pausedp = yes (pseq pausedp)
paused-dec (p >> q) | no ¬pausedp = no (λ { (pseq pausedp) → ¬pausedp pausedp })
paused-dec (suspend p S) with paused-dec p
paused-dec (suspend p S) | yes pausedp = yes (psuspend pausedp)
paused-dec (suspend p S) | no ¬pausedp = no (λ { (psuspend pausedp) → ¬pausedp pausedp })
paused-dec (trap p) with paused-dec p
paused-dec (trap p) | yes pasuedp = yes (ptrap pasuedp)
paused-dec (trap p) | no ¬pausedp = no (λ { (ptrap pausedp) → ¬pausedp pausedp })
paused-dec (exit x) = no (λ ())
paused-dec (shared s ≔ e in: p) = no (λ ())
paused-dec (s ⇐ e) = no (λ ())
paused-dec (var x ≔ e in: p) = no (λ ())
paused-dec (x ≔ e) = no (λ ())
paused-dec (if x ∣⇒ p ∣⇒ q) = no (λ ())
paused-dec (ρ⟨ θ , A ⟩· p) = no (λ ())

done-dec : ∀ p → Dec (done p)
done-dec p with halted-dec p
done-dec p | yes halted-p = yes (dhalted halted-p)
done-dec p | no ¬halted-p with paused-dec p
done-dec p | no _ | yes paused-p = yes (dpaused paused-p)
done-dec p | no ¬halted-p | (no ¬paused-p) = no
  (λ { (dhalted p/halted) → ¬halted-p p/halted ;
       (dpaused p/paused) → ¬paused-p p/paused})

signal-absent-or-present : Signal.Status → Set
signal-absent-or-present S = S ≡ Signal.absent ⊎ S ≡ Signal.present

signal-absent-or-present-dec : Decidable signal-absent-or-present
signal-absent-or-present-dec present = yes (inj₂ refl)
signal-absent-or-present-dec absent = yes (inj₁ refl)
signal-absent-or-present-dec unknown = no (λ { (inj₁ ()) ; (inj₂ ())})

signals-all-absent-or-present-dec :
  (Ss :  SigMap.Map Signal.Status) ->
        Dec (∀ S → (S∈ : (SigMap.∈Dom S Ss)) →
              (signal-absent-or-present (SigMap.lookup{k = S} Ss S∈)))
signals-all-absent-or-present-dec m
   with SigOMap.andmap{_}{signal-absent-or-present} signal-absent-or-present-dec m
signals-all-absent-or-present-dec m | yes p = yes (λ S → p (Signal.unwrap S))
signals-all-absent-or-present-dec m | no ¬p = no (λ z → ¬p (λ n → z (n ₛ)))

var-is-ready : SharedVar.Status × ℕ → Set
var-is-ready p = (proj₁ p) ≡ SharedVar.ready

var-is-ready-dec : Decidable var-is-ready
var-is-ready-dec (ready , _) = yes refl
var-is-ready-dec (new , _) = no (λ ())
var-is-ready-dec (old , _) = no (λ ())

vars-all-ready-dec :
  (ss : ShrMap.Map (SharedVar.Status × ℕ)) ->
   Dec (∀ s → (s∈ : ShrMap.∈Dom s ss) →
        var-is-ready (ShrMap.lookup{k = s} ss s∈))
vars-all-ready-dec ss with ShrOMap.andmap{_}{var-is-ready} var-is-ready-dec ss
vars-all-ready-dec ss | yes p = yes (λ s → p (SharedVar.unwrap s))
vars-all-ready-dec ss | no ¬p = no (λ z → ¬p (λ n → z (n ₛₕ)))

complete-θ-dec : ∀ θ → Dec (complete-θ θ)
complete-θ-dec (Θ sigs shr _) with signals-all-absent-or-present-dec sigs
complete-θ-dec (Θ sigs shrs _) | yes p with vars-all-ready-dec shrs
complete-θ-dec (Θ sigs shrs _) | yes p₁ | yes p₂ = yes (θcomplete p₁ p₂)
complete-θ-dec (Θ sigs shrs _) | yes _ | no ¬p = no (λ { (θcomplete _ x) → ¬p x } )
complete-θ-dec (Θ sigs shrs _) | no ¬p = no (λ { (θcomplete x _) → ¬p x } )

complete-dec : ∀ p → Dec (complete p)
complete-dec p with done-dec p
complete-dec p | yes donep = yes (codone donep)
complete-dec nothin | no ¬donep = no (λ _ → ¬donep (dhalted hnothin))
complete-dec pause | no ¬donep = no (λ _ → ¬donep (dpaused ppause))
complete-dec (signl S p) | no ¬donep = no (λ { (codone x) → ¬donep x } )
complete-dec (present S ∣⇒ p ∣⇒ p₁) | no ¬donep = no (λ { (codone x) → ¬donep x } )
complete-dec (emit S) | no ¬donep = no (λ { (codone x) → ¬donep x } )
complete-dec (p ∥ p₁) | no ¬donep =  no (λ { (codone x) → ¬donep x } )
complete-dec (loop p) | no ¬donep = no (λ { (codone x) → ¬donep x } )
complete-dec (loopˢ p q) | no ¬donep = no (λ { (codone x) → ¬donep x } )
complete-dec (p >> p₁) | no ¬donep = no (λ { (codone x) → ¬donep x } )
complete-dec (suspend p S) | no ¬donep = no (λ { (codone x) → ¬donep x } )
complete-dec (trap p) | no ¬donep = no (λ { (codone x) → ¬donep x } )
complete-dec (exit x) | no ¬donep = no (λ { (codone x) → ¬donep x } )
complete-dec (shared s ≔ e in: p) | no ¬donep = no (λ { (codone x) → ¬donep x } )
complete-dec (s ⇐ e) | no ¬donep =  no (λ { (codone x) → ¬donep x } )
complete-dec (var x ≔ e in: p) | no ¬donep =  no (λ { (codone x) → ¬donep x } )
complete-dec (x ≔ e) | no ¬donep =  no (λ { (codone x) → ¬donep x } )
complete-dec (if x ∣⇒ p ∣⇒ p₁) | no ¬donep =  no (λ { (codone x) → ¬donep x } )
complete-dec (ρ⟨ θ , A ⟩· p) | _ with done-dec p
complete-dec (ρ⟨ θ , A ⟩· p) | _ | yes donep with complete-θ-dec θ
complete-dec (ρ⟨ θ , A ⟩· p) | _ | yes donep | (yes complete-θ) = yes (coenv complete-θ donep)
complete-dec (ρ⟨ θ , A ⟩· p) | _ | yes donep | (no ¬complete-θ) = no
   (λ { (codone (dhalted ())) ;
        (codone (dpaused ())) ;
        (coenv complete-θ _) → ¬complete-θ complete-θ })
complete-dec (ρ⟨ θ , A ⟩· p) | _ | no ¬donep = no
  (λ { (codone (dhalted ())) ;
       (codone (dpaused ())) ;
       (coenv _ donep) → ¬donep donep })

A-max-GO-≡-left : ∀ A → A-max GO A ≡ GO
A-max-GO-≡-left GO =  refl
A-max-GO-≡-left WAIT = refl

A-max-GO-≡-right : ∀ A → A-max A GO ≡ GO
A-max-GO-≡-right GO = refl
A-max-GO-≡-right WAIT = refl

A-max-comm : ∀ A1 A2 → A-max A1 A2 ≡ A-max A2 A1
A-max-comm GO GO = refl
A-max-comm GO WAIT = refl
A-max-comm WAIT GO = refl
A-max-comm WAIT WAIT = refl

A-max-assoc : ∀ A1 A2 A3 → (A-max A1 $ A-max A2 A3) ≡ A-max (A-max A1 A2) A3
A-max-assoc GO GO GO = refl
A-max-assoc GO GO WAIT = refl
A-max-assoc GO WAIT GO = refl
A-max-assoc GO WAIT WAIT = refl
A-max-assoc WAIT GO GO = refl
A-max-assoc WAIT GO WAIT = refl
A-max-assoc WAIT WAIT GO = refl
A-max-assoc WAIT WAIT WAIT = refl

A-max-swap : ∀ A1 A2 A3
             → (A-max (A-max A1 A2) A3) ≡ (A-max (A-max A1 A3) A2)
A-max-swap A1 A2 A3 = begin
                        (A-max (A-max A1 A2) A3) ≡⟨ sym (A-max-assoc A1 A2 A3) ⟩
                        (A-max A1 $ A-max A2 A3) ≡⟨ sym (cong (A-max A1) (A-max-comm A3 A2)) ⟩
                        (A-max A1 $ A-max A3 A2) ≡⟨ A-max-assoc A1 A3 A2 ⟩
                        (A-max (A-max A1 A3) A2) ∎


------------------------------------------------------------------------
-- An up-to technique for CCS
------------------------------------------------------------------------

{-# OPTIONS --sized-types #-}

open import Prelude hiding (step-→)

module Bisimilarity.Weak.Up-to.CCS {ℓ} {Name : Type ℓ} where

open import Equality.Propositional
open import Logical-equivalence using (_⇔_)
open import Prelude.Size

open import Function-universe equality-with-J hiding (id; _∘_)

open import Bisimilarity.Weak.CCS
import Bisimilarity.Weak.Equational-reasoning-instances
open import Equational-reasoning
open import Indexed-container hiding (⟨_⟩)
open import Labelled-transition-system.CCS Name
open import Relation

open import Bisimilarity.Weak CCS
open import Bisimilarity.Weak.Up-to CCS
import Labelled-transition-system.Equational-reasoning-instances CCS
  as Dummy

-- Up to (non-degenerate) context for CCS (for polyadic, coinductive
-- contexts).

Up-to-context : Trans₂ ℓ (Proc ∞)
Up-to-context R (p , q) =
  ∃ λ n →
  ∃ λ (C : Context ∞ n) →
  Non-degenerate ∞ C
    ×
  ∃ λ ps →
  ∃ λ qs →
  p ≡ C [ ps ]
    ×
  q ≡ C [ qs ]
    ×
  ∀ x → R (ps x , qs x)

-- Up to context is monotone.

up-to-context-monotone : Monotone Up-to-context
up-to-context-monotone R⊆S =
  Σ-map id $ Σ-map id $ Σ-map id $ Σ-map id $ Σ-map id $ Σ-map id $
  Σ-map id (R⊆S ∘_)

-- Up to context is size-preserving.

up-to-context-size-preserving : Size-preserving Up-to-context
up-to-context-size-preserving =
  _⇔_.from (monotone→⇔ up-to-context-monotone)
  (λ where
     (_ , C , D , ps , qs , refl , refl , ps∼qs) →

      C [ ps ]  ∼⟨ D [ ps∼qs ]-cong ⟩■
      C [ qs ])

-- Note that up to context is not compatible (assuming that Name is
-- inhabited).
--
-- This counterexample is a minor variant of one due to Pous and
-- Sangiorgi, who state that up to context is contained in a larger
-- function that is compatible for another, "one-sided" step function
-- (see Section 6.5.3 in "Enhancements of the bisimulation proof
-- method").

¬-up-to-context-compatible : Name → ¬ Compatible Up-to-context
¬-up-to-context-compatible x comp = contradiction
  where
  a = x , true

  data R₀ : Rel₂ ℓ (Proc ∞) where
    base : R₀ (τ ∙ (a ∙) , a ∙)

  R : Rel₂ ℓ (Proc ∞)
  R = R₀ ⁼

  !τa[R]!a : Up-to-context R (! τ ∙ (a ∙) , ! a ∙)
  !τa[R]!a =
      1
    , ! hole fzero
    , ! hole
    , (λ _ → τ ∙ (a ∙))
    , (λ _ → a ∙)
    , refl
    , refl
    , (λ _ → inj₁ base)

  !a[τ]⇒̂→≡ : ∀ {P} → ! a ∙ [ τ ]⇒̂ P → P ≡ ! a ∙
  !a[τ]⇒̂→≡ (non-silent ¬s _)                 = ⊥-elim $ ¬s _
  !a[τ]⇒̂→≡ (silent _ done)                   = refl
  !a[τ]⇒̂→≡ (silent _ (step {μ = μ} s !a⟶ _)) = ⊥-elim $ name≢τ (
                                                 name a  ≡⟨ !-only ·-only !a⟶ ⟩
                                                 μ       ≡⟨ silent≡τ s ⟩∎
                                                 τ       ∎)

  drop-[] : ∀ {P Q S} →
            Up-to-context R (P ∣ Q , ! S) → R (P ∣ Q , ! S)
  drop-[] (_ , hole i , _ , _ , _ , P∣Q≡Ps[i] , !S≡Qs[i] , PsRQs) =
    subst R (cong₂ _,_ (sym P∣Q≡Ps[i]) (sym !S≡Qs[i])) (PsRQs i)

  drop-[] (_ , ∅        , _ , _ , _ , () , _)
  drop-[] (_ , _ ∣ _    , _ , _ , _ , _  , () , _)
  drop-[] (_ , _ ⊕ _    , _ , _ , _ , () , _)
  drop-[] (_ , _ · _    , _ , _ , _ , () , _)
  drop-[] (_ , ⟨ν _ ⟩ _ , _ , _ , _ , () , _)
  drop-[] (_ , ! _      , _ , _ , _ , () , _)

  R⊆StepR : R ⊆ ⟦ StepC ⟧ R
  R⊆StepR (inj₁ base) = ⟨ lr , rl ⟩
    where
    lr :
      ∀ {P μ} →
      τ ∙ (a ∙) [ μ ]⟶ P →
      ∃ λ Q → a ∙ [ μ ]⇒̂ Q × R (P , Q)
    lr action =
        _
      , (a ∙  ■)
      , inj₂ refl

    rl :
      ∀ {Q μ} →
      a ∙ [ μ ]⟶ Q →
      ∃ λ P → τ ∙ (a ∙) [ μ ]⇒̂ P × R (P , Q)
    rl action =
        _
      , (τ ∙ (a ∙)  →⟨ ⟶: action ⟩
         a ∙        →⟨ ⟶: action ⟩■
         ∅)
      , inj₂ refl

  R⊆StepR {P , _} (inj₂ refl) =
    ⟨ Σ-map id (Σ-map id inj₂)         ∘ lr
    , Σ-map id (Σ-map id (inj₂ ∘ sym)) ∘ lr
    ⟩
    where
    lr : ∀ {P′ μ} →
         P [ μ ]⟶ P′ →
         ∃ λ Q′ → P [ μ ]⇒̂ Q′ × P′ ≡ Q′
    lr P⟶P′ = _ , ⟶→⇒̂ P⟶P′ , refl

  -- Note the use of compatibility in [R]⊆Step[S].

  [R]⊆Step[R] : Up-to-context R ⊆ ⟦ StepC ⟧ (Up-to-context R)
  [R]⊆Step[R] =
    Up-to-context R              ⊆⟨ up-to-context-monotone (λ {x} → R⊆StepR {x}) ⟩
    Up-to-context (⟦ StepC ⟧ R)  ⊆⟨ comp ⟩∎
    ⟦ StepC ⟧ (Up-to-context R)  ∎

  contradiction : ⊥
  contradiction =                                                       $⟨ !τa[R]!a ⟩
    Up-to-context R (! τ ∙ (a ∙) , ! a ∙)                               ↝⟨ [R]⊆Step[R] ⟩
    ⟦ StepC ⟧ (Up-to-context R) (! τ ∙ (a ∙) , ! a ∙)                   ↝⟨ (λ s → StepC.left-to-right s (replication (par-right action))) ⟩
    (∃ λ P → ! a ∙ [ τ ]⇒̂ P × Up-to-context R (! τ ∙ (a ∙) ∣ a ∙ , P))  ↝⟨ (λ { (_ , !a⟶ , hyp) →
                                                                                subst (Up-to-context R ∘ (_ ,_)) (!a[τ]⇒̂→≡ !a⟶) hyp }) ⟩
    Up-to-context R (! τ ∙ (a ∙) ∣ a ∙ , ! a ∙)                         ↝⟨ drop-[] ⟩
    R (! τ ∙ (a ∙) ∣ a ∙ , ! a ∙)                                       ↝⟨ [ (λ ()) , (λ ()) ] ⟩□
    ⊥                                                                   □