-- The comonad named Store by Russel O'Connor.
-- See his WGP 2011 paper.

{-# OPTIONS --copatterns #-}

module Control.Comonad.Store where

open import Function using (id) renaming (_∘′_ to _∘_)
open import Relation.Binary.PropositionalEquality
  using (_≡_; refl; sym; trans; cong; cong₂; module ≡-Reasoning)
open ≡-Reasoning

open import Axiom.FunctionExtensionality
open import Util.Equality

open import Control.Functor
open import Control.Functor.NaturalTransformation
open import Control.Comonad

-- The Store comonad.

record Store (I O : Set) : Set where
  constructor store
  field
    peek : I → O
    pos  : I

  extract : O
  extract = peek pos

{- not in scope: store
  extend′ : ∀ {B} → (Store I O → B) → Store I B
  extend′ f = store (f ∘ store peek) pos
-}

  extend′ : ∀ {B} → (Store I O → B) → Store I B
  pos  (extend′ f) = pos
  peek (extend′ f) = f ∘ s
    where
      s : I → Store I O
      peek (s i) = peek
      pos  (s i) = i

storeIsComonad : ∀ I → IsComonad (Store I)
storeIsComonad I = record
  { extract  = extract
  ; extend   = extend
  ; extend-β = refl
  ; extend-η = refl
  ; extend-∘ = refl
  }
  where
    extract : ∀ {O} → Store I O → O
    extract (store v i) = v i

    extend : ∀ {A B} → (Store I A → B) → Store I A → Store I B
    extend f (store v i) = store (f ∘ store v) i

    extend-β : ∀ {A B} (f : Store I A → B) → extract ∘ extend f ≡ f
    extend-β f = refl

StoreC : ∀ I → Comonad
StoreC I = comonad (Store I) (storeIsComonad I)

-- Functoriality,

storeIsFunctor : ∀ I → IsFunctor (Store I)
storeIsFunctor I = IsComonad.isFunctor (storeIsComonad I)

StoreF : (I : Set) → Functor
StoreF I = functor (Store I) (storeIsFunctor I)

idLens : ∀ {I} → I → Store I I
idLens = store id

-- Van Laarhoven presentation

record LStore (I O : Set) : Set₁ where
  -- constructor lstore
  field
    modifier : (FF : Functor) → let open Functor FF in
               (I → F I) → F O

  -- Laws.

  -- 0. Free theorem.
  field
    modifier-free : {FF GG : Functor} (N : NatTrans FF GG) →
      let open Functor FF using () renaming (F   to F) in
      let open Functor GG using () renaming (F   to G) in
      let open NatTrans N using () renaming (eta to η) in
      (f : I → F I) →

        η (modifier FF f) ≡ modifier GG (η ∘ f)

  -- 1. Identity

  -- modifier-id :

-- Converting between store comonads.

storeToLStore : ∀ {I O} → Store I O → LStore I O
storeToLStore {I = I} {O = O} (store v i) = record
  { modifier      = modifier
  ; modifier-free = modifier-free
  }
  where
    modifier : (FF : Functor) → let open Functor FF in
               (I → F I) → F O
    modifier FF f = map v (f i)
      where open Functor FF

    modifier-free : {FF GG : Functor} (N : NatTrans FF GG) →
      let open Functor FF using () renaming (F   to F) in
      let open Functor GG using () renaming (F   to G) in
      let open NatTrans N using () renaming (eta to η) in
      (f : I → F I) →

        η (modifier FF f) ≡ modifier GG (η ∘ f)

    modifier-free {FF = FF}{GG = GG} N f = begin
        η (modifier FF f)   ≡⟨⟩
        (η ∘ mapF v) (f i)  ≡⟨ app-≡ (f i) (naturality _) ⟩
        (mapG v ∘ η) (f i)  ≡⟨⟩
        modifier GG (η ∘ f) ∎

      where
        open Functor FF using () renaming (F to F; map to mapF; map-id to mapF-id; map-∘ to mapF-∘)
        open Functor GG using () renaming (F to G; map to mapG; map-id to mapG-id; map-∘ to mapG-∘)
        open NatTrans N using (naturality) renaming (eta to η)

lstoreToStore : ∀ {I O} → LStore I O → Store I O
lstoreToStore {I = I} {O = O} l = LStore.modifier l (StoreF I) idLens

-- Isomorphism.

storeId : ∀ {I O} (s : Store I O) → lstoreToStore (storeToLStore s) ≡ s
storeId {I = I}{O = O} (store v i) = begin
  lstoreToStore (storeToLStore (store v i))                      ≡⟨⟩
  LStore.modifier (storeToLStore (store v i)) (StoreF I) idLens  ≡⟨⟩
  Functor.map (StoreF I) v (idLens i)                            ≡⟨⟩
  Functor.map (StoreF I) v (store id i)                          ≡⟨⟩
  store (v ∘ id) i                                               ≡⟨⟩
  store v i ∎

-- -- BAD IDEA: the proof of modifier-free should not be compared with ≡

-- lstoreId : ∀ {I O} (l : LStore I O) → storeToLStore (lstoreToStore l) ≡ l
-- lstoreId {I = I}{O = O} l = begin
--    storeToLStore (lstoreToStore l)             ≡⟨⟩
--    storeToLStore (modifier (StoreF I) idLens)  ≡⟨⟩
--    storeToLStore (modifier (StoreF I) idLens)  ≡⟨ {!!} ⟩
--    l                                           ∎
--   where open LStore l


module Pruning where

le2 : {B : Set} -> (A : Set) -> A -> (C : Set) -> C -> (A -> C -> B) -> B
le2 _ x _ y f = f x y

test : le2 Set _ (Set -> Set) _ (\ H -> (\M -> (z : Set) -> H == M z))
test z = refl

{-
let : {B : Set} -> (A : Set) -> A -> (A -> B) -> B
let A x f = f x

test : let Set _ (\ H -> let (Set -> Set) _ (\ M -> (z : Set) -> H == M z))
test z = refl
-}


open import Oscar.Prelude
open import Oscar.Class
open import Oscar.Class.Surjection
open import Oscar.Class.Smap
open import Oscar.Class.Reflexivity
open import Oscar.Data.Proposequality

module Oscar.Class.Surjidentity where

module _
  {𝔬₁ 𝔯₁ 𝔬₂ 𝔯₂ ℓ₂}
  {𝔒₁ : Ø 𝔬₁}
  {𝔒₂ : Ø 𝔬₂}
  where
  module Surjidentity
    {μ : Surjection.type 𝔒₁ 𝔒₂}
    (_∼₁_ : 𝔒₁ → 𝔒₁ → Ø 𝔯₁)
    (_∼₂_ : 𝔒₂ → 𝔒₂ → Ø 𝔯₂)
    (_∼̇₂_ : ∀ {x y} → x ∼₂ y → x ∼₂ y → Ø ℓ₂)
    (§ : Smap.type _∼₁_ _∼₂_ μ μ)
    (ε₁ : Reflexivity.type _∼₁_)
    (ε₂ : Reflexivity.type _∼₂_)
    = ℭLASS ((λ {x} {y} → § {x} {y}) , (λ {x} → ε₁ {x}) , (λ {x y} → _∼̇₂_ {x} {y}) , (λ {x} → ε₂ {x})) (∀ {x} → § (ε₁ {x}) ∼̇₂ ε₂)
  module _
    {μ : Surjection.type 𝔒₁ 𝔒₂}
    {_∼₁_ : 𝔒₁ → 𝔒₁ → Ø 𝔯₁}
    {_∼₂_ : 𝔒₂ → 𝔒₂ → Ø 𝔯₂}
    {_∼̇₂_ : ∀ {x y} → x ∼₂ y → x ∼₂ y → Ø ℓ₂}
    {§ : Smap.type _∼₁_ _∼₂_ μ μ}
    {ε₁ : Reflexivity.type _∼₁_}
    {ε₂ : Reflexivity.type _∼₂_}
    where
    surjidentity = Surjidentity.method _∼₁_ _∼₂_ _∼̇₂_ (λ {x} {y} → § {x} {y}) (λ {x} → ε₁ {x}) (λ {x} → ε₂ {x})
  module Surjidentity!
    (∼₁ : 𝔒₁ → 𝔒₁ → Ø 𝔯₁)
    (∼₂ : 𝔒₂ → 𝔒₂ → Ø 𝔯₂)
    (∼̇₂ : ∀ {x y} → ∼₂ x y → ∼₂ x y → Ø ℓ₂)
    ⦃ _ : Surjection.class 𝔒₁ 𝔒₂ ⦄
    ⦃ _ : Smap!.class ∼₁ ∼₂ ⦄
    ⦃ _ : Reflexivity.class ∼₁ ⦄
    ⦃ _ : Reflexivity.class ∼₂ ⦄
    = Surjidentity {surjection} ∼₁ ∼₂ ∼̇₂ § ε ε
  module _
    (_∼₁_ : 𝔒₁ → 𝔒₁ → Ø 𝔯₁)
    {_∼₂_ : 𝔒₂ → 𝔒₂ → Ø 𝔯₂}
    (_∼̇₂_ : ∀ {x y} → x ∼₂ y → x ∼₂ y → Ø ℓ₂)
    ⦃ _ : Surjection.class 𝔒₁ 𝔒₂ ⦄
    ⦃ _ : Smap!.class _∼₁_ _∼₂_ ⦄
    ⦃ _ : Reflexivity.class _∼₁_ ⦄
    ⦃ _ : Reflexivity.class _∼₂_ ⦄
    where
    surjidentity[_,_] = Surjidentity.method {surjection} _∼₁_ _∼₂_ _∼̇₂_ § ε ε


{-# OPTIONS --without-K #-}
open import level
open import algebra.group.core
open import algebra.monoid.mset
open import algebra.monoid.morphism
open import function.extensionality
open import function.isomorphism
open import equality.calculus
open import equality.core
open import sum
open import hott.level
open import hott.equivalence
open import hott.univalence

module algebra.group.gset {i}(G : Set i) ⦃ gG : IsGroup G ⦄ where
  open IsGroup ⦃ ... ⦄

  IsGSet : ∀ {j}(X : Set j) → Set (i ⊔ j)
  IsGSet X = IsMSet G X

  GSet : ∀ j → Set (i ⊔ lsuc j)
  GSet j = Σ (Set j) IsGSet

  GSet₀ : ∀ j → Set (i ⊔ lsuc j)
  GSet₀ j = Σ (Type j 2) λ { (X , hX) → G → X → X }

  GSet₁ : ∀ {j} → GSet₀ j → Set (i ⊔ j)
  GSet₁ ((X , _) , _◂_) =
    ((g₁ g₂ : G)(x : X) → (g₁ * g₂) ◂ x ≡ g₁ ◂ (g₂ ◂ x))
    × ((x : X) → e ◂ x ≡ x)

  gset₁-level : ∀ {j}(X : GSet₀ j)
              → h 1 (GSet₁ X)
  gset₁-level ((X , hX) , act) = ×-level
    (Π-level λ g₁ → Π-level λ g₂ → Π-level λ x → hX _ _)
    (Π-level λ x → hX _ _)

  gset-struct-iso : ∀ {j} → GSet j ≅ Σ (GSet₀ j) GSet₁
  gset-struct-iso = record
    { to = λ { (X , xG) → (((X , IsMSet.mset-level xG) , IsMSet._◂_ xG) ,
                           (IsMSet.◂-hom xG , IsMSet.◂-id xG)) }
    ; from = λ { (((X , hX) , _◂_) , (◂-hom , ◂-id))
             → (X , mk-is-mset _◂_ ◂-hom ◂-id hX) }
    ; iso₁ = λ _ → refl
    ; iso₂ = λ _ → refl }

  open IsMSet ⦃ ... ⦄

  module _ {j k}
           {X : Set j} ⦃ xG : IsGSet X ⦄
           {Y : Set k} ⦃ yG : IsGSet Y ⦄ where
    IsGSetMorphism : (X → Y) → Set (i ⊔ j ⊔ k)
    IsGSetMorphism = IsMSetMorphism G

  module _ {j k}
           (X : Set j) ⦃ xG : IsGSet X ⦄
           (Y : Set k) ⦃ yG : IsGSet Y ⦄ where
    GSetMorphism : Set (i ⊔ j ⊔ k)
    GSetMorphism = Σ (X → Y) IsGSetMorphism

    gsetmorphism-equality : h 2 Y → {f g : X → Y}
      (f-mor : IsGSetMorphism f) (g-mor : IsGSetMorphism g)
      → f ≡ g
      → _≡_ {A = GSetMorphism}
        (f , f-mor)
        (g , g-mor)
    gsetmorphism-equality hY {f} f-mor g-mor refl =
      ap (λ m → (f , m)) (h1⇒prop (is-mset-morphism-level G hY f) _ _)

  module _ {j} (X : Set j) ⦃ xG : IsGSet X ⦄
               (Y : Set j) ⦃ yG : IsGSet Y ⦄ where
    𝑋 𝑌 : GSet j
    𝑋 = (X , xG)
    𝑌 = (Y , yG)

    X₀ Y₀ : GSet₀ j
    X₀ = ((X , IsMSet.mset-level xG) , _◂_)
    Y₀ = ((Y , IsMSet.mset-level yG) , _◂_)

    GSet-univalence : (𝑋 ≡ 𝑌)
                    ≅ (Σ (GSetMorphism X Y) λ { (f , _) → weak-equiv f })
    GSet-univalence = begin
        (𝑋 ≡ 𝑌)
      ≅⟨ iso≡ gset-struct-iso ·≅ sym≅ (subtype-equality gset₁-level) ⟩
        (X₀ ≡ Y₀)
      ≅⟨ sym≅ Σ-split-iso ⟩
        ( Σ (proj₁ X₀ ≡ proj₁ Y₀) λ p →
            subst (λ { (X , _) → G → X → X }) p (proj₂ X₀) ≡ proj₂ Y₀ )
      ≅⟨ ( Σ-ap-iso (sym≅ (subtype-equality λ X → hn-h1 2 X)) λ p
         → trans≡-iso (sym (subst-naturality (λ X → G → X → X)
                             proj₁ p (proj₂ X₀)))) ⟩
        ( Σ (X ≡ Y) λ p → subst (λ X → G → X → X) p (proj₂ X₀) ≡ proj₂ Y₀ )
      ≅⟨ Σ-ap-iso refl≅ (λ p → sym≅ (lem₁ p _ _)) ⟩
        ( Σ (X ≡ Y) λ p → ∀ g w → coerce p (proj₂ X₀ g w)
                                ≡ proj₂ Y₀ g (coerce p w) )
      ≅⟨ ( Σ-ap-iso uni-iso λ p → refl≅ ) ⟩
        ( Σ (X ≈ Y) λ f → ∀ g w → apply≈ f (proj₂ X₀ g w)
                                ≡ proj₂ Y₀ g (apply≈ f w))
      ≅⟨  record
            { to = λ { ((f , we), mor) → ((f , mor) , we) }
            ; from = λ { ((f , mor) , we) → ((f , we) , mor) }
            ; iso₁ = λ _ → refl
            ; iso₂ = λ _ → refl } ⟩
        (Σ (GSetMorphism X Y) λ { (f , _) → weak-equiv f })
      ∎
      where
        open ≅-Reasoning

        lem₁ : {U V : Set j}(p : U ≡ V)
             → (act : G → U → U)
             → (act' : G → V → V)
             → (∀ g u → coerce p (act g u) ≡ act' g (coerce p u))
             ≅ (subst (λ { X → G → X → X }) p act ≡ act')
        lem₁ refl act act' = (Π-ap-iso refl≅ λ g → strong-funext-iso)
          ·≅ strong-funext-iso

  instance
    GisGSet : IsGSet G
    GisGSet = record
      { _◂_ = _*_
      ; ◂-hom = assoc
      ; ◂-id = lunit
      ; mset-level = is-set }

  module _ {j} {X : Set j} (hX : h 2 X) ⦃ xG : IsGSet X ⦄ where
    GSet-repr : (ϕ : G → X) → IsGSetMorphism ϕ
              → (g : G) → ϕ g ≡ g ◂ ϕ e
    GSet-repr ϕ ϕ-mor g = ap ϕ (sym (runit g)) · ϕ-mor g e

    GSet-repr-iso : GSetMorphism G X ≅ X
    GSet-repr-iso = iso f g α β
      where
        f : GSetMorphism G X → X
        f (ϕ , _) = ϕ e

        g : X → GSetMorphism G X
        g x = (ϕ , ϕ-mor)
          where
            ϕ : G → X
            ϕ g = g ◂ x

            ϕ-mor : IsGSetMorphism ϕ
            ϕ-mor g₁ g₂ = ◂-hom g₁ g₂ x

        α : (ϕ : GSetMorphism G X) → g (f ϕ) ≡ ϕ
        α (ϕ , ϕ-mor) = gsetmorphism-equality G X hX _ _
          (funext λ g → sym (GSet-repr ϕ ϕ-mor g))

        β : (x : X) → f (g x) ≡ x
        β x = (IsMSet.◂-id xG) x


data Tree : Set where
  leaf : Tree
  _∣_ : Tree → Tree → Tree

{-# FOREIGN GHC data Tree = Leaf | Tree :| Tree #-}

{-# COMPILE GHC Tree = data Tree (Leaf | (:|)) #-}


open import ExtractSac as ES using ()
open import Extract (ES.kompile-fun)

open import Data.Nat as N using (ℕ; zero; suc; _≤_; _≥_; _<_; s≤s; z≤n)
import      Data.Nat.DivMod as N
open import Data.Nat.Properties as N
open import Data.List as L using (List; []; _∷_)
open import Data.Vec as V using (Vec; []; _∷_)
import      Data.Vec.Properties as V
open import Data.Fin using (Fin; zero; suc; #_)
open import Data.Product as Prod using (Σ; _,_; curry; uncurry) renaming (_×_ to _⊗_)

open import Relation.Binary.PropositionalEquality

open import Reflection

open import Structures
open import Function

open import Array.Base
open import Array.Properties

open import APL2

open import Agda.Builtin.Float

v→a : ∀ {a}{X : Set a}{n} → Vec X n → Ar X 1 (n ∷ [])
v→a s = imap (λ iv → V.lookup s $ ix-lookup iv zero )

a→v : ∀ {a}{X : Set a}{s} → Ar X 1 (s ∷ []) → Vec X s
a→v (imap x) = V.tabulate λ i → x (i ∷ [])

-- blog←{⍺×⍵×1-⍵}
blog : ∀ {n s} → Ar Float n s → Ar Float n s → Ar Float n s
blog α ω = α ×ᵣ ω ×ᵣ 1.0 -ᵣ ω

test-blog = a→v $ blog (v→a $ 3.0 ∷ 4.0 ∷ []) (v→a $ 5.0 ∷ 6.0 ∷ [])

kblog = kompile blog [] []
test₃₆ : kblog ≡ ok _
test₃₆ = refl

-- backbias←{+/,⍵}
backbias : ∀ {n s} → Ar Float n s → Scal Float
backbias ω = --(▾_ ∘₂ _+ᵣ_) / , ω
             _+ᵣ′_ / , ω
  where
    --_+ᵣ′_ : Float → Float → Float
    --a +ᵣ′ b = ▾ (a +ᵣ b)

    _+ᵣ′_ = primFloatPlus

kbackbias = kompile backbias (quote prod ∷ []) (quote prod ∷ quote off→idx ∷ quote reduce-custom.reduce-1d ∷ [])
--test₃₇ : kbackbias ≡ ok _
--test₃₇ = refl

-- logistic←{÷1+*-⍵}
logistic : ∀ {n s} → Ar Float n s → Ar Float n s
logistic ω = ÷ᵣ 1.0 +ᵣ *ᵣ -ᵣ ω

klogistic = kompile logistic [] []
test₃₈ : klogistic ≡ ok _
test₃₈ = refl

-- meansqerr←{÷∘2+/,(⍺-⍵)*2}
meansqerr : ∀ {n s} → Ar Float n s → Ar Float n s → Scal Float
meansqerr α ω = _÷ᵣ 2.0 $ _+ᵣ′_ / , (α +ᵣ ω) ×ᵣ (α -ᵣ ω)
  where
    _+ᵣ′_ = primFloatPlus

kmeansqerr = kompile meansqerr (quote prod ∷ []) (quote prod ∷ quote off→idx ∷ quote reduce-custom.reduce-1d ∷ [])
test₃₉ : klogistic ≡ ok _
test₃₉ = refl

-- backavgpool←{2⌿2/⍵÷4}⍤2
backavgpool : ∀ {s} → Ar Float 2 s → Ar Float 2 $ ▾ (2 × s)
backavgpool {s = _ ∷ _ ∷ []} ω = 2 /ᵣ′ 2 ⌿ᵣ ω ×ᵣ 4.0
  where
    infixr 20 _/ᵣ′_
    _/ᵣ′_ = _/ᵣ_ {s = _ ∷ []}

kbackavgpool = kompile backavgpool [] []
test₄₀ : kbackavgpool ≡ ok _
test₄₀ = refl

-- Something that could go in Stdlib.
≡⇒≤ : ∀ {a b} → a ≡ b → a N.≤ b
≡⇒≤ refl = ≤-refl

-- This should be perfectly generaliseable --- instead of 2
-- we can use any m>0
a<b⇒k<2⇒a*2+k<b*2 : ∀ {a b k} → a N.< b → k N.< 2 → a N.* 2 N.+ k N.< b N.* 2
a<b⇒k<2⇒a*2+k<b*2 {a} {b} {zero} a<b k<2
                  rewrite (+-identityʳ (a N.* 2))
                        | (*-comm a 2)
                        | (*-comm b 2) = *-monoʳ-< 1 a<b
a<b⇒k<2⇒a*2+k<b*2 {a} {b} {suc zero} a<b k<2 = ≤-trans (N.s≤s (≡⇒≤ (+-comm _ 1)))
                                                        (*-monoˡ-≤ 2 a<b)
a<b⇒k<2⇒a*2+k<b*2 {a} {b} {suc (suc k)} a<b (N.s≤s (N.s≤s ()))

A<B⇒K<2⇒A*2+K<B*2 : ∀ {n s}{a b k : Ar ℕ n s} → a <a b → k <a (cst 2) → ((a × 2) + k) <a (b × 2)
A<B⇒K<2⇒A*2+K<B*2 {a = imap a} {imap b} {imap k} a<b k<2 = λ iv → a<b⇒k<2⇒a*2+k<b*2 (a<b iv) (k<2 iv)

avgpool : ∀ {s}
        → Ar Float 2 $ ▾ (s × 2)
        → Ar Float 2 s
avgpool {s} (imap p) = imap body
  where
    body : _ → _
    body iv = ▾ (_÷ᵣ 4.0 $ _+ᵣ′_ / , f ̈ ι [2,2])
      where
         [2,2] = cst {s = 2 ∷ []} 2
         f : _ → _
         f (i , pf) = let ix , ix<s = ix→a iv in
                      p $ a→ix ((ix × 2) + i) (s × 2) $ A<B⇒K<2⇒A*2+K<B*2 ix<s pf
         _+ᵣ′_ = primFloatPlus

kavgpool = kompile avgpool [] []

open import ReflHelper
fin-id : ∀ {n} → Fin n → Fin n
fin-id x = x


------------------------------------------------------------------------
-- Fixity and associativity
------------------------------------------------------------------------

module RecursiveDescent.Hybrid.Mixfix.Fixity where

open import Data.Fin using (Fin; zero; suc; #_)
open import Data.Fin.Props using (eq?)
open import Relation.Nullary
open import Relation.Binary
open import Relation.Binary.PropositionalEquality

data Associativity : Set where
  left  : Associativity
  right : Associativity
  non   : Associativity

-- A combination of fixity and associativity. Only infix operators
-- have associativity.

-- Note that infix is a reserved word.

data Fixity : Set where
  prefx  : Fixity
  infx   : (assoc : Associativity) -> Fixity
  postfx : Fixity
  closed : Fixity

Fixity-is-finite : LeftInverse Fixity (Fin 6)
Fixity-is-finite = record
  { from         = from
  ; to           = to
  ; left-inverse = left-inverse
  }
  where
  to : Fixity -> Fin 6
  to prefx        = # 0
  to (infx left)  = # 1
  to (infx right) = # 2
  to (infx non)   = # 3
  to postfx       = # 4
  to closed       = # 5

  from : Fin 6 -> Fixity
  from zero                                   = prefx
  from (suc zero)                             = infx left
  from (suc (suc zero))                       = infx right
  from (suc (suc (suc zero)))                 = infx non
  from (suc (suc (suc (suc zero))))           = postfx
  from (suc (suc (suc (suc (suc zero)))))     = closed
  from (suc (suc (suc (suc (suc (suc ()))))))

  left-inverse : from LeftInverseOf to
  left-inverse prefx        = refl
  left-inverse (infx left)  = refl
  left-inverse (infx right) = refl
  left-inverse (infx non)   = refl
  left-inverse postfx       = refl
  left-inverse closed       = refl

_≟_ : Decidable (_≡_ {Fixity})
_≟_ = eq? injection
  where open LeftInverse Fixity-is-finite


{-# OPTIONS -v tc.size:100 #-}
-- {-# OPTIONS -v tc.meta:100 #-}

open import Common.Size using (Size; Size<_)

postulate
  A : Set

record R (i₀ : Size) (x : A) : Set where
  coinductive
  field
    force : (j : Size< i₀) → R j x

postulate
  P : (A → Set) → Set
  f : (Q : A → Set) (x : A) {{ c : P Q }} → Q x → Q x
  g : (i₁ : Size) (x : A) → R i₁ x → R i₁ x

  instance
    c : {i₂ : Size} → P (R i₂)

accepted rejected : A → (x : A) (i₃ : Size) → R i₃ x → R i₃ x

accepted y x i r = g _ _ (f _ _ r)

rejected y x i r = g _ _ (f _ x r)


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

open import Agda.Primitive
open import Prelude
import GSeTT.Typed-Syntax
import Globular-TT.Syntax

{- Disk and Sphere contexts - properties -}
module Globular-TT.Disks {l} (index : Set l) (rule : index → GSeTT.Typed-Syntax.Ctx × (Globular-TT.Syntax.Pre-Ty index)) (eqdec-index : eqdec index) where
  open import Globular-TT.Syntax index
  open import Globular-TT.Rules index rule
  open import Globular-TT.CwF-Structure index rule
  open import Globular-TT.Uniqueness-Derivations index rule eqdec-index
  open import Globular-TT.Typed-Syntax index rule eqdec-index

  {- Definition of "universal source and target variables" -}
  n-src : ℕ → ℕ
  n-tgt : ℕ → ℕ
  n⇒ : ℕ → Pre-Ty

  n-src O = O
  n-src (S n) = S (n-tgt n)
  n-tgt n = S (n-src n)

  n⇒ O = ∗
  n⇒ (S n) = ⇒ (n⇒ n) (Var (n-src n)) (Var (n-tgt  n))

  dim⇒ : ∀ (n : ℕ) → dim (n⇒ n) == n
  dim⇒ O = idp
  dim⇒ (S n) = S= (dim⇒ n)

  {- Syntactic definition of disks and spheres -}
  Pre-𝕊 : ℕ → Pre-Ctx
  Pre-𝔻 : ℕ → Pre-Ctx

  Pre-𝕊 O = ⊘
  Pre-𝕊 (S n) = (Pre-𝔻 n) ∙ C-length (Pre-𝔻 n) # n⇒ n
  Pre-𝔻 n = (Pre-𝕊 n) ∙ C-length (Pre-𝕊 n) # n⇒ n

  𝕊-length : ∀ n → C-length (Pre-𝕊 n) == n-src n
  𝕊-length O = idp
  𝕊-length (S n) = S= (S= (𝕊-length n))
  {-# REWRITE 𝕊-length #-}

  {- Disk and Sphere context are valid -}
  𝕊⊢ : ∀ n → Pre-𝕊 n ⊢C
  𝔻⊢ : ∀ n → Pre-𝔻 n ⊢C
  𝕊⊢⇒ : ∀ n → Pre-𝕊 n ⊢T n⇒ n

  𝕊⊢ O = ec
  𝕊⊢ (S n) = cc (𝔻⊢ n) (wkT (𝕊⊢⇒ n) (𝔻⊢ n)) idp
  𝔻⊢ n = cc (𝕊⊢ n) (𝕊⊢⇒ n) idp

  𝕊⊢⇒ O = ob ec
  𝕊⊢⇒ (S n) = ar (wkT (wkT (𝕊⊢⇒ n) (𝔻⊢ n)) (𝕊⊢ (S n))) (wkt (var (𝔻⊢ n) (inr (((𝕊-length n) ^) , idp))) (𝕊⊢ (S n))) (var (𝕊⊢ (S n)) (inr ((S= (𝕊-length n) ^) , idp)))

  𝕊 : ℕ → Ctx
  𝕊 n = Pre-𝕊 n , 𝕊⊢ n

  𝔻 : ℕ → Ctx
  𝔻 n = Pre-𝔻 n , 𝔻⊢ n

  Ty-n : ∀ {Γ} → Σ ℕ (λ n →  Sub Γ (𝕊 n)) → Ty Γ
  Ty-n {Γ} (n , (γ , Γ⊢γ:Sn) ) = ((n⇒ n)[ γ ]Pre-Ty) , ([]T (𝕊⊢⇒ n) Γ⊢γ:Sn)

  private
    Pre-χ : Pre-Ty → Pre-Sub

    Pre-χ ∗ = <>
    Pre-χ (⇒ A t u) = < < Pre-χ A , n-src (dim A) ↦ t > , n-tgt (dim A) ↦ u >

    χ_⊢ : ∀ {Γ A} → (Γ⊢A : Γ ⊢T A) → Γ ⊢S (Pre-χ A) > Pre-𝕊 (dim A)
    ⇒[χ_] : ∀ {Γ A} → (Γ⊢A : Γ ⊢T A) → A == ((n⇒  (dim A))[ Pre-χ A ]Pre-Ty)

    χ ob Γ⊢ ⊢ = es Γ⊢
    χ_⊢ {Γ} {⇒ A t u} (ar Γ⊢A Γ⊢t:A Γ⊢u:A) =
      let Γ⊢χt = sc χ Γ⊢A ⊢ (𝔻⊢ (dim A)) (trT (⇒[χ Γ⊢A ]) Γ⊢t:A) idp in
      sc Γ⊢χt (𝕊⊢ (S (dim A))) (trT (⇒[χ Γ⊢A ] >> (wk[]T (𝕊⊢⇒ (dim A)) Γ⊢χt ^)) Γ⊢u:A) idp

    ⇒[χ_] {Γ} {.∗} (ob _) = idp
    ⇒[χ_] {Γ} {(⇒ A t u)} (ar Γ⊢A Γ⊢t:A Γ⊢u:A) with eqdecℕ (n-src (dim A)) (n-tgt (dim A)) | eqdecℕ (n-src (dim A)) (n-src (dim A)) | eqdecℕ (S (n-src (dim A))) (S (n-src (dim A)))
    ...                                     | inl contra | _ | _ = ⊥-elim (n≠Sn _ contra)
    ...                                     | inr _ | inr n≠n | _ = ⊥-elim (n≠n idp)
    ...                                     | inr _ | inl _ | inr n≠n = ⊥-elim (n≠n idp)
    ...                                     | inr _ | inl _ | inl _ =
      let Γ⊢χt = (sc χ Γ⊢A ⊢ (𝔻⊢(dim A)) (trT ⇒[χ Γ⊢A ] Γ⊢t:A) idp) in
      let A=⇒[γt] = ⇒[χ Γ⊢A ] >> (wk[]T (𝕊⊢⇒ (dim A)) Γ⊢χt ^) in
      ⇒= (A=⇒[γt] >> (wk[]T (wkT (𝕊⊢⇒ (dim A)) (𝔻⊢ (dim A))) (sc Γ⊢χt (𝕊⊢ (S (dim A))) (trT A=⇒[γt] Γ⊢u:A) idp) ^)) idp idp

    χ : ∀ {Γ} → Ty Γ → Σ ℕ λ n → Sub Γ (𝕊 n)
    χ (A , Γ⊢A) = dim A , (Pre-χ A , χ Γ⊢A ⊢)

    dim-Ty-n : ∀ {Γ} (n : ℕ) → (γ : Sub Γ (𝕊 n)) → dim (fst (Ty-n {Γ} (n , γ))) == n
    dim-Ty-n n (γ , Γ⊢γ:Sn) = dim[] (n⇒ n) γ >> (dim⇒ n)

    trS-sph : ∀ {Γ n m} → (p : n == m) → {γ : Sub Γ (𝕊 n)} → {δ : Sub Γ (𝕊 m)} → fst γ == fst δ → transport p γ == δ
    trS-sph {Γ} {n} {m} idp {γ} {δ} x = eqS {Γ} {𝕊 m} γ δ x

    lemma1 : ∀ t u γ n → (if n-src n ≡ S (n-src n) then u else (if n-src n ≡ n-src n then t else (Var (n-src n) [ γ ]Pre-Tm))) == t
    lemma1 t u γ n with eqdecℕ (n-src n) (S (n-src n))
    ... | inl n=Sn = ⊥-elim (n≠Sn _ (n=Sn))
    ... | inr _ with eqdecℕ (n-src n) (n-src n)
    ... | inl _ = idp
    ... | inr n≠n = ⊥-elim (n≠n idp)

    lemma2 : ∀ t u γ n → (if S (n-src n) ≡ S (n-src n) then u else (if S (n-src n) ≡ n-src n then t else (Var (S (n-src n)) [ γ ]Pre-Tm))) == u
    lemma2 t u γ n with eqdecℕ (S (n-src n)) (S (n-src n))
    ... | inl _ = idp
    ... | inr n≠n = ⊥-elim (n≠n idp)

    Pre-χTy-n : ∀ {Γ} (n : ℕ) → (γ : Sub Γ (𝕊 n)) → Pre-χ (fst (Ty-n {Γ} (n , γ))) == fst γ
    Pre-χTy-n O (.<> , (es _)) = idp
    Pre-χTy-n {Γ} (S n) (< < γ , _ ↦ t > , _ ↦ u > , (sc (sc Γ⊢γ:Sn _ Γ⊢t:A idp) _ Γ⊢u:A idp)) with eqdecℕ (n-src n) (S (n-src n)) | eqdecℕ (n-src n) (n-src n) | eqdecℕ (S (n-src n)) (S (n-src n))
    ...                                     | inl contra | _ | _ = ⊥-elim (n≠Sn _ contra)
    ...                                     | inr _ | inr n≠n | _ = ⊥-elim (n≠n idp)
    ...                                     | inr _ | inl _ | inr n≠n = ⊥-elim (n≠n idp)
    ...                                     | inr _ | inl _ | inl _ =
      let χTm-n = (sc Γ⊢γ:Sn (𝔻⊢ n) Γ⊢t:A idp) in
      <,>= (<,>= (ap Pre-χ (wk[]T (wkT (𝕊⊢⇒ n) (𝔻⊢ n)) (sc χTm-n (𝕊⊢ (S n)) Γ⊢u:A idp) >> wk[]T (𝕊⊢⇒ n) χTm-n) >> Pre-χTy-n {Γ} n (γ , Γ⊢γ:Sn))
           (ap n-src (dim[] (n⇒ n) _ >> (dim⇒ n))) (lemma1 t u γ n))
      (S= (ap n-src (dim[] (n⇒ n) _ >> (dim⇒ n))))
      (lemma2 t u γ n)

    χTy-n : ∀ {Γ} (n : ℕ) → (γ : Sub Γ (𝕊 n)) → χ {Γ} (Ty-n {Γ} (n , γ)) == (n , γ)
    χTy-n {Γ} n γ = Σ= (dim-Ty-n {Γ} n γ) (trS-sph {Γ} (dim-Ty-n {Γ} n γ) {snd (χ {Γ} (Ty-n {Γ} (n , γ)))} {γ} (Pre-χTy-n {Γ} n γ))

  Ty-classifier : ∀ Γ → is-equiv (Ty-n {Γ})
  is-equiv.g (Ty-classifier Γ) (A , Γ⊢A) = χ {Γ} (A , Γ⊢A)
  is-equiv.f-g (Ty-classifier Γ) (A , Γ⊢A) = Σ= (⇒[χ Γ⊢A ] ^) (has-all-paths-⊢T _ _)
  is-equiv.g-f (Ty-classifier Γ) (n , γ) = χTy-n {Γ} n γ
  is-equiv.adj (Ty-classifier Γ) (n , γ) = (is-prop-has-all-paths (is-set-Ty Γ _ _)) _ _


{-# OPTIONS --cubical-compatible #-}

postulate w/e : Set

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

data Square {A : Set} {a : A} : {b c d : A} (p : a == b) (q : c == d) (r : a == c) (s : b == d) → Set where
  ids : Square {a = a} idp idp idp idp

J1 : {A : Set} {a : A} {p : a == a} → Square p idp idp idp → Set
J1 ids = w/e

J2 : {A : Set} {a : A} {p : a == a} → Square idp p idp idp → Set
J2 ids = w/e

J3 : {A : Set} {a : A} {p : a == a} → Square idp idp p idp → Set
J3 ids = w/e

J4 : {A : Set} {a : A} {p : a == a} → Square idp idp idp p → Set
J4 ids = w/e


module Issue327 where

open import Common.Prelude
open import Common.Reflect

_==_ : QName → QName → Bool
_==_ = primQNameEquality

postulate
  Dec : Bool → Set
  _≟_ : (x y : QName) → Dec (x == y)

Foo : Set₁
Foo with quote Foo ≟ quote Foo
... | _ = Set


module para where

module Top (A B : Set) where

  module A (C D : Set) where
    postulate f : A -> B -> C -> D

  module B (E F : Set) = A F E renaming (f to j)

  postulate h : A -> B

  module C (G H : Set) where

    module D = B G H

    g' : A -> B
    g' = h

    g : A -> H -> G
    g x y = D.j x (h x) y

module Bottom where

  postulate
    Nat : Set
    zero : Nat

  module D = Top Nat Nat
  module C = D.C Nat Nat

  x : Nat
  x = C.g zero zero


{-# OPTIONS --safe --no-qualified-instances #-}
open import Data.List hiding (concat)

module JVM.Syntax.Labeling {ℓ} (T : Set ℓ) where

open import Relation.Unary hiding (_∈_; Empty)
open import Relation.Ternary.Core
open import Relation.Ternary.Data.Bigplus

open import Data.Sum
open import Data.Product

open import JVM.Model T

Labeling : T → Pred (List T) _
Labeling = λ τ → Bigplus (One τ)
  where open Disjoint


------------------------------------------------------------------------
-- INCREMENTAL λ-CALCULUS
--
-- Delta-observational equivalence - support for equational reasoning
------------------------------------------------------------------------
module Base.Change.Equivalence.EqReasoning where

open import Relation.Binary.PropositionalEquality
open import Base.Change.Algebra
open import Level
open import Data.Unit
open import Function

open import Base.Change.Equivalence.Base public

module _ {a} {A : Set a} {{ca : ChangeAlgebra A}} {x : A} where
  ------------------------------------------------------------------------
  -- Convenient syntax for equational reasoning

  import Relation.Binary.EqReasoning as EqR

  module ≙-Reasoning where
    open EqR (≙-setoid {x = x}) public
      renaming (_≈⟨_⟩_ to _≙⟨_⟩_)


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

module Data.List.Base where

open import Level
open import Agda.Builtin.List using (List; _∷_; []) public
open import Data.Nat.Base
open import Function
open import Strict
open import Data.Maybe using (Maybe; just; nothing; maybe)

foldr : (A → B → B) → B → List A → B
foldr f b [] = b
foldr f b (x ∷ xs) = f x (foldr f b xs)

foldrMay : (A → A → A) → List A → Maybe A
foldrMay f = foldr (λ x → just ∘ maybe x (f x)) nothing

foldl : (B → A → B) → B → List A → B
foldl f b [] = b
foldl f b (x ∷ xs) = foldl f (f b x) xs

foldl′ : (B → A → B) → B → List A → B
foldl′ f b [] = b
foldl′ f b (x ∷ xs) = let! z =! f b x in! foldl′ f z xs

foldr′ : (A → B → B) → B → List A → B
foldr′ f b [] = b
foldr′ f b (x ∷ xs) = f x $! foldr′ f b xs

infixr 5 _++_
_++_ : List A → List A → List A
xs ++ ys = foldr _∷_ ys xs

length : List A → ℕ
length = foldr (const suc) zero

concat : List (List A) → List A
concat = foldr _++_ []

concatMap : (A → List B) → List A → List B
concatMap f = foldr (λ x ys → f x ++ ys) []

map : (A → B) → List A → List B
map f = foldr (λ x xs → f x ∷ xs) []

take : ℕ → List A → List A
take zero _ = []
take (suc n) [] = []
take (suc n) (x ∷ xs) = x ∷ take n xs

_⋯_ : ℕ → ℕ → List ℕ
_⋯_ n = go n
  where
  go″ : ℕ → ℕ → List ℕ
  go′ : ℕ → ℕ → List ℕ

  go″ n zero = []
  go″ n (suc m) = go′ (suc n) m

  go′ n m = n ∷ go″ n m

  go : ℕ → ℕ → List ℕ
  go zero = go′ n
  go (suc n) zero = []
  go (suc n) (suc m) = go n m

replicate : A → ℕ → List A
replicate {A = A} x = go
  where
  go : ℕ → List A
  go zero = []
  go (suc n) = x ∷ go n


------------------------------------------------------------------------------
-- Totality properties respect to OrdTree
------------------------------------------------------------------------------

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

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

open import FOTC.Base
open import FOTC.Data.Bool.PropertiesI
open import FOTC.Data.Nat.Inequalities
open import FOTC.Data.Nat.Inequalities.PropertiesATP
open import FOTC.Data.Nat.List.Type
open import FOTC.Data.Nat.Type
open import FOTC.Program.SortList.SortList
open import FOTC.Program.SortList.Properties.Totality.BoolATP
open import FOTC.Program.SortList.Properties.Totality.TreeATP

------------------------------------------------------------------------------
-- Subtrees

-- If (node t₁ i t₂) is ordered then t₁ is ordered.
postulate leftSubTree-OrdTree : ∀ {t₁ i t₂} → Tree t₁ → N i → Tree t₂ →
                                OrdTree (node t₁ i t₂) → OrdTree t₁
{-# ATP prove leftSubTree-OrdTree &&-Bool &&-list₂-t le-ItemTree-Bool le-TreeItem-Bool ordTree-Bool #-}

-- If (node t₁ i t₂) is ordered then t₂ is ordered.
postulate rightSubTree-OrdTree : ∀ {t₁ i t₂} → Tree t₁ → N i → Tree t₂ →
                                 OrdTree (node t₁ i t₂) → OrdTree t₂
-- 2018-06-28: The ATPs could not prove the theorem (300 sec), but
-- Vampire 4.2.2, via `online-atps`, could prove it.
--
-- {-# ATP prove rightSubTree-OrdTree &&-Bool &&-list₂-t le-ItemTree-Bool le-TreeItem-Bool ordTree-Bool #-}

------------------------------------------------------------------------------
-- Helper functions

toTree-OrdTree-helper₁ : ∀ {i₁ i₂ t} → N i₁ → N i₂ → i₁ > i₂ →
                         Tree t →
                         ≤-TreeItem t i₁ →
                         ≤-TreeItem (toTree · i₂ · t) i₁
toTree-OrdTree-helper₁ {i₁} {i₂} .{nil} Ni₁ Ni₂ i₁>i₂ tnil t≤i₁ = prf
  where postulate prf : ≤-TreeItem (toTree · i₂ · nil) i₁
        {-# ATP prove prf x<y→x≤y #-}

toTree-OrdTree-helper₁ {i₁} {i₂} Ni₁ Ni₂ i₁>i₂ (ttip {j} Nj) t≤i₁ =
  case prf₁ prf₂ (x>y∨x≤y Nj Ni₂)
  where
  postulate prf₁ : j > i₂ → ≤-TreeItem (toTree · i₂ · tip j) i₁
  {-# ATP prove prf₁ x>y→x≰y x<y→x≤y #-}

  postulate prf₂ : j ≤ i₂ → ≤-TreeItem (toTree · i₂ · tip j) i₁
  {-# ATP prove prf₂ x<y→x≤y #-}

toTree-OrdTree-helper₁ {i₁} {i₂} Ni₁ Ni₂ i₁>i₂
                       (tnode {t₁} {j} {t₂} Tt₁ Nj Tt₂) t≤i₁ =
  case (prf₁ (toTree-OrdTree-helper₁ Ni₁ Ni₂ i₁>i₂ Tt₁
               (&&-list₂-t₁ (le-TreeItem-Bool Tt₁ Ni₁)
                            (le-TreeItem-Bool Tt₂ Ni₁)
                            (trans (sym (le-TreeItem-node t₁ j t₂ i₁)) t≤i₁))))

       (prf₂ (toTree-OrdTree-helper₁ Ni₁ Ni₂ i₁>i₂ Tt₂
               (&&-list₂-t₂ (le-TreeItem-Bool Tt₁ Ni₁)
                            (le-TreeItem-Bool Tt₂ Ni₁)
                            (trans (sym (le-TreeItem-node t₁ j t₂ i₁)) t≤i₁))))
       (x>y∨x≤y Nj Ni₂)
  where
  postulate prf₁ : ≤-TreeItem (toTree · i₂ · t₁) i₁ →
                   j > i₂ →
                   ≤-TreeItem (toTree · i₂ · node t₁ j t₂) i₁
  {-# ATP prove prf₁ x>y→x≰y &&-list₂-t le-TreeItem-Bool #-}

  postulate prf₂ : ≤-TreeItem (toTree · i₂ · t₂) i₁ →
                   j ≤ i₂ →
                   ≤-TreeItem (toTree · i₂ · node t₁ j t₂) i₁
  {-# ATP prove prf₂ &&-list₂-t le-TreeItem-Bool #-}

toTree-OrdTree-helper₂ : ∀ {i₁ i₂ t} → N i₁ → N i₂ → i₁ ≤ i₂ →
                         Tree t →
                         ≤-ItemTree i₁ t →
                         ≤-ItemTree i₁ (toTree · i₂ · t)
toTree-OrdTree-helper₂ {i₁} {i₂} .{nil} Ni₁ Ni₂ i₁≤i₂ tnil i₁≤t = prf
  where postulate prf : ≤-ItemTree i₁ (toTree · i₂ · nil)
        {-# ATP prove prf #-}

toTree-OrdTree-helper₂ {i₁} {i₂} Ni₁ Ni₂ i₁≤i₂ (ttip {j} Nj) i₁≤t =
  case prf₁ prf₂ (x>y∨x≤y Nj Ni₂)
  where
  postulate prf₁ : j > i₂ → ≤-ItemTree i₁ (toTree · i₂ · tip j)
  {-# ATP prove prf₁ x>y→x≰y #-}

  postulate prf₂ : j ≤ i₂ → ≤-ItemTree i₁ (toTree · i₂ · tip j)
  {-# ATP prove prf₂ #-}

toTree-OrdTree-helper₂ {i₁} {i₂} Ni₁ Ni₂ i₁≤i₂
                       (tnode {t₁} {j} {t₂} Tt₁ Nj Tt₂) i₁≤t =
  case (prf₁ (toTree-OrdTree-helper₂ Ni₁ Ni₂ i₁≤i₂ Tt₁
               (&&-list₂-t₁ (le-ItemTree-Bool Ni₁ Tt₁)
                            (le-ItemTree-Bool Ni₁ Tt₂)
                            (trans (sym (le-ItemTree-node i₁ t₁ j t₂)) i₁≤t))))

       (prf₂ (toTree-OrdTree-helper₂ Ni₁ Ni₂ i₁≤i₂ Tt₂
               (&&-list₂-t₂ (le-ItemTree-Bool Ni₁ Tt₁)
                            (le-ItemTree-Bool Ni₁ Tt₂)
                            (trans (sym (le-ItemTree-node i₁ t₁ j t₂)) i₁≤t))))
       (x>y∨x≤y Nj Ni₂)
  where
  postulate prf₁ : ≤-ItemTree i₁ (toTree · i₂ · t₁) →
                   j > i₂ →
                   ≤-ItemTree i₁ (toTree · i₂ · node t₁ j t₂)
  {-# ATP prove prf₁ x>y→x≰y &&-list₂-t le-ItemTree-Bool #-}

  postulate prf₂ : ≤-ItemTree i₁ (toTree · i₂ · t₂) →
                   j ≤ i₂ →
                   ≤-ItemTree i₁ (toTree · i₂ · node t₁ j t₂)
  {-# ATP prove prf₂ &&-list₂-t le-ItemTree-Bool #-}


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

module Algebra.Linear.Construct where

import Algebra.Linear.Construct.Vector
import Algebra.Linear.Construct.Matrix


open import Formalization.PredicateLogic.Signature

module Formalization.PredicateLogic.Syntax.Substitution (𝔏 : Signature) where
open Signature(𝔏)

open import Data.Boolean
open import Data.ListSized
import      Data.ListSized.Functions as List
open import Formalization.PredicateLogic.Syntax(𝔏)
open import Functional using (_∘_ ; _∘₂_ ; id ; apply)
open import Numeral.CoordinateVector as Vector using (Vector)
open import Numeral.Finite
open import Numeral.Natural
open import Syntax.Function
open import Type

private variable args n vars vars₁ vars₂ : ℕ

-- Substitutes the variables of a term by mapping every variable index to a term.
substituteTerm : Vector(vars₁)(Term(vars₂)) → Term(vars₁) → Term(vars₂)
substituteTerm₊ : Vector(vars₁)(Term(vars₂)) → List(Term(vars₁))(args) → List(Term(vars₂))(args)
substituteTerm  t (var v)    = Vector.proj t v
substituteTerm  t (func f x) = func f (substituteTerm₊ t x)
substituteTerm₊ t ∅        = ∅
substituteTerm₊ t (x ⊰ xs) = (substituteTerm t x) ⊰ (substituteTerm₊ t xs)

-- Adds a new untouched variable to a term mapper.
-- Example: termMapper𝐒(0 ↦ t0 ; 1 ↦ t1 ; 2 ↦ t2) = (0 ↦ var 0 ; 1 ↦ t0 ; 2 ↦ t1 ; 3 ↦ t2)
termMapper𝐒 : Vector(vars₁)(Term(vars₂)) → Vector(𝐒(vars₁))(Term(𝐒(vars₂)))
termMapper𝐒 = Vector.prepend(var 𝟎) ∘ Vector.map(substituteTerm(var ∘ 𝐒))

-- Substitutes the variables of a formula by mapping every variable index to a term.
substitute : Vector(vars₁)(Term(vars₂)) → Formula(vars₁) → Formula(vars₂)
substitute t (P $ x)  = P $ (substituteTerm₊ t x)
substitute t ⊤        = ⊤
substitute t ⊥        = ⊥
substitute t (φ ∧ ψ)  = (substitute t φ) ∧ (substitute t ψ)
substitute t (φ ∨ ψ)  = (substitute t φ) ∨ (substitute t ψ)
substitute t (φ ⟶ ψ)  = (substitute t φ) ⟶ (substitute t ψ)
substitute t (Ɐ φ)    = Ɐ(substitute (termMapper𝐒 t) φ)
substitute t (∃ φ)    = ∃(substitute (termMapper𝐒 t) φ)

-- Substitutes the most recent variable of a formula by mapping it to a term.
substitute0 : Term(vars) → Formula(𝐒(vars)) → Formula(vars)
substitute0 = substitute ∘ (t ↦ Vector.prepend t var)

-- Substitutes a single arbitrary variable of a formula by mapping it to a term.
-- Note: (substituteN 𝟎) normalizes to substitute0 because of the definition for Vector.insert.
substituteN : 𝕟₌(vars) → Term(vars) → Formula(𝐒(vars)) → Formula(vars)
substituteN n = substitute ∘ (t ↦ Vector.insert₊ n t var)

open import Data
open import Function.Equals
import      Function.Names as Names
import      Lvl
open import Relator.Equals
open import Relator.Equals.Proofs
open import Structure.Function
open import Structure.Operator
open import Syntax.Number

private variable ℓ : Lvl.Level
private variable A B : Type{ℓ}
private variable f g : A → B
private variable φ : Formula(vars)

termMapper𝐒-identity : (termMapper𝐒{vars₁ = vars} var ⊜ var)
_⊜_.proof termMapper𝐒-identity {x = 𝟎}   = [≡]-intro
_⊜_.proof termMapper𝐒-identity {x = 𝐒 v} = [≡]-intro

module _ {f g : 𝕟(vars₁) → Term(vars₂)} (eq : f ⊜ g) where
  termMapper𝐒-equal-functions : (termMapper𝐒 f ⊜ termMapper𝐒 g)
  _⊜_.proof termMapper𝐒-equal-functions {𝟎} = [≡]-intro
  _⊜_.proof termMapper𝐒-equal-functions {𝐒 v} rewrite _⊜_.proof eq{v} = [≡]-intro

  substituteTerm-equal-functions-raw : (substituteTerm f Names.⊜ substituteTerm g)
  substituteTerm₊-equal-functions-raw : (substituteTerm₊{args = args} f Names.⊜ substituteTerm₊ g)
  (substituteTerm-equal-functions-raw) {var x} = _⊜_.proof eq
  (substituteTerm-equal-functions-raw) {func f x}
    rewrite substituteTerm₊-equal-functions-raw {x = x}
    = [≡]-intro
  (substituteTerm₊-equal-functions-raw) {x = ∅}      = [≡]-intro
  (substituteTerm₊-equal-functions-raw) {x = x ⊰ xs}
    rewrite substituteTerm-equal-functions-raw {x}
    rewrite substituteTerm₊-equal-functions-raw {x = xs}
    = [≡]-intro
  substituteTerm-equal-functions : (substituteTerm f ⊜ substituteTerm g)
  substituteTerm-equal-functions = intro(\{x} → substituteTerm-equal-functions-raw{x})
  substituteTerm₊-equal-functions : (substituteTerm₊{args = args} f ⊜ substituteTerm₊ g)
  substituteTerm₊-equal-functions = intro substituteTerm₊-equal-functions-raw

substitute-equal-functions : (f ⊜ g) → (substitute f ⊜ substitute g)
substitute-equal-functions = intro ∘ p where
  p : (f ⊜ g) → (substitute f Names.⊜ substitute g)
  p eq {P $ x}
    rewrite _⊜_.proof (substituteTerm₊-equal-functions eq) {x}
    = [≡]-intro
  p eq {⊤}     = [≡]-intro
  p eq {⊥}     = [≡]-intro
  p eq {φ ∧ ψ}
    rewrite p eq {φ}
    rewrite p eq {ψ}
    = [≡]-intro
  p eq {φ ∨ ψ}
    rewrite p eq {φ}
    rewrite p eq {ψ}
    = [≡]-intro
  p eq {φ ⟶ ψ}
    rewrite p eq {φ}
    rewrite p eq {ψ}
    = [≡]-intro
  p eq {Ɐ φ}
    rewrite p (termMapper𝐒-equal-functions eq) {φ}
    = [≡]-intro
  p eq {∃ φ}
    rewrite p (termMapper𝐒-equal-functions eq) {φ}
    = [≡]-intro

substituteTerm-identity-raw : (substituteTerm{vars₁ = vars} var Names.⊜ id)
substituteTerm₊-identity-raw : (substituteTerm₊{vars₁ = vars}{args = args} var Names.⊜ id)
substituteTerm-identity-raw {x = var x}    = [≡]-intro
substituteTerm-identity-raw {x = func f x} rewrite substituteTerm₊-identity-raw{x = x} = [≡]-intro
substituteTerm₊-identity-raw {x = ∅} = [≡]-intro
substituteTerm₊-identity-raw {x = x ⊰ xs}
  rewrite substituteTerm-identity-raw{x = x}
  rewrite substituteTerm₊-identity-raw{x = xs}
  = [≡]-intro
substituteTerm-identity : (substituteTerm{vars₁ = vars} var ⊜ id)
substituteTerm-identity = intro substituteTerm-identity-raw
substituteTerm₊-identity : (substituteTerm₊{vars₁ = vars}{args = args} var ⊜ id)
substituteTerm₊-identity = intro substituteTerm₊-identity-raw

substitute-identity : (substitute{vars₁ = vars} var ⊜ id)
substitute-identity = intro p where
  p : (substitute{vars₁ = vars} var Names.⊜ id)
  p {x = P $ x} rewrite _⊜_.proof substituteTerm₊-identity {x} = [≡]-intro
  p {x = ⊤}     = [≡]-intro
  p {x = ⊥}     = [≡]-intro
  p {x = φ ∧ ψ} rewrite p {x = φ} rewrite p {x = ψ} = [≡]-intro
  p {x = φ ∨ ψ} rewrite p {x = φ} rewrite p {x = ψ} = [≡]-intro
  p {x = φ ⟶ ψ} rewrite p {x = φ} rewrite p {x = ψ} = [≡]-intro
  p {x = Ɐ φ}
    rewrite _⊜_.proof (substitute-equal-functions termMapper𝐒-identity) {φ}
    rewrite p {x = φ}
    = [≡]-intro
  p {x = ∃ φ}
    rewrite _⊜_.proof (substitute-equal-functions termMapper𝐒-identity) {φ}
    rewrite p {x = φ}
    = [≡]-intro

{-
test1 : ∀{t : Term(vars)}{n : 𝕟(𝐒(𝐒 vars))} → (termMapper𝐒 (introduceVar t) n ≡ introduceVar (termVar𝐒 t) n)
test1 {t = var 𝟎} {𝟎} = {!introduceVar(termVar𝐒{_}(?)) 0!}
test1 {t = var 𝟎} {𝐒 n} = {!termMapper𝐒(introduceVar(?)) 1!}
test1 {t = var (𝐒 v)}{n} = {!!}
test1 {t = func f x}{n} = {!!}

test : ∀{t}{φ : Formula(𝐒 vars)} → (substitute(introduceVar t) φ ≡ substitute0 t φ)
test {vars} {t} {P $ x} = {!!}
test {vars} {t} {⊤} = [≡]-intro
test {vars} {t} {⊥} = [≡]-intro
test {vars} {t} {φ ∧ ψ} rewrite test {vars}{t}{φ} rewrite test{vars}{t}{ψ} = [≡]-intro
test {vars} {t} {φ ∨ ψ} rewrite test {vars}{t}{φ} rewrite test{vars}{t}{ψ} = [≡]-intro
test {vars} {t} {φ ⟶ ψ} rewrite test {vars}{t}{φ} rewrite test{vars}{t}{ψ} = [≡]-intro
test {vars} {t} {Ɐ φ} = {!test{𝐒 vars}{termVar𝐒 t}{φ}!}
test {vars} {t} {∃ φ} = {!!}
-}


------------------------------------------------------------------------
-- Indexed containers
------------------------------------------------------------------------

-- Some parts are based on "Indexed containers" by Altenkirch, Ghani,
-- Hancock, McBride and Morris (JFP, 2015).

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

module Indexed-container where

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

open import Bijection equality-with-J as Bijection using (_↔_)
import Equivalence equality-with-J as Eq
open import Function-universe equality-with-J hiding (id; _∘_)
open import H-level.Closure equality-with-J
open import Surjection equality-with-J using (_↠_)
open import Univalence-axiom equality-with-J

open import Relation

------------------------------------------------------------------------
-- Containers

-- Doubly indexed containers.

record Container {ℓ} (I O : Type ℓ) : Type (lsuc ℓ) where
  constructor _◁_
  field
    Shape    : Rel ℓ O
    Position : ∀ {o} → Shape o → Rel ℓ I

-- Interpretation of containers.

⟦_⟧ : ∀ {ℓ₁ ℓ₂} {I O : Type ℓ₁} →
      Container I O → Rel ℓ₂ I → Rel (ℓ₁ ⊔ ℓ₂) O
⟦ S ◁ P ⟧ A = λ o → ∃ λ (s : S o) → P s ⊆ A

-- A map function.

map : ∀ {ℓ₁ ℓ₂ ℓ₃} {I O : Type ℓ₁} (C : Container I O)
        {A : Rel ℓ₂ I} {B : Rel ℓ₃ I} →
      A ⊆ B → ⟦ C ⟧ A ⊆ ⟦ C ⟧ B
map _ f (s , g) = (s , f ∘ g)

-- Functor laws.

map-id : ∀ {ℓ₁ ℓ₂} {I O : Type ℓ₁} {C : Container I O} {A : Rel ℓ₂ I} →
         _≡_ {A = ⟦ C ⟧ A ⊆ _} (map C id) id
map-id = refl

map-∘ : ∀ {ℓ₁ ℓ₂ ℓ₃ ℓ₄} {I O : Type ℓ₁} {C : Container I O}
          {D : Rel ℓ₂ I} {E : Rel ℓ₃ I} {F : Rel ℓ₄ I}
        (f : E ⊆ F) (g : D ⊆ E) →
        _≡_ {A = ⟦ C ⟧ D ⊆ _} (map C (f ∘ g)) (map C f ∘ map C g)
map-∘ _ _ = refl

-- A preservation lemma.

⟦⟧-cong : ∀ {k ℓ₁ ℓ₂ ℓ₃} {I O : Type ℓ₁} →
          Extensionality? k ℓ₁ (ℓ₁ ⊔ ℓ₂ ⊔ ℓ₃) →
          (C : Container I O) {A : Rel ℓ₂ I} {B : Rel ℓ₃ I} →
          (∀ {i} → A i ↝[ k ] B i) →
          (∀ {o} → ⟦ C ⟧ A o ↝[ k ] ⟦ C ⟧ B o)
⟦⟧-cong ext (S ◁ P) {A} {B} A↝B {o} =
  (∃ λ (s : S o) → P s ⊆ A)  ↝⟨ (∃-cong λ _ → ⊆-congʳ ext A↝B) ⟩□
  (∃ λ (s : S o) → P s ⊆ B)  □

-- The shapes of a container are in pointwise bijective correspondence
-- with the interpretation of the container applied to the constant
-- function yielding the unit type.
--
-- (This lemma was suggested to me by an anonymous reviewer of another
-- paper.)

Shape↔⟦⟧⊤ : ∀ {ℓ} {I O : Type ℓ} (C : Container I O) {o} →
            Container.Shape C o ↔ ⟦ C ⟧ (λ _ → ⊤) o
Shape↔⟦⟧⊤ C {o} =
  Shape C o                                         ↝⟨ inverse $ drop-⊤-right (λ _ → →-right-zero) ⟩
  (∃ λ (s : Shape C o) → ∃ (Position C s) → ⊤)      ↝⟨ ∃-cong (λ _ → currying) ⟩
  (∃ λ (s : Shape C o) → ∀ i → Position C s i → ⊤)  ↝⟨ ∃-cong (λ _ → inverse Bijection.implicit-Π↔Π) ⟩□
  (∃ λ (s : Shape C o) → Position C s ⊆ (λ _ → ⊤))  □
  where
  open Container

------------------------------------------------------------------------
-- Least fixpoints

mutual

  -- The least fixpoint of an indexed "endocontainer", expressed using
  -- sized types.

  μ : ∀ {ℓ} {X : Type ℓ} → Container X X → Size → Rel ℓ X
  μ C i = ⟦ C ⟧ (μ′ C i)

  data μ′ {ℓ} {X : Type ℓ}
          (C : Container X X) (i : Size) (x : X) : Type ℓ where
    ⟨_⟩ : {j : Size< i} → μ C j x → μ′ C i x

-- The least fixpoint μ C ∞ is pointwise logically equivalent to
-- μ′ C ∞.

μ⇔μ′ :
  ∀ {ℓ} {X : Type ℓ} {C : Container X X} {x : X} →
  μ C ∞ x ⇔ μ′ C ∞ x
μ⇔μ′ = record
  { to   = ⟨_⟩
  ; from = λ { ⟨ x ⟩ → x }
  }

-- The least fixpoint is a post-fixpoint.

μ-out :
  ∀ {ℓ} {X : Type ℓ} {C : Container X X} →
  μ C ∞ ⊆ ⟦ C ⟧ (μ C ∞)
μ-out {C = C} = map C (_⇔_.from μ⇔μ′)

-- The least fixpoint is a pre-fixpoint.

μ-in :
  ∀ {ℓ} {X : Type ℓ} {C : Container X X} →
  ⟦ C ⟧ (μ C ∞) ⊆ μ C ∞
μ-in {C = C} = map C (_⇔_.to μ⇔μ′)

-- The least fixpoint is smaller than or equal to every
-- pre-fixpoint.

fold :
  ∀ {ℓ₁ ℓ₂} {X : Type ℓ₁} (C : Container X X) {A : Rel ℓ₂ X} →
  ⟦ C ⟧ A ⊆ A →
  ∀ {i} → μ C i ⊆ A
fold C f a = f (map C (λ { ⟨ a ⟩ → fold C f a }) a)

------------------------------------------------------------------------
-- Greatest fixpoints

mutual

  -- The greatest fixpoint of an indexed "endocontainer", expressed
  -- using sized types.

  ν : ∀ {ℓ} {X : Type ℓ} → Container X X → Size → Rel ℓ X
  ν C i = ⟦ C ⟧ (ν′ C i)

  record ν′ {ℓ} {X : Type ℓ}
            (C : Container X X) (i : Size) (x : X) : Type ℓ where
    coinductive
    field
      force : {j : Size< i} → ν C j x

open ν′ public

-- The greatest fixpoint ν C ∞ is pointwise logically equivalent to
-- ν′ C ∞.

ν⇔ν′ :
  ∀ {ℓ} {X : Type ℓ} {C : Container X X} {x : X} →
  ν C ∞ x ⇔ ν′ C ∞ x
ν⇔ν′ = record
  { to   = λ { x .force → x }
  ; from = λ x → force x
  }

-- The greatest fixpoint ν C ∞ is a post-fixpoint.

ν-out :
  ∀ {ℓ} {X : Type ℓ} {i} {j : Size< i} (C : Container X X) →
  ν C i ⊆ ⟦ C ⟧ (ν C j)
ν-out C = map C (λ x → force x)

private

  ν-out-∞ :
    ∀ {ℓ} {X : Type ℓ} (C : Container X X) →
    ν C ∞ ⊆ ⟦ C ⟧ (ν C ∞)
  ν-out-∞ = ν-out

-- The greatest fixpoint is a pre-fixpoint.

ν-in :
  ∀ {ℓ} {X : Type ℓ} {i} (C : Container X X) →
  ⟦ C ⟧ (ν C i) ⊆ ν C i
ν-in C = map C (λ x → λ { .force → x })

-- The greatest fixpoint is greater than or equal to every
-- post-fixpoint.

unfold :
  ∀ {ℓ₁ ℓ₂} {X : Type ℓ₁} {A : Rel ℓ₂ X} {i} (C : Container X X) →
  A ⊆ ⟦ C ⟧ A → A ⊆ ν C i
unfold C f = map C (λ a → λ { .force → unfold C f a }) ∘ f

-- A generalisation of unfold with more sized types.

sized-unfold :
  ∀ {ℓ₁ ℓ₂} {X : Type ℓ₁} (C : Container X X) (A : Size → Rel ℓ₂ X) →
  (∀ {i} {j : Size< i} → A i ⊆ ⟦ C ⟧ (A j)) →
  ∀ {i} {j : Size< i} → A i ⊆ ν C j
sized-unfold C A f =
  map C (λ a → λ { .force → sized-unfold C A f a }) ∘ f

------------------------------------------------------------------------
-- Bisimilarity

-- A container corresponding to bisimilarity for a given container.

Bisimilarity :
  ∀ {ℓ} {X : Type ℓ} {C : Container X X} →
  let P = ∃ λ x → ν C ∞ x × ν C ∞ x in
  Container P P
Bisimilarity {C = C} =
  (λ { (_ , (s₁ , _) , (s₂ , _)) → s₁ ≡ s₂ })
    ◁
  (λ { {o = _ , (s₁ , f₁) , (s₂ , f₂)} eq (x , x₁ , x₂) →
       ∃ λ (p : Container.Position C s₁ x) →
       x₁ ≡ force (f₁ p)
         ×
       x₂ ≡ force (f₂ (subst (λ s → Container.Position C s x) eq p)) })

-- Bisimilarity for ν.

ν-bisimilar :
  ∀ {ℓ} {X : Type ℓ} {C : Container X X} {x} →
  Size → Rel₂ ℓ (ν C ∞ x)
ν-bisimilar i p = ν Bisimilarity i (_ , p)

ν′-bisimilar :
  ∀ {ℓ} {X : Type ℓ} {C : Container X X} {x} →
  Size → Rel₂ ℓ (ν′ C ∞ x)
ν′-bisimilar i (x , y) = ν′ Bisimilarity i (_ , force x , force y)

-- Lifts a family of binary relations from X to ⟦ C ⟧ X.

⟦_⟧₂ :
  ∀ {ℓ₁ ℓ₂} {I O : Type ℓ₁} {A : Rel ℓ₂ I} (C : Container I O) →
  (∀ {i} → Rel₂ ℓ₁ (A i)) →
  ∀ {o} → Rel₂ ℓ₁ (⟦ C ⟧ A o)
⟦ C ⟧₂ R ((s , f) , (t , g)) =
  ∃ λ (eq : s ≡ t) →
  ∀ {o} (p : Position C s o) →
  R (f p , g (subst (λ s → Position C s o) eq p))
  where
  open Container

-- An alternative characterisation of bisimilarity.

ν-bisimilar↔ :
  ∀ {k ℓ} {X : Type ℓ} {C : Container X X} {x i} →
  Extensionality? k ℓ ℓ →
  (x y : ν C ∞ x) →
  ν-bisimilar i (x , y) ↝[ k ] ⟦ C ⟧₂ (ν′-bisimilar i) (x , y)
ν-bisimilar↔ {C = C} {i = i} ext (s₁ , f₁) (s₂ , f₂) =

  ν-bisimilar i ((s₁ , f₁) , (s₂ , f₂))                             ↔⟨⟩

  (∃ λ (eq : s₁ ≡ s₂) →
   ∀ {x} →
   (∃ λ (p : Position C s₁ (proj₁ x)) →
      proj₁ (proj₂ x) ≡ force (f₁ p) ×
      proj₂ (proj₂ x) ≡
        force (f₂ (subst (λ s → Position C s (proj₁ x)) eq p))) →
   ν′ Bisimilarity i x)                                             ↝⟨ ∃-cong lemma ⟩

  (∃ λ (eq : s₁ ≡ s₂) →
   ∀ {x} (p : Position C s₁ x) →
   ν′-bisimilar i (f₁ p , f₂ (subst (λ s → Position C s x) eq p)))  ↔⟨⟩

  ⟦ C ⟧₂ (ν′-bisimilar i) ((s₁ , f₁) , (s₂ , f₂))                   □

  where
  open Container

  lemma = λ eq →

    (∀ {x} →
     (∃ λ (p : Position C s₁ (proj₁ x)) →
      proj₁ (proj₂ x) ≡ force (f₁ p) ×
      proj₂ (proj₂ x) ≡
        force (f₂ (subst (λ s → Position C s (proj₁ x)) eq p))) →
     ν′ Bisimilarity i x)                                                 ↔⟨ Bijection.implicit-Π↔Π ⟩

    (∀ x →
     (∃ λ (p : Position C s₁ (proj₁ x)) →
      proj₁ (proj₂ x) ≡ force (f₁ p) ×
      proj₂ (proj₂ x) ≡
        force (f₂ (subst (λ s → Position C s (proj₁ x)) eq p))) →
     ν′ Bisimilarity i x)                                                 ↝⟨ (∀-cong ext λ _ → from-isomorphism currying) ⟩

    (∀ x (p : Position C s₁ (proj₁ x)) →
     proj₁ (proj₂ x) ≡ force (f₁ p) ×
     proj₂ (proj₂ x) ≡
       force (f₂ (subst (λ s → Position C s (proj₁ x)) eq p)) →
     ν′ Bisimilarity i x)                                                 ↝⟨ (∀-cong ext λ _ → ∀-cong ext λ _ → from-isomorphism currying) ⟩

    (∀ x (p : Position C s₁ (proj₁ x)) →
     proj₁ (proj₂ x) ≡ force (f₁ p) →
     proj₂ (proj₂ x) ≡
       force (f₂ (subst (λ s → Position C s (proj₁ x)) eq p)) →
     ν′ Bisimilarity i x)                                                 ↔⟨ currying ⟩

    (∀ x yz (p : Position C s₁ x) →
     proj₁ yz ≡ force (f₁ p) →
     proj₂ yz ≡ force (f₂ (subst (λ s → Position C s x) eq p)) →
     ν′ Bisimilarity i (x , yz))                                          ↝⟨ (∀-cong ext λ _ → from-isomorphism Π-comm) ⟩

    (∀ x (p : Position C s₁ x) yz →
     proj₁ yz ≡ force (f₁ p) →
     proj₂ yz ≡ force (f₂ (subst (λ s → Position C s x) eq p)) →
     ν′ Bisimilarity i (x , yz))                                          ↝⟨ (∀-cong ext λ _ → ∀-cong ext λ _ → from-isomorphism currying) ⟩

    (∀ x (p : Position C s₁ x) y z →
     y ≡ force (f₁ p) →
     z ≡ force (f₂ (subst (λ s → Position C s x) eq p)) →
     ν′ Bisimilarity i (x , y , z))                                       ↝⟨ (∀-cong ext λ _ → ∀-cong ext λ _ → ∀-cong ext λ _ →
                                                                              from-isomorphism Π-comm) ⟩
    (∀ x (p : Position C s₁ x) →
     ∀ y → y ≡ force (f₁ p) →
     ∀ z → z ≡ force (f₂ (subst (λ s → Position C s x) eq p)) →
     ν′ Bisimilarity i (x , y , z))                                       ↝⟨ (∀-cong ext λ _ → ∀-cong ext λ _ →
                                                                              from-isomorphism $ inverse currying) ⟩
    (∀ x (p : Position C s₁ x) →
     (y : ∃ λ y → y ≡ force (f₁ p)) →
     ∀ z → z ≡ force (f₂ (subst (λ s → Position C s x) eq p)) →
     ν′ Bisimilarity i (x , proj₁ y , z))                                 ↝⟨ (∀-cong ext λ _ → ∀-cong ext λ _ → drop-⊤-left-Π ext (
                                                                              _⇔_.to contractible⇔↔⊤ $ singleton-contractible _)) ⟩
    (∀ x (p : Position C s₁ x) →
     ∀ z → z ≡ force (f₂ (subst (λ s → Position C s x) eq p)) →
     ν′ Bisimilarity i (x , force (f₁ p) , z))                            ↝⟨ (∀-cong ext λ _ → ∀-cong ext λ _ →
                                                                              from-isomorphism $ inverse currying) ⟩
    (∀ x (p : Position C s₁ x) →
     (z : ∃ λ z → z ≡ force (f₂ (subst (λ s → Position C s x) eq p))) →
     ν′ Bisimilarity i (x , force (f₁ p) , proj₁ z))                      ↝⟨ (∀-cong ext λ _ → ∀-cong ext λ _ → drop-⊤-left-Π ext (
                                                                              _⇔_.to contractible⇔↔⊤ $ singleton-contractible _)) ⟩
    (∀ x (p : Position C s₁ x) →
     ν′ Bisimilarity i
       (x , force (f₁ p)
          , force (f₂ (subst (λ s → Position C s x) eq p))))              ↔⟨ inverse $ Bijection.implicit-Π↔Π ⟩

    (∀ {x} (p : Position C s₁ x) →
     ν′ Bisimilarity i
       (x , force (f₁ p)
          , force (f₂ (subst (λ s → Position C s x) eq p))))              ↔⟨⟩

    (∀ {x} (p : Position C s₁ x) →
     ν′-bisimilar i (f₁ p , f₂ (subst (λ s → Position C s x) eq p)))      □

module Bisimilarity
         {ℓ} {X : Type ℓ} {C : Container X X} {x i}
         (x y : ν C ∞ x)
         where

  -- A "constructor".

  ⟨_,_,_,_⟩ :
    (eq : proj₁ x ≡ proj₁ y) →
    (∀ {o} (p : Container.Position C (proj₁ x) o) →
     ν′-bisimilar i
       ( proj₂ x p
       , proj₂ y (subst (λ s → Container.Position C s o) eq p)
       )) →
    ν-bisimilar i (x , y)
  ⟨_,_,_,_⟩ = curry $ _⇔_.from (ν-bisimilar↔ _ x y)

  -- A "projection".

  split : ν-bisimilar i (x , y) → ⟦ C ⟧₂ (ν′-bisimilar i) (x , y)
  split = ν-bisimilar↔ _ x y

-- Bisimilarity is reflexive.

reflexive-ν :
  ∀ {ℓ} {X : Type ℓ} {C : Container X X} {x} (x : ν C ∞ x) {i} →
  ν-bisimilar i (x , x)
reflexive-ν x =
  Bisimilarity.⟨ x , x , refl
               , (λ { p .force → reflexive-ν (force (proj₂ x p)) })
               ⟩

-- Bisimilarity is symmetric.

symmetric-ν :
  ∀ {ℓ} {X : Type ℓ} {C : Container X X} {x} (x y : ν C ∞ x) {i} →
  ν-bisimilar i (x , y) → ν-bisimilar i (y , x)
symmetric-ν x y bisim with Bisimilarity.split x y bisim
... | refl , bisim′ =
  Bisimilarity.⟨ y , x , refl
               , (λ { p .force →
                      symmetric-ν (force (proj₂ x p))
                                  (force (proj₂ y p))
                                  (force (bisim′ p)) })
               ⟩

-- Bisimilarity is transitive.

transitive-ν :
  ∀ {ℓ} {X : Type ℓ} {C : Container X X} {x} (x y z : ν C ∞ x) {i} →
  ν-bisimilar i (x , y) → ν-bisimilar i (y , z) →
  ν-bisimilar i (x , z)
transitive-ν x y z bisim₁ bisim₂ with Bisimilarity.split x y bisim₁
                                    | Bisimilarity.split y z bisim₂
... | refl , bisim₁′ | refl , bisim₂′ =
  Bisimilarity.⟨ x
               , z
               , refl
               , (λ { p .force →
                      transitive-ν
                        (force (proj₂ x p))
                        (force (proj₂ y p))
                        (force (proj₂ z p))
                        (force (bisim₁′ p))
                        (force (bisim₂′ p)) })
               ⟩

-- Extensionality for ν′ C: bisimilarity implies equality.
--
-- Note that I have not, at the time of writing, determined whether
-- this is a consistent assumption. Uses of this and similar
-- assumptions are tracked using the type system.

ν′-extensionality : ∀ {ℓ} {X : Type ℓ} → Container X X → Type ℓ
ν′-extensionality C =
  ∀ {x} {y z : ν′ C ∞ x} → ν′-bisimilar ∞ (y , z) → y ≡ z

-- The formulation of extensionality given above for ν′ can be used to
-- derive a form of extensionality for ν (in the presence of
-- extensionality for functions).

ν-extensionality :
  ∀ {ℓ} {X : Type ℓ} {C : Container X X} →
  Extensionality ℓ ℓ →
  ν′-extensionality C →
  ∀ {x} {y z : ν C ∞ x} → ν-bisimilar ∞ (y , z) → y ≡ z
ν-extensionality {C = C} ext ν′-ext
                 {y = y@(s , f₁)} {z = z@(.s , f₂)} bisim@(refl , _) =

                                                             $⟨ (λ _ → proj₂ $ Bisimilarity.split y z bisim) ⟩
  (∀ x (p : Position C s x) → ν′-bisimilar ∞ (f₁ p , f₂ p))  ↝⟨ (ν′-ext ∘_) ∘_ ⟩
  (∀ x (p : Position C s x) → f₁ p ≡ f₂ p)                   ↝⟨ implicit-extensionality ext ∘ (apply-ext ext ∘_) ⟩
  (λ {_} → f₁) ≡ f₂                                          ↝⟨ cong (s ,_) ⟩□
  y ≡ z                                                      □

  where
  open Container

------------------------------------------------------------------------
-- More properties related to ν and ν′

-- The greatest fixpoint is a fixpoint in a different sense
-- (assuming two kinds of extensionality and univalence).

ν-fixpoint :
  ∀ {ℓ} →
  Extensionality ℓ (lsuc ℓ) →
  Univalence ℓ →
  {X : Type ℓ} (C : Container X X) →
  ν′-extensionality C →
  ν C ∞ ≡ ⟦ C ⟧ (ν C ∞)
ν-fixpoint ext univ C ν′-ext =
  ν C ∞           ≡⟨⟩
  ⟦ C ⟧ (ν′ C ∞)  ≡⟨ cong ⟦ C ⟧ (apply-ext ext λ _ → ≃⇒≡ univ (Eq.↔⇒≃ ν′↔ν)) ⟩
  ⟦ C ⟧ (ν C ∞)   ∎
  where
  ν′↔ν : ∀ {x} → ν′ C ∞ x ↔ ν C ∞ x
  ν′↔ν = record
    { surjection = record
      { logical-equivalence = record
        { to   = λ x → force x
        ; from = λ x → record { force = x }
        }
      ; right-inverse-of = λ _ → refl
      }
    ; left-inverse-of = λ x →
        ν′-ext (record { force = reflexive-ν (force x) })
    }

-- The unfold function makes a certain diagram commute.

unfold-commute :
  ∀ {ℓ₁ ℓ₂} {X : Type ℓ₁} (C : Container X X) {A : Rel ℓ₂ X}
  (f : A ⊆ ⟦ C ⟧ A) →
  ∀ {i x} (a : A x) →
  ν-bisimilar i
    ( unfold C f a
    , ν-in C (map C (unfold C f) (f a))
    )
unfold-commute C f a =
  Bisimilarity.⟨ unfold C f a
               , ν-in C (map C (unfold C f) (f a))
               , refl
               , (λ { p .force →
                      reflexive-ν (unfold C f (proj₂ (f a) p)) })
               ⟩

-- A uniqueness property for unfold.

unfold-unique :
  ∀ {ℓ₁ ℓ₂} {X : Type ℓ₁} (C : Container X X) {A : Rel ℓ₂ X}
  (f : A ⊆ ⟦ C ⟧ A) (u : A ⊆ ν C ∞) {i} →
  (∀ {x} (a : A x) →
   ν-bisimilar i (u a , ν-in C (map C u (f a)))) →
  ∀ {x} (a : A x) → ν-bisimilar i (u a , unfold C f a)
unfold-unique C f u bisim a
  with Bisimilarity.split (u a) (ν-in C (map C u (f a))) (bisim a)
... | eq , bisim′ =
  Bisimilarity.⟨ u a
               , unfold C f a
               , eq
               , (λ { p .force →
                      let p′ = subst (λ s → Container.Position C s _)
                                     eq p in
                      transitive-ν
                        (force (proj₂ (u a) p))
                        (force (proj₂ (ν-in C (map C u (f a))) p′))
                        (force (proj₂ (unfold C f a) p′))
                        (force (bisim′ p))
                        (unfold-unique C f u bisim _) })
               ⟩

------------------------------------------------------------------------
-- An alternative definition of greatest fixpoints

-- The greatest fixpoint of an indexed "endocontainer" (parametrised
-- by a universe level).

gfp : ∀ {ℓ₁} ℓ₂ {X : Type ℓ₁} → Container X X → Rel (lsuc (ℓ₁ ⊔ ℓ₂)) X
gfp {ℓ₁} ℓ₂ {X} C x = ∃ λ (R : Rel (ℓ₁ ⊔ ℓ₂) X) → R ⊆ ⟦ C ⟧ R × R x

-- The greatest fixpoint is greater than or equal to every
-- sufficiently small post-fixpoint.

gfp-unfold :
  ∀ {ℓ₁ ℓ₂} ℓ₃ {X : Type ℓ₁} {C : Container X X} {A : Rel ℓ₂ X} →
  A ⊆ ⟦ C ⟧ A →
  A ⊆ gfp (ℓ₂ ⊔ ℓ₃) C
gfp-unfold {ℓ₁} ℓ₃ {C = C} {A} f a =
  ↑ (ℓ₁ ⊔ ℓ₃) ∘ A , map C lift ∘ f ∘ lower , lift a

-- The greatest fixpoint is a post-fixpoint.

gfp-out : ∀ {ℓ₁} ℓ₂ {X : Type ℓ₁} {C : Container X X} →
          gfp ℓ₂ C ⊆ ⟦ C ⟧ (gfp ℓ₂ C)
gfp-out ℓ₂ {C = C} (R , R⊆CR , Ri) =
  map C (λ Ri → R , (λ {_} → R⊆CR) , Ri) (R⊆CR Ri)

  -- It is possible to use gfp-unfold ℓ₂ R⊆CR as the second argument
  -- to map above. However, the extra lifting would break the proof
  -- gfp⊆ν∘ν⊆gfp given below.

-- The first definition of greatest fixpoints is contained in the
-- second one.

ν⊆gfp : ∀ {ℓ₁} ℓ₂ {X : Type ℓ₁} {C : Container X X} →
        ν C ∞ ⊆ gfp ℓ₂ C
ν⊆gfp ℓ₂ = gfp-unfold ℓ₂ (ν-out {i = ∞} _)

-- The second definition of greatest fixpoints is contained in the
-- first one.

gfp⊆ν : ∀ {ℓ₁} ℓ₂ {X : Type ℓ₁} {C : Container X X} {i} →
        gfp ℓ₂ C ⊆ ν C i
gfp⊆ν ℓ₂ = unfold _ (gfp-out ℓ₂)

-- Thus the two definitions of greatest fixpoints are pointwise
-- logically equivalent.

gfp⇔ν : ∀ {ℓ₁} ℓ₂ {X : Type ℓ₁} {C : Container X X} {i} →
        gfp ℓ₂ C i ⇔ ν C ∞ i
gfp⇔ν ℓ₂ = record
  { to   = gfp⊆ν ℓ₂
  ; from = ν⊆gfp ℓ₂
  }

-- The function gfp⊆ν is a left inverse of ν⊆gfp (up to pointwise
-- bisimilarity).

gfp⊆ν∘ν⊆gfp :
  ∀ {ℓ₁} ℓ₂ {X : Type ℓ₁} {C : Container X X} {x} (x : ν C ∞ x) {i} →
  ν-bisimilar i (gfp⊆ν ℓ₂ (ν⊆gfp ℓ₂ x) , x)
gfp⊆ν∘ν⊆gfp ℓ₂ {C = C} x =
  _⇔_.from (ν-bisimilar↔ _ (gfp⊆ν ℓ₂ (ν⊆gfp ℓ₂ x)) x)
    ( refl
    , (λ { p .force → gfp⊆ν∘ν⊆gfp ℓ₂ (force (proj₂ x p)) })
    )

-- There is a split surjection from the second definition of greatest
-- fixpoints to the first one (assuming two kinds of extensionality).

gfp↠ν :
  ∀ {ℓ₁} →
  Extensionality ℓ₁ ℓ₁ →
  ∀ ℓ₂ {X : Type ℓ₁} {C : Container X X} →
  ν′-extensionality C →
  ∀ {x} → gfp ℓ₂ C x ↠ ν C ∞ x
gfp↠ν ext ℓ₂ ν′-ext = record
  { logical-equivalence = gfp⇔ν ℓ₂
  ; right-inverse-of    = λ x →
      ν-extensionality ext ν′-ext (gfp⊆ν∘ν⊆gfp ℓ₂ x)
  }

-- The larger versions of gfp are logically equivalent to the smallest
-- one.

larger⇔smallest :
  ∀ {ℓ₁} ℓ₂ {X : Type ℓ₁} {C : Container X X} {x} →
  gfp ℓ₂ C x ⇔ gfp lzero C x
larger⇔smallest ℓ₂ {C = C} {x} =
  gfp ℓ₂ C x     ↝⟨ gfp⇔ν ℓ₂ ⟩
  ν C ∞ x        ↝⟨ inverse $ gfp⇔ν lzero ⟩□
  gfp lzero C x  □


{-# OPTIONS --cubical --no-import-sorts --safe #-}
module Cubical.Data.DiffInt.Base where

open import Cubical.Foundations.Prelude

open import Cubical.HITs.SetQuotients.Base

open import Cubical.Data.Sigma
open import Cubical.Data.Nat

rel : (ℕ × ℕ) → (ℕ × ℕ) → Type₀
rel (a₀ , b₀) (a₁ , b₁) = x ≡ y
  where
    x = a₀ + b₁
    y = a₁ + b₀

ℤ = (ℕ × ℕ) / rel

open import Cubical.Data.Nat.Literals public

instance
  fromNatDiffInt : HasFromNat ℤ
  fromNatDiffInt = record { Constraint = λ _ → Unit ; fromNat = λ n → [ n , 0 ] }

instance
  fromNegDiffInt : HasFromNeg ℤ
  fromNegDiffInt = record { Constraint = λ _ → Unit ; fromNeg = λ n → [ 0 , n ] }


module Logic.Linear.Properties where

open import Logic.Linear using
  (LinearProp; _⊢_; Proof
  ; _^⊥; _⊗_; _⊕_; _&_; _⅋_; _⊸_; _≡_; e!_; e?_
  ; ^⊥-i; ⊗-i; ⊕-i₁; ⊕-i₂; &-i; ⅋-i; e?-i₁; e?-i₂; e!-i; e?-e; swap
  )
open import Data.Nat using (ℕ; zero; suc)
open import Data.Fin using (Fin; zero; suc)
open import Data.Vec using (Vec; []; _∷_; _++_; map)

one : {n : ℕ} → Fin (suc (suc n))
one = suc zero
two : {n : ℕ} → Fin (suc (suc (suc n)))
two = suc one
three : {n : ℕ} → Fin (suc (suc (suc (suc n))))
three = suc two

-- Proof of distributivity of _⊗_ over _⊕_: p ⊗ (q ⊕ r) ≡ (p ⊗ q) ⊕ (p ⊗ r).
⊕⊗-distrib : ∀ {a}
             {A : Set a}
             (S : LinearProp A → Set a)
             {p q r : LinearProp A} →
             Proof S (p ⊗ (q ⊕ r) ≡ (p ⊗ q) ⊕ (p ⊗ r))
⊕⊗-distrib {_} {_} S {p} {q} {r} = &-i left⊸right right⊸left where
  left⊸right : S ⊢ (p ⊗ (q ⊕ r) ⊸ p ⊗ q ⊕ p ⊗ r ∷ [])
  left⊸right = ⅋-i (⅋-i (swap zero one q&r)) where
    q&r : S ⊢ (q ^⊥ & r ^⊥ ∷ p ^⊥ ∷ p ⊗ q ⊕ p ⊗ r ∷ [])
    q&r = &-i q-side r-side where
      q-side : S ⊢ (q ^⊥ ∷ p ^⊥ ∷ p ⊗ q ⊕ p ⊗ r ∷ [])
      q-side = swap one two (swap zero one disj)
        where
          conj : S ⊢ (p ⊗ q ∷ p ^⊥ ∷ q ^⊥ ∷ [])
          conj = ⊗-i (^⊥-i p) (^⊥-i q)
          disj : S ⊢ (p ⊗ q ⊕ p ⊗ r ∷ q ^⊥ ∷ p ^⊥ ∷ [])
          disj = ⊕-i₁ (swap one two conj)
      r-side : S ⊢ (r ^⊥ ∷ p ^⊥ ∷ p ⊗ q ⊕ p ⊗ r ∷ [])
      r-side = swap one two (swap zero one disj)
        where
          conj : S ⊢ (p ⊗ r ∷ p ^⊥ ∷ r ^⊥ ∷ [])
          conj = ⊗-i (^⊥-i p) (^⊥-i r)
          disj : S ⊢ (p ⊗ q ⊕ p ⊗ r ∷ r ^⊥ ∷ p ^⊥ ∷ [])
          disj = ⊕-i₂ (swap one two conj)
  right⊸left : S ⊢ (p ⊗ q ⊕ p ⊗ r ⊸ p ⊗ (q ⊕ r) ∷ [])
  right⊸left = ⅋-i (&-i q-side r-side) where
    q-side : S ⊢ (p ^⊥ ⅋ q ^⊥ ∷ p ⊗ (q ⊕ r) ∷ [])
    q-side = ⅋-i (swap one two (swap zero one conj)) where
      disj : S ⊢ (q ⊕ r ∷ q ^⊥ ∷ [])
      disj = ⊕-i₁ (^⊥-i q)
      conj : S ⊢ (p ⊗ (q ⊕ r) ∷ p ^⊥ ∷ q ^⊥ ∷ [])
      conj = ⊗-i (^⊥-i p) disj
    r-side : S ⊢ (p ^⊥ ⅋ r ^⊥ ∷ p ⊗ (q ⊕ r) ∷ [])
    r-side = ⅋-i (swap one two (swap zero one conj)) where
      disj : S ⊢ (q ⊕ r ∷ r ^⊥ ∷ [])
      disj = ⊕-i₂ (^⊥-i r)
      conj : S ⊢ (p ⊗ (q ⊕ r) ∷ p ^⊥ ∷ r ^⊥ ∷ [])
      conj = ⊗-i (^⊥-i p) disj

-- Proof of isomorphism of e!_ through _&_ and _⊗_: e! (p & q) ≡ (e! p) ⊗ (e! q).
e!-iso : ∀ {a}
         {A : Set a}
         (S : LinearProp A → Set a)
         {p q : LinearProp A} →
         Proof S (e! (p & q) ≡ (e! p) ⊗ (e! q))
e!-iso {_} {_} S {p} {q} = &-i left⊸right right⊸left where
  left⊸right : S ⊢ (e! (p & q) ⊸ e! p ⊗ e! q ∷ [])
  left⊸right = ⅋-i (e?-e (swap zero two conj)) where
    p-side : S ⊢ (p ∷ e? (p ^⊥ ⊕ q ^⊥) ∷ [])
    p-side = swap zero one (e?-i₂ disj) where
      disj : S ⊢ (p ^⊥ ⊕ q ^⊥ ∷ p ∷ [])
      disj = ⊕-i₁ (swap zero one (^⊥-i p))
    q-side : S ⊢ (q ∷ e? (p ^⊥ ⊕ q ^⊥) ∷ [])
    q-side = swap zero one (e?-i₂ disj) where
      disj : S ⊢ (p ^⊥ ⊕ q ^⊥ ∷ q ∷ [])
      disj = ⊕-i₂ (swap zero one (^⊥-i q))
    conj : S ⊢ (e! p ⊗ e! q ∷ e? (p ^⊥ ⊕ q ^⊥) ∷ e? (p ^⊥ ⊕ q ^⊥) ∷ [])
    conj = ⊗-i (e!-i p-side) (e!-i q-side)
  right⊸left : S ⊢ (e! p ⊗ e! q ⊸ e! (p & q) ∷ [])
  right⊸left = ⅋-i (⅋-i swapped) where
    p-side : S ⊢ (p ∷ e? (p ^⊥) ∷ e? (q ^⊥) ∷ [])
    p-side = swap zero two (e?-i₁ init) where
      init : S ⊢ (e? (p ^⊥) ∷ p ∷ [])
      init = e?-i₂ (swap zero one (^⊥-i p))
    q-side : S ⊢ (q ∷ e? (p ^⊥) ∷ e? (q ^⊥) ∷ [])
    q-side = swap zero one (swap one two (e?-i₁ init)) where
      init : S ⊢ (e? (q ^⊥) ∷ q ∷ [])
      init = e?-i₂ (swap zero one (^⊥-i q))
    conj : S ⊢ (p & q ∷ e? (p ^⊥) ∷ e? (q ^⊥) ∷ [])
    conj = &-i p-side q-side
    swapped : S ⊢ (e? (p ^⊥) ∷ e? (q ^⊥) ∷ e! (p & q) ∷ [])
    swapped = swap one two (swap zero one (e!-i conj))

-- Proof of mapping of _⊗_ and _⅋_: p ⊗ (q ⅋ r) ⊸ (p ⊗ q) ⅋ r.
⊗⅋-map : ∀ {a}
         {A : Set a}
         (S : LinearProp A → Set a)
         {p q r : LinearProp A} →
         Proof S (p ⊗ (q ⅋ r) ⊸ (p ⊗ q) ⅋ r)
⊗⅋-map {_} {_} S {p} {q} {r} = ⅋-i (⅋-i (swap zero two disj)) where
  pq-side : S ⊢ (q ^⊥ ∷ p ⊗ q ∷ p ^⊥ ∷ [])
  pq-side = swap zero one (swap one two (⊗-i (^⊥-i p) (^⊥-i q)))
  r-side : S ⊢ (r ^⊥ ∷ r ∷ [])
  r-side = swap zero one (^⊥-i r)
  conj : S ⊢ (q ^⊥ ⊗ r ^⊥ ∷ p ⊗ q ∷ p ^⊥ ∷ r ∷ [])
  conj = ⊗-i pq-side r-side
  disj : S ⊢ (p ⊗ q ⅋ r ∷ (q ^⊥ ⊗ r ^⊥) ∷ p ^⊥ ∷ [])
  disj = ⅋-i (swap one two (swap zero one (swap two three conj)))


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

open import HoTT
open import cohomology.Exactness
open import cohomology.Choice
open import cohomology.FunctionOver

module cohomology.Theory where

-- [i] for the universe level of the group
record CohomologyTheory i : Type (lsucc i) where
  field
    C : ℤ → Ptd i → Group i

  CEl : ℤ → Ptd i → Type i
  CEl n X = Group.El (C n X)

  Cid : (n : ℤ) (X : Ptd i) → CEl n X
  Cid n X = GroupStructure.ident (Group.group-struct (C n X))

  ⊙CEl : ℤ → Ptd i → Ptd i
  ⊙CEl n X = ⊙[ CEl n X , Cid n X ]

  field
    CF-hom : (n : ℤ) {X Y : Ptd i} → fst (X ⊙→ Y) → (C n Y →ᴳ C n X)

    CF-ident : (n : ℤ) {X : Ptd i}
      → CF-hom n {X} {X} (⊙idf X) == idhom (C n X)
    CF-comp : (n : ℤ) {X Y Z : Ptd i} (g : fst (Y ⊙→ Z)) (f : fst (X ⊙→ Y))
      → CF-hom n (g ⊙∘ f) == CF-hom n f ∘ᴳ CF-hom n g

  CF : (n : ℤ) {X Y : Ptd i} → fst (X ⊙→ Y) → CEl n Y → CEl n X
  CF n f = GroupHom.f (CF-hom n f)

  field
    C-abelian : (n : ℤ) (X : Ptd i) → is-abelian (C n X)

    C-Susp : (n : ℤ) (X : Ptd i) → C (succ n) (⊙Susp X) ≃ᴳ C n X

    C-SuspF : (n : ℤ) {X Y : Ptd i} (f : fst (X ⊙→ Y))
      → fst (C-Susp n X) ∘ᴳ CF-hom (succ n) (⊙susp-fmap f)
        == CF-hom n f ∘ᴳ fst (C-Susp n Y)

    C-exact : (n : ℤ) {X Y : Ptd i} (f : fst (X ⊙→ Y))
      → is-exact (CF-hom n (⊙cfcod' f)) (CF-hom n f)

    C-additive : (n : ℤ) {I : Type i} (Z : I → Ptd i)
      → ((W : I → Type i) → has-choice 0 I W)
      → is-equiv (GroupHom.f (Πᴳ-hom-in (CF-hom n ∘ ⊙bwin {X = Z})))

  {- Alternate form of suspension axiom naturality -}
  C-Susp-↓ : (n : ℤ) {X Y : Ptd i} (f : fst (X ⊙→ Y))
    → CF-hom (succ n) (⊙susp-fmap f) == CF-hom n f
      [ uncurry _→ᴳ_ ↓ pair×= (group-ua (C-Susp n Y)) (group-ua (C-Susp n X)) ]
  C-Susp-↓ n f =
    hom-over-isos $ function-over-equivs _ _ $ ap GroupHom.f (C-SuspF n f)

record OrdinaryTheory i : Type (lsucc i) where
  constructor ordinary-theory
  field
    cohomology-theory : CohomologyTheory i
  open CohomologyTheory cohomology-theory public
  field
    C-dimension : (n : ℤ) → n ≠ 0 → C n (⊙Lift ⊙S⁰) == 0ᴳ


------------------------------------------------------------------------
-- The Agda standard library
--
-- Vectors with fast append
------------------------------------------------------------------------

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

module Data.DifferenceVec where

open import Data.DifferenceNat
open import Data.Vec as V using (Vec)
open import Function
import Data.Nat.Base as N

infixr 5 _∷_ _++_

DiffVec : ∀ {ℓ} → Set ℓ → Diffℕ → Set ℓ
DiffVec A m = ∀ {n} → Vec A n → Vec A (m n)

[] : ∀ {a} {A : Set a} → DiffVec A 0#
[] = λ k → k

_∷_ : ∀ {a} {A : Set a} {n} → A → DiffVec A n → DiffVec A (suc n)
x ∷ xs = λ k → V._∷_ x (xs k)

[_] : ∀ {a} {A : Set a} → A → DiffVec A 1#
[ x ] = x ∷ []

_++_ : ∀ {a} {A : Set a} {m n} →
       DiffVec A m → DiffVec A n → DiffVec A (m + n)
xs ++ ys = λ k → xs (ys k)

toVec : ∀ {a} {A : Set a} {n} → DiffVec A n → Vec A (toℕ n)
toVec xs = xs V.[]

-- fromVec xs is linear in the length of xs.

fromVec : ∀ {a} {A : Set a} {n} → Vec A n → DiffVec A (fromℕ n)
fromVec xs = λ k → xs ⟨ V._++_ ⟩ k

head : ∀ {a} {A : Set a} {n} → DiffVec A (suc n) → A
head xs = V.head (toVec xs)

tail : ∀ {a} {A : Set a} {n} → DiffVec A (suc n) → DiffVec A n
tail xs = λ k → V.tail (xs k)

take : ∀ {a} {A : Set a} m {n} →
       DiffVec A (fromℕ m + n) → DiffVec A (fromℕ m)
take N.zero    xs = []
take (N.suc m) xs = head xs ∷ take m (tail xs)

drop : ∀ {a} {A : Set a} m {n} →
       DiffVec A (fromℕ m + n) → DiffVec A n
drop N.zero    xs = xs
drop (N.suc m) xs = drop m (tail xs)


------------------------------------------------------------------------
-- The Agda standard library
--
-- M-types (the dual of W-types)
------------------------------------------------------------------------

{-# OPTIONS --without-K --guardedness --sized-types #-}

module Codata.Musical.M where

open import Codata.Musical.Notation
open import Level
open import Data.Product hiding (map)
open import Data.Container.Core as C hiding (map)

-- The family of M-types.

data M {s p} (C : Container s p) : Set (s ⊔ p) where
  inf : ⟦ C ⟧ (∞ (M C)) → M C

-- Projections.

module _ {s p} (C : Container s p) where

  head : M C → Shape C
  head (inf (x , _)) = x

  tail : (x : M C) → Position C (head x) → M C
  tail (inf (x , f)) b = ♭ (f b)

-- map

module _ {s₁ s₂ p₁ p₂} {C₁ : Container s₁ p₁} {C₂ : Container s₂ p₂}
         (m : C₁ ⇒ C₂) where

  map : M C₁ → M C₂
  map (inf (x , f)) = inf (shape m x , λ p → ♯ map (♭ (f (position m p))))

-- unfold

module _ {s p ℓ} {C : Container s p} (open Container C)
         {S : Set ℓ} (alg : S → ⟦ C ⟧ S) where

  unfold : S → M C
  unfold seed = let (x , f) = alg seed in
                inf (x , λ p → ♯ unfold (f p))

------------------------------------------------------------------------
-- Legacy

import Codata.M as M
open import Codata.Thunk
import Size

module _ {s p} {C : Container s p} where

  fromMusical : ∀ {i} → M C → M.M C i
  fromMusical (inf t) = M.inf (C.map rec t) where
    rec = λ x → λ where .force → fromMusical (♭ x)

  toMusical : M.M C Size.∞ → M C
  toMusical (M.inf (s , f)) = inf (s , λ p → ♯ toMusical (f p .force))


module SizedPolyIO.Console where

open import Level using () renaming (zero to lzero)
open import Size

open import NativePolyIO
open import SizedPolyIO.Base

data ConsoleCommand : Set where
  putStrLn : String → ConsoleCommand
  getLine  : ConsoleCommand

ConsoleResponse : ConsoleCommand → Set
ConsoleResponse (putStrLn s) = Unit
ConsoleResponse  getLine     = String

consoleI : IOInterface lzero lzero
Command  consoleI  = ConsoleCommand
Response consoleI  = ConsoleResponse

IOConsole : Size → Set → Set
IOConsole i = IO consoleI i

IOConsole+ : Size → Set → Set
IOConsole+ i = IO+ consoleI i

translateIOConsoleLocal : (c : ConsoleCommand) → NativeIO (ConsoleResponse c)
translateIOConsoleLocal (putStrLn s) = nativePutStrLn s
translateIOConsoleLocal getLine      = nativeGetLine

translateIOConsole : {A : Set} → IOConsole ∞ A → NativeIO A
translateIOConsole = translateIO translateIOConsoleLocal

main : NativeIO (Unit {lzero})
main = nativePutStrLn "Console"


module Numeral.Finite.Oper.Comparisons.Proofs where

import      Lvl
open import Data
open import Data.Boolean
import      Data.Boolean.Operators
open        Data.Boolean.Operators.Programming
open import Logic.Propositional
open import Logic.Predicate
open import Numeral.Finite
open import Numeral.Finite.Oper.Comparisons
open import Numeral.Sign
open import Numeral.Sign.Oper0
open import Relator.Equals
open import Relator.Equals.Proofs.Equivalence
import      Structure.Operator.Names as Names
open import Structure.Operator.Properties
open import Syntax.Number

⋚-of-𝟎-not-+ : ∀{an bn}{b : 𝕟(bn)} → ⦃ _ : 𝟎 {an} ⋚? b ≡ ➕ ⦄ → ⊥
⋚-of-𝟎-not-+ {b = 𝟎}    ⦃ ⦄
⋚-of-𝟎-not-+ {b = 𝐒(_)} ⦃ ⦄

⋚-of-𝟎-not-− : ∀{an bn}{a : 𝕟(an)} → ⦃ _ : a ⋚? 𝟎 {bn} ≡ ➖ ⦄ → ⊥
⋚-of-𝟎-not-− {a = 𝟎}    ⦃ ⦄
⋚-of-𝟎-not-− {a = 𝐒(_)} ⦃ ⦄

⋚-of-𝐒𝟎-not-𝟎 : ∀{an bn}{a : 𝕟(an)} → ⦃ _ : 𝐒(a) ⋚? 𝟎 {bn} ≡ 𝟎 ⦄ → ⊥
⋚-of-𝐒𝟎-not-𝟎 {a = 𝟎}    ⦃ ⦄
⋚-of-𝐒𝟎-not-𝟎 {a = 𝐒(_)} ⦃ ⦄

⋚-of-𝟎𝐒-not-𝟎 : ∀{an bn}{b : 𝕟(bn)} → ⦃ _ : 𝟎 {an} ⋚? 𝐒(b) ≡ 𝟎 ⦄ → ⊥
⋚-of-𝟎𝐒-not-𝟎 {b = 𝟎}    ⦃ ⦄
⋚-of-𝟎𝐒-not-𝟎 {b = 𝐒(_)} ⦃ ⦄

⋚-surjective : ∀{an bn}{a : 𝕟(an)}{b : 𝕟(bn)} → ∃{Obj = (−|0|+)} (a ⋚? b ≡_)
⋚-surjective {a = 𝟎}   {𝟎}   = [∃]-intro 𝟎
⋚-surjective {a = 𝟎}   {𝐒 b} = [∃]-intro ➖
⋚-surjective {a = 𝐒 a} {𝟎}   = [∃]-intro ➕
⋚-surjective {a = 𝐒 a} {𝐒 b} = ⋚-surjective {a = a} {b}

⋚-to-< : ∀{an bn}{a : 𝕟(an)}{b : 𝕟(bn)} → ⦃ _ : a ⋚? b ≡ ➕ ⦄ → (a >? b ≡ 𝑇)
⋚-to-< {a = 𝐒 a} {𝟎} = [≡]-intro
⋚-to-< {a = 𝐒 a} {𝐒 b} = ⋚-to-< {a = a} {b}

⋚-to-> : ∀{an bn}{a : 𝕟(an)}{b : 𝕟(bn)} → ⦃ _ : a ⋚? b ≡ ➖ ⦄ → (a <? b ≡ 𝑇)
⋚-to-> {a = 𝟎}   {𝐒 b} = [≡]-intro
⋚-to-> {a = 𝐒 a} {𝐒 b} = ⋚-to-> {a = a} {b}

⋚-to-≡ : ∀{an bn}{a : 𝕟(an)}{b : 𝕟(bn)} → ⦃ _ : a ⋚? b ≡ 𝟎 ⦄ → (a ≡? b ≡ 𝑇)
⋚-to-≡ {a = 𝟎}   {𝟎}   = [≡]-intro
⋚-to-≡ {a = 𝐒 a} {𝐒 b} = ⋚-to-≡ {a = a} {b}

instance
  [≡?]-commutativity : ∀{n} → Commutativity{T₁ = 𝕟(n)} ⦃ [≡]-equiv ⦄ (_≡?_)
  [≡?]-commutativity{n} = intro(\{x y} → p{n}{x}{y}) where
    p : ∀{n} → Names.Commutativity{T₁ = 𝕟(n)} ⦃ [≡]-equiv ⦄ (_≡?_)
    p{_}{𝟎}  {𝟎}   = [≡]-intro
    p{_}{𝟎}  {𝐒 y} = [≡]-intro
    p{_}{𝐒 x}{𝟎}   = [≡]-intro
    p{_}{𝐒 x}{𝐒 y} = p{_}{x}{y}

⋚-anticommutativity : ∀{xn yn}{x : 𝕟(xn)}{y : 𝕟(yn)} → (−(x ⋚? y) ≡ y ⋚? x)
⋚-anticommutativity {x = 𝟎}  {y = 𝟎}   = [≡]-intro
⋚-anticommutativity {x = 𝟎}  {y = 𝐒 y} = [≡]-intro
⋚-anticommutativity {x = 𝐒 x}{y = 𝟎}   = [≡]-intro
⋚-anticommutativity {x = 𝐒 x}{y = 𝐒 y} = ⋚-anticommutativity {x = x}{y = y}

⋚-elim₃-negation-flip : ∀{xn yn}{x : 𝕟(xn)}{y : 𝕟(yn)}{b₁ b₂ b₃} → (elim₃{P = \_ → Bool} b₁ b₂ b₃ (−(x ⋚? y)) ≡ elim₃ b₃ b₂ b₁ (x ⋚? y))
⋚-elim₃-negation-flip {x = 𝟎}  {y = 𝟎}   = [≡]-intro
⋚-elim₃-negation-flip {x = 𝟎}  {y = 𝐒 y} = [≡]-intro
⋚-elim₃-negation-flip {x = 𝐒 x}{y = 𝟎}   = [≡]-intro
⋚-elim₃-negation-flip {x = 𝐒 x}{y = 𝐒 y} = ⋚-elim₃-negation-flip {x = x}{y = y}

⋚-elim₃-negation-distribution : ∀{xn yn}{x : 𝕟(xn)}{y : 𝕟(yn)}{b₁ b₂ b₃ : Bool} → (!(elim₃ b₁ b₂ b₃ (x ⋚? y)) ≡ elim₃ (! b₁) (! b₂) (! b₃) (x ⋚? y))
⋚-elim₃-negation-distribution {x = 𝟎}  {y = 𝟎}   = [≡]-intro
⋚-elim₃-negation-distribution {x = 𝟎}  {y = 𝐒 y} = [≡]-intro
⋚-elim₃-negation-distribution {x = 𝐒 x}{y = 𝟎}   = [≡]-intro
⋚-elim₃-negation-distribution {x = 𝐒 x}{y = 𝐒 y} = ⋚-elim₃-negation-distribution {x = x}{y = y}


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

   Copyright (c) 2020 Oracle and/or its affiliates.
   Licensed under the Universal Permissive License v 1.0 as shown at https://opensource.oracle.com/licenses/upl
-}
open import LibraBFT.Prelude

-- This module contains a model of a key-value store, along with its
-- functionality and various properties about it.  Most of the properties
-- are not currently used, but they are included here based on our
-- experience in other work, as we think many of them will be needed when
-- reasoning about an actual LibraBFT implementation.

-- Although we believe the assumptions here are reasonable, it is always
-- possible that we made a mistake in postulating one of the properties,
-- making it impossible to implement.  Thus, it would a useful contribution
-- to:
--
-- TODO-1: construct an actual implementation and provide and prove the
-- necessary properties to satisfy the requirements of this module
--
-- Note that this would require some work, but should be relatively
-- straightforward and requires only "local" changes.

module LibraBFT.Base.KVMap  where

 private
  variable
   Key : Set
   Val : Set

   k k' : Key
   v v' : Val

 postulate -- valid assumptions, but would be good to eliminate with a reference implementation (above)
   _≟Key_ : ∀ (k1 k2 : Key) → Dec (k1 ≡ k2)

   KVMap : Set → Set → Set

   _∈KV_          : Key → KVMap Key Val → Set
   _∈KV?_         : (k : Key) (kvm : KVMap Key Val) → Dec (k ∈KV kvm)
   ∈KV-irrelevant : (k : Key) (kvm : KVMap Key Val)
                  → (r s : k ∈KV kvm)
                  → r ≡ s

   -- functionality
   empty          : KVMap Key Val

   ∈KV-empty-⊥    : k ∈KV (empty {Val = Val}) → ⊥

   lookup         : Key → KVMap Key Val → Maybe Val
   kvm-insert     : (k : Key)(v : Val)(kvm : KVMap Key Val)
                  → lookup k kvm ≡ nothing
                  → KVMap Key Val

   -- TODO-3: update properties to reflect kvm-update, consider combining insert/update
   kvm-update     : (k : Key)(v : Val)(kvm : KVMap Key Val)
                  → lookup k kvm ≢ nothing
                  → KVMap Key Val

   kvm-size       : KVMap Key Val → ℕ
   -- TODO-1: add properties relating kvm-toList to empty, kvm-insert and kvm-update
   kvm-toList     : KVMap Key Val → List (Key × Val)
   kvm-toList-length : (kvm : KVMap Key Val)
                     → length (kvm-toList kvm) ≡ kvm-size kvm

   -- TODO-1: need properties showing that the resulting map contains (k , v) for
   --         each pair in the list, provided there is no pair (k , v') in the list
   --         after (k , v).  This is consistent with Haskell's Data.Map.fromList
   kvm-fromList   : List (Key × Val) → KVMap Key Val

   -- properties
   lookup-correct : {kvm : KVMap Key Val}
                  → (prf : lookup k kvm ≡ nothing)
                  → lookup k (kvm-insert k v kvm prf) ≡ just v

   lookup-correct-update
                  : {kvm : KVMap Key Val}
                  → (prf : lookup k kvm ≢ nothing)
                  → lookup k (kvm-update k v kvm prf) ≡ just v

   lookup-stable  : {kvm : KVMap Key Val}{k k' : Key}{v' : Val}
                  → (prf : lookup k kvm ≡ nothing)
                  → lookup k' kvm ≡ just v
                  → lookup k' (kvm-insert k v' kvm prf) ≡ just v

   insert-target  : {kvm : KVMap Key Val}
                  → (prf : lookup k kvm ≡ nothing)
                  → lookup k' kvm ≢ just v
                  → lookup k' (kvm-insert k v' kvm prf) ≡ just v
                  → k' ≡ k × v ≡ v'

   insert-target-≢ : {kvm : KVMap Key Val}{k k' : Key}
                   → (prf : lookup k kvm ≡ nothing)
                   → k' ≢ k
                   → lookup k' kvm ≡ lookup k' (kvm-insert k v kvm prf)

   update-target-≢  : {kvm : KVMap Key Val}
                  → ∀ {k1 k2 x}
                  → k2 ≢ k1
                  → lookup k1 kvm ≡ lookup k1 (kvm-update k2 v kvm x)

   kvm-empty      : lookup {Val = Val} k empty ≡ nothing

   kvm-empty-⊥    : {k : Key} {v : Val} → lookup k empty ≡ just v → ⊥

   KVM-extensionality : ∀ {kvm1 kvm2 : KVMap Key Val}
                      → (∀ (x : Key) → lookup x kvm1 ≡ lookup x kvm2)
                      → kvm1 ≡ kvm2

  -- Corollaries
 lookup-stable-1  : {kvm : KVMap Key Val}{k k' : Key}{v' : Val}
                  → (prf : lookup k kvm ≡ nothing)
                  → lookup k' kvm ≡ just v'
                  → lookup k' (kvm-insert k v kvm prf) ≡ lookup k' kvm
 lookup-stable-1 prf hyp = trans (lookup-stable prf hyp) (sym hyp)

 lookup-correct-update-2
                : {kvm : KVMap Key Val}
                → (prf : lookup k kvm ≢ nothing)
                → lookup k (kvm-update k v kvm prf) ≡ just v'
                → v ≡ v'
 lookup-correct-update-2 {kvm} prf lkup =
   just-injective
     (trans (sym (lookup-correct-update prf)) lkup)

 update-target  : {kvm : KVMap Key Val}
                → ∀ {k1 k2 x}
                → lookup k1 kvm ≢ lookup k1 (kvm-update k2 v kvm x)
                → k2 ≡ k1
 update-target {kvm = kvm}{k1 = k1}{k2 = k2}{x} vneq
    with k1 ≟Key k2
 ...| yes refl = refl
 ...| no  neq  = ⊥-elim (vneq (update-target-≢ {k1 = k1} {k2 = k2} (neq ∘ sym)))

 lookup-correct-update-3 : ∀ {kvm : KVMap Key Val}{k1 k2 v2}
                → (prf : lookup k2 kvm ≢ nothing)
                → lookup k2 kvm ≡ just v2
                → lookup k1 (kvm-update k2 v2 kvm prf) ≡ lookup k1 kvm
 lookup-correct-update-3 {kvm = kvm} {k1 = k1} {k2 = k2} {v2 = v2} prf with k1 ≟Key k2
 ...| yes refl = λ pr → trans (lookup-correct-update {v = v2} prf) (sym pr)
 ...| no  neq  = λ pr → sym (update-target-≢ {k1 = k1} {k2 = k2} {prf} λ k2≢k1 → ⊥-elim (neq (sym k2≢k1)))

 lookup-correct-update-4
                : ∀ {orig : KVMap Key Val}{k1}{v1}
                    {rdy : lookup k1 orig ≢ nothing}
                → lookup k1 orig ≡ just v1
                → kvm-update k1 v1 orig rdy ≡ orig
 lookup-correct-update-4 {orig = orig} {k1 = k1} {v1 = v1} {rdy = rdy} hyp =
    KVM-extensionality {kvm1 = kvm-update k1 v1 orig rdy} {kvm2 = orig}
                       λ x → lookup-correct-update-3 rdy hyp

 insert-target-0 : {kvm : KVMap Key Val}
                 → (prf : lookup k kvm ≡ nothing)
                 → lookup k' kvm ≢ lookup k' (kvm-insert k v kvm prf)
                 → k ≡ k'
 insert-target-0 {k = k} {k' = k'} prf lookups≢
    with k' ≟Key k
 ...| yes refl = refl
 ...| no  neq  = ⊥-elim (lookups≢ (insert-target-≢ prf neq))


-- Andreas, 2017-01-19, issue #2416, probably regression
-- Give failed for constrained size

-- {-# OPTIONS -v interaction.give:40 #-}
-- {-# OPTIONS -v tc.conv:10 #-}
-- {-# OPTIONS -v tc.conv.coerce:70 #-}
-- {-# OPTIONS -v tc.size:40 #-}
-- {-# OPTIONS -v tc.check.internal:40 #-}

open import Common.Size
open import Common.Equality

data Nat i : Set where
  zero : Nat i
  suc  : (j : Size< i) (n : Nat j) → Nat i

postulate
  divideBySuc : Nat ∞ → ∀ k → Nat k → Nat k
  div-self : ∀ l (n : Nat l) → divideBySuc n (↑ l) (suc {! l !} n) ≡ suc l zero

-- Cannot solve size constraints
-- [i, n] i ≤ _j_19 i n
-- [i, n] (↑ _j_19 i n) ≤ _i_18 i n
-- [i, n] (↑ _j_20 i n) ≤ _i_18 i n
-- Reason: inconsistent upper bound for 20
-- when checking that zero is a valid argument to a function of type


open import Spire.Type
module Spire.Denotational where

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

data Term : Set → Set₁
eval : {A : Set} → Term A → A

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

data Term where
  {- Type introduction -}
  `⊥ `⊤ `Bool `ℕ `Desc `Type : ∀{ℓ} → Term (Type ℓ)
  `Π `Σ : ∀{ℓ}
    (A : Term (Type ℓ))
    (B : ⟦ ℓ ∣ eval A ⟧ → Term (Type ℓ))
    → Term (Type ℓ)
  `⟦_⟧ : ∀{ℓ}
    (A : Term (Type ℓ))
    → Term (Type (suc ℓ))
  `⟦_⟧ᵈ : ∀{ℓ}
    (D : Term (Desc ℓ))
    (X : Term (Type ℓ))
    → Term (Type ℓ)
  `μ : ∀{ℓ}
    (D : Term (Desc ℓ))
    → Term (Type ℓ)

  {- Type elimination -}
  `elimType : ∀{ℓ}
    (P : (n : ℕ) → Type n → Term (Type ℓ))
    → ((n : ℕ) → Term ⟦ ℓ ∣ eval (P n `⊥) ⟧)
    → ((n : ℕ) → Term ⟦ ℓ ∣ eval (P n `⊤) ⟧)
    → ((n : ℕ) → Term ⟦ ℓ ∣ eval (P n `Bool) ⟧)
    → ((n : ℕ) → Term ⟦ ℓ ∣ eval (P n `ℕ) ⟧)
    → ((n : ℕ) (A : Type n) (B : ⟦ n ∣ A ⟧ → Type n)
       (rec₁ : ⟦ ℓ ∣ eval (P n A) ⟧)
       (rec₂ : (a : ⟦ n ∣ A ⟧) → ⟦ ℓ ∣ eval (P n (B a)) ⟧)
       → Term ⟦ ℓ ∣ eval (P n (`Π A B)) ⟧)
    → ((n : ℕ) (A : Type n) (B : ⟦ n ∣ A ⟧ → Type n)
       (rec₁ : ⟦ ℓ ∣ eval (P n A) ⟧)
       (rec₂ : (a : ⟦ n ∣ A ⟧) → ⟦ ℓ ∣ eval (P n (B a)) ⟧)
       → Term ⟦ ℓ ∣ eval (P n (`Σ A B)) ⟧)
    → ((n : ℕ) → Term ⟦ ℓ ∣ eval (P n `Desc) ⟧)
    → ((n : ℕ) (D : Desc n) (X : Type n)
       (rec : ⟦ ℓ ∣ eval (P n X) ⟧)
       → Term ⟦ ℓ ∣ eval (P n (`⟦ D ⟧ᵈ X)) ⟧)
    → ((n : ℕ) (D : Desc n) → Term ⟦ ℓ ∣ eval (P n (`μ D)) ⟧)
    → ((n : ℕ) → Term ⟦ ℓ ∣ eval (P n `Type) ⟧)
    → ((n : ℕ) (A : Type n)
        (rec : ⟦ ℓ ∣ eval (P n A) ⟧)
        → Term ⟦ ℓ ∣ eval (P (suc n) `⟦ A ⟧) ⟧)
    → (n : Term ℕ)
    (A : Term (Type (eval n)))
    → Term ⟦ ℓ ∣ eval (P (eval n) (eval A)) ⟧

  {- Desc introduction -}
  `⊤ᵈ `Xᵈ : ∀{ℓ} → Term (Desc ℓ)
  `Πᵈ `Σᵈ : ∀{ℓ}
    (A : Term (Type ℓ))
    (B : ⟦ ℓ ∣ eval A ⟧ → Term (Desc (suc ℓ)))
    → Term (Desc (suc ℓ))

  {- Desc elimination -}
  `elimDesc : ∀{ℓ}
    (P : (n : ℕ) → Desc n → Term (Type ℓ))
    → ((n : ℕ) → Term ⟦ ℓ ∣ eval (P n `⊤) ⟧)
    → ((n : ℕ) → Term ⟦ ℓ ∣ eval (P n `X) ⟧)
    → ((n : ℕ) (A : Type n) (D : ⟦ n ∣ A ⟧ → Desc (suc n))
       (rec : (a : ⟦ n ∣ A ⟧) → ⟦ ℓ ∣ eval (P (suc n) (D a)) ⟧)
       → Term ⟦ ℓ ∣ eval (P (suc n) (`Π A D)) ⟧)
    → ((n : ℕ) (A : Type n) (D : ⟦ n ∣ A ⟧ → Desc (suc n))
       (rec : (a : ⟦ n ∣ A ⟧) → ⟦ ℓ ∣ eval (P (suc n) (D a)) ⟧)
       → Term ⟦ ℓ ∣ eval (P (suc n) (`Σ A D)) ⟧)
    → (n : Term ℕ)
    (D : Term (Desc (eval n)))
    → Term ⟦ ℓ ∣ eval (P (eval n) (eval D)) ⟧

  {- Value introduction -}
  `tt : Term ⊤
  `true `false : Term Bool
  `zero : Term ℕ
  `suc : Term ℕ → Term ℕ
  `λ : ∀{A} {B : A → Set}
    (f : (a : A) → Term (B a))
    → Term ((a : A) → B a)
  _`,_ : ∀{A B}
    (a : Term A)
    (b : Term (B (eval a)))
    → Term (Σ A B)
  `con : ∀{ℓ D}
    (x : Term (⟦ ℓ ∣ D ⟧ᵈ (μ D)))
    → Term (μ D)

  {- Value elimination -}
  `elim⊥ : ∀{A}
    → Term ⊥
    → Term A
  `elimBool : ∀{ℓ}
    (P : Bool → Term (Type ℓ))
    (pt : Term ⟦ ℓ ∣ eval (P true) ⟧)
    (pf : Term ⟦ ℓ ∣ eval (P false) ⟧)
    (b : Term Bool)
    → Term ⟦ ℓ ∣ eval (P (eval b)) ⟧
  `elimℕ : ∀{ℓ}
    (P : ℕ → Term (Type ℓ))
    (pz : Term ⟦ ℓ ∣ eval (P zero) ⟧)
    (ps : (n : ℕ) → ⟦ ℓ ∣ eval (P n) ⟧ → Term ⟦ ℓ ∣ eval (P (suc n)) ⟧)
    (n : Term ℕ)
    → Term ⟦ ℓ ∣ eval (P (eval n)) ⟧
  `proj₁ : ∀{A B}
    (ab : Term (Σ A B))
    → Term A
  `proj₂ : ∀{A B}
    (ab : Term (Σ A B))
    → Term (B (proj₁ (eval ab)))
  _`$_ : ∀{A} {B : A → Set}
    (f : Term ((a : A) → B a))
    (a : Term A)
    → Term (B (eval a))
  `des : ∀{ℓ} {D : Desc ℓ}
    → (Term (μ D))
    → Term (⟦ ℓ ∣ D ⟧ᵈ (μ D))

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

{- Type introduction -}
eval `⊥ = `⊥
eval `⊤ = `⊤
eval `Bool = `Bool
eval `ℕ = `ℕ
eval `Desc = `Desc
eval `Type = `Type
eval (`Π A B) = `Π (eval A) (λ a → eval (B a))
eval (`Σ A B) = `Σ (eval A) (λ a → eval (B a))
eval (`μ D) = `μ (eval D)
eval (`⟦ D ⟧ᵈ X) = `⟦ eval D ⟧ᵈ (eval X)
eval `⟦ A ⟧ = `⟦ eval A ⟧

{- Type elimination -}
eval (`elimType {ℓ = ℓ} P p⊥ p⊤ pBool pℕ pΠ pΣ pDesc p⟦D⟧ᵈ pμ pType p⟦A⟧ n A) =
  elimType (λ n A → ⟦ ℓ ∣ eval (P n A) ⟧)
    (λ n → eval (p⊥ n)) (λ n → eval (p⊤ n)) (λ n → eval (pBool n)) (λ n → eval (pℕ n))
    (λ n A B rec₁ rec₂ → eval (pΠ n A B rec₁ rec₂))
    (λ n A B rec₁ rec₂ → eval (pΣ n A B rec₁ rec₂))
    (λ n → eval (pDesc n))
    (λ n D X rec → eval (p⟦D⟧ᵈ n D X rec))
    (λ n D → eval (pμ n D))
    (λ n → eval (pType n))
    (λ n A rec → eval (p⟦A⟧ n A rec))
    (eval n)
    (eval A)

{- Desc introduction -}
eval `⊤ᵈ = `⊤
eval `Xᵈ = `X
eval (`Πᵈ A D) = `Π (eval A) (λ a → eval (D a))
eval (`Σᵈ A D) = `Σ (eval A) (λ a → eval (D a))

{- Desc elimination -}
eval (`elimDesc {ℓ = ℓ} P p⊤ pX pΠ pΣ n D) =
  elimDesc (λ n D → ⟦ ℓ ∣ eval (P n D) ⟧)
    (λ n → eval (p⊤ n)) (λ n → eval (pX n))
    (λ n A D rec → eval (pΠ n A D rec))
    (λ n A D rec → eval (pΣ n A D rec))
    (eval n)
    (eval D)

{- Value introduction -}
eval `tt = tt
eval `true = true
eval `false = false
eval `zero = zero
eval (`suc n) = suc (eval n)
eval (`λ f) = λ a → eval (f a)
eval (a `, b) = eval a , eval b
eval (`con x) = con (eval x)

{- Value elimination -}
eval (`elim⊥ bot) = elim⊥ (eval bot)
eval (`elimBool {ℓ = ℓ} P pt pf b) =
  elimBool (λ b → ⟦ ℓ ∣ eval (P b) ⟧)
    (eval pt) (eval pf) (eval b)
eval (`elimℕ {ℓ = ℓ} P pz ps n) =
  elimℕ (λ n → ⟦ ℓ ∣ eval (P n) ⟧)
    (eval pz) (λ n pn → eval (ps n pn)) (eval n)
eval (`proj₁ ab) = proj₁ (eval ab)
eval (`proj₂ ab) = proj₂ (eval ab)
eval (f `$ a) = (eval f) (eval a)
eval (`des {ℓ = ℓ} x) = des {ℓ = ℓ} (eval x)

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


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

open import HoTT
open import cohomology.Exactness
open import cohomology.FunctionOver
open import cohomology.Theory
open import cohomology.CofiberSequence

module cohomology.LongExactSequence {i} (CT : CohomologyTheory i)
  {X Y : Ptd i} (n : ℤ) (f : fst (X ⊙→ Y)) where

open CohomologyTheory CT
open import cohomology.Functor CT
open import cohomology.BaseIndependence CT

co∂ : C n X →ᴳ C (succ n) (⊙Cof f)
co∂ = CF-hom (succ n) ⊙ext-glue ∘ᴳ fst ((C-Susp n X)⁻¹ᴳ)

long-cofiber-seq : HomSequence _ _
long-cofiber-seq =
  C n Y                ⟨ CF-hom n f                 ⟩→
  C n X                ⟨ co∂                        ⟩→
  C (succ n) (⊙Cof f)  ⟨ CF-hom (succ n) (⊙cfcod f) ⟩→
  C (succ n) Y         ⟨ CF-hom (succ n) f          ⟩→
  C (succ n) X         ⊣|

long-cofiber-exact : is-exact-seq long-cofiber-seq
long-cofiber-exact =
  {- apply the suspension isomorphism -}
  transport
    (λ {(r , s) → is-exact-seq s})
    (pair= _ $ sequence= _ _ $
      group-ua (C-Susp n Y)
        ∥⟨ C-Susp-↓ n f ⟩∥
      group-ua (C-Susp n X)
        ∥⟨ ↓-over-×-in _→ᴳ_
             (domain-over-iso
               (λ= (! ∘ ap (GroupHom.f (CF-hom _ ⊙ext-glue))
                      ∘ is-equiv.g-f (snd (C-Susp n X)))
                ◃ domain-over-equiv _ _))
             idp ⟩∥
      idp    ∥⟨ idp ⟩∥
      idp    ∥⟨ idp ⟩∥
      idp    ∥⊣|)
    {- fix the function basepoints -}
    (transport
      (λ {(φ , ψ) → is-exact-seq $
        _ ⟨ φ ⟩→ _ ⟨ ψ ⟩→
        _ ⟨ CF-hom (succ n) (⊙cfcod f) ⟩→ _ ⟨ CF-hom (succ n) f ⟩→ _ ⊣|})
      (pair×= (CF-base-indep (succ n) _ _ _)
              (CF-base-indep (succ n) _ _ _))
      {- do the CofiberSequence transport -}
      (transport {A = Σ _ (λ {((U , V) , g , h) →
                        (g (cfbase _) == snd U) × (h (snd U) == snd V)})}
        (λ {((_ , g , h) , (p , q)) → is-exact-seq $
          _ ⟨ CF-hom (succ n) (h , q) ⟩→ _ ⟨ CF-hom (succ n) (g , p) ⟩→
          _ ⟨ CF-hom (succ n) (⊙cfcod f) ⟩→ _ ⟨ CF-hom (succ n) f ⟩→ _ ⊣|})
        (pair= (cofiber-sequence f)
               (↓-×-in (from-transp _ _ idp) (from-transp _ _ idp)))
        (exact-build
          (_ ⟨ CF-hom (succ n) (⊙cfcod³ f) ⟩→ _ ⟨ CF-hom (succ n) (⊙cfcod² f) ⟩→
           _ ⟨ CF-hom (succ n) (⊙cfcod f) ⟩→ _ ⟨ CF-hom (succ n) f ⟩→ _ ⊣|)
          (C-exact (succ n) (⊙cfcod² f))
          (C-exact (succ n) (⊙cfcod f)) (C-exact (succ n) f))))


--#include "prelude.agda"
--#include "PropPrelude.agda"

proof_reverse_nil :: PropPrelude.prop_reverse_nil
  = ref@_ (reverse Unit Nil@_)

proof_append_nil_1 :: PropPrelude.prop_append_nil_1
  = ?

proof_append_nil_2 :: PropPrelude.prop_append_nil_2
  = \ (xs::List Unit) -> ref@_ (append Unit Nil@_ xs)


-- Author: Makoto Takeyama

module ParenDepTac where

----------------------------------------------------------------------
-- Preliminary
----------------------------------------------------------------------

infix 3  _≡_
data _≡_ {A : Set}(x : A) : A -> Set where
  refl : x ≡ x

subst : {A : Set}(C : A -> Set){x y : A} -> x ≡ y -> C y -> C x
subst C refl c = c

sym : {A : Set}{x y : A} -> x ≡ y -> y ≡ x
sym refl = refl

cong : {A B : Set}(f : A -> B){x y : A} -> x ≡ y -> f x ≡ f y
cong f refl = refl

infixl 2 _`tran`_
_`tran`_ : {A : Set}{x y z : A} -> x ≡ y -> y ≡ z -> x ≡ z
refl `tran` refl = refl

data FALSE : Set where
data TRUE  : Set where tt : TRUE

data Nat : Set where
  zer : Nat
  suc : Nat -> Nat

_+_ : Nat -> Nat -> Nat
zer   + n = n
suc m + n = suc ( m + n )

----------------------------------------------------------------------
-- Strings of parentheses
----------------------------------------------------------------------

infix 5 ≪_ ≫_
data Parens : Set where
  ε  : Parens
  ≪_ : Parens -> Parens
  ≫_ : Parens -> Parens

infixr 5 _·_

_·_ : Parens -> Parens -> Parens
ε    · ys = ys
≪ xs · ys = ≪ (xs · ys)
≫ xs · ys = ≫ (xs · ys)

·ass : (xs : Parens){ys zs : Parens} -> xs · (ys · zs) ≡ (xs · ys) · zs
·ass ε      = refl
·ass (≪ xs) = cong ≪_ (·ass xs)
·ass (≫ xs) = cong ≫_ (·ass xs)

·unitR : {xs : Parens} -> xs · ε ≡ xs
·unitR {ε}    = refl
·unitR {≪ xs} = cong ≪_ ·unitR
·unitR {≫ xs} = cong ≫_ ·unitR

_≫' : Parens -> Parens
xs ≫' = xs · ≫ ε
_≪' : Parens -> Parens
xs ≪' = xs · ≪ ε

----------------------------------------------------------------------
-- A poorman's tactics for equational reasoning
----------------------------------------------------------------------

infixr 5 _⊙_
data Exp : Set where
  Var : Nat    -> Exp
  Lit : Parens -> Exp
  _⊙_ : Exp -> Exp -> Exp

nf0 : Exp -> Exp -> Exp
nf0 (Var x)   e0 = Var x ⊙ e0
nf0 (Lit a)   e0 = Lit a ⊙ e0
nf0 (e1 ⊙ e2) e0 = nf0 e1 (nf0 e2 e0)

nf : Exp -> Exp
nf e = nf0 e (Lit ε)

Env = Nat -> Parens

module withEnv(ρ : Env) where

  ⟦_⟧ : Exp -> Parens
  ⟦ Var x   ⟧ = ρ x
  ⟦ Lit a   ⟧ = a
  ⟦ e1 ⊙ e2 ⟧ = ⟦ e1 ⟧ · ⟦ e2 ⟧

  nfSound0 : (e e0 : Exp) -> ⟦ e ⊙ e0 ⟧ ≡ ⟦ nf0 e e0 ⟧
  nfSound0 (Var x)   e0 = refl
  nfSound0 (Lit a)   e0 = refl
  nfSound0 (e1 ⊙ e2) e0 = sym (·ass ⟦ e1 ⟧) `tran`
                          cong (_·_ ⟦ e1 ⟧) (nfSound0 e2 e0)  `tran`
                          nfSound0 e1 (nf0 e2 e0)

  nfSound : (e : Exp) -> ⟦ e ⟧ ≡ ⟦ nf e ⟧
  nfSound e = sym ·unitR `tran` nfSound0 e (Lit ε)

  tac : (e1 e2 : Exp) -> nf e1 ≡ nf e2 -> ⟦ e1 ⟧ ≡ ⟦ e2 ⟧
  tac e1 e2 p = nfSound e1 `tran` subst (\x -> ⟦ x ⟧ ≡ ⟦ nf e2 ⟧) p refl `tran`
                sym (nfSound e2)

module tac4 (a0 a1 a2 a3 : Parens) where
  ρ : Env
  ρ zer                         = a0
  ρ (suc zer)                   = a1
  ρ (suc (suc zer))             = a2
  ρ (suc (suc (suc zer)))       = a3
  ρ (suc (suc (suc (suc _  )))) = ε
  open module tac4' = withEnv ρ public using (tac)

v0 = Var zer
v1 = Var (suc zer)
v2 = Var (suc (suc zer))
v3 = Var (suc (suc (suc zer)))
[≪] = Lit (≪ ε)
[≫] = Lit (≫ ε)

----------------------------------------------------------------------
-- Derivations of S and T grammars
--     indexed by their underlying strings
----------------------------------------------------------------------

infix  3 _∈S _∈T
infix  4 <_> _⟨_⟩
infixl 4 _•_

data  _∈S : Parens -> Set where
  εS  : ε ∈S
  <_> : {xs    : Parens} -> xs ∈S -> ≪ xs ≫' ∈S
  _•_ : {xs ys : Parens} -> xs ∈S -> ys ∈S -> xs · ys ∈S

data _∈T : Parens -> Set where
  εT   : ε ∈T
  _⟨_⟩ : {xs ys : Parens} -> xs ∈T -> ys ∈T -> xs · ≪ ys ≫' ∈T

----------------------------------------------------------------------
-- Equivalence of S and T grammars
----------------------------------------------------------------------

infixl 3 _○_
_○_ : {xs ys : Parens} -> xs ∈T -> ys ∈T -> xs · ys ∈T
t ○ εT                 = subst _∈T ·unitR    t
_○_ {xs} t (t1 ⟨ t2 ⟩) = subst _∈T (·ass xs) ((t ○ t1) ⟨ t2 ⟩)

S⊂T : {xs : Parens} -> xs ∈S -> xs ∈T
S⊂T εS        = εT
S⊂T (< s >)   = εT ⟨ S⊂T s ⟩
S⊂T (s1 • s2) = S⊂T s1 ○ S⊂T s2

T⊂S : {xs : Parens} -> xs ∈T -> xs ∈S
T⊂S εT          = εS
T⊂S (t1 ⟨ t2 ⟩) = T⊂S t1 • < T⊂S t2 >

----------------------------------------------------------------------
-- Recursively defined test function
----------------------------------------------------------------------

Test : Nat -> Parens -> Set
Test n       (≪ xs) = Test (suc n) xs
Test (suc n) (≫ xs) = Test n       xs
Test zer     (≫ xs) = FALSE
Test (suc n)  ε     = FALSE
Test zer      ε     = TRUE

----------------------------------------------------------------------
-- Soundness of Test
----------------------------------------------------------------------

lemTest : (m : Nat)(xs : Parens) -> Test m xs ->
          (n : Nat)(ys : Parens) -> Test n ys ->
          Test (m + n) (xs · ys)
lemTest m       (≪ xs) p  = lemTest (suc m) xs p
lemTest (suc m) (≫ xs) p  = lemTest m       xs p
lemTest zer     (≫ xs) ()
lemTest (suc m) ε      ()
lemTest zer     ε      tt = \ n ys q -> q

sound : {xs : Parens} -> xs ∈S -> Test zer xs
sound εS                  = tt
sound (<_>{xs} s)         = lemTest zer xs (sound s) (suc zer) (≫ ε) tt
sound (_•_{xs}{ys} s1 s2) = lemTest zer xs (sound s1) zer ys (sound s2)

----------------------------------------------------------------------
-- Completeness of Test
----------------------------------------------------------------------

complete : (xs : Parens) -> Test zer xs -> xs ∈S
complete xs0 p0 = parse init εS xs0 p0
  where
  data St : Nat -> Parens -> Set where
    init : St zer ε
    _*_≪ : {n  : Nat} ->
           {xs : Parens} -> St n xs ->
           {ys : Parens} -> ys ∈S   ->
           St (suc n) (xs · ys ≪')

  stPar : forall {n xs} -> St n xs -> Parens
  stPar {xs = xs} _ = xs

  ∈SPar : forall {xs} -> xs ∈S -> Parens
  ∈SPar {xs} _ = xs

  parse : {n  : Nat} ->
          {xs : Parens} -> St n xs   ->
          {ys : Parens} -> ys ∈S     ->
          (zs : Parens) -> Test n zs ->
          xs · ys · zs ∈S

  -- <SHIFT>  (st        ,  s ,  ≪ zs )  ↦  (st * s ≪ , εS         , zs)
  -- <REDUCE> (st * s3 ≪ ,  s ,  ≫ zs )  ↦  (st       , s3 • < s > , zs)
  -- <FINISH> (init      ,  s ,  ε    )  ↦  s

  parse {_} {xs} st {ys} s (≪ zs) p = subst _∈S eq (parse (st * s ≪) εS zs p)
    where open module foo = tac4 xs ys zs ε
          eq = tac (v0 ⊙ v1 ⊙ [≪]  ⊙ v2) ((v0 ⊙ v1 ⊙ [≪]) ⊙ v2) refl

  parse (st * s3 ≪) {ys} s (≫ zs) p
                                    = subst _∈S eq (parse st (s3 • < s >) zs p)
    where open module foo = tac4 (stPar st) (∈SPar s3) ys zs
          eq = tac ((v0 ⊙  v1 ⊙ [≪]) ⊙ v2 ⊙ [≫]  ⊙ v3)
                   ( v0 ⊙ (v1 ⊙ [≪]  ⊙ v2 ⊙ [≫]) ⊙ v3) refl

  parse ( _ * _ ≪) _ ε      ()

  parse init       _ (≫ zs) ()
  parse init       s ε      tt = subst _∈S ·unitR s