module Data.Num.Nat where

open import Data.Num.Core renaming
    (   carry to carry'
    ;   carry-lower-bound to carry-lower-bound'
    ;   carry-upper-bound to carry-upper-bound'
    )
open import Data.Num.Maximum
open import Data.Num.Bounded
open import Data.Num.Next
open import Data.Num.Increment
open import Data.Num.Continuous

open import Data.Nat
open import Data.Nat.Properties
open import Data.Nat.Properties.Simple
open import Data.Nat.Properties.Extra
open import Data.Nat.DM

open import Data.Fin as Fin
    using (Fin; fromℕ≤; inject≤)
    renaming (zero to z; suc to s)

open import Data.Fin.Properties using (toℕ-fromℕ≤; bounded)
open import Data.Product
open import Data.Empty using (⊥)
open import Data.Unit using (⊤; tt)

open import Function
open import Relation.Nullary.Decidable
open import Relation.Nullary
open import Relation.Nullary.Negation
open import Relation.Binary
open import Relation.Binary.PropositionalEquality

open ≡-Reasoning
open ≤-Reasoning renaming (begin_ to start_; _∎ to _□; _≡⟨_⟩_ to _≈⟨_⟩_)
open DecTotalOrder decTotalOrder using (reflexive) renaming (refl to ≤-refl)

-- left-bounded infinite interval of natural number
data Nat : ℕ → Set where
    from : ∀ offset   → Nat offset
    suc  : ∀ {offset} → Nat offset → Nat offset

Nat-toℕ : ∀ {offset} → Nat offset → ℕ
Nat-toℕ (from offset) = offset
Nat-toℕ (suc n)       = suc (Nat-toℕ n)

Nat-fromℕ : ∀ offset
    → (n : ℕ)
    → .(offset ≤ n)
    → Nat offset
Nat-fromℕ offset n       p with offset ≟ n
Nat-fromℕ offset n       p | yes eq = from offset
Nat-fromℕ offset zero    p | no ¬eq = from offset
Nat-fromℕ offset (suc n) p | no ¬eq = suc (Nat-fromℕ offset n (≤-pred (≤∧≢⇒< p ¬eq)))

Nat-fromℕ-toℕ : ∀ offset
    → (n : ℕ)
    → (p : offset ≤ n)
    → Nat-toℕ (Nat-fromℕ offset n p) ≡ n
Nat-fromℕ-toℕ offset n       p with offset ≟ n
Nat-fromℕ-toℕ offset n       p | yes eq = eq
Nat-fromℕ-toℕ .0      zero z≤n | no ¬eq = refl
Nat-fromℕ-toℕ offset (suc n) p | no ¬eq =
    begin
        suc (Nat-toℕ (Nat-fromℕ offset n (≤-pred (≤∧≢⇒< p ¬eq))))
    ≡⟨ cong suc (Nat-fromℕ-toℕ offset n (≤-pred (≤∧≢⇒< p ¬eq))) ⟩
        suc n
    ∎

fromNat : ∀ {b d o}
    → {cont : True (Continuous? b (suc d) o)}
    → Nat o
    → Num b (suc d) o
fromNat               (from offset) = z ∙
fromNat {cont = cont} (suc nat)     = 1+ {cont = cont} (fromNat {cont = cont} nat)

toℕ-fromNat : ∀ b d o
    → (cont : True (Continuous? b (suc d) o))
    → (n : ℕ)
    → (p : o ≤ n)
    → ⟦ fromNat {b} {d} {o} {cont = cont} (Nat-fromℕ o n p) ⟧ ≡ n
toℕ-fromNat b d o cont n       p with o ≟ n
toℕ-fromNat b d o cont n       p | yes eq = cong (_+_ zero) eq
toℕ-fromNat b d .0 cont zero z≤n | no ¬eq = refl
toℕ-fromNat b d o cont (suc n) p | no ¬eq =
    begin
        ⟦ 1+ {b} {cont = cont} (fromNat (Nat-fromℕ o n (≤-pred (≤∧≢⇒< p ¬eq)))) ⟧
    ≡⟨ 1+-toℕ {b} (fromNat {cont = cont} (Nat-fromℕ o n (≤-pred (≤∧≢⇒< p ¬eq)))) ⟩
        suc ⟦ fromNat {cont = cont} (Nat-fromℕ o n (≤-pred (≤∧≢⇒< p ¬eq))) ⟧
    -- mysterious agda bug, this refl must stay here
    ≡⟨ refl ⟩
        suc ⟦ fromNat {cont = cont} (Nat-fromℕ o n (≤-pred (≤∧≢⇒< p ¬eq))) ⟧
    ≡⟨ cong suc (toℕ-fromNat b d o cont n (≤-pred (≤∧≢⇒< p ¬eq))) ⟩
        suc n
    ∎
-- -- a partial function that only maps ℕ to Continuous Nums
-- fromℕ : ∀ {b d o}
--     → {cond : N+Closed b d o}
--     → ℕ
--     → Num b (suc d) o
-- fromℕ {cond = cond} zero = z ∙
-- fromℕ {cond = cond} (suc n) = {!   !}

-- fromℕ {cont = cont} zero = z ∙
-- fromℕ {cont = cont} (suc n) = 1+ {cont = cont} (fromℕ {cont = cont} n)

-- toℕ-fromℕ : ∀ {b d o}
--     → {cont : True (Continuous? b (suc d) o)}
--     → (n : ℕ)
--     → ⟦ fromℕ {cont = cont} n ⟧ ≡ n + o
-- toℕ-fromℕ {_} {_} {_} {cont} zero = refl
-- toℕ-fromℕ {b} {d} {o} {cont} (suc n) =
--     begin
--         ⟦ 1+ {cont = cont} (fromℕ {cont = cont} n) ⟧
--     ≡⟨ 1+-toℕ {cont = cont} (fromℕ {cont = cont} n) ⟩
--         suc ⟦ fromℕ {cont = cont} n ⟧
--     ≡⟨ cong suc (toℕ-fromℕ {cont = cont} n) ⟩
--         suc (n + o)
--     ∎


open import Agda.Builtin.Nat
open import Agda.Builtin.Sigma
open import Agda.Builtin.Equality

data I : Set where
  it : I

data D : I → Set where
  d : D it

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

mutual
  data Code : Set where
    d   : I → Code
    box : Code
    sg  : (a : Code) → (El a → Code) → Code

  El : Code → Set
  El (d i)    = D i
  El box      = Box
  El (sg a f) = Σ (El a) λ x → El (f x)

foo : (i : I) → Code
foo i = sg (d i) aux
  where
    aux : D i → Code
    aux d = sg box λ { [ a ] → box }

crash : ∀ i → El (foo i) → Nat
crash i (d , p) = p


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

open import HoTT
open import homotopy.RibbonCover

module experimental.CoverClassification2 {i} (X : Ptd i)
  (A-conn : is-connected 0 (de⊙ X)) where

  private
    A = de⊙ X
    a = pt X

  open Cover
  open import homotopy.CoverClassification X A-conn

  {-
      Universality of the covering generated by the fundamental group itself.
  -}

  -- FIXME What's the established terminology for this?
  canonical-gset : Gset (πS 0 X) i
  canonical-gset = record
    { El = a =₀ a
    ; El-level = Trunc-level
    ; gset-struct = record
      { act = _∙₀_
      ; unit-r = ∙₀-unit-r
      ; assoc = ∙₀-assoc
      }
    }

  -- FIXME What's the established terminology for this?
  canonical-cover : Cover A i
  canonical-cover = gset-to-cover canonical-gset

{-
  private
    module CanonicalIsUniversal where
      open covering canonical-covering
      open gset canonical-gset

      center′ : ∀ a → Σ A fiber
      center′ a = (a , trace {gs = act} refl₀ refl₀)

      center : τ ⟨1⟩ (Σ A fiber)
      center = proj center′

      private
        -- An ugly lemma for this development only
        trans-fiber≡cst-proj-Σ-eq : ∀ {i} (P : Set i) (Q : P → Set i)
          (a : P) (c : Σ P Q) {b₁ b₂} (p : b₁ ≡ b₂) (q : a ≡ π₁ c)
          (r : transport Q q b₁ ≡ π₂ c)
          → transport (λ r → (a , r) ≡₀ c) p (proj $ Σ-eq q r)
          ≡ proj (Σ-eq q (ap (transport Q q) (! p) ∘ r))
        trans-fiber≡cst-proj-Σ-eq P Q a c refl q r = refl

      abstract
        path-trace-fiber : ∀ {a₂} y (p : a ≡ a₂)
          → transport fiber (! p ∘ ! y) (trace (proj y) (proj p))
          ≡ trace refl₀ refl₀
        path-trace-fiber y refl =
          transport fiber (! y) (trace (proj y) refl₀)
            ≡⟨ trans-trace act (! y) (proj y) refl₀ ⟩
          trace (proj y) (proj $ ! y)
            ≡⟨ paste refl₀ (proj y) (proj $ ! y) ⟩
          trace refl₀ (proj $ y ∘ ! y)
            ≡⟨ ap (trace refl₀ ◯ proj) $ opposite-right-inverse y ⟩∎
          trace refl₀ refl₀
            ∎

      path-trace : ∀ {a₂} y p → (a₂ , trace {act = act} y p) ≡₀ center′
      path-trace {a₂} =
        π₀-extend ⦃ λ y → Π-is-set λ p → π₀-is-set ((a₂ , trace y p) ≡ center′) ⦄
          (λ y → π₀-extend ⦃ λ p → π₀-is-set ((a₂ , trace (proj y) p) ≡ center′) ⦄
            (λ p → proj $ Σ-eq (! p ∘ ! y) (path-trace-fiber y p)))

      abstract
        path-paste′ : ∀ {a₂} y loop p
          → transport (λ r → (a₂ , r) ≡₀ center′) (paste (proj y) (proj loop) (proj p))
              (path-trace (proj $ y ∘ loop) (proj p))
          ≡ path-trace (proj y) (proj $ loop ∘ p)
        path-paste′ y loop refl =
          transport (λ r → (a , r) ≡₀ center′) (paste (proj y) (proj loop) refl₀)
            (proj $ Σ-eq (! (y ∘ loop)) (path-trace-fiber (y ∘ loop) refl))
              ≡⟨ trans-fiber≡cst-proj-Σ-eq A fiber a center′
                    (paste (proj y) (proj loop) refl₀)
                    (! (y ∘ loop)) (path-trace-fiber (y ∘ loop) refl) ⟩
          proj (Σ-eq (! (y ∘ loop)) _)
              ≡⟨ ap proj $
                  ap2 (λ p q → Σ-eq p q)
                    (! (y ∘ loop)
                      ≡⟨ opposite-concat y loop ⟩
                    ! loop ∘ ! y
                      ≡⟨ ap (λ x → ! x ∘ ! y) $ ! $ refl-right-unit loop ⟩∎
                    ! (loop ∘ refl) ∘ ! y
                      ∎)
                    (prop-has-all-paths (ribbon-is-set a _ _) _ _) ⟩∎
          proj (Σ-eq (! (loop ∘ refl) ∘ ! y) (path-trace-fiber y (loop ∘ refl)))
              ∎

      abstract
        path-paste : ∀ {a₂} y loop p
          → transport (λ r → (a₂ , r) ≡₀ center′) (paste y loop p)
              (path-trace (y ∘₀ loop) p)
          ≡ path-trace y (loop ∘₀ p)
        path-paste {a₂} =
          π₀-extend ⦃ λ y → Π-is-set λ loop → Π-is-set λ p → ≡-is-set $ π₀-is-set _ ⦄
            (λ y → π₀-extend ⦃ λ loop → Π-is-set λ p → ≡-is-set $ π₀-is-set _ ⦄
              (λ loop → π₀-extend ⦃ λ p → ≡-is-set $ π₀-is-set _ ⦄
                (λ p → path-paste′ y loop p)))

      path′ : (y : Σ A fiber) → proj {n = ⟨1⟩} y ≡ center
      path′ y = τ-path-equiv-path-τ-S {n = ⟨0⟩} ☆
        ribbon-rec {act = act} (π₁ y)
          (λ r → (π₁ y , r) ≡₀ center′)
          ⦃ λ r → π₀-is-set ((π₁ y , r) ≡ center′) ⦄
          path-trace
          path-paste
          (π₂ y)

      path : (y : τ ⟨1⟩ (Σ A fiber)) → y ≡ center
      path = τ-extend {n = ⟨1⟩} ⦃ λ _ → ≡-is-truncated ⟨1⟩ $ τ-is-truncated ⟨1⟩ _ ⦄ path′

  canonical-covering-is-universal : is-universal canonical-covering
  canonical-covering-is-universal = Universality.center , Universality.path

  -- The other direction:  If a covering is universal, then the fiber
  -- is equivalent to the fundamental group.
  module _ (cov : covering) (cov-is-universal : is-universal cov) where
    open covering cov
    open action (covering⇒action cov)

    -- We need a point!
    module GiveMeAPoint (center : fiber a) where

      -- Goal: fiber a <-> fundamental group

      fiber-a⇒fg : fiber a → a ≡₀ a
      fiber-a⇒fg y = ap₀ π₁ $ connected-has-all-τ-paths
        cov-is-universal (a , center) (a , y)

      fg⇒fiber-a : a ≡₀ a → fiber a
      fg⇒fiber-a = tracing cov center

      fg⇒fiber-a⇒fg : ∀ p → fiber-a⇒fg (fg⇒fiber-a p) ≡ p
      fg⇒fiber-a⇒fg = π₀-extend ⦃ λ _ → ≡-is-set $ π₀-is-set _ ⦄ λ p →
        ap₀ π₁ (connected-has-all-τ-paths
          cov-is-universal (a , center) (a , transport fiber p center))
            ≡⟨ ap (ap₀ π₁)
                  $ ! $ π₂ (connected-has-connected-paths cov-is-universal _ _)
                           (proj $ Σ-eq p refl) ⟩
        ap₀ π₁ (proj $ Σ-eq p refl)
            ≡⟨ ap proj $ base-path-Σ-eq p refl ⟩∎
        proj p
            ∎

      fiber-a⇒fg⇒fiber-a : ∀ y → fg⇒fiber-a (fiber-a⇒fg y) ≡ y
      fiber-a⇒fg⇒fiber-a y = π₀-extend
        ⦃ λ p → ≡-is-set {x = tracing cov center (ap₀ π₁ p)} {y = y}
                  $ fiber-is-set a ⦄
        (λ p →
          transport fiber (base-path p) center
            ≡⟨ trans-base-path p ⟩∎
          y
            ∎)
        (connected-has-all-τ-paths cov-is-universal (a , center) (a , y))

      fiber-a≃fg : fiber a ≃ (a ≡₀ a)
      fiber-a≃fg = fiber-a⇒fg , iso-is-eq _ fg⇒fiber-a
        fg⇒fiber-a⇒fg fiber-a⇒fg⇒fiber-a

    -- This is the best we can obtain, because there is no continuous
    -- choice of the center.
    [center] : [ fiber a ]
    [center] = τ-extend-nondep
      ⦃ prop-is-gpd []-is-prop ⦄
      (λ y → []-extend-nondep
        ⦃ []-is-prop ⦄
        (proj ◯ λ p → transport fiber p (π₂ y))
        (connected-has-all-τ-paths A⋆-is-conn (π₁ y) a))
      (π₁ cov-is-universal)

    -- [ isomorphism between the fiber and the fundamental group ]
    -- This is the best we can obtain, because there is no continuous
    -- choice of the center.
    [fiber-a≃fg] : [ fiber a ≃ (a ≡₀ a) ]
    [fiber-a≃fg] = []-extend-nondep ⦃ []-is-prop ⦄
      (proj ◯ GiveMeAPoint.fiber-a≃fg) [center]

-}


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

open import HoTT

module groups.CoefficientExtensionality where

module _ {i} {A : Type i} (dec : has-dec-eq A) where

  Word-coef : Word A → (A → ℤ)
  Word-coef nil a = 0
  Word-coef (inl a' :: w) a with dec a' a
  Word-coef (inl a' :: w) a | inl a'=a = succ $ Word-coef w a
  Word-coef (inl a' :: w) a | inr a'≠a = Word-coef w a
  Word-coef (inr a' :: w) a with dec a' a
  Word-coef (inr a' :: w) a | inl a'=a = pred $ Word-coef w a
  Word-coef (inr a' :: w) a | inr a'≠a = Word-coef w a

  abstract
    Word-coef-++ : ∀ w₁ w₂ a → Word-coef (w₁ ++ w₂) a
      == Word-coef w₁ a ℤ+ Word-coef w₂ a
    Word-coef-++ nil w₂ a = idp
    Word-coef-++ (inl a' :: w₁) w₂ a with dec a' a
    Word-coef-++ (inl a' :: w₁) w₂ a | inl a'=a =
        ap succ (Word-coef-++ w₁ w₂ a)
      ∙ ! (succ-+ (Word-coef w₁ a) (Word-coef w₂ a))
    Word-coef-++ (inl a' :: w₁) w₂ a | inr a'≠a = Word-coef-++ w₁ w₂ a
    Word-coef-++ (inr a' :: w₁) w₂ a with dec a' a
    Word-coef-++ (inr a' :: w₁) w₂ a | inl a'=a =
        ap pred (Word-coef-++ w₁ w₂ a)
      ∙ ! (pred-+ (Word-coef w₁ a) (Word-coef w₂ a))
    Word-coef-++ (inr a' :: w₁) w₂ a | inr a'≠a = Word-coef-++ w₁ w₂ a

    Word-coef-flip : ∀ w a → Word-coef (Word-flip w) a == ℤ~ (Word-coef w a)
    Word-coef-flip nil a = idp
    Word-coef-flip (inl a' :: w) a with dec a' a
    Word-coef-flip (inl a' :: w) a | inl a'=a =
        ap pred (Word-coef-flip w a) ∙ ! (ℤ~-succ (Word-coef w a))
    Word-coef-flip (inl a' :: w) a | inr a'≠a = Word-coef-flip w a
    Word-coef-flip (inr a' :: w) a with dec a' a
    Word-coef-flip (inr a' :: w) a | inl a'=a =
        ap succ (Word-coef-flip w a) ∙ ! (ℤ~-pred (Word-coef w a))
    Word-coef-flip (inr a' :: w) a | inr a'≠a = Word-coef-flip w a

  private
    abstract
      FormalSum-coef-rel : {w₁ w₂ : Word A} → FormalSumRel w₁ w₂
        → ∀ a → Word-coef w₁ a == Word-coef w₂ a
      FormalSum-coef-rel (fsr-refl p) a = ap (λ w → Word-coef w a) p
      FormalSum-coef-rel (fsr-trans fwr₁ fwr₂) a = (FormalSum-coef-rel fwr₁ a) ∙ (FormalSum-coef-rel fwr₂ a)
      FormalSum-coef-rel (fsr-sym fsr) a = ! $ FormalSum-coef-rel fsr a
      FormalSum-coef-rel (fsr-cons x fwr) a =
          Word-coef-++ (x :: nil) _ a
        ∙ ap (Word-coef (x :: nil) a ℤ+_) (FormalSum-coef-rel fwr a)
        ∙ ! (Word-coef-++ (x :: nil) _ a)
      FormalSum-coef-rel (fsr-swap x y w) a =
          Word-coef-++ (x :: y :: nil) _ a
        ∙ ap (_ℤ+ Word-coef w a)
            ( Word-coef-++ (x :: nil) (y :: nil) a
            ∙ ℤ+-comm (Word-coef (x :: nil) a) (Word-coef (y :: nil) a)
            ∙ ! (Word-coef-++ (y :: nil) (x :: nil) a))
        ∙ ! (Word-coef-++ (y :: x :: nil) _ a)
      FormalSum-coef-rel (fsr-flip x w) a =
          Word-coef-++ (x :: flip x :: nil) w a
        ∙ ap (_ℤ+ Word-coef w a)
            ( Word-coef-++ (x :: nil) (flip x :: nil) a
            ∙ ap (Word-coef (x :: nil) a ℤ+_) (Word-coef-flip (x :: nil) a)
            ∙ ℤ~-inv-r (Word-coef (x :: nil) a) )
        ∙ ℤ+-unit-l (Word-coef w a)

  FormalSum-coef : FormalSum A → (A → ℤ)
  FormalSum-coef = FormalSum-rec Word-coef (λ r → λ= $ FormalSum-coef-rel r)

  -- Theorem : if coef w a == 0 then FormalSumRel w nil

  private
    abstract
      Word-exp-succ : ∀ (a : A) z → FormalSumRel (inl a :: Word-exp a z) (Word-exp a (succ z))
      Word-exp-succ a (pos _) = fsr-refl idp
      Word-exp-succ a (negsucc 0) = fsr-flip (inl a) nil
      Word-exp-succ a (negsucc (S n)) = fsr-flip (inl a) (Word-exp a (negsucc n))

      Word-exp-pred : ∀ (a : A) z → FormalSumRel (inr a :: Word-exp a z) (Word-exp a (pred z))
      Word-exp-pred a (pos 0) = fsr-refl idp
      Word-exp-pred a (pos (S n)) = fsr-flip (inr a) (Word-exp a (pos n))
      Word-exp-pred a (negsucc _) = fsr-refl idp

      Word-coef-inl-eq : ∀ {a b} (p : b == a) w
        → Word-coef (inl b :: w) a == succ (Word-coef w a)
      Word-coef-inl-eq {a} {b} p w with dec b a
      Word-coef-inl-eq {a} {b} p w | inl _ = idp
      Word-coef-inl-eq {a} {b} p w | inr ¬p = ⊥-rec (¬p p)

      Word-coef-inr-eq : ∀ {a b} (p : b == a) w
        → Word-coef (inr b :: w) a == pred (Word-coef w a)
      Word-coef-inr-eq {a} {b} p w with dec b a
      Word-coef-inr-eq {a} {b} p w | inl _ = idp
      Word-coef-inr-eq {a} {b} p w | inr ¬p = ⊥-rec (¬p p)

      Word-coef-inl-neq : ∀ {a b} (p : b ≠ a) w
        → Word-coef (inl b :: w) a == Word-coef w a
      Word-coef-inl-neq {a} {b} ¬p w with dec b a
      Word-coef-inl-neq {a} {b} ¬p w | inl p = ⊥-rec (¬p p)
      Word-coef-inl-neq {a} {b} ¬p w | inr _ = idp

      Word-coef-inr-neq : ∀ {a b} (p : b ≠ a) w
        → Word-coef (inr b :: w) a == Word-coef w a
      Word-coef-inr-neq {a} {b} ¬p w with dec b a
      Word-coef-inr-neq {a} {b} ¬p w | inl p = ⊥-rec (¬p p)
      Word-coef-inr-neq {a} {b} ¬p w | inr _ = idp

    -- TODO maybe there is a better way to prove the final theorem?
    -- Here we are collecting all elements [inl a] and [inr a], and recurse on the rest.
    -- The [right-shorter] field makes sure that it is terminating.
    record CollectSplitIH (a : A) {n : ℕ} (w : Word A) (len : length w == n) : Type i where
      field
        left-exponent : ℤ
        left-captures-all : Word-coef w a == left-exponent
        right-list : Word A
        right-shorter : length right-list ≤ n
        fsr : FormalSumRel w (Word-exp a left-exponent ++ right-list)

    abstract
      collect-split : ∀ a {n} w (len=n : length w == n) → CollectSplitIH a w len=n
      collect-split a nil idp = record {
        left-exponent = 0;
        left-captures-all = idp;
        right-list = nil;
        right-shorter = inl idp;
        fsr = fsr-refl idp}
      collect-split a (inl b :: w) idp with dec b a
      ... | inl b=a = record {
        left-exponent = succ left-exponent;
        left-captures-all = Word-coef-inl-eq b=a w ∙ ap succ left-captures-all;
        right-list = right-list;
        right-shorter = ≤-trans right-shorter (inr ltS);
        fsr = fsr-trans (fsr-refl (ap (λ a → inl a :: w) b=a)) $
              fsr-trans (fsr-cons (inl a) fsr) $
                        (FormalSumRel-cong-++-l (Word-exp-succ a left-exponent) right-list)}
        where open CollectSplitIH (collect-split a w idp)
      ... | inr b≠a = record {
        left-exponent = left-exponent;
        left-captures-all = Word-coef-inl-neq b≠a w ∙ left-captures-all;
        right-list = inl b :: right-list;
        right-shorter = ≤-ap-S right-shorter;
        fsr = fsr-trans (fsr-cons (inl b) fsr) $
          fsr-sym (FormalSumRel-swap1 (inl b) (Word-exp a left-exponent) right-list)}
        where open CollectSplitIH (collect-split a w idp)
      collect-split a (inr b :: w) idp with dec b a
      ... | inl b=a = record {
        left-exponent = pred left-exponent;
        left-captures-all = Word-coef-inr-eq b=a w ∙ ap pred left-captures-all;
        right-list = right-list;
        right-shorter = ≤-trans right-shorter (inr ltS);
        fsr = fsr-trans (fsr-refl (ap (λ a → inr a :: w) b=a)) $
              fsr-trans (fsr-cons (inr a) fsr) $
                        (FormalSumRel-cong-++-l (Word-exp-pred a left-exponent) right-list)}
        where open CollectSplitIH (collect-split a w idp)
      ... | inr b≠a = record {
        left-exponent = left-exponent;
        left-captures-all = Word-coef-inr-neq b≠a w ∙ left-captures-all;
        right-list = inr b :: right-list;
        right-shorter = ≤-ap-S right-shorter;
        fsr = fsr-trans (fsr-cons (inr b) fsr) $
          fsr-sym (FormalSumRel-swap1 (inr b) (Word-exp a left-exponent) right-list)}
        where open CollectSplitIH (collect-split a w idp)

      -- We simulate strong induction by recursing on both [m] and [n≤m].
      -- We could develop a general framework for strong induction but I am lazy. -Favonia
      zero-coef-is-ident' : ∀ {m n} (n≤m : n ≤ m) (w : Word A) (len : length w == n)
        → (∀ a → Word-coef w a == 0) → FormalSumRel w nil
      zero-coef-is-ident' (inr ltS) w len zero-coef
        = zero-coef-is-ident' (inl idp) w len zero-coef
      zero-coef-is-ident' (inr (ltSR lt)) w len zero-coef
        = zero-coef-is-ident' (inr lt) w len zero-coef
      zero-coef-is-ident' {m = O} (inl idp) nil _ _ = fsr-refl idp
      zero-coef-is-ident' {m = O} (inl idp) (_ :: _) len _ = ⊥-rec $ ℕ-S≠O _ len
      zero-coef-is-ident' {m = S m} (inl idp) nil len _ = ⊥-rec $ ℕ-S≠O _ (! len)
      zero-coef-is-ident' {m = S m} (inl idp) (inl a :: w) len zero-coef =
        fsr-trans whole-is-right (zero-coef-is-ident' right-shorter right-list idp right-zero-coef)
        where
          open CollectSplitIH (collect-split a w (ℕ-S-is-inj _ _ len))
          left-exponent-is-minus-one : left-exponent == -1
          left-exponent-is-minus-one = succ-is-inj left-exponent -1 $
            ap succ (! left-captures-all) ∙ ! (Word-coef-inl-eq idp w) ∙ zero-coef a

          whole-is-right : FormalSumRel (inl a :: w) right-list
          whole-is-right =
            fsr-trans (fsr-cons (inl a) fsr) $
            fsr-trans (fsr-refl (ap (λ e → inl a :: Word-exp a e ++ right-list) left-exponent-is-minus-one)) $
                      fsr-flip (inl a) right-list

          right-zero-coef : ∀ a' → Word-coef right-list a' == 0
          right-zero-coef a' = ! (FormalSum-coef-rel whole-is-right a') ∙ zero-coef a'
      zero-coef-is-ident' {m = S m} (inl idp) (inr a :: w) len zero-coef =
        fsr-trans whole-is-right (zero-coef-is-ident' right-shorter right-list idp right-zero-coef)
        where
          open CollectSplitIH (collect-split a w (ℕ-S-is-inj _ _ len))
          left-exponent-is-one : left-exponent == 1
          left-exponent-is-one = pred-is-inj left-exponent 1 $
            ap pred (! left-captures-all) ∙ ! (Word-coef-inr-eq idp w) ∙ zero-coef a

          whole-is-right : FormalSumRel (inr a :: w) right-list
          whole-is-right =
            fsr-trans (fsr-cons (inr a) fsr) $
            fsr-trans (fsr-refl (ap (λ e → inr a :: Word-exp a e ++ right-list) left-exponent-is-one)) $
                      fsr-flip (inr a) right-list

          right-zero-coef : ∀ a' → Word-coef right-list a' == 0
          right-zero-coef a' = ! (FormalSum-coef-rel whole-is-right a') ∙ zero-coef a'

      zero-coef-is-ident : ∀ (w : Word A)
        → (∀ a → Word-coef w a == 0)
        → FormalSumRel w nil
      zero-coef-is-ident w = zero-coef-is-ident' (inl idp) w idp

  abstract
    FormalSum-coef-ext' : ∀ w₁ w₂
      → (∀ a → Word-coef w₁ a == Word-coef w₂ a)
      → fs[ w₁ ] == fs[ w₂ ]
    FormalSum-coef-ext' w₁ w₂ same-coef = G.inv-is-inj fs[ w₁ ] fs[ w₂ ] $
      G.inv-unique-l (G.inv fs[ w₂ ]) fs[ w₁ ] $ quot-rel $
      zero-coef-is-ident (Word-flip w₂ ++ w₁)
        (λ a → Word-coef-++ (Word-flip w₂) w₁ a
             ∙ ap2 _ℤ+_ (Word-coef-flip w₂ a) (same-coef a)
             ∙ ℤ~-inv-l (Word-coef w₂ a))
      where module G = FreeAbGroup A

    FormalSum-coef-ext : ∀ fs₁ fs₂
      → (∀ a → FormalSum-coef fs₁ a == FormalSum-coef fs₂ a)
      → fs₁ == fs₂
    FormalSum-coef-ext = FormalSum-elim
      (λ w₁ → FormalSum-elim
        (λ w₂ → FormalSum-coef-ext' w₁ w₂)
        (λ _ → prop-has-all-paths-↓))
      (λ _ → prop-has-all-paths-↓)

  has-finite-support : (A → ℤ) → Type i
  has-finite-support f = Σ (FormalSum A) λ fs → ∀ a → f a == FormalSum-coef fs a

module _ {i} {A : Type i} {dec : has-dec-eq A} where

  abstract
    has-finite-support-is-prop : ∀ f → is-prop (has-finite-support dec f)
    has-finite-support-is-prop f = all-paths-is-prop
      λ{(fs₁ , match₁) (fs₂ , match₂) → pair=
        (FormalSum-coef-ext dec fs₁ fs₂ λ a → ! (match₁ a) ∙ match₂ a)
        prop-has-all-paths-↓}

module _ where

  private
    abstract
      Word-coef-exp-diag-pos : ∀ {I} (<I : Fin I) n →
        Word-coef Fin-has-dec-eq (Word-exp <I (pos n)) <I == pos n
      Word-coef-exp-diag-pos <I O = idp
      Word-coef-exp-diag-pos <I (S n) with Fin-has-dec-eq <I <I
      ... | inl _ = ap succ (Word-coef-exp-diag-pos <I n)
      ... | inr ¬p = ⊥-rec (¬p idp)

      Word-coef-exp-diag-negsucc : ∀ {I} (<I : Fin I) n →
        Word-coef Fin-has-dec-eq (Word-exp <I (negsucc n)) <I == negsucc n
      Word-coef-exp-diag-negsucc <I O with Fin-has-dec-eq <I <I
      ... | inl _ = idp
      ... | inr ¬p = ⊥-rec (¬p idp)
      Word-coef-exp-diag-negsucc <I (S n) with Fin-has-dec-eq <I <I
      ... | inl _ = ap pred (Word-coef-exp-diag-negsucc <I n)
      ... | inr ¬p = ⊥-rec (¬p idp)

      Word-coef-exp-diag : ∀ {I} (<I : Fin I) z →
        Word-coef Fin-has-dec-eq (Word-exp <I z) <I == z
      Word-coef-exp-diag <I (pos n) = Word-coef-exp-diag-pos <I n
      Word-coef-exp-diag <I (negsucc n) = Word-coef-exp-diag-negsucc <I n

      Word-coef-exp-≠-pos : ∀ {I} {<I <I' : Fin I} (_ : <I ≠ <I') n →
        Word-coef Fin-has-dec-eq (Word-exp <I (pos n)) <I' == 0
      Word-coef-exp-≠-pos _ O = idp
      Word-coef-exp-≠-pos {<I = <I} {<I'} neq (S n) with Fin-has-dec-eq <I <I'
      ... | inl p = ⊥-rec (neq p)
      ... | inr ¬p = Word-coef-exp-≠-pos neq n

      Word-coef-exp-≠-negsucc : ∀ {I} {<I <I' : Fin I} (_ : <I ≠ <I') n →
        Word-coef Fin-has-dec-eq (Word-exp <I (negsucc n)) <I' == 0
      Word-coef-exp-≠-negsucc {<I = <I} {<I'} neq O with Fin-has-dec-eq <I <I'
      ... | inl p = ⊥-rec (neq p)
      ... | inr ¬p = idp
      Word-coef-exp-≠-negsucc {<I = <I} {<I'} neq (S n) with Fin-has-dec-eq <I <I'
      ... | inl p = ⊥-rec (neq p)
      ... | inr ¬p = Word-coef-exp-≠-negsucc neq n

      Word-coef-exp-≠ : ∀ {I} {<I <I' : Fin I} (_ : <I ≠ <I') z →
        Word-coef Fin-has-dec-eq (Word-exp <I z) <I' == 0
      Word-coef-exp-≠ neq (pos n) = Word-coef-exp-≠-pos neq n
      Word-coef-exp-≠ neq (negsucc n) = Word-coef-exp-≠-negsucc neq n

    Word-sum' : ∀ (I : ℕ) {A : Type₀} (F : Fin I → A) (f : Fin I → ℤ) → Word A
    Word-sum' 0 F f = nil
    Word-sum' (S I) F f = Word-sum' I (F ∘ Fin-S) (f ∘ Fin-S) ++ Word-exp (F (I , ltS)) (f (I , ltS))

    Word-sum : ∀ {I : ℕ} (f : Fin I → ℤ) → Word (Fin I)
    Word-sum {I} f = Word-sum' I (idf (Fin I)) f

    abstract
      Word-coef-sum'-late : ∀ n m (I : ℕ) (f : Fin I → ℤ)
        → Word-coef Fin-has-dec-eq (Word-sum' I (Fin-S^' (S n) ∘ Fin-S^' m) f) (Fin-S^' n (ℕ-S^' m I , ltS)) == 0
      Word-coef-sum'-late n m 0 f = idp
      Word-coef-sum'-late n m (S I) f =
        Word-coef Fin-has-dec-eq
          (Word-sum' I (Fin-S^' (S n) ∘ Fin-S^' (S m)) (f ∘ Fin-S) ++ Word-exp (Fin-S^' (S n) (Fin-S^' m (I , ltS))) (f (I , ltS)))
          (Fin-S^' n (ℕ-S^' (S m) I , ltS))
          =⟨ Word-coef-++ Fin-has-dec-eq
              (Word-sum' I (Fin-S^' (S n) ∘ Fin-S^' (S m)) (f ∘ Fin-S))
              (Word-exp (Fin-S^' (S n) (Fin-S^' m (I , ltS))) (f (I , ltS)))
              (Fin-S^' n (ℕ-S^' (S m) I , ltS)) ⟩
        Word-coef Fin-has-dec-eq (Word-sum' I (Fin-S^' (S n) ∘ Fin-S^' (S m)) (f ∘ Fin-S)) (Fin-S^' n (ℕ-S^' (S m) I , ltS))
        ℤ+
        Word-coef Fin-has-dec-eq (Word-exp (Fin-S^' (S n) (Fin-S^' m (I , ltS))) (f (I , ltS))) (Fin-S^' n (ℕ-S^' (S m) I , ltS))
          =⟨ ap2 _ℤ+_
              (Word-coef-sum'-late n (S m) I (f ∘ Fin-S))
              (Word-coef-exp-≠ (Fin-S^'-≠ n (ltSR≠ltS _)) (f (I , ltS))) ⟩
        0
          =∎

      Word-coef-sum' : ∀ n {I} (f : Fin I → ℤ) <I
        → Word-coef Fin-has-dec-eq (Word-sum' I (Fin-S^' n) f) (Fin-S^' n <I) == f <I
      Word-coef-sum' n f (I , ltS) =
        Word-coef Fin-has-dec-eq
          (Word-sum' I (Fin-S^' (S n)) (f ∘ Fin-S) ++ Word-exp (Fin-S^' n (I , ltS)) (f (I , ltS)))
          (Fin-S^' n (I , ltS))
          =⟨ Word-coef-++ Fin-has-dec-eq
              (Word-sum' I (Fin-S^' (S n)) (f ∘ Fin-S))
              (Word-exp (Fin-S^' n (I , ltS)) (f (I , ltS)))
              (Fin-S^' n (I , ltS)) ⟩
        Word-coef Fin-has-dec-eq (Word-sum' I (Fin-S^' (S n)) (f ∘ Fin-S)) (Fin-S^' n (I , ltS))
        ℤ+
        Word-coef Fin-has-dec-eq (Word-exp (Fin-S^' n (I , ltS)) (f (I , ltS))) (Fin-S^' n (I , ltS))
          =⟨ ap2 _ℤ+_
              (Word-coef-sum'-late n 0 I (f ∘ Fin-S))
              (Word-coef-exp-diag (Fin-S^' n (I , ltS)) (f (I , ltS))) ⟩
        f (I , ltS)
          =∎
      Word-coef-sum' n {I = S I} f (m , ltSR m<I) =
        Word-coef Fin-has-dec-eq
          (Word-sum' I (Fin-S^' (S n)) (f ∘ Fin-S) ++ Word-exp (Fin-S^' n (I , ltS)) (f (I , ltS)))
          (Fin-S^' (S n) (m , m<I))
          =⟨ Word-coef-++ Fin-has-dec-eq
              (Word-sum' I (Fin-S^' (S n)) (f ∘ Fin-S))
              (Word-exp (Fin-S^' n (I , ltS)) (f (I , ltS)))
              (Fin-S^' (S n) (m , m<I)) ⟩
        Word-coef Fin-has-dec-eq (Word-sum' I (Fin-S^' (S n)) (f ∘ Fin-S)) (Fin-S^' (S n) (m , m<I))
        ℤ+
        Word-coef Fin-has-dec-eq (Word-exp (Fin-S^' n (I , ltS)) (f (I , ltS))) (Fin-S^' (S n) (m , m<I))
          =⟨ ap2 _ℤ+_
              (Word-coef-sum' (S n) {I} (f ∘ Fin-S) (m , m<I))
              (Word-coef-exp-≠ (Fin-S^'-≠ n (ltS≠ltSR (m , m<I))) (f (I , ltS))) ⟩
        f (m , ltSR m<I) ℤ+ 0
          =⟨ ℤ+-unit-r _ ⟩
        f (m , ltSR m<I)
          =∎

  FormalSum-sum' : ∀ n (I : ℕ) (f : Fin I → ℤ) → FormalSum (Fin (ℕ-S^' n I))
  FormalSum-sum' n I f =
    Group.sum (FreeAbGroup.grp (Fin (ℕ-S^' n I)))
      (λ <I → Group.exp (FreeAbGroup.grp (Fin (ℕ-S^' n I))) fs[ inl (Fin-S^' n <I) :: nil ] (f <I))

  FormalSum-sum : ∀ {I : ℕ} (f : Fin I → ℤ) → FormalSum (Fin I)
  FormalSum-sum {I} = FormalSum-sum' 0 I

  private
    abstract
      FormalSum-sum'-β : ∀ n (I : ℕ) (f : Fin I → ℤ)
        → FormalSum-sum' n I f == fs[ Word-sum' I (Fin-S^' n) f ]
      FormalSum-sum'-β n O f = idp
      FormalSum-sum'-β n (S I) f =
        ap2 (Group.comp (FreeAbGroup.grp (Fin (ℕ-S^' (S n) I))))
          (FormalSum-sum'-β (S n) I (f ∘ Fin-S))
          (! (FormalSumRel-pres-exp (Fin-S^' n (I , ltS)) (f (I , ltS))))

  Fin→-has-finite-support : ∀ {I} (f : Fin I → ℤ) → has-finite-support Fin-has-dec-eq f
  Fin→-has-finite-support {I} f = FormalSum-sum f , lemma
    where abstract lemma = λ <I → ! (ap (λ fs → FormalSum-coef Fin-has-dec-eq fs <I) (FormalSum-sum'-β 0 I f) ∙ Word-coef-sum' 0 f <I)


module Implicits.Syntax.Type.Unification.Lemmas where

open import Prelude
open import Data.Nat.Properties.Simple
open import Data.Maybe as Maybe
open import Data.Vec
open import Extensions.Vec

open import Implicits.Syntax
open import Implicits.Syntax.Type.Unification hiding (open-meta)
open import Implicits.Substitutions
open import Implicits.Substitutions.Lemmas.MetaType

open MetaTypeMetaSubst
open MetaTypeMetaLemmas

open import Relation.Binary.HeterogeneousEquality as H using ()

-- the following properties of mgu are assumed to hold here but have been proven by
-- Conor McBride (and verified using the LEGO dependently typed language)

postulate sound : ∀ {m ν} (a : MetaType m ν) (b : SimpleType ν) →
                  Maybe.All (Unifier a b) (mgu a b)

postulate complete : ∀ {m ν} (a : MetaType m ν) (b : SimpleType ν) u →
                     Unifier a b u →
                     Is-just (mgu a b)

to-meta-zero-vanishes : ∀ {ν} {a : Type ν} → from-meta (to-meta a) ≡ a
to-meta-zero-vanishes {a = simpl (tc x)} = refl
to-meta-zero-vanishes {a = simpl (tvar n)} = refl
to-meta-zero-vanishes {a = simpl (a →' b)} =
  cong₂ (λ u v → simpl (u →' v)) to-meta-zero-vanishes to-meta-zero-vanishes
to-meta-zero-vanishes {a = a ⇒ b} = cong₂ _⇒_ to-meta-zero-vanishes to-meta-zero-vanishes
to-meta-zero-vanishes {a = ∀' a} = cong ∀' to-meta-zero-vanishes

mutual
  from-to-smeta : ∀ {ν} (a : SimpleType ν) → from-smeta (to-smeta a) ≡ a
  from-to-smeta (tc x) = refl
  from-to-smeta (tvar n) = refl
  from-to-smeta (a →' b) = cong₂ _→'_ (from-to-meta a) (from-to-meta b)

  from-to-meta : ∀ {ν} (a : Type ν) → from-meta (to-meta a) ≡ a
  from-to-meta (simpl x) = cong simpl (from-to-smeta x)
  from-to-meta (a ⇒ b) = cong₂ _⇒_ (from-to-meta a) (from-to-meta b)
  from-to-meta (∀' a) = cong ∀' (from-to-meta a)

from-to-meta-/-vanishes : ∀ {ν} {a : Type ν} {s} →
                          from-meta (to-meta {zero} a MetaTypeMetaSubst./ s) ≡ a
from-to-meta-/-vanishes {a = a} {s = []} = begin
  from-meta (MetaTypeMetaSubst._/_ (to-meta {zero} a) [])
    ≡⟨ cong (λ q → from-meta q) (MetaTypeMetaLemmas.id-vanishes (to-meta {zero} a)) ⟩
  from-meta (to-meta {zero} a)
    ≡⟨ to-meta-zero-vanishes ⟩
  a ∎

mgu-id : ∀ {ν} → (a : SimpleType ν) → Unifiable {m = zero} (simpl (to-smeta a)) a
mgu-id a = [] , (begin
  from-meta (MetaTypeMetaSubst._/_ (simpl (to-smeta a)) [])
    ≡⟨ from-to-meta-/-vanishes ⟩
  simpl a ∎)

mvar-unifiable : ∀ {ν m} (n : Fin m) (τ : SimpleType ν) → Unifiable (simpl (mvar n)) τ
mvar-unifiable n τ = u , p
  where
    u = replicate (simpl (tc zero)) [ n ]≔ simpl (to-smeta τ)

    p : from-meta (lookup n u) ≡ simpl τ
    p = begin
      from-meta (lookup n u)
        ≡⟨ cong from-meta (lookup-≔ (replicate (simpl (tc zero))) n _) ⟩
      simpl (from-smeta (to-smeta τ))
        ≡⟨ cong simpl (from-to-smeta τ) ⟩
      simpl τ ∎


module PreludeBool where
import AlonzoPrelude
open AlonzoPrelude

-- import Logic.Base

infixr 20 _||_
infixr 30 _&&_

data Bool : Set where
  false : Bool
  true  : Bool

{-# BUILTIN BOOL  Bool  #-}
{-# BUILTIN TRUE  true  #-}
{-# BUILTIN FALSE false #-}

_&&_ : Bool -> Bool -> Bool
true  && x = x
false && _ = false

_||_ : Bool -> Bool -> Bool
true  || _ = true
false || x = x

not : Bool -> Bool
not true  = false
not false = true

-- open Logic.Base

IsTrue : Bool -> Set
IsTrue true  = True
IsTrue false = False

IsFalse : Bool -> Set
IsFalse x = IsTrue (not x)

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

if'_then_else_ : {A : Set} -> (x : Bool) -> (IsTrue x -> A) -> (IsFalse x -> A) -> A
if' true  then f else g = f tt
if' false then f else g = g tt


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

--open import HoTT
open import homotopy.3x3.PushoutPushout
open import homotopy.3x3.Transpose
import homotopy.3x3.To as To
import homotopy.3x3.From as From
open import homotopy.3x3.Common

module homotopy.3x3.FromTo {i} (d : Span^2 {i}) where

open Span^2 d
open M d hiding (Pushout^2)
open M (transpose d) using () renaming (module F₁∙ to F∙₁; f₁∙ to f∙₁;
                                        module F₃∙ to F∙₃; f₃∙ to f∙₃;
                                        v-h-span to h-v-span)
open M using (Pushout^2)

open To d
open From d

open import homotopy.3x3.FromToInit d
open import homotopy.3x3.FromTo2 d
open import homotopy.3x3.FromTo3 d

from-to-g-g : (c : A₂₂) → (from-to-g-l (f₂₁ c) , ↓-='-out (apd (from-to-r ∘ f₃∙) (glue c)) , ↓-='-out (apd (ap from ∘ ap to ∘ glue) (glue c))
                        =□□ ↓-='-out (apd glue (glue c)) , ↓-='-out (apd (from-to-l ∘ f₁∙) (glue c)) , from-to-g-r (f₂₃ c))
from-to-g-g c = coh _ lemma1 lemma3 _ _ (↓-='-out (apd glue (glue c))) lemma2
                    where
                open M2 c
                open M3 c

from-to-g-g' : (c : A₂₂) → from-to-g-l (f₂₁ c) == from-to-g-r (f₂₃ c) [ (λ c → (from-to-l (f₁∙ c) , glue c =□ ap from (ap to (glue c)) , from-to-r (f₃∙ c))) ↓ glue c ]
from-to-g-g' c = ↓-=□-in (from-to-g-g c)

module FromToG = PushoutElim {d = span _ _ _ f₂₁ f₂₃} {P = λ c → (from-to-l (f₁∙ c) , glue c =□ ap from (ap to (glue c)) , from-to-r (f₃∙ c))}
                 from-to-g-l from-to-g-r from-to-g-g'

from-to-g : (c : A₂∙) → (from-to-l (f₁∙ c) , glue c =□ ap from (ap to (glue c)) , from-to-r (f₃∙ c))
from-to-g = FromToG.f

from-to-g' : (c : A₂∙) → from-to-l (f₁∙ c) == from-to-r (f₃∙ c) [ (λ z → from (to z) == z) ↓ glue c ]
from-to-g' c = ↓-∘=idf-in from to (from-to-g c)

from-to : (x : Pushout^2 d) → from (to x) == x
from-to = Pushout-elim from-to-l from-to-r from-to-g'


module Syntax.Function where

import      Lvl
open import Type
open import Syntax.Type

private variable ℓ : Lvl.Level
private variable T A B C : Type{ℓ}

infix 2 [↦] [⤠] [⤇]

-- Custom syntax for an anonymous function
-- Example:
--   f : A → A
--   f = a ↦ a
--
--   g : (A → A → A) → (A → A → A)
--   g(_▫_) = a₁ ↦ a₂ ↦ (a₁ ▫ a₂)
[↦] : T → T
[↦] x = x
syntax [↦](\x → y) = x ↦ y
{-# DISPLAY [↦] x = x #-}

-- Custom syntax for an anonymous function with an implicit argument
-- Example:
--   f : A → A
--   f = a ↦ a
[⤠] : (A → B) → ({A} → B)
[⤠] f{x} = f(x)
syntax [⤠](\x → y) = x ⤠ y
{-# DISPLAY [⤠] x = x #-}

-- Custom syntax for an anonymous function with an instance argument
[⤇] : (A → B) → (⦃ _ : A ⦄ → B)
[⤇] f ⦃ x ⦄ = f(x)
syntax [⤇](\x → y) = x ⤇ y
{-# DISPLAY [⤇] x = x #-}

-- Functions with two parameters as an infix binary operator
_⦗_⦘_ : A → (A → B → C) → B → C
a ⦗ op ⦘ b = op a b

infix  10000 _⦗_⦘_
infixl 10000 _⦗_⦘ₗ_
infixr 10000 _⦗_⦘ᵣ_

_⦗_⦘ₗ_ = _⦗_⦘_
_⦗_⦘ᵣ_ = _⦗_⦘_

{- TODO: Fix these with stuff in Lang.Function
f : {a : A} → A
f = (a ⤠ a)

g : ⦃ a₁ : A ⦄ ⦃ a₂ : A ⦄ → A
g = (a₁ ⤇ a₂ ⤇ a₁)
-}


-- This module closely follows a section of Martín Escardó's HoTT lecture notes:
-- https://www.cs.bham.ac.uk/~mhe/HoTT-UF-in-Agda-Lecture-Notes/HoTT-UF-Agda.html#funextfromua
{-# OPTIONS --without-K #-}
module Util.HoTT.FunctionalExtensionality where

open import Axiom.Extensionality.Propositional using
  (ExtensionalityImplicit ; implicit-extensionality)

open import Util.Data.Product using (map₂)
open import Util.HoTT.Equiv
open import Util.HoTT.Equiv.Induction
open import Util.HoTT.HLevel.Core
open import Util.HoTT.Homotopy
open import Util.HoTT.Section
open import Util.HoTT.Singleton
open import Util.HoTT.Univalence
open import Util.Prelude
open import Util.Relation.Binary.PropositionalEquality using (Σ-≡⁻)

private
  variable
    α β γ : Level
    A B C : Set α

FunextNondep : ∀ α β → Set (lsuc (α ⊔ℓ β))
FunextNondep α β
  = {A : Set α} {B : Set β} {f g : A → B} → (∀ a → f a ≡ g a) → f ≡ g

IsContr-∀-Closure : ∀ α β → Set (lsuc (α ⊔ℓ β))
IsContr-∀-Closure α β
  = {A : Set α} {B : A → Set β} → (∀ a → IsContr (B a)) → IsContr (∀ a → B a)

FunextHapply : ∀ α β → Set (lsuc (α ⊔ℓ β))
FunextHapply α β
  = {A : Set α} {B : A → Set β} (f g : ∀ a → B a) → IsEquiv (≡→~ {f = f} {g})

Funext : ∀ α β → Set (lsuc (α ⊔ℓ β))
Funext α β
  = {A : Set α} {B : A → Set β} {f g : ∀ a → B a} → (∀ a → f a ≡ g a) → f ≡ g

abstract
  precomp-IsEquiv : {A B : Set α} (f : A → B)
    → IsEquiv f
    → {C : Set α}
    → IsEquiv (λ (g : B → C) → g ∘ f)
  precomp-IsEquiv f f-equiv {C}
    = J-IsEquiv (λ A B f → IsEquiv (λ (g : B → C) → g ∘ f)) (λ A → id-IsEquiv) f
        f-equiv

  funext-nondep : FunextNondep α β
  funext-nondep {α} {β} {A} {B} {f} {g} f~g
    = cong (λ π x → π (f x , g x , f~g x)) π₀≡π₁
    where
      Δ : Set β
      Δ = Σ[ b ∈ B ] Σ[ b′ ∈ B ] (b ≡ b′)

      δ : B → Δ
      δ b = b , b , refl

      π₀ π₁ : Δ → B
      π₀ (b , b′ , p) = b
      π₁ (b , b′ , p) = b′

      δ-IsEquiv : IsEquiv δ
      δ-IsEquiv = IsIso→IsEquiv record
        { back = π₀
        ; back∘forth = λ _ → refl
        ; forth∘back = λ { (b , b′ , refl) → refl }
        }

      φ : (Δ → B) → (B → B)
      φ = _∘ δ

      φ-IsEquiv : IsEquiv φ
      φ-IsEquiv = precomp-IsEquiv δ δ-IsEquiv

      φπ₀≡φπ₁ : φ π₀ ≡ φ π₁
      φπ₀≡φπ₁ = refl

      π₀≡π₁ : π₀ ≡ π₁
      π₀≡π₁ = IsEquiv→Injective φ-IsEquiv φπ₀≡φπ₁

  postcomp-IsIso : {A : Set α} {B : Set β} (f : B → C)
    → IsIso f
    → IsIso (λ (g : A → B) → f ∘ g)
  postcomp-IsIso {A = A} {B} f i = record
    { back = λ g a → i .IsIso.back (g a)
    ; back∘forth = λ g → funext-nondep λ a → i .IsIso.back∘forth (g a)
    ; forth∘back = λ g → funext-nondep λ a → i .IsIso.forth∘back (g a)
    }

  postcomp-IsEquiv : {A : Set α} {B : Set β} (f : B → C)
    → IsEquiv f
    → IsEquiv (λ (g : A → B) → f ∘ g)
  postcomp-IsEquiv f f-equiv
    = IsIso→IsEquiv (postcomp-IsIso f (IsEquiv→IsIso f-equiv))

  ∀-IsContr : IsContr-∀-Closure α β
  ∀-IsContr {A = A} {B} B-contr = ◁-pres-IsContr ΠB◁g-fiber g-fiber-IsContr
    where
      f : Σ A B → A
      f = proj₁

      f-IsEquiv : IsEquiv f
      f-IsEquiv = proj₁-IsEquiv B-contr

      g : (A → Σ A B) → (A → A)
      g = f ∘_

      g-IsEquiv : IsEquiv g
      g-IsEquiv = postcomp-IsEquiv f f-IsEquiv

      g-fiber-IsContr : IsContr (Σ[ h ∈ (A → Σ A B) ] (f ∘ h ≡ id))
      g-fiber-IsContr = g-IsEquiv id

      ΠB◁g-fiber : (∀ a → B a) ◁ (Σ[ h ∈ (A → Σ A B) ] (f ∘ h ≡ id))
      ΠB◁g-fiber = record
        { retraction = λ { (h , p) a → subst B (≡→~ p a) (proj₂ (h a)) }
        ; hasSection = record
          { section = λ h → (λ a → a , h a) , refl
          ; isSection = λ _ → refl
          }
        }

  ≡→~-IsEquiv : FunextHapply α β
  ≡→~-IsEquiv {A = A} {B} f = goal
    where
      i : ∀ a → IsContr (Σ[ b ∈ B a ] (f a ≡ b))
      i a = IsContr-Singleton′

      ii : IsContr (∀ a → Σ[ b ∈ B a ] (f a ≡ b))
      ii = ∀-IsContr i

      iii : (∃[ g ] (f ~ g)) ◁ (∀ a → Σ[ b ∈ B a ] (f a ≡ b))
      iii = ≅→▷ (Π-distr-Σ-≅ _ _ _)

      iv : IsContr (∃[ g ] (f ~ g))
      iv = ◁-pres-IsContr iii ii

      e : (∃[ g ] (f ≡ g)) → (∃[ g ] (f ~ g))
      e = map₂ (λ _ → ≡→~)

      e-IsEquiv : IsEquiv e
      e-IsEquiv = IsContr→IsEquiv IsContr-Singleton′ iv e

      goal : ∀ g → IsEquiv (≡→~ {f = f} {g})
      goal = IsEquiv-map₂-f→IsEquiv-f (λ _ → ≡→~) e-IsEquiv

funext : Funext α β
funext {f = f} {g} eq = ≡→~-IsEquiv f g eq .proj₁ .proj₁

funext∙ : ExtensionalityImplicit α β
funext∙ = implicit-extensionality funext

module _ {α β} {A : Set α} {B : A → Set β} {f g : ∀ a → B a} where

  ≡→~∘funext : (eq : ∀ a → f a ≡ g a)
    → ≡→~ (funext eq) ≡ eq
  ≡→~∘funext eq = ≡→~-IsEquiv f g eq .proj₁ .proj₂

  funext-unique′ : ∀ eq
    → (y : Σ-syntax (f ≡ g) (λ p → ≡→~ p ≡ eq))
    → (funext eq , ≡→~∘funext eq) ≡ y
  funext-unique′ eq = ≡→~-IsEquiv f g eq .proj₂

  funext-unique : ∀ eq (p : f ≡ g)
    → ≡→~ p ≡ eq
    → funext eq ≡ p
  funext-unique eq p q = proj₁ (Σ-≡⁻ (funext-unique′ eq (p , q)))

  funext∘≡→~ : ∀ (eq : f ≡ g)
    → funext (≡→~ eq) ≡ eq
  funext∘≡→~ eq = funext-unique (≡→~ eq) eq refl

subst-funext : ∀ {α β γ} {A : Set α} {B : A → Set β} {f g : ∀ a → B a}
  → (P : ∀ a → B a → Set γ)
  → (f≡g : ∀ x → f x ≡ g x)
  → ∀ {a} (Pf : P a (f a))
  → subst (λ f → P a (f a)) (funext f≡g) Pf ≡ subst (P a) (f≡g a) Pf
subst-funext P f≡g {a} Pf = sym
  (trans
    (cong (λ p → subst (P a) (p a) Pf) (sym (≡→~∘funext f≡g)))
    go)
  where
    go : subst (P a) (≡→~ (funext f≡g) a) Pf
        ≡ subst (λ f → P a (f a)) (funext f≡g) Pf
    go with funext f≡g
    ... | refl = refl


{-# OPTIONS --without-K  #-}
module sets.fin.universe where

open import level
open import sum
open import decidable
open import equality.core
open import equality.calculus
open import equality.inspect
open import function.isomorphism
open import function.core
open import function.extensionality
open import function.fibration
open import function.overloading
open import sets.core
open import sets.properties
open import sets.nat.core
  hiding (_≟_)
open import sets.nat.ordering
  hiding (compare)
open import sets.fin.core
open import sets.fin.ordering
open import sets.fin.properties
open import sets.unit
open import sets.empty
open import sets.bool
open import sets.vec.dependent
open import hott.level.core
open import hott.level.closure
open import hott.level.sets

fin-struct-iso : ∀ {n} → Fin (suc n) ≅ (⊤ {lzero} ⊎ Fin n)
fin-struct-iso = record
  { to = λ { zero → inj₁ tt; (suc i) → inj₂ i }
  ; from = [ (λ _ → zero) ,⊎ (suc) ]
  ; iso₁ = λ { zero → refl ; (suc i) → refl }
  ; iso₂ = λ { (inj₁ _) → refl; (inj₂ i) → refl } }

fin0-empty : ⊥ ≅ Fin 0
fin0-empty = sym≅ (empty-⊥-iso (λ ()))

fin1-unit : ∀ {i} → ⊤ {i} ≅ Fin 1
fin1-unit = record
  { to = λ _ → zero
  ; from = λ { zero → tt ; (suc ()) }
  ; iso₁ = λ _ → refl
  ; iso₂ = λ { zero → refl ; (suc ()) } }

fin2-bool : Bool ≅ Fin 2
fin2-bool = record
  { to = λ b → if b then # 0 else # 1
  ; from = true ∷∷ false ∷∷ ⟦⟧
  ; iso₁ = λ { true → refl ; false → refl }
  ; iso₂ = refl ∷∷ refl ∷∷ ⟦⟧ }

fin-sum : ∀ {n m} → (Fin n ⊎ Fin m) ≅ Fin (n + m)
fin-sum {0} = record
  { to = λ { (inj₁ ()) ; (inj₂ j) → j }
  ; from = λ { j → inj₂ j }
  ; iso₁ = λ { (inj₁ ()); (inj₂ j) → refl }
  ; iso₂ = λ _ → refl }
fin-sum {suc n}{m} = begin
    (Fin (suc n) ⊎ Fin m)
  ≅⟨ ⊎-ap-iso fin-struct-iso refl≅ ⟩
    ((⊤ ⊎ Fin n) ⊎ Fin m)
  ≅⟨ ⊎-assoc-iso ⟩
    (⊤ ⊎ (Fin n ⊎ Fin m))
  ≅⟨ ⊎-ap-iso refl≅ fin-sum ⟩
    (⊤ ⊎ Fin (n + m))
  ≅⟨ sym≅ fin-struct-iso ⟩
    Fin (suc (n + m))
  ∎
  where open ≅-Reasoning

fin-prod : ∀ {n m} → (Fin n × Fin m) ≅ Fin (n * m)
fin-prod {0} = iso (λ { (() , _) }) (λ ()) (λ { (() , _) }) (λ ())
fin-prod {suc n}{m} = begin
    (Fin (suc n) × Fin m)
  ≅⟨ ×-ap-iso fin-struct-iso refl≅ ⟩
    ((⊤ ⊎ Fin n) × Fin m)
  ≅⟨ ⊎×-distr-iso ⟩
    ((⊤ × Fin m) ⊎ (Fin n × Fin m))
  ≅⟨ ⊎-ap-iso ×-left-unit fin-prod ⟩
    (Fin m ⊎ (Fin (n * m)))
  ≅⟨ fin-sum ⟩
    (Fin (m + (n * m)))
  ≡⟨ refl ⟩
    Fin (suc n * m)
  ∎
  where open ≅-Reasoning

fin-exp : ∀ {n m} → (Fin n → Fin m) ≅ Fin (m ^ n)
fin-exp {0} = record
  { to = λ f → zero
  ; from = (λ ()) ∷∷ ⟦⟧
  ; iso₁ = λ f → funext λ ()
  ; iso₂ = refl ∷∷ ⟦⟧ }
fin-exp {suc n}{m} = begin
    (Fin (suc n) → Fin m)
  ≅⟨ (Π-ap-iso fin-struct-iso λ _ → refl≅) ⟩
    ((⊤ ⊎ Fin n) → Fin m)
  ≅⟨ iso (λ f → f (inj₁ tt) , f ∘' inj₂)
         (λ { (i , _) (inj₁ _) → i
            ; (_ , g) (inj₂ i) → g i })
         (λ f → funext λ { (inj₁ tt) → refl
                          ; (inj₂ i) → refl })
         (λ { (i , g) → refl }) ⟩
    (Fin m × (Fin n → Fin m))
  ≅⟨ ×-ap-iso refl≅ fin-exp ⟩
    (Fin m × Fin (m ^ n))
  ≅⟨ fin-prod ⟩
    Fin (m ^ (suc n))
  ∎
  where open ≅-Reasoning

factorial : ℕ → ℕ
factorial 0 = 1
factorial (suc n) = suc n * factorial n

fin-inj-iso : ∀ {n} → (Fin n ≅ Fin n) ≅ (Fin n ↣ Fin n)
fin-inj-iso {n} = record
  { to = λ f → (apply f , iso⇒inj f)
  ; from = λ { (f , inj) → inj⇒iso f inj }
  ; iso₁ = λ f → iso-eq-h2 (fin-set n) (fin-set n) refl
  ; iso₂ = λ { (f , inj) → inj-eq-h2 (fin-set n) refl } }

fin-iso-iso : ∀ {n} → (Fin n ↣ Fin n) ≅ Fin (factorial n)
fin-iso-iso {0} = record
  { to = λ { (f , _) → zero }
  ; from = λ _ → (λ ()) , (λ { {()} p })
  ; iso₁ = λ { (f , _) → inj-eq-h2 (fin-set _) (funext λ ()) }
  ; iso₂ = λ { zero → refl ; (suc ()) } }
fin-iso-iso {suc n} = begin
    (X ↣ X)
  ≅⟨ sym≅ (total-iso classify) ⟩
    (Σ X λ i → classify ⁻¹ i)
  ≅⟨ (Σ-ap-iso₂ λ i → trans≅ (sym≅ (const-fibre i)) fibre-zero-iso) ⟩
    (Fin (suc n) × (Fin n ↣ Fin n))
  ≅⟨ ×-ap-iso refl≅ fin-iso-iso ⟩
    (Fin (suc n) × Fin (factorial n))
  ≅⟨ fin-prod ⟩
    Fin (factorial (suc n))
  ∎
  where
    X = Fin (suc n)
    open ≅-Reasoning

    classify : (X ↣ X) → X
    classify (f , _) = f zero

    const-fibre : (i : X) → classify ⁻¹ zero ≅ classify ⁻¹ i
    const-fibre i = begin
        ( Σ (X ↣ X) λ { (f , _) → f zero ≡ zero } )
      ≅⟨ ( Σ-ap-iso (transpose-inj-iso' zero i) (λ { (f , inj)
         → mk-prop-iso (fin-set _ _ _) (fin-set _ _ _)
                       (ap (transpose zero i)) (u f) }) ) ⟩
        ( Σ (X ↣ X) λ { (f , _) → f zero ≡ i } )
      ∎
      where
        u : (f : X → X)
          → transpose zero i (f zero) ≡ i
          → f zero ≡ zero
        u f p = sym (_≅_.iso₁ (transpose-iso zero i) (f zero))
              · (ap (transpose zero i) p
              · transpose-β₂ zero i)

    fibre-zero-iso : classify ⁻¹ zero ≅ (Fin n ↣ Fin n)
    fibre-zero-iso = record
      { to = λ { (f , z) → fin-inj-remove₀ f z }
      ; from = λ { g → fin-inj-add g , refl }
      ; iso₁ = λ { (f , p)
                 → unapΣ (inj-eq-h2 (fin-set (suc n))
                         (funext (α f p ))
                         , h1⇒prop (fin-set (suc n) _ _) _ _) }
      ; iso₂ = λ g → inj-eq-h2 (fin-set n) refl }
        where
            α : (f : Fin (suc n) ↣ Fin (suc n))
              → (p : apply f zero ≡ zero)
              → (i : Fin (suc n))
              → apply (fin-inj-add (fin-inj-remove₀ f p)) i
              ≡ apply f i
            α _ p zero = sym p
            α (f , f-inj) p (suc i) = pred-β (f (suc i))
              (λ q → fin-disj _ (f-inj (p · sym q)))

fin-subsets : ∀ {n} → (Fin n → Bool) ≅ Fin (2 ^ n)
fin-subsets = trans≅ (Π-ap-iso refl≅ λ _ → fin2-bool) fin-exp


open import Function using (_∘_)
open import Category.Functor
open import Category.Monad
open import Data.Empty using (⊥; ⊥-elim)
open import Data.Fin as Fin using (Fin; zero; suc)
open import Data.Fin.Props as FinProps using ()
open import Data.Maybe as Maybe using (Maybe; maybe; just; nothing)
open import Data.Nat using (ℕ; zero; suc)
open import Data.Product using (Σ; ∃; _,_; proj₁; proj₂) renaming (_×_ to _∧_)
open import Data.Sum using (_⊎_; inj₁; inj₂; [_,_])
open import Data.Vec as Vec using (Vec; []; _∷_; head; tail)
open import Data.Vec.Equality as VecEq
open import Relation.Nullary using (Dec; yes; no; ¬_)
open import Relation.Binary
open import Relation.Binary.PropositionalEquality as PropEq using (_≡_; _≢_; refl; sym; trans; cong; cong₂; inspect; Reveal_is_; [_])

module Unification.Correctness (Symbol : ℕ -> Set) (decEqSym : ∀ {k} (f g : Symbol k) → Dec (f ≡ g)) where

  open import Unification Symbol decEqSym

  open RawFunctor {{...}}
  open DecSetoid {{...}} using (_≟_)

  private maybeFunctor = Maybe.functor
  private finDecSetoid : ∀ {n} → DecSetoid _ _
          finDecSetoid {n} = FinProps.decSetoid n

  -- * proving correctness of replacement function

  mutual
    -- | proof that var is the identity of replace
    replace-thm₁ : ∀ {n} (t : Term n) → replace var t ≡ t
    replace-thm₁ (var x)    = refl
    replace-thm₁ (con s ts) = cong (con s) (replaceChildren-thm₁ ts)

    -- | proof that var is the identity of replaceChildren
    replaceChildren-thm₁ : ∀ {n k} (ts : Vec (Term n) k) → replaceChildren var ts ≡ ts
    replaceChildren-thm₁ [] = refl
    replaceChildren-thm₁ (t ∷ ts) rewrite replace-thm₁ t = cong (_∷_ _) (replaceChildren-thm₁ ts)

  -- * proving correctness of substitution/replacement composition

  -- | proof that `var ∘ _` is the identity of ◇
  compose-thm₁
    : ∀ {m n l} (f : Fin m → Term n) (r : Fin l → Fin m) (t : Term l)
    → f ◇ (var ∘ r) ≡ f ∘ r
  compose-thm₁ f r t = refl

  mutual
    -- | proof that _◇_ behaves as composition of replacements
    compose-thm₂
      : ∀ {m n l} (f : Fin m → Term n) (g : Fin l → Term m) (t : Term l)
      → replace (f ◇ g) t ≡ replace f (replace g t)
    compose-thm₂ f g (var x) = refl
    compose-thm₂ f g (con s ts) = cong (con s) (composeChildren-thm₂ f g ts)

    -- | proof that _◇_ behaves as composition of replacements
    composeChildren-thm₂
      : ∀ {m n l k} (f : Fin m → Term n) (g : Fin l → Term m) (ts : Vec (Term l) k)
      → replaceChildren (f ◇ g) ts ≡ replaceChildren f (replaceChildren g ts)
    composeChildren-thm₂ f g [] = refl
    composeChildren-thm₂ f g (t ∷ ts) rewrite compose-thm₂ f g t = cong (_∷_ _) (composeChildren-thm₂ f g ts)

  -- * proving correctness of thick and thin

  -- | predecessor function over finite numbers
  pred : ∀ {n} → Fin (suc (suc n)) → Fin (suc n)
  pred  zero   = zero
  pred (suc x) = x

  -- | proof of injectivity of thin
  thin-injective
    : ∀ {n} (x : Fin (suc n)) (y z : Fin n)
    → thin x y ≡ thin x z → y ≡ z
  thin-injective {zero}   zero    ()      _       _
  thin-injective {zero}  (suc _)  ()      _       _
  thin-injective {suc _}  zero    zero    zero    refl = refl
  thin-injective {suc _}  zero    zero   (suc _)  ()
  thin-injective {suc _}  zero   (suc _)  zero    ()
  thin-injective {suc _}  zero   (suc y) (suc .y) refl = refl
  thin-injective {suc _} (suc _)  zero    zero    refl = refl
  thin-injective {suc _} (suc _)  zero   (suc _)  ()
  thin-injective {suc _} (suc _) (suc _)  zero    ()
  thin-injective {suc n} (suc x) (suc y) (suc z)  p
    = cong suc (thin-injective x y z (cong pred p))

  -- | proof that thin x will never map anything to x
  thinxy≢x
    : ∀ {n} (x : Fin (suc n)) (y : Fin n)
    → thin x y ≢ x
  thinxy≢x  zero    zero   ()
  thinxy≢x  zero   (suc _) ()
  thinxy≢x (suc _)  zero   ()
  thinxy≢x (suc x) (suc y) p
    = thinxy≢x x y (cong pred p)

  -- | proof that `thin x` reaches all y where x ≢ y
  x≢y→thinxz≡y
    : ∀ {n} (x y : Fin (suc n))
    → x ≢ y → ∃ (λ z → thin x z ≡ y)
  x≢y→thinxz≡y          zero     zero 0≢0 with 0≢0 refl
  x≢y→thinxz≡y          zero     zero 0≢0 | ()
  x≢y→thinxz≡y {zero}  (suc ())  _       _
  x≢y→thinxz≡y {zero}   zero    (suc ()) _
  x≢y→thinxz≡y {suc _}  zero    (suc y)  _ = y , refl
  x≢y→thinxz≡y {suc _} (suc x)   zero    _ = zero , refl
  x≢y→thinxz≡y {suc _} (suc x)  (suc y)  sx≢sy
    = (suc (proj₁ prf)) , (lem x y (proj₁ prf) (proj₂ prf))
    where
    x≢y = sx≢sy ∘ cong suc
    prf = x≢y→thinxz≡y x y x≢y
    lem : ∀ {n} (x y : Fin (suc n)) (z : Fin n)
        → thin x z ≡ y → thin (suc x) (suc z) ≡ suc y
    lem  zero    zero              _      ()
    lem  zero    (suc .z)          z      refl = refl
    lem (suc _)  zero              zero   refl = refl
    lem (suc _)  zero             (suc _) ()
    lem (suc _) (suc _)            zero   ()
    lem (suc x) (suc .(thin x z)) (suc z) refl = refl

  -- | proof that thick x composed with thin x is the identity
  thickx∘thinx≡yes
    : ∀ {n} (x : Fin (suc n)) (y : Fin n)
    → thick x (thin x y) ≡ just y
  thickx∘thinx≡yes  zero    zero   = refl
  thickx∘thinx≡yes  zero   (suc _) = refl
  thickx∘thinx≡yes (suc _)  zero   = refl
  thickx∘thinx≡yes (suc x) (suc y) = cong (_<$>_ suc) (thickx∘thinx≡yes x y)

  -- | proof that `thin` is a partial inverse of `thick`
  thin≡thick⁻¹
    : ∀ {n} (x : Fin (suc n)) (y : Fin n) (z : Fin (suc n))
    → thin x y ≡ z
    → thick x z ≡ just y
  thin≡thick⁻¹ x y z p with p
  thin≡thick⁻¹ x y .(thin x y) _ | refl = thickx∘thinx≡yes x y

  -- | proof that `thick x x` returns nothing
  thickxx≡no
    : ∀ {n} (x : Fin (suc n))
    → thick x x ≡ nothing
  thickxx≡no zero = refl
  thickxx≡no {zero}  (suc ())
  thickxx≡no {suc n} (suc x)
    = cong (maybe (λ x → just (suc x)) nothing) (thickxx≡no x)

  -- | proof that `thick x y` returns something when x ≢ y
  x≢y→thickxy≡yes
    : ∀ {n} (x y : Fin (suc n))
    → x ≢ y → ∃ (λ z → thick x y ≡ just z)
  x≢y→thickxy≡yes zero zero 0≢0 with 0≢0 refl
  x≢y→thickxy≡yes zero zero 0≢0 | ()
  x≢y→thickxy≡yes zero (suc y) p = y , refl
  x≢y→thickxy≡yes {zero}  (suc ())  _ _
  x≢y→thickxy≡yes {suc n} (suc x) zero _ = zero , refl
  x≢y→thickxy≡yes {suc n} (suc x) (suc y) sx≢sy
    = (suc (proj₁ prf)) , (cong (_<$>_ suc) (proj₂ prf))
    where
    x≢y = sx≢sy ∘ cong suc
    prf = x≢y→thickxy≡yes {n} x y x≢y

  -- | proof that `thick` is the partial inverse of `thin`
  thick≡thin⁻¹ : ∀ {n} (x y : Fin (suc n)) (r : Maybe (Fin n))
    → thick x y ≡ r
    → x ≡ y ∧ r ≡ nothing
    ⊎ ∃ (λ z → thin x z ≡ y ∧ r ≡ just z)
  thick≡thin⁻¹ x  y _ thickxy≡r with x ≟ y | thickxy≡r
  thick≡thin⁻¹ x .x .(thick x x) _ | yes refl | refl
    = inj₁ (refl , thickxx≡no x)
  thick≡thin⁻¹ x  y .(thick x y) _ | no  x≢y  | refl
    = inj₂ (proj₁ prf₁ , (proj₂ prf₁) , prf₂)
    where
    prf₁ = x≢y→thinxz≡y x y x≢y
    prf₂ = thin≡thick⁻¹ x (proj₁ prf₁) y (proj₂ prf₁)

  -- | proof that if check returns nothing, checkChildren will too
  check≡no→checkChildren≡no
    : ∀ {n} (x : Fin (suc n)) (s : Symbol (suc n)) (ts : Vec (Term (suc n)) (suc n))
    → check x (con s ts) ≡ nothing → checkChildren x ts ≡ nothing
  check≡no→checkChildren≡no x s ts p with checkChildren x ts
  check≡no→checkChildren≡no x s ts p  | nothing = refl
  check≡no→checkChildren≡no x s ts () | just _

  -- | proof that if check returns something, checkChildren will too
  check≡yes→checkChildren≡yes
    : ∀ {n} (x : Fin (suc n)) (s : Symbol (suc n)) (ts : Vec (Term (suc n)) (suc n)) (ts' : Vec (Term n) (suc n))
    → check x (con s ts) ≡ just (con s ts') → checkChildren x ts ≡ just ts'
  check≡yes→checkChildren≡yes x s ts ts' p with checkChildren x ts
  check≡yes→checkChildren≡yes x s ts ts' refl | just .ts' = refl
  check≡yes→checkChildren≡yes x s ts ts' ()   | nothing

  -- | occurs predicate that is only inhabited if x occurs in t
  mutual
    data Occurs {n : ℕ} (x : Fin n) : Term n → Set where
      Here    : Occurs x (var x)
      Further : ∀ {k ts} {s : Symbol k} → OccursChildren x {k} ts → Occurs x (con s ts)

    data OccursChildren {n : ℕ} (x : Fin n) : {k : ℕ} → Vec (Term n) k → Set where
      Here    : ∀ {k t ts} → Occurs x t → OccursChildren x {suc k} (t ∷ ts)
      Further : ∀ {k t ts} → OccursChildren x {k} ts → OccursChildren x {suc k} (t ∷ ts)

  -- | proof of decidability for the occurs predicate
  mutual
    occurs? : ∀ {n} (x : Fin n) (t : Term n) → Dec (Occurs x t)
    occurs?  x₁ (var x₂) with x₁ ≟ x₂
    occurs? .x₂ (var x₂) | yes refl = yes Here
    occurs?  x₁ (var x₂) | no x₁≢x₂ = no (x₁≢x₂ ∘ lem x₁ x₂)
      where
      lem : ∀ {n} (x y : Fin n) → Occurs x (var y) → x ≡ y
      lem  zero    zero    _    = refl
      lem  zero   (suc _)  ()
      lem (suc x)  zero    ()
      lem (suc x) (suc .x) Here = refl
    occurs?  x₁ (con s ts) with occursChildren? x₁ ts
    occurs?  x₁ (con s ts) | yes x₁∈ts = yes (Further x₁∈ts)
    occurs?  x₁ (con s ts) | no  x₁∉ts = no (x₁∉ts ∘ lem x₁)
      where
      lem : ∀ {n s ts} (x : Fin n) → Occurs x (con s ts) → OccursChildren x ts
      lem x (Further x₂) = x₂

    occursChildren? : ∀ {n k} (x : Fin n) (ts : Vec (Term n) k) → Dec (OccursChildren x ts)
    occursChildren? x₁ [] = no (λ ())
    occursChildren? x₁ (t ∷ ts) with occurs? x₁ t
    occursChildren? x₁ (t ∷ ts) | yes h = yes (Here h)
    occursChildren? x₁ (t ∷ ts) | no ¬h with occursChildren? x₁ ts
    occursChildren? x₁ (t ∷ ts) | no ¬h | yes f = yes (Further f)
    occursChildren? x₁ (t ∷ ts) | no ¬h | no ¬f = no lem
      where
      lem : OccursChildren x₁ (t ∷ ts) → ⊥
      lem (Here p)    = ¬h p
      lem (Further p) = ¬f p

  -- * proving correctness of check

  mutual
    -- | proving that if x occurs in t, check returns nothing
    occurs→check≡no
      : ∀ {n} (x : Fin (suc n)) (t : Term (suc n))
      → Occurs x t → check x t ≡ nothing
    occurs→check≡no x .(Unification.var x) Here
      rewrite thickxx≡no x = refl
    occurs→check≡no x .(Unification.con s ts) (Further {k} {ts} {s} p)
      rewrite occursChildren→checkChildren≡no x ts p = refl

    -- | proving that if x occurs in ts, checkChildren returns nothing
    occursChildren→checkChildren≡no
      : ∀ {n k} (x : Fin (suc n)) (ts : Vec (Term (suc n)) k)
      → OccursChildren x ts → checkChildren x ts ≡ nothing
    occursChildren→checkChildren≡no x .(t ∷ ts) (Here {k} {t} {ts} p)
      rewrite occurs→check≡no x t p = refl
    occursChildren→checkChildren≡no x .(t ∷ ts) (Further {k} {t} {ts} p)
      with check x t
    ... | just  _ rewrite occursChildren→checkChildren≡no x ts p = refl
    ... | nothing rewrite occursChildren→checkChildren≡no x ts p = refl

  mutual
    -- | proof that if check x t returns nothing, x occurs in t
    check≡no→occurs
      : ∀ {n} (x : Fin (suc n)) (t : Term (suc n))
      → check x t ≡ nothing → Occurs x t
    check≡no→occurs  x₁ (var x₂) p with x₁ ≟ x₂
    check≡no→occurs .x₂ (var x₂) p | yes refl = Here
    check≡no→occurs  x₁ (var x₂) p | no x₁≢x₂ = ⊥-elim (lem₂ p)
      where
      lem₁ : ∃ (λ z → thick x₁ x₂ ≡ just z)
      lem₁ = x≢y→thickxy≡yes x₁ x₂ x₁≢x₂
      lem₂ : var <$> thick x₁ x₂ ≡ nothing → ⊥
      lem₂ rewrite proj₂ lem₁ = λ ()
    check≡no→occurs {n} x₁ (con s ts) p
      = Further (checkChildren≡no→occursChildren x₁ ts (lem p))
      where
      lem : con s <$> checkChildren x₁ ts ≡ nothing → checkChildren x₁ ts ≡ nothing
      lem p with checkChildren x₁ ts | inspect (checkChildren x₁) ts
      lem () | just  _ | [ eq ]
      lem p  | nothing | [ eq ] = refl

    -- | proof that if checkChildren x ts returns nothing, x occurs in ts
    checkChildren≡no→occursChildren
      : ∀ {n k} (x : Fin (suc n)) (ts : Vec (Term (suc n)) k)
      → checkChildren x ts ≡ nothing → OccursChildren x ts
    checkChildren≡no→occursChildren x [] ()
    checkChildren≡no→occursChildren x (t ∷ ts) p with check x t | inspect (check x) t
    ... | nothing | [ e₁ ] = Here (check≡no→occurs x t e₁)
    ... | just  _ | [ e₁ ] with checkChildren x ts | inspect (checkChildren x) ts
    ... | nothing | [ e₂ ] = Further (checkChildren≡no→occursChildren x ts e₂)
    checkChildren≡no→occursChildren x (t ∷ ts) () | just _ | [ e₁ ] | just _ | [ e₂ ]

  -- | proof that if check returns just, x does not occur in t
  check≡yes→¬occurs
    : ∀ {n} (x : Fin (suc n)) (t : Term (suc n)) (t' : Term n)
    → check x t ≡ just t' → ¬ (Occurs x t)
  check≡yes→¬occurs x t t' p₁ x∈t with occurs→check≡no x t x∈t
  check≡yes→¬occurs x t t' p₁ _   | p₂  with check x t
  check≡yes→¬occurs x t t' p₁ _   | ()  | just _
  check≡yes→¬occurs x t t' () _   | p₂  | nothing

  -- | proof that x does not occur in t, check returns just
  ¬occurs→check≡yes
    : ∀ {n} (x : Fin (suc n)) (t : Term (suc n))
    → ¬ (Occurs x t) → ∃ (λ t' → check x t ≡ just t')
  ¬occurs→check≡yes x t x∉t with check x t | inspect (check x) t
  ¬occurs→check≡yes x t x∉t | nothing | [ eq ] with x∉t (check≡no→occurs x t eq)
  ¬occurs→check≡yes x t x∉t | nothing | [ eq ] | ()
  ¬occurs→check≡yes x t x∉t | just t' | [ eq ] = t' , refl

  -- * proving correctness of _for_

  -- | proof that if there is nothing to unify, _for_ is the identity
  for-thm₁
    : ∀ {n} (t : Term n) (x : Fin (suc n)) (y : Fin n)
    → (t for x) (thin x y) ≡ var y
  for-thm₁ t x y rewrite thickx∘thinx≡yes x y = refl

  mutual
    -- | proof that if there is something to unify, _for_ unifies
    for-thm₂
      : ∀ {n} (x : Fin (suc n)) (t : Term (suc n)) (t' : Term n)
      → check x t ≡ just t' → replace (t' for x) t ≡ (t' for x) x
    for-thm₂  x (var y) _ _ with x ≟ y
    for-thm₂ .y (var y) _ _ | yes refl = refl
    for-thm₂  x (var y) _ _ | no x≢y
      with thick x y | x≢y→thickxy≡yes x y x≢y
         | thick x x | thickxx≡no x
    for-thm₂  x (var y) .(var z) refl | no _
         | .(just z) | z , refl
         | .nothing  | refl = refl
    for-thm₂  x (con s ts) _ _ with checkChildren x ts | inspect (checkChildren x) ts
    for-thm₂  x (con s ts) _ ()              | nothing  | _
    for-thm₂  x (con s ts) .(con s ts') refl | just ts' | [ checkChildren≡yes ]
      rewrite thickxx≡no x = cong (con s) (forChildren-thm₂ x s ts ts' checkChildren≡yes)

    forChildren-thm₂ : ∀ {n k} -> (x : Fin (suc n)) (s : Symbol k)
     (ts : Vec (Term (suc n)) k) (ts' : Vec (Term n) k) ->
     checkChildren x ts ≡ just ts' ->
     replaceChildren (con s ts' for x) ts ≡ ts'
    forChildren-thm₂ x s [] [] eq rewrite thickxx≡no x = refl
    forChildren-thm₂ x s (t1 ∷ ts) (t2 ∷ ts') eq
      with check x t1 | inspect (check x) t1 | checkChildren x ts |  inspect (checkChildren x) ts
    forChildren-thm₂ x s (t1 ∷ ts) (t2 ∷ ts') refl | just .t2 | [ eq1 ] | just .ts' | [ eq2 ]
      = cong₂ _∷_ {!!} {!!}
      where
      lemma₁ = for-thm₂ x t1 t2 eq1
    forChildren-thm₂ x s (t1 ∷ ts) (t2 ∷ ts') () | just x₁ | _ | nothing | _
    forChildren-thm₂ x s (t1 ∷ ts) (t2 ∷ ts') () | nothing | _ | cs | _

  -- * proving correctness of apply, concat and compose

  ++-thm₁ : ∀ {m n} (s : Subst m n) → nil ++ s ≡ s
  ++-thm₁ nil = refl
  ++-thm₁ (snoc s t x) = cong (λ s → snoc s t x) (++-thm₁ s)

  mutual
    replace-var-id : ∀ {m} (t : Term m) -> replace var t ≡ t
    replace-var-id (Unification.var x) = refl
    replace-var-id (Unification.con s ts) = cong (con s) (replaceChildren-var-id ts)

    replaceChildren-var-id : ∀ {m n} -> (ts : Vec (Term m) n) -> replaceChildren var ts ≡ ts
    replaceChildren-var-id [] = refl
    replaceChildren-var-id (x ∷ ts) = cong₂ _∷_ (replace-var-id x) (replaceChildren-var-id ts)

  mutual

    replace-var-id' : ∀ {n m} (f : Fin n -> Term m) (t : Term n)  ->
      replace (\x -> replace var (f x)) t ≡ replace f t
    replace-var-id' f (Unification.var x) = replace-var-id (f x)
    replace-var-id' f (Unification.con s ts) = cong (con s) (replaceChildren-var-id' f ts)

    replaceChildren-var-id' : ∀ {m n k} -> (f : Fin m -> Term k) (ts : Vec (Term m) n) ->
      replaceChildren (\x -> replace var (f x)) ts ≡ replaceChildren f ts
    replaceChildren-var-id' f [] = refl
    replaceChildren-var-id' f (x ∷ ts) = cong₂ _∷_ (replace-var-id' f x) (replaceChildren-var-id' f ts)

  ++-lem₁ : ∀ {m n} (s : Subst m n) (t : Term (suc m)) (t' : Term m) (x : Fin (suc m)) ->
       replace (apply s) (replace (t' for x) t) ≡ replace (\x' -> replace (apply s) (_for_ t' x x')) t
  ++-lem₁ Unification.nil t t' x
    rewrite replace-var-id (replace (t' for x) t)
    | replace-var-id' (t' for x) t = refl
  ++-lem₁ (Unification.snoc s t x) t₁ t' x₁ = {!!}

  ++-lem₂
    : ∀ {l m n} (s₁ : Subst m n) (s₂ : Subst l m) (t : Term l)
    → replace (apply (s₁ ++ s₂)) t ≡ replace (apply s₁) (replace (apply s₂) t)
  ++-lem₂ s₁ nil t rewrite replace-thm₁ t = refl
  ++-lem₂ {.(suc k)} {m} {n} s₁ (snoc {k} s₂ t₂ x) t = {!!}
    where
    lem = ++-lem₂ s₁ s₂ (replace (t₂ for x) t)

  ++-thm₂
    : ∀ {l m n} (s₁ : Subst m n) (s₂ : Subst l m) (x : Fin l)
    → apply (s₁ ++ s₂) x ≡ (apply s₁ ◇ apply s₂) x
  ++-thm₂ s₁ nil x = refl
  ++-thm₂ s₁ (snoc s₂ t y) x with thick y x
  ++-thm₂ s₁ (snoc s₂ t y) x | just t' = ++-thm₂ s₁ s₂ t'
  ++-thm₂ s₁ (snoc s₂ t y) x | nothing = ++-lem₂ s₁ s₂ t


open import Data.Bool using ( Bool ; true ; false ; if_then_else_ )
open import Data.Empty using ( ⊥-elim )
open import Data.Product using ( _×_ ; _,_ )
open import Data.Sum using ( inj₁ ; inj₂ )
open import Relation.Unary using ( _∈_ ; _∉_ )
open import Web.Semantic.DL.Concept using ( neg )
open import Web.Semantic.DL.Concept.Model using ( _⟦_⟧₁ ; neg-sound )
open import Web.Semantic.DL.Concept.Skolemization using
  ( CSkolems ; cskolem ; cskolem-sound )
open import Web.Semantic.DL.FOL using
  ( Formula ; true ; false ; _∧_ ; _∈₁_ ; _∈₂_ ; _∼_ ; ∀₁ )
open import Web.Semantic.DL.FOL.Model using ( _⊨f_ )
open import Web.Semantic.DL.Role.Skolemization using
  ( rskolem ; rskolem⇒ ; rskolem-sound ; rskolem⇒-sound )
open import Web.Semantic.DL.Role.Model using ( _⟦_⟧₂ )
open import Web.Semantic.DL.Signature using ( Signature )
open import Web.Semantic.DL.TBox using
  ( TBox ; ε ; _,_ ;_⊑₁_ ; _⊑₂_ ; Dis ; Ref ; Irr ; Tra )
open import Web.Semantic.DL.TBox.Model using ( _⊨t_ )
open import Web.Semantic.Util using ( True ; tt )

module Web.Semantic.DL.TBox.Skolemization {Σ : Signature} where

TSkolems : Set → TBox Σ → Set
TSkolems Δ ε = True
TSkolems Δ (T , U) = (TSkolems Δ T) × (TSkolems Δ U)
TSkolems Δ (C ⊑₁ D) = (Δ → Bool) × (CSkolems Δ (neg C)) × (CSkolems Δ D)
TSkolems Δ (Q ⊑₂ R) = True
TSkolems Δ (Dis Q R) = True
TSkolems Δ (Ref R) = True
TSkolems Δ (Irr R) = True
TSkolems Δ (Tra R) = True

tskolem : ∀ {Δ} T → (TSkolems Δ T) → Formula Σ Δ
tskolem ε Φ = true
tskolem (T , U) (Φ , Ψ) = (tskolem T Φ) ∧ (tskolem U Ψ)
tskolem (C ⊑₁ D) (φ , Φ , Ψ) = ∀₁ λ x →
  if (φ x) then (cskolem (neg C) Φ x) else (cskolem D Ψ x)
tskolem (Q ⊑₂ R) Φ = ∀₁ λ x → ∀₁ λ y →
  rskolem⇒ Q x y (rskolem R x y)
tskolem (Dis Q R) Φ = ∀₁ λ x → ∀₁ λ y →
  rskolem⇒ Q x y (rskolem⇒ R x y false)
tskolem (Ref R) Φ = ∀₁ λ x →
  rskolem R x x
tskolem (Irr R) Φ = ∀₁ λ x →
  rskolem⇒ R x x false
tskolem (Tra R) Φ = ∀₁ λ x → ∀₁ λ y → ∀₁ λ z →
  rskolem⇒ R x y (rskolem⇒ R y z (rskolem R x z))

tskolem-sound : ∀ I T Φ → (I ⊨f tskolem T Φ) → (I ⊨t T)
tskolem-sound I ε Φ _ = tt
tskolem-sound I (T , U) (Φ , Ψ) (I⊨T , I⊨U) =
  (tskolem-sound I T Φ I⊨T , tskolem-sound I U Ψ I⊨U)
tskolem-sound I (C ⊑₁ D) (φ , Φ , Ψ) I⊨C⊑D = lemma where
  lemma : ∀ {x} → (x ∈ I ⟦ C ⟧₁) → (x ∈ I ⟦ D ⟧₁)
  lemma {x} x∈⟦C⟧ with φ x | I⊨C⊑D x
  lemma {x} x∈⟦C⟧ | true  | x∈⟦¬C⟧ =
    ⊥-elim (neg-sound I C (cskolem-sound I (neg C) Φ x x∈⟦¬C⟧) x∈⟦C⟧)
  lemma {x} x∈⟦C⟧ | false | x∈⟦D⟧  =
    cskolem-sound I D Ψ x x∈⟦D⟧
tskolem-sound I (Q ⊑₂ R) Φ I⊨Q⊑R = lemma where
  lemma : ∀ {xy} → (xy ∈ I ⟦ Q ⟧₂) → (xy ∈ I ⟦ R ⟧₂)
  lemma {x , y} xy∈⟦Q⟧ =
    rskolem-sound I R x y (rskolem⇒-sound I Q x y _ (I⊨Q⊑R x y) xy∈⟦Q⟧)
tskolem-sound I (Dis Q R) Φ I⊨DisQR = lemma where
  lemma : ∀ {xy} → (xy ∈ I ⟦ Q ⟧₂) → (xy ∉ I ⟦ R ⟧₂)
  lemma {x , y} xy∈⟦Q⟧ =
    rskolem⇒-sound I R x y _ (rskolem⇒-sound I Q x y _ (I⊨DisQR x y) xy∈⟦Q⟧)
tskolem-sound I (Ref R) Φ I⊨RefR = λ x → rskolem-sound I R x x (I⊨RefR x)
tskolem-sound I (Irr R) Φ I⊨IrrR = λ x → rskolem⇒-sound I R x x _ (I⊨IrrR x)
tskolem-sound I (Tra R) Φ I⊨TraR =
  λ {x} {y} {z} xy∈⟦R⟧ yz∈⟦R⟧ → rskolem-sound I R x z
    (rskolem⇒-sound I R y z _ (rskolem⇒-sound I R x y _ (I⊨TraR x y z) xy∈⟦R⟧) yz∈⟦R⟧)


-- Reported by nad, 2018-12-13.
-- The option --no-sized-types should turn off sized types
{-# OPTIONS --no-sized-types #-}

{-# BUILTIN SIZE   Size   #-}
{-# BUILTIN SIZELT Size<_ #-}

record Stream (A : Set) (i : Size) : Set where
  coinductive
  field
    head : A
    tail : {j : Size< i} → Stream A j

open Stream

postulate
  destroy-guardedness : {A : Set} → A → A

repeat : ∀ {A i} → A → Stream A i
repeat x .head = x
repeat x .tail = destroy-guardedness (repeat x)


------------------------------------------------------------------------
-- A delimited continuation monad
------------------------------------------------------------------------

module Category.Monad.Continuation where

open import Category.Applicative
open import Category.Applicative.Indexed
open import Category.Monad
open import Category.Monad.Indexed
open import Category.Monad.Identity

open import Data.Function

------------------------------------------------------------------------
-- Delimited continuation monads

DContT : {I : Set} → (I → Set) → (Set → Set) → IFun I
DContT K M r₂ r₁ a = (a → M (K r₁)) → M (K r₂)

DCont : {I : Set} → (I → Set) → IFun I
DCont K = DContT K Identity

DContTIMonad : ∀ {I} (K : I → Set) {M} →
               RawMonad M → RawIMonad (DContT K M)
DContTIMonad K Mon = record
  { return = λ a k → k a
  ; _>>=_  = λ c f k → c (flip f k)
  }
  where open RawMonad Mon

DContIMonad : ∀ {I} (K : I → Set) → RawIMonad (DCont K)
DContIMonad K = DContTIMonad K IdentityMonad

------------------------------------------------------------------------
-- Delimited continuation operations

record RawIMonadDCont {I : Set} (K : I → Set)
                      (M : I → I → Set → Set) : Set₁ where
  field
    monad : RawIMonad M
    reset : ∀ {r₁ r₂ r₃} → M r₁ r₂ (K r₂) → M r₃ r₃ (K r₁)
    shift : ∀ {a r₁ r₂ r₃ r₄} →
            ((a → M r₁ r₁ (K r₂)) → M r₃ r₄ (K r₄)) → M r₃ r₂ a

  open RawIMonad monad public

DContTIMonadDCont : ∀ {I} (K : I → Set) {M} →
                    RawMonad M → RawIMonadDCont K (DContT K M)
DContTIMonadDCont K Mon = record
  { monad = DContTIMonad K Mon
  ; reset = λ e k → e return >>= k
  ; shift = λ e k → e (λ a k' → (k a) >>= k') return
  }
  where
  open RawIMonad Mon

DContIMonadDCont : ∀ {I} (K : I → Set) → RawIMonadDCont K (DCont K)
DContIMonadDCont K = DContTIMonadDCont K IdentityMonad


module Star where

data Star {A : Set}(R : A -> A -> Set) : A -> A -> Set where
  rf   : {x : A} -> Star R x x
  _<>_ : forall {x y z} -> R x y -> Star R y z -> Star R x z


{-# OPTIONS --universe-polymorphism #-}
module Categories.Monoidal.Braided where

open import Level
open import Level using (_⊔_)

open import Categories.Category

open import Categories.Bifunctor using (Bifunctor)
open import Categories.NaturalIsomorphism
open import Categories.NaturalTransformation using (_∘₁_) renaming (_≡_ to _≡ⁿ_)

open import Categories.Monoidal.Helpers
open import Categories.Monoidal.Braided.Helpers

open import Categories.Monoidal

record Braided {o ℓ e} {C : Category o ℓ e} (M : Monoidal C) : Set (o ⊔ ℓ ⊔ e) where
  private module C = Category C
  private module M = Monoidal M
  open C hiding (id; identityˡ; identityʳ; assoc)
  open M

  open MonoidalHelperFunctors C ⊗ id
  open BraidedHelperFunctors C ⊗ id

  field
    braid : NaturalIsomorphism x⊗y y⊗x

  open Braiding identityˡ identityʳ assoc braid

  field
    -- NB: Triangle is redundant, proof coming soon...
    .hexagon₁ : (Hexagon1SideB ∘₁ (Hexagon1TopB ∘₁ Hexagon1TopA)) ≡ⁿ (Hexagon1BottomB ∘₁ (Hexagon1BottomA ∘₁ Hexagon1SideA))
    .hexagon₂ : (Hexagon2SideB ∘₁ (Hexagon2TopB ∘₁ Hexagon2TopA)) ≡ⁿ (Hexagon2BottomB ∘₁ (Hexagon2BottomA ∘₁ Hexagon2SideA))


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

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

-- This module defines the types used to define a SystemModel.

module LibraBFT.Yasm.Base
  (ℓ-EC        : Level)
  (EpochConfig : Set ℓ-EC)
  (epochId     : EpochConfig → ℕ)
  (authorsN    : EpochConfig → ℕ)
 where

 EpochId : Set
 EpochId = ℕ

 Member : EpochConfig → Set
 Member = Fin ∘ authorsN

 record EpochConfigFor (eid : EpochId) : Set ℓ-EC where
   field
    epochConfig : EpochConfig
    forEpochId  : epochId epochConfig ≡ eid

 -- Our system is configured through a value of type
 -- SystemParameters where we specify:
 record SystemParameters : Set (ℓ+1 0ℓ ℓ⊔ ℓ-EC) where
  constructor mkSysParms
  field
    PeerId    : Set
    _≟PeerId_ : ∀ (p₁ p₂ : PeerId) → Dec (p₁ ≡ p₂)
    PeerState : Set
    initPS    : PeerState  -- Represents an uninitialised PeerState, about which we know nothing whatsoever
    Msg       : Set
    Part      : Set -- Types of interest that can be represented in Msgs

    -- The messages must be able to carry signatures
    instance Part-sig : WithSig Part

    -- A relation specifying what Parts are included in a Msg.
    _⊂Msg_       : Part → Msg → Set

    -- Finally, messages must carry an epoch id and might have an author
    part-epoch  : Part → EpochId

    -- Initializes a potentially-empty state with an EpochConfig
    init : PeerId → EpochConfig → PeerState → PeerState × List Msg

    -- Handles a message on a previously initialized peer.
    handle : PeerId → Msg → PeerState → PeerState × List Msg

    -- TODO-3?: So far, handlers only produce messages to be sent.
    -- It would be reasonable to generalize this to something like
    --
    --   data Action = Send Msg | Crash CrashMsg | Log LogMsg | ...
    --
    -- on the system level, and have the handlers return List Action,
    -- rather than just ListMsg.  For example, if an assertion fires, this
    -- could "kill the process" and make it not send any messages in the future.
    -- We could also then prove that the handlers do not crash, certain
    -- messages are logged under certain circumstances, etc.
    --
    -- Alternatively, we could keep this outside the system model by
    -- defining an application-specific peerState type, for example:
    --
    -- > libraHandle : Msg → Status × Log × LState → Status × LState × List Action
    -- > libraHandle _ (Crashed , l , s) = Crashed , s , [] -- i.e., crashed peers never send messages
    -- >
    -- > handle = filter isSend ∘ libraHandle


{-# OPTIONS --cubical-compatible --guardedness #-}
module Common.Coinduction where

open import Agda.Builtin.Coinduction public

private
  my-♯ : ∀ {a} {A : Set a} → A → ∞ A
  my-♯ x = ♯ x


module Eval where

open import Data.Empty
open import Data.Unit
open import Data.Unit.Core
open import Data.Nat renaming (_⊔_ to _⊔ℕ_)
open import Data.Sum renaming (map to _⊎→_)
open import Data.Product renaming (map to _×→_)
open import Data.Vec
open import Relation.Binary.PropositionalEquality

open import FT -- Finite Types

_∘_ = trans

mutual
  evalComb : {a b : FT} → a ⇛ b → ⟦ a ⟧ → ⟦ b ⟧
  evalComb unite₊⇛ (inj₁ ())
  evalComb unite₊⇛ (inj₂ y) = y
  evalComb uniti₊⇛ v = inj₂ v
  evalComb swap₊⇛ (inj₁ x) = inj₂ x
  evalComb swap₊⇛ (inj₂ y) = inj₁ y
  evalComb assocl₊⇛ (inj₁ x) = inj₁ (inj₁ x)
  evalComb assocl₊⇛ (inj₂ (inj₁ x)) = inj₁ (inj₂ x)
  evalComb assocl₊⇛ (inj₂ (inj₂ y)) = inj₂ y
  evalComb assocr₊⇛ (inj₁ (inj₁ x)) = inj₁ x
  evalComb assocr₊⇛ (inj₁ (inj₂ y)) = inj₂ (inj₁ y)
  evalComb assocr₊⇛ (inj₂ y) = inj₂ (inj₂ y)
  evalComb unite⋆⇛ (tt , proj₂) = proj₂
  evalComb uniti⋆⇛ v = tt , v
  evalComb swap⋆⇛ (proj₁ , proj₂) = proj₂ , proj₁
  evalComb assocl⋆⇛ (proj₁ , proj₂ , proj₃) = (proj₁ , proj₂) , proj₃
  evalComb assocr⋆⇛ ((proj₁ , proj₂) , proj₃) = proj₁ , proj₂ , proj₃
  evalComb distz⇛ (() , proj₂)
  evalComb factorz⇛ ()
  evalComb dist⇛ (inj₁ x , proj₂) = inj₁ (x , proj₂)
  evalComb dist⇛ (inj₂ y , proj₂) = inj₂ (y , proj₂)
  evalComb factor⇛ (inj₁ (proj₁ , proj₂)) = inj₁ proj₁ , proj₂
  evalComb factor⇛ (inj₂ (proj₁ , proj₂)) = inj₂ proj₁ , proj₂
  evalComb id⇛ v = v
  evalComb (sym⇛ c) v = evalBComb c v
  evalComb (c₁ ◎ c₂) v = evalComb c₂ (evalComb c₁ v)
  evalComb (c ⊕ c₁) (inj₁ x) = inj₁ (evalComb c x)
  evalComb (c ⊕ c₁) (inj₂ y) = inj₂ (evalComb c₁ y)
  evalComb (c ⊗ c₁) (proj₁ , proj₂) = evalComb c proj₁ , evalComb c₁ proj₂

  evalBComb : {a b : FT} → a ⇛ b → ⟦ b ⟧ → ⟦ a ⟧
  evalBComb unite₊⇛ v = inj₂ v
  evalBComb uniti₊⇛ (inj₁ ())
  evalBComb uniti₊⇛ (inj₂ y) = y
  evalBComb swap₊⇛ (inj₁ x) = inj₂ x
  evalBComb swap₊⇛ (inj₂ y) = inj₁ y
  evalBComb assocl₊⇛ (inj₁ (inj₁ x)) = inj₁ x
  evalBComb assocl₊⇛ (inj₁ (inj₂ y)) = inj₂ (inj₁ y)
  evalBComb assocl₊⇛ (inj₂ y) = inj₂ (inj₂ y)
  evalBComb assocr₊⇛ (inj₁ x) = inj₁ (inj₁ x)
  evalBComb assocr₊⇛ (inj₂ (inj₁ x)) = inj₁ (inj₂ x)
  evalBComb assocr₊⇛ (inj₂ (inj₂ y)) = inj₂ y
  evalBComb unite⋆⇛ x = tt , x
  evalBComb uniti⋆⇛ (tt , x) = x
  evalBComb swap⋆⇛ (x , y) = y , x
  evalBComb assocl⋆⇛ ((x , y) , z) = x , y , z
  evalBComb assocr⋆⇛ (x , y , z) = (x , y) , z
  evalBComb distz⇛ ()
  evalBComb factorz⇛ (() , _)
  evalBComb dist⇛ (inj₁ (proj₁ , proj₂)) = inj₁ proj₁ , proj₂
  evalBComb dist⇛ (inj₂ (proj₁ , proj₂)) = inj₂ proj₁ , proj₂
  evalBComb factor⇛ (inj₁ x , proj₂) = inj₁ (x , proj₂)
  evalBComb factor⇛ (inj₂ y , proj₂) = inj₂ (y , proj₂)
  evalBComb id⇛ x = x
  evalBComb (sym⇛ c) x = evalComb c x
  evalBComb (c ◎ c₁) x = evalBComb c (evalBComb c₁ x)
  evalBComb (c ⊕ c₁) (inj₁ x) = inj₁ (evalBComb c x)
  evalBComb (c ⊕ c₁) (inj₂ y) = inj₂ (evalBComb c₁ y)
  evalBComb (c ⊗ c₁) (proj₁ , proj₂) = evalBComb c proj₁ , evalBComb c₁ proj₂

mutual
  Comb∘BComb : {a b : FT} → (c : a ⇛ b) → ∀ x → evalBComb c (evalComb c x) ≡ x
  Comb∘BComb unite₊⇛ (inj₁ ())
  Comb∘BComb unite₊⇛ (inj₂ y) = refl
  Comb∘BComb uniti₊⇛ x = refl
  Comb∘BComb swap₊⇛ (inj₁ x) = refl
  Comb∘BComb swap₊⇛ (inj₂ y) = refl
  Comb∘BComb assocl₊⇛ (inj₁ x) = refl
  Comb∘BComb assocl₊⇛ (inj₂ (inj₁ x)) = refl
  Comb∘BComb assocl₊⇛ (inj₂ (inj₂ y)) = refl
  Comb∘BComb assocr₊⇛ (inj₁ (inj₁ x)) = refl
  Comb∘BComb assocr₊⇛ (inj₁ (inj₂ y)) = refl
  Comb∘BComb assocr₊⇛ (inj₂ y) = refl
  Comb∘BComb unite⋆⇛ (tt , y) = refl
  Comb∘BComb uniti⋆⇛ x = refl
  Comb∘BComb swap⋆⇛ (x , y) = refl
  Comb∘BComb assocl⋆⇛ (x , y , z) = refl
  Comb∘BComb assocr⋆⇛ ((x , y) , z) = refl
  Comb∘BComb distz⇛ (() , _)
  Comb∘BComb factorz⇛ ()
  Comb∘BComb dist⇛ (inj₁ x , y) = refl
  Comb∘BComb dist⇛ (inj₂ x , y) = refl
  Comb∘BComb factor⇛ (inj₁ (x , y)) = refl
  Comb∘BComb factor⇛ (inj₂ (x , y)) = refl
  Comb∘BComb id⇛ x = refl
  Comb∘BComb (sym⇛ c) x = BComb∘Comb c x
  Comb∘BComb (c₀ ◎ c₁) x =
    cong (evalBComb c₀)  (Comb∘BComb c₁ (evalComb c₀ x)) ∘ Comb∘BComb c₀ x
  Comb∘BComb (c₀ ⊕ c₁) (inj₁ x) = cong inj₁ (Comb∘BComb c₀ x)
  Comb∘BComb (c₀ ⊕ c₁) (inj₂ y) = cong inj₂ (Comb∘BComb c₁ y)
  Comb∘BComb (c₀ ⊗ c₁) (x , y) = cong₂ _,_ (Comb∘BComb c₀ x) (Comb∘BComb c₁ y)

  BComb∘Comb : {a b : FT} → (c : a ⇛ b) → ∀ x → evalComb c (evalBComb c x) ≡ x
  BComb∘Comb unite₊⇛ x = refl
  BComb∘Comb uniti₊⇛ (inj₁ ())
  BComb∘Comb uniti₊⇛ (inj₂ y) = refl
  BComb∘Comb swap₊⇛ (inj₁ x) = refl
  BComb∘Comb swap₊⇛ (inj₂ y) = refl
  BComb∘Comb assocl₊⇛ (inj₁ (inj₁ x)) = refl
  BComb∘Comb assocl₊⇛ (inj₁ (inj₂ y)) = refl
  BComb∘Comb assocl₊⇛ (inj₂ y) = refl
  BComb∘Comb assocr₊⇛ (inj₁ x) = refl
  BComb∘Comb assocr₊⇛ (inj₂ (inj₁ x)) = refl
  BComb∘Comb assocr₊⇛ (inj₂ (inj₂ y)) = refl
  BComb∘Comb unite⋆⇛ x = refl
  BComb∘Comb uniti⋆⇛ (tt , proj₂) = refl
  BComb∘Comb swap⋆⇛ (proj₁ , proj₂) = refl
  BComb∘Comb assocl⋆⇛ ((proj₁ , proj₂) , proj₃) = refl
  BComb∘Comb assocr⋆⇛ (proj₁ , proj₂ , proj₃) = refl
  BComb∘Comb distz⇛ ()
  BComb∘Comb factorz⇛ (() , _)
  BComb∘Comb dist⇛ (inj₁ (proj₁ , proj₂)) = refl
  BComb∘Comb dist⇛ (inj₂ (proj₁ , proj₂)) = refl
  BComb∘Comb factor⇛ (inj₁ x , proj₂) = refl
  BComb∘Comb factor⇛ (inj₂ y , proj₂) = refl
  BComb∘Comb id⇛ x = refl
  BComb∘Comb (sym⇛ c) x = Comb∘BComb c x
  BComb∘Comb (c₀ ◎ c₁) x =
    cong (evalComb c₁) (BComb∘Comb c₀ (evalBComb c₁ x)) ∘ BComb∘Comb c₁ x
  BComb∘Comb (c ⊕ c₁) (inj₁ x) = cong inj₁ (BComb∘Comb c x)
  BComb∘Comb (c ⊕ c₁) (inj₂ y) = cong inj₂ (BComb∘Comb c₁ y)
  BComb∘Comb (c ⊗ c₁) (x , y) = cong₂ _,_ (BComb∘Comb c x) (BComb∘Comb c₁ y)

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

-- evaluate the alternative interpretation; A needs to be a pointed type.
mutual
  evalComb′ : {a b : FT} {A : Set} {pt : A} → a ⇛ b → ⟦ a ⟧′ A → ⟦ b ⟧′ A
  evalComb′ unite₊⇛ (inj₁ ())
  evalComb′ unite₊⇛ (inj₂ y) = y
  evalComb′ uniti₊⇛ x = inj₂ x
  evalComb′ swap₊⇛ (inj₁ x) = inj₂ x
  evalComb′ swap₊⇛ (inj₂ y) = inj₁ y
  evalComb′ assocl₊⇛ (inj₁ x) = inj₁ (inj₁ x)
  evalComb′ assocl₊⇛ (inj₂ (inj₁ x)) = inj₁ (inj₂ x)
  evalComb′ assocl₊⇛ (inj₂ (inj₂ y)) = inj₂ y
  evalComb′ assocr₊⇛ (inj₁ (inj₁ x)) = inj₁ x
  evalComb′ assocr₊⇛ (inj₁ (inj₂ y)) = inj₂ (inj₁ y)
  evalComb′ assocr₊⇛ (inj₂ y) = inj₂ (inj₂ y)
  evalComb′ unite⋆⇛ (_ , x) = x
  evalComb′ {pt = a} uniti⋆⇛ x = a , x
  evalComb′ swap⋆⇛ (x , y) = y , x
  evalComb′ assocl⋆⇛ (x , y , z) = (x , y) , z
  evalComb′ assocr⋆⇛ ((x , y) , z) = x , y , z
  evalComb′ distz⇛ (() , _)
  evalComb′ factorz⇛ ()
  evalComb′ dist⇛ (inj₁ x , z) = inj₁ (x , z)
  evalComb′ dist⇛ (inj₂ y , z) = inj₂ (y , z)
  evalComb′ factor⇛ (inj₁ (x , y)) = inj₁ x , y
  evalComb′ factor⇛ (inj₂ (x , y)) = inj₂ x , y
  evalComb′ id⇛ x = x
  evalComb′ {pt = a} (sym⇛ c) x = evalBComb′ {pt = a} c x
  evalComb′ {pt = a} (c₀ ◎ c₁) x = evalComb′ {pt = a} c₁ (evalComb′ {pt = a} c₀ x)
  evalComb′ {pt = a} (c₀ ⊕ c₁) (inj₁ x) = inj₁ (evalComb′ {pt = a} c₀ x)
  evalComb′ {pt = a} (c₀ ⊕ c₁) (inj₂ y) = inj₂ (evalComb′ {pt = a} c₁ y)
  evalComb′ {pt = a} (c₀ ⊗ c₁) (x , y) = evalComb′ {pt = a} c₀ x , evalComb′ {pt = a} c₁ y

  evalBComb′ : {a b : FT} {A : Set} {pt : A} → a ⇛ b → ⟦ b ⟧′ A → ⟦ a ⟧′ A
  evalBComb′ unite₊⇛ x = inj₂ x
  evalBComb′ uniti₊⇛ (inj₁ ())
  evalBComb′ uniti₊⇛ (inj₂ y) = y
  evalBComb′ swap₊⇛ (inj₁ x) = inj₂ x
  evalBComb′ swap₊⇛ (inj₂ y) = inj₁ y
  evalBComb′ assocl₊⇛ (inj₁ (inj₁ x)) = inj₁ x
  evalBComb′ assocl₊⇛ (inj₁ (inj₂ y)) = inj₂ (inj₁ y)
  evalBComb′ assocl₊⇛ (inj₂ y) = inj₂ (inj₂ y)
  evalBComb′ assocr₊⇛ (inj₁ x) = inj₁ (inj₁ x)
  evalBComb′ assocr₊⇛ (inj₂ (inj₁ x)) = inj₁ (inj₂ x)
  evalBComb′ assocr₊⇛ (inj₂ (inj₂ y)) = inj₂ y
  evalBComb′ {pt = a} unite⋆⇛ x = a , x
  evalBComb′ uniti⋆⇛ (_ , y) = y
  evalBComb′ swap⋆⇛ (x , y) = y , x
  evalBComb′ assocl⋆⇛ ((x , y) , z) = x , y , z
  evalBComb′ assocr⋆⇛ (x , y , z) = (x , y) , z
  evalBComb′ distz⇛ ()
  evalBComb′ factorz⇛ (() , _)
  evalBComb′ dist⇛ (inj₁ (x , y)) = inj₁ x , y
  evalBComb′ dist⇛ (inj₂ (x , y)) = inj₂ x , y
  evalBComb′ factor⇛ (inj₁ x , z) = inj₁ (x , z)
  evalBComb′ factor⇛ (inj₂ y , z) = inj₂ (y , z)
  evalBComb′ id⇛ x = x
  evalBComb′ {pt = a} (sym⇛ c) x = evalComb′ {pt = a} c x
  evalBComb′ {pt = a} (c₀ ◎ c₁) x = evalBComb′ {pt = a} c₀ (evalBComb′ {pt = a} c₁ x)
  evalBComb′ {pt = a} (c₀ ⊕ c₁) (inj₁ x) = inj₁ (evalBComb′ {pt = a} c₀ x)
  evalBComb′ {pt = a} (c₀ ⊕ c₁) (inj₂ y) = inj₂ (evalBComb′ {pt = a} c₁ y)
  evalBComb′ {pt = a} (c₀ ⊗ c₁) (x , y) = evalBComb′ {pt = a} c₀ x , evalBComb′ {pt = a} c₁ y

---

SWAP12 SWAP23 SWAP13 : PLUS ONE (PLUS ONE ONE) ⇛ PLUS ONE (PLUS ONE ONE)
SWAP12 = assocl₊⇛ ◎ (swap₊⇛ ⊕ id⇛) ◎ assocr₊⇛
SWAP23 = id⇛ ⊕ swap₊⇛
SWAP13 = SWAP23 ◎ SWAP12 ◎ SWAP23

x121 = evalComb SWAP12 (inj₁ tt)         -- 0 -> 1
x122 = evalComb SWAP12 (inj₂ (inj₁ tt))  -- 1 -> 0
x123 = evalComb SWAP12 (inj₂ (inj₂ tt))  -- 2 -> 2

x231 = evalComb SWAP23 (inj₁ tt)         -- 0 -> 0
x232 = evalComb SWAP23 (inj₂ (inj₁ tt))  -- 1 -> 2
x233 = evalComb SWAP23 (inj₂ (inj₂ tt))  -- 2 -> 1

x131 = evalComb SWAP13 (inj₁ tt)         -- 0 -> 2
x132 = evalComb SWAP13 (inj₂ (inj₁ tt))  -- 1 -> 1
x133 = evalComb SWAP13 (inj₂ (inj₂ tt))  -- 2 -> 0


module Lib where
open import Data.List
open import Relation.Binary.PropositionalEquality

data _∧_ (A : Set) (B : Set) : Set where
  ∧-intro : A → B → (A ∧ B)

--------------------------------
-- Extension with Pairs and Sums
--------------------------------

--------------------------------
-- Basic Set-up
--------------------------------
record Sg  (S : Set) (T : S → Set) : Set where
  constructor _,_
  field
    ffst : S
    ssnd : T ffst
open Sg public

--pair type on the agda level
_*_ : Set → Set → Set
S * T = Sg S \ _ → T
--proj functions on the agda level
fst : {A B : Set} → A * B → A
fst (a , b) =  a

snd : {A B : Set} → A * B → B
snd (a , b) =  b

--sum type on the agda level
data _⨄_ (A : Set) (B : Set) : Set where
  tl : (a : A) → A ⨄ B
  tr : (b : B) → A ⨄ B

--typeofSum : ∀ {A B : Set} (sum : A ⨄ B) → Set
--typeofSum {A = A} (tl _) = A
--typeofSum {B = B} (tr _) = B

-- Pointer into a list. It is similar to list membership as defined in
-- Data.List.AnyMembership, rather than going through propositional
-- equality, it asserts the existence of the referenced element
-- directly.
module ListReference where
  infix 4 _∈_
  data _∈_ {A : Set} : A → List A → Set where
    hd : ∀ {x xs} → x ∈ (x ∷ xs)
    tl : ∀ {x y xs} → x ∈ xs → x ∈ (y ∷ xs)
open ListReference public

mapIdx : {A B : Set} → (f : A → B) →
         {x : A} {xs : List A} → x ∈ xs → f x ∈ map f xs
mapIdx f hd = hd
mapIdx f (tl x₁) = tl (mapIdx f x₁)

-- Extension of lists at the front and, as a generalization, extension
-- of lists somewhere in the middle.
module ListExtension where
  open import Relation.Binary.PropositionalEquality

  -- Extension of a list by consing elements at the front.
  data _↝_ {A : Set} : List A → List A → Set where
    ↝-refl   : ∀ {Γ}      → Γ ↝ Γ
    ↝-extend : ∀ {Γ Γ' τ} → Γ ↝ Γ' → Γ ↝ (τ ∷ Γ')

  -- Combining two transitive extensions.
  ↝-trans : ∀ {A : Set}{Γ Γ' Γ'' : List A} → Γ ↝ Γ' → Γ' ↝ Γ'' → Γ ↝ Γ''
  ↝-trans Γ↝Γ' ↝-refl = Γ↝Γ'
  ↝-trans Γ↝Γ' (↝-extend Γ'↝Γ'') = ↝-extend (↝-trans Γ↝Γ' Γ'↝Γ'')

  -- Of course, ↝-refl is the identity for combining two extensions.
  lem-↝-refl-id : ∀ {A : Set} {Γ Γ' : List A} →
                    (Γ↝Γ' : Γ ↝ Γ') →
                    Γ↝Γ' ≡ (↝-trans ↝-refl Γ↝Γ')
  lem-↝-refl-id ↝-refl = refl
  lem-↝-refl-id (↝-extend Γ↝Γ') = cong ↝-extend (lem-↝-refl-id Γ↝Γ')

  -- Extending a list in the middle:
  data _↝_↝_ {A : Set} : List A → List A → List A → Set where
    -- First prepend the extension list to the common suffix
    ↝↝-base   : ∀ {Γ Γ''} → Γ ↝ Γ'' → Γ ↝ [] ↝ Γ''
    -- ... and then add the common prefix
    ↝↝-extend : ∀ {Γ Γ' Γ'' τ} →
                 Γ ↝ Γ' ↝ Γ'' → (τ ∷ Γ) ↝ (τ ∷ Γ') ↝ (τ ∷ Γ'')
open ListExtension public

    ---------------------------------
    -- helper functions for rewriting
    ---------------------------------
→tl : ∀ {A B x' y'} (x y : A ⨄ B)→ x ≡ y →  x ≡ tl x' → y ≡ tl y' → x' ≡ y'
→tl {x' = x'} px py a b c rewrite b | c with py | a
... | H | refl = refl
-- →tl {α} {α'} {.y'} {y'} px py a b c | refl | ._ | refl | ._ | refl = ? -- rewrite b | c = {!!}

→tr : ∀ {A B x' y'} (x y : A ⨄ B)→ x ≡ y →  x ≡ tr x' → y ≡ tr y' → x' ≡ y'
→tr px py a b c rewrite c | b with px | a
... | H | refl = refl
    ---------------------------------


module VecReplicate where

open import Prelude

replicate : forall {A} -> (n : Nat) -> A -> Vec A n
replicate count x = {!!}


{-# OPTIONS --cubical --no-import-sorts --safe #-}
module Cubical.Reflection.StrictEquiv where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Function
open import Cubical.Foundations.Equiv.Base
open import Cubical.Foundations.Isomorphism

open import Cubical.Data.List.Base
open import Cubical.Data.Unit.Base

import Agda.Builtin.Reflection as R
open import Cubical.Reflection.Base

strictEquivClauses : R.Term → R.Term → List R.Clause
strictEquivClauses f g =
  R.clause []
    (R.proj (quote fst) v∷ [])
    f
  ∷ R.clause []
    (R.proj (quote snd) v∷ R.proj (quote equiv-proof) v∷ [])
    (R.def (quote strictContrFibers) (g v∷ []))
  ∷ []

strictEquivTerm : R.Term → R.Term → R.Term
strictEquivTerm f g = R.pat-lam (strictEquivClauses f g) []

strictEquivMacro : ∀ {ℓ ℓ'} {A : Type ℓ} {B : Type ℓ'}
  → (A → B) → (B → A) → R.Term → R.TC Unit
strictEquivMacro {A = A} {B} f g hole =
  R.quoteTC (A ≃ B) >>= λ equivTy →
  R.checkType hole equivTy >>
  R.quoteTC f >>= λ `f` →
  R.quoteTC g >>= λ `g` →
  R.unify (strictEquivTerm `f` `g`) hole

strictIsoToEquivMacro : ∀ {ℓ ℓ'} {A : Type ℓ} {B : Type ℓ'}
  → Iso A B → R.Term → R.TC Unit
strictIsoToEquivMacro isom =
  strictEquivMacro (Iso.fun isom) (Iso.inv isom)

-- For use with unquoteDef

defStrictEquiv : ∀ {ℓ ℓ'} {A : Type ℓ} {B : Type ℓ'}
  → R.Name → (A → B) → (B → A) → R.TC Unit
defStrictEquiv idName f g =
  R.quoteTC f >>= λ `f` →
  R.quoteTC g >>= λ `g` →
  R.defineFun idName (strictEquivClauses `f` `g`)

defStrictIsoToEquiv : ∀ {ℓ ℓ'} {A : Type ℓ} {B : Type ℓ'}
  → R.Name → Iso A B → R.TC Unit
defStrictIsoToEquiv idName isom =
  defStrictEquiv idName (Iso.fun isom) (Iso.inv isom)

-- For use with unquoteDef

declStrictEquiv : ∀ {ℓ ℓ'} {A : Type ℓ} {B : Type ℓ'}
  → R.Name → (A → B) → (B → A) → R.TC Unit
declStrictEquiv {A = A} {B = B} idName f g =
  R.quoteTC (A ≃ B) >>= λ ty →
  R.declareDef (varg idName) ty >>
  defStrictEquiv idName f g

declStrictIsoToEquiv : ∀ {ℓ ℓ'} {A : Type ℓ} {B : Type ℓ'}
  → R.Name → Iso A B → R.TC Unit
declStrictIsoToEquiv idName isom =
  declStrictEquiv idName (Iso.fun isom) (Iso.inv isom)

macro
  -- (f : A → B) → (g : B → A) → (A ≃ B)
  -- Assumes that `f` and `g` are inverse up to definitional equality
  strictEquiv : ∀ {ℓ ℓ'} {A : Type ℓ} {B : Type ℓ'}
    → (A → B) → (B → A) → R.Term → R.TC Unit
  strictEquiv = strictEquivMacro

  -- (isom : Iso A B) → (A ≃ B)
  -- Assumes that the functions defining `isom` are inverse up to definitional equality
  strictIsoToEquiv : ∀ {ℓ ℓ'} {A : Type ℓ} {B : Type ℓ'}
    → Iso A B → R.Term → R.TC Unit
  strictIsoToEquiv = strictIsoToEquivMacro


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

module Data.Unit.UniversePolymorphic where

open import Level

record ⊤ {ℓ} : Type ℓ where instance constructor tt


------------------------------------------------------------------------
-- Code related to the delay monad
--
-- Nils Anders Danielsson
------------------------------------------------------------------------

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

module README where

-- The concept referred to as the delay monad here is the monad
-- presented by Capretta in "General Recursion via Coinductive Types".

------------------------------------------------------------------------
-- The delay monad

-- The delay monad, defined coinductively.

import Delay-monad

-- A type used to index a combined definition of strong and weak
-- bisimilarity and expansion.

import Delay-monad.Bisimilarity.Kind

-- A combined definition of strong and weak bisimilarity and
-- expansion, along with various properties.

import Delay-monad.Bisimilarity

-- Strong bisimilarity for partially defined values, along with a
-- proof showing that this relation is pointwise isomorphic to path
-- equality.

import Delay-monad.Bisimilarity.For-all-sizes

-- A variant of weak bisimilarity that can be used to relate the
-- number of steps in two computations.

import Delay-monad.Quantitative-weak-bisimilarity

-- Termination.

import Delay-monad.Termination

-- Alternative definitions of weak bisimilarity.

import Delay-monad.Bisimilarity.Alternative

-- An observation about weak bisimilarity.

import Delay-monad.Bisimilarity.Observation

-- Some negative results related to weak bisimilarity and expansion.

import Delay-monad.Bisimilarity.Negative

-- An example showing that transitivity-like proofs that are not
-- size-preserving can sometimes be used in a compositional way.

import Delay-monad.Bisimilarity.Transitivity-constructor

-- A partial order.

import Delay-monad.Partial-order

-- Least upper bounds.

import Delay-monad.Least-upper-bound

-- The delay monad is a monad up to strong bisimilarity.

import Delay-monad.Monad

-- The "always true" predicate, □.

import Delay-monad.Always

-- A combinator for running two (independent) computations in
-- sequence.

import Delay-monad.Sequential

-- A combinator for running two computations in parallel.

import Delay-monad.Parallel

------------------------------------------------------------------------
-- A variant of the delay monad with a sized type parameter

-- The delay monad, defined coinductively, with a sized type
-- parameter.

import Delay-monad.Sized

-- A combined definition of strong and weak bisimilarity and
-- expansion, along with various properties.

import Delay-monad.Sized.Bisimilarity

-- Strong bisimilarity for partially defined values, along with a
-- proof showing that this relation is pointwise isomorphic to path
-- equality.

import Delay-monad.Sized.Bisimilarity.For-all-sizes

-- Termination.

import Delay-monad.Sized.Termination

-- Alternative definitions of weak bisimilarity.

import Delay-monad.Sized.Bisimilarity.Alternative

-- Some negative results related to weak bisimilarity and expansion.

import Delay-monad.Sized.Bisimilarity.Negative

-- A partial order.

import Delay-monad.Sized.Partial-order

-- Least upper bounds.

import Delay-monad.Sized.Least-upper-bound

-- A monad-like structure.

import Delay-monad.Sized.Monad

-- The "always true" predicate, □.

import Delay-monad.Sized.Always


module Test where

import Data.Bits
import Data.Bool
import Data.Char
import Data.Fin
import Data.Integer
import Data.Interval
import Data.List
import Data.Map
import Data.Maybe
import Data.Nat
import Data.Nat.Properties
import Data.Permutation
import Data.PigeonHole
import Data.Rational
import Data.Real.Base
import Data.Real.CReal
import Data.Real.Complete
import Data.Real.Gauge
import Data.Show
import Data.String
import Data.Tuple
import Data.Vec
import Logic.Base
import Logic.ChainReasoning
import Logic.Congruence
import Logic.Equivalence
import Logic.Identity
import Logic.Leibniz
import Logic.Operations
import Logic.Relations
import Logic.Structure.Applicative
import Logic.Structure.Monoid
import Prelude


postulate
  A : Set
  a : A

data D : Set where
  d : D

data E : Set where
  e₀ : E
  e₁ : E → E
  e₂ : E → E → E

_[_] : E → E → E
e₀       [ y ] = y
e₁ x     [ y ] = e₁ x
e₂ x₁ x₂ [ y ] = e₂ (x₁ [ y ]) (x₂ [ y ])

data P : E → Set where
  p₁ : ∀ x₁ x₂ → P x₁ → P x₂ → P (e₂ x₁ x₂)
  p₂ : ∀ x → P (x [ e₁ x ]) → P (e₁ x)
  p₃ : ∀ x → P (e₁ x)

module M (_ : A) where

  record R (A B : Set) : Set where
    field f : A → B

  instance
    r₁ : R D D
    R.f r₁ d = d

open M a

open R ⦃ … ⦄ public

r₂ : R D E
R.f r₂ d = e₀

instance

  r₃ : {A : Set} ⦃ c : R A D ⦄ → R A E
  R.f (r₃ ⦃ c ⦄) x = R.f r₂ (R.f c x)

f′ : {A : Set} ⦃ c : R A D ⦄ → A → E
f′ = f

postulate
  p : {A : Set} ⦃ c : R A D ⦄ (x : A) → P (f′ x)

rejected : P (e₂ (e₁ e₀) (f d))
rejected = p₁ _ (f′ d) (p₂ _ (p₃ e₀)) (p d)


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

module _ where

postulate
  Functor : (Set → Set) → Set₁
  fmap : {F : Set → Set} {{_ : Functor F}} {A B : Set} → (A → B) → F A → F B

postulate
  Id : Set → Set

bla : {A : Set} → Id A → Id A
bla = fmap {{?}} (λ x → x) -- should not fail!