module Data.Collection.Inclusion where

open import Data.Collection.Equivalence
open import Data.Collection.Core

open import Function using (id; _∘_)
open import Function.Equivalence using (equivalence)
open import Level using (Level; suc; zero)
open import Relation.Unary hiding (_⇒_)
open import Relation.Binary
open import Relation.Binary.PropositionalEquality

≋⇒⊆ : _≋_ ⇒ _⊆_
≋⇒⊆ P≋Q ∈P = nach P≋Q ∈P

⊆-Transitive : ∀ {a ℓ} {A : Set a} → Transitive {_} {_} {Pred A ℓ} _⊆_
⊆-Transitive P⊆Q Q⊆R = Q⊆R ∘ P⊆Q

⊆-IsPreorder : IsPreorder _≋_ _⊆_
⊆-IsPreorder = record
    { isEquivalence = ≋-IsEquivalence
    ; reflexive = ≋⇒⊆
    ; trans = ⊆-Transitive
    }

⊆-Preorder : Preorder _ _ _
⊆-Preorder = record
    { Carrier = Pred String zero
    ; _≈_ = _≋_
    ; _∼_ = _⊆_
    ; isPreorder = ⊆-IsPreorder
    }

⊆-Antisymmetric : Antisymmetric _≋_ _⊆_
⊆-Antisymmetric P⊆Q Q⊆P = equivalence P⊆Q Q⊆P

⊆-IsPartialOrder : IsPartialOrder _≋_ _⊆_
⊆-IsPartialOrder = record
    { isPreorder = ⊆-IsPreorder
    ; antisym = ⊆-Antisymmetric
    }

⊆-Poset : Poset _ _ _
⊆-Poset = record
    { Carrier = Pred String zero
    ; _≈_ = _≋_
    ; _≤_ = _⊆_
    ; isPartialOrder = ⊆-IsPartialOrder
    }

--------------------------------------------------------------------------------
--  Conditional Inclusion
--------------------------------------------------------------------------------

_⊆[_]_ : ∀ {a ℓ₀ ℓ₁ ℓ₂} {A : Set a} → Pred A ℓ₀ → Pred A ℓ₁ → Pred A ℓ₂ → Set _
A ⊆[ P ] B = ∀ {x} → x ∈ P → x ∈ A → x ∈ B

_⊈[_]_ : ∀ {a ℓ₀ ℓ₁ ℓ₂} {A : Set a} → Pred A ℓ₀ → Pred A ℓ₁ → Pred A ℓ₂ → Set _
A ⊈[ P ] B = ∀ {x} → x ∈ P → x ∉ A → x ∉ B

-- prefix version of _⊆[_]_, with the predicate being the first argument
[_]⊆ : ∀ {a ℓ₀ ℓ₁ ℓ₂} {A : Set a} → Pred A ℓ₁ → Pred A ℓ₀ → Pred A ℓ₂ → Set _
[ P ]⊆ A B = A ⊆[ P ] B

≋[]⇒⊆[] : ∀ {a} {P : Pred Element a} → [ P ]≋ ⇒ [ P ]⊆
≋[]⇒⊆[] A≋B = nach ∘ A≋B

⊆[]-Transitive : ∀ {a ℓ} {P : Pred Element a} → Transitive {_} {_} {Pred String ℓ} [ P ]⊆
⊆[]-Transitive A⊆B B⊆C ∈P = B⊆C ∈P ∘ A⊆B ∈P

⊆[]-IsPreorder : ∀ {a} {P : Pred Element a} → IsPreorder [ P ]≋ [ P ]⊆
⊆[]-IsPreorder = record
    { isEquivalence = ≋[]-IsEquivalence
    ; reflexive = ≋[]⇒⊆[]
    ; trans = ⊆[]-Transitive
    }

⊆[]-Preorder : ∀ {a} {P : Pred Element a} → Preorder _ _ _
⊆[]-Preorder {_} {P} = record
    { Carrier = Pred String zero
    ; _≈_ = [ P ]≋
    ; _∼_ = [ P ]⊆
    ; isPreorder = ⊆[]-IsPreorder
    }

⊆[]-Antisymmetric : ∀ {a} {P : Pred Element a} → Antisymmetric [ P ]≋ [ P ]⊆
⊆[]-Antisymmetric P⊆Q Q⊆P ∈P = equivalence (P⊆Q ∈P) (Q⊆P ∈P)

⊆[]-IsPartialOrder : ∀ {a} {P : Pred Element a} → IsPartialOrder [ P ]≋ [ P ]⊆
⊆[]-IsPartialOrder = record
    { isPreorder = ⊆[]-IsPreorder
    ; antisym = ⊆[]-Antisymmetric
    }

⊆[]-Poset : ∀ {a} {P : Pred Element a} → Poset _ _ _
⊆[]-Poset {_} {P} = record
    { Carrier = Pred String zero
    ; _≈_ = [ P ]≋
    ; _≤_ = [ P ]⊆
    ; isPartialOrder = ⊆[]-IsPartialOrder
    }


{-# OPTIONS --cubical --safe --no-import-sorts #-}

module Cubical.Data.Fin.Recursive where

open import Cubical.Data.Fin.Recursive.Base public
open import Cubical.Data.Fin.Recursive.Properties public


-- Andreas, 2015-07-20, record patterns

open import Common.Prelude

postulate A : Set

record R : Set where
  field f : A

T : Bool → Set
T true  = R
T false = A

test : ∀{b} → T b → A
test record{f = a} = a

-- Could succeed by some magic.


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

open import lib.Basics

module lib.types.Empty where

Empty-rec : ∀ {i} {A : Type i} → (Empty → A)
Empty-rec = Empty-elim

⊥-rec : ∀ {i} {A : Type i} → (⊥ → A)
⊥-rec = Empty-rec

Empty-is-prop : is-prop Empty
Empty-is-prop = has-level-in Empty-elim

instance
  Empty-level : {n : ℕ₋₂} → has-level (S n) Empty
  Empty-level = prop-has-level-S Empty-is-prop

Empty-is-set : is-set Empty
Empty-is-set = raise-level -1 Empty-is-prop

⊥-is-prop = Empty-is-prop
⊥-is-set = Empty-is-set
⊥-level = Empty-level


{-# OPTIONS --cubical --safe #-}

open import Prelude
open import Relation.Binary

module Relation.Binary.Construct.LowerBound {e} {E : Type e} {r₁ r₂} (totalOrder : TotalOrder E r₁ r₂) where

open TotalOrder totalOrder renaming (refl to <-refl)
import Data.Unit.UniversePolymorphic as Poly
import Data.Empty.UniversePolymorphic as Poly

data ⌊∙⌋ : Type e where
  ⌊⊥⌋ : ⌊∙⌋
  ⌊_⌋ : E → ⌊∙⌋

⌊_⌋≤_ : E → ⌊∙⌋ → Type _
⌊ x ⌋≤ ⌊⊥⌋ = Poly.⊥
⌊ x ⌋≤ ⌊ y ⌋ = x ≤ y

_⌊≤⌋_ : ⌊∙⌋ → ⌊∙⌋ → Type _
⌊⊥⌋   ⌊≤⌋ y = Poly.⊤
⌊ x ⌋ ⌊≤⌋ y = ⌊ x ⌋≤ y

_<⌊_⌋ : ⌊∙⌋ → E → Type _
⌊⊥⌋   <⌊ y ⌋ = Poly.⊤
⌊ x ⌋ <⌊ y ⌋ = x < y

_⌊<⌋_ : ⌊∙⌋ → ⌊∙⌋ → Type _
_     ⌊<⌋ ⌊⊥⌋   = Poly.⊥
x     ⌊<⌋ ⌊ y ⌋ = x <⌊ y ⌋

lb-pord : PartialOrder ⌊∙⌋ _
Preorder._≤_   (PartialOrder.preorder lb-pord) = _⌊≤⌋_
Preorder.refl  (PartialOrder.preorder lb-pord) {⌊⊥⌋} = _
Preorder.refl  (PartialOrder.preorder lb-pord) {⌊ x ⌋} = <-refl
Preorder.trans (PartialOrder.preorder lb-pord) {⌊⊥⌋} {_} {_} p q = _
Preorder.trans (PartialOrder.preorder lb-pord) {⌊ x ⌋} {⌊ y ⌋} {⌊ z ⌋} p q = ≤-trans p q
PartialOrder.antisym lb-pord {⌊⊥⌋} {⌊⊥⌋} p q = refl
PartialOrder.antisym lb-pord {⌊ x ⌋} {⌊ x₁ ⌋} p q = cong ⌊_⌋ (antisym p q)

lb-sord : StrictPartialOrder ⌊∙⌋ _
StrictPreorder._<_   (StrictPartialOrder.strictPreorder lb-sord) = _⌊<⌋_
StrictPreorder.trans (StrictPartialOrder.strictPreorder lb-sord) {⌊⊥⌋} {⌊⊥⌋} {⌊⊥⌋} p q = q
StrictPreorder.trans (StrictPartialOrder.strictPreorder lb-sord) {⌊⊥⌋} {⌊⊥⌋} {⌊ x ⌋} p q = q
StrictPreorder.trans (StrictPartialOrder.strictPreorder lb-sord) {⌊⊥⌋} {⌊ x ⌋} {⌊ x₁ ⌋} p q = p
StrictPreorder.trans (StrictPartialOrder.strictPreorder lb-sord) {⌊ x ⌋} {⌊ x₁ ⌋} {⌊ x₂ ⌋} p q = <-trans p q
StrictPreorder.irrefl  (StrictPartialOrder.strictPreorder lb-sord) {⌊ x ⌋} = irrefl {x = x}
StrictPartialOrder.conn  lb-sord {⌊⊥⌋} {⌊⊥⌋} p q = refl
StrictPartialOrder.conn  lb-sord {⌊⊥⌋} {⌊ x ⌋} p q = ⊥-elim (p _)
StrictPartialOrder.conn  lb-sord {⌊ x ⌋} {⌊⊥⌋} p q = ⊥-elim (q _)
StrictPartialOrder.conn  lb-sord {⌊ x ⌋} {⌊ x₁ ⌋} p q = cong ⌊_⌋ (conn p q)

lb-lt : ∀ x y → Dec (x ⌊<⌋ y)
lb-lt x ⌊⊥⌋ = no (λ ())
lb-lt ⌊⊥⌋ ⌊ y ⌋ = yes Poly.tt
lb-lt ⌊ x ⌋ ⌊ y ⌋ = x <? y

lb-ord : TotalOrder ⌊∙⌋ _ _
TotalOrder.strictPartialOrder lb-ord = lb-sord
TotalOrder.partialOrder lb-ord = lb-pord
TotalOrder._<?_ lb-ord = lb-lt
TotalOrder.≰⇒> lb-ord {⌊⊥⌋} {⌊⊥⌋} p = ⊥-elim (p _)
TotalOrder.≰⇒> lb-ord {⌊⊥⌋} {⌊ x ⌋} p = ⊥-elim (p _ )
TotalOrder.≰⇒> lb-ord {⌊ x ⌋} {⌊⊥⌋} p = _
TotalOrder.≰⇒> lb-ord {⌊ x ⌋} {⌊ x₁ ⌋} p = ≰⇒> p
TotalOrder.≮⇒≥ lb-ord {x} {⌊⊥⌋} p = _
TotalOrder.≮⇒≥ lb-ord {⌊⊥⌋} {⌊ y ⌋} p = ⊥-elim (p _)
TotalOrder.≮⇒≥ lb-ord {⌊ x ⌋} {⌊ y ⌋} p = ≮⇒≥ p


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

open import Prelude
open import GSeTT.Syntax
open import GSeTT.Rules
open import GSeTT.Uniqueness-Derivations
open import Sets ℕ eqdecℕ
open import GSeTT.Dec-Type-Checking
open import CaTT.Ps-contexts
open import CaTT.Relation

{- PS-contexts -}
module CaTT.Uniqueness-Derivations-Ps where
  Γ⊢psx-dim≤ : ∀ {Γ x A} → Γ ⊢ps x # A → dim A ≤ dimC Γ
  Γ⊢psx-dim≤  pss = n≤n 0
  Γ⊢psx-dim≤ (psd Γ⊢psy) = Sn≤m→n≤m (Γ⊢psx-dim≤ Γ⊢psy)
  Γ⊢psx-dim≤ {((Γ :: (_ , A)) :: (_ , _))} {_} {_} (pse Γ⊢psx idp idp idp idp idp) with dec-≤ (dimC (Γ :: (length Γ , A))) (S (dim A))
  ... | inr res = Sn≤m→n≤m (≰ res)
  ... | inl res = n≤n (S (dim A))

  Γ⊢psx-dim : ∀ {Γ x y A B} → Γ ⊢ps x # A → Γ ⊢ps y # B → dim A == dim B → x == y
  Γ⊢psx-dim pss pss dimA=dimB = idp
  Γ⊢psx-dim {x = x} {y = y} {A = A} {B = B} (psd {x = x₁} Γ⊢psx) (psd {x = x₂} Γ⊢psy) dimA=dimB  = =Var (tgt= (unique-type (Γ⊢psx:A→Γ⊢x:A Γ⊢psx) (Γ⊢psx:A→Γ⊢x:A Γ⊢psy) (ap Var (Γ⊢psx-dim Γ⊢psx Γ⊢psy (ap S dimA=dimB)))))
  Γ⊢psx-dim {B = ∗} pss (psd Γ⊢psy) dimA=dimB = ⊥-elim (Sn≰n _ ((Γ⊢psx-dim≤ Γ⊢psy)))
  Γ⊢psx-dim {A = ∗} (psd Γ⊢psx) pss dimA=dimB = ⊥-elim (Sn≰n _ ((Γ⊢psx-dim≤ Γ⊢psx)))
  Γ⊢psx-dim (pse _ _ _ _ idp idp) (pse _ _ _ _ idp idp) dimA==dimB = idp
  Γ⊢psx-dim Γ++⊢psx@(psd Γ++⊢_) Γ++⊢psy@(pse _ idp idp idp idp idp) dimA=dimB with psx-◃-linear→ Γ++⊢psx _ _ (Γ⊢x:A→x∈Γ (psvar Γ++⊢psx)) (Γ⊢x:A→x∈Γ (psvar Γ++⊢psy))
  ... | inl (inl x◃Sl) = ⊥-elim (Sn≰n-t (dimA=dimB ^) (⟿dim (psvar Γ++⊢psx) (psvar Γ++⊢psy) (⊢psx-◃→⟿ Γ++⊢psx x◃Sl)))
  ... | inl (inr Sl◃x) = ⊥-elim (Sn≰n-t (dimA=dimB) (⟿dim (psvar Γ++⊢psy) (psvar Γ++⊢psx) (⊢psx-◃→⟿ Γ++⊢psy Sl◃x)))
  ... | inr idp = idp
  Γ⊢psx-dim Γ++⊢psx@(pse _  idp idp idp idp idp) Γ++⊢psy@(psd _) dimA=dimB with psx-◃-linear→ Γ++⊢psx _ _ (Γ⊢x:A→x∈Γ (psvar Γ++⊢psx)) (Γ⊢x:A→x∈Γ (psvar Γ++⊢psy))
  ... | inl (inl Sl◃y) = ⊥-elim (Sn≰n-t (dimA=dimB ^) (⟿dim (psvar Γ++⊢psx) (psvar Γ++⊢psy) (⊢psx-◃→⟿ Γ++⊢psx Sl◃y)))
  ... | inl (inr y◃Sl) = ⊥-elim (Sn≰n-t (dimA=dimB) (⟿dim (psvar Γ++⊢psy) (psvar Γ++⊢psx) (⊢psx-◃→⟿ Γ++⊢psy y◃Sl)))
  ... | inr idp = idp

  has-all-paths-⊢psx : ∀ {Γ x A} → has-all-paths (Γ ⊢ps x # A)
  has-all-paths-⊢psx pss pss = idp
  has-all-paths-⊢psx (psd a) (psd b) with (Γ⊢psx-dim a b idp)
  ... | idp with unique-type (psvar a) (psvar b) idp
  ... | p = psd↓ a b (=Var (snd (fst (=⇒ p)))) (has-all-paths-⊢psx _ _)
  has-all-paths-⊢psx  pss (psd b) with (psvar b)
  ... | var _ (inl ())
  ... | var _ (inr ())
  has-all-paths-⊢psx (psd a) pss with (psvar a)
  ... | var _ (inl ())
  ... | var _ (inr ())
  has-all-paths-⊢psx (psd a) (pse b idp idp idp idp idp) with (psvar a)
  ... | var _ (inl (inl contra)) = ⊥-elim (l∉ (psv b) (n≤Sn _) (Γ⊢x:A→x∈Γ (Γ⊢tgt (Γ⊢t:A→Γ⊢A (var (psv b) contra)))))
  has-all-paths-⊢psx (pse a idp idp idp idp idp) (psd b) with psvar b
  ... | var _ (inl (inl contra)) = ⊥-elim (l∉ (psv a) (n≤Sn _) (Γ⊢x:A→x∈Γ (Γ⊢tgt (Γ⊢t:A→Γ⊢A (var (psv a) contra)))))
  has-all-paths-⊢psx (pse a idp idp idp idp idp) (pse b p q r s u) = let eq = =Var (snd (fst (=⇒ r))) in pse↓ a _ _ _ _ _ b _ _ _ _ _ eq (has-all-paths-⊢psx _ _)

  has-all-paths-⊢ps : ∀ Γ → has-all-paths (Γ ⊢ps)
  has-all-paths-⊢ps Γ (ps Γ⊢psx₁) (ps Γ⊢psx₂) = ps↓ Γ⊢psx₁ Γ⊢psx₂ (Γ⊢psx-dim Γ⊢psx₁ Γ⊢psx₂ idp) (has-all-paths-⊢psx _ _)

  is-prop-⊢ps : ∀ Γ → is-prop (Γ ⊢ps)
  is-prop-⊢ps Γ = has-all-paths-is-prop (has-all-paths-⊢ps Γ)

  eqdec-ps : eqdec ps-ctx
  eqdec-ps (Γ , Γ⊢ps) (Δ , Δ⊢ps) with eqdec-PreCtx Γ Δ
  ... | inl idp = inl (Σ= idp (is-prop-has-all-paths (is-prop-⊢ps Γ) _ _))
  ... | inr Γ≠Δ = inr λ{idp → Γ≠Δ idp}


module Data.QuadTree.Implementation.DataLenses where

open import Haskell.Prelude renaming (zero to Z; suc to S)
open import Data.Lens.Lens
open import Data.Logic
open import Data.QuadTree.Implementation.PropDepthRelation
open import Data.QuadTree.Implementation.Definition
open import Data.QuadTree.Implementation.ValidTypes
open import Data.QuadTree.Implementation.QuadrantLenses

{-# FOREIGN AGDA2HS
{-# LANGUAGE Safe #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE Rank2Types #-}
import Data.Nat
import Data.Lens.Lens
import Data.Logic

import Data.QuadTree.Implementation.Definition
import Data.QuadTree.Implementation.ValidTypes
import Data.QuadTree.Implementation.QuadrantLenses
#-}

---- Functions for whether a coordinate is inside

isInsideQuadTree : {t : Set} -> (Nat × Nat) -> QuadTree t -> Bool
isInsideQuadTree (x , y) (Wrapper (w , h) _) = x < w && y < h

isInsidePow : (Nat × Nat) -> Nat -> Bool
isInsidePow (x , y) deps = x < pow 2 deps && y < pow 2 deps

insideQTtoInsidePow : {t : Set} {{eqT : Eq t}} -> (loc : Nat × Nat) -> {dep : Nat} -> (vqt : VQuadTree t {dep})
  -> IsTrue (isInsideQuadTree loc (qtFromSafe vqt))
  -> IsTrue (isInsidePow loc dep)
insideQTtoInsidePow (x , y) {dep} (CVQuadTree (Wrapper (w , h) qd) {p} {q}) it =
  let
    p1 : IsTrue (pow 2 dep >= (max w h))
    p1 = log2upPow dep (max w h) (eqToGte dep (log2up (max w h)) q)

    p2 : IsTrue ((max w h) <= pow 2 dep)
    p2 = gteInvert (pow 2 dep) (max w h) p1

    p3 : IsTrue (w <= pow 2 dep && h <= pow 2 dep)
    p3 = useEq (sym $ propMaxLte w h (pow 2 dep)) p2
  in andCombine
    ( ltLteTransitive x w (pow 2 dep) (andFst {x < w} it) (andFst p3) )
    ( ltLteTransitive y h (pow 2 dep) (andSnd {x < w} it) (andSnd p3) )

---- Data access

-- Lens into the leaf quadrant corresponding to a location in a quadrant
go : {t : Set} {{eqT : Eq t}}
  -> (loc : Nat × Nat) -> (dep : Nat)
  -> {.(IsTrue (isInsidePow loc dep))}
  -> Lens (VQuadrant t {dep}) t
go _ Z = lensLeaf
go {t} (x , y) (S deps) =
  let
    mid = pow 2 deps
    gorec = go {t} (mod x mid {pow_not_zero_cv deps} , mod y mid {pow_not_zero_cv deps}) deps
      {andCombine (modLt x mid {pow_not_zero_cv deps}) (modLt y mid {pow_not_zero_cv deps})}
  in
    if (y < mid)
      then if x < mid
        then (lensA ∘ gorec)
        else (lensB ∘ gorec)
      else if x < mid
        then (lensC ∘ gorec)
        else (lensD ∘ gorec)
{-# COMPILE AGDA2HS go #-}

-- Lenses into the root quadrant of a quadtree
lensWrappedTree : {t : Set} {{eqT : Eq t}}
  -> {dep : Nat}
  -> Lens (VQuadTree t {dep}) (VQuadrant t {dep})
lensWrappedTree fun (CVQuadTree (Wrapper (w , h) qd) {p} {q}) =
  fmap
    (λ where (CVQuadrant qd {p}) → CVQuadTree (Wrapper (w , h) qd) {p} {q})
    (fun (CVQuadrant qd {p}))
{-# COMPILE AGDA2HS lensWrappedTree #-}

-- Lens into the leaf quadrant corresponding to a location in a quadtree
atLocation : {t : Set} {{eqT : Eq t}}
  -> (loc : Nat × Nat) -> (dep : Nat)
  -> {.(IsTrue (isInsidePow loc dep))}
  -> Lens (VQuadTree t {dep}) t
atLocation index dep {p} = lensWrappedTree ∘ (go index dep {p})
{-# COMPILE AGDA2HS atLocation #-}


-- 2010-10-05 Andreas

module TerminationRecordPatternLie where

data Empty : Set where

record Unit : Set where

data Bool : Set where
  true false : Bool

T : Bool -> Set
T true = Unit
T false = Empty

-- Thorsten suggests on the Agda list  thread "Coinductive families"
-- to encode lists as records
record List (A : Set) : Set where
  inductive
  constructor list
  field
    isCons : Bool
    head   : T isCons -> A
    tail   : T isCons -> List A

open List public

-- However, we have to be careful to preserve termination
-- in the presence of a lie

postulate
  lie : {b : Bool} -> T b

-- this function is rejected
f : {A : Set} -> List A -> Empty
f (list b h t) = f (t lie)

-- since its internal representation is
g : {A : Set} -> List A -> Empty
g l = g (tail l lie)

-- however could record constructors still count as structural increase
-- if they cannot be translated away
-- should we accept this?
--   f (list true h t) = f (t _)


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

postulate _↦_ : Set → Set → Set
{-# BUILTIN REWRITE _↦_ #-}

postulate
  X : Set
  P : Set → Set → Set
  P-rewr : (A : Set) → (P A A ↦ X)
  {-# REWRITE P-rewr #-}

f : (B : Set → Set) {x y : Set} → P (B x) (B y)
f = {!!}


-- Reported by fredrik.forsberg, Oct 21, 2014
-- The following code gives an internal error

-- "An internal error has occurred. Please report this as a bug.
-- Location of the error: src/full/Agda/TypeChecking/InstanceArguments.hs:269"

-- on Agda head, since "n ≠ zero" is not expanded.

open import Common.Prelude
open import Common.Equality

¬ : (A : Set) → Set
¬ A = A → ⊥

_≠_ : {A : Set} → (A → A → Set)
x ≠ y = ¬ (x ≡ y)

f : (n : Nat) ⦃ _ : n ≠ zero ⦄ -> Nat
f n = n

g : Nat
g = f (suc zero)


-- Parametrised maps of families and their coalgebraic properties
module SOAS.Coalgebraic.Map {T : Set} where

open import SOAS.Common
open import SOAS.Context
open import SOAS.Variable
open import SOAS.Families.Core {T}
open import SOAS.Abstract.Hom {T}
import SOAS.Abstract.Box {T} as □ ;  open □.Sorted
import SOAS.Abstract.Coalgebra {T} as →□ ; open →□.Sorted

private
  variable
    𝒳 𝒴 𝒫 : Familyₛ
    Γ Δ Θ : Ctx
    α : T

record Coalgebraic (𝒳ᴮ : Coalgₚ 𝒳)(𝒫ᴮ : Coalgₚ 𝒫)(𝒴ᴮ : Coalgₚ 𝒴)
                   (f : 𝒳 ⇾̣ 〖 𝒫 , 𝒴 〗) : Set where
  private module 𝒳 = Coalgₚ 𝒳ᴮ
  private module 𝒫 = Coalgₚ 𝒫ᴮ
  private module 𝒴 = Coalgₚ 𝒴ᴮ

  -- Interaction between the point and renaming of all three coalgebras
  field
    r∘f : {σ : Γ ~[ 𝒫 ]↝ Δ}{ϱ : Δ ↝ Θ}{t : 𝒳 α Γ}
        → 𝒴.r (f t σ) ϱ ≡ f t (λ v → 𝒫.r (σ v) ϱ)

    f∘r : {ρ : Γ ↝ Δ}{ς : Δ ~[ 𝒫 ]↝ Θ}{t : 𝒳 α Γ}
        → f (𝒳.r t ρ) ς ≡ f t (ς ∘ ρ)

    f∘η : {v : ℐ α Γ} → f (𝒳.η v) 𝒫.η ≡ 𝒴.η v

  -- Codomain of coalgebraic map is a pointed coalgebra
  〖𝒫,𝒴〗ᴮ : Coalgₚ 〖 𝒫 , 𝒴 〗
  〖𝒫,𝒴〗ᴮ = record
    { ᵇ = record { r = λ h ρ σ → h (σ ∘ ρ) ; counit = refl ; comult = refl }
    ; η = λ v σ → f (𝒳.η v) σ
    ; r∘η = dext (λ σ → trans (sym f∘r) (congr 𝒳.r∘η (λ - → f - σ))) }

  -- The map is a pointed coalgebra homomorphism
  ᴮ⇒ : Coalgₚ⇒ 𝒳ᴮ 〖𝒫,𝒴〗ᴮ f
  ᴮ⇒ = record { ᵇ⇒ = record { ⟨r⟩ = dext′ f∘r } ; ⟨η⟩ = refl }

  -- Equality of two substitutions at the new index extends to equality of
  -- transforming new variables with the substitution
  eq-at-new : {σ : α ∙ Γ ~[ 𝒫 ]↝ α ∙ Θ}
              {ς : α ∙ Δ ~[ 𝒫 ]↝ α ∙ Θ}
           → σ new ≡ ς new
           → f (𝒳.η new) σ ≡ f (𝒳.η new) ς
  eq-at-new {σ = σ} {ς} eq = begin
         f (𝒳.η new) σ           ≡⟨⟩
         f (𝒳.η (ι new)) σ      ≡˘⟨ cong (λ - → f - σ) (𝒳.r∘η) ⟩
         f (𝒳.r (𝒳.η new) ι) σ  ≡⟨ f∘r ⟩
         f (𝒳.η new) (σ ∘ ι)    ≡⟨ cong (f (𝒳.η new)) (dext (λ{ new → eq })) ⟩
         f (𝒳.η new) (ς ∘ ι)    ≡˘⟨ f∘r ⟩
         f (𝒳.r (𝒳.η new) ι) ς  ≡⟨ cong (λ - → f - ς) (𝒳.r∘η) ⟩
         f (𝒳.η (ι new)) ς      ≡⟨⟩
         f (𝒳.η new) ς          ∎
    where
    open ≡-Reasoning
    open Coalgₚ
    ι : (α ∙ ∅) ↝ (α ∙ Δ)
    ι new = new

-- Application for a pointed coalgebra is coalgebraic
jᶜ : (𝒳ᴮ : Coalgₚ 𝒳) → Coalgebraic ℐᴮ 𝒳ᴮ 𝒳ᴮ (j 𝒳)
jᶜ 𝒳ᴮ = record { r∘f = refl ; f∘r = refl ; f∘η = refl }

-- Renaming of pointed coalgebr is coalgebraic
rᶜ : (𝒳ᴮ : Coalgₚ 𝒳) → Coalgebraic 𝒳ᴮ ℐᴮ 𝒳ᴮ (Coalgₚ.r 𝒳ᴮ)
rᶜ 𝒳ᴮ = record { r∘f = sym comult ; f∘r = sym comult ; f∘η = r∘η }
  where open Coalgₚ 𝒳ᴮ


open import Nat
open import Prelude
open import List
open import contexts
open import judgemental-erase
open import lemmas-matching
open import moveerase
open import sensibility
open import statics-core
open import synth-unicity

module statics-checks where
  -- these three judmgements lift the action semantics judgements to relate
  -- an expression and a list of pair-wise composable actions to the
  -- expression that's produced by tracing through the action semantics for
  -- each element in that list.
  --
  -- we do this just by appealing to the original judgement with
  -- constraints on the terms to enforce composability.
  --
  -- in all three cases, we assert that the empty list of actions
  -- constitutes a reflexivity step, so when you run out of actions to
  -- preform you have to be where you wanted to be.
  --
  -- note that the only difference between the types for each judgement and
  -- the original action semantics is that the action is now a list of
  -- actions.
  data runtype : (t : ztyp) (Lα : List action) (t' : ztyp) → Set where
     DoRefl : {t : ztyp} →
              runtype t [] t
     DoType : {t : ztyp} {α : action} {t' t'' : ztyp}
              {L : List action} →
              t + α +> t' →
              runtype t' L t'' →
              runtype t (α :: L) t''

  data runsynth : (Γ : tctx) (e : zexp) (t1 : htyp) (Lα : List action)
                  (e' : zexp) (t2 : htyp) → Set where
     DoRefl  : {Γ : tctx} {e : zexp} {t : htyp} →
               runsynth Γ e t [] e t
     DoSynth : {Γ : tctx} {e : zexp} {t : htyp} {α : action} {e' e'' : zexp} {t' t'' : htyp}
               {L : List action} →
               Γ ⊢ e => t ~ α ~> e' => t' →
               runsynth Γ e' t' L e'' t'' →
               runsynth Γ e t (α :: L) e'' t''

  data runana : (Γ : tctx) (e : zexp) (Lα : List action) (e' : zexp) (t : htyp) → Set where
     DoRefl : {Γ : tctx} {e : zexp} {t : htyp} →
              runana Γ e [] e t
     DoAna  : {Γ : tctx} {e : zexp} {α : action} {e' e'' : zexp} {t : htyp}
              {L : List action} →
              Γ ⊢ e ~ α ~> e' ⇐ t →
              runana Γ e' L e'' t →
              runana Γ e (α :: L) e'' t

  -- all three run judgements lift to the list monoid as expected. these
  -- theorems are simple because the structure of lists is simple, but they
  -- amount a reasoning principle about the composition of action sequences
  -- by letting you split lists in (nearly) arbitrary places and argue
  -- about the consequences of the splits before composing them together.
  runtype++ : ∀{t t' t'' L1 L2 } →
              runtype t  L1 t' →
              runtype t' L2 t'' →
              runtype t (L1 ++ L2) t''
  runtype++ DoRefl d2 = d2
  runtype++ (DoType x d1) d2 = DoType x (runtype++ d1 d2)

  runsynth++ : ∀{Γ e t L1 e' t' L2 e'' t''} →
               runsynth Γ e t L1 e' t' →
               runsynth Γ e' t' L2 e'' t'' →
               runsynth Γ e t (L1 ++ L2) e'' t''
  runsynth++ DoRefl d2 = d2
  runsynth++ (DoSynth x d1) d2 = DoSynth x (runsynth++ d1 d2)

  runana++ : ∀{Γ e t L1 e' L2 e''} →
             runana Γ e  L1 e' t →
             runana Γ e' L2 e'' t →
             runana Γ e (L1 ++ L2) e'' t
  runana++ DoRefl d2 = d2
  runana++ (DoAna x d1) d2 = DoAna x (runana++ d1 d2)

  -- the following collection of lemmas asserts that the various runs
  -- interoperate nicely. in many cases, these amount to observing
  -- something like congruence: if a subterm is related to something by one
  -- of the judgements, it can be replaced by the thing to which it is
  -- related in a larger context without disrupting that larger
  -- context.
  --
  -- taken together, this is a little messier than a proper congruence,
  -- because the action semantics demand well-typedness at each step, and
  -- therefore there are enough premises to each lemma to supply to the
  -- action semantics rules.
  --
  -- therefore, these amount to a checksum on the zipper actions under the
  -- lifing of the action semantics to the list monoid.
  --
  -- they only check the zipper actions they happen to be include, however,
  -- which is driven by the particular lists we use in the proofs of
  -- contructability and reachability, which may or may not be all of
  -- them. additionally, the lemmas given here are what is needed for these
  -- proofs, not anything that's more general.

    -- type zippers
  ziplem-tmarr1 : ∀{t1 t1' t2 L} →
                  runtype t1' L t1 →
                  runtype (t1' ==>₁ t2) L (t1 ==>₁ t2)
  ziplem-tmarr1 DoRefl = DoRefl
  ziplem-tmarr1 (DoType x L') = DoType (TMArrZip1 x) (ziplem-tmarr1 L')

  ziplem-tmarr2 : ∀{t1 t2 t2' L} →
                  runtype t2' L t2 →
                  runtype (t1 ==>₂ t2') L (t1 ==>₂ t2)
  ziplem-tmarr2 DoRefl = DoRefl
  ziplem-tmarr2 (DoType x L') = DoType (TMArrZip2 x) (ziplem-tmarr2 L')

  ziplem-tmplus1 : ∀{t1 t1' t2 L} →
                   runtype t1' L t1 →
                   runtype (t1' ⊕₁ t2) L (t1 ⊕₁ t2)
  ziplem-tmplus1 DoRefl = DoRefl
  ziplem-tmplus1 (DoType x L') = DoType (TMPlusZip1 x) (ziplem-tmplus1 L')

  ziplem-tmplus2 : ∀{t1 t2 t2' L} →
                   runtype t2' L t2 →
                   runtype (t1 ⊕₂ t2') L (t1 ⊕₂ t2)
  ziplem-tmplus2 DoRefl = DoRefl
  ziplem-tmplus2 (DoType x L') = DoType (TMPlusZip2 x) (ziplem-tmplus2 L')

  ziplem-tmprod1 : ∀{t1 t1' t2 L} →
                   runtype t1' L t1 →
                   runtype (t1' ⊠₁ t2) L (t1 ⊠₁ t2)
  ziplem-tmprod1 DoRefl = DoRefl
  ziplem-tmprod1 (DoType x L') = DoType (TMProdZip1 x) (ziplem-tmprod1 L')

  ziplem-tmprod2 : ∀{t1 t2 t2' L} →
                   runtype t2' L t2 →
                   runtype (t1 ⊠₂ t2') L (t1 ⊠₂ t2)
  ziplem-tmprod2 DoRefl = DoRefl
  ziplem-tmprod2 (DoType x L') = DoType (TMProdZip2 x) (ziplem-tmprod2 L')

    -- expression zippers
  ziplem-asc1 : ∀{Γ t L e e'} →
                runana Γ e L e' t →
                runsynth Γ (e ·:₁ t) t L (e' ·:₁ t) t
  ziplem-asc1 DoRefl = DoRefl
  ziplem-asc1 (DoAna a r) = DoSynth (SAZipAsc1 a) (ziplem-asc1 r)

  ziplem-asc2 : ∀{Γ t L t' t◆ t'◆ u} →
                erase-t t t◆ →
                erase-t t' t'◆ →
                runtype t L t' →
                runsynth Γ (⦇-⦈[ u ] ·:₂ t) t◆ L (⦇-⦈[ u ] ·:₂ t') t'◆
  ziplem-asc2 {Γ} er er' rt with erase-t◆ er | erase-t◆ er'
  ... | refl | refl = ziplem-asc2' {Γ = Γ} rt
   where
     ziplem-asc2' : ∀{t L t' Γ u} →
                    runtype t L t' →
                    runsynth Γ (⦇-⦈[ u ] ·:₂ t) (t ◆t) L (⦇-⦈[ u ] ·:₂ t') (t' ◆t)
     ziplem-asc2' DoRefl = DoRefl
     ziplem-asc2' (DoType x rt) =
       DoSynth (SAZipAsc2 x (◆erase-t _ _ refl) (◆erase-t _ _ refl) (ASubsume SEHole TCHole1))
               (ziplem-asc2' rt)

  ziplem-lam : ∀{Γ x e t t1 t2 L e'} →
               x # Γ →
               t ▸arr (t1 ==> t2) →
               runana (Γ ,, (x , t1)) e L e' t2 →
               runana Γ (·λ x e) L (·λ x e') t
  ziplem-lam a m DoRefl = DoRefl
  ziplem-lam a m (DoAna x₁ d) = DoAna (AAZipLam a m x₁) (ziplem-lam a m d)

  ziplem-halflam1 : ∀{Γ u t1 t1' t1◆ t1'◆ x l} →
                    x # Γ →
                    erase-t t1 t1◆ →
                    erase-t t1' t1'◆ →
                    runtype t1 l t1' →
                    runsynth Γ (·λ x ·[ t1 ]₁ ⦇-⦈[ u ]) (t1◆ ==> ⦇-⦈) l
                      (·λ x ·[ t1' ]₁ ⦇-⦈[ u ]) (t1'◆ ==> ⦇-⦈)
  ziplem-halflam1 apt et et' DoRefl
    with eraset-det et et'
  ... | refl = DoRefl
  ziplem-halflam1 apt et et' (DoType x rt) =
    DoSynth (SAZipLam1 apt et (rel◆t _) x SEHole SEHole)
            (ziplem-halflam1 apt (rel◆t _) et' rt)

  ziplem-halflam2 : ∀{Γ e e' e◆ t1 t2 t2' x L} →
                    x # Γ →
                    erase-e e e◆ →
                    (Γ ,, (x , t1)) ⊢ e◆ => t2 →
                    runsynth (Γ ,, (x , t1)) e t2 L e' t2' →
                    runsynth Γ (·λ x ·[ t1 ]₂ e) (t1 ==> t2) L
                      (·λ x ·[ t1 ]₂ e') (t1 ==> t2')
  ziplem-halflam2 apt ee wt DoRefl = DoRefl
  ziplem-halflam2 apt ee wt (DoSynth x rs) =
    DoSynth (SAZipLam2 apt ee wt x)
            (ziplem-halflam2 apt (rel◆ _) (actsense-synth ee (rel◆ _) x wt) rs)

  ziplem-plus1 : ∀{Γ e L e' f} →
                 runana Γ e L e' num →
                 runsynth Γ (e ·+₁ f) num L (e' ·+₁ f) num
  ziplem-plus1 DoRefl = DoRefl
  ziplem-plus1 (DoAna x d) = DoSynth (SAZipPlus1 x) (ziplem-plus1 d)

  ziplem-plus2 : ∀{Γ e L e' f} →
                 runana Γ e L e' num →
                 runsynth Γ (f ·+₂ e) num L (f ·+₂ e') num
  ziplem-plus2 DoRefl = DoRefl
  ziplem-plus2 (DoAna x d) = DoSynth (SAZipPlus2 x) (ziplem-plus2 d)

  ziplem-ap2 : ∀{Γ e L e' t t' f tf} →
               Γ ⊢ f => t' →
               t' ▸arr (t ==> tf) →
               runana Γ e L e' t →
               runsynth Γ (f ∘₂ e) tf L (f ∘₂ e') tf
  ziplem-ap2 wt m DoRefl = DoRefl
  ziplem-ap2 wt m (DoAna x d) = DoSynth (SAZipApAna m wt x) (ziplem-ap2 wt m d)

  ziplem-nehole-a : ∀{Γ e e' L t t' u} →
                    (Γ ⊢ e ◆e => t) →
                    runsynth Γ e t L e' t' →
                    runsynth Γ ⦇⌜ e ⌟⦈[ u ] ⦇-⦈ L ⦇⌜ e' ⌟⦈[ u ] ⦇-⦈
  ziplem-nehole-a wt DoRefl = DoRefl
  ziplem-nehole-a wt (DoSynth {e = e} x d) =
    DoSynth (SAZipNEHole (rel◆ e) wt x)
            (ziplem-nehole-a (actsense-synth (rel◆ e) (rel◆ _) x wt) d)

  ziplem-nehole-b : ∀{Γ e e' L t t' t'' u} →
                    (Γ ⊢ e ◆e => t) →
                    (t'' ~ t') →
                    runsynth Γ e t L e' t' →
                    runana Γ ⦇⌜ e ⌟⦈[ u ] L ⦇⌜ e' ⌟⦈[ u ] t''
  ziplem-nehole-b wt c DoRefl = DoRefl
  ziplem-nehole-b wt c (DoSynth x rs) =
    DoAna (AASubsume (erase-in-hole (rel◆ _)) (SNEHole wt) (SAZipNEHole (rel◆ _) wt x) TCHole1)
          (ziplem-nehole-b (actsense-synth (rel◆ _) (rel◆ _) x wt) c rs)

  -- because the point of the reachability theorems is to show that we
  -- didn't forget to define any of the action semantic cases, it's
  -- important that theorems include the fact that the witness only uses
  -- move -- otherwise, you could cheat by just prepending [ del ] to the
  -- list produced by constructability. constructability does also use
  -- some, but not all, of the possible movements, so this would no longer
  -- demonstrate the property we really want. to that end, we define a
  -- predicate on lists that they contain only (move _) and that the
  -- various things above that produce the lists we use have this property.

  -- predicate
  data movements : List action → Set where
    AM:: : {L : List action} {δ : direction} →
           movements L →
           movements ((move δ) :: L)
    AM[] : movements []

  -- movements breaks over the list monoid, as expected
  movements++ : {l1 l2 : List action} →
                movements l1 →
                movements l2 →
                movements (l1 ++ l2)
  movements++ (AM:: m1) m2 = AM:: (movements++ m1 m2)
  movements++ AM[] m2 = m2

  -- these are zipper lemmas that are specific to list of movement
  -- actions. they are not true for general actions, but because
  -- reachability is restricted to movements, we get some milage out of
  -- them anyway.
  endpoints : ∀{Γ e t L e' t'} →
              Γ ⊢ (e ◆e) => t →
              runsynth Γ e t L e' t' →
              movements L →
              t == t'
  endpoints _ DoRefl AM[] = refl
  endpoints wt (DoSynth x rs) (AM:: mv)
    with endpoints (actsense-synth (rel◆ _) (rel◆ _) x wt) rs mv
  ... | refl = π2 (moveerase-synth (rel◆ _) wt x)

  ziplem-moves-asc2 : ∀{ Γ l t t' e t◆} →
                      movements l →
                      erase-t t t◆ →
                      Γ ⊢ e <= t◆ →
                      runtype t l t' →
                      runsynth Γ (e ·:₂ t) t◆ l (e ·:₂ t') t◆
  ziplem-moves-asc2 _ _ _ DoRefl = DoRefl
  ziplem-moves-asc2 (AM:: m) er wt (DoType x rt) with moveeraset' er x
  ... | er' =  DoSynth (SAZipAsc2 x er' er wt) (ziplem-moves-asc2 m er' wt rt)

  synthana-moves : ∀{t t' l e e' Γ} →
                   Γ ⊢ e ◆e => t' →
                   movements l →
                   t ~ t' →
                   runsynth Γ e t' l e' t' →
                   runana Γ e l e' t
  synthana-moves _ _ _ DoRefl = DoRefl
  synthana-moves wt (AM:: m) c (DoSynth x rs) with π2 (moveerase-synth (rel◆ _) wt x)
  ... | refl =
    DoAna (AASubsume (rel◆ _) wt x c)
          (synthana-moves (actsense-synth (rel◆ _) (rel◆ _) x wt) m c rs)

  ziplem-moves-halflam1 : ∀{Γ e t1 t1' t1◆ t1'◆ t2 t2' x l} →
                          x # Γ →
                          erase-t t1 t1◆ →
                          erase-t t1' t1'◆ →
                          movements l →
                          runtype t1 l t1' →
                          (Γ ,, (x , t1◆)) ⊢ e => t2 →
                          (Γ ,, (x , t1'◆)) ⊢ e => t2' →
                          runsynth Γ (·λ x ·[ t1 ]₁ e) (t1◆ ==> t2) l
                          (·λ x ·[ t1' ]₁ e) (t1'◆ ==> t2')
  ziplem-moves-halflam1 apt et et' AM[] DoRefl wt1 wt2
    with eraset-det et et'
  ... | refl with synthunicity wt1 wt2
  ... | refl = DoRefl
  ziplem-moves-halflam1 apt et et' (AM:: mv) (DoType x rt) wt1 wt2
    with erase-t◆ et | erase-t◆ et'
  ... | refl | refl with moveeraset x
  ... | qq rewrite qq with ziplem-moves-halflam1 apt (rel◆t _) (rel◆t _) mv rt wt1 wt2
  ... | ww = DoSynth (SAZipLam1 apt et (rel◆t _) x wt1 wt1) ww

  ziplem-moves-ap1 : ∀{Γ l e1 e1' e2 t t' tx} →
                     Γ ⊢ e1 ◆e => t →
                     t ▸arr (tx ==> t') →
                     Γ ⊢ e2 <= tx →
                     movements l →
                     runsynth Γ e1 t l e1' t →
                     runsynth Γ (e1 ∘₁ e2) t' l (e1' ∘₁ e2) t'
  ziplem-moves-ap1 _ _ _ _ DoRefl = DoRefl
  ziplem-moves-ap1 wt1 mch wt2 (AM:: m) (DoSynth x rs) with π2 (moveerase-synth (rel◆ _) wt1 x)
  ... | refl =
    DoSynth (SAZipApArr mch (rel◆ _) wt1 x wt2)
    (ziplem-moves-ap1 (actsense-synth (rel◆ _) (rel◆ _) x wt1) mch wt2 m rs)

  -- zip lemmas for sums
  ziplem-inl : ∀{t t1 t2 Γ e L e'} →
               t ▸sum (t1 ⊕ t2) →
               runana Γ e L e' t1 →
               runana Γ (inl e) L (inl e') t
  ziplem-inl m DoRefl = DoRefl
  ziplem-inl m (DoAna x r) = DoAna (AAZipInl m x) (ziplem-inl m r)

  ziplem-inr : ∀{t t1 t2 Γ e L e'} →
               t ▸sum (t1 ⊕ t2) →
               runana Γ e L e' t2 →
               runana Γ (inr e) L (inr e') t
  ziplem-inr m DoRefl = DoRefl
  ziplem-inr m (DoAna x r) = DoAna (AAZipInr m x) (ziplem-inr m r)

  ziplem-case1a : ∀{x Γ y e e◆ t0 t+ e' e1 e2 L t1 t2 t} →
                  x # Γ →
                  y # Γ →
                  erase-e e e◆ →
                  Γ ⊢ e◆ => t0 →
                  runsynth Γ e t0 L e' t+ →
                  t+ ▸sum (t1 ⊕ t2) →
                  (Γ ,, (x , t1)) ⊢ e1 <= t →
                  (Γ ,, (y , t2)) ⊢ e2 <= t →
                  movements L →
                  runana Γ (case₁ e x e1 y e2) L (case₁ e' x e1 y e2) t
  ziplem-case1a x# y# er wt0 DoRefl m wt1 wt2 mv = DoRefl
  ziplem-case1a x# y# er wt0 (DoSynth α rs) m wt1 wt2 (AM:: mv)
    with endpoints (actsense-synth er (rel◆ _) α wt0) rs mv
  ... | refl with (π2 (moveerase-synth er wt0 α))
  ... | refl =
    DoAna (AAZipCase1 x# y# er wt0 α m wt1 wt2)
          (ziplem-case1a x# y# (eq-er-trans (π1 (moveerase-synth er wt0 α)) er)
                         wt0 rs m wt1 wt2 mv)

  ziplem-case1b : ∀{Γ e e' t L t' x y t0 e◆ u u1 u2} →
                  x # Γ →
                  y # Γ →
                  erase-e e e◆ →
                  Γ ⊢ e◆ => t →
                  runsynth Γ e t L e' t' →
                  runana Γ (case₁ ⦇⌜ e ⌟⦈[ u ] x ⦇-⦈[ u1 ] y ⦇-⦈[ u2 ]) L
                           (case₁ ⦇⌜ e' ⌟⦈[ u ] x ⦇-⦈[ u1 ] y ⦇-⦈[ u2 ]) t0
  ziplem-case1b _ _ _ _ DoRefl = DoRefl
  ziplem-case1b x# y# er wt (DoSynth x₁ rs) =
    DoAna (AAZipCase1 x# y# (erase-in-hole er) (SNEHole wt) (SAZipNEHole er wt x₁)
          MSHole (ASubsume SEHole TCHole1) (ASubsume SEHole TCHole1))
          (ziplem-case1b x# y# (rel◆ _) (actsense-synth er (rel◆ _) x₁ wt) rs)

  ziplem-case2 : ∀{t t+ t1 t2 Γ x y e e1 e1' e2 l} →
                 x # Γ →
                 y # Γ →
                 Γ ⊢ e => t+ →
                 (Γ ,, (y , t2)) ⊢ e2 <= t →
                 t+ ▸sum (t1 ⊕ t2) →
                 runana (Γ ,, (x , t1)) e1 l e1' t →
                 runana Γ (case₂ e x e1 y e2) l (case₂ e x e1' y e2) t
  ziplem-case2 x# y# wt1 wt2 m DoRefl = DoRefl
  ziplem-case2 x# y# wt1 wt2 m (DoAna x₁ ra) =
    DoAna (AAZipCase2 x# y# wt1 m x₁)
          (ziplem-case2 x# y# wt1 wt2 m ra)

  ziplem-case3  : ∀{t t+ t1 t2 Γ x y e e1 e2 e2' l} →
                  x # Γ →
                  y # Γ →
                  Γ ⊢ e => t+ →
                  (Γ ,, (x , t1)) ⊢ e1 <= t →
                  t+ ▸sum (t1 ⊕ t2) →
                  runana (Γ ,, (y , t2)) e2 l e2' t →
                  runana Γ (case₃ e x e1 y e2) l (case₃ e x e1 y e2') t
  ziplem-case3 x# y# wt1 wt2 m DoRefl = DoRefl
  ziplem-case3 x# y# wt1 wt2 m (DoAna x₁ ra) =
    DoAna (AAZipCase3 x# y# wt1 m x₁)
          (ziplem-case3 x# y# wt1 wt2 m ra)

  -- zip lemma for products
  ziplem-pair1 : ∀ {t1 t1' t2 Γ e1 e1◆ l e1' e2} →
                 erase-e e1 e1◆ →
                 Γ ⊢ e1◆ => t1 →
                 runsynth Γ e1 t1 l e1' t1' →
                 Γ ⊢ e2 => t2 →
                 runsynth Γ ⟨ e1 , e2 ⟩₁ (t1 ⊠ t2) l ⟨ e1' , e2 ⟩₁ (t1' ⊠ t2)
  ziplem-pair1 er wt1 DoRefl wt2 = DoRefl
  ziplem-pair1 er wt1 (DoSynth x rs) wt2 =
    DoSynth (SAZipPair1 er wt1 x wt2)
            (ziplem-pair1 (rel◆ _) (actsense-synth er (rel◆ _) x wt1) rs wt2)

  ziplem-pair2 : ∀ {t1 t2 t2' Γ e1 e2 e2◆ l e2'} →
                 Γ ⊢ e1 => t1 →
                 erase-e e2 e2◆ →
                 Γ ⊢ e2◆ => t2 →
                 runsynth Γ e2 t2 l e2' t2' →
                 runsynth Γ ⟨ e1 , e2 ⟩₂ (t1 ⊠ t2) l ⟨ e1 , e2' ⟩₂ (t1 ⊠ t2')
  ziplem-pair2 wt1 er wt2 DoRefl = DoRefl
  ziplem-pair2 wt1 er wt2 (DoSynth x rs) =
    DoSynth (SAZipPair2 wt1 er wt2 x)
            (ziplem-pair2 wt1 (rel◆ _) (actsense-synth er (rel◆ _) x wt2) rs)

  ziplem-moves-fst : ∀ {t× t×' t1 t1' t2 t2' Γ e e◆ l e'} →
                   t× ▸prod (t1 ⊠ t2) →
                   t×' ▸prod (t1' ⊠ t2') →
                   erase-e e e◆ →
                   Γ ⊢ e◆ => t× →
                   movements l →
                   runsynth Γ e t× l e' t×' →
                   runsynth Γ (fst e) t1 l (fst e') t1'
  ziplem-moves-fst pr pr' er wt m DoRefl with ▸prod-unicity pr pr'
  ... | refl = DoRefl
  ziplem-moves-fst pr pr' er wt (AM:: m) (DoSynth x rs)
    with endpoints (actsense-synth er (rel◆ _) x wt) rs m
  ... | refl with moveerase-synth er wt x
  ... | q , refl with ▸prod-unicity pr pr'
  ... | refl =
    DoSynth (SAZipFst pr pr' er wt x)
            (ziplem-moves-fst pr pr' (eq-er-trans q er) wt m rs)

  ziplem-moves-snd : ∀ {t× t×' t1 t1' t2 t2' Γ e e◆ l e'} →
                   t× ▸prod (t1 ⊠ t2) →
                   t×' ▸prod (t1' ⊠ t2') →
                   erase-e e e◆ →
                   Γ ⊢ e◆ => t× →
                   movements l →
                   runsynth Γ e t× l e' t×' →
                   runsynth Γ (snd e) t2 l (snd e') t2'
  ziplem-moves-snd pr pr' er wt m DoRefl with ▸prod-unicity pr pr'
  ... | refl = DoRefl
  ziplem-moves-snd pr pr' er wt (AM:: m) (DoSynth x rs)
    with endpoints (actsense-synth er (rel◆ _) x wt) rs m
  ... | refl with moveerase-synth er wt x
  ... | q , refl with ▸prod-unicity pr pr'
  ... | refl =
    DoSynth (SAZipSnd pr pr' er wt x)
            (ziplem-moves-snd pr pr' (eq-er-trans q er) wt m rs)


------------------------------------------------------------------------
-- The Agda standard library
--
-- Base definitions for the right-biased universe-sensitive functor
-- and monad instances for the Product type.
--
-- To minimize the universe level of the RawFunctor, we require that
-- elements of B are "lifted" to a copy of B at a higher universe level
-- (a ⊔ b). See the Data.Product.Categorical.Examples for how this is
-- done.
------------------------------------------------------------------------

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

open import Level

module Data.Product.Categorical.Right.Base
  {b} (B : Set b) (a : Level) where

open import Data.Product using (_×_; map₁; proj₁; proj₂; <_,_>)
open import Category.Functor using (RawFunctor)
open import Category.Comonad using (RawComonad)

------------------------------------------------------------------------
-- Definitions

Productᵣ : Set (a ⊔ b) → Set (a ⊔ b)
Productᵣ A = A × B

functor : RawFunctor Productᵣ
functor = record { _<$>_ = map₁ }

comonad : RawComonad Productᵣ
comonad = record
  { extract = proj₁
  ; extend  = <_, proj₂ >
  }


module _ where

postulate
  T U V : Set
  F G : Set → Set
  Sea : {A : Set} → (A → A → Set) → Set
  Seas : {I : Set} (As : I → Set) → ({i j : I} → As i → As j → Set) → Set
  _eq_ _to_ : T → T → Set

record K : Set₁ where
  field
    A : Set
    B : A → A → Set
    C : Sea B

record IK (I : Set) : Set₁ where
  field
    As : I → Set
    Bs : {i j : I} → As i → As j → Set
    Cs : Seas As Bs

open K
open IK

record L (f t : K) : Set where
  field
    D : A f → A t
    E : ∀ {x y} → (B f x y) → B t (D x) (D y)

record IL (f : K) (t : IK (A f)): Set where
  field
    Ds : (x : A f) → As t x
    Es : ∀ {x y} → (B f x y) → Bs t (Ds x) (Ds y)

-- make Cs or E irrelevant and the last line turns yellow
postulate blah : ∀ {a b c : K} → L a b → L b c → L a c

foop : ∀ {a b c d : K} → L a b → L b c → L c d → L a d
foop f g h = blah f (blah g h)

postulate Equiv : Sea _eq_

Cat : K
Cat = record
  { A = T
  ; B = _eq_
  ; C = Equiv
  }

record T2 : Set where
  constructor _,_
  field fst snd : T

open T2

record _eq2_ (a b : T2) : Set where
  constructor _∧_
  field
    feq : (fst a) eq (fst b)
    seq : (snd a) eq (snd b)

postulate Equiv2 : Sea _eq2_

Cat2 : K
Cat2 = record { A = T2; B = _eq2_; C = Equiv2 }

postulate
  Hm : T2 → Set
  _heq_ : {t t' : T2} → Hm t → Hm t' → Set
  HEquiv : Seas Hm _heq_

Hom : IK T2
Hom = record
  { As = Hm
  ; Bs = _heq_
  ; Cs = HEquiv
  }

_×_ : ∀ {U} → L U Cat → L U Cat → L U Cat2
X × Y = record { D = λ x → L.D X x , L.D Y x
               ; E = λ x' → L.E X x' ∧ L.E Y x' }

postulate
  _∘_ : ∀ {a b c} → Hm (b , c) → Hm (a , b) → Hm (a , c)
  ∘cong : ∀ {a b c} {f f' : Hm (b , c)} {g g' : Hm (a , b)} → f heq f' → g heq g' → (f ∘ g) heq (f' ∘ g')
  _∘H_ : ∀ {a b c} → Hm (b , c) → Hm (a , b) → Hm (a , c)

module Fool (Base : K) where
  Dust = L Base Cat

  promote : L Base Cat2 → IK (A Base)
  promote f = record
    { As = λ x → Hm (L.D f x)
    ; Bs = λ x y → x heq y
    ; Cs = my-Cs
    }
    where
    postulate my-Cs : Seas (λ x → Hm (L.D f x)) (λ {i} {j} x y → x heq y)

  Dance : Dust → Dust → Set
  Dance f t = IL Base (promote (f × t))

  _⊚_ : ∀ {as bs cs} → Dance bs cs → Dance as bs → Dance as cs
  _⊚_ {as} {bs} {cs} fs gs = record
    { Ds = λ x → IL.Ds fs x ∘ IL.Ds gs x
    ; Es = my-Es
    }
    where
    postulate my-Es : ∀ {x y} → B Base x y → _

  comp3 : ∀ {as bs cs ds} → Dance cs ds → Dance bs cs → Dance as bs → Dance as ds
  comp3 f g h = f ⊚ (g ⊚ h)


module Bool where

data Bool : Set where
  true  : Bool
  false : Bool

if_then_else_ : {A : Set} -> Bool -> A -> A -> A
if true  then x else y = x
if false then x else y = y


module VecMap where

open import Prelude

map : forall {A B n} -> (A -> B) -> Vec A n -> Vec B n
map f xs = {!!}


open import Relation.Ternary.Separation

module Relation.Ternary.Separation.Monad.CompleteUpdate
  {a} {A : Set a} {{r : RawSep A}} {u} {{ s : IsUnitalSep r u }}
  where

open import Function
open import Level hiding (Lift)
open import Data.Product
open import Data.Unit using (⊤)

open import Relation.Unary
open import Relation.Unary.PredicateTransformer using (Pt)
open import Relation.Binary hiding (_⇒_)
open import Relation.Binary.PropositionalEquality as P

open import Relation.Ternary.Separation.Morphisms
open import Relation.Ternary.Separation.Monad
open import Relation.Ternary.Separation.Construct.Product
open import Relation.Ternary.Separation.Construct.Market

open Monads {{ bs = record { Carrier = A × A } }} (id-morph (A × A))
open ⟰_

module Update where
  private bind' : ∀ {p q} {P : Pred (A × A) p} {Q : Pred (A × A) q} → ∀[ (P ─✴ ⟰ Q) ⇒ (⟰ P ─✴ ⟰ Q) ]
  updater (app (bind' f) c σ) fr with ⊎-assoc (⊎-comm σ) fr
  ... | xs , σ₂ , σ₃ with updater c σ₂
  ... | ys , zs , σ₄ , px with ⊎-unassoc σ₄ σ₃
  ... | _ , σ₅ , σ₆ = updater (app f px (⊎-comm σ₅)) σ₆

  ⟰-monad : Monad ⊤ a (λ _ _ → ⟰_)
  updater (Monad.return ⟰-monad px) fr = -, -, fr , px
  Monad.bind ⟰-monad = bind'

{- updates with failure -}
module UpdateWithFailure where

  open import Relation.Ternary.Separation.Monad.Error
  open import Data.Sum

  ⟰? : Pt (A × A) a
  ⟰? P = ⟰ (Err P)

  instance ⟰?-monad : Monad ⊤ a (λ _ _ → ⟰?)
  Monad.return ⟰?-monad px = Monad.return Update.⟰-monad (return px)
  updater (app (Monad.bind ⟰?-monad f) m σ) fr with ⊎-assoc (⊎-comm σ) fr
  ... | _ , σ₂ , σ₃ with updater m σ₂
  ... | _ , _ , τ₁ , error  = -, -, fr , error
  ... | _ , _ , τ₁ , partial (inj₂ v) with ⊎-unassoc τ₁ σ₃
  ... | _ , τ₃ , τ₄ = updater (app f v (⊎-comm τ₃)) τ₄

  ⟰error : ∀ P → ∀[ ⟰? P ]
  updater (⟰error _) fr = -, -, fr , error


module Issue157b where

postulate
  A B : Set
  R   : A → B → Set
  err : ∀ {a b} → R a b → R b


{-# OPTIONS --without-K #-}
module sum-properties where

open import Type
import Level as L
open L using (Lift)
open import Data.Zero using (𝟘)
open import Data.Bool.NP
open Data.Bool.NP.Indexed
open import Data.Nat.NP
open import Data.Nat.Properties
open import Data.Product renaming (map to pmap)
open import Data.Sum
open import Relation.Binary.Product.Pointwise
open import Data.Maybe
open import Data.One using (𝟙)
open import Function.NP
import Function.Inverse as Inv
open Inv using (_↔_)
open import Function.Related
open import Function.Related.TypeIsomorphisms.NP
open import Function.Equality using (_⟨$⟩_)

--open import sum
open import Search.Type
open import Search.Sum
open import Search.Derived using (sum-swap)
open import Search.Searchable renaming (Searchable to SumProp)
open import Search.Searchable.Fin
open import Search.Searchable.Product
open import Search.Searchable.Sum
open import Relation.Binary.Sum
import Relation.Binary.PropositionalEquality.NP as ≡
open ≡ using (_≡_ ; _≗_ ; _≗₂_)

module _M2 {A : ★} (μA : SumProp A) (f g : A → Bool) where

sum-ext₂ : ∀ {A B}{f g : A → B → ℕ}(μA : SumProp A)(μB : SumProp B) → f ≗₂ g → sum μA (sum μB ∘ f) ≡ sum μA (sum μB ∘ g)
sum-ext₂ μA μB f≗g = sum-ext μA (sum-ext μB ∘ f≗g)

CountStableUnderInjection : ∀ {A} → SumProp A → Set
CountStableUnderInjection μ = ∀ p → Injective p → CountStableUnder (count μ) p

#-StableUnderInjection : ∀ {A}{μ : SumProp A} → SumStableUnderInjection (sum μ) → CountStableUnderInjection μ
#-StableUnderInjection sui p p-inj f = sui p p-inj (toℕ ∘ f)

𝟙SUI : SumStableUnderInjection (sum μ𝟙)
𝟙SUI f p x = ≡.refl

{-
stableMaybe : ∀ {A} (μA : SumProp A) → StableUnderInjection μA
                                     → StableUnderInjection (μMaybe μA)
stableMaybe {A} μA suiA f p p-inj with p nothing | ≡.inspect p nothing
... | nothing | ≡.[ eq ] = {!!}
  where h : ∀ x → p (just x) ≡ just {!!}
        h = {!!}
        p' : A → A
        p' x = {!p (just x)!}
        p'-inj : Injective p'
        p'-inj = {!!}
... | just pn | ≡.[ eq ] = ≡.trans (≡.cong (λ x → f nothing + x) (suiA (f ∘ just) p' p'-inj)) {!!}
  where p' : A → A
        p' x = maybe id pn (p (just x))
        p'-inj : Injective p'
        p'-inj = {!!}

SumsOk : ∀ {A B} → SumProp A → SumProp B → A ↔ B → ★
SumsOk μA μB iso = ∀ f → sum μA f ≡ sum μB (f ∘ from)
  where from = _⟨$⟩_ (Inv.Inverse.from iso)

module StableIso {A B}(μA : SumProp A)(μB : SumProp B)(iso : A ↔ B)
                 (sums-ok : SumsOk μA μB iso)
                 (suiB    : StableUnderInjection μB) where
  to : A → B
  to x = Inv.Inverse.to iso ⟨$⟩ x

  from : B → A
  from x = Inv.Inverse.from iso ⟨$⟩ x

  from-inj : Injective from
  from-inj = Inv.Inverse.injective (Inv.sym iso)

  to-inj : Injective to
  to-inj = Inv.Inverse.injective iso

  left-inv : from ∘ to ≗ id
  left-inv = Inv.Inverse.left-inverse-of iso

  stable : StableUnderInjection μA
  stable f p p-inj
    = sum μA f
    ≡⟨ sums-ok f ⟩
      sum μB (f ∘ from)
    ≡⟨ suiB (f ∘ from) (to ∘ p ∘ from) (from-inj ∘ p-inj ∘ to-inj) ⟩
      sum μB (f ∘ from ∘ to ∘ p ∘ from)
    ≡⟨ sum-ext μB (λ x → ≡.cong f (left-inv (p (from x)))) ⟩
      sum μB (f ∘ p ∘ from)
    ≡⟨ ≡.sym (sums-ok (f ∘ p)) ⟩
      sum μA (f ∘ p)
    ∎
    where open ≡.≡-Reasoning

record Iso1+ {A : Set}(μA : SumProp A) : ★₁ where
  constructor mk
  field
    B   : ★
    μB  : SumProp B
    iso : A ↔ Maybe B

  toMaybe : A → Maybe B
  toMaybe x = Inv.Inverse.to iso ⟨$⟩ x

  fromMaybe : Maybe B → A
  fromMaybe x = Inv.Inverse.from iso ⟨$⟩ x

  field
    sums-ok  : ∀ f → sum μA f ≡ sum (μMaybe μB) (f ∘ fromMaybe)

  from-inj : Injective fromMaybe
  from-inj = Inv.Inverse.injective (Inv.sym iso)

  to-inj : Injective toMaybe
  to-inj = Inv.Inverse.injective iso

  left-inv : fromMaybe ∘ toMaybe ≗ id
  left-inv = Inv.Inverse.left-inverse-of iso

  stable : StableUnderInjection (μMaybe μB) → StableUnderInjection μA
  stable suiMB = StableIso.stable μA (μMaybe μB) iso sums-ok suiMB

-- iso1+𝟙 : Iso1+ μ𝟙
-- iso1+𝟙 = {!mk !}

iso1+Maybe : ∀ {A} (μA : SumProp A) → Iso1+ μA → Iso1+ (μMaybe μA)
iso1+Maybe {A} μA A≅1+ = mk A μA Inv.id (λ f → ≡.refl)

iso1+FinSuc : ∀ n → Iso1+ (μFinSuc (suc n))
iso1+FinSuc n = mk (Fin (suc n)) (μFinSuc n) Fin∘suc↔Maybe∘Fin (λ f → ≡.refl)
-}

infix 4 _≈_

record _≈_ {A B} (μA : SumProp A)(μB : SumProp B) : Set where
  constructor mk
  field
    iso : A ↔ B
  from : B → A
  from x = Inv.Inverse.from iso ⟨$⟩ x

  to : A → B
  to x = Inv.Inverse.to iso ⟨$⟩ x

  from-inj : Injective from
  from-inj = Inv.Inverse.injective (Inv.sym iso)

  to-inj : Injective to
  to-inj = Inv.Inverse.injective iso

  field
    sums-ok : ∀ f → sum μA f ≡ sum μB (f ∘ from)

  sums-ok' : ∀ f → sum μB f ≡ sum μA (f ∘ to)
  sums-ok' f = sum μB f
             ≡⟨ sum-ext μB (≡.cong f ∘ ≡.sym ∘ Inv.Inverse.right-inverse-of iso) ⟩
               sum μB (f ∘ to ∘ from)
             ≡⟨ ≡.sym (sums-ok (f ∘ to)) ⟩
               sum μA (f ∘ to)
             ∎
    where open ≡.≡-Reasoning

  StableUnder≈ : SumStableUnderInjection (sum μA) → SumStableUnderInjection (sum μB)
  StableUnder≈ μA-SUI p p-inj f
    = sum μB f
    ≡⟨ sums-ok' f ⟩
      sum μA (f ∘ to)
    ≡⟨ μA-SUI (from ∘ p ∘ to) (to-inj ∘ p-inj ∘ from-inj) (f ∘ to) ⟩
      sum μA (f ∘ to ∘ from ∘ p ∘ to)
    ≡⟨ ≡.sym (sums-ok' (f ∘ to ∘ from ∘ p)) ⟩
      sum μB (f ∘ to ∘ from ∘ p)
    ≡⟨ sum-ext μB (≡.cong f ∘ Inv.Inverse.right-inverse-of iso ∘ p) ⟩
      sum μB (f ∘ p)
    ∎
    where open ≡.≡-Reasoning

≈-refl : ∀ {A} (μA : SumProp A) → μA ≈ μA
≈-refl μA = mk Inv.id (λ f → ≡.refl)

≈-id : ∀ {A} {μA : SumProp A} → μA ≈ μA
≈-id = ≈-refl _

≈-sym : ∀ {A B}{μA : SumProp A}{μB : SumProp B} → μA ≈ μB → μB ≈ μA
≈-sym A≈B = mk (Inv.sym iso) sums-ok'
  where open _≈_ A≈B

≈-trans : ∀ {A B C}{μA : SumProp A}{μB : SumProp B}{μC : SumProp C} → μA ≈ μB → μB ≈ μC → μA ≈ μC
≈-trans A≈B B≈C = mk (iso B≈C Inv.∘ iso A≈B) (λ f → ≡.trans (sums-ok A≈B f) (sums-ok B≈C (f ∘ from A≈B)))
  where open _≈_

infix 2 _≈∎
infixr 2 _≈⟨_⟩_

_≈∎ : ∀ {A} (μA : SumProp A) → μA ≈ μA
_≈∎ = ≈-refl

_≈⟨_⟩_ : ∀ {A B C} (μA : SumProp A){μB : SumProp B}{μC : SumProp C} → μA ≈ μB → μB ≈ μC → μA ≈ μC
_ ≈⟨ A≈B ⟩ B≈C = ≈-trans A≈B B≈C

{-
Fin1≈𝟙 : μFin 1 ≈ μ𝟙
Fin1≈𝟙 = mk iso sums-ok where
  open import Relation.Binary.Sum
  iso : _
  iso = (A⊎𝟘↔A Inv.∘ Inv.id ⊎-cong Fin0↔𝟘) Inv.∘ Fin∘suc↔𝟙⊎Fin

  sums-ok : (_ : _) → _
  sums-ok f = ≡.refl
-}

𝟙+Fin : ∀ {n pf} → μ𝟙 ⊎-μ μFinSuc n ≈ μFinSuc (suc n)
𝟙+Fin {zero} {()}
𝟙+Fin {suc n} = mk iso sums-ok where
  iso : _
  iso = Inv.sym Fin∘suc↔𝟙⊎Fin

  sums-ok : (_ : _) → _
  sums-ok f = ≡.refl

𝟙×A≈A : ∀ {A}{μA : SumProp A} → μ𝟙 ×-μ μA ≈ μA
𝟙×A≈A = mk iso sums-ok where
  iso : _
  iso = 𝟙×A↔A

  sums-ok : (_ : _) → _
  sums-ok f = ≡.refl

μFinSucPres : ∀ {m n} → m ≡ n → μFinSuc m ≈ μFinSuc n
μFinSucPres eq rewrite eq = ≈-refl _

μFinPres : ∀ {m n pfm pfn} → m ≡ n → μFinSuc m {pfm} ≈ μFinSuc n {pfn}
μFinPres eq rewrite eq = ≈-refl _

  {-
Maybe-Finable : ∀ {A} (μA : SumProp A) → Finable μA → Finable (μMaybe μA)
Maybe-Finable {A} μA finA = mk card iso sums-ok where
  module FinA = Finable finA
  card = suc FinA.FinCard

  |A| : ℕ
  |A| = suc (Finable.FinCard finA)

  iso : _
  iso = (𝟙 ⊎ A)       ↔⟨ Inv.id ⊎-cong FinA.iso ⟩
        (𝟙 ⊎ Fin |A|) ↔⟨ sym Fin∘suc↔𝟙⊎Fin ⟩
        Fin (suc |A|) ∎
    where open EquationalReasoning

  sums-ok : (_ : _) → _
  sums-ok f = ≡.cong (λ x → f (inj₁ _) + x) (FinA.sums-ok _)
-}

_+μ-cong_ : ∀ {A B C D}{μA : SumProp A}{μB : SumProp B}{μC : SumProp C}{μD : SumProp D}
          → μA ≈ μC → μB ≈ μD → μA ⊎-μ μB ≈ μC ⊎-μ μD
A≈C +μ-cong B≈D = mk iso sums-ok where
  open import Relation.Binary.Sum
  iso : _
  iso = (_≈_.iso A≈C) ⊎-cong (_≈_.iso B≈D)

  sums-ok : (_ : _) → _
  sums-ok f = ≡.cong₂ _+_ (_≈_.sums-ok A≈C (f ∘ inj₁)) (_≈_.sums-ok B≈D (f ∘ inj₂))

+μ-assoc : ∀ {A B C}(μA : SumProp A)(μB : SumProp B)(μC : SumProp C)
         → (μA ⊎-μ μB) ⊎-μ μC ≈ μA ⊎-μ (μB ⊎-μ μC)
+μ-assoc μA μB μC = mk iso sums-ok where
  iso : _
  iso = ⊎-CMon.assoc _ _ _

  sums-ok : (_ : _) → _
  sums-ok f = ℕ°.+-assoc (sum μA (f ∘ inj₁ ∘ inj₁)) (sum μB (f ∘ inj₁ ∘ inj₂)) (sum μC (f ∘ inj₂))

+μ-comm : ∀ {A B}(μA : SumProp A)(μB : SumProp B)
        → μA ⊎-μ μB ≈ μB ⊎-μ μA
+μ-comm μA μB = mk iso sums-ok where
  iso : _
  iso = ⊎-CMon.comm _ _

  sums-ok : (_ : _) → _
  sums-ok f = ℕ°.+-comm (sum μA (f ∘ inj₁)) (sum μB (f ∘ inj₂))

_×μ-cong_ :  ∀ {A B C D}{μA : SumProp A}{μB : SumProp B}{μC : SumProp C}{μD : SumProp D}
          → μA ≈ μC → μB ≈ μD → μA ×-μ μB ≈ μC ×-μ μD
_×μ-cong_ {μA = μA}{μD = μD} A≈C B≈D = mk iso sums-ok where
  open import Relation.Binary.Product.Pointwise
  iso : _
  iso = _≈_.iso A≈C ×-cong _≈_.iso B≈D

  sums-ok : (_ : _) → _
  sums-ok f = ≡.trans (sum-ext μA (_≈_.sums-ok B≈D ∘ curry f))
                      (_≈_.sums-ok A≈C (λ a → sum μD (curry f a ∘ (_≈_.from B≈D))))

×μ-assoc : ∀ {A B C}(μA : SumProp A)(μB : SumProp B)(μC : SumProp C)
         → (μA ×-μ μB) ×-μ μC ≈ μA ×-μ (μB ×-μ μC)
×μ-assoc μA μB μC = mk iso sums-ok where
  iso : _
  iso = ×-CMon.assoc _ _ _

  sums-ok : (_ : _) → _
  sums-ok f = ≡.refl

×μ-comm : ∀ {A B}(μA : SumProp A)(μB : SumProp B)
        → μA ×-μ μB ≈ μB ×-μ μA
×μ-comm μA μB = mk iso sums-ok where
  iso : _
  iso = ×-CMon.comm _ _

  sums-ok : (_ : _) → _
  sums-ok f = sum-swap μA μB (curry f)

×+-distrib : ∀ {A B C}(μA : SumProp A)(μB : SumProp B)(μC : SumProp C)
           → (μA ⊎-μ μB) ×-μ μC ≈ (μA ×-μ μC) ⊎-μ (μB ×-μ μC)
×+-distrib μA μB μC = mk iso sums-ok where
  iso : _
  iso = ×⊎°.distribʳ _ _ _

  sums-ok : (_ : _) → _
  sums-ok f = ≡.refl

{-
_Suc-+_ : ∀ {m} → Suc m → ∀ n → Suc (m + n)
_Suc-+_ {zero}  () _
_Suc-+_ {suc m} _  _ = _

+-≈ : ∀ m n {pfm pfn} → (μFin m {pfm}) +μ (μFin n {pfn}) ≈ μFin (m + n) {pfm Suc-+ n}
+-≈ zero _ {()}
+-≈ _ zero {_} {()}
+-≈ (suc m) (suc n) = μFin (suc m) +μ μFin (suc n)
                    ≈⟨ {!!} ⟩
                      μFin (suc m + suc n)
                    ≈∎
-}

{-
+-≈ (suc zero) (suc n) = μFin 1 +μ μFin (suc n)
               ≈⟨ Fin1≈𝟙 +μ-cong ≈-refl (μFin (suc n)) ⟩
                μ𝟙 +μ μFinSuc n
              ≈⟨ 𝟙+Fin ⟩
                μFinSuc (suc n)
              ≈∎
+-≈ (suc (suc m)) (suc n) = μFinSuc (suc m) +μ μFinSuc n
              ≈⟨ ≈-sym 𝟙+Fin +μ-cong ≈-refl (μFinSuc n) ⟩
                (μ𝟙 +μ μFinSuc m) +μ μFinSuc n
              ≈⟨ +μ-assoc μ𝟙 (μFinSuc m) (μFinSuc n) ⟩
                μ𝟙 +μ (μFinSuc m +μ μFinSuc n)
              ≈⟨ ≈-refl μ𝟙 +μ-cong +-≈ (suc m) (suc n) ⟩
                μ𝟙 +μ μFinSuc (m + suc n)
              ≈⟨ 𝟙+Fin ⟩
                μFinSuc (suc m + suc n)
              ≈∎
              -}

{-
+-≈ : ∀ m n → (μFinSuc m) +μ (μFinSuc n) ≈ μFinSuc (m + suc n)
+-≈ zero n    = μFinSuc zero +μ μFinSuc n
              ≈⟨ Fin1≈𝟙 +μ-cong ≈-refl (μFinSuc n) ⟩
                μ𝟙 +μ μFinSuc n
              ≈⟨ 𝟙+Fin ⟩
                μFinSuc (suc n)
              ≈∎
+-≈ (suc m) n = μFinSuc (suc m) +μ μFinSuc n
              ≈⟨ ≈-sym 𝟙+Fin +μ-cong ≈-refl (μFinSuc n) ⟩
                (μ𝟙 +μ μFinSuc m) +μ μFinSuc n
              ≈⟨ +μ-assoc μ𝟙 (μFinSuc m) (μFinSuc n) ⟩
                μ𝟙 +μ (μFinSuc m +μ μFinSuc n)
              ≈⟨ ≈-refl μ𝟙 +μ-cong +-≈ m n ⟩
                μ𝟙 +μ μFinSuc (m + suc n)
              ≈⟨ 𝟙+Fin ⟩
                μFinSuc (suc m + suc n)
              ≈∎

×-≈ : ∀ m n → μFinSuc m ×μ μFinSuc n ≈ μFinSuc (n + m * suc n)
×-≈ zero n    = μFinSuc 0 ×μ μFinSuc n
              ≈⟨ Fin1≈𝟙 ×μ-cong (≈-refl (μFinSuc n)) ⟩
                μ𝟙 ×μ μFinSuc n
              ≈⟨ 𝟙×A≈A ⟩
                μFinSuc n
              ≈⟨ μFinSucPres (ℕ°.+-comm 0 n) ⟩
                μFinSuc (n + 0)
              ≈∎
×-≈ (suc m) n = μFinSuc (suc m) ×μ μFinSuc n
              ≈⟨ ≈-sym 𝟙+Fin ×μ-cong ≈-refl (μFinSuc n) ⟩
                (μ𝟙 +μ μFinSuc m) ×μ μFinSuc n
              ≈⟨ ×+-distrib μ𝟙 (μFinSuc m) (μFinSuc n) ⟩
                (μ𝟙 ×μ μFinSuc n) +μ (μFinSuc m ×μ μFinSuc n)
              ≈⟨ 𝟙×A≈A {μA = μFinSuc n} +μ-cong ×-≈ m n ⟩
                μFinSuc n +μ μFinSuc (n + m * suc n)
              ≈⟨ +-≈ n (n + m * suc n) ⟩
                μFinSuc (n + suc m * suc n)
              ≈∎

-- μA→B ≈ μFinSuc (m ^ n)
-- μB   ≈ μFinSuc m
-- μMaybe→ μA→B μB ≈ μFinSuc (m * m ^ n)

open import Data.Fin using (Fin ; zero ; suc)

Finable : ∀ {A} → SumProp A → Set
Finable μA = Σ ℕ λ FinCard → μA ≈ μFinSuc FinCard

𝟙-Finable : Finable μ𝟙
𝟙-Finable = 0 , ≈-sym Fin1≈𝟙

Fin-Finable : ∀ {n} → Finable (μFinSuc n)
Fin-Finable {n} = n , ≈-refl (μFinSuc n)

+-Finable : ∀ {A B}(μA : SumProp A)(μB : SumProp B) → Finable μA → Finable μB → Finable (μA +μ μB)
+-Finable μA μB (|A| , A≈) (|B| , B≈) = (|A| + suc |B|) ,
  ( μA +μ μB
  ≈⟨ A≈ +μ-cong B≈ ⟩
    μFinSuc |A| +μ μFinSuc |B|
  ≈⟨ +-≈ |A| |B| ⟩
    μFinSuc (|A| + suc |B|) ≈∎)

×-Finable : ∀ {A B}(μA : SumProp A)(μB : SumProp B) → Finable μA → Finable μB → Finable (μA ×μ μB)
×-Finable μA μB (|A| , A≈) (|B| , B≈) = (|B| + |A| * suc |B|) ,
  ( μA ×μ μB
  ≈⟨ A≈ ×μ-cong B≈ ⟩
    μFinSuc |A| ×μ μFinSuc |B|
  ≈⟨ ×-≈ |A| |B| ⟩
    μFinSuc (|B| + |A| * suc |B|)
  ≈∎)

module _M3 where
  open import bijection-fin
  open import Data.Fin using (Fin; zero; suc)
  open import Data.Vec.NP renaming (sum to vsum)

  sumFin : ∀ n → Sum (Fin n)
  sumFin n f = vsum (tabulate f)

  sumFin-spec : ∀ n → sumFin (suc n) ≗ sum (μFinSuc n)
  sumFin-spec zero    f = ℕ°.+-comm (f zero) 0
  sumFin-spec (suc n) f = ≡.cong (_+_ (f zero)) (sumFin-spec n (f ∘ suc))

  sumFinSUI : ∀ n f p → Injective p → sumFin n f ≡ sumFin n (f ∘ p)
  sumFinSUI n f p p-inj = count-perm f p (λ _ _ → p-inj)

  μFinSUI : ∀ {n} → StableUnderInjection (μFinSuc n)
  μFinSUI {n} p p-inj f rewrite ≡.sym (sumFin-spec n f)
                              | ≡.sym (sumFin-spec n (f ∘ p))
                              = sumFinSUI (suc n) f p p-inj
open _M3 public

StableIfFinable : ∀ {A} (μA : SumProp A) → Finable μA → StableUnderInjection μA
StableIfFinable μA (_ , A≈Fin)
  = _≈_.StableUnder≈ (≈-sym A≈Fin) μFinSUI

Decomposable : ★ → ★₁
Decomposable A = (A ↔ 𝟙) ⊎ (∃ λ (B : ★) → A ↔ Maybe B)

open EquationalReasoning

dec-iso : ∀ {A B} → (A ↔ B) → Decomposable A → Decomposable B
dec-iso A↔B (inj₁ A↔𝟙) = inj₁ (A↔𝟙 Inv.∘ sym A↔B)
dec-iso A↔B (inj₂ (C , A↔MaybeC)) = inj₂ (C , A↔MaybeC Inv.∘ sym A↔B)

Maybe×⊎ : ∀ {A B : ★} → (Maybe A × B) ↔ (B ⊎ (A × B))
Maybe×⊎ {A} {B} = (Maybe A × B)   ↔⟨ Maybe↔𝟙⊎ ×-cong Inv.id ⟩
                  ((𝟙 ⊎ A) × B)   ↔⟨ ×⊎°.distribʳ B 𝟙 A ⟩
                  (𝟙 × B ⊎ A × B) ↔⟨ 𝟙×A↔A ⊎-cong Inv.id ⟩
                  (B ⊎ (A × B))   ∎

dec× : ∀ {A B} → Decomposable A → Decomposable B → Decomposable (A × B)
dec× {A} {B} (inj₁ A↔𝟙) dB = dec-iso (B      ↔⟨ sym 𝟙×A↔A ⟩
                                     (𝟙 × B) ↔⟨ sym A↔𝟙 ×-cong Inv.id ⟩
                                     (A × B) ∎) dB
dec× {A} {B} dA (inj₁ B↔𝟙) = dec-iso (A      ↔⟨ sym A×𝟙↔A ⟩
                                     (A × 𝟙) ↔⟨ Inv.id ×-cong sym B↔𝟙 ⟩
                                     (A × B) ∎) dA
dec× {A} {B} (inj₂ (C , A↔1+C)) (inj₂ (D , B↔1+D))
  = inj₂ (_ , Maybe-⊎ Inv.∘ Maybe×⊎ Inv.∘ A↔1+C ×-cong B↔1+D)

dec+ : ∀ {A B} → Decomposable A → Decomposable B → Decomposable (A ⊎ B)
dec+ {A} {B} (inj₁ A↔𝟙)         dB = inj₂ (B , sym Maybe↔𝟙⊎ Inv.∘ A↔𝟙 ⊎-cong Inv.id)
dec+ {A} {B} (inj₂ (C , A↔1+C)) dB = inj₂ ((C ⊎ B) , sym Maybe↔𝟙⊎
                                               Inv.∘ ⊎-CMon.assoc 𝟙 C B
                                               Inv.∘ (Maybe↔𝟙⊎ Inv.∘ A↔1+C) ⊎-cong Inv.id)

{-
dB = dec-iso {!!} dB
  where dec : Decomposable (A × B)
{-
 -- B     + C×B
 -- 1×B   + C×B
 -- (1+C) × B
 -- A     × B
 -}

Stable× : ∀ {A} (μA : SumProp A) {B} (μB : SumProp B)
                (suiA : StableUnderInjection μA)
                (suiB : StableUnderInjection μB)
              → StableUnderInjection (μA ×μ μB)
Stable× μA μB suiA suiB = {!!}

        -- -}
        -- -}
        -- -}
        -- -}


{-# OPTIONS --cubical --safe #-}
module Cubical.Data.SumFin where

open import Cubical.Data.SumFin.Base public


open import Common.Prelude

record Number (A : Set) : Set where
  field fromNat : Nat → A

record Negative (A : Set) : Set where
  field fromNeg : Nat → A

open Number {{...}} public
open Negative {{...}} public

{-# BUILTIN FROMNAT fromNat #-}
{-# BUILTIN FROMNEG fromNeg #-}

instance
  NumberNat : Number Nat
  NumberNat = record { fromNat = λ n → n }

data Int : Set where
  pos : Nat → Int
  neg : Nat → Int

instance
  NumberInt : Number Int
  NumberInt = record { fromNat = pos }

  NegativeInt : Negative Int
  NegativeInt = record { fromNeg = λ { zero → pos 0 ; (suc n) → neg n } }

minusFive : Int
minusFive = -5

open import Common.Equality

thm : -5 ≡ neg 4
thm = refl


open import Agda.Builtin.Reflection renaming (bindTC to _>>=_)
open import Agda.Builtin.Sigma
open import Agda.Builtin.List
open import Agda.Builtin.Unit
open import Agda.Builtin.Nat

map : {A B : Set} → (A → B) → List A → List B
map f [] = []
map f (x ∷ xs) = f x ∷ map f xs

reverseAcc : {A : Set} → List A → List A → List A
reverseAcc [] ys = ys
reverseAcc (x ∷ xs) ys = reverseAcc xs (x ∷ ys)

reverse : {A : Set} → List A → List A
reverse xs = reverseAcc xs []

data Vec (A : Set) : Nat → Set where
  _∷_ : ∀ {n} (x : A) (xs : Vec A n) → Vec A (suc n)

postulate
  replicate : ∀ {A : Set} {n} → A → Vec A n
  zipWith : ∀ {A B C : Set} {n} → (A → B → C) → Vec A n → Vec B n → Vec C n

macro
  rtest : Name → Term → TC ⊤
  rtest f a = do
     (function (clause tel _ t ∷ [])) ← withReconstructed (getDefinition f) where
        _ → typeError (strErr "ERROR" ∷ [])
     t ← inContext (reverse tel) (normalise t)
     quoteTC t >>= unify a

transp : ∀ m n → Vec (Vec Nat n) m → Vec (Vec Nat m) n
transp .(suc m) n (_∷_ {m} x xs) = zipWith {Nat} {Vec Nat m} {Vec Nat (suc m)} {n} (_∷_ {Nat} {m}) x (transp _ n xs)

test : Term
test = rtest transp


------------------------------------------------------------------------
-- A simplification of Hinze.Section2-4
------------------------------------------------------------------------

module Hinze.Simplified.Section2-4 where

open import Stream.Programs
open import Stream.Equality
open import Stream.Pointwise hiding (⟦_⟧)
open import Hinze.Lemmas

open import Codata.Musical.Notation hiding (∞)
open import Data.Nat renaming (suc to 1+)
open import Function using (_∘_)
open import Relation.Binary.PropositionalEquality
  renaming (module ≡-Reasoning to ER)
open import Algebra.Structures
import Data.Nat.Properties as Nat
private
  module CS = IsCommutativeSemiring Nat.+-*-isCommutativeSemiring
open import Data.Product

------------------------------------------------------------------------
-- Abbreviations

2* : ℕ → ℕ
2* n = 2 * n

1+2* : ℕ → ℕ
1+2* n = 1 + 2 * n

2+2* : ℕ → ℕ
2+2* n = 2 + 2 * n

------------------------------------------------------------------------
-- Definitions

nat : Prog ℕ
nat = 0 ≺ ♯ (1+ · nat)

fac : Prog ℕ
fac = 1 ≺ ♯ (1+ · nat ⟨ _*_ ⟩ fac)

fib : Prog ℕ
fib = 0 ≺ ♯ (fib ⟨ _+_ ⟩ (1 ≺ ♯ fib))

bin : Prog ℕ
bin = 0 ≺ ♯ (1+2* · bin ⋎ 2+2* · bin)

------------------------------------------------------------------------
-- Laws and properties

const-is-∞ : ∀ {A} {x : A} {xs} →
             xs ≊ x ≺♯ xs → xs ≊ x ∞
const-is-∞ {x = x} {xs} eq =
  xs
            ≊⟨ eq ⟩
  x ≺♯ xs
            ≊⟨ refl ≺ ♯ const-is-∞ eq ⟩
  x ≺♯ x ∞
            ≡⟨ refl ⟩
  x ∞
            ∎

nat-lemma₁ : 0 ≺♯ 1+2* · nat ⋎ 2+2* · nat ≊ 2* · nat ⋎ 1+2* · nat
nat-lemma₁ =
  0 ≺♯ 1+2* · nat ⋎ 2+2* · nat
                                   ≊⟨ refl ≺ ♯ ⋎-cong
                                        (1+2* · nat) (1+2* · nat) (1+2* · nat ∎)
                                        (2+2* · nat) (2* · 1+ · nat) (lemma 2 nat) ⟩
  0 ≺♯ 1+2* · nat ⋎ 2* · 1+ · nat
                                   ≡⟨ refl ⟩
  2* · nat ⋎ 1+2* · nat
                                   ∎
  where
  lemma : ∀ m s → (λ n → m + m * n) · s ≊ _*_ m · 1+ · s
  lemma m = pointwise 1 (λ s → (λ n → m + m * n) · s)
                        (λ s → _*_ m · 1+ · s)
                        (λ n → sym (ER.begin
                           m * (1 + n)
                                          ER.≡⟨ proj₁ CS.distrib m 1 n ⟩
                           m * 1 + m * n
                                          ER.≡⟨ cong (λ x → x + m * n)
                                                     (proj₂ CS.*-identity m) ⟩
                           m + m * n
                                          ER.∎))

nat-lemma₂ : nat ≊ 2* · nat ⋎ 1+2* · nat
nat-lemma₂ =
  nat
                                        ≡⟨ refl ⟩
  0 ≺♯ 1+ · nat
                                        ≊⟨ refl ≺ ♯ ·-cong 1+ nat (2* · nat ⋎ 1+2* · nat) nat-lemma₂ ⟩
  0 ≺♯ 1+ · (2* · nat ⋎ 1+2* · nat)
                                        ≊⟨ ≅-sym (refl ≺ ♯ ⋎-map 1+ (2* · nat) (1+2* · nat)) ⟩
  0 ≺♯ 1+ · 2* · nat ⋎ 1+ · 1+2* · nat
                                        ≊⟨ refl ≺ ♯ ⋎-cong (1+ ·   2* · nat) (1+2* · nat)
                                                           (map-fusion 1+   2* nat)
                                                           (1+ · 1+2* · nat) (2+2* · nat)
                                                           (map-fusion 1+ 1+2* nat) ⟩
  0 ≺♯ 1+2* · nat ⋎ 2+2* · nat
                                        ≊⟨ nat-lemma₁ ⟩
  2* · nat ⋎ 1+2* · nat
                                        ∎

nat≊bin : nat ≊ bin
nat≊bin =
  nat
                                  ≊⟨ nat-lemma₂ ⟩
  2* · nat ⋎ 1+2* · nat
                                  ≊⟨ ≅-sym nat-lemma₁ ⟩
  0 ≺♯ 1+2* · nat ⋎ 2+2* · nat
                                  ≊⟨ refl ≺ coih ⟩
  0 ≺♯ 1+2* · bin ⋎ 2+2* · bin
                                  ≡⟨ refl ⟩
  bin
                                  ∎
  where
  coih = ♯ ⋎-cong (1+2* · nat) (1+2* · bin)
                  (·-cong 1+2* nat bin nat≊bin)
                  (2+2* · nat) (2+2* · bin)
                  (·-cong 2+2* nat bin nat≊bin)

iterate-fusion
  : ∀ {A B} (h : A → B) (f₁ : A → A) (f₂ : B → B) →
    (∀ x → h (f₁ x) ≡ f₂ (h x)) →
    ∀ x → h · iterate f₁ x ≊ iterate f₂ (h x)
iterate-fusion h f₁ f₂ hyp x =
  h · iterate f₁ x
                                ≡⟨ refl ⟩
  h x ≺♯ h · iterate f₁ (f₁ x)
                                ≊⟨ refl ≺ ♯ iterate-fusion h f₁ f₂ hyp (f₁ x) ⟩
  h x ≺♯ iterate f₂ (h (f₁ x))
                                ≡⟨ cong (λ y → ⟦ h x ≺♯ iterate f₂ y ⟧) (hyp x) ⟩
  h x ≺♯ iterate f₂ (f₂ (h x))
                                ≡⟨ refl ⟩
  iterate f₂ (h x)
                                ∎

nat-iterate : nat ≊ iterate 1+ 0
nat-iterate =
  nat
                          ≡⟨ refl ⟩
  0 ≺ ♯ (1+ · nat)
                          ≊⟨ refl ≺ ♯ ·-cong 1+ nat (iterate 1+ 0) nat-iterate ⟩
  0 ≺♯ 1+ · iterate 1+ 0
                          ≊⟨ refl ≺ ♯ iterate-fusion 1+ 1+ 1+ (λ _ → refl) 0 ⟩
  0 ≺♯ iterate 1+ 1
                          ≡⟨ refl ⟩
  iterate 1+ 0
                          ∎


module Abstract where

data Bool : Set where
  true false : Bool

not : Bool → Bool
not true  = false
not false = true

abstract
  Answer : Set
  Answer = Bool

  yes : Answer
  yes = true

  no : Answer
  no = false

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

data Box : Set where
  [_] : Answer → Box

bad-box : Box
bad-box = [ true ]


open import Structure.Setoid
open import Structure.Category
open import Type

module Structure.Category.Monad.ExtensionSystem
  {ℓₒ ℓₘ ℓₑ}
  {cat : CategoryObject{ℓₒ}{ℓₘ}{ℓₑ}}
  where

import      Data.Tuple as Tuple
import      Function.Equals
open        Function.Equals.Dependent
open import Functional.Dependent using () renaming (_∘_ to _∘ᶠⁿ_)
import      Lvl
open import Logic.Predicate
open import Structure.Category.Functor
open import Structure.Category.Functor.Functors as Functors
open import Structure.Category.Monad{cat = cat}
open import Structure.Category.NaturalTransformation
open import Structure.Category.NaturalTransformation.NaturalTransformations as NaturalTransformations
open import Structure.Category.Proofs
open import Structure.Categorical.Properties
open import Structure.Function
open import Structure.Operator
open import Structure.Relator.Equivalence
open import Structure.Relator.Properties
open import Syntax.Transitivity

open CategoryObject(cat)
open Category.ArrowNotation(category)
open Category(category)
open NaturalTransformations.Raw(cat)(cat)
private open module MorphismEquiv {x}{y} = Equivalence (Equiv-equivalence ⦃ morphism-equiv{x}{y} ⦄) using ()

record ExtensionSystem (T : Object → Object) : Type{Lvl.of(Type.of(cat))} where
  field
    η   : (x : Object) → (x ⟶ T(x))
    ext : ∀{x y} → (x ⟶ T(y)) → (T(x) ⟶ T(y))

  μ : (x : Object) → (T(T(x)) ⟶ T(x))
  μ(x) = ext(id{x = T(x)})

  field
    ⦃ ext-function ⦄ : ∀{x y} → Function(ext{x}{y})
    ext-inverse      : ∀{x} → (ext(η(x)) ≡ id) -- ext ∘ᶠⁿ η ⊜ idᴺᵀ
    ext-identity     : ∀{x y}{f : x ⟶ T(y)} → (ext(f) ∘ η(x) ≡ f)
    ext-distribute   : ∀{x y z}{f : y ⟶ T(z)}{g : x ⟶ T(y)} → (ext(ext(f) ∘ g) ≡ ext(f) ∘ ext(g))

  functor : Functor(category)(category)(T)
  Functor.map functor {x} {y} f = ext(η(y) ∘ f)
  Function.congruence (Functor.map-function functor) xy = congruence₁(ext) (congruence₂ᵣ(_∘_)(_) xy)
  Functor.op-preserving functor {x} {y} {z} {f} {g} =
    ext(η(z) ∘ f ∘ g)               🝖-[ congruence₁(ext) (Morphism.associativity(_∘_)) ]-sym
    ext((η(z) ∘ f) ∘ g)             🝖-[ congruence₁(ext) (congruence₂ₗ(_∘_)(g) (symmetry(_≡_) ext-identity)) ]
    ext((ext(η(z) ∘ f) ∘ η(y)) ∘ g) 🝖-[ congruence₁(ext) (Morphism.associativity(_∘_)) ]
    ext(ext(η(z) ∘ f) ∘ (η(y) ∘ g)) 🝖-[ ext-distribute ]
    ext(η(z) ∘ f) ∘ ext(η(y) ∘ g)   🝖-end
  Functor.id-preserving functor {x} =
    ext(η(x) ∘ id) 🝖-[ congruence₁(ext) (Morphism.identityᵣ(_∘_)(id)) ]
    ext(η(x))      🝖-[ ext-inverse ]
    id             🝖-end
  open Functor(functor)

  monad : Monad(T) ⦃ functor ⦄
  ∃.witness (Monad.Η monad) = η
  NaturalTransformation.natural (∃.proof (Monad.Η monad)) = symmetry(_≡_) ext-identity
  ∃.witness (Monad.Μ monad) = μ
  NaturalTransformation.natural (∃.proof (Monad.Μ monad)) {x} {y} {f} =
    μ(y) ∘ ext(η(T(y)) ∘ ext(η(y) ∘ f))      🝖[ _≡_ ]-[]
    ext(id) ∘ ext(η(T(y)) ∘ ext(η(y) ∘ f))   🝖-[ ext-distribute ]-sym
    ext(ext(id) ∘ (η(T(y)) ∘ ext(η(y) ∘ f))) 🝖-[ congruence₁(ext) (symmetry(_≡_) (Morphism.associativity(_∘_))) ]
    ext((ext(id) ∘ η(T(y))) ∘ ext(η(y) ∘ f)) 🝖-[ congruence₁(ext) (congruence₂ₗ(_∘_)(_) ext-identity) ]
    ext(id ∘ ext(η(y) ∘ f))                  🝖-[ congruence₁(ext) (Morphism.identityₗ(_∘_)(id)) ]
    ext(ext(η(y) ∘ f))                       🝖-[ congruence₁(ext) (Morphism.identityᵣ(_∘_)(id)) ]-sym
    ext(ext(η(y) ∘ f) ∘ id)                  🝖-[ ext-distribute ]
    ext(η(y) ∘ f) ∘ ext(id)                  🝖[ _≡_ ]-[]
    ext(η(y) ∘ f) ∘ μ(x)                     🝖-end
  _⊜_.proof (Monad.μ-functor-[∘]-commutativity monad) {x} = -- TODO: Same as above?
    μ(x) ∘ map(μ(x))                   🝖[ _≡_ ]-[]
    ext(id) ∘ map(ext(id))             🝖[ _≡_ ]-[]
    ext(id) ∘ ext(η(T(x)) ∘ ext(id))   🝖-[ ext-distribute ]-sym
    ext(ext(id) ∘ (η(T(x)) ∘ ext(id))) 🝖-[ congruence₁(ext) (symmetry(_≡_) (Morphism.associativity(_∘_))) ]
    ext((ext(id) ∘ η(T(x))) ∘ ext(id)) 🝖-[ congruence₁(ext) (congruence₂ₗ(_∘_)(_) ext-identity) ]
    ext(id ∘ ext(id))                  🝖-[ congruence₁(ext) (Morphism.identityₗ(_∘_)(id)) ]
    ext(ext(id))                       🝖-[ congruence₁(ext) (Morphism.identityᵣ(_∘_)(id)) ]-sym
    ext(ext(id) ∘ id)                  🝖-[ ext-distribute ]
    ext(id) ∘ ext(id)                  🝖[ _≡_ ]-[]
    μ(x) ∘ μ(T(x))                     🝖-end
  _⊜_.proof (Monad.μ-functor-[∘]-identityₗ monad) {x} =
    μ(x) ∘ ext(η(T(x)) ∘ η(x))      🝖[ _≡_ ]-[]
    ext(id) ∘ ext(η(T(x)) ∘ η(x))   🝖[ _≡_ ]-[ ext-distribute ]-sym
    ext(ext(id) ∘ (η(T(x)) ∘ η(x))) 🝖[ _≡_ ]-[ congruence₁(ext) (symmetry(_≡_) (Morphism.associativity(_∘_))) ]
    ext((ext(id) ∘ η(T(x))) ∘ η(x)) 🝖[ _≡_ ]-[ congruence₁(ext) (congruence₂ₗ(_∘_)(_) ext-identity) ]
    ext(id ∘ η(x))                  🝖[ _≡_ ]-[ congruence₁(ext) (Morphism.identityₗ(_∘_)(id)) ]
    ext(η(x))                       🝖[ _≡_ ]-[ ext-inverse ]
    id                              🝖[ _≡_ ]-end
  _⊜_.proof (Monad.μ-functor-[∘]-identityᵣ monad) {x} =
    μ(x) ∘ η(T(x))    🝖[ _≡_ ]-[]
    ext(id) ∘ η(T(x)) 🝖[ _≡_ ]-[ ext-identity ]
    id                🝖[ _≡_ ]-end

  -- Also called: Kleisli composition.
  _∘ₑₓₜ_ : ∀{x y z} → (y ⟶ T(z)) → (x ⟶ T(y)) → (x ⟶ T(z))
  f ∘ₑₓₜ g = ext(f) ∘ g

  idₑₓₜ : ∀{x} → (x ⟶ T(x))
  idₑₓₜ{x} = η(x)

  module FunctionalNames where
    -- Name sources:
    --   https://wiki.haskell.org/Lifting
    -- Also called: unit.
    lift : ∀{x} → (x ⟶ T(x))
    lift{x} = η(x)

    -- Name sources:
    --   Javascript: Array.prototype.flat
    --   Scala: scala.collection.IterableOnceOps.flatten
    flatten : ∀{x} → (T(T(x)) ⟶ T(x))
    flatten{x} = μ(x)

    -- Name sources:
    --   Javascript: Array.prototype.flatMap
    --   Java: Stream.flatMap
    --   Scala: scala.collection.IterableOnceOps.flatMap
    flatMap : ∀{x y} → (x ⟶ T(y)) → (T(x) ⟶ T(y))
    flatMap = ext

  module HaskellNames where
    return = FunctionalNames.lift
    join   = FunctionalNames.flatten
    bind   = FunctionalNames.flatMap

module _ where
  open Functor ⦃ … ⦄
  open Monad   ⦃ … ⦄

  monad-to-extensionSystem : ∀{T : Object → Object} → ⦃ functor : Functor(category)(category)(T) ⦄ → ⦃ monad : Monad(T) ⦄ → ExtensionSystem(T)
  ExtensionSystem.η   (monad-to-extensionSystem ⦃ functor ⦄ ⦃ monad ⦄) = η
  ExtensionSystem.ext (monad-to-extensionSystem ⦃ functor ⦄ ⦃ monad ⦄) = ext
  Function.congruence (ExtensionSystem.ext-function monad-to-extensionSystem  {x} {y}) {f} {g} fg =
    ((μ(y) ∘_) ∘ᶠⁿ map) f 🝖[ _≡_ ]-[]
    μ(y) ∘ map f          🝖[ _≡_ ]-[ congruence₂ᵣ(_∘_) _ (congruence₁(map) fg) ]
    μ(y) ∘ map g          🝖[ _≡_ ]-[]
    ((μ(y) ∘_) ∘ᶠⁿ map) g 🝖[ _≡_ ]-end
  ExtensionSystem.ext-inverse monad-to-extensionSystem {x} =
    ((μ(x) ∘_) ∘ᶠⁿ map)(η(x)) 🝖[ _≡_ ]-[]
    μ(x) ∘ map(η(x))          🝖[ _≡_ ]-[ _⊜_.proof μ-functor-[∘]-identityₗ ]
    id                        🝖[ _≡_ ]-end
  ExtensionSystem.ext-identity (monad-to-extensionSystem {T = T}) {x} {y} {f} =
    ((μ(y) ∘_) ∘ᶠⁿ map)(f) ∘ η(x) 🝖[ _≡_ ]-[]
    (μ(y) ∘ (map f)) ∘ η(x)       🝖[ _≡_ ]-[ Morphism.associativity(_∘_) ]
    μ(y) ∘ ((map f) ∘ η(x))       🝖[ _≡_ ]-[ congruence₂ᵣ(_∘_) _ η-natural ]-sym
    μ(y) ∘ (η(T(y)) ∘ f)          🝖[ _≡_ ]-[ Morphism.associativity(_∘_) ]-sym
    (μ(y) ∘ η(T(y))) ∘ f          🝖[ _≡_ ]-[ congruence₂ₗ(_∘_) _ (_⊜_.proof μ-functor-[∘]-identityᵣ) ]
    id ∘ f                        🝖[ _≡_ ]-[ Morphism.identityₗ(_∘_)(id) ]
    f                             🝖[ _≡_ ]-end
  ExtensionSystem.ext-distribute (monad-to-extensionSystem {T = T}) {x} {y} {z} {f} {g} =
    ((μ(z) ∘_) ∘ᶠⁿ map)(((μ(z) ∘_) ∘ᶠⁿ map)(f) ∘ g) 🝖[ _≡_ ]-[]
    μ(z) ∘ map((μ(z) ∘ (map f)) ∘ g)                🝖[ _≡_ ]-[ congruence₂ᵣ(_∘_) _ op-preserving ]
    μ(z) ∘ (map(μ(z) ∘ (map f)) ∘ (map g))          🝖[ _≡_ ]-[ congruence₂ᵣ(_∘_) _ (congruence₂ₗ(_∘_) _ op-preserving) ]
    μ(z) ∘ ((map(μ(z)) ∘ map(map f)) ∘ (map g))     🝖[ _≡_ ]-[ associate4-231-121 category ]
    (μ(z) ∘ map(μ(z))) ∘ (map(map f) ∘ (map g))     🝖[ _≡_ ]-[ congruence₂ₗ(_∘_) _ (_⊜_.proof μ-functor-[∘]-commutativity) ]
    (μ(z) ∘ μ(T(z))) ∘ (map(map f) ∘ (map g))       🝖[ _≡_ ]-[ associate4-213-121 category ]-sym
    (μ(z) ∘ (μ(T(z)) ∘ map(map f))) ∘ (map g)       🝖[ _≡_ ]-[ congruence₂ₗ(_∘_) _ (congruence₂ᵣ(_∘_) _ μ-natural) ]
    (μ(z) ∘ ((map f) ∘ μ(y))) ∘ (map g)             🝖[ _≡_ ]-[ associate4-213-121 category ]
    (μ(z) ∘ (map f)) ∘ (μ(y) ∘ (map g))             🝖[ _≡_ ]-[]
    ((μ(z) ∘_) ∘ᶠⁿ map)(f) ∘ ((μ(y) ∘_) ∘ᶠⁿ map)(g) 🝖[ _≡_ ]-end


------------------------------------------------------------------------------
-- Induction principles for Tree and Forest
------------------------------------------------------------------------------

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

module FOT.FOTC.Program.Mirror.Induction.InductionPrinciples where

open import FOTC.Base
open import FOTC.Base.List
open import FOTC.Program.Mirror.Type

------------------------------------------------------------------------------
-- These induction principles *not cover* the mutual structure of the
-- types Tree and Rose (Bertot and Casterán, 2004, p. 401).

-- Induction principle for Tree.
Tree-ind : (A : D → Set) →
           (∀ d {ts} → Forest ts → A (node d ts)) →
           ∀ {t} → Tree t → A t
Tree-ind A h (tree d Fts) = h d Fts

-- Induction principle for Forest.
Forest-ind : (A : D → Set) →
             A [] →
             (∀ {t ts} → Tree t → Forest ts → A ts → A (t ∷ ts)) →
             ∀ {ts} → Forest ts → A ts
Forest-ind A A[] h fnil           = A[]
Forest-ind A A[] h (fcons Tt Fts) = h Tt Fts (Forest-ind A A[] h Fts)

------------------------------------------------------------------------------
-- References
--
-- Bertot, Yves and Castéran, Pierre (2004). Interactive Theorem
-- Proving and Program Development. Coq’Art: The Calculus of Inductive
-- Constructions. Springer.


open import Common.Prelude renaming (Nat to ℕ)
open import Common.Reflect

module StrangeRecursiveUnquote where

`ℕ : Term
`ℕ = def (quote ℕ) []

-- the term f n is stuck and so we cannot unquote (as expected)
f : ℕ → Term
f zero    = `ℕ
f (suc n) = unquote (f n)


------------------------------------------------------------------------
-- INCREMENTAL λ-CALCULUS
--
-- Incrementalization as term-to-term transformation with the Nehemiah plugin.
------------------------------------------------------------------------

module Nehemiah.Change.Derive where

open import Nehemiah.Syntax.Type
open import Nehemiah.Syntax.Term
open import Nehemiah.Change.Type
open import Nehemiah.Change.Term

open import Data.Integer

import Parametric.Change.Derive Const ΔBase as Derive

derive-const : Derive.Structure
derive-const (intlit-const n) = intlit (+ 0)
derive-const add-const        = absV 4 (λ s ds t dt → add ds dt)
derive-const minus-const      = absV 2 (λ t dt → minus dt)
derive-const empty-const      = empty
derive-const insert-const     = absV 4 (λ s ds t dt →
  insert (s ⊕₍ int ₎ ds) (t ⊕₍ bag ₎ dt) ⊝ insert s t)
derive-const union-const      = absV 4 (λ s ds t dt → union ds dt)
derive-const negate-const     = absV 2 (λ t dt → negate dt)
derive-const flatmap-const    = absV 4 (λ s ds t dt →
  flatmap (s ⊕₍ int ⇒ bag ₎ ds) (t ⊕₍ bag ₎ dt) ⊝ flatmap s t)
derive-const sum-const        = absV 2 (λ t dt → sum dt)

open Derive.Structure derive-const public


module RecordInParModule (a : Set) where

record Setoid : Set1 where
  field el : Set

postulate
  S : Setoid
  A : Setoid.el S

postulate X : Set

module M (x : X) where
  record R : Set where

module E {x : X} (r : M.R x) where
  open module M' = M.R x r


{-# OPTIONS --without-K --safe #-}
module Cats.Category.Cones where

open import Relation.Binary using (Rel ; IsEquivalence ; _Preserves₂_⟶_⟶_)
open import Level using (_⊔_)

open import Cats.Category.Base
open import Cats.Category.Cat using (Cat)
open import Cats.Category.Fun as Fun using (Fun ; Trans)
open import Cats.Functor using (Functor) renaming (_∘_ to _∘F_)
open import Cats.Util.Conv

import Relation.Binary.PropositionalEquality as ≡

import Cats.Category.Constructions.Iso as Iso
import Cats.Util.Function as Fun

open Functor
open Trans
open Fun._≈_

module Build {lo la l≈ lo′ la′ l≈′}
  {J : Category lo la l≈}
  {Z : Category lo′ la′ l≈′}
  (D : Functor J Z)
  where

  infixr 9 _∘_
  infixr 4 _≈_

  private
    module Z = Category Z
    module J = Category J
    module D = Functor D

  -- We could define cones in terms of wedges (and limits in terms of ends).
  record Cone : Set (lo ⊔ la ⊔ la′ ⊔ lo′ ⊔ l≈′) where
    field
      Apex : Z.Obj
      arr : ∀ j → Apex Z.⇒ D.fobj j
      commute : ∀ {i j} (α : i J.⇒ j) → arr j Z.≈ D.fmap α Z.∘ arr i

  open Cone public

  instance
    HasObj-Cone : HasObj Cone lo′ la′ l≈′
    HasObj-Cone = record { Cat = Z ; _ᴼ = Cone.Apex }

  Obj = Cone

  record _⇒_ (A B : Obj) : Set (lo ⊔ la′ ⊔ l≈′) where
    private
      module A = Cone A ; module B = Cone B

    field
      arr : A.Apex Z.⇒ B.Apex
      commute : ∀ j → B.arr j Z.∘ arr Z.≈ A.arr j

  open _⇒_ public

  instance
    HasArrow-⇒ : ∀ {A B} → HasArrow (A ⇒ B) lo′ la′ l≈′
    HasArrow-⇒ = record { Cat = Z ; _⃗ = _⇒_.arr }

  _≈_ : ∀ {A B} → Rel (A ⇒ B) l≈′
  _≈_ = Z._≈_ Fun.on arr

  equiv : ∀ {A B} → IsEquivalence (_≈_ {A} {B})
  equiv = Fun.on-isEquivalence _⇒_.arr Z.equiv

  id : ∀ {A} → A ⇒ A
  id = record
      { arr = Z.id
      ; commute = λ j → Z.id-r
      }

  _∘_ : ∀ {A B C} → B ⇒ C → A ⇒ B → A ⇒ C
  _∘_ {A} {B} {C} f g = record
      { arr = f ⃗ Z.∘ g ⃗
      ; commute = λ j →
          begin
            arr C j Z.∘ f ⃗ Z.∘ g ⃗
          ≈⟨ Z.unassoc ⟩
            (arr C j Z.∘ f ⃗) Z.∘ g ⃗
          ≈⟨ Z.∘-resp-l (commute f j) ⟩
            arr B j Z.∘ g ⃗
          ≈⟨ commute g j ⟩
            arr A j
          ∎
      }
    where
      open Z.≈-Reasoning

  Cones : Category (lo ⊔ la ⊔ lo′ ⊔ la′ ⊔ l≈′) (lo ⊔ la′ ⊔ l≈′) l≈′
  Cones = record
      { Obj = Obj
      ; _⇒_ = _⇒_
      ; _≈_ = _≈_
      ; id = id
      ; _∘_ = _∘_
      ; equiv = equiv
      ; ∘-resp = Z.∘-resp
      ; id-r = Z.id-r
      ; id-l = Z.id-l
      ; assoc = Z.assoc
      }

  open Iso.Build Cones using (_≅_)
  open Iso.Build Z using () renaming (_≅_ to _≅Z_)

  cone-iso→obj-iso : ∀ {c d : Cone}
    → c ≅ d
    → c ᴼ ≅Z d ᴼ
  cone-iso→obj-iso i = record
      { forth = forth i ⃗
      ; back = back i ⃗
      ; back-forth = back-forth i
      ; forth-back = forth-back i
      }
    where
      open _≅_

open Build public hiding (HasObj-Cone ; HasArrow-⇒)

private
  open module Build′ {lo la l≈ lo′ la′ l≈′}
    {J : Category lo la l≈}
    {Z : Category lo′ la′ l≈′}
    {D : Functor J Z}
    = Build D
    public using (HasObj-Cone ; HasArrow-⇒)

-- TODO better name
apFunctor : ∀ {lo la l≈ lo′ la′ l≈′ lo″ la″ l≈″}
  → {Y : Category lo la l≈}
  → {Z : Category lo′ la′ l≈′}
  → (F : Functor Y Z)
  → {J : Category lo″ la″ l≈″}
  → {D : Functor J Y}
  → Cone D
  → Cone (F ∘F D)
apFunctor {Y = Y} {Z} F {J} {D} c = record
    { Apex = fobj F (c .Apex)
    ; arr = λ j → fmap F (c .arr j)
    ; commute = λ {i} {j} α → Z.≈.sym (
        begin
          fmap F (fmap D α) Z.∘ fmap F (c .arr i)
        ≈⟨ fmap-∘ F ⟩
          fmap F (fmap D α Y.∘ c .arr i)
        ≈⟨ fmap-resp F (Y.≈.sym (c .commute α)) ⟩
          fmap F (c .arr j)
        ∎
      )
    }
  where
    module Y = Category Y
    module Z = Category Z
    open Z.≈-Reasoning

module _ {lo la l≈ lo′ la′ l≈′}
  {C : Category lo la l≈} {D : Category lo′ la′ l≈′}
  where

  module D = Category D

  trans : {F G : Functor C D} → Trans F G → Cone F → Cone G
  trans {F} {G} θ c = record
    { Apex = c .Apex
    ; arr = λ j → component θ j D.∘ c .arr j
    ; commute = λ {i} {j} α →
      let open D.≈-Reasoning in
      begin
      component θ j D.∘ c .arr j
      ≈⟨ D.∘-resp-r (c .commute α) ⟩
      component θ j D.∘ fmap F α D.∘ c .arr i
      ≈⟨ D.unassoc ⟩
      (component θ j D.∘ fmap F α) D.∘ c .arr i
      ≈⟨ D.∘-resp-l (natural θ) ⟩
      (fmap G α D.∘ component θ i) D.∘ c .arr i
      ≈⟨ D.assoc ⟩
      fmap G α D.∘ component θ i D.∘ c .arr i
      ∎
    }

  ConesF : Functor (Fun C D) (Cat (lo ⊔ la ⊔ lo′ ⊔ la′ ⊔ l≈′) (lo ⊔ la′ ⊔ l≈′) l≈′)
  ConesF = record
    { fobj = Cones
    ; fmap = λ {F} {G} ϑ → record
      { fobj = λ c → trans ϑ c
      ; fmap = λ f → record
        { arr = f .arr
        ; commute = λ j → D.≈.trans D.assoc (D.∘-resp-r (commute f j))
        }
      ; fmap-resp = λ x → x
      ; fmap-id = D.≈.refl
      ; fmap-∘ = D.≈.refl
      }
    ; fmap-resp = λ ϑ≈ι → record
      { iso = record
        { forth = record
          { arr = D.id
          ; commute = λ j → D.≈.trans D.id-r (D.∘-resp-l (D.≈.sym (≈-elim ϑ≈ι)))
          }
        ; back = record
          { arr = D.id
          ; commute = λ j → D.≈.trans D.id-r (D.∘-resp-l (≈-elim ϑ≈ι))
          }
        ; back-forth = D.id-l
        ; forth-back = D.id-l
        }
      ; forth-natural = D.≈.trans D.id-l (D.≈.sym D.id-r)
      }
    ; fmap-id = record
      { iso = record
        { forth = record
          { arr = D.id
          ; commute = λ j → D.≈.trans D.id-r (D.≈.sym D.id-l)
          }
        ; back = record
          { arr = D.id
          ; commute = λ j → D.≈.trans D.id-r D.id-l
          }
        ; back-forth = D.id-l
        ; forth-back = D.id-l
        }
      ; forth-natural = D.≈.trans D.id-l (D.≈.sym D.id-r)
      }
    ; fmap-∘ = record
      { iso = record
        { forth = record
          { arr = D.id
          ; commute = λ j → D.≈.trans D.id-r D.assoc
          }
        ; back = record
          { arr = D.id
          ; commute = λ j → D.≈.trans D.id-r D.unassoc
          }
        ; back-forth = D.id-l
        ; forth-back = D.id-l
        }
      ; forth-natural = D.≈.trans D.id-l (D.≈.sym D.id-r)
      }
    }


module Common.Integer where

open import Agda.Builtin.Int public renaming (Int to Integer)


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

module 2DTypes where

-- open import Level renaming (zero to lzero)
open import Relation.Binary.PropositionalEquality
open import Data.Unit
open import Data.Sum
open import Data.Empty using (⊥; ⊥-elim)
open import Data.Product
open import Function using (_∘_)
open import Relation.Binary using (Setoid)
open import Data.Nat using (ℕ) renaming (suc to ℕsuc; _+_ to _ℕ+_; _*_ to _ℕ*_)
open import Data.Fin using (Fin; zero; suc)
open import Data.Vec using (Vec; lookup; _∷_; []; zipWith)
open import Data.Integer hiding (suc)

open import VectorLemmas using (_!!_)
open import PiU
open import PiLevel0 hiding (!!)
open import PiEquiv
open import PiLevel1
open import Equiv
open import EquivEquiv using (_≋_; module _≋_)

open import Categories.Category
open import Categories.Groupoid
open import Categories.Equivalence.Strong

-- This exists somewhere, but I can't find it
⊎-inj : ∀ {ℓ} {A B : Set ℓ} {a : A} {b : B} → inj₁ a ≡ inj₂ b → ⊥
⊎-inj ()

-- should probably make this level-polymorphic
record Typ : Set where
  constructor typ
  field
    carr : U
    len : ℕ -- number of non-trivial automorphisms
    auto : Vec (carr ⟷ carr) (ℕsuc len) -- the real magic goes here

    -- normally the stuff below is "global", but here
    -- we attach it to a type.
    id : id⟷ ⇔ (auto !! zero)
    _⊙_ : Fin (ℕsuc len) → Fin (ℕsuc len) → Fin (ℕsuc len)
    coh : ∀ (i j : Fin (ℕsuc len)) → -- note the flip !!!
        ((auto !! i) ◎ (auto !! j) ⇔ (auto !! (j ⊙ i)))
    -- to get groupoid, we need inverse knowledge, do later

open Typ

-- The above 'induces' a groupoid structure, which
-- we need to show in detail.
-- First, a useful container for the info we need:
record Hm (t : Typ) (a b : ⟦ carr t ⟧) : Set where
  constructor hm
  field
    eq : carr t ⟷ carr t
    good : Σ (Fin (ℕsuc (len t))) (λ n → eq ⇔ (auto t !! n))
    fwd : proj₁ (c2equiv eq) a ≡ b
    bwd : isqinv.g (proj₂ (c2equiv eq)) b ≡ a

-- note how (auto t) is not actually used!
-- also: not sure e₁ and e₂ always used coherently, as types are not enough
--  to decide which one to use...
induceCat : Typ → Category _ _ _
induceCat t = record
  { Obj =  ⟦ carr t ⟧
  ; _⇒_ = Hm t
  ; _≡_ = λ { (hm e₁ g₁ _ _) → λ { (hm e₂ g₂ _ _) → e₁ ⇔ e₂} }
  ; id = hm id⟷ (zero , id t) refl refl
  ; _∘_ = λ { {A} {B} {C} (hm e₁ (n₁ , p₁) fwd₁ bwd₁) (hm e₂ (n₂ , p₂) fwd₂ bwd₂) →
   let pf₁ = (begin (
        proj₁ (c2equiv e₁ ● c2equiv e₂) A
          ≡⟨ β₁ A ⟩
        (proj₁ (c2equiv e₁) ∘ (proj₁ (c2equiv e₂))) A
          ≡⟨ cong (proj₁ (c2equiv e₁)) fwd₂ ⟩
        proj₁ (c2equiv e₁) B
          ≡⟨ fwd₁ ⟩
        C ∎ ))
       -- same as above (in opposite direction), just compressed
       pf₂ = trans (β₂ C)
            (trans (cong (isqinv.g (proj₂ (c2equiv e₂))) bwd₁)
                   bwd₂)
       n₃ = _⊙_ t n₁ n₂
       compos = n₃ , trans⇔ (p₂ ⊡ p₁) (coh t n₂ n₁)
   in
        hm (e₂ ◎ e₁) compos pf₁ pf₂ }
  ; assoc = assoc◎l
  ; identityˡ = idr◎l
  ; identityʳ = idl◎l
  ; equiv = record { refl = id⇔ ; sym = 2! ; trans = trans⇔ }
  ; ∘-resp-≡ = λ f g → g ⊡ f
  }
  where open Typ
        open ≡-Reasoning

{-
 -- to get the Groupoid structure, there is stuff in the type that is
 -- missing; see the hole.
induceG : (t : Typ)  → Groupoid (induceCat t)
induceG t = record
  { _⁻¹ = λ { {A} {B} (hm e g fw bw) →
    hm (! e) {!!} (trans (f≡ (!≡sym≃ e) B) bw) (trans (g≡ (!≡sym≃ e) A) fw) }
  ; iso = record { isoˡ = linv◎l ; isoʳ = rinv◎l }
  }
  where open _≋_
-}

-- some useful functions for defining the type 1T
private
  mult : Fin 1 → Fin 1 → Fin 1
  mult zero zero = zero
  mult _ (suc ())
  mult (suc ()) _

  triv : Vec (ONE ⟷ ONE) 1
  triv = id⟷ ∷ []

  mult-coh : ∀ (i j : Fin 1) →
        ((triv !! i) ◎ (triv !! j) ⇔ (triv !! (mult j i)))
  mult-coh zero zero = idl◎l -- note how this is non-trivial!
  mult-coh _ (suc ())
  mult-coh (suc ()) _

1T : Typ
1T = record
  { carr = ONE
  ; len = 0
  ; auto = triv
  ; id = id⇔
  ; _⊙_ = mult
  ; coh = mult-coh
  }

BOOL : U
BOOL = PLUS ONE ONE

-- some useful functions for defining the type 1T′
private
  mult′ : Fin 2 → Fin 2 → Fin 2
  mult′ zero zero = zero
  mult′ zero (suc zero) = suc zero
  mult′ _ (suc (suc ()))
  mult′ (suc zero) zero = suc zero
  mult′ (suc zero) (suc zero) = zero
  mult′ (suc (suc ())) _

  sw : Vec (BOOL ⟷ BOOL) 2
  sw = id⟷ ∷ swap₊ ∷ []

  sw-coh :  ∀ (i j : Fin 2) →
        ((sw !! i) ◎ (sw !! j) ⇔ (sw !! (mult′ j i)))
  sw-coh zero zero = idl◎l
  sw-coh zero (suc zero) = idl◎l
  sw-coh _ (suc (suc ()))
  sw-coh (suc zero) zero = idr◎l
  sw-coh (suc zero) (suc zero) = linv◎l
  sw-coh (suc (suc ())) _

1T′ : Typ
1T′ = record
  { carr = BOOL
  ; len = 1
  ; auto = sw
  ; id = id⇔
  ; _⊙_ = mult′
  ; coh = sw-coh
  }

-- useful utilities
private
  collapse : ⊤ ⊎ ⊤ → ⊤
  collapse (inj₁ a) = a
  collapse (inj₂ b) = b

  collapse-coh : ∀ {A B : ⊤ ⊎ ⊤} → collapse A ≡ collapse B
  collapse-coh {inj₁ tt} {inj₁ tt} = refl
  collapse-coh {inj₁ tt} {inj₂ tt} = refl
  collapse-coh {inj₂ tt} {inj₁ tt} = refl
  collapse-coh {inj₂ tt} {inj₂ tt} = refl

-- let's do it on categories only.
-- The important thing here is that we only have
-- access to id⟷ and (auto 1T′) as things of type
-- (carr 1T′ ⟷ carr 1T′).
1T≃1T′ : StrongEquivalence (induceCat 1T) (induceCat 1T′)
1T≃1T′ =
  record
  -- from 1T to 1T′, we really do want to map down to id⟷ onto inj₁
  { F = record
    { F₀ = inj₁
    ; F₁ = λ { {tt} {tt} (hm e g fwd bwd) → hm id⟷ (zero , id⇔) refl refl}
    ; identity = id⇔
    ; homomorphism = idl◎r
    ; F-resp-≡ = λ _ → id⇔
    }
  -- and here, everything should be collapsed
  ; G = record
    { F₀ = collapse
    ; F₁ = λ { {A} {B} (hm e g fwd bwd) →
        hm id⟷ (zero , id⇔) (collapse-coh {A} {B}) (collapse-coh {B} {A})}
    ; identity = id⇔
    ; homomorphism = idl◎r
    ; F-resp-≡ = λ _ → id⇔
    }
  -- and here is where (auto 1T′) is needed, else this is false!!
  ; weak-inverse = record
    { F∘G≅id = record
      { F⇒G = record
        { η = λ { (inj₁ a) → hm id⟷ (zero , id⇔) refl refl;
                  (inj₂ b) → hm swap₊ (suc zero , id⇔) refl refl }
        ; commute =
          λ { {inj₁ tt} {inj₁ tt} (hm c (zero , x) _ _) →  trans⇔ idl◎l (trans⇔ (2! x) idl◎r) ;
              {inj₁ tt} {inj₁ tt} (hm c (suc zero , x) a b) →
                  ⊥-elim (⊎-inj (
                    trans (sym a) (
                    trans (sym (lemma0 c (inj₁ tt)))
                          (≋⇒≡ x (inj₁ tt))))) ;
              {inj₁ tt} {inj₁ tt} (hm c (suc (suc ()), _) _ _);
              {inj₁ tt} {inj₂ tt} (hm c (zero , x) a b) →
                ⊥-elim (⊎-inj (
                  trans (sym (≋⇒≡ x (inj₁ tt))) (
                  trans (lemma0 c (inj₁ tt))
                         a ) ) );
              {inj₁ tt} {inj₂ tt} (hm c (suc zero , x) _ _) →
                trans⇔ idl◎l (trans⇔ (2! x) idl◎r) ;
              {inj₁ tt} {inj₂ tt} (hm c (suc (suc ()), _) _ _);
              {inj₂ tt} {inj₁ tt} (hm c (zero , x) a b) →
                ⊥-elim (⊎-inj (
                  trans (sym a) (
                  trans (sym (lemma0 c (inj₂ tt)))
                        (≋⇒≡ x (inj₂ tt)) ) ) );
              {inj₂ tt} {inj₁ tt} (hm c (suc (suc ()), _) _ _);
              {inj₂ tt} {inj₂ tt} (hm c (zero , x) _ _) →
                trans⇔ idl◎l (trans⇔ idr◎r (id⇔ ⊡ (2! x)));
              {inj₂ tt} {inj₁ tt} (hm c (suc zero , x) _ _) →
                trans⇔ idl◎l (trans⇔ linv◎r (id⇔ ⊡ (2! x)));
              {inj₂ tt} {inj₂ tt} (hm c (suc zero , x) a b) →
                ⊥-elim (⊎-inj (
                  trans (sym (≋⇒≡ x (inj₂ tt))) (
                   trans (lemma0 c (inj₂ tt)) a) ) ) ;
              {inj₂ tt} {inj₂ tt} (hm c (suc (suc ()), _) _ _)
            }
          }
      ; F⇐G = record
        { η = λ { (inj₁ a) → hm id⟷ (zero , id⇔) refl refl;
                  (inj₂ b) → hm swap₊ ((suc zero , id⇔)) refl refl }
        ; commute = λ
          { {inj₁ tt} {inj₁ tt} (hm a (zero , e) c d) → e ⊡ id⇔
          ; {inj₁ tt} {inj₂ tt} (hm a (zero , e) c d) → {!!}
          ; {inj₂ tt} {inj₁ tt} (hm a (zero , e) c d) → {!!}
          ; {inj₂ tt} {inj₂ tt} (hm a (zero , e) c d) → trans⇔ (e ⊡ id⇔) (trans⇔ idl◎l idr◎r)
          ; {inj₁ tt} {inj₁ tt} (hm a (suc zero , e) c d) → {!!}
          ; {inj₁ tt} {inj₂ tt} (hm a (suc zero , e) c d) → {!!}
          ; {inj₂ tt} {inj₁ tt} (hm a (suc zero , e) c d) → {!!}
          ; {inj₂ tt} {inj₂ tt} (hm a (suc zero , e) c d) → {!!}
          ; (hm a (suc (suc ()) , _) _ _) }
        }
      ; iso = λ { (inj₁ tt) → record { isoˡ = idl◎l ; isoʳ = idl◎l };
                  (inj₂ tt) → record { isoˡ = linv◎l ; isoʳ = linv◎l } }
      }
    ; G∘F≅id = record
      { F⇒G = record
        { η = λ {tt → hm id⟷ (zero , id⇔) refl refl}
        ; commute =
          λ { {tt} {tt} (hm eq (zero , e) _ _) → id⇔ ⊡ (2! e)
            ; {tt} {tt} (hm eq (suc () , _) _ _) }
        }
      ; F⇐G = record
        { η = λ {tt → hm id⟷ (zero , id⇔) refl refl}
        ; commute =
          λ { {tt} {tt} (hm c (zero , e) _ _) → e ⊡ id⇔
            ; {tt} {tt} (hm c (suc () , _) _ _) }
        }
      ; iso = λ {tt → record { isoˡ = linv◎l ; isoʳ = linv◎l } }
      }
    }
  }

-- And so 1T′ is equivalent to 1T.  This can be interpreted to mean
-- that swap₊ (perhaps more precisely, id⟷ ∷ swap₊ ∷ [] ) is the
-- representation of a 'negative type'.

---------------
-- Cardinality function
card : Typ → ℤ
card (typ carr len _ _ _ _) = (+ size carr) - (+ len)

-- check
card-1T : card 1T ≡ + 1
card-1T = refl

card-1T′ : card 1T′ ≡ + 1
card-1T′ = refl

--------------
-- Conjecture...

-- to make this work, we're going to postulate another loop
-- and that it is idempotent:
postulate
  loop : ZERO ⟷ ZERO
  idemp : loop ◎ loop ⇔ loop

private
  cc : Fin 2 → Fin 2 → Fin 2
  cc zero zero = zero
  cc zero (suc zero) = suc zero
  cc (suc zero) zero = suc zero
  cc (suc zero) (suc zero) = suc zero
  cc (suc (suc ())) _
  cc _ (suc (suc ()))

  two-loops : Vec (ZERO ⟷ ZERO) 2
  two-loops = id⟷ ∷ loop ∷ []

  tl-coh :   ∀ (i j : Fin 2) →
        ((two-loops !! i) ◎ (two-loops !! j) ⇔ (two-loops !! (cc j i)))
  tl-coh zero zero = idl◎l
  tl-coh zero (suc zero) = idl◎l
  tl-coh (suc zero) zero = idr◎l
  tl-coh (suc zero) (suc zero) = {!idemp!}
  tl-coh (suc (suc ())) _
  tl-coh _ (suc (suc ()))

-1T : Typ
-1T = typ ZERO 1 two-loops id⇔ cc tl-coh

card--1T : card -1T ≡ -[1+ 0 ] -- indeed -1 ...
card--1T = refl

{--
Here is my current thinking:

* A type is a package of:
 - a carrier (that comes with the trivial automorphism)
 - a collection of non-trivial automorphisms that have a groupoid structure
 Let’s denote this package by ‘R A (Auto A)'

* The collection of non-trivial automorphisms could very well be
  missing (i.e., empty) and we then recover plain sets like Bool etc.

* Now here is the interesting bit: the carrier itself could be
  missing, i.e., a parameter. In that case we get something like:

 A -> R A (Auto A)

 That thing could be treated as outside the universe of types but we
 are proposing to enlarge the universe of type to also include it as a
 fractional type. Of course we need a way to combine such a fractional
 type with a carrier to get a regular type so we need another
 operation _[_] to do the instantiation.

* So to revise, a type is:

 T ::= R A (Auto A)    |    /\ A . T    |     T[A]

To make sure this behaves like fractional types, we want /\ A. T and
T[A] to behave like a product. It is a product of course but a
dependent one.
--}

-- Parameterized type
-- Frac supposed to 1/t
-- instantiate Frac with u to get u/t
-- make sure t/t is 1
-- define eta and epsilon and check axioms

{-- Syntax of types --}

Auto : (u : U) → Set
Auto u = Σ[ n ∈ ℕ ] (Vec (u ⟷ u) n)

trivA : (u : U) → Auto u
trivA u = (1 , id⟷ ∷ [])

data T : (u₁ : U) → {u₂ : U} → Auto u₂ → Set where
  UT : (u : U) → T u (trivA u) -- regular sets
  FT : (u₁ u₂ : U) → (auto₂ : Auto u₂) → T u₁ auto₂

-- Regular sets

ZT : T ZERO (trivA ZERO)
ZT = UT ZERO

OT : T ONE (trivA ONE)
OT = UT ONE

-- one third

2U : U
2U = PLUS ONE ONE

3U : U
3U = PLUS ONE (PLUS ONE ONE)

3T : T 3U (trivA 3U)
3T = UT 3U

-- could add the remaining two but these are sufficient I think
all3A : Auto 3U
all3A = (4 , id⟷ ∷
             (id⟷ ⊕ swap₊) ∷
             (assocl₊ ◎ (swap₊ ⊕ id⟷) ◎ assocr₊) ∷
             ((id⟷ ⊕ swap₊) ◎ (assocl₊ ◎ (swap₊ ⊕ id⟷) ◎ assocr₊) ◎ (id⟷ ⊕ swap₊)) ∷
             [])

1/3T : T ONE all3A
1/3T = FT ONE 3U all3A

-- notice that a/b + c/b = (a+c) / b
-- So 1/3T + 1/3T is

2/3T : T 2U all3A
2/3T = FT 2U 3U all3A

-- one more

3/3T : T 3U all3A
3/3T = FT 3U 3U all3A

-- Now eta applied to 3/3T should match the carrier with the autos and produce the plain OT


module UnicodeEllipsis where

f : {A B : Set} → (A → B) → A → B
f g a with g a
… | x = x