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

open import lib.Base
open import lib.PathGroupoid
open import lib.PathOver

module lib.cubical.Square where

{-
  *--1--*
  |     |
  0     3
  |     |
  *--2--*
-}

data Square {i} {A : Type i} {a₀₀ : A} : {a₀₁ a₁₀ a₁₁ : A}
  → a₀₀ == a₀₁ → a₀₀ == a₁₀ → a₀₁ == a₁₁ → a₁₀ == a₁₁ → Type i
  where
  ids : Square idp idp idp idp

hid-square : ∀ {i} {A : Type i} {a₀₀ a₀₁ : A} {p : a₀₀ == a₀₁}
  → Square p idp idp p
hid-square {p = idp} = ids

vid-square : ∀ {i} {A : Type i} {a₀₀ a₁₀ : A} {p : a₀₀ == a₁₀}
  → Square idp p p idp
vid-square {p = idp} = ids

square-to-disc : ∀ {i} {A : Type i} {a₀₀ a₀₁ a₁₀ a₁₁ : A}
  {p₀₋ : a₀₀ == a₀₁} {p₋₀ : a₀₀ == a₁₀} {p₋₁ : a₀₁ == a₁₁} {p₁₋ : a₁₀ == a₁₁}
  → Square p₀₋ p₋₀ p₋₁ p₁₋
  → p₀₋ ∙ p₋₁ == p₋₀ ∙ p₁₋
square-to-disc ids = idp

disc-to-square : ∀ {i} {A : Type i} {a₀₀ a₀₁ a₁₀ a₁₁ : A}
  {p₀₋ : a₀₀ == a₀₁} {p₋₀ : a₀₀ == a₁₀} {p₋₁ : a₀₁ == a₁₁} {p₁₋ : a₁₀ == a₁₁}
  → p₀₋ ∙ p₋₁ == p₋₀ ∙ p₁₋
  → Square p₀₋ p₋₀ p₋₁ p₁₋
disc-to-square {p₀₋ = idp} {p₋₀ = idp} {p₋₁ = idp} {p₁₋ = .idp} idp = ids

square-to-disc-β : ∀ {i} {A : Type i} {a₀₀ a₀₁ a₁₀ a₁₁ : A}
  {p₀₋ : a₀₀ == a₀₁} {p₋₀ : a₀₀ == a₁₀} {p₋₁ : a₀₁ == a₁₁} {p₁₋ : a₁₀ == a₁₁}
  (α : p₀₋ ∙ p₋₁ == p₋₀ ∙ p₁₋)
  → square-to-disc (disc-to-square {p₀₋ = p₀₋} {p₋₀ = p₋₀} α) == α
square-to-disc-β {p₀₋ = idp} {p₋₀ = idp} {p₋₁ = idp} {p₁₋ = .idp} idp = idp

disc-to-square-β : ∀ {i} {A : Type i} {a₀₀ a₀₁ a₁₀ a₁₁ : A}
  {p₀₋ : a₀₀ == a₀₁} {p₋₀ : a₀₀ == a₁₀} {p₋₁ : a₀₁ == a₁₁} {p₁₋ : a₁₀ == a₁₁}
  (sq : Square p₀₋ p₋₀ p₋₁ p₁₋)
  → disc-to-square (square-to-disc sq) == sq
disc-to-square-β ids = idp

ap-square : ∀ {i j} {A : Type i} {B : Type j} (f : A → B)
  {a₀₀ a₀₁ a₁₀ a₁₁ : A}
  {p₀₋ : a₀₀ == a₀₁} {p₋₀ : a₀₀ == a₁₀} {p₋₁ : a₀₁ == a₁₁} {p₁₋ : a₁₀ == a₁₁}
  → Square p₀₋ p₋₀ p₋₁ p₁₋
  → Square (ap f p₀₋) (ap f p₋₀) (ap f p₋₁) (ap f p₁₋)
ap-square f ids = ids

ap-square-hid : ∀ {i j} {A : Type i} {B : Type j} {f : A → B}
  {a₀ a₁ : A} {p : a₀ == a₁}
  → ap-square f (hid-square {p = p}) == hid-square
ap-square-hid {p = idp} = idp

ap-square-vid : ∀ {i j} {A : Type i} {B : Type j} {f : A → B}
  {a₀ a₁ : A} {p : a₀ == a₁}
  → ap-square f (vid-square {p = p}) == vid-square
ap-square-vid {p = idp} = idp

module _ {i} {A : Type i} where

  horiz-degen-square : {a a' : A} {p q : a == a'}
    → p == q → Square p idp idp q
  horiz-degen-square {p = idp} α = disc-to-square α

  horiz-degen-path : {a a' : A} {p q : a == a'}
    → Square p idp idp q → p == q
  horiz-degen-path {p = idp} sq = square-to-disc sq

  horiz-degen-path-β : {a a' : A} {p q : a == a'} (α : p == q)
    → horiz-degen-path (horiz-degen-square α) == α
  horiz-degen-path-β {p = idp} α = square-to-disc-β α

  horiz-degen-square-β : {a a' : A} {p q : a == a'} (sq : Square p idp idp q)
    → horiz-degen-square (horiz-degen-path sq) == sq
  horiz-degen-square-β {p = idp} sq = disc-to-square-β sq

  vert-degen-square : {a a' : A} {p q : a == a'}
    → p == q → Square idp p q idp
  vert-degen-square {p = idp} α = disc-to-square (! α)

  vert-degen-path : {a a' : A} {p q : a == a'}
    → Square idp p q idp → p == q
  vert-degen-path {p = idp} sq = ! (square-to-disc sq)

  vert-degen-path-β : {a a' : A} {p q : a == a'} (α : p == q)
    → vert-degen-path (vert-degen-square α) == α
  vert-degen-path-β {p = idp} α = ap ! (square-to-disc-β (! α)) ∙ !-! α

  vert-degen-square-β : {a a' : A} {p q : a == a'} (sq : Square idp p q idp)
    → vert-degen-square (vert-degen-path sq) == sq
  vert-degen-square-β {p = idp} sq =
    ap disc-to-square (!-! (square-to-disc sq)) ∙ disc-to-square-β sq

  horiz-degen-square-idp : {a a' : A} {p : a == a'}
    → horiz-degen-square (idp {a = p}) == hid-square
  horiz-degen-square-idp {p = idp} = idp

  vert-degen-square-idp : {a a' : A} {p : a == a'}
    → vert-degen-square (idp {a = p}) == vid-square
  vert-degen-square-idp {p = idp} = idp

{- Flipping squares -}
module _ {i} {A : Type i} where

  square-symmetry : {a₀₀ a₀₁ a₁₀ a₁₁ : A}
    {p₀₋ : a₀₀ == a₀₁} {p₋₀ : a₀₀ == a₁₀} {p₋₁ : a₀₁ == a₁₁} {p₁₋ : a₁₀ == a₁₁}
    → Square p₀₋ p₋₀ p₋₁ p₁₋ → Square p₋₀ p₀₋ p₁₋ p₋₁
  square-symmetry ids = ids

  square-sym-inv : {a₀₀ a₀₁ a₁₀ a₁₁ : A}
    {p₀₋ : a₀₀ == a₀₁} {p₋₀ : a₀₀ == a₁₀} {p₋₁ : a₀₁ == a₁₁} {p₁₋ : a₁₀ == a₁₁}
    (sq : Square p₀₋ p₋₀ p₋₁ p₁₋)
    → square-symmetry (square-symmetry sq) == sq
  square-sym-inv ids = idp

ap-square-symmetry : ∀ {i j} {A : Type i} {B : Type j} (f : A → B)
  {a₀₀ a₀₁ a₁₀ a₁₁ : A} {p₀₋ : a₀₀ == a₀₁} {p₋₀ : a₀₀ == a₁₀}
  {p₋₁ : a₀₁ == a₁₁} {p₁₋ : a₁₀ == a₁₁}
  (sq : Square p₀₋ p₋₀ p₋₁ p₁₋)
  → ap-square f (square-symmetry sq) == square-symmetry (ap-square f sq)
ap-square-symmetry f ids = idp

{- Alternate induction principles -}

square-left-J : ∀ {i j} {A : Type i} {a₀₀ a₀₁ : A} {p₀₋ : a₀₀ == a₀₁}
  (P : {a₁₀ a₁₁ : A} {p₋₀ : a₀₀ == a₁₀} {p₋₁ : a₀₁ == a₁₁} {p₁₋ : a₁₀ == a₁₁}
       (sq : Square p₀₋ p₋₀ p₋₁ p₁₋)
       → Type j)
  (r : P hid-square)
  {a₁₀ a₁₁ : A} {p₋₀ : a₀₀ == a₁₀} {p₋₁ : a₀₁ == a₁₁} {p₁₋ : a₁₀ == a₁₁}
  (sq : Square p₀₋ p₋₀ p₋₁ p₁₋)
  → P sq
square-left-J P r ids = r

square-top-J : ∀ {i j} {A : Type i} {a₀₀ a₁₀ : A} {p₋₀ : a₀₀ == a₁₀}
  (P : {a₀₁ a₁₁ : A} {p₀₋ : a₀₀ == a₀₁} {p₋₁ : a₀₁ == a₁₁} {p₁₋ : a₁₀ == a₁₁}
       (sq : Square p₀₋ p₋₀ p₋₁ p₁₋)
       → Type j)
  (r : P vid-square)
  {a₀₁ a₁₁ : A} {p₀₋ : a₀₀ == a₀₁} {p₋₁ : a₀₁ == a₁₁} {p₁₋ : a₁₀ == a₁₁}
  (sq : Square p₀₋ p₋₀ p₋₁ p₁₋)
  → P sq
square-top-J P r ids = r

square-bot-J : ∀ {i j} {A : Type i} {a₀₁ a₁₁ : A} {p₋₁ : a₀₁ == a₁₁}
  (P : {a₀₀ a₁₀ : A} {p₀₋ : a₀₀ == a₀₁} {p₋₀ : a₀₀ == a₁₀} {p₁₋ : a₁₀ == a₁₁}
       (sq : Square p₀₋ p₋₀ p₋₁ p₁₋)
       → Type j)
  (r : P vid-square)
  {a₀₀ a₁₀ : A} {p₀₋ : a₀₀ == a₀₁} {p₋₀ : a₀₀ == a₁₀} {p₁₋ : a₁₀ == a₁₁}
  (sq : Square p₀₋ p₋₀ p₋₁ p₁₋)
  → P sq
square-bot-J P r ids = r

square-right-J : ∀ {i j} {A : Type i} {a₁₀ a₁₁ : A} {p₁₋ : a₁₀ == a₁₁}
  (P : {a₀₀ a₀₁ : A} {p₀₋ : a₀₀ == a₀₁} {p₋₀ : a₀₀ == a₁₀} {p₋₁ : a₀₁ == a₁₁}
       (sq : Square p₀₋ p₋₀ p₋₁ p₁₋)
       → Type j)
  (r : P hid-square)
  {a₀₀ a₀₁ : A} {p₀₋ : a₀₀ == a₀₁} {p₋₀ : a₀₀ == a₁₀} {p₋₁ : a₀₁ == a₁₁}
  (sq : Square p₀₋ p₋₀ p₋₁ p₁₋)
  → P sq
square-right-J P r ids = r

module _ where
  private
    lemma : ∀ {i j} {A : Type i} {a₀ : A}
      (P : {a₁ : A} {p q : a₀ == a₁} → p == q → Type j)
      (r : P (idp {a = idp}))
      {a₁ : A} {p q : a₀ == a₁} (α : p == q)
      → P α
    lemma P r {p = idp} idp = r

  horiz-degen-J : ∀ {i j} {A : Type i} {a₀ : A}
    (P : {a₁ : A} {p q : a₀ == a₁} → Square p idp idp q → Type j)
    (r : P ids)
    {a₁ : A} {p q : a₀ == a₁} (sq : Square p idp idp q)
    → P sq
  horiz-degen-J P r sq = transport P
    (horiz-degen-square-β sq)
    (lemma (P ∘ horiz-degen-square) r (horiz-degen-path sq))

  vert-degen-J : ∀ {i j} {A : Type i} {a₀ : A}
    (P : {a₁ : A} {p q : a₀ == a₁} → Square idp p q idp → Type j)
    (r : P ids)
    {a₁ : A} {p q : a₀ == a₁} (sq : Square idp p q idp)
    → P sq
  vert-degen-J P r sq = transport P
    (vert-degen-square-β sq)
    (lemma (P ∘ vert-degen-square) r (vert-degen-path sq))

{- Square filling -}
module _ {i} {A : Type i} where
  fill-square-left : {a₀₀ a₀₁ a₁₀ a₁₁ : A}
    (p₋₀ : a₀₀ == a₁₀) (p₋₁ : a₀₁ == a₁₁) (p₁₋ : a₁₀ == a₁₁)
    → Σ (a₀₀ == a₀₁) (λ p₀₋ → Square p₀₋ p₋₀ p₋₁ p₁₋)
  fill-square-left idp idp p = (p , hid-square)

  fill-square-top : {a₀₀ a₀₁ a₁₀ a₁₁ : A}
    (p₀₋ : a₀₀ == a₀₁) (p₋₁ : a₀₁ == a₁₁) (p₁₋ : a₁₀ == a₁₁)
    → Σ (a₀₀ == a₁₀) (λ p₋₀ → Square p₀₋ p₋₀ p₋₁ p₁₋)
  fill-square-top idp p idp = (p , vid-square)

  fill-square-bot : {a₀₀ a₀₁ a₁₀ a₁₁ : A}
    (p₀₋ : a₀₀ == a₀₁) (p₋₀ : a₀₀ == a₁₀) (p₁₋ : a₁₀ == a₁₁)
    → Σ (a₀₁ == a₁₁) (λ p₋₁ → Square p₀₋ p₋₀ p₋₁ p₁₋)
  fill-square-bot idp p idp = (p , vid-square)

  fill-square-right : {a₀₀ a₀₁ a₁₀ a₁₁ : A}
    (p₀₋ : a₀₀ == a₀₁) (p₋₀ : a₀₀ == a₁₀) (p₋₁ : a₀₁ == a₁₁)
    → Σ (a₁₀ == a₁₁) (λ p₁₋ → Square p₀₋ p₋₀ p₋₁ p₁₋)
  fill-square-right p idp idp = (p , hid-square)

module _ {i j} {A : Type i} {B : Type j} {f g : A → B} where

  ↓-='-to-square : {x y : A} {p : x == y} {u : f x == g x} {v : f y == g y}
    → u == v [ (λ z → f z == g z) ↓ p ]
    → Square u (ap f p) (ap g p) v
  ↓-='-to-square {p = idp} α = horiz-degen-square α

  ↓-='-from-square : {x y : A} {p : x == y} {u : f x == g x} {v : f y == g y}
    → Square u (ap f p) (ap g p) v
    → u == v [ (λ z → f z == g z) ↓ p ]
  ↓-='-from-square {p = idp} sq = horiz-degen-path sq

module _  {i j} {A : Type i} {B : Type j} {f : A → B} {b : B} where

  ↓-cst=app-from-square : {x y : A} {p : x == y}
    {u : b == f x} {v : b == f y}
    → Square u idp (ap f p) v
    → u == v [ (λ z → b == f z) ↓ p ]
  ↓-cst=app-from-square {p = idp} sq = horiz-degen-path sq

  ↓-cst=app-to-square : {x y : A} {p : x == y}
    {u : b == f x} {v : b == f y}
    → u == v [ (λ z → b == f z) ↓ p ]
    → Square u idp (ap f p) v
  ↓-cst=app-to-square {p = idp} α = horiz-degen-square α

  ↓-app=cst-from-square : {x y : A} {p : x == y}
    {u : f x == b} {v : f y == b}
    → Square u (ap f p) idp v
    → u == v [ (λ z → f z == b) ↓ p ]
  ↓-app=cst-from-square {p = idp} sq = horiz-degen-path sq

  ↓-app=cst-to-square : {x y : A} {p : x == y}
    {u : f x == b} {v : f y == b}
    → u == v [ (λ z → f z == b) ↓ p ]
    → Square u (ap f p) idp v
  ↓-app=cst-to-square {p = idp} α = horiz-degen-square α

module _  {i} {A : Type i} {f : A → A} where

  ↓-idf=app-from-square : {x y : A} {p : x == y}
    {u : x == f x} {v : y == f y}
    → Square u p (ap f p) v
    → u == v [ (λ z → z == f z) ↓ p ]
  ↓-idf=app-from-square {p = idp} sq = horiz-degen-path sq

  ↓-idf=app-to-square : {x y : A} {p : x == y}
    {u : x == f x} {v : y == f y}
    → u == v [ (λ z → z == f z) ↓ p ]
    → Square u p (ap f p) v
  ↓-idf=app-to-square {p = idp} α = horiz-degen-square α

  ↓-app=idf-from-square : {x y : A} {p : x == y}
    {u : f x == x} {v : f y == y}
    → Square u (ap f p) p v
    → u == v [ (λ z → f z == z) ↓ p ]
  ↓-app=idf-from-square {p = idp} sq = horiz-degen-path sq

  ↓-app=idf-to-square : {x y : A} {p : x == y}
    {u : f x == x} {v : f y == y}
    → u == v [ (λ z → f z == z) ↓ p ]
    → Square u (ap f p) p v
  ↓-app=idf-to-square {p = idp} α = horiz-degen-square α

module _  {i j} {A : Type i} {B : Type j} (g : B → A) (f : A → B) where

  ↓-∘=idf-from-square : {x y : A} {p : x == y}
    {u : g (f x) == x} {v : g (f y) == y}
    → Square u (ap g (ap f p)) p v
    → (u == v [ (λ z → g (f z) == z) ↓ p ])
  ↓-∘=idf-from-square {p = idp} sq = horiz-degen-path sq

  ↓-∘=idf-to-square : {x y : A} {p : x == y}
    {u : g (f x) == x} {v : g (f y) == y}
    → (u == v [ (λ z → g (f z) == z) ↓ p ])
    → Square u (ap g (ap f p)) p v
  ↓-∘=idf-to-square {p = idp} α = horiz-degen-square α

module _ {i j} {A : Type i} {B : Type j} where

  natural-square : {f₁ f₂ : A → B} (p : ∀ a → f₁ a == f₂ a)
    {a₁ a₂ : A} (q : a₁ == a₂)
    → Square (p a₁) (ap f₁ q) (ap f₂ q) (p a₂)
  natural-square p idp = hid-square

  natural-square-idp : {f₁ : A → B} {a₁ a₂ : A} (q : a₁ == a₂)
    → natural-square {f₁ = f₁} (λ _ → idp) q == vid-square
  natural-square-idp idp = idp

  {- Used for getting square equivalents of glue-β terms -}
  natural-square-β : {f₁ f₂ : A → B} (p : (a : A) → f₁ a == f₂ a)
    {x y : A} (q : x == y)
    {sq : Square (p x) (ap f₁ q) (ap f₂ q) (p y)}
    → apd p q == ↓-='-from-square sq
    → natural-square p q == sq
  natural-square-β _ idp α =
    ! horiz-degen-square-idp ∙ ap horiz-degen-square α ∙ horiz-degen-square-β _

_⊡v_ : ∀ {i} {A : Type i} {a₀₀ a₀₁ a₁₀ a₁₁ a₀₂ a₁₂ : A}
  {p₀₋ : a₀₀ == a₀₁} {p₋₀ : a₀₀ == a₁₀} {p₋₁ : a₀₁ == a₁₁} {p₁₋ : a₁₀ == a₁₁}
  {q₀₋ : a₀₁ == a₀₂} {q₋₂ : a₀₂ == a₁₂} {q₁₋ : a₁₁ == a₁₂}
  → Square p₀₋ p₋₀ p₋₁ p₁₋ → Square q₀₋ p₋₁ q₋₂ q₁₋
  → Square (p₀₋ ∙ q₀₋) p₋₀ q₋₂ (p₁₋ ∙ q₁₋)
ids ⊡v sq = sq

_⊡v'_ : ∀ {i} {A : Type i} {a₀₀ a₀₁ a₁₀ a₁₁ a₀₂ a₁₂ : A}
  {p₀₋ : a₀₀ == a₀₁} {p₋₀ : a₀₀ == a₁₀} {p₋₁ : a₀₁ == a₁₁} {p₁₋ : a₁₀ == a₁₁}
  {q₀₋ : a₀₁ == a₀₂} {q₋₂ : a₀₂ == a₁₂} {q₁₋ : a₁₁ == a₁₂}
  → Square p₀₋ p₋₀ p₋₁ p₁₋ → Square q₀₋ p₋₁ q₋₂ q₁₋
  → Square (p₀₋ ∙' q₀₋) p₋₀ q₋₂ (p₁₋ ∙' q₁₋)
sq ⊡v' ids = sq

_∙v⊡_ : ∀ {i} {A : Type i} {a₀₀ a₀₁ a₁₀ a₁₁ : A}
  {p₀₋ : a₀₀ == a₀₁} {p₋₀ p₋₀' : a₀₀ == a₁₀}
  {p₋₁ : a₀₁ == a₁₁} {p₁₋ : a₁₀ == a₁₁}
  → p₋₀ == p₋₀'
  → Square p₀₋ p₋₀' p₋₁ p₁₋
  → Square p₀₋ p₋₀ p₋₁ p₁₋
idp ∙v⊡ sq = sq

_⊡v∙_ : ∀ {i} {A : Type i} {a₀₀ a₀₁ a₁₀ a₁₁ : A}
  {p₋₀ : a₀₀ == a₁₀} {p₀₋ : a₀₀ == a₀₁}
  {p₋₁ p₋₁' : a₀₁ == a₁₁} {p₁₋ : a₁₀ == a₁₁}
  → Square p₀₋ p₋₀ p₋₁ p₁₋
  → p₋₁ == p₋₁'
  → Square p₀₋ p₋₀ p₋₁' p₁₋
sq ⊡v∙ idp = sq

_⊡h_ : ∀ {i} {A : Type i} {a₀₀ a₀₁ a₁₀ a₁₁ a₂₀ a₂₁ : A}
  {p₀₋ : a₀₀ == a₀₁} {p₋₀ : a₀₀ == a₁₀} {p₋₁ : a₀₁ == a₁₁} {p₁₋ : a₁₀ == a₁₁}
  {q₋₀ : a₁₀ == a₂₀} {q₋₁ : a₁₁ == a₂₁} {q₂₋ : a₂₀ == a₂₁}
  → Square p₀₋ p₋₀ p₋₁ p₁₋
  → Square p₁₋ q₋₀ q₋₁ q₂₋
  → Square p₀₋ (p₋₀ ∙ q₋₀) (p₋₁ ∙ q₋₁) q₂₋
ids ⊡h sq = sq

_⊡h'_ : ∀ {i} {A : Type i} {a₀₀ a₀₁ a₁₀ a₁₁ a₂₀ a₂₁ : A}
  {p₀₋ : a₀₀ == a₀₁} {p₋₀ : a₀₀ == a₁₀} {p₋₁ : a₀₁ == a₁₁} {p₁₋ : a₁₀ == a₁₁}
  {q₋₀ : a₁₀ == a₂₀} {q₋₁ : a₁₁ == a₂₁} {q₂₋ : a₂₀ == a₂₁}
  → Square p₀₋ p₋₀ p₋₁ p₁₋
  → Square p₁₋ q₋₀ q₋₁ q₂₋
  → Square p₀₋ (p₋₀ ∙' q₋₀) (p₋₁ ∙' q₋₁) q₂₋
sq ⊡h' ids = sq

_∙h⊡_ : ∀ {i} {A : Type i} {a₀₀ a₀₁ a₁₀ a₁₁ : A}
  {p₀₋ p₀₋' : a₀₀ == a₀₁} {p₋₀ : a₀₀ == a₁₀}
  {p₋₁ : a₀₁ == a₁₁} {p₁₋ : a₁₀ == a₁₁}
  → p₀₋ == p₀₋'
  → Square p₀₋' p₋₀ p₋₁ p₁₋
  → Square p₀₋ p₋₀ p₋₁ p₁₋
idp ∙h⊡ sq = sq

_⊡h∙_ : ∀ {i} {A : Type i} {a₀₀ a₀₁ a₁₀ a₁₁ : A}
  {p₀₋ : a₀₀ == a₀₁} {p₋₀ : a₀₀ == a₁₀}
  {p₋₁ : a₀₁ == a₁₁} {p₁₋ p₁₋' : a₁₀ == a₁₁}
  → Square p₀₋ p₋₀ p₋₁ p₁₋
  → p₁₋ == p₁₋'
  → Square p₀₋ p₋₀ p₋₁ p₁₋'
sq ⊡h∙ idp = sq

infixr 80 _⊡v_ _⊡v'_ _⊡h_ _⊡h'_

infixr 80 _∙v⊡_ _∙h⊡_
infixl 85 _⊡v∙_ _⊡h∙_

module _ {i} {A : Type i} where
  !□h : {a₀₀ a₀₁ a₁₀ a₁₁ : A}
    {p₀₋ : a₀₀ == a₀₁} {p₋₀ : a₀₀ == a₁₀}
    {p₋₁ : a₀₁ == a₁₁} {p₁₋ : a₁₀ == a₁₁}
    → Square p₀₋ p₋₀ p₋₁ p₁₋
    → Square p₁₋ (! p₋₀) (! p₋₁) p₀₋
  !□h ids = ids

  !□v : {a₀₀ a₀₁ a₁₀ a₁₁ : A}
    {p₀₋ : a₀₀ == a₀₁} {p₋₀ : a₀₀ == a₁₀}
    {p₋₁ : a₀₁ == a₁₁} {p₁₋ : a₁₀ == a₁₁}
    → Square p₀₋ p₋₀ p₋₁ p₁₋
    → Square (! p₀₋) p₋₁ p₋₀ (! p₁₋)
  !□v ids = ids

module _ {i} {A : Type i} where

  {- TODO rest of these -}

  ⊡h-unit-l : {a₀₀ a₀₁ a₁₀ a₁₁ : A}
    {p₀₋ : a₀₀ == a₀₁} {p₋₀ : a₀₀ == a₁₀} {p₋₁ : a₀₁ == a₁₁} {p₁₋ : a₁₀ == a₁₁}
    (sq : Square p₀₋ p₋₀ p₋₁ p₁₋)
    → hid-square ⊡h sq == sq
  ⊡h-unit-l ids = idp

  ⊡h-unit-r : {a₀₀ a₀₁ a₁₀ a₁₁ : A}
    {p₀₋ : a₀₀ == a₀₁} {p₋₀ : a₀₀ == a₁₀} {p₋₁ : a₀₁ == a₁₁} {p₁₋ : a₁₀ == a₁₁}
    (sq : Square p₀₋ p₋₀ p₋₁ p₁₋)
    → sq ⊡h hid-square == ∙-unit-r _ ∙v⊡ (sq ⊡v∙ ! (∙-unit-r _))
  ⊡h-unit-r ids = idp

  ⊡h'-unit-l : {a₀₀ a₀₁ a₁₀ a₁₁ : A}
    {p₀₋ : a₀₀ == a₀₁} {p₋₀ : a₀₀ == a₁₀} {p₋₁ : a₀₁ == a₁₁} {p₁₋ : a₁₀ == a₁₁}
    (sq : Square p₀₋ p₋₀ p₋₁ p₁₋)
    → hid-square ⊡h' sq == ∙'-unit-l _ ∙v⊡ (sq ⊡v∙ ! (∙'-unit-l _))
  ⊡h'-unit-l ids = idp

  ⊡h-unit-l-unique : {a₀₀ a₀₁ a₁₀ a₁₁ : A}
    {p₀₋ : a₀₀ == a₀₁} {p₋₀ : a₀₀ == a₁₀} {p₋₁ : a₀₁ == a₁₁} {p₁₋ : a₁₀ == a₁₁}
    (sq' : Square p₀₋ idp idp p₀₋) (sq : Square p₀₋ p₋₀ p₋₁ p₁₋)
    → sq' ⊡h sq == sq
    → sq' == hid-square
  ⊡h-unit-l-unique sq' ids p = ! (⊡h-unit-r sq') ∙ p

module _ {i} {A : Type i} where
  !□h-inv-l : {a₀₀ a₀₁ a₁₀ a₁₁ : A}
    {p₀₋ : a₀₀ == a₀₁} {p₋₀ : a₀₀ == a₁₀}
    {p₋₁ : a₀₁ == a₁₁} {p₁₋ : a₁₀ == a₁₁}
    (sq : Square p₀₋ p₋₀ p₋₁ p₁₋)
    → (!□h sq) ⊡h sq == !-inv-l p₋₀ ∙v⊡ (hid-square ⊡v∙ ! (!-inv-l p₋₁))
  !□h-inv-l ids = idp

  !□h-inv-r : {a₀₀ a₀₁ a₁₀ a₁₁ : A}
    {p₀₋ : a₀₀ == a₀₁} {p₋₀ : a₀₀ == a₁₀}
    {p₋₁ : a₀₁ == a₁₁} {p₁₋ : a₁₀ == a₁₁}
    (sq : Square p₀₋ p₋₀ p₋₁ p₁₋)
    → sq ⊡h (!□h sq) == !-inv-r p₋₀ ∙v⊡ (hid-square ⊡v∙ ! (!-inv-r p₋₁))
  !□h-inv-r ids = idp

  !□v-inv-l : {a₀₀ a₀₁ a₁₀ a₁₁ : A}
    {p₀₋ : a₀₀ == a₀₁} {p₋₀ : a₀₀ == a₁₀}
    {p₋₁ : a₀₁ == a₁₁} {p₁₋ : a₁₀ == a₁₁}
    (sq : Square p₀₋ p₋₀ p₋₁ p₁₋)
    → (!□v sq) ⊡v sq == !-inv-l p₀₋ ∙h⊡ (vid-square ⊡h∙ ! (!-inv-l p₁₋))
  !□v-inv-l ids = idp

  !□v-inv-r : {a₀₀ a₀₁ a₁₀ a₁₁ : A}
    {p₀₋ : a₀₀ == a₀₁} {p₋₀ : a₀₀ == a₁₀}
    {p₋₁ : a₀₁ == a₁₁} {p₁₋ : a₁₀ == a₁₁}
    (sq : Square p₀₋ p₋₀ p₋₁ p₁₋)
    → sq ⊡v (!□v sq) == !-inv-r p₀₋ ∙h⊡ (vid-square ⊡h∙ ! (!-inv-r p₁₋))
  !□v-inv-r ids = idp

module _ {i} {A : Type i} where
  square-left-unique : {a₀₀ a₀₁ a₁₀ a₁₁ : A}
    {p₀₋ p₀₋' : a₀₀ == a₀₁} {p₋₀ : a₀₀ == a₁₀}
    {p₋₁ : a₀₁ == a₁₁} {p₁₋ : a₁₀ == a₁₁}
    → Square p₀₋ p₋₀ p₋₁ p₁₋ → Square p₀₋' p₋₀ p₋₁ p₁₋
    → p₀₋ == p₀₋'
  square-left-unique {p₋₀ = idp} {p₋₁ = idp} sq₁ sq₂ =
    horiz-degen-path (sq₁ ⊡h (!□h sq₂))

  square-top-unique : {a₀₀ a₀₁ a₁₀ a₁₁ : A}
    {p₀₋ : a₀₀ == a₀₁} {p₋₀ p₋₀' : a₀₀ == a₁₀}
    {p₋₁ : a₀₁ == a₁₁} {p₁₋ : a₁₀ == a₁₁}
    → Square p₀₋ p₋₀ p₋₁ p₁₋ → Square p₀₋ p₋₀' p₋₁ p₁₋
    → p₋₀ == p₋₀'
  square-top-unique {p₀₋ = idp} {p₁₋ = idp} sq₁ sq₂ =
    vert-degen-path (sq₁ ⊡v (!□v sq₂))

  square-bot-unique : {a₀₀ a₀₁ a₁₀ a₁₁ : A}
    {p₀₋ : a₀₀ == a₀₁} {p₋₀ : a₀₀ == a₁₀}
    {p₋₁ p₋₁' : a₀₁ == a₁₁} {p₁₋ : a₁₀ == a₁₁}
    → Square p₀₋ p₋₀ p₋₁ p₁₋ → Square p₀₋ p₋₀ p₋₁' p₁₋
    → p₋₁ == p₋₁'
  square-bot-unique {p₀₋ = idp} {p₁₋ = idp} sq₁ sq₂ =
    vert-degen-path ((!□v sq₁) ⊡v sq₂)

  square-right-unique : {a₀₀ a₀₁ a₁₀ a₁₁ : A}
    {p₀₋ : a₀₀ == a₀₁} {p₋₀ : a₀₀ == a₁₀}
    {p₋₁ : a₀₁ == a₁₁} {p₁₋ p₁₋' : a₁₀ == a₁₁}
    → Square p₀₋ p₋₀ p₋₁ p₁₋ → Square p₀₋ p₋₀ p₋₁ p₁₋'
    → p₁₋ == p₁₋'
  square-right-unique {p₋₀ = idp} {p₋₁ = idp} sq₁ sq₂ =
    horiz-degen-path ((!□h sq₁) ⊡h sq₂)

module _ {i} {A : Type i} where

  {- XXX naminig -}
  connection : {a₀ a₁ : A} {q : a₀ == a₁}
    → Square idp idp q q
  connection {q = idp} = ids

  {- XXX naminig -}
  connection2 : {a₀ a₁ a₂ : A} {p : a₀ == a₁} {q : a₁ == a₂}
    → Square p p q q
  connection2 {p = idp} {q = idp} = ids

  lb-square : {a₀ a₁ : A} (p : a₀ == a₁)
    → Square p idp (! p) idp
  lb-square idp = ids

  bl-square : {a₀ a₁ : A} (p : a₀ == a₁)
    → Square (! p) idp p idp
  bl-square idp = ids

  br-square : {a₀ a₁ : A} (p : a₀ == a₁)
    → Square idp idp p p
  br-square idp = ids

  rb-square = br-square

  rt-square : {a₀ a₁ : A} (p : a₀ == a₁)
    → Square idp (! p) idp p
  rt-square idp = ids

  tr-square : {a₀ a₁ : A} (p : a₀ == a₁)
    → Square idp p idp (! p)
  tr-square idp = ids

  lt-square : {a₀ a₁ : A} (p : a₀ == a₁)
    → Square p p idp idp
  lt-square idp = ids

  tl-square = lt-square


module Tactic.Monoid where

open import Prelude
open import Tactic.Reflection
open import Tactic.Reflection.Quote

open import Structure.Monoid.Laws

open import Tactic.Monoid.Exp
open import Tactic.Monoid.Reflect
open import Tactic.Monoid.Proofs

monoidTactic : ∀ {a} {A : Set a} {MonA : Monoid A} {{_ : MonoidLaws A {{MonA}}}} → Tactic
monoidTactic {A = A} {dict} {{laws}} hole = do
  goal   ← inferNormalisedType hole
  `A     ← quoteTC A
  unify goal (def (quote _≡_) (hArg unknown ∷ hArg `A ∷ vArg unknown ∷ vArg unknown ∷ []))
    <|> do typeError $ strErr "Goal is not an equality" ∷ termErr goal ∷ []
  goal   ← normalise goal
  ensureNoMetas goal
  match  ← monoidMatcher dict
  `dict  ← quoteTC dict
  `laws  ← quoteTC laws
  ensureNoMetas `dict
  debugPrint "tactic.monoid" 20 $ strErr "monoidTactic" ∷ termErr goal ∷ strErr "dict =" ∷ termErr `dict ∷ []
  (lhs , rhs) , env ← parseGoal match goal
  unify hole (def (quote proof) (iArg `dict ∷ iArg `laws ∷ vArg (` lhs) ∷ vArg (` rhs) ∷
                                 vArg (quoteEnv `dict env) ∷ vArg (con (quote refl) []) ∷ []))
    <|> do typeError $ strErr "Can't prove" ∷ termErr (` lhs) ∷ strErr "==" ∷ termErr (` rhs)
                     ∷ strErr "because" ∷ termErr (` (flatten lhs)) ∷ strErr "/=" ∷ termErr (` (flatten rhs))
                     ∷ []

macro
  auto-monoid : ∀ {a} {A : Set a} {Mon : Monoid A} {{Laws : MonoidLaws A {{Mon}}}} → Tactic
  auto-monoid {{Laws}} = monoidTactic {{Laws}}


-- The SIP applied to groups
{-# OPTIONS --safe #-}
module Cubical.Algebra.Group.GroupPath where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Isomorphism
open import Cubical.Foundations.Equiv
open import Cubical.Foundations.Equiv.HalfAdjoint
open import Cubical.Foundations.HLevels
open import Cubical.Foundations.Transport
open import Cubical.Foundations.Univalence
open import Cubical.Foundations.SIP
open import Cubical.Foundations.Function using (_∘_)
open import Cubical.Foundations.GroupoidLaws hiding (assoc)
open import Cubical.Data.Sigma

open import Cubical.Displayed.Base
open import Cubical.Displayed.Auto
open import Cubical.Displayed.Record
open import Cubical.Displayed.Universe

open import Cubical.Algebra.Semigroup
open import Cubical.Algebra.Monoid

open import Cubical.Algebra.Group.Base
open import Cubical.Algebra.Group.Properties
open import Cubical.Algebra.Group.Morphisms
open import Cubical.Algebra.Group.MorphismProperties

private
  variable
    ℓ ℓ' ℓ'' : Level

open Iso
open GroupStr
open IsGroupHom

𝒮ᴰ-Group : DUARel (𝒮-Univ ℓ) GroupStr ℓ
𝒮ᴰ-Group =
  𝒮ᴰ-Record (𝒮-Univ _) IsGroupEquiv
    (fields:
      data[ _·_ ∣ autoDUARel _ _ ∣ pres· ]
      data[ 1g ∣ autoDUARel _ _ ∣ pres1 ]
      data[ inv ∣ autoDUARel _ _ ∣ presinv ]
      prop[ isGroup ∣ (λ _ _ → isPropIsGroup _ _ _) ])
  where
  open GroupStr
  open IsGroupHom

GroupPath : (M N : Group ℓ) → GroupEquiv M N ≃ (M ≡ N)
GroupPath = ∫ 𝒮ᴰ-Group .UARel.ua

-- TODO: Induced structure results are temporarily inconvenient while we transition between algebra
-- representations
module _ (G : Group ℓ) {A : Type ℓ} (m : A → A → A)
  (e : ⟨ G ⟩ ≃ A)
  (p· : ∀ x y → e .fst (G .snd ._·_ x y) ≡ m (e .fst x) (e .fst y))
  where

  private
    module G = GroupStr (G .snd)

    FamilyΣ : Σ[ B ∈ Type ℓ ] (B → B → B) → Type ℓ
    FamilyΣ (B , n) =
      Σ[ e ∈ B ]
      Σ[ i ∈ (B → B) ]
      IsGroup e n i

    inducedΣ : FamilyΣ (A , m)
    inducedΣ =
      subst FamilyΣ
        (UARel.≅→≡ (autoUARel (Σ[ B ∈ Type ℓ ] (B → B → B))) (e , p·))
        (G.1g , G.inv , G.isGroup)

  InducedGroup : Group ℓ
  InducedGroup .fst = A
  InducedGroup .snd ._·_ = m
  InducedGroup .snd .1g = inducedΣ .fst
  InducedGroup .snd .inv = inducedΣ .snd .fst
  InducedGroup .snd .isGroup = inducedΣ .snd .snd

  InducedGroupEquiv : GroupEquiv G InducedGroup
  fst InducedGroupEquiv = e
  snd InducedGroupEquiv = makeIsGroupHom p·

  InducedGroupPath : G ≡ InducedGroup
  InducedGroupPath = GroupPath _ _ .fst InducedGroupEquiv

uaGroup : {G H : Group ℓ} → GroupEquiv G H → G ≡ H
uaGroup {G = G} {H = H} = equivFun (GroupPath G H)

-- Group-ua functoriality
Group≡ : (G H : Group ℓ) → (
  Σ[ p ∈ ⟨ G ⟩ ≡ ⟨ H ⟩ ]
  Σ[ q ∈ PathP (λ i → p i) (1g (snd G)) (1g (snd H)) ]
  Σ[ r ∈ PathP (λ i → p i → p i → p i) (_·_ (snd G)) (_·_ (snd H)) ]
  Σ[ s ∈ PathP (λ i → p i → p i) (inv (snd G)) (inv (snd H)) ]
  PathP (λ i → IsGroup (q i) (r i) (s i)) (isGroup (snd G)) (isGroup (snd H)))
  ≃ (G ≡ H)
Group≡ G H = isoToEquiv theIso
  where
  theIso : Iso _ _
  fun theIso (p , q , r , s , t) i = p i , groupstr (q i) (r i) (s i) (t i)
  inv theIso x = cong ⟨_⟩ x , cong (1g ∘ snd) x , cong (_·_ ∘ snd) x , cong (inv ∘ snd) x , cong (isGroup ∘ snd) x
  rightInv theIso _ = refl
  leftInv theIso _ = refl

caracGroup≡ : {G H : Group ℓ} (p q : G ≡ H) → cong ⟨_⟩ p ≡ cong ⟨_⟩ q → p ≡ q
caracGroup≡ {G = G} {H = H} p q P =
  sym (transportTransport⁻ (ua (Group≡ G H)) p)
                                   ∙∙ cong (transport (ua (Group≡ G H))) helper
                                   ∙∙ transportTransport⁻ (ua (Group≡ G H)) q
    where
    helper : transport (sym (ua (Group≡ G H))) p ≡ transport (sym (ua (Group≡ G H))) q
    helper = Σ≡Prop
               (λ _ → isPropΣ
                         (isOfHLevelPathP' 1 (is-set (snd H)) _ _)
                         λ _ → isPropΣ (isOfHLevelPathP' 1 (isSetΠ2 λ _ _ → is-set (snd H)) _ _)
                         λ _ → isPropΣ (isOfHLevelPathP' 1 (isSetΠ λ _ → is-set (snd H)) _ _)
                         λ _ → isOfHLevelPathP 1 (isPropIsGroup _ _ _) _ _)
               (transportRefl (cong ⟨_⟩ p) ∙ P ∙ sym (transportRefl (cong ⟨_⟩ q)))

uaGroupId : (G : Group ℓ) → uaGroup (idGroupEquiv {G = G}) ≡ refl
uaGroupId G = caracGroup≡ _ _ uaIdEquiv

uaCompGroupEquiv : {F G H : Group ℓ} (f : GroupEquiv F G) (g : GroupEquiv G H)
                 → uaGroup (compGroupEquiv f g) ≡ uaGroup f ∙ uaGroup g
uaCompGroupEquiv f g = caracGroup≡ _ _ (
  cong ⟨_⟩ (uaGroup (compGroupEquiv f g))
    ≡⟨ uaCompEquiv _ _ ⟩
  cong ⟨_⟩ (uaGroup f) ∙ cong ⟨_⟩ (uaGroup g)
    ≡⟨ sym (cong-∙ ⟨_⟩ (uaGroup f) (uaGroup g)) ⟩
  cong ⟨_⟩ (uaGroup f ∙ uaGroup g) ∎)

-- J-rule for GroupEquivs
GroupEquivJ : {G : Group ℓ} (P : (H : Group ℓ) → GroupEquiv G H → Type ℓ')
            → P G idGroupEquiv
            → ∀ {H} e → P H e
GroupEquivJ {G = G} P p {H} e =
  transport (λ i → P (GroupPath G H .fst e i)
    (transp (λ j → GroupEquiv G (GroupPath G H .fst e (i ∨ ~ j))) i e))
      (subst (P G) (sym lem) p)
  where
  lem : transport (λ j → GroupEquiv G (GroupPath G H .fst e (~ j))) e
       ≡ idGroupEquiv
  lem = Σ≡Prop (λ _ → isPropIsGroupHom _ _)
       (Σ≡Prop (λ _ → isPropIsEquiv _)
         (funExt λ x → (λ i → fst (fst (fst e .snd .equiv-proof
                          (transportRefl (fst (fst e) (transportRefl x i)) i))))
                         ∙ retEq (fst e) x))


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

module FOT.FOTC.Program.McCarthy91.WF-Relation.Induction.NonAcc.TerminationCheckIssue
  where

data ℕ : Set where
  zero : ℕ
  succ : ℕ → ℕ

{-# BUILTIN NATURAL ℕ #-}

postulate someℕ : ℕ

{-# TERMINATING #-}
foo : ℕ → ℕ → ℕ
foo n        zero    = 10
foo zero     (succ m) = foo zero someℕ
foo (succ n) (succ m) = foo n (succ m)

{-# TERMINATING #-}
bar : ℕ → ℕ → ℕ
bar n        zero    = 10
bar zero     (succ m) = bar m someℕ
bar (succ n) (succ m) = bar n (succ m)

{-# TERMINATING #-}
foobar : ℕ → ℕ → ℕ
foobar n zero = 10
foobar zero (succ m) with someℕ
... | zero   = 10
... | succ o = foobar m (succ o)
foobar (succ n) (succ m) = foobar n (succ m)


------------------------------------------------------------------------
-- The Agda standard library
--
-- Non-empty lists
------------------------------------------------------------------------

module Data.List.NonEmpty where

open import Category.Monad
open import Data.Bool
open import Data.Bool.Properties
open import Data.List as List using (List; []; _∷_)
open import Data.Maybe using (nothing; just)
open import Data.Nat as Nat
open import Data.Product using (∃; proj₁; proj₂; _,_; ,_)
open import Data.Sum as Sum using (_⊎_; inj₁; inj₂)
open import Data.Unit
open import Data.Vec as Vec using (Vec; []; _∷_)
open import Function
open import Function.Equality using (_⟨$⟩_)
open import Function.Equivalence
  using () renaming (module Equivalence to Eq)
open import Relation.Binary.PropositionalEquality as P using (_≡_; refl)
open import Relation.Nullary.Decidable using (⌊_⌋)

------------------------------------------------------------------------
-- Non-empty lists

infixr 5 _∷_

record List⁺ {a} (A : Set a) : Set a where
  constructor _∷_
  field
    head : A
    tail : List A

open List⁺ public

[_] : ∀ {a} {A : Set a} → A → List⁺ A
[ x ] = x ∷ []

infixr 5 _∷⁺_

_∷⁺_ : ∀ {a} {A : Set a} → A → List⁺ A → List⁺ A
x ∷⁺ y ∷ xs = x ∷ y ∷ xs

length : ∀ {a} {A : Set a} → List⁺ A → ℕ
length (x ∷ xs) = suc (List.length xs)

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

toList : ∀ {a} {A : Set a} → List⁺ A → List A
toList (x ∷ xs) = x ∷ xs

fromVec : ∀ {n a} {A : Set a} → Vec A (suc n) → List⁺ A
fromVec (x ∷ xs) = x ∷ Vec.toList xs

toVec : ∀ {a} {A : Set a} (xs : List⁺ A) → Vec A (length xs)
toVec (x ∷ xs) = x ∷ Vec.fromList xs

lift : ∀ {a b} {A : Set a} {B : Set b} →
       (∀ {m} → Vec A (suc m) → ∃ λ n → Vec B (suc n)) →
       List⁺ A → List⁺ B
lift f xs = fromVec (proj₂ (f (toVec xs)))

------------------------------------------------------------------------
-- Other operations

map : ∀ {a b} {A : Set a} {B : Set b} → (A → B) → List⁺ A → List⁺ B
map f (x ∷ xs) = (f x ∷ List.map f xs)

-- Right fold. Note that s is only applied to the last element (see
-- the examples below).

foldr : ∀ {a b} {A : Set a} {B : Set b} →
        (A → B → B) → (A → B) → List⁺ A → B
foldr {A = A} {B} c s (x ∷ xs) = foldr′ x xs
  where
  foldr′ : A → List A → B
  foldr′ x []       = s x
  foldr′ x (y ∷ xs) = c x (foldr′ y xs)

-- Left fold. Note that s is only applied to the first element (see
-- the examples below).

foldl : ∀ {a b} {A : Set a} {B : Set b} →
        (B → A → B) → (A → B) → List⁺ A → B
foldl c s (x ∷ xs) = List.foldl c (s x) xs

-- Append (several variants).

infixr 5 _⁺++⁺_ _++⁺_ _⁺++_

_⁺++⁺_ : ∀ {a} {A : Set a} → List⁺ A → List⁺ A → List⁺ A
(x ∷ xs) ⁺++⁺ (y ∷ ys) = x ∷ (xs List.++ y ∷ ys)

_⁺++_ : ∀ {a} {A : Set a} → List⁺ A → List A → List⁺ A
(x ∷ xs) ⁺++ ys = x ∷ (xs List.++ ys)

_++⁺_ : ∀ {a} {A : Set a} → List A → List⁺ A → List⁺ A
xs ++⁺ ys = List.foldr _∷⁺_ ys xs

concat : ∀ {a} {A : Set a} → List⁺ (List⁺ A) → List⁺ A
concat (xs ∷ xss) = xs ⁺++ List.concat (List.map toList xss)

monad : ∀ {f} → RawMonad (List⁺ {a = f})
monad = record
  { return = [_]
  ; _>>=_  = λ xs f → concat (map f xs)
  }

reverse : ∀ {a} {A : Set a} → List⁺ A → List⁺ A
reverse = lift (,_ ∘′ Vec.reverse)

-- Snoc.

infixl 5 _∷ʳ_ _⁺∷ʳ_

_∷ʳ_ : ∀ {a} {A : Set a} → List A → A → List⁺ A
[]       ∷ʳ y = [ y ]
(x ∷ xs) ∷ʳ y = x ∷ (xs List.∷ʳ y)

_⁺∷ʳ_ : ∀ {a} {A : Set a} → List⁺ A → A → List⁺ A
xs ⁺∷ʳ x = toList xs ∷ʳ x

-- A snoc-view of non-empty lists.

infixl 5 _∷ʳ′_

data SnocView {a} {A : Set a} : List⁺ A → Set a where
  _∷ʳ′_ : (xs : List A) (x : A) → SnocView (xs ∷ʳ x)

snocView : ∀ {a} {A : Set a} (xs : List⁺ A) → SnocView xs
snocView (x ∷ xs)              with List.initLast xs
snocView (x ∷ .[])             | []            = []       ∷ʳ′ x
snocView (x ∷ .(xs List.∷ʳ y)) | xs List.∷ʳ' y = (x ∷ xs) ∷ʳ′ y

-- The last element in the list.

last : ∀ {a} {A : Set a} → List⁺ A → A
last xs with snocView xs
last .(ys ∷ʳ y) | ys ∷ʳ′ y = y

-- Groups all contiguous elements for which the predicate returns the
-- same result into lists.

split : ∀ {a} {A : Set a}
        (p : A → Bool) → List A →
        List (List⁺ (∃ (T ∘ p)) ⊎ List⁺ (∃ (T ∘ not ∘ p)))
split p []       = []
split p (x ∷ xs) with p x | P.inspect p x | split p xs
... | true  | P.[ px≡t ] | inj₁ xs′ ∷ xss = inj₁ ((x , Eq.from T-≡     ⟨$⟩ px≡t) ∷⁺ xs′) ∷ xss
... | true  | P.[ px≡t ] | xss            = inj₁ [ x , Eq.from T-≡     ⟨$⟩ px≡t ]        ∷ xss
... | false | P.[ px≡f ] | inj₂ xs′ ∷ xss = inj₂ ((x , Eq.from T-not-≡ ⟨$⟩ px≡f) ∷⁺ xs′) ∷ xss
... | false | P.[ px≡f ] | xss            = inj₂ [ x , Eq.from T-not-≡ ⟨$⟩ px≡f ]        ∷ xss

-- If we flatten the list returned by split, then we get the list we
-- started with.

flatten : ∀ {a p q} {A : Set a} {P : A → Set p} {Q : A → Set q} →
          List (List⁺ (∃ P) ⊎ List⁺ (∃ Q)) → List A
flatten = List.concat ∘
          List.map Sum.[ toList ∘ map proj₁ , toList ∘ map proj₁ ]

flatten-split :
  ∀ {a} {A : Set a}
  (p : A → Bool) (xs : List A) → flatten (split p xs) ≡ xs
flatten-split p []       = refl
flatten-split p (x ∷ xs)
  with p x | P.inspect p x | split p xs | flatten-split p xs
... | true  | P.[ _ ] | []         | hyp = P.cong (_∷_ x) hyp
... | true  | P.[ _ ] | inj₁ _ ∷ _ | hyp = P.cong (_∷_ x) hyp
... | true  | P.[ _ ] | inj₂ _ ∷ _ | hyp = P.cong (_∷_ x) hyp
... | false | P.[ _ ] | []         | hyp = P.cong (_∷_ x) hyp
... | false | P.[ _ ] | inj₁ _ ∷ _ | hyp = P.cong (_∷_ x) hyp
... | false | P.[ _ ] | inj₂ _ ∷ _ | hyp = P.cong (_∷_ x) hyp

-- Groups all contiguous elements /not/ satisfying the predicate into
-- lists. Elements satisfying the predicate are dropped.

wordsBy : ∀ {a} {A : Set a} → (A → Bool) → List A → List (List⁺ A)
wordsBy p =
  List.gfilter Sum.[ const nothing , just ∘′ map proj₁ ] ∘ split p

------------------------------------------------------------------------
-- Examples

-- Note that these examples are simple unit tests, because the type
-- checker verifies them.

private
 module Examples {A B : Set}
                 (_⊕_ : A → B → B)
                 (_⊗_ : B → A → B)
                 (f : A → B)
                 (a b c : A)
                 where

  hd : head (a ∷⁺ b ∷⁺ [ c ]) ≡ a
  hd = refl

  tl : tail (a ∷⁺ b ∷⁺ [ c ]) ≡ b ∷ c ∷ []
  tl = refl

  mp : map f (a ∷⁺ b ∷⁺ [ c ]) ≡ f a ∷⁺ f b ∷⁺ [ f c ]
  mp = refl

  right : foldr _⊕_ f (a ∷⁺ b ∷⁺ [ c ]) ≡ a ⊕ (b ⊕ f c)
  right = refl

  left : foldl _⊗_ f (a ∷⁺ b ∷⁺ [ c ]) ≡ (f a ⊗ b) ⊗ c
  left = refl

  ⁺app⁺ : (a ∷⁺ b ∷⁺ [ c ]) ⁺++⁺ (b ∷⁺ [ c ]) ≡
          a ∷⁺ b ∷⁺ c ∷⁺ b ∷⁺ [ c ]
  ⁺app⁺ = refl

  ⁺app : (a ∷⁺ b ∷⁺ [ c ]) ⁺++ (b ∷ c ∷ []) ≡
          a ∷⁺ b ∷⁺ c ∷⁺ b ∷⁺ [ c ]
  ⁺app = refl

  app⁺ : (a ∷ b ∷ c ∷ []) ++⁺ (b ∷⁺ [ c ]) ≡
          a ∷⁺ b ∷⁺ c ∷⁺ b ∷⁺ [ c ]
  app⁺ = refl

  conc : concat ((a ∷⁺ b ∷⁺ [ c ]) ∷⁺ [ b ∷⁺ [ c ] ]) ≡
         a ∷⁺ b ∷⁺ c ∷⁺ b ∷⁺ [ c ]
  conc = refl

  rev : reverse (a ∷⁺ b ∷⁺ [ c ]) ≡ c ∷⁺ b ∷⁺ [ a ]
  rev = refl

  snoc : (a ∷ b ∷ c ∷ []) ∷ʳ a ≡ a ∷⁺ b ∷⁺ c ∷⁺ [ a ]
  snoc = refl

  snoc⁺ : (a ∷⁺ b ∷⁺ [ c ]) ⁺∷ʳ a ≡ a ∷⁺ b ∷⁺ c ∷⁺ [ a ]
  snoc⁺ = refl

  split-true : split (const true) (a ∷ b ∷ c ∷ []) ≡
               inj₁ ((a , tt) ∷⁺ (b , tt) ∷⁺ [ c , tt ]) ∷ []
  split-true = refl

  split-false : split (const false) (a ∷ b ∷ c ∷ []) ≡
                inj₂ ((a , tt) ∷⁺ (b , tt) ∷⁺ [ c , tt ]) ∷ []
  split-false = refl

  split-≡1 :
    split (λ n → ⌊ n Nat.≟ 1 ⌋) (1 ∷ 2 ∷ 3 ∷ 1 ∷ 1 ∷ 2 ∷ 1 ∷ []) ≡
    inj₁ [ 1 , tt ] ∷ inj₂ ((2 , tt) ∷⁺ [ 3 , tt ]) ∷
    inj₁ ((1 , tt) ∷⁺ [ 1 , tt ]) ∷ inj₂ [ 2 , tt ] ∷ inj₁ [ 1 , tt ] ∷
    []
  split-≡1 = refl

  wordsBy-true : wordsBy (const true) (a ∷ b ∷ c ∷ []) ≡ []
  wordsBy-true = refl

  wordsBy-false : wordsBy (const false) (a ∷ b ∷ c ∷ []) ≡
                  (a ∷⁺ b ∷⁺ [ c ]) ∷ []
  wordsBy-false = refl

  wordsBy-≡1 :
    wordsBy (λ n → ⌊ n Nat.≟ 1 ⌋) (1 ∷ 2 ∷ 3 ∷ 1 ∷ 1 ∷ 2 ∷ 1 ∷ []) ≡
    (2 ∷⁺ [ 3 ]) ∷ [ 2 ] ∷ []
  wordsBy-≡1 = refl


module WrongDotPattern where

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

data NonZero : Nat -> Set where
  nonZ : (n : Nat) -> NonZero (suc n)

f : (n : Nat) -> NonZero n -> Nat
f .zero (nonZ n) = n


-- Andreas, 2016-07-17 issue 2101

-- It should be possible to place a single function with a where block
-- inside `abstract`.

-- This will work if type signatures inside a where-block
-- are considered private, since in private type signatures,
-- abstract definitions are transparent.
-- (Unlike in public type signatures.)

record Wrap (A : Set) : Set where
  field unwrap : A

postulate
  P : ∀{A : Set} → A → Set

module AbstractPrivate (A : Set) where
  abstract
    B : Set
    B = Wrap A

    postulate
      b : B

    private -- this makes abstract defs transparent in type signatures
      postulate
        test : P (Wrap.unwrap b) -- should succeed

abstract

  unnamedWhere : (A : Set) → Set
  unnamedWhere A = A
    where  -- the following definitions are private!
    B : Set
    B = Wrap A

    postulate
      b : B
      test : P (Wrap.unwrap b) -- should succeed

  namedWherePrivate : (A : Set) → Set
  namedWherePrivate A = A
    module MP where
    B : Set
    B = Wrap A

    private
      postulate
        b : B
        test : P (Wrap.unwrap b) -- should succeed

  namedWhere : (A : Set) → Set
  namedWhere A = A
    module M where  -- the definitions in this module are not private!
    B : Set
    B = Wrap A

    postulate
      b : B
      test : P (Wrap.unwrap b) -- should fail!

access = M.b  -- should be in scope

outside : ∀ {A} → M.B A → A
outside = Wrap.unwrap  -- should fail and does so

--


{-# OPTIONS --type-in-type #-}

module BialgebraSorting where

import Relation.Binary.PropositionalEquality
open Relation.Binary.PropositionalEquality
open ≡-Reasoning
open import Function
open import Data.Product using (Σ; _,_; proj₁; proj₂)

record Functor (F : Set → Set) : Set where
  field
    map  : {A B : Set} → (A → B) → F A → F B
    map-∘ : {A B C : Set} {f : A → B} {g : B → C} → map g ∘ map f ≡ map (g ∘ f)
    map-id : {A : Set} → map (id {A = A}) ≡ id

postulate
  extensionality : {S : Set}{T : S -> Set}
                  {f g : (x : S) -> T x} ->
                  ((x : S) -> f x ≡ g x) ->
                  f ≡ g

record InitialAlgebra {F : Set → Set} (F-Functor : Functor F) : Set where
  open Functor F-Functor
  field
    Mu : Set
    In : F Mu → Mu
    inᵒ : Mu → F Mu
    In-inᵒ : In ∘ inᵒ ≡ id
    inᵒ-In : inᵒ ∘ In ≡ id
    fold
        : {A : Set} (f : F A → A)
        → Mu
        → A
    fold-∘
        : {A : Set} (f : F A → A)
        → (x : F Mu)
        → fold f (In x) ≡ f (map (fold f) x)
    fold-unique
        : {A : Set} {f : F A → A}
        → (h : Mu → A)
        → ((y : F Mu) → h (In y) ≡ f (map h y))
        → (x : Mu)
        → h x ≡ fold f x

record TerminalCoalgebra {F : Set → Set} (F-Functor : Functor F) : Set where
  open Functor F-Functor
  field
    Nu : Set
    Out : Nu → F Nu
    outᵒ : F Nu → Nu
    Out-outᵒ : Out ∘ outᵒ ≡ id
    outᵒ-Out : outᵒ ∘ Out ≡ id
    unfold : {A : Set} → (A → F A) → A → Nu
    unfold-∘
        : {A : Set} (f : A → F A)
        → (x : A)
        → Out (unfold f x) ≡ map (unfold f) (f x)
    unfold-unique
        : {A : Set} {f : A → F A}
        → (h : A → Nu)
        → ((y : A) → Out (unfold f y) ≡ map (unfold f) (f y))
        → (x : A)
        → h x ≡ unfold f x

module Example {F : Set → Set} {F-Functor : Functor F} (alg : InitialAlgebra F-Functor) where
  open Functor F-Functor
  open InitialAlgebra alg

  {-# TERMINATING #-}
  in-is-in
      : inᵒ ≡ fold (map In)
  in-is-in = extensionality $ \ x →
    let f = map In in
    begin
      inᵒ x
    ≡⟨⟩
      id (inᵒ x)
    ≡⟨ cong (_$ inᵒ x) $ sym map-id ⟩
      map id (inᵒ x)
    ≡⟨ cong (\p → map p (inᵒ x)) $ sym In-inᵒ ⟩
      map (In ∘ inᵒ) (inᵒ x)
    ≡⟨ cong (_$ inᵒ x) $ sym map-∘ ⟩
      map In (map inᵒ (inᵒ x))
    ≡⟨ cong (\p → map In ((map p) (inᵒ x))) in-is-in ⟩
      map In (map (fold (map In)) (inᵒ x))
    ≡⟨⟩
      map In (map (fold f) (inᵒ x))
    ≡⟨⟩
      f (map (fold f) (inᵒ x))
    ≡⟨ sym $ fold-∘ f (inᵒ x) ⟩
      fold f (In (inᵒ x))
    ≡⟨ cong (\p → fold f (p x)) In-inᵒ ⟩
      fold f x
    ≡⟨⟩
      fold (map In) x
    ∎

module Paper
    {F : Set → Set}
    {F-Functor : Functor F}
    (alg : InitialAlgebra F-Functor)
    (coalg : TerminalCoalgebra F-Functor) where
  open Functor F-Functor public
  open InitialAlgebra alg public
  open TerminalCoalgebra coalg public

  {-# TERMINATING #-}
  downcast : Nu → Mu
  downcast = In ∘ map downcast ∘ Out

  upcast : Mu → Nu
  upcast = fold outᵒ

data List (A : Set) (K : Set) : Set where
  Nil : List A K
  Cons : A → K → List A K

data Ordering : Set where
  LT : Ordering
  EQ : Ordering
  GT : Ordering

record Ord (A : Set) : Set where
  field
    compare : A → A → Ordering

data Bool : Set where
  false : Bool
  true  : Bool

_&&_ : Bool → Bool → Bool
false && _ = false
true && b = b

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

_==_ : Ordering → Ordering → Bool
_==_ EQ EQ = true
_==_ LT LT = true
_==_ GT GT = true
_==_ _ _ = false

_!=_ : Ordering → Ordering → Bool
_!=_ a b = not (a == b)

data Maybe (A : Set) : Set where
  just : A → Maybe A
  nothing : Maybe A

module Paper₂
    {A : Set}
    (Ord-A : Ord A)
    (List-Functor : Functor (List A))
    (alg : InitialAlgebra List-Functor)
    (coalg : TerminalCoalgebra List-Functor) where
  open Paper alg coalg
  open Ord Ord-A public

  is-sorted : Nu → Bool
  is-sorted = proj₂ ∘ fold (\ { Nil → nothing , true
                              ; (Cons a (nothing , x)) → just a , x
                              ; (Cons a (just a' , x)) → just a' , (x && (compare a a' != GT))
                              } ) ∘ downcast

  -- SortedList : {A : Set} → Ord A → Set
  -- SortedList ord = Σ Nu is-sorted

open Functor

record Bialgebra
       {F G : Set → Set}
       {F-functor : Functor F}
       {G-functor : Functor G}
       (f : {X : Set} → F (G X) → G (F X)) : Set where
  field
    a : {X : Set} → F X → X
    c : {X : Set} → X → G X
    bialgebra-proof
      : {X : Set}
      → c {X} ∘ a ≡ map G-functor a ∘ f ∘ map F-functor c

bubbleSort : Bialgebra ?
bubbleSort = ?


open import Type

module Relator.Equals.Proofs.Equiv {ℓ} {T : Type{ℓ}} where

import Relator.Equals.Proofs.Equivalence

open Relator.Equals.Proofs.Equivalence.One   {T = T} public
open Relator.Equals.Proofs.Equivalence.Two   {A = T} public
open Relator.Equals.Proofs.Equivalence.Three {A = T} public
open Relator.Equals.Proofs.Equivalence.Four  {A = T} public

instance [≡]-unary-relator-instance    = [≡]-unary-relator
instance [≡]-binary-relator-instance   = [≡]-binary-relator
instance [≡]-binary-operator-instance  = [≡]-binary-operator
instance [≡]-trinary-operator-instance = [≡]-trinary-operator
instance [≡]-to-function-instance      = [≡]-to-function
instance [≡]-equiv-instance            = [≡]-equiv


-- The category of monadic functions.

open import Level

open import Relation.Binary
open import Relation.Binary.PropositionalEquality

open import Axiom.FunctionExtensionality

open import Control.Monad
open import Control.Category

module Control.Kleisli where

-- The type of monadic functions.

Kleisli : (M : Set → Set) (A : Set) (B : Set) → Set
Kleisli M A B = A → M B

KleisliHom : (M : Set → Set) (A : Set) (B : Set) → Setoid zero zero
KleisliHom M A B = setoid (Kleisli M A B)

-- The laws of a Kleisli category correspond to the Monad laws,
-- modulo function extensionality.

kleisliIsCategory : {M : Set → Set} (monad : IsMonad M) → IsCategory (KleisliHom M)
kleisliIsCategory monad = record
  { ops = record
    { id  = return
    ; _⟫_ = _⟫_
    }
  ; laws = record
    { id-first = fun-ext (bind-β _)
    ; id-last  = fun-ext (λ a → bind-η _)
    ; ∘-assoc  = λ f → fun-ext (λ a → bind-assoc (f a))
    ; ∘-cong   = cong₂ _⟫_
    }
  }
  where
    open IsMonad monad
    open T-CategoryOps (KleisliHom _)
    _⟫_ : T-⟫
    f ⟫ g = λ a → f a >>= g

-- The Kleisli category over a Monad on Set

KLEISLI : {M : Set → Set} (monad : IsMonad M) → Category _ _ _
KLEISLI monad = record { Hom = KleisliHom _; isCategory = kleisliIsCategory monad }


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

open import Cubical.Core.Everything

------------------------------------------------------------------------
-- Unary and binary operations

Op₁ : ∀ {ℓ} → Type ℓ → Type ℓ
Op₁ A = A → A

Op₂ : ∀ {ℓ} → Type ℓ → Type ℓ
Op₂ A = A → A → A

------------------------------------------------------------------------
-- Left and right actions

Opₗ : ∀ {a b} → Type a → Type b → Type _
Opₗ A B = A → B → B

Opᵣ : ∀ {a b} → Type a → Type b → Type _
Opᵣ A B = B → A → B


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

open import HoTT
open import groups.KernelImage
open import groups.KernelImageEmap

module cohomology.ChainComplex where

  record ChainComplex i : Type (lsucc i) where
    field
      head : AbGroup i
      chain : ℕ → AbGroup i
      augment : AbGroup.grp (chain 0) →ᴳ AbGroup.grp head
      boundary : ∀ n → (AbGroup.grp (chain (S n)) →ᴳ AbGroup.grp (chain n))

  record CochainComplex i : Type (lsucc i) where
    field
      head : AbGroup i
      cochain : ℕ → AbGroup i
      augment : AbGroup.grp head →ᴳ AbGroup.grp (cochain 0)
      coboundary : ∀ n → (AbGroup.grp (cochain n) →ᴳ AbGroup.grp (cochain (S n)))

  record CochainComplexEquiv {i₀ i₁}
    (cc₀ : CochainComplex i₀) (cc₁ : CochainComplex i₁) : Type (lmax i₀ i₁) where
    private
      module cc₀ = CochainComplex cc₀
      module cc₁ = CochainComplex cc₁
    field
      head : AbGroup.grp cc₀.head ≃ᴳ AbGroup.grp cc₁.head
      cochain : (n : ℕ) → AbGroup.grp (cc₀.cochain n) ≃ᴳ AbGroup.grp (cc₁.cochain n)
      augment : CommSquareᴳ cc₀.augment cc₁.augment (–>ᴳ head) (–>ᴳ (cochain 0))
      coboundary : ∀ n → CommSquareᴳ (cc₀.coboundary n) (cc₁.coboundary n)
        (–>ᴳ (cochain n)) (–>ᴳ (cochain (S n)))

  homology-group : ∀ {i} → ChainComplex i → (n : ℤ) → Group i
  homology-group cc (pos 0) = Ker/Im cc.augment (cc.boundary 0) (snd (cc.chain 0))
    where module cc = ChainComplex cc
  homology-group cc (pos (S n)) = Ker/Im (cc.boundary n) (cc.boundary (S n)) (snd (cc.chain (S n)))
    where module cc = ChainComplex cc
  homology-group {i} cc (negsucc _) = Lift-group {j = i} Unit-group

  cohomology-group : ∀ {i} → CochainComplex i → (n : ℤ) → Group i
  cohomology-group cc (pos 0) = Ker/Im (cc.coboundary 0) cc.augment (snd (cc.cochain 0))
    where module cc = CochainComplex cc
  cohomology-group cc (pos (S n)) = Ker/Im (cc.coboundary (S n)) (cc.coboundary n) (snd (cc.cochain (S n)))
    where module cc = CochainComplex cc
  cohomology-group {i} cc (negsucc _) = Lift-group {j = i} Unit-group

  cohomology-group-emap : ∀ {i₀ i₁} {cc₀ : CochainComplex i₀} {cc₁ : CochainComplex i₁}
    → CochainComplexEquiv cc₀ cc₁
    → (n : ℤ) → cohomology-group cc₀ n ≃ᴳ cohomology-group cc₁ n
  cohomology-group-emap {cc₀ = cc₀} {cc₁} cc= (pos 0) =
    Ker/Im-emap (snd (cc₀.cochain 0)) (snd (cc₁.cochain 0))
      (cc=.coboundary 0) cc=.augment
      (snd cc=.head) (snd (cc=.cochain 0)) (snd (cc=.cochain 1))
    where module cc₀ = CochainComplex cc₀
          module cc₁ = CochainComplex cc₁
          module cc= = CochainComplexEquiv cc=
  cohomology-group-emap {cc₀ = cc₀} {cc₁} cc= (pos (S n)) =
    Ker/Im-emap (snd (cc₀.cochain (S n))) (snd (cc₁.cochain (S n)))
      (cc=.coboundary (S n)) (cc=.coboundary n)
      (snd (cc=.cochain n)) (snd (cc=.cochain (S n))) (snd (cc=.cochain (S (S n))))
    where module cc₀ = CochainComplex cc₀
          module cc₁ = CochainComplex cc₁
          module cc= = CochainComplexEquiv cc=
  cohomology-group-emap _ (negsucc _) = lift-iso ∘eᴳ lower-iso

  complex-dualize : ∀ {i j} → ChainComplex i → AbGroup j
    →  CochainComplex (lmax i j)
  complex-dualize {i} {j} cc G = record {M} where
    module cc = ChainComplex cc
    module M where
      head : AbGroup (lmax i j)
      head = hom-abgroup (AbGroup.grp cc.head) G

      cochain : ℕ → AbGroup (lmax i j)
      cochain n = hom-abgroup (AbGroup.grp (cc.chain n)) G

      augment : AbGroup.grp head →ᴳ AbGroup.grp (cochain 0)
      augment = pre∘ᴳ-hom G cc.augment

      coboundary : ∀ n → (AbGroup.grp (cochain n) →ᴳ AbGroup.grp (cochain (S n)))
      coboundary n = pre∘ᴳ-hom G (cc.boundary n)


module Generic.Test.Data.List where

module _ where
  open import Generic.Main as Main hiding ([]; _∷_) renaming (List to StdList)

  infixr 5 _∷_ _∷′_

  List : ∀ {α} -> Set α -> Set α
  List = readData StdList

  pattern []       = #₀ lrefl
  pattern _∷_ x xs = !#₁ (relv x , xs , lrefl)

  _∷′_ : ∀ {α} {A : Set α} -> A -> List A -> List A
  _∷′_ = _∷_

  elimList : ∀ {α π} {A : Set α}
           -> (P : List A -> Set π)
           -> (∀ {xs} x -> P xs -> P (x ∷ xs))
           -> P []
           -> ∀ xs
           -> P xs
  elimList P f z  []      = z
  elimList P f z (x ∷ xs) = f x (elimList P f z xs)

  toStdList : ∀ {α} {A : Set α} -> List A -> StdList A
  toStdList xs = guncoerce xs

-- The entire content of `Data.List.Base` (modulo `Generic.Test.Data.Maybe` instead of
-- `Data.Maybe.Base` and _∷_ was renamed to _∷′_ in some places)

open import Data.Nat.Base using (ℕ; zero; suc; _+_; _*_)
open import Data.Sum as Sum using (_⊎_; inj₁; inj₂)
open import Data.Bool.Base using (Bool; false; true; not; _∧_; _∨_; if_then_else_)
open import Generic.Test.Data.Maybe
open import Data.Product as Prod using (_×_; _,_)
open import Function

infixr 5 _++_

[_] : ∀ {a} {A : Set a} → A → List A
[ x ] = x ∷ []

_++_ : ∀ {a} {A : Set a} → List A → List A → List A
[]       ++ ys = ys
(x ∷ xs) ++ ys = x ∷ (xs ++ ys)

-- Snoc.

infixl 5 _∷ʳ_

_∷ʳ_ : ∀ {a} {A : Set a} → List A → A → List A
xs ∷ʳ x = xs ++ [ x ]

null : ∀ {a} {A : Set a} → List A → Bool
null []       = true
null (x ∷ xs) = false

-- * List transformations

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

replicate : ∀ {a} {A : Set a} → (n : ℕ) → A → List A
replicate zero    x = []
replicate (suc n) x = x ∷ replicate n x

zipWith : ∀ {a b c} {A : Set a} {B : Set b} {C : Set c}
          → (A → B → C) → List A → List B → List C
zipWith f (x ∷ xs) (y ∷ ys) = f x y ∷ zipWith f xs ys
zipWith f _        _        = []

zip : ∀ {a b} {A : Set a} {B : Set b} → List A → List B → List (A × B)
zip = zipWith (_,_)

intersperse : ∀ {a} {A : Set a} → A → List A → List A
intersperse x []           = []
intersperse x (y ∷ [])     = [ y ]
intersperse x (y ∷ z ∷ zs) = y ∷ x ∷ intersperse x (z ∷ zs)

-- * Reducing lists (folds)

foldr : ∀ {a b} {A : Set a} {B : Set b} → (A → B → B) → B → List A → B
foldr c n []       = n
foldr c n (x ∷ xs) = c x (foldr c n xs)

foldl : ∀ {a b} {A : Set a} {B : Set b} → (A → B → A) → A → List B → A
foldl c n []       = n
foldl c n (x ∷ xs) = foldl c (c n x) xs

-- ** Special folds

concat : ∀ {a} {A : Set a} → List (List A) → List A
concat = foldr _++_ []

concatMap : ∀ {a b} {A : Set a} {B : Set b} →
            (A → List B) → List A → List B
concatMap f = concat ∘ map f

and : List Bool → Bool
and = foldr _∧_ true

or : List Bool → Bool
or = foldr _∨_ false

any : ∀ {a} {A : Set a} → (A → Bool) → List A → Bool
any p = or ∘ map p

all : ∀ {a} {A : Set a} → (A → Bool) → List A → Bool
all p = and ∘ map p

sum : List ℕ → ℕ
sum = foldr _+_ 0

product : List ℕ → ℕ
product = foldr _*_ 1

length : ∀ {a} {A : Set a} → List A → ℕ
length = foldr (λ _ → suc) 0

import Data.List.Base

reverse : ∀ {a} {A : Set a} → List A → List A
reverse = foldl (λ rev x → x ∷′ rev) []

-- * Building lists

-- ** Scans

scanr : ∀ {a b} {A : Set a} {B : Set b} →
        (A → B → B) → B → List A → List B
scanr f e []       = e ∷ []
scanr f e (x ∷ xs) with scanr f e xs
... | []     = []                -- dead branch
... | y ∷ ys = f x y ∷ y ∷ ys

scanl : ∀ {a b} {A : Set a} {B : Set b} →
        (A → B → A) → A → List B → List A
scanl f e []       = e ∷ []
scanl f e (x ∷ xs) = e ∷ scanl f (f e x) xs

-- ** Unfolding

-- Unfold. Uses a measure (a natural number) to ensure termination.

unfold : ∀ {a b} {A : Set a} (B : ℕ → Set b)
         (f : ∀ {n} → B (suc n) → Maybe (A × B n)) →
         ∀ {n} → B n → List A
unfold B f {n = zero}  s = []
unfold B f {n = suc n} s with f s
... | nothing       = []
... | just (x , s') = x ∷ unfold B f s'

-- downFrom 3 = 2 ∷ 1 ∷ 0 ∷ [].

downFrom : ℕ → List ℕ
downFrom n = unfold Singleton f (wrap n)
  where
  data Singleton : ℕ → Set where
    wrap : (n : ℕ) → Singleton n

  f : ∀ {n} → Singleton (suc n) → Maybe (ℕ × Singleton n)
  f {n} (wrap .(suc n)) = just (n , wrap n)

-- ** Conversions

fromMaybe : ∀ {a} {A : Set a} → Maybe A → List A
fromMaybe (just x) = [ x ]
fromMaybe nothing  = []

-- * Sublists

-- ** Extracting sublists

take : ∀ {a} {A : Set a} → ℕ → List A → List A
take zero    xs       = []
take (suc n) []       = []
take (suc n) (x ∷ xs) = x ∷ take n xs

drop : ∀ {a} {A : Set a} → ℕ → List A → List A
drop zero    xs       = xs
drop (suc n) []       = []
drop (suc n) (x ∷ xs) = drop n xs

splitAt : ∀ {a} {A : Set a} → ℕ → List A → (List A × List A)
splitAt zero    xs       = ([] , xs)
splitAt (suc n) []       = ([] , [])
splitAt (suc n) (x ∷ xs) with splitAt n xs
... | (ys , zs) = (x ∷ ys , zs)

takeWhile : ∀ {a} {A : Set a} → (A → Bool) → List A → List A
takeWhile p []       = []
takeWhile p (x ∷ xs) with p x
... | true  = x ∷ takeWhile p xs
... | false = []

dropWhile : ∀ {a} {A : Set a} → (A → Bool) → List A → List A
dropWhile p []       = []
dropWhile p (x ∷ xs) with p x
... | true  = dropWhile p xs
... | false = x ∷ xs

span : ∀ {a} {A : Set a} → (A → Bool) → List A → (List A × List A)
span p []       = ([] , [])
span p (x ∷ xs) with p x
... | true  = Prod.map (_∷′_ x) id (span p xs)
... | false = ([] , x ∷ xs)

break : ∀ {a} {A : Set a} → (A → Bool) → List A → (List A × List A)
break p = span (not ∘ p)

inits : ∀ {a} {A : Set a} → List A → List (List A)
inits []       = [] ∷ []
inits (x ∷ xs) = [] ∷ map (_∷′_ x) (inits xs)

tails : ∀ {a} {A : Set a} → List A → List (List A)
tails []       = [] ∷ []
tails (x ∷ xs) = (x ∷ xs) ∷ tails xs

infixl 5 _∷ʳ'_

data InitLast {a} {A : Set a} : List A → Set a where
  []ʳ   : InitLast []
  _∷ʳ'_ : (xs : List A) (x : A) → InitLast (xs ∷ʳ x)

initLast : ∀ {a} {A : Set a} (xs : List A) → InitLast xs
initLast []               = []ʳ
initLast (x ∷ xs)         with initLast xs
initLast (x ∷ .[])        | []ʳ      = [] ∷ʳ' x
initLast (x ∷ .(ys ∷ʳ y)) | ys ∷ʳ' y = (x ∷ ys) ∷ʳ' y

-- * Searching lists

-- ** Searching with a predicate

-- A generalised variant of filter.

gfilter : ∀ {a b} {A : Set a} {B : Set b} →
          (A → Maybe B) → List A → List B
gfilter p []       = []
gfilter p (x ∷ xs) with p x
... | just y  = y ∷ gfilter p xs
... | nothing =     gfilter p xs

filter : ∀ {a} {A : Set a} → (A → Bool) → List A → List A
filter p = gfilter (λ x → if p x then just′ x else nothing)

partition : ∀ {a} {A : Set a} → (A → Bool) → List A → (List A × List A)
partition p []       = ([] , [])
partition p (x ∷ xs) with p x | partition p xs
... | true  | (ys , zs) = (x ∷ ys , zs)
... | false | (ys , zs) = (ys , x ∷ zs)


{-# OPTIONS --universe-polymorphism #-}

module SetInf where

id : ∀ {A} → A → A
id x = x


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

module Note where

open import Data.Integer using (ℤ)
open import Data.Nat     using (ℕ; _*_)

open import Pitch        using (Pitch; transposePitch)

data Duration : Set where
  duration : ℕ → Duration

unduration : Duration → ℕ
unduration (duration d) = d

data Note : Set where
  tone : Duration → Pitch → Note
  rest : Duration         → Note

-- Note: If we inline duration here Agda can't figure out
-- that noteDuration (tone d _) = unduration d
noteDuration : Note → ℕ
noteDuration (tone d _) = unduration d
noteDuration (rest d)   = unduration d

transposeNote : ℤ → Note → Note
transposeNote k (tone d p) = tone d (transposePitch k p)
transposeNote k (rest d)   = rest d

-- duration in 16th notes
-- assume duration of a 16th note is 1
16th 8th qtr half whole : Duration
16th   = duration 1
8th    = duration 2
dqtr   = duration 3
qtr    = duration 4
half   = duration 8
dhalf  = duration 12
whole  = duration 16
dwhole = duration 24


{-# OPTIONS --cubical --safe --postfix-projections #-}

open import Prelude
open import Relation.Binary

module Data.AVLTree.Internal {k} {K : Type k} {r₁ r₂} (totalOrder : TotalOrder K r₁ r₂) where

open import Relation.Binary.Construct.Bounded totalOrder
open import Data.Nat using (_+_)
open TotalOrder totalOrder using (_<?_; compare)
open TotalOrder b-ord using (<-trans) renaming (refl to <-refl)
import Data.Empty.UniversePolymorphic as Poly

private
  variable
    n m l : ℕ

data Bal : ℕ → ℕ → ℕ → Type where
  ll : Bal (suc n) n (suc n)
  ee : Bal n n n
  rr : Bal n (suc n) (suc n)

balr : Bal n m l → Bal l n l
balr ll = ee
balr ee = ee
balr rr = ll

ball : Bal n m l → Bal m l l
ball ll = rr
ball ee = ee
ball rr = ee

private
  variable
    v : Level
    Val : K → Type v

data Tree {v} (Val : K → Type v) (lb ub : [∙]) : ℕ → Type (k ℓ⊔ r₁ ℓ⊔ v) where
  leaf : (lb<ub : lb [<] ub) →
         Tree Val lb ub zero
  node : (key : K)
         (val : Val key)
         (bal : Bal n m l)
         (lchild : Tree Val lb [ key ] n)
         (rchild : Tree Val [ key ] ub m) →
         Tree Val lb ub (suc l)

private
  variable
    lb ub : [∙]

data Inc {t} (T : ℕ → Type t) (n : ℕ) : Type t where
  stay : T n       → Inc T n
  high : T (suc n) → Inc T n

private
  variable
    t : Level
    N : ℕ → Type t

rotʳ : (x : K) →
       (xv : Val x) →
       (ls : Tree Val lb [ x ] (2 + n)) →
       (rs : Tree Val [ x ] ub n) →
       Inc (Tree Val lb ub) (2 + n)
rotʳ y yv (node x xv ll xl xr) zs = stay (node x xv ee xl (node y yv ee xr zs))
rotʳ y yv (node x xv ee xl xr) zs = high (node x xv rr xl (node y yv ll xr zs))
rotʳ z zv (node x xv rr xl (node y yv bl yl yr)) zr = stay (node y yv ee (node x xv (balr bl) xl yl) (node z zv (ball bl) yr zr))

rotˡ : (x : K) → (xv : Val x) →
       (ls : Tree Val lb [ x ] n) →
       (rs : Tree Val [ x ] ub (2 + n)) →
       Inc (Tree Val lb ub) (2 + n)
rotˡ x xv xl (node y yv ee yl yr) = high (node y yv ll (node x xv rr xl yl) yr)
rotˡ x xv xl (node y yv rr yl yr) = stay (node y yv ee (node x xv ee xl yl) yr)
rotˡ x xv xl (node z zv ll (node y yv bl yl yr) zr) = stay (node y yv ee (node x xv (balr bl) xl yl) (node z zv (ball bl) yr zr))

insertWith : (x : K) → Val x →
             ((new : Val x) → (old : Val x) → Val x) →
             (lb [<] [ x ]) →
             ([ x ] [<] ub) →
             (tr : Tree Val lb ub n) →
             Inc (Tree Val lb ub) n
insertWith x xv xf lb<x x<ub (leaf lb<ub) =
  high (node x xv ee (leaf lb<x) (leaf x<ub))
insertWith x xv xf lb<x x<ub (node y yv bal ls rs) with compare x y
... | lt x<y with insertWith x xv xf lb<x x<y ls
... | stay ls′ = stay (node y yv bal ls′ rs)
... | high ls′ with bal
... | ll = rotʳ y yv ls′ rs
... | ee = high (node y yv ll ls′ rs)
... | rr = stay (node y yv ee ls′ rs)
insertWith x xv xf lb<x x<ub (node y yv bal ls rs)
    | gt y<x with insertWith x xv xf y<x x<ub rs
... | stay rs′ = stay (node y yv bal ls rs′)
... | high rs′ with bal
... | ll = stay (node y yv ee ls rs′)
... | ee = high (node y yv rr ls rs′)
... | rr = rotˡ y yv ls rs′
insertWith x xv xf lb<x x<ub (node y yv bal ls rs)
    | eq x≡y = stay (node y (subst _ x≡y (xf xv (subst _ (sym x≡y) yv))) bal ls rs)

lookup : (x : K) → Tree  Val lb ub n → Maybe (Val x)
lookup x (leaf lb<ub) = nothing
lookup x (node y val bal lhs rhs) with compare y x
... | lt x<y = lookup x lhs
... | eq x≡y = just (subst _ x≡y val)
... | gt x>y = lookup x rhs

record Cons (Val : K → Type v) (lb ub : [∙]) (h : ℕ) : Type (k ℓ⊔ v ℓ⊔ r₁) where
  constructor cons
  field
    head : K
    val  : Val head
    bounds : lb [<] [ head ]
    tail : Inc (Tree Val [ head ] ub) h
open Cons public

map-tail : ∀ {ub₁ ub₂} →
             Cons Val lb ub₁ n →
             (∀ {lb} → Inc (Tree Val lb ub₁) n → Inc (Tree Val lb ub₂) m) →
             Cons Val lb ub₂ m
map-tail (cons h v b t) f = cons h v b (f t)

uncons : (x : K) →
         Val x →
         Bal n m l →
         Tree Val lb [ x ] n →
         Tree Val [ x ] ub m →
         Cons Val lb ub l
uncons x xv bl (leaf lb<ub) rhs .head = x
uncons x xv bl (leaf lb<ub) rhs .val = xv
uncons x xv bl (leaf lb<ub) rhs .bounds = lb<ub
uncons x xv ee (leaf lb<ub) rhs .tail = stay rhs
uncons x xv rr (leaf lb<ub) rhs .tail = stay rhs
uncons x xv bl (node y yv yb ls yrs) rs =
  map-tail (uncons y yv yb ls yrs)
    λ { (high ys) → high (node x xv bl ys rs)
      ; (stay ys) → case bl of
        λ { ll → stay (node x xv ee ys rs)
          ; ee → high (node x xv rr ys rs)
          ; rr → rotˡ x xv ys rs
          }
      }

ext : ∀ {ub′} → ub [<] ub′ → Tree Val lb ub n → Tree Val lb ub′ n
ext {lb = lb} ub<ub′ (leaf lb<ub) = leaf (<-trans {x = lb} lb<ub ub<ub′)
ext ub<ub′ (node x xv bal lhs rhs) = node x xv bal lhs (ext ub<ub′ rhs)

join : ∀ {x} →
       Tree Val lb [ x ] m →
       Bal m n l →
       Tree Val [ x ] ub n →
       Inc (Tree Val lb ub) l
join lhs ll (leaf lb<ub) = stay (ext lb<ub lhs)
join {lb = lb} (leaf lb<ub₁) ee (leaf lb<ub) = stay (leaf (<-trans {x = lb} lb<ub₁ lb<ub))
join lhs bl (node x xv xb xl xr) with uncons x xv xb xl xr
... | cons k′ v′ l<u (high tr′) = high (node k′ v′ bl (ext l<u lhs) tr′)
... | cons k′ v′ l<u (stay tr′) with bl
... | ll = rotʳ k′ v′ (ext l<u lhs) tr′
... | ee = high (node k′ v′ ll (ext l<u lhs) tr′)
... | rr = stay (node k′ v′ ee (ext l<u lhs) tr′)

data Decr {t} (T : ℕ → Type t) : ℕ → Type t where
  same : T n → Decr T n
  decr : T n → Decr T (suc n)

inc→dec : Inc N n → Decr N (suc n)
inc→dec (stay x) = decr x
inc→dec (high x) = same x

delete : (x : K)
        → Tree Val lb ub n
        → Decr (Tree Val lb ub) n
delete x (leaf l<u) = same (leaf l<u)
delete x (node y yv b l r) with compare x y
delete x (node y yv b l r) | eq _ = inc→dec (join l b r)
delete x (node y yv b l r) | lt a with delete x l
... | same l′ = same (node y yv b l′ r)
... | decr l′ with b
... | ll = decr (node y yv ee l′ r)
... | ee = same (node y yv rr l′ r)
... | rr = inc→dec (rotˡ y yv l′ r)
delete x (node y yv b l r) | gt c with delete x r
... | same r′ = same (node y yv b l r′)
... | decr r′ with b
... | ll = inc→dec (rotʳ y yv l r′)
... | ee =  same (node y yv ll  l r′)
... | rr =  decr (node y yv ee  l r′)

data Change {t} (T : ℕ → Type t) : ℕ → Type t where
  up : T (suc n) → Change T n
  ev : T n → Change T n
  dn : T n → Change T (suc n)

inc→changeup : Inc N n → Change N (suc n)
inc→changeup (stay x) = dn x
inc→changeup (high x) = ev x

inc→changedn : Inc N n → Change N n
inc→changedn (stay x) = ev x
inc→changedn (high x) = up x

_<_<_ : [∙] → K → [∙] → Type _
l < x < u = l [<] [ x ] × [ x ] [<] u

alter : (x : K)
      → (Maybe (Val x) → Maybe (Val x))
      → Tree Val lb ub n
      → lb < x < ub
      → Change (Tree Val lb ub) n
alter x f (leaf l<u) (l , u) with f nothing
...  | just xv = up (node x xv ee (leaf l) (leaf u))
...  | nothing = ev (leaf l<u)
alter x f (node y yv b tl tr) (l , u) with compare x y
alter x f (node y yv b tl tr) (l , u)
     | eq x≡y with f (just (subst _ (sym x≡y) yv))
...  | just xv = ev (node y (subst _ x≡y xv) b tl tr)
...  | nothing = inc→changeup (join tl b tr)
alter x f (node y yv b tl tr) (l , u)
      | lt a with alter x f tl (l , a) | b
...  | ev tl′ | _  = ev (node y yv b  tl′ tr)
...  | up tl′ | ll = inc→changedn (rotʳ y yv tl′ tr)
...  | up tl′ | ee = up (node y yv ll  tl′ tr)
...  | up tl′ | rr = ev (node y yv ee  tl′ tr)
...  | dn tl′ | ll = dn (node y yv ee  tl′ tr)
...  | dn tl′ | ee = ev (node y yv rr  tl′ tr)
...  | dn tl′ | rr = inc→changeup (rotˡ y yv tl′ tr)
alter x f (node y yv b tl tr) (l , u)
     | gt c with alter x f tr (c , u) | b
...  | ev tr′ | _  = ev (node y yv b  tl tr′)
...  | up tr′ | ll = ev (node y yv ee tl tr′)
...  | up tr′ | ee = up (node y yv rr  tl tr′)
...  | up tr′ | rr = inc→changedn (rotˡ y yv tl tr′)
...  | dn tr′ | ll = inc→changeup (rotʳ y yv tl tr′)
...  | dn tr′ | ee = ev (node y yv ll  tl tr′)
...  | dn tr′ | rr = dn (node y yv ee  tl tr′)

open import Lens

alterF : (x : K) →
         Tree Val lb ub n →
         lb < x < ub →
         LensPart (Change (Tree Val lb ub) n) (Maybe (Val x))
alterF x xs bnds = go (ev xs) x xs bnds id
  where
  go : A → (x : K) →
       Tree Val lb ub n →
       lb < x < ub →
       (Change (Tree Val lb ub) n → A) →
       LensPart A (Maybe (Val x))
  go xs x (leaf lb<ub) (l , u) k = λ where
    .get → nothing
    .set nothing → xs
    .set (just xv) → k (up (node x xv ee (leaf l) (leaf u)))
  go xs x (node y yv bl yl yr) (l , u) k with compare x y
  go xs x (node y yv bl yl yr) (l , u) k | eq x≡y = λ where
    .get → just (subst _ (sym x≡y) yv)
    .set nothing → k (inc→changeup (join yl bl yr))
    .set (just xv) → k (ev (node y (subst _ x≡y xv) bl yl yr))
  go xs x (node y yv bl yl yr) (l , u) k | lt x<y =
    go xs x yl (l , x<y)
      λ { (up yl′) → case bl of
          λ { ll → k (inc→changedn (rotʳ y yv yl′ yr))
            ; ee → k (up (node y yv ll yl′ yr))
            ; rr → k (ev (node y yv ee yl′ yr))
            }
        ; (ev yl′) → k (ev (node y yv bl yl′ yr))
        ; (dn yl′) → case bl of
          λ { rr → k (inc→changeup (rotˡ y yv yl′ yr))
            ; ee → k (ev (node y yv rr yl′ yr))
            ; ll → k (dn (node y yv ee yl′ yr))
            }
        }
  go xs x (node y yv bl yl yr) (l , u) k | gt x>y =
    go xs x yr (x>y , u)
      λ { (up yr′) → case bl of
          λ { rr → k (inc→changedn (rotˡ y yv yl yr′))
            ; ee → k (up (node y yv rr yl yr′))
            ; ll → k (ev (node y yv ee yl yr′))
            }
        ; (ev yr′) → k (ev (node y yv bl yl yr′))
        ; (dn yr′) → case bl of
          λ { ll → k (inc→changeup (rotʳ y yv yl yr′))
            ; ee → k (ev (node y yv ll yl yr′))
            ; rr → k (dn (node y yv ee yl yr′))
            }
        }

open import Data.List

toList⊙ : Tree Val lb ub n → List (∃ x × Val x) → List (∃ x × Val x)
toList⊙ (leaf lb<ub) ks = ks
toList⊙ (node x xv bal xl xr) ks = toList⊙ xl ((x , xv) ∷ toList⊙ xr ks)

toList : Tree Val lb ub n → List (∃ x × Val x)
toList xs = toList⊙ xs []


{-# OPTIONS --without-K --safe --overlapping-instances #-}
module Examples where

open import Data.Nat

-- local imports
open import Interpreter

pf : y' ∈ y' ::: `ℕ , (x' ::: `ℕ , ·)
pf = H

pf2 : x' ∈ y' ::: `ℕ , (x' ::: `ℕ , ·)
pf2 = TH

testSimpleLambda : · ⊢ `ℕ
testSimpleLambda = (`λ x' `: `ℕ ⇨ (`v x' `+ `v x')) `₋ `n 10

testSimpleLambda2 : · ⊢ `ℕ `⇨ `ℕ
testSimpleLambda2 = `λ x' `: `ℕ ⇨ (`v x') `+ (`v x')

testNestedLambda : · ⊢ `ℕ
testNestedLambda = (`λ x' `: `ℕ ⇨ (`λ_`:_⇨_ y' `ℕ (`v x' `* `v y'))) `₋ `n 10  `₋ `n 15

testNestedLambda2 : · ⊢  `ℕ `⇨ `ℕ `⇨ `ℕ
testNestedLambda2 = (`λ x' `: `ℕ ⇨ (`λ_`:_⇨_ y' `ℕ (`v x' `* `v y')))

-- The following definitions do not type check. They are a relic from
-- when the interpreter still had some bugs. Uncomment them to verify
-- they don't type check
-- testNamingNotWorking : · ⊢ `Bool
-- testNamingNotWorking = (`λ x' `: `Bool ⇨ (`λ x' `: `⊤ ⇨ `v x')) `₋ `true `₋ `tt

-- testNamingNotWorking2 : · ⊢ `Bool `⇨ `⊤ `⇨ `Bool -- incorrect type!
-- testNamingNotWorking2 = `λ x' `: `Bool ⇨ (`λ x' `: `⊤ ⇨ `v x')

testNamingWorking : · ⊢ `⊤
testNamingWorking = (`λ x' `: `Bool ⇨ (`λ x' `: `⊤ ⇨ `v x')) `₋ `true `₋ `tt

testNamingWorking2 : · ⊢ `Bool `⇨ `⊤ `⇨ `⊤
testNamingWorking2 = `λ x' `: `Bool ⇨ (`λ x' `: `⊤ ⇨ `v x')

testSum1 : · ⊢ `ℕ
testSum1 = `let z' `= `case `left (`n 10) `of
                              `λ z' `: `ℕ ⇨ `v z'
                           || `λ x' `: `Bool ⇨ `if `v x' `then `n 1 `else `n 0
           `in `v z'

testSum2 : · ⊢ `ℕ
testSum2 = `let z' `= `case `right `true `of
                              `λ z' `: `ℕ ⇨ `v z'
                           || `λ x' `: `Bool ⇨ `if `v x' `then `n 1 `else `n 0
           `in `v z'

testProduct1 : · ⊢ `Bool
testProduct1 = `fst (`true `, (`n 10 `, `tt ))

testProduct2 : · ⊢ `ℕ `× `⊤
testProduct2 = `snd (`true `, (`n 10 `, `tt ))

testDeMorganFullOr : · ⊢ `Bool
testDeMorganFullOr = `let z' `= `λ x' `: `Bool ⇨ `λ y' `: `Bool ⇨ `¬ (`v x' `∨ `v y')
                     `in `v z' `₋ `true `₋ `true

testDeMorganBrokenAnd : · ⊢ `Bool
testDeMorganBrokenAnd = `let z' `= `λ x' `: `Bool ⇨ `λ y' `: `Bool ⇨ `¬ `v x' `∧ `¬ `v y'
                        `in `v z' `₋ `true `₋ `true

tester : Set
tester = {! interpret testSimpleLambda2 !}


open import Level
open import Data.Unit
open import Data.Bool
open import Data.Nat
open import Data.Fin
open import Data.Sum
open import Data.Maybe
open import Data.Product
open import Data.Vec using (Vec; _∷_; [])
import Data.Vec as Vec
open import Data.List
open import Relation.Binary.PropositionalEquality

--------------- lenses

Lens : Set → Set → Set
Lens A B = A → B × (B → A)

idₗ : {A : Set} → Lens A A
idₗ = λ z → z , λ x → x

_∘ₗ_ : {A B C : Set} → Lens A B → Lens B C → Lens A C
l ∘ₗ k = λ a → let (l₁ , l₂) = l a; (k₁ , k₂) = k l₁ in k₁ , λ x → l₂ (k₂ x)

infixl 9 _∘ₗ_

--- composition laws

_≡ₗ_ : {A B : Set} (k l : Lens A B) → Set
_≡ₗ_ {A} {B} k l = (a : A) → let (k₁ , k₂) = k a; (l₁ , l₂) = l a in k₁ ≡ l₁ × ((b : B) → k₂ b ≡ l₂ b)

infix 4 _≡ₗ_

id-left : {A B : Set} (k : Lens A B) → idₗ ∘ₗ k ≡ₗ k
id-left k a = refl , λ b → refl

id-right : {A B : Set} (k : Lens A B) → k ≡ₗ idₗ ∘ₗ k
id-right k a = refl , λ b → refl

comp-assoc : {A B C D : Set} (k : Lens A B) (l : Lens B C) (m : Lens C D) → k ∘ₗ (l ∘ₗ m) ≡ₗ (k ∘ₗ l) ∘ₗ m
comp-assoc k l m a = refl , λ b → refl

--------------- heterogeneous lists

TList : Set₁
TList = List Set

data HList : TList → Set where
  [] : HList []
  _∷_ : ∀ {t : Set} {ts : TList} → (v : t) → HList ts → HList (t ∷ ts)

--- operations

_+++_ : ∀ {ts xs : TList} → HList ts → HList xs → HList (ts ++ xs)
[] +++ y = y
(v ∷ x) +++ y = v ∷ (x +++ y)

splitH : ∀ {ts xs : TList} → HList (ts ++ xs) → HList ts × HList xs
splitH {ts = []} xs₁ = [] , xs₁
splitH {ts = x ∷ ts} (v ∷ xs₁) = let (r₁ , r₂) = splitH {ts = ts} xs₁ in v ∷ r₁ , r₂

---------------- auxiliary stuff

TList′ : ℕ → Set₁
TList′ = Vec Set

data HList′ : {n : ℕ} → TList′ n → Set where
  [] : HList′ []
  _∷_ : ∀ {n} {t : Set} {ts : TList′ n} → (v : t) → HList′ ts → HList′ (t ∷ ts)

pattern ex a = ._ , a

toVec : ∀ {ℓ} {A : Set ℓ} (as : List A) → Σ ℕ λ n → (n ≡ length as) × Vec A n
toVec [] = 0 , refl , []
toVec (x ∷ as) with toVec as
toVec (x ∷ as) | ex (refl , as′) = _ , refl , x ∷ as′

toVec′ : ∀ {ts : TList} → HList ts → let (_ , _ , ts′) = toVec ts in HList′ ts′ × (HList′ ts′ → HList ts)
toVec′ {[]} [] = [] , (λ _ → [])
toVec′ {x ∷ ts} (v ∷ xs) with toVec ts | toVec′ xs
toVec′ {x ∷ ts} (v ∷ xs) | ex (refl , _) | xs′ , f = v ∷ xs′ , λ { (v₁ ∷ x₁) → v₁ ∷ f x₁ }

----------

lookup : (ts : TList) → Fin (length ts) → Set
lookup x i with toVec x
lookup x i | ex (refl , v) = Vec.lookup i v

---------------------------------------------- signals

Signal : ∀ {ℓ} → TList → Set ℓ → Set ℓ
Signal ts A = HList ts → A

widenSignal : ∀ {ts xs : TList} {A : Set} → Signal ts A → Signal (ts ++ xs) A
widenSignal s vs = s (proj₁ (splitH vs))

sig : ∀ {ts : TList} (i : Fin (length ts)) → Signal ts (lookup ts i)
sig {ts} i st with toVec ts | toVec′ st
sig i st | ex (refl , v) | z , _ = sig′ i z
  where
    sig′ : ∀ {n} {ts : Vec Set n} (i : Fin n) → HList′ ts → Vec.lookup i ts
    sig′ zero (v ∷ x) = v
    sig′ (suc i) (v ∷ x) = sig′ i x

join : ∀ {ts : TList} {A : Set} → Signal ts (Signal ts A) → Signal ts A
join s vs = s vs vs

ret : ∀ {ts : TList} {A : Set} → A → Signal ts A
ret a _ = a

-- TODO: ret + join  monad laws

------------------------------------ references

Ref : TList → Set → Set
Ref ts = Lens (HList ts)

widenRef : {ts xs : TList} {A : Set} → Ref ts A → Ref (ts ++ xs) A
widenRef r vs = let (vs₁ , vs₂) = splitH vs; (r₁ , r₂) = r vs₁ in r₁ , λ x → r₂ x +++ vs₂

ref : {ts : TList} (i : Fin (length ts)) → Ref ts (lookup ts i)
ref {ts} i st with toVec ts | toVec′ st
ref {ts} i st | ex (refl , v) | z , tr = let (r₁ , r₂) = ref′ i z in r₁ , λ x → tr (r₂ x)
  where
    ref′ : ∀ {n} {ts : TList′ n} (i : Fin n) → Lens (HList′ ts) (Vec.lookup i ts)
    ref′ zero (v ∷ x) = v , λ v → v ∷ x
    ref′ (suc i) (v ∷ x) with ref′ i x
    ref′ (suc i) (v ∷ x) | z , f = z , λ z → v ∷ f z

unitRef : ∀ {ts : TList} → Ref ts ⊤
unitRef st = tt , λ tt → st

joinRef : ∀ {ts : TList} {A : Set} → Signal ts (Ref ts A) → Ref ts A
joinRef s st = s st st

lensMap : ∀ {ts : TList} {A B : Set} → Ref ts A → Lens A B → Ref ts B
lensMap = _∘ₗ_

readRef : ∀ {ts : TList} {A : Set} → Ref ts A → Signal ts A
readRef r st = proj₁ (r st)

---------------------------------- programs

open import Coinduction

Event : TList → Set
Event ts = Σ (Fin (length ts)) λ i → lookup ts i

mutual
  data R (ts : TList) : Set₁ where
    step : HList ts → (Event ts → ∞ (W ts)) → R ts

  W : TList → Set₁
  W ts = Σ TList λ vs → R (ts ++ vs)

Prog : Set₁
Prog = W []

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

Gen : TList → TList → Set → Set
Gen ts xs A = HList ts → A × HList (ts ++ xs)

Gen′ : TList → Set → Set₁
Gen′ ts A = HList ts → A × Σ TList λ xs → HList (ts ++ xs)

-- TODO: widenGen

data Trigger (ts : TList) (A : Set) : Set₁ where
    extend : {B : Set} → Ref ts B → Lens A B → Trigger ts A
    stabilize : (A → A → Bool) → Signal ts A → Trigger ts A
    onChange : Signal ts (Gen′ ts A) → Trigger ts A

runTrigger : ∀ {ts : TList} {A : Set} → Trigger ts A → Gen′ ts A
runTrigger (extend x x₁) x₂ = {!!}
runTrigger (stabilize x x₁) x₂ = {!!}
runTrigger (onChange x) x₁ = {!!}

-- ...


module static where

open import Data.Nat using (ℕ; _+_; zero; suc)
open import Data.Fin using (Fin; toℕ; zero; suc)
open import Data.Vec using (lookup; _∷_; [])
open import Data.Bool using (Bool; true; false)
open import LSsyntax
open import Relation.Binary.PropositionalEquality -- using (_≡_; refl)

-- inference rules for typed terms
data STyped {n} (Γ : Ctx n) : GType → Set where
    Sx   : ∀ {S} (v : Fin n) → S ≡ lookup v Γ → STyped Γ S
    Sb   : Bool → (ℓ : Label) → STyped Γ (bool ℓ)
    _S∧_ : ∀ {t₁ t₂} → STyped Γ t₁ → STyped Γ t₂ → STyped Γ (bool (getLabel t₁ ~⋎~ getLabel t₂))
    _S∨_ : ∀ {t₁ t₂} → STyped Γ t₁ → STyped Γ t₂ → STyped Γ (bool (getLabel t₁ ~⋎~ getLabel t₂))
    Sif  : ∀ {t t₁ t₂} → STyped Γ t → STyped Γ t₁ → STyped Γ t₂ → STyped Γ (bool (getLabel (t₁ :∨: t₂) ~⋎~ getLabel t))
    S∙   : ∀ {t₁ ℓ t₂ t₃} → STyped Γ ((t₁ ⇒ ℓ) t₂) → STyped Γ t₃ → t₃ ≾ t₁ → STyped Γ (bool ((getLabel t₂) ~⋎~ ℓ))
    Sλ   : ∀ t₁ {t₂} ℓ → STyped (t₁ ∷ Γ) t₂ → STyped Γ ((t₁ ⇒ ℓ) t₂)

erase : ∀ {n} {Γ : Ctx n} {t} → STyped Γ t → Term
erase (Sx v x)      = var (toℕ v)
erase (Sb b ℓ)      = litBool b ℓ
erase (t₁ S∧ t₂)    = (erase t₁) ∧ erase t₂
erase (t₁ S∨ t₂)    = (erase t₁) ∨ (erase t₂)
erase (Sif b t₁ t₂) = if (erase b) then (erase t₁) else (erase t₂)
erase (S∙ t₁ t₂ _)  = (erase t₁) ∙ (erase t₂)
erase (Sλ t₁ ℓ t)   = lam t₁ (erase t) ℓ

data Fromℕ (n : ℕ) : ℕ → Set where
    yes : (m : Fin n) → Fromℕ n (toℕ m)
    no  : (m : ℕ) → Fromℕ n (n + m)

fromℕ : ∀ n m → Fromℕ n m
fromℕ zero m = no m
fromℕ (suc n) zero = yes zero
fromℕ (suc n) (suc m) with fromℕ n m
fromℕ (suc n) (suc .(toℕ m)) | yes m = yes (suc m)
fromℕ (suc n) (suc .(n + m)) | no m = no m

data Check {n} (Γ : Ctx n) : Term → Set where
    yes : (τ : GType) (t : STyped Γ τ) → Check Γ (erase t)
    no  : {e : Term} → Check Γ e

staticCheck : ∀ {n} (Γ : Ctx n) (t : Term) → Check Γ t
staticCheck {n} Γ (var v) with fromℕ n v
staticCheck {n} Γ (var .(toℕ m)) | yes m = yes (lookup m Γ) (Sx m refl)
staticCheck {n} Γ (var .(n + m)) | no m = no

staticCheck Γ (litBool x ℓ) = yes (bool ℓ) (Sb x ℓ)

staticCheck Γ (lam x t ℓ) with staticCheck (x ∷ Γ) t
staticCheck Γ (lam x .(erase t) ℓ) | yes τ t = yes ((x ⇒ ℓ) τ) (Sλ x ℓ t)
staticCheck Γ (lam x t ℓ) | no = no

staticCheck Γ (t ∧ t₁) with staticCheck Γ t | staticCheck Γ t₁
staticCheck Γ (.(erase t₁) ∧ .(erase t)) | yes τ₁ t₁ | (yes τ t) = yes (bool (getLabel τ₁ ~⋎~ getLabel τ)) (t₁ S∧ t)
staticCheck Γ (.(erase t) ∧ t₁) | yes τ t | no = no
staticCheck Γ (t₁ ∧ .(erase t)) | no | yes τ t = no
staticCheck Γ (t ∧ t₁) | no | no = no

staticCheck Γ (t ∨ t₁) with staticCheck Γ t | staticCheck Γ t₁
staticCheck Γ (.(erase t₁) ∨ .(erase t)) | yes τ₁ t₁ | (yes τ t) = yes (bool (getLabel τ₁ ~⋎~ getLabel τ)) (t₁ S∨ t)
staticCheck Γ (.(erase t) ∨ t₁) | yes τ t | no = no
staticCheck Γ (t₁ ∨ .(erase t)) | no | yes τ t = no
staticCheck Γ (t ∨ t₁) | no | no = no

staticCheck Γ (t ∙ t₁) with staticCheck Γ t | staticCheck Γ t₁
staticCheck Γ (.(erase t) ∙ .(erase t₁)) | yes ((τ ⇒ ℓ) τ₂) t | (yes τ₁ t₁) with τ₁ ≾? τ
staticCheck Γ (.(erase t) ∙ .(erase t₁)) | yes ((τ ⇒ ℓ) τ₂) t | (yes τ₁ t₁) | (yes .τ₁ .τ) = yes (bool (getLabel τ₂ ~⋎~ ℓ)) (S∙ t t₁ (yes τ₁ τ))
staticCheck Γ (.(erase t) ∙ .(erase t₁)) | yes ((τ ⇒ ℓ) τ₂) t | (yes τ₁ t₁) | (no .τ₁ .τ) = no
staticCheck Γ (.(erase t) ∙ .(erase t₁)) | yes err t | (yes τ₁ t₁) = no
staticCheck Γ (.(erase t) ∙ .(erase t₁)) | yes (bool x) t | (yes τ₁ t₁) = no
staticCheck Γ (.(erase t) ∙ t₁) | yes τ t | no = no
staticCheck Γ (t₁ ∙ .(erase t)) | no | yes τ t = no
staticCheck Γ (t ∙ t₁) | no | no = no

staticCheck Γ (if b then t₁ else t₂) with staticCheck Γ b
staticCheck Γ (if .(erase t) then t₁ else t₂) | yes τ t with staticCheck Γ t₁ | staticCheck Γ t₂
staticCheck Γ (if .(erase t₂) then .(erase t₁) else .(erase t)) | yes τ₂ t₂ | (yes τ₁ t₁) | (yes τ t) = yes (bool (getLabel (τ₁ :∨: τ) ~⋎~ getLabel τ₂)) (Sif t₂ t₁ t)
staticCheck Γ (if .(erase t₁) then .(erase t) else t₂)          | yes τ₁ t₁ | (yes τ t)   | no = no
staticCheck Γ (if .(erase t₂) then t₁ else .(erase t))          | yes τ₁ t₂ | no          | (yes τ t) = no
staticCheck Γ (if .(erase t) then t₁ else t₂)                   | yes τ t   | no          | no = no
staticCheck Γ (if b then t₁ else t₂)                            | no = no

staticCheck Γ error = no

-- examples from Section 3.5

-- Type : yes ((bool ⊥ ⇒ ⊥) (bool ⊥)) (Sλ (bool ⊥) ⊥ (Sx zero refl S∧ Sx zero refl))
f : Term
f = lam (bool ⊥) (var 0 ∨ var 0) ⊥

-- Type : yes ((bool ✭ ⇒ ⊥) (bool ✭)) (Sλ (bool ✭) ⊥ (Sx zero refl S∨ Sx zero refl))
g : Term
g = lam (bool ✭) (var 0 ∧ var 0) ⊥

-- Type : yes (bool ⊤) (Sb false ⊤)
v : Term
v = litBool false ⊤

test₁ : staticCheck [] (f ∙ v) ≡ no
test₁ = refl


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

data Unit : Set where
  unit : Unit

record _∼_ (From To : Set) : Set where
  field
    to      : From → To
    from    : To → From
    to-from : ∀ {x} → to (from x) ≡ x

postulate
  P : {A : Set} → A → Set
  f : {A B : Set} (A∼B : A ∼ B) (x : A) → P (_∼_.to A∼B x) ∼ P x

record R : Set where
  field
    p   : {x y : Unit} → P x → P y
    u v : Unit

g : (r : R) → _ ∼ P r
g = f lemma
  where
  lemma : R ∼ Σ _ λ _ → Σ _ λ (_ : ∀ {x y} → _ → _) → _
  lemma = record
    { to      = λ x → R.u x , R.p x , R.v x
    ; from    = λ { (u , p , v) → record
                    { u  = u
                    ; p  = λ {x y} → p {x = x} {y = y}
                    ; v  = v
                    } }
    ; to-from = refl
    }


data ℕ : Set where
  zero : ℕ
  succ : ℕ → ℕ

data D : Set

foo : ℕ → ℕ
foo n = n

data D where
  lam : (D → D) → D


module Numeral.Natural.Oper.Modulo.Proofs.Algorithm where

import Lvl
open import Logic
open import Numeral.Natural
open import Numeral.Natural.Oper
open import Numeral.Natural.Oper.Modulo
open import Numeral.Natural.Oper.Proofs
open import Numeral.Natural.Oper.Proofs.Order
open import Numeral.Natural.Relation
open import Numeral.Natural.Relation.Order
open import Numeral.Natural.Relation.Order.Proofs
open import Relator.Equals
open import Relator.Equals.Proofs
open import Structure.Function
open import Structure.Operator.Properties
open import Structure.Relator.Properties
open import Syntax.Function
open import Syntax.Transitivity
open import Type

-- The many steps variant of: `[ r , b ] 𝐒(a') mod' 𝐒(b') = [ 𝐒(r) , b ] a' mod' b'` from the definition.
mod'-ind-step : ∀{r b' a b c} → [ r , b' ] (a + c) mod' (b + c) ≡ [ (r + c) , b' ] a mod' b
mod'-ind-step {_}{_} {_}{_}{𝟎}   = [≡]-intro
mod'-ind-step {r}{b'}{a}{b}{𝐒 c} = mod'-ind-step {𝐒 r}{b'}{a}{b}{c = c}

-- The many steps variant of: `[ r , b ] 𝐒(a') mod' 𝐒(b') = [ 𝐒(r) , b ] a' mod' b'` from the definition when the dividend is greater than the modulus.
mod'-ind-step-modulo : ∀{r m' a m} → [ r , m' ] (a + m) mod' m ≡ [ (r + m) , m' ] a mod' 𝟎
mod'-ind-step-modulo {r}{m'}{a}{𝟎} =
  [ r       , m' ] (a + 𝟎) mod' 𝟎 🝖[ _≡_ ]-[]
  [ (r + 𝟎) , m' ] a       mod' 𝟎 🝖-end
mod'-ind-step-modulo {r}{m'}{a}{𝐒 m} =
  [ r          , m' ] (a + 𝐒(m)) mod' 𝐒(m) 🝖[ _≡_ ]-[]
  [ r          , m' ] 𝐒(a + m)   mod' 𝐒(m) 🝖[ _≡_ ]-[]
  [ 𝐒(r)       , m' ] (a + m)    mod' m    🝖[ _≡_ ]-[ mod'-ind-step-modulo {𝐒 r}{m'}{a}{m} ]
  [ 𝐒(r + m)   , m' ] a          mod' 𝟎    🝖[ _≡_ ]-[]
  [ (r + 𝐒(m)) , m' ] a          mod' 𝟎    🝖-end

-- When states and modulus is zero, the result is zero.
mod'-zero-all-except-dividend : ∀{a} → ([ 0 , 0 ] a mod' 0 ≡ 0)
mod'-zero-all-except-dividend {𝟎}    = [≡]-intro
mod'-zero-all-except-dividend {𝐒(a)} = mod'-zero-all-except-dividend {a}

mod'-greater-dividend : ∀{r b' a b} → (a > b) → ([ r , b' ] a mod' b ≡ [ 𝟎 , b' ] (a −₀ 𝐒(b)) mod' b')
mod'-greater-dividend {r} {b'} {.(𝐒 _)} {𝟎}   (succ ab) = [≡]-intro
mod'-greater-dividend {r} {b'} {.(𝐒 _)} {𝐒 b} (succ ab) = mod'-greater-dividend ab

mod'-zero-modulo-greater-dividend : ∀{r a b} → (a > b) → ([ r , 𝟎 ] a mod' b ≡ 𝟎)
mod'-zero-modulo-greater-dividend {r} {.𝟏}         {𝟎}   (succ {y = 𝟎}   ab) = [≡]-intro
mod'-zero-modulo-greater-dividend {r} {.(𝐒 (𝐒 a))} {𝟎}   (succ {y = 𝐒 a} ab) = mod'-zero-all-except-dividend {a}
mod'-zero-modulo-greater-dividend {r} {.(𝐒 _)}     {𝐒 b} (succ           ab) = mod'-zero-modulo-greater-dividend ab

mod'-lesser-dividend : ∀{r b' a b} → (a ≤ b) → ([ r , b' ] a mod' b ≡ r + a)
mod'-lesser-dividend {r} {b'} min = [≡]-intro
mod'-lesser-dividend {r} {b'} (succ ab) = mod'-lesser-dividend {𝐒 r} {b'} ab

-- When the number is the temporary modulus, the result is zero.
mod'-equal-dividend : ∀{r b' b} → ([ r , b' ] 𝐒(b) mod' b) ≡ 𝟎
mod'-equal-dividend {r}{b'}{b} = mod'-greater-dividend {r}{b'} (reflexivity(_≤_) {𝐒 b})

mod'-sumᵣ-modulo : ∀{r b' a b} → ([ r , b' ] (a + 𝐒(b)) mod' b) ≡ ([ 𝟎 , b' ] a mod' b')
mod'-sumᵣ-modulo {r}{b'}{a}{b} = mod'-greater-dividend {r}{b'}{a + 𝐒(b)}{b} (succ([≤]-of-[+]ᵣ {a}{b})) 🝖 congruence₁(a ↦ [ 𝟎 , b' ] a mod' b') (inverseOperᵣ(_+_)(_−₀_) {a}{b})

-- When the
mod'-sumₗ-modulo : ∀{r b' a b} → ([ r , b' ] (𝐒(b) + a) mod' b) ≡ ([ 𝟎 , b' ] a mod' b')
mod'-sumₗ-modulo {r}{b'}{a}{b} = congruence₁(a ↦ [ r , b' ] a mod' b) (commutativity(_+_) {𝐒(b)}{a}) 🝖 mod'-sumᵣ-modulo {r}{b'}{a}{b}

mod'-maxᵣ : ∀{r b a b'} → ⦃ _ : (b' ≤ b) ⦄ → (([ r , r + b ] a mod' b') ≤ r + b)
mod'-maxᵣ {r} {b} {𝟎} {b'} ⦃ b'b ⦄ = [≤]-of-[+]ₗ
mod'-maxᵣ {r} {𝟎} {𝐒 a} {.0} ⦃ min ⦄ = mod'-maxᵣ {𝟎} {r} {a} {r} ⦃ reflexivity(_≤_) ⦄
mod'-maxᵣ {r} {𝐒 b} {𝐒 a} {.0} ⦃ min ⦄ = mod'-maxᵣ {𝟎} {𝐒(r + b)} {a} {𝐒(r + b)} ⦃ reflexivity(_≤_) ⦄
mod'-maxᵣ {r} {𝐒 b} {𝐒 a} {𝐒 b'} ⦃ succ {b'} p ⦄ = mod'-maxᵣ {𝐒 r} {b} {a} {b'} ⦃ p ⦄

mod'-maxₗ : ∀{r b a b'} → (([ r , b ] a mod' b') ≤ r + a)
mod'-maxₗ {𝟎}  {_}  {𝟎}  {_}    = min
mod'-maxₗ {𝐒 r}{b}  {𝟎}  {𝐒 b'} = mod'-maxₗ {𝐒 r}{𝟎}{𝟎}{b'}
mod'-maxₗ {𝐒 r}{𝐒 b}{𝟎}  {b'}   = mod'-maxₗ {𝐒 r}{b}{𝟎}{b'}
mod'-maxₗ {𝐒 r}{b}  {𝐒 a}{𝟎}    = mod'-maxₗ {𝟎} {b} {a} {b} 🝖 [≤]-successor ([≤]-successor ([≤]-of-[+]ᵣ {r}))
mod'-maxₗ {r}  {b}  {𝐒 a}{𝐒 b'} = mod'-maxₗ {𝐒 r} {b} {a} {b'}
mod'-maxₗ {𝟎}  {𝟎}  {𝐒 a}{𝟎}    = [≤]-successor(mod'-maxₗ {𝟎} {𝟎} {a} {𝟎})
mod'-maxₗ {𝟎}  {𝐒 b}{𝐒 a}{𝟎}    = [≤]-successor(mod'-maxₗ {0} {𝐒 b} {a} {𝐒 b})
mod'-maxₗ {𝐒 r}{𝟎}  {𝟎}  {𝟎}    = succ(mod'-maxₗ {r}{𝟎}{𝟎}{𝟎})


{-# OPTIONS --copatterns #-}

module Control.Functor.NaturalTransformation where

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

open import Control.Functor using (Functor; module Functor; Const)
open import Control.Category using (Category; module Category)

-- Natural transformations.

IsNatTrans : (F! G! : Functor) →
  let open Functor F! using () renaming (F to F; map to mapF)
      open Functor G! using () renaming (F to G; map to mapG)
  in
      (n : ∀ {A} → F A → G A) → Set₁

IsNatTrans F! G! eta = ∀ {A B} (f : A → B) →
  let open Functor F! using () renaming (F to F; map to mapF)
      open Functor G! using () renaming (F to G; map to mapG)
  in
      eta ∘ mapF f ≡ mapG f ∘ eta

-- Constant-Constant natural transformation.

KKNat : ∀ {A B} (η : A → B) → IsNatTrans (Const A) (Const B) η
KKNat η = λ f → refl

-- Natural transformations (packaged).

record NatTrans (F! G! : Functor) : Set₁ where

  open Functor F! using () renaming (F to F; map to mapF)
  open Functor G! using () renaming (F to G; map to mapG)
  field

    eta        : ∀ {A} → F A → G A

    naturality : ∀ {A B} (f : A → B) →

        eta ∘ mapF f ≡ mapG f ∘ eta

  -- To use naturality in applications:
  postulate
    app-naturality : ∀ {A : Set} {B C : A → Set}
     (f : (x : A) → B x → C x)
     (g : (x : A) → F (B x))
     (x : A) →

        eta (mapF (f x) (g x)) ≡ mapG (f x) (eta (g x))

  -- app-naturality g f x = {!!}

open NatTrans

-- The identity natural transformation.

Id : ∀ {F! : Functor} → NatTrans F! F!
Id {F! = F!} = record { eta = λ x → x ; naturality = λ f → refl }

-- Natural transformations compose.

Comp : ∀ {F! G! H! : Functor} → NatTrans F! G! → NatTrans G! H! → NatTrans F! H!
Comp {F! = F!}{G! = G!}{H! = H!} n m = record { eta = nm ; naturality = snm }
  where
    open Functor F! using () renaming (F to F; map to mapF)
    open Functor G! using () renaming (F to G; map to mapG)
    open Functor H! using () renaming (F to H; map to mapH)

    nm : ∀ {A} → F A → H A
    nm = λ x → eta m (eta n x)

    snm :  ∀ {A B} (f : A → B) →

        nm ∘ mapF f ≡ mapH f ∘ nm

    snm f = begin
        nm ∘ mapF f             ≡⟨⟩
        eta m ∘ eta n ∘ mapF f  ≡⟨ cong (λ z → eta m ∘ z) (naturality n f) ⟩
        eta m ∘ mapG f ∘ eta n  ≡⟨ cong (λ z → z ∘ eta n) (naturality m f) ⟩
        mapH f ∘ eta m ∘ eta n  ≡⟨⟩
        mapH f ∘ nm
      ∎

-- Natural transformation between constant functors.

ConstNat : ∀ {A B} (η : A → B) → NatTrans (Const A) (Const B)
ConstNat η = record
  { eta        = η
  ; naturality = λ f → refl
  }

-- Functor category.

FunctorHom : ∀ (F G : Functor) → Setoid _ _
FunctorHom F G = record
  { Carrier       = NatTrans F G
  ; _≈_           = λ n m → ∀ {A} → eta n {A} ≡ eta m {A}
  ; isEquivalence = record
    { refl  = refl
    ; sym   = λ p → sym p
    ; trans = λ p q → trans p q
    }
  }

FUNCTOR : Category _ _ _
FUNCTOR = record
  { Hom = FunctorHom
  ; isCategory = record
    { ops = record
      { id = Id
      ; _⟫_ = Comp
    }
    ; laws = record
      { id-first = refl
      ; id-last  = refl
      ; ∘-assoc  = λ f → refl
      ; ∘-cong   = λ n≡n' m≡m' → cong₂ (λ m n x → m (n x)) m≡m' n≡n' }
    }
  }


open import Web.Semantic.DL.ABox.Interp using ( _*_ )
open import Web.Semantic.DL.Category.Object using ( Object )
open import Web.Semantic.DL.Category.Morphism using ( _⇒_ ; _≣_ ; _⊑_ ; _,_ )
open import Web.Semantic.DL.Category.Composition using ( _∙_ )
open import Web.Semantic.DL.Category.Properties.Composition.Lemmas using
  ( compose-left ; compose-mid ; compose-right ; compose-resp-⊨b )
open import Web.Semantic.DL.Signature using ( Signature )
open import Web.Semantic.DL.TBox using ( TBox )
open import Web.Semantic.Util using ( left ; right )

module Web.Semantic.DL.Category.Properties.Composition.RespectsEquiv
  {Σ : Signature} {S T : TBox Σ} where

compose-resp-⊑ : ∀ {A B C : Object S T} (F₁ F₂ : A ⇒ B) (G₁ G₂ : B ⇒ C) →
  (F₁ ⊑ F₂) → (G₁ ⊑ G₂) → (F₁ ∙ G₁ ⊑ F₂ ∙ G₂)
compose-resp-⊑ F₁ F₂ G₁ G₂ F₁⊑F₂ G₁⊑G₂ I I⊨STA I⊨F₁⟫G₁ =
  compose-resp-⊨b F₂ G₂ I
    (F₁⊑F₂ (left * I) I⊨STA
      (compose-left F₁ G₁ I I⊨F₁⟫G₁))
    (G₁⊑G₂ (right * I) (compose-mid F₁ G₁ I I⊨STA I⊨F₁⟫G₁)
      (compose-right F₁ G₁ I I⊨F₁⟫G₁))

compose-resp-≣ : ∀ {A B C : Object S T} {F₁ F₂ : A ⇒ B} {G₁ G₂ : B ⇒ C} →
  (F₁ ≣ F₂) → (G₁ ≣ G₂) → (F₁ ∙ G₁ ≣ F₂ ∙ G₂)
compose-resp-≣ {A} {B} {C} {F₁} {F₂} {G₁} {G₂}
  (F₁⊑F₂ , F₂⊑F₁) (G₁⊑G₂ , G₂⊑G₁) =
    ( compose-resp-⊑ F₁ F₂ G₁ G₂ F₁⊑F₂ G₁⊑G₂
    , compose-resp-⊑ F₂ F₁ G₂ G₁ F₂⊑F₁ G₂⊑G₁ )


-- Andreas, 2019-04-10, issue #3689, reported by andrejtokarcik

-- Regression introduced by #3533 (dropping trivially impossible clauses
-- during case-splitting).

-- {-# OPTIONS -v interaction.case:100 #-}
-- {-# OPTIONS -v tc.cover:100 #-}

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

record Σ (A : Set) (B : A → Set) : Set where
  constructor _,_
  field
    fst : A
    snd : B fst

record R (A : Set) : Set where
  field π : A

fun : {A : Set} (xyz : Σ (R A) λ r → Σ (R.π r ≡ R.π r) λ _ → R.π r ≡ R.π r) → Set
fun (x , y) = {!y !} -- C-c C-c

-- WAS: internal error.

-- Should succeed.


{-

This file contains:

- Definitions equivalences

- Glue types

-}
{-# OPTIONS --cubical --no-import-sorts --safe #-}
module Cubical.Core.Glue where

open import Cubical.Core.Primitives

open import Agda.Builtin.Cubical.Glue public
  using ( isEquiv       -- ∀ {ℓ ℓ'} {A : Type ℓ} {B : Type ℓ'} (f : A → B) → Type (ℓ ⊔ ℓ')

        ; equiv-proof   -- ∀ (y : B) → isContr (fiber f y)

        ; _≃_           -- ∀ {ℓ ℓ'} (A : Type ℓ) (B : Type ℓ') → Type (ℓ ⊔ ℓ')

        ; equivFun      -- ∀ {ℓ ℓ'} {A : Type ℓ} {B : Type ℓ'} → A ≃ B → A → B

        ; equivProof    -- ∀ {ℓ ℓ'} (T : Type ℓ) (A : Type ℓ') (w : T ≃ A) (a : A) φ →
                        -- Partial φ (fiber (equivFun w) a) → fiber (equivFun w) a

        ; primGlue      -- ∀ {ℓ ℓ'} (A : Type ℓ) {φ : I} (T : Partial φ (Type ℓ'))
                        -- → (e : PartialP φ (λ o → T o ≃ A)) → Type ℓ'

        ; prim^unglue   -- ∀ {ℓ ℓ'} {A : Type ℓ} {φ : I} {T : Partial φ (Type ℓ')}
                        -- → {e : PartialP φ (λ o → T o ≃ A)} → primGlue A T e → A

        -- The ∀ operation on I. This is commented out as it is not currently used for anything
        -- ; primFaceForall -- (I → I) → I
        )
  renaming ( prim^glue   to glue         -- ∀ {ℓ ℓ'} {A : Type ℓ} {φ : I} {T : Partial φ (Type ℓ')}
                                         -- → {e : PartialP φ (λ o → T o ≃ A)}
                                         -- → PartialP φ T → A → primGlue A T e

           ; pathToEquiv to lineToEquiv  -- ∀ {ℓ : I → Level} (P : (i : I) → Type (ℓ i)) → P i0 ≃ P i1
           )

private
  variable
    ℓ ℓ' : Level

-- Uncurry Glue to make it more pleasant to use
Glue : (A : Type ℓ) {φ : I}
       → (Te : Partial φ (Σ[ T ∈ Type ℓ' ] T ≃ A))
       → Type ℓ'
Glue A Te = primGlue A (λ x → Te x .fst) (λ x → Te x .snd)

-- Make the φ argument of prim^unglue explicit
unglue : {A : Type ℓ} (φ : I) {T : Partial φ (Type ℓ')}
         {e : PartialP φ (λ o → T o ≃ A)} → primGlue A T e → A
unglue φ = prim^unglue {φ = φ}

-- People unfamiliar with [Glue], [glue] and [uglue] can find the types below more
-- informative as they demonstrate the computational behavior.
--
-- Full inference rules can be found in Section 6 of CCHM:
-- https://arxiv.org/pdf/1611.02108.pdf
-- Cubical Type Theory: a constructive interpretation of the univalence axiom
-- Cyril Cohen, Thierry Coquand, Simon Huber, Anders Mörtberg
private

  module GluePrims (A : Type ℓ) {φ : I} (Te : Partial φ (Σ[ T ∈ Type ℓ' ] T ≃ A)) where
    T : Partial φ (Type ℓ')
    T φ1 = Te φ1 .fst
    e : PartialP φ (λ φ → T φ ≃ A)
    e φ1 = Te φ1 .snd

    -- Glue can be seen as a subtype of Type that, at φ, is definitionally equal to the left type
    -- of the given equivalences.
    Glue-S : Type ℓ' [ φ ↦ T ]
    Glue-S = inS (Glue A Te)

    -- Which means partial elements of T are partial elements of Glue
    coeT→G :
      ∀ (t : PartialP φ T)
      → Partial φ (Glue A Te)
    coeT→G t (φ = i1) = t 1=1

    -- ... and elements of Glue can be seen as partial elements of T
    coeG→T :
      ∀ (g : Glue A Te)
      → PartialP φ T
    coeG→T g (φ = i1) = g

    -- What about elements that are applied to the equivalences?
    trans-e :
      ∀ (t : PartialP φ T)
      → Partial φ A
    trans-e t ϕ1 = equivFun (e ϕ1) (t ϕ1)

    -- glue gives a partial element of Glue given an element of A. Note that it "undoes"
    -- the application of the equivalences!
    glue-S :
      ∀ (t : PartialP φ T)
      → A [ φ ↦ trans-e t ]
      → Glue A Te [ φ ↦ coeT→G t ]
    glue-S t s = inS (glue t (outS s))

    -- typechecking glue enforces this, e.g. you can not simply write
    -- glue-bad : (t : PartialP φ T) → A → Glue A Te
    -- glue-bad t s = glue t s

    -- unglue does the inverse:
    unglue-S :
      ∀ (b : Glue A Te)
      → A [ φ ↦ trans-e (coeG→T b) ]
    unglue-S b = inS (unglue φ b)

  module GlueTransp (A : I → Type ℓ) (Te : (i : I) → Partial (i ∨ ~ i) (Σ[ T ∈ Type ℓ' ] T ≃ A i)) where
    A0 A1 : Type ℓ
    A0 = A i0
    A1 = A i1
    T : (i : I) → Partial (i ∨ ~ i) (Type ℓ')
    T i φ = Te i φ .fst
    e : (i : I) → PartialP (i ∨ ~ i) (λ φ → T i φ ≃ A i)
    e i φ = Te i φ .snd
    T0 T1 : Type ℓ'
    T0 = T i0 1=1
    T1 = T i1 1=1
    e0 : T0 ≃ A0
    e0 = e i0 1=1
    e1 : T1 ≃ A1
    e1 = e i1 1=1

    open import Cubical.Foundations.Prelude using (transport)
    transportA : A0 → A1
    transportA = transport (λ i → A i)

    -- copied over from Foundations/Equiv for readability, can't directly import due to cyclic dependency
    invEq : ∀ {X : Type ℓ'} {ℓ''} {Y : Type ℓ''} (w : X ≃ Y) → Y → X
    invEq w y = w .snd .equiv-proof y .fst .fst

    -- transport in Glue reduces to transport in A + the application of the equivalences in forward and backward
    -- direction.
    transp-S : (t0 : T0) → T1 [ i1 ↦ (λ _ → invEq e1 (transportA (equivFun e0 t0))) ]
    transp-S t0 = inS (transport (λ i → Glue (A i) (Te i)) t0)