module Types.IND1 where

open import Data.Nat
open import Data.Fin hiding (_+_)
open import Data.Product

open import Function

open import Relation.Binary.PropositionalEquality hiding (Extensionality)

open import Types.Direction
open import Auxiliary.Extensionality
open import Auxiliary.RewriteLemmas

private
  variable
    m n : ℕ

----------------------------------------------------------------------
-- session type inductively with explicit rec
-- without polarized variables

mutual
  data Type n : Set where
    TUnit TInt : Type n
    TPair : (T₁ : Type n) (T₂ : Type n) → Type n
    TChan : (S : SType n) → Type n

  data SType n : Set where
    gdd : (G : GType n) → SType n
    rec : (G : GType (suc n) ) → SType n
    var : (x : Fin n) → SType n

  data GType n : Set where
    transmit : (d : Dir) (T : Type n) (S : SType n) → GType n
    choice : (d : Dir) (m : ℕ) (alt : Fin m → SType n) → GType n
    end : GType n

TType = Type

-- weakening

weakenS : (n : ℕ) → SType m → SType (m + n)
weakenG : (n : ℕ) → GType m → GType (m + n)
weakenT : (n : ℕ) → TType m → TType (m + n)

weakenS n (gdd gst) = gdd (weakenG n gst)
weakenS n (rec gst) = rec (weakenG n gst)
weakenS n (var x) = var (inject+ n x)

weakenG n (transmit d t s) = transmit d (weakenT n t) (weakenS n s)
weakenG n (choice d m alt) = choice d m (weakenS n ∘ alt)
weakenG n end = end

weakenT n TUnit = TUnit
weakenT n TInt = TInt
weakenT n (TPair ty ty₁) = TPair (weakenT n ty) (weakenT n ty₁)
weakenT n (TChan x) = TChan (weakenS n x)

weaken1 : SType m → SType (suc m)
weaken1{m} stm with weakenS 1 stm
... | r rewrite n+1=suc-n {m} = r

module CheckWeaken where
  s0 : SType 0
  s0 = rec (transmit SND TUnit (var zero))
  s1 : SType 1
  s1 = rec (transmit SND TUnit (var zero))
  s2 : SType 2
  s2 = rec (transmit SND TUnit (var zero))

  check-weakenS1 : weakenS 1 s0 ≡ s1
  check-weakenS1 = cong rec (cong (transmit SND TUnit) refl)

  check-weakenS2 : weakenS 2 s0 ≡ s2
  check-weakenS2 = cong rec (cong (transmit SND TUnit) refl)

weaken1'N : Fin (suc n) → Fin n → Fin (suc n)
weaken1'N zero x = suc x
weaken1'N (suc i) zero = zero
weaken1'N (suc i) (suc x) = suc (weaken1'N i x)

weaken1'S : Fin (suc n) → SType n → SType (suc n)
weaken1'G : Fin (suc n) → GType n → GType (suc n)
weaken1'T : Fin (suc n) → TType n → TType (suc n)

weaken1'S i (gdd gst) = gdd (weaken1'G i gst)
weaken1'S i (rec gst) = rec (weaken1'G (suc i) gst)
weaken1'S i (var x) = var (weaken1'N i x)

weaken1'G i (transmit d t s) = transmit d (weaken1'T i t) (weaken1'S i s)
weaken1'G i (choice d m alt) = choice d m (weaken1'S i ∘ alt)
weaken1'G i end = end

weaken1'T i TUnit = TUnit
weaken1'T i TInt = TInt
weaken1'T i (TPair t₁ t₂) = TPair (weaken1'T i t₁) (weaken1'T i t₂)
weaken1'T i (TChan x) = TChan (weaken1'S i x)

weaken1S : SType n → SType (suc n)
weaken1G : GType n → GType (suc n)
weaken1T : Type n → Type (suc n)

weaken1S = weaken1'S zero
weaken1G = weaken1'G zero
weaken1T = weaken1'T zero

module CheckWeaken1' where
  sxy : ∀ n → Fin (suc n) → SType n
  sxy n x = rec (transmit SND TUnit (var x))

  s00 : SType 0
  s00 = sxy 0 zero
  s10 : SType 1
  s10 = sxy 1 zero
  s11 : SType 1
  s11 = sxy 1 (suc zero)
  s22 : SType 2
  s22 = sxy 2 (suc (suc zero))

  check-weaken-s01 : weaken1'S zero s00 ≡ s10
  check-weaken-s01 = refl

  check-weaken-s1-s2 : weaken1'S zero s11 ≡ s22
  check-weaken-s1-s2 = refl

  check-weaken-s21 : weaken1'S (suc zero) (sxy 2 (suc zero)) ≡ sxy 3 (suc zero)
  check-weaken-s21 = refl
--------------------------------------------------------------------

weak-weakN : (i : Fin (suc n)) (j : Fin (suc n)) (le : Data.Fin._≤_ j i) (x : Fin n)
  → weaken1'N (suc i) (weaken1'N j x) ≡ weaken1'N (inject₁ j) (weaken1'N i x)
weak-weakG : (i : Fin (suc n)) (j : Fin (suc n)) (le : Data.Fin._≤_ j i) (g : GType n)
  → weaken1'G (suc i) (weaken1'G j g) ≡ weaken1'G (inject₁ j) (weaken1'G i g)
weak-weakS : (i : Fin (suc n)) (j : Fin (suc n)) (le : Data.Fin._≤_ j i) (s : SType n)
  → weaken1'S (suc i) (weaken1'S j s) ≡ weaken1'S (inject₁ j) (weaken1'S i s)
weak-weakT : (i : Fin (suc n)) (j : Fin (suc n)) (le : Data.Fin._≤_ j i) (t : Type n)
  → weaken1'T (suc i) (weaken1'T j t) ≡ weaken1'T (inject₁ j) (weaken1'T i t)

weak-weakN zero zero le x                              = refl
weak-weakN (suc i) zero le x                         = refl
weak-weakN (suc i) (suc j) (s≤s le) zero           = refl
weak-weakN{suc n} (suc i) (suc j) (s≤s le) (suc x) = cong suc (weak-weakN i j le x)

weak-weakG i j le (transmit d t s) = cong₂ (transmit d) (weak-weakT i j le t) (weak-weakS i j le s)
weak-weakG i j le (choice d m alt) = cong (choice d m) (ext (weak-weakS i j le ∘ alt))
weak-weakG i j le end              = refl

weak-weakS i j le (gdd gst) = cong gdd (weak-weakG i j le gst)
weak-weakS i j le (rec gst) = cong rec (weak-weakG (suc i) (suc j) (s≤s le) gst)
weak-weakS i j le (var x) = cong (var) (weak-weakN i j le x)

weak-weakT i j le TUnit        = refl
weak-weakT i j le TInt         = refl
weak-weakT i j le (TPair t t₁) = cong₂ TPair (weak-weakT i j le t) (weak-weakT i j le t₁)
weak-weakT i j le (TChan s)    = cong TChan (weak-weakS i j le s)

weaken1-weakenN : (m : ℕ) (j : Fin (suc n)) (x : Fin n)
  → inject+ m (weaken1'N j x) ≡ weaken1'N (inject+ m j) (inject+ m x)
weaken1-weakenN m zero zero           = refl
weaken1-weakenN m zero (suc x)      = refl
weaken1-weakenN m (suc j) zero      = refl
weaken1-weakenN m (suc j) (suc x) = cong suc (weaken1-weakenN m j x)

weaken1-weakenS : (m : ℕ) (j : Fin (suc n)) (s : SType n)
  → weakenS m (weaken1'S j s) ≡ weaken1'S (inject+ m j) (weakenS m s)
weaken1-weakenG : (m : ℕ) (j : Fin (suc n)) (g : GType n)
  → weakenG m (weaken1'G j g) ≡ weaken1'G (inject+ m j) (weakenG m g)
weaken1-weakenT : (m : ℕ) (j : Fin (suc n)) (t : Type n)
  → weakenT m (weaken1'T j t) ≡ weaken1'T (inject+ m j) (weakenT m t)
weaken1-weakenS m j (gdd gst) = cong gdd (weaken1-weakenG m j gst)
weaken1-weakenS m j (rec gst) = cong rec (weaken1-weakenG m (suc j) gst)
weaken1-weakenS m zero (var zero)      = refl
weaken1-weakenS m zero (var (suc x)) = refl
weaken1-weakenS {suc n} m (suc j) (var zero)      = refl
weaken1-weakenS {suc n} m (suc j) (var (suc x)) = cong (var) (cong suc (weaken1-weakenN m j x))

weaken1-weakenG m j (transmit d t s)  = cong₂ (transmit d) (weaken1-weakenT m j t) (weaken1-weakenS m j s)
weaken1-weakenG m j (choice d m₁ alt) = cong (choice d m₁) (ext (weaken1-weakenS m j ∘ alt))
weaken1-weakenG m j end = refl

weaken1-weakenT m j TUnit = refl
weaken1-weakenT m j TInt = refl
weaken1-weakenT m j (TPair t t₁) = cong₂ TPair (weaken1-weakenT m j t) (weaken1-weakenT m j t₁)
weaken1-weakenT m j (TChan x) = cong TChan (weaken1-weakenS m j x)

--------------------------------------------------------------------
-- substitution

st-substS : SType (suc n) → Fin (suc n) → SType 0 → SType n
st-substG : GType (suc n) → Fin (suc n) → SType 0 → GType n
st-substT : Type (suc n) → Fin (suc n) → SType 0 → Type n

st-substS (gdd gst) i st0 = gdd (st-substG gst i st0)
st-substS (rec gst) i st0 = rec (st-substG gst (suc i) st0)
st-substS {n} (var zero) zero st0 = weakenS n st0
st-substS {suc n} (var zero) (suc i) st0 = var zero
st-substS {suc n} (var (suc x)) zero st0 = var x
st-substS {suc n} (var (suc x)) (suc i) st0 = weaken1S (st-substS (var x) i st0)

st-substG (transmit d t s) i st0 = transmit d (st-substT t i st0) (st-substS s i st0)
st-substG (choice d m alt) i st0 = choice d m (λ j → st-substS (alt j) i st0)
st-substG end i st0 = end

st-substT TUnit i st0 = TUnit
st-substT TInt i st0 = TInt
st-substT (TPair ty ty₁) i st0 = TPair (st-substT ty i st0) (st-substT ty₁ i st0)
st-substT (TChan st) i st0 = TChan (st-substS st i st0)

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

trivial-subst-var : (x : Fin n) (ist₁ ist₂ : SType 0)
  → st-substS (var (suc x)) zero ist₁ ≡ st-substS (var (suc x)) zero ist₂
trivial-subst-var zero ist1 ist2 = refl
trivial-subst-var (suc x) ist1 ist2 = refl

trivial-subst-var' : (i : Fin n) (ist₁ ist₂ : SType 0)
  → st-substS (var zero) (suc i) ist₁ ≡ st-substS (var zero) (suc i) ist₂
trivial-subst-var' zero ist1 ist2 = refl
trivial-subst-var' (suc x) ist1 ist2 = refl

--------------------------------------------------------------------
-- equivalence
variable
  t t₁ t₂ t₁' t₂' : Type n
  s s₁ s₂ : SType n
  g g₁ g₂ : GType n

unfold : SType 0 → GType 0
unfold (gdd gst) = gst
unfold (rec gst) = st-substG gst zero (rec gst)

-- type equivalence
data EquivT (R : SType n → SType n → Set) : Type n → Type n → Set where
  eq-unit : EquivT R TUnit TUnit
  eq-int  : EquivT R TInt TInt
  eq-pair : EquivT R t₁ t₁' → EquivT R t₂ t₂' → EquivT R (TPair t₁ t₂) (TPair t₁' t₂')
  eq-chan : R s₁ s₂ → EquivT R (TChan s₁) (TChan s₂)

-- session type equivalence
data EquivG (R : SType n → SType n → Set) : GType n → GType n → Set where
  eq-transmit : (d : Dir) → EquivT R t₁ t₂ → R s₁ s₂ → EquivG R (transmit d t₁ s₁) (transmit d t₂ s₂)
  eq-choice : ∀ {alt alt'} → (d : Dir) → ((i : Fin m) → R (alt i) (alt' i)) → EquivG R (choice d m alt) (choice d m alt')
  eq-end : EquivG R end end

record Equiv (s₁ s₂ : SType 0) : Set where
  coinductive
  field force : EquivG Equiv (unfold s₁) (unfold s₂)

open Equiv

_≈_ = Equiv
_≈'_ = EquivG Equiv
_≈ᵗ_ = EquivT Equiv

-- reflexive

≈-refl : s ≈ s
≈'-refl : g ≈' g
≈ᵗ-refl : t ≈ᵗ t

force (≈-refl {s}) = ≈'-refl

≈'-refl {transmit d t s} = eq-transmit d ≈ᵗ-refl ≈-refl
≈'-refl {choice d m alt} = eq-choice d (λ i → ≈-refl)
≈'-refl {end} = eq-end

≈ᵗ-refl {TUnit} = eq-unit
≈ᵗ-refl {TInt} = eq-int
≈ᵗ-refl {TPair t t₁} = eq-pair ≈ᵗ-refl ≈ᵗ-refl
≈ᵗ-refl {TChan x} = eq-chan ≈-refl

-- symmetric

≈-symm : s₁ ≈ s₂ → s₂ ≈ s₁
≈'-symm : g₁ ≈' g₂ → g₂ ≈' g₁
≈ᵗ-symm : t₁ ≈ᵗ t₂ → t₂ ≈ᵗ t₁

force (≈-symm s₁≈s₂) = ≈'-symm (force s₁≈s₂)

≈'-symm (eq-transmit d x x₁) = eq-transmit d (≈ᵗ-symm x) (≈-symm x₁)
≈'-symm (eq-choice d x) = eq-choice d (≈-symm ∘ x)
≈'-symm eq-end = eq-end

≈ᵗ-symm eq-unit = eq-unit
≈ᵗ-symm eq-int = eq-int
≈ᵗ-symm (eq-pair t₁≈ᵗt₂ t₁≈ᵗt₃) = eq-pair (≈ᵗ-symm t₁≈ᵗt₂) (≈ᵗ-symm t₁≈ᵗt₃)
≈ᵗ-symm (eq-chan x) = eq-chan (≈-symm x)


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

open import lib.Basics
open import lib.types.Paths
open import lib.types.TwoSemiCategory

module lib.two-semi-categories.Functor where

record TwoSemiFunctor {i₁ j₁ i₂ j₂} (C : TwoSemiCategory i₁ j₁) (D : TwoSemiCategory i₂ j₂)
  : Type (lmax (lmax i₁ j₁) (lmax i₂ j₂)) where
  private
    module C = TwoSemiCategory C
    module D = TwoSemiCategory D
  field
    F₀ : C.El → D.El
    F₁ : {x y : C.El} → C.Arr x y → D.Arr (F₀ x) (F₀ y)
    pres-comp : {x y z : C.El} (f : C.Arr x y) (g : C.Arr y z)
      → F₁ (C.comp f g) == D.comp (F₁ f) (F₁ g)

  pres-comp-coh-seq₁ : {w x y z : C.El} (f : C.Arr w x) (g : C.Arr x y) (h : C.Arr y z)
    → F₁ (C.comp (C.comp f g) h) =-= D.comp (F₁ f) (D.comp (F₁ g) (F₁ h))
  pres-comp-coh-seq₁ f g h =
    F₁ (C.comp (C.comp f g) h)
      =⟪ pres-comp (C.comp f g) h ⟫
    D.comp (F₁ (C.comp f g)) (F₁ h)
      =⟪ ap (λ s → D.comp s (F₁ h)) (pres-comp f g) ⟫
    D.comp (D.comp (F₁ f) (F₁ g)) (F₁ h)
      =⟪ D.assoc (F₁ f) (F₁ g) (F₁ h) ⟫
    D.comp (F₁ f) (D.comp (F₁ g) (F₁ h)) ∎∎

  pres-comp-coh-seq₂ : {w x y z : C.El} (f : C.Arr w x) (g : C.Arr x y) (h : C.Arr y z)
    → F₁ (C.comp (C.comp f g) h) =-= D.comp (F₁ f) (D.comp (F₁ g) (F₁ h))
  pres-comp-coh-seq₂ f g h =
    F₁ (C.comp (C.comp f g) h)
      =⟪ ap F₁ (C.assoc f g h) ⟫
    F₁ (C.comp f (C.comp g h))
      =⟪ pres-comp f (C.comp g h) ⟫
    D.comp (F₁ f) (F₁ (C.comp g h))
      =⟪ ap (D.comp (F₁ f)) (pres-comp g h) ⟫
    D.comp (F₁ f) (D.comp (F₁ g) (F₁ h)) ∎∎

  field
    pres-comp-coh : {w x y z : C.El} (f : C.Arr w x) (g : C.Arr x y) (h : C.Arr y z)
      → pres-comp-coh-seq₁ f g h =ₛ pres-comp-coh-seq₂ f g h

module FunctorComposition
  {i₁ j₁ i₂ j₂ i₃ j₃} {C : TwoSemiCategory i₁ j₁} {D : TwoSemiCategory i₂ j₂} {E : TwoSemiCategory i₃ j₃}
  (F : TwoSemiFunctor C D) (G : TwoSemiFunctor D E) where

  private
    module C = TwoSemiCategory C
    module D = TwoSemiCategory D
    module E = TwoSemiCategory E
    module F = TwoSemiFunctor F
    module G = TwoSemiFunctor G

    F₀ : C.El → E.El
    F₀ = G.F₀ ∘ F.F₀

    F₁ : {x y : C.El} → C.Arr x y → E.Arr (F₀ x) (F₀ y)
    F₁ f = G.F₁ (F.F₁ f)

  pres-comp-seq : {x y z : C.El} (f : C.Arr x y) (g : C.Arr y z)
    → G.F₁ (F.F₁ (C.comp f g)) =-= E.comp (G.F₁ (F.F₁ f)) (G.F₁ (F.F₁ g))
  pres-comp-seq f g =
    G.F₁ (F.F₁ (C.comp f g))
      =⟪ ap G.F₁ (F.pres-comp f g) ⟫
    G.F₁ (D.comp (F.F₁ f) (F.F₁ g))
      =⟪ G.pres-comp (F.F₁ f) (F.F₁ g) ⟫
    E.comp (G.F₁ (F.F₁ f)) (G.F₁ (F.F₁ g)) ∎∎

  abstract
    pres-comp : {x y z : C.El} (f : C.Arr x y) (g : C.Arr y z)
      → G.F₁ (F.F₁ (C.comp f g)) == E.comp (G.F₁ (F.F₁ f)) (G.F₁ (F.F₁ g))
    pres-comp f g = ↯ (pres-comp-seq f g)

    pres-comp-β : {x y z : C.El} (f : C.Arr x y) (g : C.Arr y z)
      → pres-comp f g ◃∎ =ₛ pres-comp-seq f g
    pres-comp-β f g = =ₛ-in idp

  private
    abstract
      pres-comp-coh : {w x y z : C.El} (f : C.Arr w x) (g : C.Arr x y) (h : C.Arr y z)
        → pres-comp (C.comp f g) h ◃∙ ap (λ s → E.comp s (F₁ h)) (pres-comp f g) ◃∙ E.assoc (F₁ f) (F₁ g) (F₁ h) ◃∎
          =ₛ
          ap F₁ (C.assoc f g h) ◃∙ pres-comp f (C.comp g h) ◃∙ ap (E.comp (F₁ f)) (pres-comp g h) ◃∎
      pres-comp-coh f g h =
        pres-comp (C.comp f g) h ◃∙
        ap (λ s → E.comp s (F₁ h)) (pres-comp f g) ◃∙
        E.assoc (F₁ f) (F₁ g) (F₁ h) ◃∎
          =ₛ⟨ 0 & 1 & expand (pres-comp-seq (C.comp f g) h) ⟩
        ap G.F₁ (F.pres-comp (C.comp f g) h) ◃∙
        G.pres-comp (F.F₁ (C.comp f g)) (F.F₁ h) ◃∙
        ap (λ s → E.comp s (F₁ h)) (pres-comp f g) ◃∙
        E.assoc (F₁ f) (F₁ g) (F₁ h) ◃∎
          =ₛ⟨ 2 & 1 & ap-seq-∙ (λ s → E.comp s (F₁ h)) (pres-comp-seq f g) ⟩
        ap G.F₁ (F.pres-comp (C.comp f g) h) ◃∙
        G.pres-comp (F.F₁ (C.comp f g)) (F.F₁ h) ◃∙
        ap (λ s → E.comp s (F₁ h)) (ap G.F₁ (F.pres-comp f g)) ◃∙
        ap (λ s → E.comp s (F₁ h)) (G.pres-comp (F.F₁ f) (F.F₁ g)) ◃∙
        E.assoc (F₁ f) (F₁ g) (F₁ h) ◃∎
          =ₛ₁⟨ 2 & 1 & ∘-ap (λ s → E.comp s (F₁ h)) G.F₁ (F.pres-comp f g) ⟩
        ap G.F₁ (F.pres-comp (C.comp f g) h) ◃∙
        G.pres-comp (F.F₁ (C.comp f g)) (F.F₁ h) ◃∙
        ap (λ s → E.comp (G.F₁ s) (F₁ h)) (F.pres-comp f g) ◃∙
        ap (λ s → E.comp s (F₁ h)) (G.pres-comp (F.F₁ f) (F.F₁ g)) ◃∙
        E.assoc (F₁ f) (F₁ g) (F₁ h) ◃∎
          =ₛ⟨ 1 & 2 & !ₛ $
              homotopy-naturality (λ s → G.F₁ (D.comp s (F.F₁ h)))
                                  (λ s → E.comp (G.F₁ s) (F₁ h))
                                  (λ s → G.pres-comp s (F.F₁ h))
                                  (F.pres-comp f g) ⟩
        ap G.F₁ (F.pres-comp (C.comp f g) h) ◃∙
        ap (λ s → G.F₁ (D.comp s (F.F₁ h))) (F.pres-comp f g) ◃∙
        G.pres-comp (D.comp (F.F₁ f) (F.F₁ g)) (F.F₁ h) ◃∙
        ap (λ s → E.comp s (F₁ h)) (G.pres-comp (F.F₁ f) (F.F₁ g)) ◃∙
        E.assoc (F₁ f) (F₁ g) (F₁ h) ◃∎
          =ₛ⟨ 2 & 3 & G.pres-comp-coh (F.F₁ f) (F.F₁ g) (F.F₁ h) ⟩
        ap G.F₁ (F.pres-comp (C.comp f g) h) ◃∙
        ap (λ s → G.F₁ (D.comp s (F.F₁ h))) (F.pres-comp f g) ◃∙
        ap G.F₁ (D.assoc (F.F₁ f) (F.F₁ g) (F.F₁ h)) ◃∙
        G.pres-comp (F.F₁ f) (D.comp (F.F₁ g) (F.F₁ h)) ◃∙
        ap (E.comp (F₁ f)) (G.pres-comp (F.F₁ g) (F.F₁ h)) ◃∎
          =ₛ₁⟨ 1 & 1 & ap-∘ G.F₁ (λ s → D.comp s (F.F₁ h)) (F.pres-comp f g) ⟩
        ap G.F₁ (F.pres-comp (C.comp f g) h) ◃∙
        ap G.F₁ (ap (λ s → D.comp s (F.F₁ h)) (F.pres-comp f g)) ◃∙
        ap G.F₁ (D.assoc (F.F₁ f) (F.F₁ g) (F.F₁ h)) ◃∙
        G.pres-comp (F.F₁ f) (D.comp (F.F₁ g) (F.F₁ h)) ◃∙
        ap (E.comp (F₁ f)) (G.pres-comp (F.F₁ g) (F.F₁ h)) ◃∎
          =ₛ⟨ 0 & 3 & ap-seq-=ₛ G.F₁ (F.pres-comp-coh f g h) ⟩
        ap G.F₁ (ap F.F₁ (C.assoc f g h)) ◃∙
        ap G.F₁ (F.pres-comp f (C.comp g h)) ◃∙
        ap G.F₁ (ap (D.comp (F.F₁ f)) (F.pres-comp g h)) ◃∙
        G.pres-comp (F.F₁ f) (D.comp (F.F₁ g) (F.F₁ h)) ◃∙
        ap (E.comp (F₁ f)) (G.pres-comp (F.F₁ g) (F.F₁ h)) ◃∎
          =ₛ₁⟨ 2 & 1 & ∘-ap G.F₁ (D.comp (F.F₁ f)) (F.pres-comp g h) ⟩
        ap G.F₁ (ap F.F₁ (C.assoc f g h)) ◃∙
        ap G.F₁ (F.pres-comp f (C.comp g h)) ◃∙
        ap (G.F₁ ∘ D.comp (F.F₁ f)) (F.pres-comp g h) ◃∙
        G.pres-comp (F.F₁ f) (D.comp (F.F₁ g) (F.F₁ h)) ◃∙
        ap (E.comp (F₁ f)) (G.pres-comp (F.F₁ g) (F.F₁ h)) ◃∎
          =ₛ⟨ 2 & 2 &
              homotopy-naturality (G.F₁ ∘ D.comp (F.F₁ f))
                                  (E.comp (F₁ f) ∘ G.F₁)
                                  (G.pres-comp (F.F₁ f))
                                  (F.pres-comp g h) ⟩
        ap G.F₁ (ap F.F₁ (C.assoc f g h)) ◃∙
        ap G.F₁ (F.pres-comp f (C.comp g h)) ◃∙
        G.pres-comp (F.F₁ f) (F.F₁ (C.comp g h)) ◃∙
        ap (λ s → E.comp (F₁ f) (G.F₁ s)) (F.pres-comp g h) ◃∙
        ap (E.comp (F₁ f)) (G.pres-comp (F.F₁ g) (F.F₁ h)) ◃∎
          =ₛ⟨ 1 & 2 & contract ⟩
        ap G.F₁ (ap F.F₁ (C.assoc f g h)) ◃∙
        pres-comp f (C.comp g h) ◃∙
        ap (λ s → E.comp (F₁ f) (G.F₁ s)) (F.pres-comp g h) ◃∙
        ap (E.comp (F₁ f)) (G.pres-comp (F.F₁ g) (F.F₁ h)) ◃∎
          =ₛ₁⟨ 2 & 1 & ap-∘ (E.comp (F₁ f)) G.F₁ (F.pres-comp g h) ⟩
        ap G.F₁ (ap F.F₁ (C.assoc f g h)) ◃∙
        pres-comp f (C.comp g h) ◃∙
        ap (E.comp (F₁ f)) (ap G.F₁ (F.pres-comp g h)) ◃∙
        ap (E.comp (F₁ f)) (G.pres-comp (F.F₁ g) (F.F₁ h)) ◃∎
          =ₛ⟨ 2 & 2 & ∙-ap-seq (E.comp (F₁ f)) (pres-comp-seq g h) ⟩
        ap G.F₁ (ap F.F₁ (C.assoc f g h)) ◃∙
        pres-comp f (C.comp g h) ◃∙
        ap (E.comp (F₁ f)) (pres-comp g h) ◃∎
          =ₛ₁⟨ 0 & 1 & ∘-ap G.F₁ F.F₁ (C.assoc f g h) ⟩
        ap F₁ (C.assoc f g h) ◃∙
        pres-comp f (C.comp g h) ◃∙
        ap (E.comp (F₁ f)) (pres-comp g h) ◃∎ ∎ₛ

  composition : TwoSemiFunctor C E
  composition =
    record
    { F₀ = F₀
    ; F₁ = F₁
    ; pres-comp = pres-comp
    ; pres-comp-coh = pres-comp-coh
    }

open FunctorComposition
  renaming ( composition to comp-functors
           ; pres-comp-seq to comp-functors-pres-comp-seq
           ; pres-comp to comp-functors-pres-comp
           ; pres-comp-β to comp-functors-pres-comp-β
           ) public

infixr 80 _–F→_
_–F→_ = comp-functors


module Issue4869 where

open import Agda.Builtin.Nat

infix 4 _≤_

data _≤_ : Nat → Nat → Set where
  z≤n : ∀ {n} → zero ≤ n
  s≤s : ∀ {m n} (m≤n : m ≤ n) → suc m ≤ suc n

foo : 2 ≤ 1 → Nat
foo (s≤s ()) = 123


module Data.Num.Bij.Properties where

open import Data.Num.Bij renaming (_+B_ to _+_; _*B_ to _*_)

open import Data.List
open import Relation.Binary.PropositionalEquality as PropEq
    using (_≡_; _≢_; refl; cong; sym; trans)
open PropEq.≡-Reasoning

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

1∷≡incrB∘*2 : ∀ m → one ∷ m ≡ incrB (*2 m)
1∷≡incrB∘*2 []         = refl
1∷≡incrB∘*2 (one ∷ ms) = cong (λ x → one ∷ x)       (1∷≡incrB∘*2 ms)
1∷≡incrB∘*2 (two ∷ ms) = cong (λ x → one ∷ incrB x) (1∷≡incrB∘*2 ms)

split-∷ : ∀ m ms → m ∷ ms ≡ (m ∷ []) + *2 ms
split-∷ m [] = refl
split-∷ one (one ∷ ns) = cong (λ x → one ∷ x)       (1∷≡incrB∘*2 ns)
split-∷ one (two ∷ ns) = cong (λ x → one ∷ incrB x) (1∷≡incrB∘*2 ns)
split-∷ two (one ∷ ns) = cong (λ x → two ∷ x)       (1∷≡incrB∘*2 ns)
split-∷ two (two ∷ ns) = cong (λ x → two ∷ incrB x) (1∷≡incrB∘*2 ns)

{-
+B-assoc : ∀ m n o → (m + n) + o ≡ m + (n + o)
+B-assoc []       _ _ = refl
+B-assoc (m ∷ ms) n o =
    begin
        (m ∷ ms) + n + o
    ≡⟨ cong (λ x → x + n + o) (split-∷ m ms) ⟩
        (m ∷ []) + *2 ms + n + o
    ≡⟨ cong (λ x → x + o) (+B-assoc (m ∷ []) (*2 ms) n) ⟩
        (m ∷ []) + (*2 ms + n) + o
    ≡⟨ +B-assoc (m ∷ []) (*2 ms + n) o ⟩
        (m ∷ []) + ((*2 ms + n) + o)
    ≡⟨ cong (λ x → (m ∷ []) + x) (+B-assoc (*2 ms) n o) ⟩
        (m ∷ []) + (*2 ms + (n + o))
    ≡⟨ sym (+B-assoc (m ∷ []) (*2 ms) (n + o))  ⟩
        (m ∷ []) + *2 ms + (n + o)
    ≡⟨ cong (λ x → x + (n + o)) (sym (split-∷ m ms)) ⟩
        (m ∷ ms) + (n + o)
    ∎
+B-right-identity : ∀ n → n + [] ≡ n
+B-right-identity []       = refl
+B-right-identity (n ∷ ns) = refl

+B-comm : ∀ m n → m + n ≡ n + m
+B-comm []       n = sym (+B-right-identity n)
+B-comm (m ∷ ms) n =
    begin
        (m ∷ ms) + n
    ≡⟨ cong (λ x → x + n) (split-∷ m ms) ⟩
        (m ∷ []) + *2 ms + n
    ≡⟨ +B-comm ((m ∷ []) + *2 ms) n ⟩
        n + ((m ∷ []) + *2 ms)
    ≡⟨ cong (λ x → n + x) (sym (split-∷ m ms)) ⟩
        n + (m ∷ ms)
    ∎
{-
    begin
        (m ∷ ms) + n
    ≡⟨ cong (λ x → x + n) (split-∷ m ms) ⟩
        (m ∷ []) + *2 ms + n
    ≡⟨ +B-assoc (m ∷ []) (*2 ms) n ⟩
        (m ∷ []) + (*2 ms + n)
    ≡⟨ cong (λ x → (m ∷ []) + x) (+B-comm (*2 ms) n) ⟩
        (m ∷ []) + (n + *2 ms)
    ≡⟨ sym (+B-assoc (m ∷ []) n (*2 ms)) ⟩
        (m ∷ []) + n + *2 ms
    ≡⟨ cong (λ x → x + *2 ms) (+B-comm (m ∷ []) n) ⟩
        n + (m ∷ []) + *2 ms
    ≡⟨ +B-assoc n (m ∷ []) (*2 ms) ⟩
        n + ((m ∷ []) + *2 ms)
    ≡⟨ cong (λ x → n + x) (sym (split-∷ m ms)) ⟩
        n + (m ∷ ms)
    ∎
-}
+B-*2-distrib : ∀ m n → *2 (m + n) ≡ *2 m + *2 n
+B-*2-distrib []       n = refl
+B-*2-distrib (m ∷ ms) n =
    begin
        *2 ((m ∷ ms) + n)
    ≡⟨ cong (λ x → *2 (x + n)) (split-∷ m ms) ⟩
        *2 ((m ∷ []) + *2 ms + n)
    ≡⟨ +B-*2-distrib ((m ∷ []) + *2 ms) n ⟩
        *2 ((m ∷ []) + *2 ms) + *2 n
    ≡⟨ cong (λ x → *2 x + *2 n) (sym (split-∷ m ms)) ⟩
        *2 (m ∷ ms) + *2 n
    ∎

+B-*B-incrB : ∀ m n → m * incrB n ≡ m + m * n
+B-*B-incrB []         n = refl
+B-*B-incrB (m ∷ ms) n =
    begin
        (m ∷ ms) * incrB n
    ≡⟨ cong (λ x → x * incrB n) (split-∷ m ms) ⟩
        ((m ∷ []) + *2 ms) * incrB n
    ≡⟨ +B-*B-incrB ((m ∷ []) + *2 ms) n ⟩
        (m ∷ []) + *2 ms + ((m ∷ []) + *2 ms) * n
    ≡⟨ cong (λ x → x + x * n) (sym (split-∷ m ms)) ⟩
        (m ∷ ms) + (m ∷ ms) * n
    ∎

*B-right-[] : ∀ n → n * [] ≡ []
*B-right-[] [] = refl
*B-right-[] (one ∷ ns) = cong *2_ (*B-right-[] ns)
*B-right-[] (two ∷ ns) = cong *2_ (*B-right-[] ns)

*B-+B-distrib : ∀ m n o → (n + o) * m ≡ n * m + o * m
*B-+B-distrib m []       o = refl
*B-+B-distrib m (n ∷ ns) o =
    begin
        ((n ∷ ns) + o) * m
    ≡⟨ cong (λ x → (x + o) * m) (split-∷ n ns) ⟩
        ((n ∷ []) + *2 ns + o) * m
    ≡⟨ *B-+B-distrib m ((n ∷ []) + *2 ns) o ⟩
        ((n ∷ []) + *2 ns) * m + o * m
    ≡⟨ cong (λ x → x * m + o * m) (sym (split-∷ n ns)) ⟩
        (n ∷ ns) * m + o * m
    ∎

*B-comm : ∀ m n → m * n ≡ n * m
*B-comm []         n = sym (*B-right-[] n)
*B-comm (m ∷ ms) n =
    begin
        (m ∷ ms) * n
    ≡⟨ cong (λ x → x * n) (split-∷ m ms) ⟩
        ((m ∷ []) + *2 ms) * n
    ≡⟨ *B-comm ((m ∷ []) + *2 ms) n ⟩
        n * ((m ∷ []) + *2 ms)
    ≡⟨ cong (λ x → n * x) (sym (split-∷ m ms)) ⟩
        n * (m ∷ ms)
    ∎

{-
    begin
        {!   !}
    ≡⟨ {!   !} ⟩
        {!   !}
    ≡⟨ {!   !} ⟩
        {!   !}
    ≡⟨ {!   !} ⟩
        {!   !}
    ≡⟨ {!   !} ⟩
        {!   !}
    ∎
-}
{-
+B-*B-incrB : ∀ m n → m * incrB n ≡ m + m * n
+B-*B-incrB []         n = refl
+B-*B-incrB (one ∷ ms) [] = {!   !}
+B-*B-incrB (one ∷ ms) (n ∷ ns) = {!   !}
    begin
        incrB n + ms * incrB n
    ≡⟨ cong (λ x → incrB n + x) (+B-*B-incrB ms n) ⟩
        incrB n + (ms + ms * n)
    ≡⟨ sym (+B-assoc (incrB n) ms (ms * n)) ⟩
        incrB n + ms + ms * n
    ≡⟨ {!   !} ⟩
        {!   !}
    ≡⟨ {!   !} ⟩
        {!   !}
    ≡⟨ {!   !} ⟩
        {!   !}
    ≡⟨ {!   !} ⟩
        (one ∷ []) + *2 ms + (n + ms * n)
    ≡⟨ cong (λ x → x + (n + ms * n)) (sym (split-∷ one ms)) ⟩
        (one ∷ ms) + (n + ms * n)
    ∎
+B-*B-incrB (two ∷ ms) n =
    begin
        {!   !}
    ≡⟨ {!   !} ⟩
        {!   !}
    ≡⟨ {!   !} ⟩
        {!   !}
    ≡⟨ {!   !} ⟩
        {!   !}
    ≡⟨ {!   !} ⟩
        {!    !}
    ∎
-}
{-
    begin
        {!   !}
    ≡⟨ {!   !} ⟩
        {!   !}
    ≡⟨ {!   !} ⟩
        {!   !}
    ≡⟨ {!   !} ⟩
        {!   !}
    ≡⟨ {!   !} ⟩
        {!   !}
    ∎
-}
-}


{-# OPTIONS --universe-polymorphism #-}
module tests.Literals where

open import Prelude.Nat
open import Prelude.Float
open import Prelude.Char
open import Prelude.String
open import Prelude.Unit
open import Prelude.IO

afloat : Float
afloat = 1.23

astring : String
astring = "abc"

achar : Char
achar = 'd'

anat : Nat
anat = 123

main : IO Unit
main =
  printFloat  afloat  ,,
  putStr      astring ,,
  printChar   achar   ,,
  printNat    anat    ,,
  putStrLn ""


open import Data.Empty using ( ⊥ )
open import FRP.LTL.RSet.Core using ( RSet )

module FRP.LTL.RSet.Empty where

F : RSet
F t = ⊥


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

-- Finished 6pm Th, March 24! yay!
-- Bit thanks to tzaikin for posting his work online (some of his macros
-- were essential for this proof for me) and to the code we saw in class today.

module EH where

open import Level using (_⊔_)
open import Data.Product using (Σ; _,_)
open import Function renaming (_∘_ to _○_)

infixr 8  _∘_     -- path composition
infixr 8  _⋆_     -- horizontal path composition
infix  4  _≡_     -- propositional equality
infix  4  _∼_     -- homotopy between two functions
infix  4  _≃_     -- type of equivalences
-- macros from tzaikin for equational rewriting over non-standard ≡
infixr 4 _≡⟨_⟩_
infix 4  _∎

------------------------------------------------------------------------------
-- A few HoTT primitives

data _≡_ {ℓ} {A : Set ℓ} : (a b : A) → Set ℓ where
  refl : (a : A) → (a ≡ a)

pathInd : ∀ {u ℓ} → {A : Set u} →
          (C : {x y : A} → x ≡ y → Set ℓ) →
          (c : (x : A) → C (refl x)) →
          ({x y : A} (p : x ≡ y) → C p)
pathInd C c (refl x) = c x

--

! : ∀ {u} → {A : Set u} {x y : A} → (x ≡ y) → (y ≡ x)
! = pathInd (λ {x} {y} _ → y ≡ x) refl

_∘_ : ∀ {u} → {A : Set u} → {x y z : A} → (x ≡ y) → (y ≡ z) → (x ≡ z)
_∘_ {u} {A} {x} {y} {z} p q =
  pathInd {u}
    (λ {x} {y} p → ((z : A) → (q : y ≡ z) → (x ≡ z)))
    (λ x z q → pathInd (λ {x} {z} _ → x ≡ z) refl {x} {z} q)
    {x} {y} p z q

-- Handy "macros" (from tzaikin)
_∎ : {A : Set} → (p : A) → p ≡ p
p ∎ = refl p

_≡⟨_⟩_ : {A : Set} → {q r : A} → (p : A) → p ≡ q → q ≡ r → p ≡ r
p ≡⟨ α ⟩ β = α ∘ β

--

RU : {A : Set} {x y : A} → (p : x ≡ y) → (p ≡ p ∘ refl y)
RU {A} {x} {y} p =
  pathInd
    (λ {x} {y} p → p ≡ p ∘ (refl y))
    (λ x → refl (refl x))
    {x} {y} p

LU : {A : Set} {x y : A} → (p : x ≡ y) → (p ≡ refl x ∘ p)
LU {A} {x} {y} p =
  pathInd
    (λ {x} {y} p → p ≡ (refl x) ∘ p)
    (λ x → refl (refl x))
    {x} {y} p

invTransL : {A : Set} {x y : A} → (p : x ≡ y) → (! p ∘ p ≡ refl y)
invTransL {A} {x} {y} p =
  pathInd
    (λ {x} {y} p → ! p ∘ p ≡ refl y)
    (λ x → refl (refl x))
    {x} {y} p

invTransR : ∀ {ℓ} {A : Set ℓ} {x y : A} → (p : x ≡ y) → (p ∘ ! p ≡ refl x)
invTransR {ℓ} {A} {x} {y} p =
  pathInd
    (λ {x} {y} p → p ∘ ! p ≡ refl x)
    (λ x → refl (refl x))
    {x} {y} p

invId : {A : Set} {x y : A} → (p : x ≡ y) → (! (! p) ≡ p)
invId {A} {x} {y} p =
  pathInd
    (λ {x} {y} p → ! (! p) ≡ p)
    (λ x → refl (refl x))
    {x} {y} p

assocP : {A : Set} {x y z w : A} → (p : x ≡ y) → (q : y ≡ z) → (r : z ≡ w) →
         (p ∘ (q ∘ r) ≡ (p ∘ q) ∘ r)
assocP {A} {x} {y} {z} {w} p q r =
  pathInd
    (λ {x} {y} p → (z : A) → (w : A) → (q : y ≡ z) → (r : z ≡ w) →
      p ∘ (q ∘ r) ≡ (p ∘ q) ∘ r)
    (λ x z w q r →
      pathInd
        (λ {x} {z} q → (w : A) → (r : z ≡ w) →
          (refl x) ∘ (q ∘ r) ≡ ((refl x) ∘ q) ∘ r)
        (λ x w r →
          pathInd
            (λ {x} {w} r →
              (refl x) ∘ ((refl x) ∘ r) ≡
              ((refl x) ∘ (refl x)) ∘ r)
            (λ x → (refl (refl x)))
            {x} {w} r)
        {x} {z} q w r)
    {x} {y} p z w q r

invComp : {A : Set} {x y z : A} → (p : x ≡ y) → (q : y ≡ z) →
          ! (p ∘ q) ≡ ! q ∘ ! p
invComp {A} {x} {y} {z} p q =
  pathInd
    (λ {x} {y} p → (z : A) → (q : y ≡ z) → ! (p ∘ q) ≡ ! q ∘ ! p)
    (λ x z q →
      pathInd
        (λ {x} {z} q → ! (refl x ∘ q) ≡ ! q ∘ ! (refl x))
        (λ x → refl (refl x))
        {x} {z} q)
    {x} {y} p z q

--

ap : ∀ {ℓ ℓ'} → {A : Set ℓ} {B : Set ℓ'} {x y : A} →
     (f : A → B) → (x ≡ y) → (f x ≡ f y)
ap {ℓ} {ℓ'} {A} {B} {x} {y} f p =
  pathInd -- on p
    (λ {x} {y} p → f x ≡ f y)
    (λ x → refl (f x))
    {x} {y} p

apfTrans : ∀ {u} → {A B : Set u} {x y z : A} →
  (f : A → B) → (p : x ≡ y) → (q : y ≡ z) → ap f (p ∘ q) ≡ (ap f p) ∘ (ap f q)
apfTrans {u} {A} {B} {x} {y} {z} f p q =
  pathInd {u}
    (λ {x} {y} p → (z : A) → (q : y ≡ z) →
      ap f (p ∘ q) ≡ (ap f p) ∘ (ap f q))
    (λ x z q →
      pathInd {u}
        (λ {x} {z} q →
          ap f (refl x ∘ q) ≡ (ap f (refl x)) ∘ (ap f q))
        (λ x → refl (refl (f x)))
        {x} {z} q)
    {x} {y} p z q

apfInv : ∀ {u} → {A B : Set u} {x y : A} → (f : A → B) → (p : x ≡ y) →
         ap f (! p) ≡ ! (ap f p)
apfInv {u} {A} {B} {x} {y} f p =
  pathInd {u}
    (λ {x} {y} p → ap f (! p) ≡ ! (ap f p))
    (λ x → refl (ap f (refl x)))
    {x} {y} p

apfComp : {A B C : Set} {x y : A} → (f : A → B) → (g : B → C) → (p : x ≡ y) →
          ap g (ap f p) ≡ ap (g ○ f) p
apfComp {A} {B} {C} {x} {y} f g p =
  pathInd
    (λ {x} {y} p → ap g (ap f p) ≡ ap (g ○ f) p)
    (λ x → refl (ap g (ap f (refl x))))
    {x} {y} p

apfId : {A : Set} {x y : A} → (p : x ≡ y) → ap id p ≡ p
apfId {A} {x} {y} p =
  pathInd
    (λ {x} {y} p → ap id p ≡ p)
    (λ x → refl (refl x))
    {x} {y} p

--

transport : ∀ {ℓ ℓ'} → {A : Set ℓ} {x y : A} →
  (P : A → Set ℓ') → (p : x ≡ y) → P x → P y
transport {ℓ} {ℓ'} {A} {x} {y} P p =
  pathInd -- on p
    (λ {x} {y} p → (P x → P y))
    (λ _ → id)
    {x} {y} p

apd : ∀ {ℓ ℓ'} → {A : Set ℓ} {B : A → Set ℓ'} {x y : A} → (f : (a : A) → B a) →
  (p : x ≡ y) → (transport B p (f x) ≡ f y)
apd {ℓ} {ℓ'} {A} {B} {x} {y} f p =
  pathInd
    (λ {x} {y} p → transport B p (f x) ≡ f y)
    (λ x → refl (f x))
    {x} {y} p

-- Homotopies and equivalences

_∼_ : ∀ {ℓ ℓ'} → {A : Set ℓ} {P : A → Set ℓ'} →
      (f g : (x : A) → P x) → Set (ℓ ⊔ ℓ')
_∼_ {ℓ} {ℓ'} {A} {P} f g = (x : A) → f x ≡ g x

record qinv {ℓ ℓ'} {A : Set ℓ} {B : Set ℓ'} (f : A → B) :
  Set (ℓ ⊔ ℓ') where
  constructor mkqinv
  field
    g : B → A
    α : (f ○ g) ∼ id
    β : (g ○ f) ∼ id

record isequiv {ℓ ℓ'} {A : Set ℓ} {B : Set ℓ'} (f : A → B) :
  Set (ℓ ⊔ ℓ') where
  constructor mkisequiv
  field
    g : B → A
    α : (f ○ g) ∼ id
    h : B → A
    β : (h ○ f) ∼ id

equiv₁ : ∀ {ℓ ℓ'} → {A : Set ℓ} {B : Set ℓ'} {f : A → B} → qinv f → isequiv f
equiv₁ (mkqinv qg qα qβ) = mkisequiv qg qα qg qβ

_≃_ : ∀ {ℓ ℓ'} (A : Set ℓ) (B : Set ℓ') → Set (ℓ ⊔ ℓ')
A ≃ B = Σ (A → B) isequiv

postulate
  univalence : {A B : Set} → (A ≡ B) ≃ (A ≃ B)

------------------------------------------------------------------------------
-- Path and loop spaces

1-Path : {A : Set} → (a b : A) → Set
1-Path {A} a b = (a ≡ b)

2-Path : {A : Set} → (a b : A) (p q : 1-Path {A} a b) → Set
2-Path {A} a b p q = (p ≡ q)

Ω : (A : Set) → {a : A} → Set
Ω A {a} = 1-Path {A} a a

Ω² : (A : Set) → {a : A} → Set
Ω² A {a} = 2-Path {A} a a (refl a) (refl a)

-- Whiskering Lemmas
--     ___ p ___     ___ r ___
--   /           \ /           \
--  a     α⇓      b     β⇓     c
--   \           / \           /
--     --- q ---     --- s ---

wskR : {A : Set}
           {a b c : A}
           {p q : 1-Path {A} a b} →
           (α : 2-Path {A} a b p q) →
           (r : 1-Path {A} b c) →
           (p ∘ r) ≡ (q ∘ r)
wskR {A} {a} {b} {c} {p} {q} α r =
         (pathInd (λ {b} {c} r →
                     {p q : a ≡ b} →
                     (α : p ≡ q) →
                     2-Path {A} a c (p ∘ r) (q ∘ r))
                  (λ b {p} {q} α →
                    (p ∘ refl b) ≡⟨ ! (RU p) ⟩
                    p ≡⟨ α ⟩
                    q ≡⟨ RU q ⟩
                    (q ∘ refl b) ∎)
                 r)
                 α

wskL : {A : Set}
           {a b c : A}
           {r s : 1-Path {A} b c} →
           (q : 1-Path {A} a b) →
           (β : 2-Path {A} b c r s) →
           (q ∘ r) ≡ (q ∘ s)
wskL {A} {a} {b} {c} {r} {s} q β =
  (pathInd (λ {a} {b} q →
              {r s : b ≡ c} →
              (α : r ≡ s) →
              2-Path {A} a c (q ∘ r) (q ∘ s))
           ((λ b {p} {q} β →
               (refl b ∘ p) ≡⟨ ! (LU p) ⟩
               p ≡⟨ β ⟩
               q ≡⟨ LU q ⟩
               (refl b ∘ q) ∎))
           q)
           β

_⋆_ : {A : Set}
      {a b c : A}
      {p q : 1-Path {A} a b}
      {r s : 1-Path {A} b c}
      (α : 2-Path {A} a b p q) →
      (β : 2-Path {A} b c r s) →
      (p ∘ r) ≡ (q ∘ s)
_⋆_ {A} {a} {b} {c} {p} {q} {r} {s} α β = (wskR α r) ∘ (wskL q β)

Hcomp→compR1 : {A : Set}
              {a : A}
              (α : 2-Path {A} a a (refl a) (refl a)) →
              (wskR α (refl a)) ≡ (! (RU (refl a))) ∘ α ∘ (RU (refl a))
Hcomp→compR1 {A} {a} α = refl
                           (pathInd (λ {x} {y} _ → x ≡ y) refl
                            (pathInd (λ {x} {y} _ → (x₁ : a ≡ a) (x₂ : y ≡ x₁) → x ≡ x₁)
                             (λ x x₁ → pathInd (λ {x₂} {y} _ → x₂ ≡ y) refl) α (refl a)
                             (refl (refl a))))

Hcomp→compL1 : {A : Set}
              {a : A}
              (β : 2-Path {A} a a (refl a) (refl a)) →
              (wskL (refl a) β) ≡ (! (LU (refl a))) ∘ β ∘ (LU (refl a))
Hcomp→compL1 {A} {a} β = refl
                           (pathInd (λ {x} {y} _ → x ≡ y) refl
                            (pathInd (λ {x} {y} _ → (x₁ : a ≡ a) (x₂ : y ≡ x₁) → x ≡ x₁)
                             (λ x x₁ → pathInd (λ {x₂} {y} _ → x₂ ≡ y) refl) β (refl a)
                             (refl (refl a))))

-- proof from pg 81
α⋆β≡α∘β : {A : Set}
             {a : A}
             (α : 2-Path {A} a a (refl a) (refl a)) →
             (β : 2-Path {A} a a (refl a) (refl a)) →
             α ⋆ β ≡ α ∘ β
α⋆β≡α∘β {A} {a} α β =

  α ⋆ β

  ≡⟨ refl (α ⋆ β) ⟩

  (wskR α ra) ∘ (wskL ra β)

  ≡⟨ refl ((!(refl ra) ∘ α ∘ (refl ra)) ∘ (wskL ra β)) ⟩

  (!(refl ra) ∘ (α ∘ (refl ra))) ∘ (wskL ra β)

  ≡⟨  ap (λ p → ((!(refl ra) ∘ p) ∘ (wskL ra β))) (! (RU α)) ⟩

  ((!(refl ra) ∘ α) ∘ (wskL ra β))

  ≡⟨ ap (λ p → (p ∘ (wskL ra β))) (! (LU α)) ⟩

  (α ∘ (wskL ra β))

  ≡⟨ refl (α ∘ (wskL ra β)) ⟩

  (α ∘ (!(refl ra) ∘ β ∘ (refl ra)))

  ≡⟨ ap (λ p → (α ∘ (!(refl ra) ∘ p))) (! (RU β)) ⟩

  (α ∘ (!(refl ra) ∘ β))

  ≡⟨ ap (λ p → (α ∘ p)) (! (LU β)) ⟩

  α ∘ β ∎
  where ra = (refl a)

_⋆'_ : {A : Set}
       {a b c : A}
       {p q : 1-Path {A} a b}
       {r s : 1-Path {A} b c}
       (α : 2-Path {A} a b p q) →
       (β : 2-Path {A} b c r s) →
       (p ∘ r) ≡ (q ∘ s)
_⋆'_ {A} {a} {b} {c} {p} {q} {r} {s} α β = (wskL p β) ∘ (wskR α s)

α⋆'β≡β∘α : {A : Set}
           {a : A}
           (α : 2-Path {A} a a (refl a) (refl a)) →
           (β : 2-Path {A} a a (refl a) (refl a)) →
           α ⋆' β ≡ β ∘ α
α⋆'β≡β∘α {A} {a} α β =
  α ⋆' β

  ≡⟨ refl (α ⋆' β) ⟩

  (wskL ra β) ∘ (!(refl ra) ∘ (α ∘ (refl ra)))

  ≡⟨  ap (λ p → ((wskL ra β) ∘ (!(refl ra) ∘ p))) (! (RU α)) ⟩

  ((wskL ra β) ∘ (!(refl ra) ∘ α))

  ≡⟨ ap (λ p → ((wskL ra β) ∘ p)) (! (LU α)) ⟩

  ((wskL ra β) ∘ α)

  ≡⟨ refl ((wskL ra β) ∘ α) ⟩

  ((!(refl ra) ∘ β ∘ (refl ra)) ∘ α)

  ≡⟨ ap (λ p → ((!(refl ra) ∘ p) ∘ α)) (! (RU β)) ⟩

  ((!(refl ra) ∘ β) ∘ α)

  ≡⟨ ap (λ p → (p ∘ α)) (! (LU β)) ⟩

  β ∘ α ∎

  where ra = (refl a)

-- yuck lots of nested induction
α⋆β≡α⋆'β : {A : Set}
           {a : A}
           (α : 2-Path {A} a a (refl a) (refl a)) →
           (β : 2-Path {A} a a (refl a) (refl a)) →
           α ⋆ β ≡ α ⋆' β
α⋆β≡α⋆'β {A} {a} α β =
  -- induction on α
  pathInd
    (λ α → α ⋆ β ≡ α ⋆' β)
    (λ p →
       -- induction on β
       pathInd
         (λ β → refl p ⋆ β ≡ refl p ⋆' β)
         (λ q →
            -- induction on p
            (pathInd
              (λ {a} {b} p → (c : A) → (q : b ≡ c) →
                 ((refl p ⋆ refl q) ≡ (refl p ⋆' refl q)))
                      (λ a d q →
                         -- induction on q
                         pathInd
                           (λ {a} {d} r →
                              ((refl (refl a) ⋆ refl r) ≡ (refl (refl a) ⋆' refl r)))
                           (λ a → refl (refl (refl a)))
                         q)
               p a q))
             β)
           α

eckmann-hilton : {A : Set} {a : A} (α β : Ω² A {a}) → α ∘ β ≡ β ∘ α
eckmann-hilton {A} {a} α β =
  α ∘ β
  ≡⟨ ! (α⋆β≡α∘β α β) ⟩
  α ⋆ β
  ≡⟨ α⋆β≡α⋆'β α β ⟩
  α ⋆' β
  ≡⟨ α⋆'β≡β∘α α β ⟩
  β ∘ α ∎
------------------------------------------------------------------------------


module Numeral.Integer.Relation.Divisibility.Proofs where

open import Functional
open import Logic.Propositional
import      Numeral.Natural.Relation.Divisibility as ℕ
import      Numeral.Natural.Relation.Divisibility.Proofs as ℕ
open import Numeral.Natural using (ℕ)
import      Numeral.Natural.Oper as ℕ
open import Numeral.Integer.Oper
open import Numeral.Integer.Proofs
open import Numeral.Integer.Relation.Divisibility
open import Numeral.Integer
open import Relator.Equals
open import Relator.Equals.Proofs.Equiv
open import Structure.Function.Multi
open import Structure.Operator.Properties
open import Structure.Relator
open import Structure.Relator.Properties
open import Type

instance
  [∣][−𝐒ₙ]-sub : ((_∣_) on₂ (−𝐒ₙ_)) ⊆₂ ((ℕ._∣_) on₂ ℕ.𝐒)
  [∣][−𝐒ₙ]-sub = intro id

instance
  [∣][+ₙ]-sub : ((_∣_) on₂ (+ₙ_)) ⊆₂ (ℕ._∣_)
  [∣][+ₙ]-sub = intro id

instance
  [∣][−ₙ]-sub : ((_∣_) on₂ (−ₙ_)) ⊆₂ (ℕ._∣_)
  _⊆₂_.proof [∣][−ₙ]-sub {ℕ.𝟎}   {ℕ.𝟎}   p = p
  _⊆₂_.proof [∣][−ₙ]-sub {ℕ.𝟎}   {ℕ.𝐒 y} p = p
  _⊆₂_.proof [∣][−ₙ]-sub {ℕ.𝐒 x} {ℕ.𝟎}   p = p
  _⊆₂_.proof [∣][−ₙ]-sub {ℕ.𝐒 x} {ℕ.𝐒 y} p = p

instance
  [∣][−𝐒ₙ]-super : ((_∣_) on₂ (−𝐒ₙ_)) ⊇₂ ((ℕ._∣_) on₂ ℕ.𝐒)
  [∣][−𝐒ₙ]-super = intro id

instance
  [∣][+ₙ]-super : ((_∣_) on₂ (+ₙ_)) ⊇₂ (ℕ._∣_)
  [∣][+ₙ]-super = intro id

instance
  [∣][−ₙ]-super : ((_∣_) on₂ (−ₙ_)) ⊇₂ (ℕ._∣_)
  _⊆₂_.proof [∣][−ₙ]-super {ℕ.𝟎}   {ℕ.𝟎}   p = p
  _⊆₂_.proof [∣][−ₙ]-super {ℕ.𝟎}   {ℕ.𝐒 y} p = p
  _⊆₂_.proof [∣][−ₙ]-super {ℕ.𝐒 x} {ℕ.𝟎}   p = p
  _⊆₂_.proof [∣][−ₙ]-super {ℕ.𝐒 x} {ℕ.𝐒 y} p = p

divides-with-[−ₙ] : ∀{a b c} → ((absₙ a) ℕ.∣ b) → ((absₙ a) ℕ.∣ c) → (a ∣ (b −ₙ c))
divides-with-[−ₙ] {a} ℕ.Div𝟎 ℕ.Div𝟎 = ℕ.Div𝟎
divides-with-[−ₙ] {a} (ℕ.Div𝐒 ab) ℕ.Div𝟎 = ℕ.Div𝐒 ab
divides-with-[−ₙ] {a} ℕ.Div𝟎 (ℕ.Div𝐒 {x = x} ac)
  with p ← ℕ.divides-with-[+] (reflexivity(ℕ._∣_)) ((super₂((_∣_) on₂ (−ₙ_))(ℕ._∣_) ac))
  rewrite absₙ-of-[−ₙ] {x}
  rewrite absₙ-of-[−ₙ] {absₙ a}
  rewrite [−ₙ]-antiidentityₗ {absₙ a ℕ.+ x}
  rewrite absₙ-of-[−ₙ] {absₙ(a) ℕ.+ x}
  = p
divides-with-[−ₙ] {a} (ℕ.Div𝐒 {x = x} ab) (ℕ.Div𝐒 {x = y} ac)
  rewrite [−ₙ]-on-[+]ₗ-redundancy{absₙ a}{x}{y}
  = divides-with-[−ₙ] {a} ab ac

divides-with-[+] : ∀{a b c} → (a ∣ b) → (a ∣ c) → (a ∣ (b + c))
divides-with-[+] {+ₙ  a} {+ₙ  b} {+ₙ  c} ab ac = ℕ.divides-with-[+] ab ac
divides-with-[+] {+ₙ  a} {+ₙ  b} {−𝐒ₙ c} ab ac = divides-with-[−ₙ] {+ₙ a} ab ac
divides-with-[+] {+ₙ  a} {−𝐒ₙ b} {+ₙ  c} ab ac = divides-with-[−ₙ] {+ₙ a} ac ab
divides-with-[+] {+ₙ  a} {−𝐒ₙ b} {−𝐒ₙ c} ab ac = ℕ.divides-with-[+] ab ac
divides-with-[+] {−𝐒ₙ a} {+ₙ  b} {+ₙ  c} ab ac = ℕ.divides-with-[+] ab ac
divides-with-[+] {−𝐒ₙ a} {+ₙ  b} {−𝐒ₙ c} ab ac = divides-with-[−ₙ] {−𝐒ₙ a} ab ac
divides-with-[+] {−𝐒ₙ a} {−𝐒ₙ b} {+ₙ  c} ab ac = divides-with-[−ₙ] {−𝐒ₙ a} ac ab
divides-with-[+] {−𝐒ₙ a} {−𝐒ₙ b} {−𝐒ₙ c} ab ac = ℕ.divides-with-[+] ab ac

divides-with-[⋅] : ∀{a b c} → ((a ∣ b) ∨ (a ∣ c)) → (a ∣ (b ⋅ c))
divides-with-[⋅] {a} {b} {c} p = substitute₂ᵣ(ℕ._∣_) {absₙ a} (symmetry(_≡_) (preserving₂(absₙ)(_⋅_)(ℕ._⋅_) {b}{c})) (ℕ.divides-with-[⋅] {absₙ a}{absₙ b}{absₙ c} p)


------------------------------------------------------------------------
-- The Agda standard library
--
-- An inductive definition of the heterogeneous suffix relation
------------------------------------------------------------------------

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

module Data.List.Relation.Binary.Suffix.Heterogeneous where

open import Level
open import Relation.Binary using (REL; _⇒_)
open import Data.List.Base as List using (List; []; _∷_)
open import Data.List.Relation.Binary.Pointwise as Pointwise
  using (Pointwise; []; _∷_)

module _ {a b r} {A : Set a} {B : Set b} (R : REL A B r) where

  data Suffix : REL (List A) (List B) (a ⊔ b ⊔ r) where
    here  : ∀ {as bs} → Pointwise R as bs → Suffix as bs
    there : ∀ {b as bs} → Suffix as bs → Suffix as (b ∷ bs)

  data SuffixView (as : List A) : List B → Set (a ⊔ b ⊔ r) where
    _++_ : ∀ cs {ds} → Pointwise R as ds → SuffixView as (cs List.++ ds)

module _ {a b r} {A : Set a} {B : Set b} {R : REL A B r} where

  tail : ∀ {a as bs} → Suffix R (a ∷ as) bs → Suffix R as bs
  tail (here (_ ∷ rs)) = there (here rs)
  tail (there x) = there (tail x)

module _ {a b r s} {A : Set a} {B : Set b} {R : REL A B r} {S : REL A B s} where

  map : R ⇒ S → Suffix R ⇒ Suffix S
  map R⇒S (here rs)   = here (Pointwise.map R⇒S rs)
  map R⇒S (there suf) = there (map R⇒S suf)

module _ {a b r} {A : Set a} {B : Set b} {R : REL A B r} where

  toView : ∀ {as bs} → Suffix R as bs → SuffixView R as bs
  toView (here rs) = [] ++ rs
  toView (there {c} suf) with toView suf
  ... | cs ++ rs = (c ∷ cs) ++ rs

  fromView : ∀ {as bs} → SuffixView R as bs → Suffix R as bs
  fromView ([]       ++ rs) = here rs
  fromView ((c ∷ cs) ++ rs) = there (fromView (cs ++ rs))


------------------------------------------------------------------------
-- Coinductive axiomatisation of subtyping
------------------------------------------------------------------------

module RecursiveTypes.Subtyping.Axiomatic.Coinductive where

import Data.Empty as E
open import Data.Fin using (Fin; zero; suc)
open import Data.Nat using (ℕ; zero; suc)
open import Codata.Musical.Notation
open import Relation.Nullary

open import RecursiveTypes.Syntax
open import RecursiveTypes.Substitution
open import RecursiveTypes.Semantics
open import RecursiveTypes.Subtyping.Semantic.Coinductive as Sem
  using (_≤∞P_; _≤Coind_; ⟦_⟧P; ⌜_⌝; ⊥; ⊤; var; _⟶_; _≤⟨_⟩_)

------------------------------------------------------------------------
-- Definition

-- This definition uses mixed induction and coinduction. Induction is
-- used for rules like transitivity, whereas coinduction is used for
-- structural rules. Benjamin Pierce observed in Types and Programming
-- Languages that coinductive inference systems cannot be
-- "declarative" (including rules like transitivity); they can be
-- "algorithmic" (syntax-directed), though. However, by mixing
-- induction and coinduction one can combine the benefits of
-- coinduction and declarative inference systems.

infixr 10 _⟶_
infix  4  _≤_
infix  3  _∎
infixr 2  _≤⟨_⟩_

data _≤_ {n} : Ty n → Ty n → Set where
  -- Structural rules. Note that the rule for _⟶_ is coinductive.
  ⊥   : ∀ {τ} → ⊥ ≤ τ
  ⊤   : ∀ {σ} → σ ≤ ⊤
  _⟶_ : ∀ {σ₁ σ₂ τ₁ τ₂} (τ₁≤σ₁ : ∞ (τ₁ ≤ σ₁)) (σ₂≤τ₂ : ∞ (σ₂ ≤ τ₂)) →
        σ₁ ⟶ σ₂ ≤ τ₁ ⟶ τ₂

  -- Rules for folding and unfolding μ.
  unfold : ∀ {τ₁ τ₂} → μ τ₁ ⟶ τ₂ ≤ unfold[μ τ₁ ⟶ τ₂ ]
  fold   : ∀ {τ₁ τ₂} → unfold[μ τ₁ ⟶ τ₂ ] ≤ μ τ₁ ⟶ τ₂

  -- Reflexivity.
  _∎ : ∀ τ → τ ≤ τ

  -- Transitivity.
  _≤⟨_⟩_ : ∀ τ₁ {τ₂ τ₃} (τ₁≤τ₂ : τ₁ ≤ τ₂) (τ₂≤τ₃ : τ₂ ≤ τ₃) → τ₁ ≤ τ₃

------------------------------------------------------------------------
-- Equivalence

-- The axiomatisation is equivalent to the semantic definitions of
-- subtyping.

soundP : ∀ {n} {σ τ : Ty n} → σ ≤ τ → ⟦ σ ⟧ ≤∞P ⟦ τ ⟧
soundP ⊥                     = ⊥
soundP ⊤                     = ⊤
soundP (τ₁≤σ₁ ⟶ σ₂≤τ₂)       = ♯ soundP (♭ τ₁≤σ₁) ⟶ ♯ soundP (♭ σ₂≤τ₂)
soundP unfold                = ⌜ Sem.unfold  ⌝
soundP fold                  = ⌜ Sem.fold    ⌝
soundP (τ ∎)                 = ⌜ Sem.refl∞ _ ⌝
soundP (τ₁ ≤⟨ τ₁≤τ₂ ⟩ τ₂≤τ₃) = _ ≤⟨ soundP τ₁≤τ₂ ⟩ soundP τ₂≤τ₃

sound : ∀ {n} {σ τ : Ty n} → σ ≤ τ → σ ≤Coind τ
sound σ≤τ = ⟦ soundP σ≤τ ⟧P

complete : ∀ {n} (σ τ : Ty n) → σ ≤Coind τ → σ ≤ τ
complete ⊥         _         _ = ⊥
complete _         ⊤         _ = ⊤
complete ⊤         ⊥         ()
complete ⊤         (var x)   ()
complete ⊤         (σ ⟶ τ)   ()
complete ⊤         (μ σ ⟶ τ) ()
complete (var x)   ⊥         ()
complete (var x)   (var .x)  var = var x ∎
complete (var x)   (σ ⟶ τ)   ()
complete (var x)   (μ σ ⟶ τ) ()
complete (σ₁ ⟶ σ₂) ⊥         ()
complete (σ₁ ⟶ σ₂) (var x)   ()
complete (σ₁ ⟶ σ₂) (τ₁ ⟶ τ₂) (τ₁≤σ₁ ⟶ σ₂≤τ₂) =
  ♯ complete τ₁ σ₁ (♭ τ₁≤σ₁) ⟶ ♯ complete σ₂ τ₂ (♭ σ₂≤τ₂)
complete (σ₁ ⟶ σ₂) (μ τ₁ ⟶ τ₂) (τ₁≤σ₁ ⟶ σ₂≤τ₂) =
  σ₁ ⟶ σ₂             ≤⟨ ♯ complete _ _ (♭ τ₁≤σ₁) ⟶
                         ♯ complete _ _ (♭ σ₂≤τ₂) ⟩
  unfold[μ τ₁ ⟶ τ₂ ]  ≤⟨ fold ⟩
  μ τ₁ ⟶ τ₂           ∎
complete (μ σ₁ ⟶ σ₂) ⊥         ()
complete (μ σ₁ ⟶ σ₂) (var x)   ()
complete (μ σ₁ ⟶ σ₂) (τ₁ ⟶ τ₂) (τ₁≤σ₁ ⟶ σ₂≤τ₂) =
  μ σ₁ ⟶ σ₂           ≤⟨ unfold ⟩
  unfold[μ σ₁ ⟶ σ₂ ]  ≤⟨ ♯ complete _ _ (♭ τ₁≤σ₁) ⟶
                         ♯ complete _ _ (♭ σ₂≤τ₂) ⟩
  (τ₁ ⟶ τ₂)           ∎
complete (μ σ₁ ⟶ σ₂) (μ τ₁ ⟶ τ₂) (τ₁≤σ₁ ⟶ σ₂≤τ₂) =
  μ σ₁ ⟶ σ₂           ≤⟨ unfold ⟩
  unfold[μ σ₁ ⟶ σ₂ ]  ≤⟨ ♯ complete _ _ (♭ τ₁≤σ₁) ⟶
                         ♯ complete _ _ (♭ σ₂≤τ₂) ⟩
  unfold[μ τ₁ ⟶ τ₂ ]  ≤⟨ fold ⟩
  μ τ₁ ⟶ τ₂           ∎

------------------------------------------------------------------------
-- The reflexivity constructor is essential

-- Minor point: the constructor _∎ cannot be omitted. In
-- RecursiveTypes.Subtyping.Axiomatic.Incorrect it is shown that
-- _≤⟨_⟩_ is also essential.

module ∎-Is-Essential where

  infixr 10 _⟶_
  infix  4  _≤′_
  infixr 2  _≤⟨_⟩_

  data _≤′_ {n} : Ty n → Ty n → Set where
    ⊥   : ∀ {τ} → ⊥ ≤′ τ
    ⊤   : ∀ {σ} → σ ≤′ ⊤
    _⟶_ : ∀ {σ₁ σ₂ τ₁ τ₂}
          (τ₁≤σ₁ : ∞ (τ₁ ≤′ σ₁)) (σ₂≤τ₂ : ∞ (σ₂ ≤′ τ₂)) →
          σ₁ ⟶ σ₂ ≤′ τ₁ ⟶ τ₂

    unfold : ∀ {τ₁ τ₂} → μ τ₁ ⟶ τ₂ ≤′ unfold[μ τ₁ ⟶ τ₂ ]
    fold   : ∀ {τ₁ τ₂} → unfold[μ τ₁ ⟶ τ₂ ] ≤′ μ τ₁ ⟶ τ₂

    _≤⟨_⟩_ : ∀ τ₁ {τ₂ τ₃}
             (τ₁≤τ₂ : τ₁ ≤′ τ₂) (τ₂≤τ₃ : τ₂ ≤′ τ₃) → τ₁ ≤′ τ₃

  sound′ : ∀ {n} {σ τ : Ty n} → σ ≤′ τ → σ ≤ τ
  sound′ ⊥                    = ⊥
  sound′ ⊤                    = ⊤
  sound′ (τ₁≤σ₁ ⟶ σ₂≤τ₂)      = ♯ sound′ (♭ τ₁≤σ₁) ⟶ ♯ sound′ (♭ σ₂≤τ₂)
  sound′ unfold               = unfold
  sound′ fold                 = fold
  sound′ (_ ≤⟨ τ₁≤τ₂ ⟩ τ₂≤τ₃) = _ ≤⟨ sound′ τ₁≤τ₂ ⟩ sound′ τ₂≤τ₃

  x : Ty 1
  x = var zero

  x≰′x : ¬ x ≤′ x
  x≰′x (.x ≤⟨ x≤′σ ⟩ σ≤x) = helper x≤′σ σ≤x
    where
    helper : ∀ {σ} → x ≤′ σ → σ ≤′ x → E.⊥
    helper (.x ≤⟨ x≤σ₁ ⟩ σ₁≤σ₂) σ₂≤′x = helper x≤σ₁ (_ ≤⟨ σ₁≤σ₂ ⟩ σ₂≤′x)
    helper ⊤                    ⊤≤′x  with sound (sound′ ⊤≤′x)
    ... | ()

  incomplete : ¬ (∀ {n} {σ τ : Ty n} → σ ≤ τ → σ ≤′ τ)
  incomplete hyp with x≰′x (hyp (x ∎))
  ... | ()


module FreezingTest where

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

data ℕ : Set where
  zero : ℕ
  suc  : (n : ℕ) → ℕ

force : let one : ℕ
            one = _         -- this meta is not frozen after the end of let
        in  one ≡ suc zero
force = refl


open import Agda.Primitive using (_⊔_)

import Categories.Category as Category
import Categories.Category.Cartesian as Cartesian

open import MultiSorted.AlgebraicTheory
import MultiSorted.Product as Product

module MultiSorted.Interpretation
         {o ℓ e}
         {𝓈 ℴ}
         (Σ : Signature {𝓈} {ℴ})
         {𝒞 : Category.Category o ℓ e}
         (cartesian-𝒞 : Cartesian.Cartesian 𝒞) where
  open Signature Σ
  open Category.Category 𝒞

  -- An interpretation of Σ in 𝒞
  record Interpretation : Set (o ⊔ ℓ ⊔ e ⊔ 𝓈 ⊔ ℴ) where

    field
      interp-sort : sort → Obj
      interp-ctx : Product.Producted 𝒞 {Σ = Σ} interp-sort
      interp-oper : ∀ (f : oper) → Product.Producted.prod interp-ctx (oper-arity f) ⇒ interp-sort (oper-sort f)

    open Product.Producted interp-ctx

    -- the interpretation of a term
    interp-term : ∀ {Γ : Context} {A} → Term Γ A → prod Γ ⇒ interp-sort A
    interp-term (tm-var x) = π x
    interp-term (tm-oper f ts) = interp-oper f ∘ tuple (oper-arity f) (λ i → interp-term (ts i))

    -- the interpretation of a substitution
    interp-subst : ∀ {Γ Δ} → Γ ⇒s Δ → prod Γ ⇒ prod Δ
    interp-subst {Γ} {Δ} σ = tuple Δ λ i → interp-term (σ i)

    -- the equality of interpretations
    ⊨_ : (ε : Equation Σ) → Set e
    open Equation
    ⊨ ε = interp-term (eq-lhs ε) ≈ interp-term (eq-rhs ε)

    -- interpretation commutes with substitution
    open HomReasoning

    interp-[]s : ∀ {Γ Δ} {A} {t : Term Δ A} {σ : Γ ⇒s Δ} →
                 interp-term (t [ σ ]s) ≈ interp-term t ∘ interp-subst σ
    interp-[]s {Γ} {Δ} {A} {tm-var x} {σ} = ⟺ (project {Γ = Δ})
    interp-[]s {Γ} {Δ} {A} {tm-oper f ts} {σ} = (∘-resp-≈ʳ
                                                (tuple-cong
                                                  {fs = λ i → interp-term (ts i [ σ ]s)}
                                                  {gs = λ z → interp-term (ts z) ∘ interp-subst σ}
                                                  (λ i → interp-[]s {t = ts i} {σ = σ})
                                              ○ (∘-distribʳ-tuple
                                                  {Γ = oper-arity f}
                                                  {fs = λ z → interp-term (ts z)}
                                                  {g = interp-subst σ})))
                                                ○ (Equiv.refl ○ sym-assoc)

  -- -- Every signature has the trivial interpretation

  open Product 𝒞

  Trivial : Interpretation
  Trivial =
    let open Cartesian.Cartesian cartesian-𝒞 in
    record
      { interp-sort = (λ _ → ⊤)
      ; interp-ctx = StandardProducted (λ _ → ⊤) cartesian-𝒞
      ; interp-oper = λ f → ! }

  record _⇒I_ (I J : Interpretation) : Set (o ⊔ ℓ ⊔ e ⊔ 𝓈 ⊔ ℴ) where
    open Interpretation
    open Producted

    field
      hom-morphism : ∀ {A} → interp-sort I A ⇒ interp-sort J A
      hom-commute :
         ∀ (f : oper) →
         hom-morphism ∘ interp-oper I f ≈
             interp-oper J f ∘ tuple (interp-ctx J) (oper-arity f) (λ i → hom-morphism ∘ π (interp-ctx I) i)

  infix  4 _⇒I_

  -- The identity homomorphism
  id-I : ∀ {A : Interpretation} → A ⇒I A
  id-I {A} =
    let open Interpretation A in
    let open HomReasoning in
    let open Producted interp-sort in
    record
      { hom-morphism = id
      ; hom-commute = λ f →
                        begin
                          (id ∘ interp-oper f) ≈⟨ identityˡ ⟩
                          interp-oper f       ≈˘⟨ identityʳ ⟩
                          (interp-oper f ∘ id)      ≈˘⟨ refl⟩∘⟨ unique interp-ctx (λ i → identityʳ ○  ⟺ identityˡ) ⟩
                          (interp-oper f ∘
                            Product.Producted.tuple interp-ctx (oper-arity f)
                            (λ i → id ∘ Product.Producted.π interp-ctx i)) ∎
      }

  -- Compositon of homomorphisms
  _∘I_ : ∀ {A B C : Interpretation} → B ⇒I C → A ⇒I B → A ⇒I C
  _∘I_ {A} {B} {C} ϕ ψ =
     let open _⇒I_ in
     record { hom-morphism = hom-morphism ϕ ∘ hom-morphism ψ
            ; hom-commute =
                let open Interpretation in
                let open Producted in
                let open HomReasoning in
                λ f →
                  begin
                    (((hom-morphism ϕ) ∘ hom-morphism ψ) ∘ interp-oper A f) ≈⟨ assoc ⟩
                    (hom-morphism ϕ ∘ hom-morphism ψ ∘ interp-oper A f) ≈⟨ (refl⟩∘⟨ hom-commute ψ f) ⟩
                    (hom-morphism ϕ ∘
                      interp-oper B f ∘
                      tuple (interp-ctx B) (oper-arity f)
                      (λ i → hom-morphism ψ ∘ π (interp-ctx A) i)) ≈˘⟨ assoc ⟩
                    ((hom-morphism ϕ ∘ interp-oper B f) ∘
                      tuple (interp-ctx B) (oper-arity f)
                      (λ i → hom-morphism ψ ∘ π (interp-ctx A) i)) ≈⟨ (hom-commute ϕ f ⟩∘⟨refl) ⟩
                     ((interp-oper C f ∘
                       tuple (interp-ctx C) (oper-arity f)
                       (λ i → hom-morphism ϕ ∘ π (interp-ctx B) i))
                      ∘
                      tuple (interp-ctx B) (oper-arity f)
                      (λ i → hom-morphism ψ ∘ π (interp-ctx A) i)) ≈⟨ assoc ⟩
                    (interp-oper C f ∘
                      tuple (interp-ctx C) (oper-arity f)
                      (λ i → hom-morphism ϕ ∘ π (interp-ctx B) i)
                      ∘
                      tuple (interp-ctx B) (oper-arity f)
                      (λ i → hom-morphism ψ ∘ π (interp-ctx A) i)) ≈⟨ (refl⟩∘⟨ ⟺ (∘-distribʳ-tuple (interp-sort C) (interp-ctx C))) ⟩
                    (interp-oper C f ∘
                      tuple (interp-ctx C) (oper-arity f)
                      (λ x →
                         (hom-morphism ϕ ∘ π (interp-ctx B) x) ∘
                         tuple (interp-ctx B) (oper-arity f)
                         (λ i → hom-morphism ψ ∘ π (interp-ctx A) i))) ≈⟨ (refl⟩∘⟨ tuple-cong (interp-sort C) (interp-ctx C) λ i → assoc) ⟩
                    (interp-oper C f ∘
                      tuple (interp-ctx C) (oper-arity f)
                      (λ z →
                         hom-morphism ϕ ∘
                         π (interp-ctx B) z ∘
                         tuple (interp-ctx B) (oper-arity f)
                         (λ i → hom-morphism ψ ∘ π (interp-ctx A) i))) ≈⟨ (refl⟩∘⟨ tuple-cong (interp-sort C) (interp-ctx C) λ i → refl⟩∘⟨ project (interp-ctx B)) ⟩
                    (interp-oper C f ∘
                      tuple (interp-ctx C) (oper-arity f)
                      (λ z → hom-morphism ϕ ∘ hom-morphism ψ ∘ π (interp-ctx A) z)) ≈⟨ (refl⟩∘⟨ tuple-cong (interp-sort C) (interp-ctx C) λ i → sym-assoc) ⟩
                   (interp-oper C f ∘
                     tuple (interp-ctx C) (oper-arity f)
                     (λ z → (hom-morphism ϕ ∘ hom-morphism ψ) ∘ π (interp-ctx A) z)) ∎}


module Examples.Parity where
open import Relation.Nullary
open import Relation.Binary.PropositionalEquality
open import Data.Empty
open import Data.Bool hiding (not)
open import Data.Nat
open import Data.Fin hiding (_+_)
open import Data.Product hiding (map)
open import Data.List hiding (and; or; sum; map; [_])
open import Data.Vec hiding (init)
import DTGP

data Word : Set where
  not and or : Word

pre : Word → ℕ → ℕ
pre not n = 1 + n
pre and n = 2 + n
pre or  n = 2 + n

post : Word → ℕ → ℕ
post not n = 1 + n
post and n = 1 + n
post or  n = 1 + n

even : ℕ → Bool
even zero = true
even (suc zero) = false
even (suc (suc zero)) = true
even (suc n) = even n

trues : ∀ {n} → Vec Bool n → ℕ
trues [] = 0
trues (true ∷ xs) = suc (trues xs)
trues (false ∷ xs) = trues xs

evenParity : ∀ {n} → Vec Bool n → Bool
evenParity xs = even (trues xs)

open DTGP pre post Data.Nat._≟_

eval : ∀ {inp out} → Term inp out → Vec Bool inp → Vec Bool out
eval [] is = is
eval (not ∷ xs) is with eval xs is
... | o ∷ os = Data.Bool.not o ∷ os
eval (and ∷ xs) is with eval xs is
... | o₂ ∷ o₁ ∷ os = (o₁ ∧ o₂) ∷ os
eval (or ∷ xs) is with eval xs is
... | o₂ ∷ o₁ ∷ os = (o₁ ∨ o₂) ∷ os

bitEqual : ∀ {m n} → Vec Bool m → Vec Bool n → Bool
bitEqual [] [] = true
bitEqual (_ ∷ _) [] = false
bitEqual [] (_ ∷ _) = false
bitEqual (x ∷ xs) (y ∷ ys) = x ∧ y ∧ bitEqual xs ys

scores : ∀ {inp out n} → Vec (Vec Bool inp) n → Term inp out → ℕ
scores ass xs = sum (map (λ as →
  if (bitEqual (eval xs as) [ evenParity as ])
  then 1 else 0)
  ass)

fitnessCases : Vec (Vec Bool _) _
fitnessCases =
    (true ∷ true ∷ [])
  ∷ (true ∷ false ∷ [])
  ∷ (false ∷ true ∷ [])
  ∷ (false ∷ false ∷ [])
  ∷ []

_==_ : ℕ → ℕ → Bool
zero == zero = true
zero == suc _ = false
suc _ == zero = false
suc m == suc n = m == n

score : Term _ _ → ℕ
score xs = scores fitnessCases xs

open Evolution score

match : (w : Word) (out : ℕ) → Dec (∃ λ n → out ≡ pre w n)
match not zero = no ¬p where
  ¬p : Σ ℕ (λ n → 0 ≡ suc n) → ⊥
  ¬p (_ , ())
match not (suc n) = yes (n , refl)
match and zero = no ¬p where
  ¬p : Σ ℕ (λ n → 0 ≡ suc (suc n)) → ⊥
  ¬p (_ , ())
match and (suc zero) = no ¬p where
  ¬p : Σ ℕ (λ n → 1 ≡ suc (suc n)) → ⊥
  ¬p (_ , ())
match and (suc (suc n)) = yes (n , refl)
match or zero = no ¬p where
  ¬p : Σ ℕ (λ n → 0 ≡ suc (suc n)) → ⊥
  ¬p (_ , ())
match or (suc zero) = no ¬p where
  ¬p : Σ ℕ (λ n → 1 ≡ suc (suc n)) → ⊥
  ¬p (_ , ())
match or (suc (suc n)) = yes (n , refl)

open Initialization match

choices : List Word
choices = not ∷ and ∷ or ∷ []

population : Population _ _ _
population = fromList (init 4 2 1 choices)

answer : Population _ _ _
answer = evolve 1337 1 population


module Examples.TestCall where

open import Prelude
open import Libraries.SelectiveReceive
open import Libraries.Call

open SelRec

AddReplyMessage : MessageType
AddReplyMessage = ValueType UniqueTag ∷ [ ValueType ℕ ]ˡ

AddReply : InboxShape
AddReply = [ AddReplyMessage ]ˡ

AddMessage : MessageType
AddMessage = ValueType UniqueTag ∷ ReferenceType AddReply ∷ ValueType ℕ ∷ [ ValueType ℕ ]ˡ

Calculator : InboxShape
Calculator = [ AddMessage ]ˡ

calculatorActor : ∀ {i} → ∞ActorM (↑ i) Calculator (Lift (lsuc lzero) ⊤) [] (λ _ → [])
calculatorActor = loop
  where
    loop : ∀ {i} → ∞ActorM i Calculator (Lift (lsuc lzero) ⊤) [] (λ _ → [])
    loop .force = receive ∞>>= λ {
      (Msg Z (tag ∷ _ ∷ n ∷ m ∷ [])) → do
        Z ![t: Z ] ((lift tag) ∷ [ lift (n + m) ]ᵃ )
        strengthen []
        loop
      ; (Msg (S ()) _) }

TestBox : InboxShape
TestBox = AddReply

calltestActor : ∀ {i} → ∞ActorM i TestBox (Lift (lsuc lzero) ℕ) [] (λ _ → [])
calltestActor .force = spawn∞ calculatorActor ∞>> do
    x ← call [] Z Z 0
         ((lift 10) ∷ [ lift 32 ]ᵃ)
         ⊆-refl Z
    strengthen []
    return-result x
  where
    return-result : SelRec TestBox (call-select 0 ⊆-refl Z) →
                    ∀ {i} → ∞ActorM i TestBox (Lift (lsuc lzero) ℕ) [] (λ _ → [])
    return-result record { msg = (Msg Z (tag ∷ n ∷ [])) } = return n
    return-result record { msg = (Msg (S x) x₁) ; msg-ok = () }


------------------------------------------------------------------------------
-- Subtraction using the rec combinator
------------------------------------------------------------------------------

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

module FOT.LTC-PCF.Data.Nat.SubtractionRecCombinator where

open import Common.FOL.Relation.Binary.EqReasoning

open import LTC-PCF.Base
open import LTC-PCF.Base.Properties
open import LTC-PCF.Data.Nat.Properties hiding ( ∸-x0 )
open import LTC-PCF.Data.Nat.Rec
open import LTC-PCF.Data.Nat.Rec.ConversionRules
open import LTC-PCF.Data.Nat.Type
open import LTC-PCF.Data.Nat.UnaryNumbers

-- We add 3 to the fixities of the Agda standard library 0.8.1 (see
-- Data/Nat.agda).
infixl 9 _∸_

------------------------------------------------------------------------------
-- Subtraction
_∸_ : D → D → D
m ∸ n = rec n m (lam (λ _ → lam pred₁))

------------------------------------------------------------------------------
-- Conversion rules from the Agda standard library 0.8.1 (see
-- Data/Nat.agda).

∸-x0 : ∀ n → n ∸ zero ≡ n
∸-x0 n = rec zero n _ ≡⟨ rec-0 n ⟩
         n            ∎

∸-0S : ∀ {n} → N n → zero ∸ succ₁ n ≡ zero
∸-0S nzero =
  rec [1] zero (lam (λ _ → lam pred₁))
    ≡⟨ rec-S zero zero (lam (λ _ → lam pred₁)) ⟩
  lam (λ _ → lam pred₁) · zero · (zero ∸ zero)
    ≡⟨ ·-leftCong (beta (λ _ → lam pred₁) zero) ⟩
  lam pred₁ · (zero ∸ zero)
    ≡⟨ beta pred₁ (zero ∸ zero) ⟩
  pred₁ (zero ∸ zero)
    ≡⟨ predCong (∸-x0 zero) ⟩
  pred₁ zero
    ≡⟨ pred-0 ⟩
  zero ∎

∸-0S (nsucc {n} Nn) =
  rec (succ₁ (succ₁ n)) zero (lam (λ _ → lam pred₁))
    ≡⟨ rec-S (succ₁ n) zero (lam (λ _ → lam pred₁)) ⟩
  lam (λ _ → lam pred₁) · (succ₁ n) · (zero ∸ (succ₁ n))
    ≡⟨ ·-leftCong (beta (λ _ → lam pred₁) (succ₁ n)) ⟩
  lam pred₁ · (zero ∸ (succ₁ n))
    ≡⟨ beta pred₁ (zero ∸ (succ₁ n)) ⟩
  pred₁ (zero ∸ (succ₁ n))
    ≡⟨ predCong (∸-0S Nn) ⟩
  pred₁ zero
    ≡⟨ pred-0 ⟩
  zero ∎

∸-0x : ∀ {n} → N n → zero ∸ n ≡ zero
∸-0x nzero      = ∸-x0 zero
∸-0x (nsucc Nn) = ∸-0S Nn

∸-SS : ∀ {m n} → N m → N n → succ₁ m ∸ succ₁ n ≡ m ∸ n
∸-SS {m} _ nzero =
  rec [1] (succ₁ m) (lam (λ _ → lam pred₁))
    ≡⟨ rec-S zero (succ₁ m) (lam (λ _ → lam pred₁)) ⟩
  lam (λ _ → lam pred₁) · zero · (succ₁ m ∸ zero)
    ≡⟨ ·-leftCong (beta (λ _ → lam pred₁) zero) ⟩
  lam pred₁ · (succ₁ m ∸ zero)
    ≡⟨ beta pred₁ (succ₁ m ∸ zero) ⟩
  pred₁ (succ₁ m ∸ zero)
    ≡⟨ predCong (∸-x0 (succ₁ m)) ⟩
  pred₁ (succ₁ m)
    ≡⟨ pred-S m ⟩
  m
    ≡⟨ sym (∸-x0 m) ⟩
  m ∸ zero ∎

∸-SS nzero (nsucc {n} Nn) =
  rec (succ₁ (succ₁ n)) [1] (lam (λ _ → lam pred₁))
    ≡⟨ rec-S (succ₁ n) [1] (lam (λ _ → lam pred₁))  ⟩
  lam (λ _ → lam pred₁) · (succ₁ n) · ([1] ∸ succ₁ n)
    ≡⟨ ·-leftCong (beta (λ _ → lam pred₁) (succ₁ n)) ⟩
  lam pred₁ · ([1] ∸ succ₁ n)
    ≡⟨ beta pred₁ ([1] ∸ succ₁ n) ⟩
  pred₁ ([1] ∸ succ₁ n)
    ≡⟨ predCong (∸-SS nzero Nn) ⟩
  pred₁ (zero ∸ n)
    ≡⟨ predCong (∸-0x Nn) ⟩
  pred₁ zero
    ≡⟨ pred-0 ⟩
  zero
    ≡⟨ sym (∸-0S Nn) ⟩
  zero ∸ succ₁ n ∎

∸-SS (nsucc {m} Nm) (nsucc {n} Nn) =
  rec (succ₁ (succ₁ n)) (succ₁ (succ₁ m)) (lam (λ _ → lam pred₁))
    ≡⟨ rec-S (succ₁ n) (succ₁ (succ₁ m)) (lam (λ _ → lam pred₁)) ⟩
  lam (λ _ → lam pred₁) · (succ₁ n) · (succ₁ (succ₁ m) ∸ succ₁ n)
    ≡⟨ ·-leftCong (beta (λ _ → lam pred₁) (succ₁ n)) ⟩
  lam pred₁ · (succ₁ (succ₁ m) ∸ succ₁ n)
    ≡⟨ beta pred₁ (succ₁ (succ₁ m) ∸ succ₁ n) ⟩
  pred₁ (succ₁ (succ₁ m) ∸ succ₁ n)
    ≡⟨ predCong (∸-SS (nsucc Nm) Nn) ⟩
  pred₁ (succ₁ m ∸ n)
    ≡⟨ sym (beta pred₁ (succ₁ m ∸ n)) ⟩
  lam pred₁ · (succ₁ m ∸ n)
    ≡⟨ ·-leftCong (sym (beta (λ _ → lam pred₁) n)) ⟩
  (lam (λ _ → lam pred₁)) · n · (succ₁ m ∸ n)
    ≡⟨ sym (rec-S n (succ₁ m) (lam (λ _ → lam pred₁))) ⟩
  rec (succ₁ n) (succ₁ m) (lam (λ _ → lam pred₁))
    ≡⟨ refl ⟩
  succ₁ m ∸ succ₁ n ∎

------------------------------------------------------------------------------
-- Conversion rules from the Agda standard library 0.8.1 (see
-- Data/Nat.agda) without totality hypotheses.

-- We could not prove this property.
-- ∸-0S₁ : ∀ n → zero ∸ succ₁ n ≡ zero
-- ∸-0S₁ n =
--   rec (succ₁ n) zero (lam (λ _ → lam pred₁))
--     ≡⟨ rec-S n zero (lam (λ _ → lam pred₁)) ⟩
--   lam (λ _ → lam pred₁) · n · (zero ∸ n)
--     ≡⟨ ·-leftCong (beta (λ _ → lam pred₁) n) ⟩
--   lam pred₁ · (zero ∸ n)
--     ≡⟨ beta pred₁ (zero ∸ n) ⟩
--   pred₁ (zero ∸ n)
--     ≡⟨ {!!} ⟩
--   {!!}
--     ≡⟨ {!!} ⟩
--   zero ∎

-- We could not prove this property.
-- ∸-SS₁ : ∀ m n → succ₁ m ∸ succ₁ n ≡ m ∸ n
-- ∸-SS₁ m n =
--   rec (succ₁ n) (succ₁ m) (lam (λ _ → lam pred₁))
--   ≡⟨ rec-S n (succ₁ m) (lam (λ _ → lam pred₁)) ⟩
--   lam (λ x → lam pred₁) · n · (succ₁ m ∸ n)
--     ≡⟨ ·-leftCong (beta (λ _ → lam pred₁) n) ⟩
--   lam pred₁ · (succ₁ m ∸ n)
--     ≡⟨ beta pred₁ (succ₁ m ∸ n) ⟩
--   pred₁ (succ₁ m ∸ n)
--     ≡⟨ {!!} ⟩
--   {!!}
--     ≡⟨ {!!} ⟩
--   m ∸ n ∎

------------------------------------------------------------------------------
-- Coq 8.4pl4 conversion rules (.../theories/Init/Peano.v):

-- Fixpoint minus (n m:nat) : nat :=
--   match n, m with
--   | O, _ => n
--   | S k, O => S k
--   | S k, S l => k - l
--   end

∸-x0-coq : ∀ n → n ∸ zero ≡ n
∸-x0-coq n = rec zero n _ ≡⟨ rec-0 n ⟩
             n            ∎

∸-S0-coq : ∀ n → succ₁ n ∸ zero ≡ succ₁ n
∸-S0-coq n =
  rec zero (succ₁ n) (lam (λ _ → lam pred₁))
    ≡⟨ rec-0 (succ₁ n) ⟩
  succ₁ n ∎

-- We could not prove this property.
-- ∸-SS-coq : ∀ m n → succ₁ m ∸ succ₁ n ≡ m ∸ n
-- ∸-SS-coq m n =
--   rec (succ₁ n) (succ₁ m) (lam (λ _ → lam pred₁))
--   ≡⟨ rec-S n (succ₁ m) (lam (λ _ → lam pred₁)) ⟩
--   lam (λ x → lam pred₁) · n · (succ₁ m ∸ n)
--     ≡⟨ ·-leftCong (beta (λ _ → lam pred₁) n) ⟩
--   lam pred₁ · (succ₁ m ∸ n)
--     ≡⟨ beta pred₁ (succ₁ m ∸ n) ⟩
--   pred₁ (succ₁ m ∸ n)
--     ≡⟨ {!!} ⟩
--   {!!}
--     ≡⟨ {!!} ⟩
--   m ∸ n ∎

------------------------------------------------------------------------------
-- Isabelle2014 conversion rules (from src/HOL/Nat.thy)

-- primrec minus_nat where
--   diff_0 [code]: "m - 0 = (m\<Colon>nat)"
-- | diff_Suc: "m - Suc n = (case m - n of 0 => 0 | Suc k => k)"

∸-x0-isabelle : ∀ n → n ∸ zero ≡ n
∸-x0-isabelle n = rec zero n _ ≡⟨ rec-0 n ⟩
                  n            ∎

-- We could not prove this property.
-- ∸-xS-isabelle : ∀ m n → m ∸ succ₁ n ≡
--                         if (iszero₁ (m ∸ n)) then zero else pred₁ (m ∸ n)
-- ∸-xS-isabelle m n =
--   rec (succ₁ n) m (lam (λ _ → lam pred₁))
--     ≡⟨ rec-S n m (lam (λ _ → lam pred₁)) ⟩
--   lam (λ x → lam pred₁) · n · (m ∸ n)
--     ≡⟨ ·-leftCong (beta (λ _ → lam pred₁) n) ⟩
--   lam pred₁ · (m ∸ n)
--     ≡⟨ beta pred₁ (m ∸ n) ⟩
--   pred₁ (m ∸ n)
--   ≡⟨ {!!} ⟩
--   if (iszero₁ (m ∸ n)) then zero else pred₁ (m ∸ n) ∎

------------------------------------------------------------------------------
-- Peter conversion rules

-- The analogous situation for subtraction is that  given

-- rec-0 : ∀ a {f} → rec zero a f ≡ a
-- rec-S : ∀ n a f → rec (succ₁ n) a f ≡ f · n · (rec n a f)

-- and

-- _∸_ : D → D → D
-- m ∸ n = rec n m (lam (λ _ → lam pred₁))

-- you get the equations obtained by the special case (instantiate a
-- and f according to the def of subtraction)!  This has nothing to do
-- a priori with the Agda standard library.

∸-x0-peter : ∀ n → n ∸ zero ≡ n
∸-x0-peter n = rec zero n _ ≡⟨ rec-0 n ⟩
               n            ∎

∸-xS-peter : ∀ m n → m ∸ succ₁ n ≡ pred₁ (m ∸ n)
∸-xS-peter m n =
  rec (succ₁ n) m (lam (λ _ → lam pred₁))
    ≡⟨ rec-S n m (lam (λ _ → lam pred₁)) ⟩
  lam (λ x → lam pred₁) · n · (m ∸ n)
    ≡⟨ ·-leftCong (beta (λ _ → lam pred₁) n) ⟩
  lam pred₁ · (m ∸ n)
    ≡⟨ beta pred₁ (m ∸ n) ⟩
  pred₁ (m ∸ n) ∎


------------------------------------------------------------------------
-- Some types and functions used by several parser variants
------------------------------------------------------------------------

module Utilities where

open import Data.Product
open import Data.List
open import Data.Function using (flip)

------------------------------------------------------------------------
-- Associativity

-- Used to specify how chain₁, chain and chain≥ should apply the
-- parsed operators: left or right associatively.

data Assoc : Set where
  left  : Assoc
  right : Assoc

------------------------------------------------------------------------
-- Post-processing for the chain parsers

-- Application.

appʳ : forall {r} -> r × (r -> r -> r) -> r -> r
appʳ (x , _•_) y = x • y

appˡ : forall {r} -> r -> (r -> r -> r) × r -> r
appˡ x (_•_ , y) = x • y

-- Shifting. See Examples below for an illuminating example.

shiftˡ : forall {a b} -> List (a × b) -> a -> a × List (b × a)
shiftˡ []                x  = (x , [])
shiftˡ ((x₁ , x₂) ∷ xs₃) x₄ = (x₁ , (x₂ , proj₁ x₃xs₄) ∷ proj₂ x₃xs₄)
  where x₃xs₄ = shiftˡ xs₃ x₄

-- The post-processing function. See Examples below for some
-- illuminating examples.

chain₁-combine : forall {r} ->
                 Assoc -> List (r × (r -> r -> r)) -> r -> r
chain₁-combine right xs y = foldr appʳ y xs
chain₁-combine left  xs y with shiftˡ xs y
... | (x , ys) = foldl appˡ x ys

-- Variants.

shiftʳ : forall {a b} -> a -> List (b × a) -> List (a × b) × a
shiftʳ x  []                = ([] , x)
shiftʳ x₁ ((x₂ , x₃) ∷ xs₄) = ((x₁ , x₂) ∷ proj₁ xs₃x₄ , proj₂ xs₃x₄)
  where xs₃x₄ = shiftʳ x₃ xs₄

chain≥-combine : forall {r} ->
                 Assoc -> r -> List ((r -> r -> r) × r) -> r
chain≥-combine left  x ys = foldl appˡ x ys
chain≥-combine right x ys with shiftʳ x ys
... | (xs , y) = foldr appʳ y xs

private
 module Examples {r s : Set}
                 (x y z : r)
                 (A B : s)
                 (_+_ _*_ : r -> r -> r)
                 where

  open import Relation.Binary.PropositionalEquality

  ex₁ : shiftˡ ((x , A) ∷ (y , B) ∷ []) z ≡ (x , ((A , y) ∷ (B , z) ∷ []))
  ex₁ = refl

  ex₁ʳ : chain₁-combine right ((x , _+_) ∷ (y , _*_) ∷ []) z ≡ x + (y * z)
  ex₁ʳ = refl

  ex₁ˡ : chain₁-combine left  ((x , _+_) ∷ (y , _*_) ∷ []) z ≡ (x + y) * z
  ex₁ˡ = refl

  ex≥ : shiftʳ x ((A , y) ∷ (B , z) ∷ []) ≡ ((x , A) ∷ (y , B) ∷ [] , z)
  ex≥ = refl

  ex≥ʳ : chain≥-combine right x ((_+_ , y) ∷ (_*_ , z) ∷ []) ≡ x + (y * z)
  ex≥ʳ = refl

  ex≥ˡ : chain≥-combine left  x ((_+_ , y) ∷ (_*_ , z) ∷ []) ≡ (x + y) * z
  ex≥ˡ = refl

------------------------------------------------------------------------
-- Some suitably typed composition operators

infixr 9 _∘′_ _∘₂_

_∘′_ : {a c : Set} {b : a -> Set1} ->
       (forall {x} -> b x -> c) -> ((x : a) -> b x) -> (a -> c)
f ∘′ g = \x -> f (g x)

_∘₂_ : {a b c : Set2} -> (b -> c) -> (a -> b) -> (a -> c)
f ∘₂ g = \x -> f (g x)


----------------------------------------------------------------------
-- Copyright: 2013, Jan Stolarek, Lodz University of Technology     --
--                                                                  --
-- License: See LICENSE file in root of the repo                    --
-- Repo address: https://github.com/jstolarek/dep-typed-wbl-heaps   --
--                                                                  --
-- Basic implementation of weight-biased leftist heap. No proofs    --
-- and no dependent types. Uses a single-pass merging algorithm.    --
--                                                                  --
-- Now we will modify our implementation by turning a two-pass      --
-- merging algorithm into a single-pass one. We will do this by     --
-- inlining makeT into merge. See [Single-pass merging algorithm]   --
-- for a detailed description of new algorithm. Since merge         --
-- function will be the only thing that changes we will not repeat  --
-- singleton, findMin and deleteMin functions - they are exactly    --
-- same as they were in case of two-pass merging algorithm. All     --
-- data declaration also remain the same. We will focus our         --
-- attention only on merging.                                       --
----------------------------------------------------------------------

{-# OPTIONS --sized-types #-}
module SinglePassMerge.NoProofs where

open import Basics.Nat
open import Basics hiding (_≥_)
open import Sized

data Heap : {i : Size} → Set where
  empty : {i : Size} → Heap {↑ i}
  node  : {i : Size} → Priority → Rank → Heap {i} → Heap {i} → Heap {↑ i}

-- Note [Single-pass merging algorithm]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
--
-- New single-pass merging algorithm is a straightfowrward derivation
-- from two-pass merge. We obtain this new algorithm by inlining calls
-- to makeT. This means that merge creates a new node instead of
-- delegating this task to makeT. The consequence of this is that
-- merge has two more cases now (a total of six). Base cases remain
-- unchanged (we use the same notation as in [Two-pass merging
-- algorithm]:
--
--    a) h1 is empty - return h2
--
--    b) h2 is empty - return h1
--
-- There are two more cases in the inductive part of merge definition:
--
--    c) priority p1 is higher than p2 AND rank of l1 is not smaller
--       than rank of r1 + h2 - p1 becomes the root, l1 becomes the
--       left child and result of merging r1 with h2 becomes the right
--       child child.
--
--               p1
--              /  \
--             /    \
--            l1  r1+h2
--
--    d) priority p1 is higher than p2 AND rank of r1 + h2 is not
--       smaller than rank of l1 - p1 becomes the root, result of
--       merging r1 with h2 becomes the left child and l1 becomes the
--       right child child.
--
--               p1
--              /  \
--             /    \
--           r1+h2  l1
--
--    e) priority p2 is higher than p1 AND rank of l2 is not smaller
--       rank of r2 + h1 - p2 becomes the root, l2 becomes the left
--       child and result of merging r2 with h1 becomes the right
--       child child.
--
--               p2
--              /  \
--             /    \
--            l2  r2+h1
--
--    f) priority p2 is higher than p1 AND rank of r2 + h1 is not
--       smaller than rank of l2 - p2 becomes the root, result of
--       merging r2 with h1 becomes the left child and l2 becomes the
--       right child child.
--
--               p2
--              /  \
--             /    \
--           r2+h1  l2

-- We still use a helper function to get rank of a node
rank : Heap → Nat
rank empty          = zero
rank (node _ r _ _) = r

-- Note [Compacting merge]
-- ~~~~~~~~~~~~~~~~~~~~~~~
--
-- To make implementation of merge slighty shorter we check which
-- priority is higher and at the same time we compute relation between
-- ranks of new possible subtrees (l1, r1 + h2 and l2, r2 + h1).
-- Depending on result of comparing p1 with p2 we will only need to
-- know one of this relations:
--
--   1) if priority p1 is higher than p2 then we need to know whether
--      l1 ≥ r1 + h2
--
--   2) if priority p2 is higher than p1 then we need to know whether
--      l2 ≥ r2 + h1
--
-- Computing these relations at once allows us to reduce code
-- verbosity at the price of doing some extra computations. In a
-- practical application we would most likely prefer performance over
-- code readibility, but I believe that for demonstration purposes it
-- is better to have shorter code.

merge : {i j : Size} → Heap {i} → Heap {j} → Heap
merge empty h2 = h2 -- See [Single-pass merging algorithm]
merge h1 empty = h1
merge (node p1 w1 l1 r1) (node p2 w2 l2 r2)
  with p1 < p2 -- See [Compacting merge]
  | rank l1 ≥ rank r1 + w2
  | rank l2 ≥ rank r2 + w1
merge (node p1 w1 l1 r1) (node p2 w2 l2 r2)
  | true | true | _   = node p1 (w1 + w2) l1 (merge r1 (node p2 w2 l2 r2))
merge (node p1 w1 l1 r1) (node p2 w2 l2 r2)
  | true | false | _  = node p1 (w1 + w2) (merge r1 (node p2 w2 l2 r2)) l1
merge (node p1 w1 l1 r1) (node p2 w2 l2 r2)
  | false | _ | true  = node p2 (w1 + w2) l2 (merge r2 (node p1 w1 l1 r1))
merge (node p1 w1 l1 r1) (node p2 w2 l2 r2)
  | false | _ | false = node p2 (w1 + w2) (merge r2 (node p1 w1 l1 r1)) l2


------------------------------------------------------------------------
-- The delay monad quotiented by weak bisimilarity
------------------------------------------------------------------------

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

module Partiality-monad.Coinductive where

open import Equality.Propositional.Cubical
open import Prelude hiding (⊥)
open import Prelude.Size

open import H-level.Truncation.Propositional equality-with-paths
open import Quotient equality-with-paths

open import Delay-monad
open import Delay-monad.Bisimilarity

-- The partiality monad, defined as the delay monad quotiented by
-- (propositionally truncated) weak bisimilarity.

_⊥ : ∀ {a} → Type a → Type a
A ⊥ = Delay A ∞ / λ x y → ∥ x ≈ y ∥

-- The partiality monad is a set.

⊥-is-set : ∀ {a} {A : Type a} → Is-set (A ⊥)
⊥-is-set = /-is-set


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

open import Cubical.Core.Everything
open import Cubical.Relation.Binary.Raw

module Cubical.Relation.Binary.Raw.Construct.StrictToNonStrict
  {a ℓ} {A : Type a}
  (_<_ : RawRel A ℓ)
  where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Function

open import Cubical.Data.Prod
open import Cubical.Data.Sum.Base renaming (rec to ⊎-rec)
open import Cubical.Data.Empty renaming (elim to ⊥-elim) using ()
open import Cubical.Relation.Binary.Raw.Properties
open import Cubical.Relation.Nullary

------------------------------------------------------------------------
-- Conversion

-- _<_ can be turned into _≤_ as follows:

_≤_ : RawRel A _
x ≤ y = (x < y) ⊎ (x ≡ y)

------------------------------------------------------------------------
-- The converted relations have certain properties
-- (if the original relations have certain other properties)

≤-isPropValued : isSet A → isPropValued _<_ → Irreflexive _<_ → isPropValued _≤_
≤-isPropValued isSetA propv irrefl x y (inl p) (inl q) = cong inl (propv x y p q)
≤-isPropValued isSetA propv irrefl x y (inl p) (inr q) = ⊥-elim (irrefl→tonoteq _<_ irrefl p q)
≤-isPropValued isSetA propv irrefl x y (inr p) (inl q) = ⊥-elim (irrefl→tonoteq _<_ irrefl q p)
≤-isPropValued isSetA propv irrefl x y (inr p) (inr q) = cong inr (isSetA x y p q)

<⇒≤ : _<_ ⇒ _≤_
<⇒≤ = inl

≤-fromEq : FromEq _≤_
≤-fromEq = inr

≤-reflexive : Reflexive _≤_
≤-reflexive = fromeq→reflx _≤_ ≤-fromEq

≤-antisym : Transitive _<_ → Irreflexive _<_ → Antisymmetric _≤_
≤-antisym transitive irrefl (inl x<y) (inl y<x) = ⊥-elim (trans∧irr→asym _<_ transitive irrefl x<y y<x)
≤-antisym _ _ _ (inr y≡x) = sym y≡x
≤-antisym _ _ (inr x≡y) _ = x≡y

≤-transitive : Transitive _<_ → Transitive _≤_
≤-transitive <-trans (inl x<y) (inl y<z) = inl $ <-trans x<y y<z
≤-transitive _       (inl x<y) (inr y≡z) = inl $ Respectsʳ≡ _<_ y≡z x<y
≤-transitive _       (inr x≡y) (inl y<z) = inl $ Respectsˡ≡ _<_ (sym x≡y) y<z
≤-transitive _       (inr x≡y) (inr y≡z) = inr $ x≡y ∙ y≡z

<-≤-trans : Transitive _<_ → Trans _<_ _≤_ _<_
<-≤-trans transitive x<y (inl y<z) = transitive x<y y<z
<-≤-trans transitive x<y (inr y≡z) = Respectsʳ≡ _<_ y≡z x<y

≤-<-trans : Transitive _<_ → Trans _≤_ _<_ _<_
≤-<-trans transitive (inl x<y) y<z = transitive x<y y<z
≤-<-trans transitive (inr x≡y) y<z = Respectsˡ≡ _<_ (sym x≡y) y<z

≤-total : Trichotomous _<_ → Total _≤_
≤-total <-tri x y with <-tri x y
... | tri< x<y x≢y x≯y = inl (inl x<y)
... | tri≡ x≮y x≡y x≯y = inl (inr x≡y)
... | tri> x≮y x≢y x>y = inr (inl x>y)

≤-decidable : Discrete A → Decidable _<_ → Decidable _≤_
≤-decidable _≟_ _<?_ x y with x ≟ y
... | yes p = yes (inr p)
... | no ¬p with x <? y
...     | yes q = yes (inl q)
...     | no ¬q = no (⊎-rec ¬q ¬p)

≤-decidable′ : Trichotomous _<_ → Decidable _≤_
≤-decidable′ compare x y with compare x y
... | tri< x<y _   _ = yes (inl x<y)
... | tri≡ _   x≡y _ = yes (inr x≡y)
... | tri> x≮y x≢y _ = no (⊎-rec x≮y x≢y)

------------------------------------------------------------------------
-- Converting structures

isPreorder : Transitive _<_ → IsPreorder _≤_
isPreorder transitive = record
  { reflexive  = ≤-reflexive
  ; transitive = ≤-transitive transitive
  }

isPartialOrder : IsStrictPartialOrder _<_ → IsPartialOrder _≤_
isPartialOrder spo = record
  { isPreorder = isPreorder S.transitive
  ; antisym    = ≤-antisym S.transitive S.irrefl
  }
  where module S = IsStrictPartialOrder spo

isTotalOrder : IsStrictTotalOrder _<_ → IsTotalOrder _≤_
isTotalOrder sto = record
  { isPartialOrder = isPartialOrder S.isStrictPartialOrder
  ; total          = λ x y → ∣ ≤-total S.compare x y ∣
  }
  where module S = IsStrictTotalOrder sto

isDecTotalOrder : IsStrictTotalOrder _<_ → IsDecTotalOrder _≤_
isDecTotalOrder sto = record
  { isTotalOrder = isTotalOrder sto
  ; _≤?_         = ≤-decidable′ S.compare
  }
  where module S = IsStrictTotalOrder sto


----------------------------------------------------------------------
-- Copyright: 2013, Jan Stolarek, Lodz University of Technology     --
--                                                                  --
-- License: See LICENSE file in root of the repo                    --
-- Repo address: https://github.com/jstolarek/dep-typed-wbl-heaps   --
--                                                                  --
-- Definition of Bool datatype, which represents logical true and   --
-- false.                                                           --
----------------------------------------------------------------------

module Basics.Bool where

data Bool : Set where
  false : Bool
  true  : Bool


module Issue512 where

postulate
  Level : Set

{-# BUILTIN LEVEL Level #-}

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

{-# BUILTIN EQUALITY _≡_ #-}
{-# BUILTIN REFL refl #-}

data A : Set where
  a b : A

proof : a ≡ a
proof = refl

f : A → A → A
f x y rewrite proof = ? -- gave error below (now complains about LEVELZERO instead of STRING)

{-
{-
No binding for builtin thing STRING, use {-# BUILTIN STRING name
#-} to bind it to 'name'
when checking that the type of the generated with function
(w : A) → _≡_ {"Max []"} {A} w w → (x y : A) → A is well-formed
-}
-}


module DenotCommutes where

open import Prelude
open import T

---- Proof that dynamic semantics commute with denotational semantics

module DenotCommutes where

  -- Proving that the dynamic semantics and the denotational semantics
  -- commute (at least if we are using regular equality as our
  -- equality for interpreted terms) basically requires
  -- extensionality, since we need to show that things at function
  -- type are equal.
  postulate iext : {A : Set}{B : A → Set}{f : ∀ {a} → B a}{g : ∀{a} → B a} →
                   (∀ a → f {a} ≡ g {a}) →
                   _≡_ { A = {a : A} → B a} f g

  postulate ext : {A : Set}{B : A → Set}{f : ∀ a → B a}{g : ∀ a → B a} →
                  (∀ a → f a ≡ g a) → f ≡ g

  -- Show that renaming and substitution commute with denotational semantics
  -- in the appropriate sense. This mirrors a bunch of the machinery in SubstTheory.

  -- Some equality related stuff

  Meaning≡ : ∀ {Γ}(f g : meaningη Γ) → Set
  Meaning≡ f g = ∀ {A} x → f {A} x ≡ g {A} x

  -- These are extensionality like lemmas. I feel like they are usually nicer
  -- to use than actually using extensionality.
  -- They could be proven legitimately but we have ext and I am feeling lazy.
  meaningeq : ∀{Γ A} {f g : meaningη Γ} → Meaning≡ f g → (e : TExp Γ A) →
               meaning e f ≡ meaning e g
  meaningeq eq e = resp (meaning e) (iext (λ B → ext (λ x → eq x)))

  foldeq : ∀{A} {a0 a0' : A} {an an' : Nat} {as as' : Nat → A → A} →
           a0 ≡ a0' →
           ((n : Nat) (x : A) → as n x ≡ as' n x) →
           an ≡ an' →
           NAT.fold a0 as an ≡ NAT.fold a0' as' an'
  foldeq eq0 eqs eqn = resp3 NAT.fold eq0 (ext (λ n → ext (λ a → eqs n a))) eqn

  -- First stuff for renaming, lifting
  meaning-ren-wk : ∀{A B Γ Γ'} → (γ : TRen Γ Γ') →
                   (η : meaningη Γ') →
                   (a : interp A) →
                   (x : B ∈ A :: Γ) →
                   extendη η a (wk γ x) ≡ extendη (λ y → η (γ y)) a x
  meaning-ren-wk γ η a Z = Refl
  meaning-ren-wk γ η a (S x) = Refl

  meaning-ren : ∀{A Γ Γ'} → (γ : TRen Γ Γ') →
                (e : TExp Γ A) →
                (η : meaningη Γ') →
                meaning (ren γ e) η ≡ meaning e (η o γ)
  meaning-ren γ (var x) η = Refl
  meaning-ren γ (Λ e) η =
    ext (λ M →
     meaning-ren (wk γ) e (extendη η M) ≡≡ meaningeq (meaning-ren-wk γ η M) e)
  meaning-ren γ (e $ e') η = resp2 (λ x y → x y) (meaning-ren γ e η) (meaning-ren γ e' η)
  meaning-ren γ zero η = Refl
  meaning-ren γ (suc e) η = resp S (meaning-ren γ e η)
  meaning-ren γ (rec en e0 es) η =
    foldeq
     (meaning-ren γ e0 η)
     (λ _ M → meaning-ren (wk γ) es (extendη η M) ≡≡ meaningeq (meaning-ren-wk γ η M) es)
     (meaning-ren γ en η)

  meaning-sub-lift : ∀{A B Γ Γ'} → (γ : TSubst Γ Γ') →
                     (η : meaningη Γ') →
                     (a : interp A) →
                     (x : B ∈ A :: Γ) →
                     meaning (liftγ γ x) (extendη η a) ≡
                     extendη (λ y → meaning (γ y) η) a x
  meaning-sub-lift γ η a Z = Refl
  meaning-sub-lift γ η a (S x) =
    (meaning-ren S (γ x) (extendη η a)) ≡≡
    resp (meaning (γ x)) (iext (λ C → ext (λ x → Refl)))

  -- Define a notion of how to commute a substitution with a
  -- denotational interpretation
  substMeaning : ∀{A Γ Γ'} → (γ : TSubst Γ Γ') →
                 (f : meaningη Γ → interp A) →
                 (meaningη Γ' → interp A)
  substMeaning γ f η = f (λ x → meaning (γ x) η)

  -- And show that that notion actually does commute with it.
  meaning-sub : ∀{A Γ Γ'} → (γ : TSubst Γ Γ') →
                (e : TExp Γ A) →
                (η : meaningη Γ') →
                meaning (ssubst γ e) η ≡ substMeaning γ (meaning e) η
  meaning-sub γ (var x) η = Refl
  meaning-sub γ (Λ e) η =
    ext (λ M →
      meaning-sub (liftγ γ) e (extendη η M) ≡≡ meaningeq (meaning-sub-lift γ η M) e)
  meaning-sub γ (e $ e') η = resp2 (λ x y → x y) (meaning-sub γ e η) (meaning-sub γ e' η)
  meaning-sub γ zero η = Refl
  meaning-sub γ (suc e) η = resp S (meaning-sub γ e η)
  meaning-sub γ (rec en e0 es) η =
   foldeq
   (meaning-sub γ e0 η)
   (λ _ M → meaning-sub (liftγ γ) es (extendη η M) ≡≡ meaningeq (meaning-sub-lift γ η M) es)
   (meaning-sub γ en η)

  -- Easy lemma about singleton contexts
  meaning-sing : ∀{A B}(e' : TCExp B) →
                 (x : A ∈ [ B ]) →
                 meaning (singγ e' x) emptyη ≡ extendη emptyη (meaning e' emptyη) x
  meaning-sing e Z = Refl
  meaning-sing e (S x) = Refl

  -- The basic fact we need about substitution.
  meaning-subst : ∀{A B}(e' : TCExp B)(e : TExp [ B ] A) →
                  meaning e (extendη emptyη (cmeaning e')) ≡
                  cmeaning (subst e' e)
  meaning-subst e' e =
    symm (meaning-sub (singγ e') e emptyη ≡≡
          resp (meaning e) (iext (λ A → ext (λ x → meaning-sing e' x))))

  -- The main theorem about the dynamic semantics
  meaning-steps : ∀{A}{e e' : TCExp A} → (e ~> e') → cmeaning e ≡ cmeaning e'
  meaning-steps {e = e₁ $ e₂} (step-app-l St) =
         resp (λ f → f (meaning e₂ emptyη)) (meaning-steps St)
  meaning-steps {e = (Λ e₁) $ e₂} step-beta = meaning-subst e₂ e₁
  meaning-steps (step-suc St) = resp S (meaning-steps St)
  meaning-steps {e = rec e e₀ es} (step-rec St) =
         resp (λ e' → NAT.fold (meaning e₀ emptyη)
                        (λ n x → meaning es (extendη emptyη x)) e')
              (meaning-steps St)
  meaning-steps step-rec-z = Refl
  meaning-steps {e = rec (suc e) e₀ es} (step-rec-s _) = meaning-subst (rec e e₀ es) es

  meaning-eval : ∀{A}{e e' : TCExp A} → (e ~>* e') → cmeaning e ≡ cmeaning e'
  meaning-eval eval-refl = Refl
  meaning-eval (eval-cons S1 E) = meaning-steps S1 ≡≡ meaning-eval E

open DenotCommutes public


-- Andreas, 2018-08-14, issue #3176, reported by identicalsnowflake
--
-- Absurd lambdas should be equal.
-- In this case, they were only considered equal during give, but not upon reload.

open import Agda.Builtin.Nat renaming (Nat to ℕ)
open import Agda.Builtin.Equality

record Σ (A : Set) (B : A → Set) : Set where
  constructor _,_
  field
    proj₁ : A
    proj₂ : B proj₁

open Σ public

∃ : ∀ {A : Set} → (A → Set) → Set
∃ = Σ _

_×_ : ∀ _ _ → _
_×_ a b = ∃ λ (_ : a) → b

record Fin (n : ℕ) : Set where
  field
    m : ℕ
    .p : ∃ λ k → (ℕ.suc k + m) ≡ n

module _ (n : ℕ) where

  data S : Set where
    V : S
    K : Fin n → S
    _X_ : S → S → S

[_] : ∀ {n} → S n → (Fin n → Set) → Set → Set
[ V       ] k t = t
[ K i     ] k _ = k i
[ s₁ X s₂ ] k t = [ s₁ ] k t × [ s₂ ] k t

postulate
  ignore : ∀ {t : Set} → t

_<*>_ : ∀ {s : S 0} {t₁ t₂}
  → [ s ] (λ ()) (t₁ → t₂)
  → [ s ] (λ ()) t₁
  → [ s ] (λ ()) t₂
_<*>_ {s₁ X s₂} {t₁} {t₂} (f , _) (x , _) =
  let v : [ s₁ ] (λ ()) t₂
      v = _<*>_ {s = s₁} {t₁ = t₁} {t₂ = t₂} f x
  in
  ignore
_<*>_ f x = ignore

-- Should succeed.


------------------------------------------------------------------------
-- Some examples related to Nat.Wrapper, defined in Cubical Agda
------------------------------------------------------------------------

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

open import Equality.Path as P
open import Prelude hiding (zero; suc; _+_)

open import Bijection equality-with-J using (_↔_)

module Nat.Wrapper.Cubical
  -- The underlying representation of natural numbers.
  (Nat′ : Type)
  -- A bijection between this representation and the unary natural
  -- numbers.
  (Nat′↔ℕ : Nat′ ↔ ℕ)
  where

open import Equality.Path.Univalence
open import Logical-equivalence using (_⇔_)

import Equivalence equality-with-J as Eq
open import Erased.Cubical equality-with-paths
open import Function-universe equality-with-J as F hiding (_∘_)
open import H-level equality-with-J
open import H-level.Closure equality-with-J
open import H-level.Truncation.Propositional equality-with-paths
  as Trunc
import Nat equality-with-J as Nat
import Univalence-axiom equality-with-J as U

open import Nat.Wrapper equality-with-J Nat′ Nat′↔ℕ as NW
open NW.[]-cong instance-of-[]-cong-axiomatisation

private
  variable
    A   : Type
    m n : A

------------------------------------------------------------------------
-- Could Nat have been defined using the propositional truncation
-- instead of Erased?

-- Could Nat have been defined using ∥_∥ instead of Erased? Let us
-- try.

-- Given a truncated natural number we can kind of apply Nat-[_] to
-- it, because Nat-[_] is a family of contractible types. (The code
-- uses univalence.)

Nat-[]′ : ∥ ℕ ∥ → ∃ λ (A : Type) → Contractible A
Nat-[]′ = Trunc.rec
  (U.∃-H-level-H-level-1+ ext univ 0)
  (λ n → Nat-[ n ]
       , propositional⇒inhabited⇒contractible
           Nat-[]-propositional
           ( _↔_.from Nat′↔ℕ n
           , [ _↔_.right-inverse-of Nat′↔ℕ n ]
           ))

Nat-[_]′ : ∥ ℕ ∥ → Type
Nat-[ n ]′ = proj₁ (Nat-[]′ n)

-- Thus we can form a variant of Nat.

Nat-with-∥∥ : Type
Nat-with-∥∥ = Σ ∥ ℕ ∥ Nat-[_]′

-- However, this variant is isomorphic to the unit type.

Nat-with-∥∥↔⊤ : Nat-with-∥∥ ↔ ⊤
Nat-with-∥∥↔⊤ =
  _⇔_.to contractible⇔↔⊤ $
  Σ-closure 0
    (propositional⇒inhabited⇒contractible
       truncation-is-proposition ∣ 0 ∣)
    (proj₂ ∘ Nat-[]′)

-- And thus it is not isomorphic to the natural numbers.

¬-Nat-with-∥∥↔ℕ : ¬ (Nat-with-∥∥ ↔ ℕ)
¬-Nat-with-∥∥↔ℕ =
  Nat-with-∥∥ ↔ ℕ  ↝⟨ F._∘ inverse Nat-with-∥∥↔⊤ ⟩
  ⊤ ↔ ℕ            ↝⟨ (λ hyp → _↔_.injective (inverse hyp) refl) ⟩
  0 ≡ 1            ↝⟨ Nat.0≢+ ⟩□
  ⊥                □

------------------------------------------------------------------------
-- Addition of "wrapped" numbers is commutative and associative

module _ (o : Operations) where

  open Operations-for-Nat o
  open Operations-for-Nat-correct o

  private

    -- A lemma used several times below.

    from[to+to]≡+ :
      ∀ m →
      _↔_.from Nat↔ℕ (_↔_.to Nat↔ℕ m Prelude.+ _↔_.to Nat↔ℕ n) ≡ m + n
    from[to+to]≡+ {n = n} m =
      _↔_.from Nat↔ℕ (_↔_.to Nat↔ℕ m Prelude.+ _↔_.to Nat↔ℕ n)  ≡⟨ cong (_↔_.from Nat↔ℕ) $ sym $ to-ℕ-+ m n ⟩
      _↔_.from Nat↔ℕ (_↔_.to Nat↔ℕ (m + n))                     ≡⟨ _↔_.left-inverse-of Nat↔ℕ _ ⟩∎
      m + n                                                     ∎

  -- First two "traditional" proofs.

  -- Addition is commutative.

  +-comm-traditional : ∀ m {n} → m + n ≡ n + m
  +-comm-traditional m {n = n} =
    m + n                                                     ≡⟨ sym $ from[to+to]≡+ m ⟩
    _↔_.from Nat↔ℕ (_↔_.to Nat↔ℕ m Prelude.+ _↔_.to Nat↔ℕ n)  ≡⟨ cong (_↔_.from Nat↔ℕ) $ Nat.+-comm (_↔_.to Nat↔ℕ m) ⟩
    _↔_.from Nat↔ℕ (_↔_.to Nat↔ℕ n Prelude.+ _↔_.to Nat↔ℕ m)  ≡⟨ from[to+to]≡+ n ⟩∎
    n + m                                                     ∎

  -- Addition is associative.

  +-assoc-traditional : ∀ m {n o} → m + (n + o) ≡ (m + n) + o
  +-assoc-traditional m {n = n} {o = o} =
    m + (n + o)                                                     ≡⟨ cong (m +_) $ sym $ from[to+to]≡+ n ⟩

    m + (_↔_.from Nat↔ℕ (_↔_.to Nat↔ℕ n Prelude.+ _↔_.to Nat↔ℕ o))  ≡⟨ sym $ from[to+to]≡+ m ⟩

    _↔_.from Nat↔ℕ (_↔_.to Nat↔ℕ m
                      Prelude.+
                    _↔_.to Nat↔ℕ (_↔_.from Nat↔ℕ
                      (_↔_.to Nat↔ℕ n Prelude.+ _↔_.to Nat↔ℕ o)))   ≡⟨ cong (λ n → _↔_.from Nat↔ℕ (_↔_.to Nat↔ℕ m Prelude.+ n)) $
                                                                       _↔_.right-inverse-of Nat↔ℕ _ ⟩
    _↔_.from Nat↔ℕ
      (_↔_.to Nat↔ℕ m
         Prelude.+
       (_↔_.to Nat↔ℕ n Prelude.+ _↔_.to Nat↔ℕ o))                   ≡⟨ cong (_↔_.from Nat↔ℕ) $ Nat.+-assoc (_↔_.to Nat↔ℕ m) ⟩

    _↔_.from Nat↔ℕ
      ((_↔_.to Nat↔ℕ m Prelude.+ _↔_.to Nat↔ℕ n)
         Prelude.+
       _↔_.to Nat↔ℕ o)                                              ≡⟨ cong (λ n → _↔_.from Nat↔ℕ (n Prelude.+ _↔_.to Nat↔ℕ o)) $ sym $
                                                                       _↔_.right-inverse-of Nat↔ℕ _ ⟩
    _↔_.from Nat↔ℕ
      (_↔_.to Nat↔ℕ (_↔_.from Nat↔ℕ
         (_↔_.to Nat↔ℕ m Prelude.+ _↔_.to Nat↔ℕ n))
         Prelude.+
       _↔_.to Nat↔ℕ o)                                              ≡⟨ from[to+to]≡+ (_↔_.from Nat↔ℕ (_↔_.to Nat↔ℕ m Prelude.+ _↔_.to Nat↔ℕ n)) ⟩

    (_↔_.from Nat↔ℕ (_↔_.to Nat↔ℕ m Prelude.+ _↔_.to Nat↔ℕ n)) + o  ≡⟨ cong (_+ o) $ from[to+to]≡+ {n = n} m ⟩∎

    (m + n) + o                                                     ∎

  -- The following proofs are instead based on a technique used by
  -- Vezzosi, Mörtberg and Abel in "Cubical Agda: A Dependently Typed
  -- Programming Language with Univalence and Higher Inductive Types".

  -- The type of unary natural numbers is equal to the type of wrapped
  -- natural numbers.

  ℕ≡Nat : ℕ ≡ Nat
  ℕ≡Nat = sym (≃⇒≡ (Eq.↔⇒≃ Nat↔ℕ))

  -- Addition of unary natural numbers is, in a certain sense, equal
  -- to addition of wrapped natural numbers.

  +≡+ : P.[ (λ i → ℕ≡Nat i → ℕ≡Nat i → ℕ≡Nat i) ] Prelude._+_ ≡ _+_
  +≡+ =
    Prelude._+_                                                         ≡⟨ (λ i → transport
                                                                                (λ j → ℕ≡Nat (min i j) → ℕ≡Nat (min i j) → ℕ≡Nat (min i j))
                                                                                (- i) Prelude._+_) ⟩h
    transport (λ i → ℕ≡Nat i → ℕ≡Nat i → ℕ≡Nat i) 0̲ Prelude._+_         ≡⟨⟩
    (λ m n → _↔_.from Nat↔ℕ (_↔_.to Nat↔ℕ m Prelude.+ _↔_.to Nat↔ℕ n))  ≡⟨ (⟨ext⟩ λ m → ⟨ext⟩ λ _ → from[to+to]≡+ m) ⟩∎
    _+_                                                                 ∎

  -- Addition is commutative.

  +-comm-cubical : ∀ m {n} → m + n ≡ n + m
  +-comm-cubical =
    transport
      (λ i → (m {n} : ℕ≡Nat i) → +≡+ i m n ≡ +≡+ i n m)
      0̲
      Nat.+-comm

  -- Addition is associative.

  +-assoc-cubical : ∀ m {n o} → m + (n + o) ≡ (m + n) + o
  +-assoc-cubical =
    transport
      (λ i → (m {n o} : ℕ≡Nat i) →
             +≡+ i m (+≡+ i n o) ≡ +≡+ i (+≡+ i m n) o)
      0̲
      Nat.+-assoc

  -- This proof technique seems to scale better than the one used
  -- above, at least for examples of the kind used here.


-- Andreas, 2016-07-13, issue reported by Mietek Bak

-- {-# OPTIONS -v tc.size:20  #-}
-- {-# OPTIONS -v tc.meta.assign:30 #-}

open import Agda.Builtin.Size

data Cx (U : Set) : Set where
  ⌀   : Cx U
  _,_ : Cx U → U → Cx U

data _∈_ {U : Set} (A : U) : Cx U → Set where
  top : ∀ {Γ} → A ∈ (Γ , A)
  pop : ∀ {C Γ} → A ∈ Γ → A ∈ (Γ , C)

infixr 3 _⊃_
data Ty : Set where
  ι   : Ty
  _⊃_ : Ty → Ty → Ty

infix 1 _⊢⟨_⟩_
data _⊢⟨_⟩_ (Γ : Cx Ty) : Size → Ty → Set where
  var : ∀ {m A}                     → A ∈ Γ → Γ ⊢⟨ m ⟩ A
  lam : ∀ {m A B} {m′ : Size< m}    → Γ , A ⊢⟨ m′ ⟩ B → Γ ⊢⟨ m ⟩ A ⊃ B
  app : ∀ {m A B} {m′ m″ : Size< m} → Γ ⊢⟨ m′ ⟩ A ⊃ B → Γ ⊢⟨ m″ ⟩ A → Γ ⊢⟨ m ⟩ B

works : ∀ {m A B Γ} → Γ ⊢⟨ ↑ ↑ ↑ ↑ m ⟩ (A ⊃ A ⊃ B) ⊃ A ⊃ B
works = lam (lam (app (app (var (pop top)) (var top)) (var top)))

test : ∀ {m A B Γ} → Γ ⊢⟨ {!↑ ↑ ↑ ↑ m!} ⟩ (A ⊃ A ⊃ B) ⊃ A ⊃ B
test = lam (lam (app (app (var (pop top)) (var top)) (var top)))

-- This interaction meta should be solvable with
--   ↑ ↑ ↑ ↑ m
-- Give should succeed.
-- The problem was: premature instantiation to ∞.


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

module Data.List.Syntax where

open import Data.List
open import Prelude

record ListSyntax {a b} (A : Type a) (B : Type b) : Type (a ℓ⊔ b) where
  field [_] : B → List A

open ListSyntax ⦃ ... ⦄ public

instance
  cons : ⦃ _ : ListSyntax A B ⦄ →  ListSyntax A (A × B)
  [_] ⦃ cons ⦄ (x , xs) = x ∷ [ xs ]

instance
  sing : ListSyntax A A
  [_] ⦃ sing ⦄ = _∷ []


-- Opening this module allows lists to be written using "list notation".
-- Examples:
--   []            = ∅
--   [ a ]         = a ⊰ ∅
--   [ a , b ]     = a ⊰ b ⊰ ∅
--   [ a , b , c ] = a ⊰ b ⊰ c ⊰ ∅
module Syntax.List where

open import Data.List

{-
infixl 1      [_
infixr 1000   _,_
infixl 100000 _]

pattern []      = ∅
pattern [_ l    = l
pattern _,_ x l = x ⊰ l
pattern _] x    = x ⊰ ∅
-}

pattern []                                             = ∅
pattern [_]                 x₁                         = x₁ ⊰ ∅
pattern [_,_]               x₁ x₂                      = x₁ ⊰ x₂ ⊰ ∅
pattern [_,_,_]             x₁ x₂ x₃                   = x₁ ⊰ x₂ ⊰ x₃ ⊰ ∅
pattern [_,_,_,_]           x₁ x₂ x₃ x₄                = x₁ ⊰ x₂ ⊰ x₃ ⊰ x₄ ⊰ ∅
pattern [_,_,_,_,_]         x₁ x₂ x₃ x₄ x₅             = x₁ ⊰ x₂ ⊰ x₃ ⊰ x₄ ⊰ x₅ ⊰ ∅
pattern [_,_,_,_,_,_]       x₁ x₂ x₃ x₄ x₅ x₆          = x₁ ⊰ x₂ ⊰ x₃ ⊰ x₄ ⊰ x₅ ⊰ x₆ ⊰ ∅
pattern [_,_,_,_,_,_,_]     x₁ x₂ x₃ x₄ x₅ x₆ x₇       = x₁ ⊰ x₂ ⊰ x₃ ⊰ x₄ ⊰ x₅ ⊰ x₆ ⊰ x₇ ⊰ ∅
pattern [_,_,_,_,_,_,_,_]   x₁ x₂ x₃ x₄ x₅ x₆ x₇ x₈    = x₁ ⊰ x₂ ⊰ x₃ ⊰ x₄ ⊰ x₅ ⊰ x₆ ⊰ x₇ ⊰ x₈ ⊰ ∅
pattern [_,_,_,_,_,_,_,_,_] x₁ x₂ x₃ x₄ x₅ x₆ x₇ x₈ x₉ = x₁ ⊰ x₂ ⊰ x₃ ⊰ x₄ ⊰ x₅ ⊰ x₆ ⊰ x₇ ⊰ x₈ ⊰ x₉ ⊰ ∅