{-# OPTIONS --safe --warning=error --without-K #-}

open import LogicalFormulae
open import Setoids.Setoids
open import Groups.Definition
open import Sets.EquivalenceRelations
open import Groups.Abelian.Definition
open import Groups.Homomorphisms.Definition
open import Groups.DirectSum.Definition
open import Groups.Isomorphisms.Definition

module Groups.Abelian.Lemmas where

directSumAbelianGroup : {m n o p : _} → {A : Set m} {S : Setoid {m} {o} A} {_·A_ : A → A → A} {B : Set n} {T : Setoid {n} {p} B} {_·B_ : B → B → B} {underG : Group S _·A_} {underH : Group T _·B_} (G : AbelianGroup underG) (h : AbelianGroup underH) → (AbelianGroup (directSumGroup underG underH))
AbelianGroup.commutative (directSumAbelianGroup {A = A} {B} G H) = AbelianGroup.commutative G ,, AbelianGroup.commutative H

subgroupOfAbelianIsAbelian : {a b c d : _} {A : Set a} {B : Set b} {S : Setoid {a} {c} A} {T : Setoid {b} {d} B} {_+A_ : A → A → A} {_+B_ : B → B → B} {G : Group S _+A_} {H : Group T _+B_} {f : B → A} {fHom : GroupHom H G f} → SetoidInjection T S f → AbelianGroup G → AbelianGroup H
AbelianGroup.commutative (subgroupOfAbelianIsAbelian {S = S} {_+B_ = _+B_} {fHom = fHom} fInj record { commutative = commutative }) {x} {y} = SetoidInjection.injective fInj (transitive (GroupHom.groupHom fHom) (transitive commutative (symmetric (GroupHom.groupHom fHom))))
  where
    open Setoid S
    open Equivalence eq

abelianIsGroupProperty : {a b c d : _} {A : Set a} {B : Set b} {S : Setoid {a} {c} A} {T : Setoid {b} {d} B} {_+A_ : A → A → A} {_+B_ : B → B → B} {G : Group S _+A_} {H : Group T _+B_} → GroupsIsomorphic G H → AbelianGroup H → AbelianGroup G
abelianIsGroupProperty iso abH = subgroupOfAbelianIsAbelian {fHom = GroupIso.groupHom (GroupsIsomorphic.proof iso)} (SetoidBijection.inj (GroupIso.bij (GroupsIsomorphic.proof iso))) abH


{-# OPTIONS --without-K --exact-split --allow-unsolved-metas #-}

module 16-sets where

import 15-number-theory
open 15-number-theory public


open import Categories
open import Monads

module Monads.EM.Functors {a b}{C : Cat {a}{b}}(M : Monad C) where

open import Library
open import Functors
open import Monads.EM M

open Cat C
open Fun
open Monad M
open Alg
open AlgMorph

EML : Fun C EM
EML = record {
  OMap = λ X → record {
    acar  = T X;
    astr  = λ _ → bind;
    alaw1 = sym law2;
    alaw2 = law3};
  HMap = λ f → record {
    amor = bind (comp η f);
    ahom = λ {Z} {g} →
      proof
      comp (bind (comp η f)) (bind g)
      ≅⟨ sym law3 ⟩
      bind (comp (bind (comp η f)) g)
      ∎};
  fid = AlgMorphEq (
    proof
    bind (comp η iden)
    ≅⟨ cong bind idr ⟩
    bind η
    ≅⟨ law1 ⟩
    iden ∎);
  fcomp = λ {_}{_}{_}{f}{g} →
    AlgMorphEq (
      proof
      bind (comp η (comp f g))
      ≅⟨ cong bind (sym ass) ⟩
      bind (comp (comp η f) g)
      ≅⟨ cong (λ f → bind (comp f g)) (sym law2) ⟩
      bind (comp (comp (bind (comp η f)) η) g)
      ≅⟨ cong bind ass ⟩
      bind (comp (bind (comp η f)) (comp η g))
      ≅⟨ law3 ⟩
      comp (bind (comp η f)) (bind (comp η g))
      ∎)}

EMR : Fun EM C
EMR  = record {
  OMap  = acar;
  HMap  = amor;
  fid   = refl;
  fcomp = refl}


module UniDB where

open import UniDB.Morph.Depth public
open import UniDB.Morph.Pair public
open import UniDB.Morph.Reg public
open import UniDB.Morph.Shift public
open import UniDB.Morph.Shifts public
open import UniDB.Morph.ShiftsPrime public
open import UniDB.Morph.Sim public
open import UniDB.Morph.Star public
open import UniDB.Morph.StarPrime public
open import UniDB.Morph.Sub public
open import UniDB.Morph.Subs public
open import UniDB.Morph.Sum public
open import UniDB.Morph.Unit public
open import UniDB.Morph.Weaken public
open import UniDB.Morph.WeakenOne public
open import UniDB.Morph.WeakenPrime public
open import UniDB.Spec public
open import UniDB.Subst public
open import UniDB.Subst.Inst public
open import UniDB.Subst.Pair public
open import UniDB.Subst.Reg public
open import UniDB.Subst.Shifts public
open import UniDB.Subst.Star public
open import UniDB.Subst.StarPrime public
open import UniDB.Subst.Subs public
open import UniDB.Subst.Sum public


{-# OPTIONS --universe-polymorphism #-}
module CompareLevel where

open import Common.Level

postulate
  X : Set
  Foo : (a b : Level) → Set (a ⊔ b) → Set
  Bar : Foo _ _ X  -- solve _1 ⊔ _2 = 0

postulate
  id    : ∀ {a}{A : Set a} → A → A
  apply : ∀ {a b} {A : Set a} {B : Set b} (f : A → B) → A → B
  a b   : Level
  Any   : (ℓ : Level) → Set ℓ
  any   : ∀ {ℓ} → Any ℓ

-- Too aggressive level solving can cause a problem here.
foo : Any (a ⊔ b)
foo =
  apply {_}{_} id any


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

open import lib.Basics
open import lib.types.Span
open import lib.types.Pointed
open import lib.types.Pushout
open import lib.types.PushoutFlattening
open import lib.types.Unit
open import lib.types.Paths
open import lib.cubical.Square

-- Suspension is defined as a particular case of pushout

module lib.types.Suspension where

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

  suspension-span : Span
  suspension-span = span Unit Unit A (λ _ → tt) (λ _ → tt)

  Suspension : Type i
  Suspension = Pushout suspension-span

  north : Suspension
  north = left tt

  south : Suspension
  south = right tt

  merid : A → north == south
  merid x = glue x

  module SuspensionElim {j} {P : Suspension → Type j} (n : P north)
    (s : P south) (p : (x : A) → n == s [ P ↓ merid x ])
    = PushoutElim (λ _ → n) (λ _ → s) p

  open SuspensionElim public using () renaming (f to Suspension-elim)

  module SuspensionRec {j} {C : Type j} (n s : C) (p : A → n == s)
    = PushoutRec {d = suspension-span} (λ _ → n) (λ _ → s) p

  module SuspensionRecType {j} (n s : Type j) (p : A → n ≃ s)
    = PushoutRecType {d = suspension-span} (λ _ → n) (λ _ → s) p

suspension-⊙span : ∀ {i} → Ptd i → ⊙Span
suspension-⊙span X =
  ⊙span ⊙Unit ⊙Unit X (⊙cst {X = X}) (⊙cst {X = X})

⊙Susp : ∀ {i} → Ptd i → Ptd i
⊙Susp (A , _) = ⊙[ Suspension A , north A ]

σloop : ∀ {i} (X : Ptd i) → fst X → north (fst X) == north (fst X)
σloop (_ , x₀) x = merid _ x ∙ ! (merid _ x₀)

σloop-pt : ∀ {i} {X : Ptd i} → σloop X (snd X) == idp
σloop-pt {X = (_ , x₀)} = !-inv-r (merid _ x₀)

module FlipSusp {i} {A : Type i} = SuspensionRec A
  (south A) (north A) (! ∘ merid A)

flip-susp : ∀ {i} {A : Type i} → Suspension A → Suspension A
flip-susp = FlipSusp.f

⊙flip-susp : ∀ {i} (X : Ptd i) → fst (⊙Susp X ⊙→ ⊙Susp X)
⊙flip-susp X = (flip-susp , ! (merid _ (snd X)))

module _ {i j} where

  module SuspFmap {A : Type i} {B : Type j} (f : A → B) =
    SuspensionRec A (north B) (south B) (merid B ∘ f)

  susp-fmap : {A : Type i} {B : Type j} (f : A → B)
    → (Suspension A → Suspension B)
  susp-fmap = SuspFmap.f

  ⊙susp-fmap : {X : Ptd i} {Y : Ptd j} (f : fst (X ⊙→ Y))
    → fst (⊙Susp X ⊙→ ⊙Susp Y)
  ⊙susp-fmap (f , fpt) = (susp-fmap f , idp)

module _ {i} where

  susp-fmap-idf : (A : Type i) → ∀ a → susp-fmap (idf A) a == a
  susp-fmap-idf A = Suspension-elim _ idp idp $ λ a →
    ↓-='-in (ap-idf (merid _ a) ∙ ! (SuspFmap.glue-β (idf A) a))

  ⊙susp-fmap-idf : (X : Ptd i)
    → ⊙susp-fmap (⊙idf X) == ⊙idf (⊙Susp X)
  ⊙susp-fmap-idf X = ⊙λ= (susp-fmap-idf (fst X)) idp

module _ {i j} where

  susp-fmap-cst : {A : Type i} {B : Type j} (b : B)
    (a : Suspension A) → susp-fmap (cst b) a == north _
  susp-fmap-cst b = Suspension-elim _ idp (! (merid _ b)) $ (λ a →
    ↓-app=cst-from-square $ SuspFmap.glue-β (cst b) a ∙v⊡ tr-square _)

  ⊙susp-fmap-cst : {X : Ptd i} {Y : Ptd j}
    → ⊙susp-fmap (⊙cst {X = X} {Y = Y}) == ⊙cst
  ⊙susp-fmap-cst = ⊙λ= (susp-fmap-cst _) idp

module _ {i j k} where

  susp-fmap-∘ : {A : Type i} {B : Type j} {C : Type k} (g : B → C) (f : A → B)
    (σ : Suspension A) → susp-fmap (g ∘ f) σ == susp-fmap g (susp-fmap f σ)
  susp-fmap-∘ g f = Suspension-elim _
    idp
    idp
    (λ a → ↓-='-in $
      ap-∘ (susp-fmap g) (susp-fmap f) (merid _ a)
      ∙ ap (ap (susp-fmap g)) (SuspFmap.glue-β f a)
      ∙ SuspFmap.glue-β g (f a)
      ∙ ! (SuspFmap.glue-β (g ∘ f) a))

  ⊙susp-fmap-∘ : {X : Ptd i} {Y : Ptd j} {Z : Ptd k}
    (g : fst (Y ⊙→ Z)) (f : fst (X ⊙→ Y))
    → ⊙susp-fmap (g ⊙∘ f) == ⊙susp-fmap g ⊙∘ ⊙susp-fmap f
  ⊙susp-fmap-∘ g f = ⊙λ= (susp-fmap-∘ (fst g) (fst f)) idp

{- Extract the 'glue component' of a pushout -}
module _ {i j k} {s : Span {i} {j} {k}} where

  module ExtGlue = PushoutRec {d = s} {D = Suspension (Span.C s)}
    (λ _ → north _) (λ _ → south _) (merid _)

  ext-glue = ExtGlue.f

module _ {i j k} {s : Span {i} {j} {k}} {x₀ : Span.A s} where

  ⊙ext-glue :
    fst ((Pushout s , left x₀) ⊙→ (Suspension (Span.C s) , north _))
  ⊙ext-glue = (ext-glue , idp)


module plfa.part2.Properties-peer where

open import Relation.Binary.PropositionalEquality
  using (_≡_; _≢_; refl; sym; cong; cong₂)
open import Data.String using (String; _≟_)
open import Data.Nat using (ℕ; zero; suc)
open import Data.Empty using (⊥; ⊥-elim)
open import Data.Product
  using (_×_; proj₁; proj₂; ∃; ∃-syntax)
  renaming (_,_ to ⟨_,_⟩)
open import Data.Sum using (_⊎_; inj₁; inj₂)
open import Relation.Nullary using (¬_; Dec; yes; no)
open import Function using (_∘_)
open import plfa.part1.Isomorphism
open import plfa.part2.Lambda

V¬—→ : ∀ {M N}
  → Value M
    ----------
  → ¬ (M —→ N)
V¬—→ V-ƛ        ()
V¬—→ V-zero     ()
V¬—→ (V-suc VM) (ξ-suc M—→N) = V¬—→ VM M—→N

—→¬V : ∀ {M N}
  → M —→ N
    ---------
  → ¬ Value M
—→¬V M—→N VM  =  V¬—→ VM M—→N

infix  4 Canonical_⦂_

data Canonical_⦂_ : Term → Type → Set where

  C-ƛ : ∀ {x A N B}
    → ∅ , x ⦂ A ⊢ N ⦂ B
      -----------------------------
    → Canonical (ƛ x ⇒ N) ⦂ (A ⇒ B)

  C-zero :
      --------------------
      Canonical `zero ⦂ `ℕ

  C-suc : ∀ {V}
    → Canonical V ⦂ `ℕ
      ---------------------
    → Canonical `suc V ⦂ `ℕ

canonical : ∀ {V A}
  → ∅ ⊢ V ⦂ A
  → Value V
    -----------
  → Canonical V ⦂ A
canonical (⊢` ())          ()
canonical (⊢ƛ ⊢N)          V-ƛ         =  C-ƛ ⊢N
canonical (⊢L · ⊢M)        ()
canonical ⊢zero            V-zero      =  C-zero
canonical (⊢suc ⊢V)        (V-suc VV)  =  C-suc (canonical ⊢V VV)
canonical (⊢case ⊢L ⊢M ⊢N) ()
canonical (⊢μ ⊢M)          ()

value : ∀ {M A}
  → Canonical M ⦂ A
    ----------------
  → Value M
value (C-ƛ ⊢N)    =  V-ƛ
value C-zero      =  V-zero
value (C-suc CM)  =  V-suc (value CM)

typed : ∀ {M A}
  → Canonical M ⦂ A
    ---------------
  → ∅ ⊢ M ⦂ A
typed (C-ƛ ⊢N)    =  ⊢ƛ ⊢N
typed C-zero      =  ⊢zero
typed (C-suc CM)  =  ⊢suc (typed CM)

data Progress (M : Term) : Set where

  step : ∀ {N}
    → M —→ N
      ----------
    → Progress M

  done :
      Value M
      ----------
    → Progress M

progress : ∀ {M A}
  → ∅ ⊢ M ⦂ A
    ----------
  → Progress M
progress (⊢` ())
progress (⊢ƛ ⊢N)                            =  done V-ƛ
progress (⊢L · ⊢M) with progress ⊢L
... | step L—→L′                            =  step (ξ-·₁ L—→L′)
... | done VL with progress ⊢M
...   | step M—→M′                          =  step (ξ-·₂ VL M—→M′)
...   | done VM with canonical ⊢L VL
...     | C-ƛ _                             =  step (β-ƛ VM)
progress ⊢zero                              =  done V-zero
progress (⊢suc ⊢M) with progress ⊢M
...  | step M—→M′                           =  step (ξ-suc M—→M′)
...  | done VM                              =  done (V-suc VM)
progress (⊢case ⊢L ⊢M ⊢N) with progress ⊢L
... | step L—→L′                            =  step (ξ-case L—→L′)
... | done VL with canonical ⊢L VL
...   | C-zero                              =  step β-zero
...   | C-suc CL                            =  step (β-suc (value CL))
progress (⊢μ ⊢M)                            =  step β-μ

postulate
  progress′ : ∀ M {A} → ∅ ⊢ M ⦂ A → Value M ⊎ ∃[ N ](M —→ N)

ext : ∀ {Γ Δ}
  → (∀ {x A}     →         Γ ∋ x ⦂ A →         Δ ∋ x ⦂ A)
    -----------------------------------------------------
  → (∀ {x y A B} → Γ , y ⦂ B ∋ x ⦂ A → Δ , y ⦂ B ∋ x ⦂ A)
ext ρ Z           =  Z
ext ρ (S x≢y ∋x)  =  S x≢y (ρ ∋x)

rename : ∀ {Γ Δ}
  → (∀ {x A} → Γ ∋ x ⦂ A → Δ ∋ x ⦂ A)
    ----------------------------------
  → (∀ {M A} → Γ ⊢ M ⦂ A → Δ ⊢ M ⦂ A)
rename ρ (⊢` ∋w)           =  ⊢` (ρ ∋w)
rename ρ (⊢ƛ ⊢N)           =  ⊢ƛ (rename (ext ρ) ⊢N)
rename ρ (⊢L · ⊢M)         =  (rename ρ ⊢L) · (rename ρ ⊢M)
rename ρ ⊢zero             =  ⊢zero
rename ρ (⊢suc ⊢M)         =  ⊢suc (rename ρ ⊢M)
rename ρ (⊢case ⊢L ⊢M ⊢N)  =  ⊢case (rename ρ ⊢L) (rename ρ ⊢M) (rename (ext ρ) ⊢N)
rename ρ (⊢μ ⊢M)           =  ⊢μ (rename (ext ρ) ⊢M)

weaken : ∀ {Γ M A}
  → ∅ ⊢ M ⦂ A
    ----------
  → Γ ⊢ M ⦂ A
weaken {Γ} ⊢M = rename ρ ⊢M
  where
  ρ : ∀ {z C}
    → ∅ ∋ z ⦂ C
      ---------
    → Γ ∋ z ⦂ C
  ρ ()

drop : ∀ {Γ x M A B C}
  → Γ , x ⦂ A , x ⦂ B ⊢ M ⦂ C
    --------------------------
  → Γ , x ⦂ B ⊢ M ⦂ C
drop {Γ} {x} {M} {A} {B} {C} ⊢M = rename ρ ⊢M
  where
  ρ : ∀ {z C}
    → Γ , x ⦂ A , x ⦂ B ∋ z ⦂ C
      -------------------------
    → Γ , x ⦂ B ∋ z ⦂ C
  ρ Z                 =  Z
  ρ (S x≢x Z)         =  ⊥-elim (x≢x refl)
  ρ (S z≢x (S _ ∋z))  =  S z≢x ∋z

swap : ∀ {Γ x y M A B C}
  → x ≢ y
  → Γ , y ⦂ B , x ⦂ A ⊢ M ⦂ C
    --------------------------
  → Γ , x ⦂ A , y ⦂ B ⊢ M ⦂ C
swap {Γ} {x} {y} {M} {A} {B} {C} x≢y ⊢M = rename ρ ⊢M
  where
  ρ : ∀ {z C}
    → Γ , y ⦂ B , x ⦂ A ∋ z ⦂ C
      --------------------------
    → Γ , x ⦂ A , y ⦂ B ∋ z ⦂ C
  ρ Z                   =  S x≢y Z
  ρ (S z≢x Z)           =  Z
  ρ (S z≢x (S z≢y ∋z))  =  S z≢y (S z≢x ∋z)

subst : ∀ {Γ x N V A B}
  → ∅ ⊢ V ⦂ A
  → Γ , x ⦂ A ⊢ N ⦂ B
    --------------------
  → Γ ⊢ N [ x := V ] ⦂ B
subst {x = y} ⊢V (⊢` {x = x} Z) with x ≟ y
... | yes _           =  weaken ⊢V
... | no  x≢y         =  ⊥-elim (x≢y refl)
subst {x = y} ⊢V (⊢` {x = x} (S x≢y ∋x)) with x ≟ y
... | yes refl        =  ⊥-elim (x≢y refl)
... | no  _           =  ⊢` ∋x
subst {x = y} ⊢V (⊢ƛ {x = x} ⊢N) with x ≟ y
... | yes refl        =  ⊢ƛ (drop ⊢N)
... | no  x≢y         =  ⊢ƛ (subst ⊢V (swap x≢y ⊢N))
subst ⊢V (⊢L · ⊢M)    =  (subst ⊢V ⊢L) · (subst ⊢V ⊢M)
subst ⊢V ⊢zero        =  ⊢zero
subst ⊢V (⊢suc ⊢M)    =  ⊢suc (subst ⊢V ⊢M)
subst {x = y} ⊢V (⊢case {x = x} ⊢L ⊢M ⊢N) with x ≟ y
... | yes refl        =  ⊢case (subst ⊢V ⊢L) (subst ⊢V ⊢M) (drop ⊢N)
... | no  x≢y         =  ⊢case (subst ⊢V ⊢L) (subst ⊢V ⊢M) (subst ⊢V (swap x≢y ⊢N))
subst {x = y} ⊢V (⊢μ {x = x} ⊢M) with x ≟ y
... | yes refl        =  ⊢μ (drop ⊢M)
... | no  x≢y         =  ⊢μ (subst ⊢V (swap x≢y ⊢M))

preserve : ∀ {M N A}
  → ∅ ⊢ M ⦂ A
  → M —→ N
    ----------
  → ∅ ⊢ N ⦂ A
preserve (⊢` ())
preserve (⊢ƛ ⊢N)                 ()
preserve (⊢L · ⊢M)               (ξ-·₁ L—→L′)     =  (preserve ⊢L L—→L′) · ⊢M
preserve (⊢L · ⊢M)               (ξ-·₂ VL M—→M′)  =  ⊢L · (preserve ⊢M M—→M′)
preserve ((⊢ƛ ⊢N) · ⊢V)          (β-ƛ VV)         =  subst ⊢V ⊢N
preserve ⊢zero                   ()
preserve (⊢suc ⊢M)               (ξ-suc M—→M′)    =  ⊢suc (preserve ⊢M M—→M′)
preserve (⊢case ⊢L ⊢M ⊢N)        (ξ-case L—→L′)   =  ⊢case (preserve ⊢L L—→L′) ⊢M ⊢N
preserve (⊢case ⊢zero ⊢M ⊢N)     (β-zero)         =  ⊢M
preserve (⊢case (⊢suc ⊢V) ⊢M ⊢N) (β-suc VV)       =  subst ⊢V ⊢N
preserve (⊢μ ⊢M)                 (β-μ)            =  subst (⊢μ ⊢M) ⊢M

sucμ  =  μ "x" ⇒ `suc (` "x")

data Gas : Set where
  gas : ℕ → Gas

data Finished (N : Term) : Set where

  done :
      Value N
      ----------
    → Finished N

  out-of-gas :
      ----------
      Finished N

data Steps (L : Term) : Set where

  steps : ∀ {N}
    → L —↠ N
    → Finished N
      ----------
    → Steps L

{-# TERMINATING #-}
eval : ∀ {L A}
  → Gas
  → ∅ ⊢ L ⦂ A
    ---------
  → Steps L

eval {L} (gas zero)    ⊢L                             =  steps (L ∎) out-of-gas
eval {L} (gas (suc m)) ⊢L with progress ⊢L
... | done VL                                         =  steps (L ∎) (done VL)
... | step L—→M with eval (gas m) (preserve ⊢L L—→M)
...    | steps M—↠N fin                               =  steps (L —→⟨ L—→M ⟩ M—↠N) fin

⊢sucμ : ∅ ⊢ μ "x" ⇒ `suc ` "x" ⦂ `ℕ
⊢sucμ = ⊢μ (⊢suc (⊢` ∋x))
  where
  ∋x = Z

_ : eval (gas 3) ⊢sucμ ≡
  steps
   (μ "x" ⇒ `suc ` "x"
   —→⟨ β-μ ⟩
    `suc (μ "x" ⇒ `suc ` "x")
   —→⟨ ξ-suc β-μ ⟩
    `suc (`suc (μ "x" ⇒ `suc ` "x"))
   —→⟨ ξ-suc (ξ-suc β-μ) ⟩
    `suc (`suc (`suc (μ "x" ⇒ `suc ` "x")))
   ∎)
   out-of-gas
_ = refl

_ : eval (gas 100) (⊢twoᶜ · ⊢sucᶜ · ⊢zero) ≡
  steps
   ((ƛ "s" ⇒ (ƛ "z" ⇒ ` "s" · (` "s" · ` "z"))) · (ƛ "n" ⇒ `suc ` "n")
   · `zero
   —→⟨ ξ-·₁ (β-ƛ V-ƛ) ⟩
    (ƛ "z" ⇒ (ƛ "n" ⇒ `suc ` "n") · ((ƛ "n" ⇒ `suc ` "n") · ` "z")) ·
     `zero
   —→⟨ β-ƛ V-zero ⟩
    (ƛ "n" ⇒ `suc ` "n") · ((ƛ "n" ⇒ `suc ` "n") · `zero)
   —→⟨ ξ-·₂ V-ƛ (β-ƛ V-zero) ⟩
    (ƛ "n" ⇒ `suc ` "n") · `suc `zero
   —→⟨ β-ƛ (V-suc V-zero) ⟩
    `suc (`suc `zero)
   ∎)
   (done (V-suc (V-suc V-zero)))
_ = refl

_ : eval (gas 100) ⊢2+2 ≡
  steps
   ((μ "+" ⇒
     (ƛ "m" ⇒
      (ƛ "n" ⇒
       case ` "m" [zero⇒ ` "n" |suc "m" ⇒ `suc (` "+" · ` "m" · ` "n")
       ])))
    · `suc (`suc `zero)
    · `suc (`suc `zero)
   —→⟨ ξ-·₁ (ξ-·₁ β-μ) ⟩
    (ƛ "m" ⇒
     (ƛ "n" ⇒
      case ` "m" [zero⇒ ` "n" |suc "m" ⇒
      `suc
      ((μ "+" ⇒
        (ƛ "m" ⇒
         (ƛ "n" ⇒
          case ` "m" [zero⇒ ` "n" |suc "m" ⇒ `suc (` "+" · ` "m" · ` "n")
          ])))
       · ` "m"
       · ` "n")
      ]))
    · `suc (`suc `zero)
    · `suc (`suc `zero)
   —→⟨ ξ-·₁ (β-ƛ (V-suc (V-suc V-zero))) ⟩
    (ƛ "n" ⇒
     case `suc (`suc `zero) [zero⇒ ` "n" |suc "m" ⇒
     `suc
     ((μ "+" ⇒
       (ƛ "m" ⇒
        (ƛ "n" ⇒
         case ` "m" [zero⇒ ` "n" |suc "m" ⇒ `suc (` "+" · ` "m" · ` "n")
         ])))
      · ` "m"
      · ` "n")
     ])
    · `suc (`suc `zero)
   —→⟨ β-ƛ (V-suc (V-suc V-zero)) ⟩
    case `suc (`suc `zero) [zero⇒ `suc (`suc `zero) |suc "m" ⇒
    `suc
    ((μ "+" ⇒
      (ƛ "m" ⇒
       (ƛ "n" ⇒
        case ` "m" [zero⇒ ` "n" |suc "m" ⇒ `suc (` "+" · ` "m" · ` "n")
        ])))
     · ` "m"
     · `suc (`suc `zero))
    ]
   —→⟨ β-suc (V-suc V-zero) ⟩
    `suc
    ((μ "+" ⇒
      (ƛ "m" ⇒
       (ƛ "n" ⇒
        case ` "m" [zero⇒ ` "n" |suc "m" ⇒ `suc (` "+" · ` "m" · ` "n")
        ])))
     · `suc `zero
     · `suc (`suc `zero))
   —→⟨ ξ-suc (ξ-·₁ (ξ-·₁ β-μ)) ⟩
    `suc
    ((ƛ "m" ⇒
      (ƛ "n" ⇒
       case ` "m" [zero⇒ ` "n" |suc "m" ⇒
       `suc
       ((μ "+" ⇒
         (ƛ "m" ⇒
          (ƛ "n" ⇒
           case ` "m" [zero⇒ ` "n" |suc "m" ⇒ `suc (` "+" · ` "m" · ` "n")
           ])))
        · ` "m"
        · ` "n")
       ]))
     · `suc `zero
     · `suc (`suc `zero))
   —→⟨ ξ-suc (ξ-·₁ (β-ƛ (V-suc V-zero))) ⟩
    `suc
    ((ƛ "n" ⇒
      case `suc `zero [zero⇒ ` "n" |suc "m" ⇒
      `suc
      ((μ "+" ⇒
        (ƛ "m" ⇒
         (ƛ "n" ⇒
          case ` "m" [zero⇒ ` "n" |suc "m" ⇒ `suc (` "+" · ` "m" · ` "n")
          ])))
       · ` "m"
       · ` "n")
      ])
     · `suc (`suc `zero))
   —→⟨ ξ-suc (β-ƛ (V-suc (V-suc V-zero))) ⟩
    `suc
    case `suc `zero [zero⇒ `suc (`suc `zero) |suc "m" ⇒
    `suc
    ((μ "+" ⇒
      (ƛ "m" ⇒
       (ƛ "n" ⇒
        case ` "m" [zero⇒ ` "n" |suc "m" ⇒ `suc (` "+" · ` "m" · ` "n")
        ])))
     · ` "m"
     · `suc (`suc `zero))
    ]
   —→⟨ ξ-suc (β-suc V-zero) ⟩
    `suc
    (`suc
     ((μ "+" ⇒
       (ƛ "m" ⇒
        (ƛ "n" ⇒
         case ` "m" [zero⇒ ` "n" |suc "m" ⇒ `suc (` "+" · ` "m" · ` "n")
         ])))
      · `zero
      · `suc (`suc `zero)))
   —→⟨ ξ-suc (ξ-suc (ξ-·₁ (ξ-·₁ β-μ))) ⟩
    `suc
    (`suc
     ((ƛ "m" ⇒
       (ƛ "n" ⇒
        case ` "m" [zero⇒ ` "n" |suc "m" ⇒
        `suc
        ((μ "+" ⇒
          (ƛ "m" ⇒
           (ƛ "n" ⇒
            case ` "m" [zero⇒ ` "n" |suc "m" ⇒ `suc (` "+" · ` "m" · ` "n")
            ])))
         · ` "m"
         · ` "n")
        ]))
      · `zero
      · `suc (`suc `zero)))
   —→⟨ ξ-suc (ξ-suc (ξ-·₁ (β-ƛ V-zero))) ⟩
    `suc
    (`suc
     ((ƛ "n" ⇒
       case `zero [zero⇒ ` "n" |suc "m" ⇒
       `suc
       ((μ "+" ⇒
         (ƛ "m" ⇒
          (ƛ "n" ⇒
           case ` "m" [zero⇒ ` "n" |suc "m" ⇒ `suc (` "+" · ` "m" · ` "n")
           ])))
        · ` "m"
        · ` "n")
       ])
      · `suc (`suc `zero)))
   —→⟨ ξ-suc (ξ-suc (β-ƛ (V-suc (V-suc V-zero)))) ⟩
    `suc
    (`suc
     case `zero [zero⇒ `suc (`suc `zero) |suc "m" ⇒
     `suc
     ((μ "+" ⇒
       (ƛ "m" ⇒
        (ƛ "n" ⇒
         case ` "m" [zero⇒ ` "n" |suc "m" ⇒ `suc (` "+" · ` "m" · ` "n")
         ])))
      · ` "m"
      · `suc (`suc `zero))
     ])
   —→⟨ ξ-suc (ξ-suc β-zero) ⟩
    `suc (`suc (`suc (`suc `zero)))
   ∎)
   (done (V-suc (V-suc (V-suc (V-suc V-zero)))))
_ = refl

Normal : Term → Set
Normal M  =  ∀ {N} → ¬ (M —→ N)

Stuck : Term → Set
Stuck M  =  Normal M × ¬ Value M

-- Exercise Progress-≃ (practice)

Progress-≃ : ∀ {M} → Progress M ≃ Value M ⊎ ∃[ N ](M —→ N)
Progress-≃ {M} = record
  { to      = to
  ; from    = from
  ; from∘to = from∘to
  ; to∘from = to∘from }
  where
    to : ∀ { M } → Progress M  → Value M ⊎ ∃[ N ](M —→ N)
    to (done m) = inj₁ m
    to (step {N} M→N) = inj₂ ⟨ N , M→N ⟩
    from : ∀ { M } →  Value M ⊎ ∃[ N ](M —→ N) → Progress M
    from (inj₁ m) = done m
    from (inj₂ ⟨ N , M→N ⟩) = step M→N
    from∘to : ∀ { M } → (m : Progress M) → from (to m) ≡ m
    from∘to (done m) = refl
    from∘to (step M→N) = refl
    to∘from : ∀ { M } ( s : Value M ⊎ ∃[ N ](M —→ N)) → to (from s) ≡ s
    to∘from (inj₁ m) = refl
    to∘from (inj₂ ⟨ N , M→N ⟩) = refl

-- Exercise value? (practice)

value? : ∀ {A M} → ∅ ⊢ M ⦂ A → Dec (Value M)
value? ⊢M with progress ⊢M
... | done m = yes m
... | step M→N = no (—→¬V M→N)

-- Exercise mul-eval (recommended)

mulᶜ : Term
mulᶜ = ƛ "m" ⇒ ƛ "n" ⇒ ƛ "s" ⇒ ƛ "z" ⇒
         ` "m" · (` "n" · ` "s" ) · ` "z"

⊢mulᶜ : ∀ {Γ A} → Γ ⊢ mulᶜ ⦂ Ch A ⇒ Ch A ⇒ Ch A
⊢mulᶜ = ⊢ƛ (⊢ƛ (⊢ƛ (⊢ƛ (⊢m · ⊢z))))
  where
    ⊢m = (⊢` (S  (λ()) (S  (λ()) (S  (λ()) Z))))
      · (⊢` (S  (λ()) (S  (λ()) Z))
      · (⊢` (S  (λ()) Z)))
    ⊢z = ⊢` Z

⊢2*2ᶜ : ∅ ⊢ mulᶜ · twoᶜ · twoᶜ · sucᶜ · `zero ⦂ `ℕ
⊢2*2ᶜ = ⊢mulᶜ · ⊢twoᶜ · ⊢twoᶜ · ⊢sucᶜ · ⊢zero

_ : eval (gas 100) (⊢2*2ᶜ) ≡
  steps
  ((ƛ "m" ⇒
    (ƛ "n" ⇒ (
      ƛ "s" ⇒ (ƛ "z" ⇒ ` "m" · (` "n" · ` "s") · ` "z"))))
   · (ƛ "s" ⇒ (ƛ "z" ⇒ ` "s" · (` "s" · ` "z")))
   · (ƛ "s" ⇒ (ƛ "z" ⇒ ` "s" · (` "s" · ` "z")))
   · (ƛ "n" ⇒ `suc ` "n")
   · `zero
  —→⟨ ξ-·₁ (ξ-·₁ (ξ-·₁ (β-ƛ V-ƛ))) ⟩
  (ƛ "n" ⇒
   (ƛ "s" ⇒
    (ƛ "z" ⇒
      (ƛ "s" ⇒ (ƛ "z" ⇒ ` "s" · (` "s" · ` "z"))) · (` "n" · ` "s") · ` "z")))
    · (ƛ "s" ⇒ (ƛ "z" ⇒ ` "s" · (` "s" · ` "z")))
    · (ƛ "n" ⇒ `suc ` "n")
    · `zero
 —→⟨ ξ-·₁ (ξ-·₁ (β-ƛ V-ƛ)) ⟩
  (ƛ "s" ⇒
   (ƛ "z" ⇒
    (ƛ "s" ⇒ (ƛ "z" ⇒ ` "s" · (` "s" · ` "z"))) ·
    ((ƛ "s" ⇒ (ƛ "z" ⇒ ` "s" · (` "s" · ` "z"))) · ` "s") · ` "z"))
   · (ƛ "n" ⇒ `suc ` "n")
   · `zero
 —→⟨ ξ-·₁ (β-ƛ V-ƛ) ⟩
  (ƛ "z" ⇒
   (ƛ "s" ⇒ (ƛ "z" ⇒ ` "s" · (` "s" · ` "z"))) ·
    ((ƛ "s" ⇒ (ƛ "z" ⇒ ` "s" · (` "s" · ` "z"))) ·
     (ƛ "n" ⇒ `suc ` "n"))
   · ` "z")
   · `zero
 —→⟨ β-ƛ V-zero ⟩
  (ƛ "s" ⇒ (ƛ "z" ⇒ ` "s" · (` "s" · ` "z"))) ·
  ((ƛ "s" ⇒ (ƛ "z" ⇒ ` "s" · (` "s" · ` "z"))) ·
    (ƛ "n" ⇒ `suc ` "n"))
    · `zero
 —→⟨ ξ-·₁ (ξ-·₂ V-ƛ (β-ƛ V-ƛ)) ⟩
   (ƛ "s" ⇒ (ƛ "z" ⇒ ` "s" · (` "s" · ` "z"))) ·
    (ƛ "z" ⇒ (ƛ "n" ⇒ `suc ` "n") · ((ƛ "n" ⇒ `suc ` "n") · ` "z"))
    · `zero
 —→⟨ ξ-·₁ (β-ƛ V-ƛ) ⟩
  (ƛ "z" ⇒
   (ƛ "z" ⇒ (ƛ "n" ⇒ `suc ` "n") · ((ƛ "n" ⇒ `suc ` "n") · ` "z")) ·
   ((ƛ "z" ⇒ (ƛ "n" ⇒ `suc ` "n") · ((ƛ "n" ⇒ `suc ` "n") · ` "z")) · ` "z"))
   · `zero
 —→⟨ β-ƛ V-zero ⟩
  (ƛ "z" ⇒ (ƛ "n" ⇒ `suc ` "n") · ((ƛ "n" ⇒ `suc ` "n") · ` "z")) ·
   ((ƛ "z" ⇒ (ƛ "n" ⇒ `suc ` "n") · ((ƛ "n" ⇒ `suc ` "n") · ` "z")) ·
   `zero)
 —→⟨ ξ-·₂ V-ƛ (β-ƛ V-zero) ⟩
  (ƛ "z" ⇒ (ƛ "n" ⇒ `suc ` "n") · ((ƛ "n" ⇒ `suc ` "n") · ` "z")) ·
   ((ƛ "n" ⇒ `suc ` "n") · ((ƛ "n" ⇒ `suc ` "n") · `zero))
 —→⟨ ξ-·₂ V-ƛ (ξ-·₂ V-ƛ (β-ƛ V-zero)) ⟩
  (ƛ "z" ⇒ (ƛ "n" ⇒ `suc ` "n") · ((ƛ "n" ⇒ `suc ` "n") · ` "z")) ·
   ((ƛ "n" ⇒ `suc ` "n") · `suc `zero)
 —→⟨ ξ-·₂ V-ƛ (β-ƛ (V-suc V-zero)) ⟩
  (ƛ "z" ⇒ (ƛ "n" ⇒ `suc ` "n") · ((ƛ "n" ⇒ `suc ` "n") · ` "z")) ·
   `suc (`suc `zero)
 —→⟨ β-ƛ (V-suc (V-suc V-zero)) ⟩
  (ƛ "n" ⇒ `suc ` "n") · ((ƛ "n" ⇒ `suc ` "n") · `suc (`suc `zero))
 —→⟨ ξ-·₂ V-ƛ (β-ƛ (V-suc (V-suc V-zero))) ⟩
  (ƛ "n" ⇒ `suc ` "n") · `suc (`suc (`suc `zero)) —→⟨
   β-ƛ (V-suc (V-suc (V-suc V-zero))) ⟩
   `suc (`suc (`suc (`suc `zero))) ∎)
  (done (V-suc (V-suc (V-suc (V-suc V-zero)))))
_ = refl

-- Exercise: progress-preservation (practice)
-- progress: If there exists a term M ⦂ A, then M must either be a value, or there exists an N such that M —→ N
-- preservation: If term M ⦂ A and N can be reduced from M, then N ⦂ A.

-- Exercise subject_expansion (practice)

-- counter example with case expression
-- M = case `suc V [zero ⇒ N |suc x ⇒ T ], ∅ ⊢ N ⦂ A,  ∅ ⊢ T ⦂ B
-- In this example, M does not have a type, but M —→ A or M  —→ B.

-- counter example without case expression
-- M —→ N, ∅ ⊢ N ⦂ A → B → A and  N = λ a b. a

-- Exercise stuck (practice)

-- example: `zero · `suc `zero
-- The example above is an ill-typed term.

-- Exercise unstuck (recommended)

unstuck : ∀ {M A}
  → ∅ ⊢ M ⦂ A
  -----------
  → ¬ (Stuck M)
unstuck m ⟨ fst , snd ⟩ with progress m
... | done m₁ = ⊥-elim (snd m₁)
... | step m₁  = ⊥-elim (fst m₁)

preserves : ∀ {M N A}
  → ∅ ⊢ M ⦂ A
  → M —↠ N
  ---------
  → ∅ ⊢ N ⦂ A
preserves m (M _—↠_.∎) = m
preserves m (L —→⟨ LM ⟩ MN) = preserves (preserve m LM) MN

wttdgs : ∀ {M N A}
  → ∅ ⊢ M ⦂ A
  → M —↠ N
  -----------
  → ¬ (Stuck N)
wttdgs a n = unstuck (preserves a n)


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

open import Agda.Builtin.Nat

record R : Set where
  field
    r₁ : Nat
    r₂ : Nat
open R

h : (n : Nat) → R
r₁ (h zero) = {!!}
r₂ (h zero) = {!!}
h (suc n) = {!!}


------------------------------------------------------------------------
-- The Agda standard library
--
-- Sum combinators for setoid equality preserving functions
------------------------------------------------------------------------

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

module Data.Sum.Function.Setoid where

open import Data.Sum
open import Data.Sum.Relation.Binary.Pointwise
open import Relation.Binary
open import Function.Equality as F using (_⟶_; _⟨$⟩_)
open import Function.Equivalence as Eq
  using (Equivalence; _⇔_; module Equivalence)
open import Function.Injection as Inj
  using (Injection; _↣_; module Injection)
open import Function.Inverse as Inv
  using (Inverse; _↔_; module Inverse)
open import Function.LeftInverse as LeftInv
  using (LeftInverse; _↞_; _LeftInverseOf_; module LeftInverse)
open import Function.Related
open import Function.Surjection as Surj
  using (Surjection; _↠_; module Surjection)

------------------------------------------------------------------------
-- Combinators for equality preserving functions

module _  {a₁ a₂ b₁ b₂ c₁ c₂ d₁ d₂}
          {A : Setoid a₁ a₂} {B : Setoid b₁ b₂}
          {C : Setoid c₁ c₂} {D : Setoid d₁ d₂}
          where

  _⊎-⟶_ : (A ⟶ B) → (C ⟶ D) → (A ⊎ₛ C) ⟶ (B ⊎ₛ D)
  _⊎-⟶_ f g = record
    { _⟨$⟩_ = fg
    ; cong  = fg-cong
    }
    where
    open Setoid (A ⊎ₛ C) using () renaming (_≈_ to _≈AC_)
    open Setoid (B ⊎ₛ D) using () renaming (_≈_ to _≈BD_)

    fg = map (_⟨$⟩_ f) (_⟨$⟩_ g)

    fg-cong : _≈AC_ =[ fg ]⇒ _≈BD_
    fg-cong (inj₁ x∼₁y) = inj₁ (F.cong f x∼₁y)
    fg-cong (inj₂ x∼₂y) = inj₂ (F.cong g x∼₂y)

module _ {a₁ a₂ b₁ b₂} {A : Setoid a₁ a₂} {B : Setoid b₁ b₂} where

  inj₁ₛ : A ⟶ (A ⊎ₛ B)
  inj₁ₛ = record { _⟨$⟩_ = inj₁ ; cong = inj₁ }

  inj₂ₛ : B ⟶ (A ⊎ₛ B)
  inj₂ₛ = record { _⟨$⟩_ = inj₂ ; cong = inj₂ }

  [_,_]ₛ : ∀ {c₁ c₂} {C : Setoid c₁ c₂} →
           (A ⟶ C) → (B ⟶ C) → (A ⊎ₛ B) ⟶ C
  [ f , g ]ₛ = record
    { _⟨$⟩_ = [ f ⟨$⟩_ , g ⟨$⟩_ ]
    ; cong = λ where
      (inj₁ x∼₁y) → F.cong f x∼₁y
      (inj₂ x∼₂y) → F.cong g x∼₂y
    }

module _ {a₁ a₂ b₁ b₂} {A : Setoid a₁ a₂} {B : Setoid b₁ b₂} where

  swapₛ : (A ⊎ₛ B) ⟶ (B ⊎ₛ A)
  swapₛ = [ inj₂ₛ , inj₁ₛ ]ₛ

------------------------------------------------------------------------
-- Combinators for more complex function types

module _  {a₁ a₂ b₁ b₂ c₁ c₂ d₁ d₂}
          {A : Setoid a₁ a₂} {B : Setoid b₁ b₂}
          {C : Setoid c₁ c₂} {D : Setoid d₁ d₂}
          where

  _⊎-equivalence_ : Equivalence A B → Equivalence C D →
                    Equivalence (A ⊎ₛ C) (B ⊎ₛ D)
  A⇔B ⊎-equivalence C⇔D = record
    { to   = to   A⇔B ⊎-⟶ to   C⇔D
    ; from = from A⇔B ⊎-⟶ from C⇔D
    } where open Equivalence

  _⊎-injection_ : Injection A B → Injection C D →
                  Injection (A ⊎ₛ C) (B ⊎ₛ D)
  _⊎-injection_ A↣B C↣D = record
    { to        = to A↣B ⊎-⟶ to C↣D
    ; injective = inj _ _
    }
    where
    open Injection
    open Setoid (A ⊎ₛ C) using () renaming (_≈_ to _≈AC_)
    open Setoid (B ⊎ₛ D) using () renaming (_≈_ to _≈BD_)

    inj : ∀ x y →
          (to A↣B ⊎-⟶ to C↣D) ⟨$⟩ x ≈BD (to A↣B ⊎-⟶ to C↣D) ⟨$⟩ y →
          x ≈AC y
    inj (inj₁ x) (inj₁ y) (inj₁ x∼₁y) = inj₁ (injective A↣B x∼₁y)
    inj (inj₂ x) (inj₂ y) (inj₂ x∼₂y) = inj₂ (injective C↣D x∼₂y)
    -- Can be removed in Agda 2.6.0?
    inj (inj₁ x) (inj₂ y) ()
    inj (inj₂ x) (inj₁ y) ()

  _⊎-left-inverse_ : LeftInverse A B → LeftInverse C D →
                     LeftInverse (A ⊎ₛ C) (B ⊎ₛ D)
  A↞B ⊎-left-inverse C↞D = record
    { to              = Equivalence.to   eq
    ; from            = Equivalence.from eq
    ; left-inverse-of = [ (λ x → inj₁ (left-inverse-of A↞B x))
                        , (λ x → inj₂ (left-inverse-of C↞D x)) ]
    }
    where
    open LeftInverse
    eq = LeftInverse.equivalence A↞B ⊎-equivalence
         LeftInverse.equivalence C↞D

module _ {a₁ a₂ b₁ b₂ c₁ c₂ d₁ d₂}
         {A : Setoid a₁ a₂} {B : Setoid b₁ b₂}
         {C : Setoid c₁ c₂} {D : Setoid d₁ d₂}
         where

  _⊎-surjection_ : Surjection A B → Surjection C D →
                   Surjection (A ⊎ₛ C) (B ⊎ₛ D)
  A↠B ⊎-surjection C↠D = record
    { to         = LeftInverse.from inv
    ; surjective = record
      { from             = LeftInverse.to inv
      ; right-inverse-of = LeftInverse.left-inverse-of inv
      }
    }
    where
    open Surjection
    inv = right-inverse A↠B ⊎-left-inverse right-inverse C↠D

  _⊎-inverse_ : Inverse A B → Inverse C D →
                Inverse (A ⊎ₛ C) (B ⊎ₛ D)
  A↔B ⊎-inverse C↔D = record
    { to         = Surjection.to   surj
    ; from       = Surjection.from surj
    ; inverse-of = record
      { left-inverse-of  = LeftInverse.left-inverse-of inv
      ; right-inverse-of = Surjection.right-inverse-of surj
      }
    }
    where
    open Inverse
    surj = Inverse.surjection   A↔B ⊎-surjection
           Inverse.surjection   C↔D
    inv  = Inverse.left-inverse A↔B ⊎-left-inverse
           Inverse.left-inverse C↔D


module _ where

open import Agda.Primitive
open import Agda.Builtin.Equality

data Wrap {a} (A : Set a) : Set a where
  wrap : A → Wrap A

data Unit (A : Set) : Set where
  unit : Unit A

record Functor {a b} (F : Set a → Set b) : Set (lsuc (a ⊔ b)) where
  field
    fmap : ∀ {A B} → (A → B) → F A → F B

open Functor ⦃ ... ⦄

instance
  FunWrap : ∀ {a} → Functor {a} Wrap
  FunWrap .fmap f (wrap x) = wrap (f x)

  FunUnit : Functor Unit
  FunUnit .fmap f unit = unit

_=$=_ : ∀ {a b} {A B : Set a} {F : Set a → Set b} {{_ : Functor F}} {x y : F A}
          (f : A → B) → x ≡ y → fmap f x ≡ fmap f y
f =$= refl = refl

postulate A : Set

wrap-refl : (x : A) → wrap x ≡ wrap x
wrap-refl x = refl

prf : (x : Wrap A) → wrap x ≡ wrap x
prf (wrap x) = wrap =$= wrap-refl x

-- Incomplete pattern matching when applying FunUnit
-- (Internal error at Reduce.Fast:1347)


module Oscar.Data.List where

open import Agda.Builtin.List public using (List; []; _∷_)


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

open import Fragment.Algebra.Signature

module Fragment.Algebra.Homomorphism (Σ : Signature) where

open import Fragment.Algebra.Homomorphism.Base Σ public
open import Fragment.Algebra.Homomorphism.Definitions Σ public
open import Fragment.Algebra.Homomorphism.Properties Σ public
open import Fragment.Algebra.Homomorphism.Setoid Σ public
open import Fragment.Algebra.Homomorphism.Equivalence Σ public


-- Andreas, 2015-07-16 issue reported by G.Allais

-- This ought to pass, ideally, but the lack of positivity polymorphism
-- does not allow for a precise analysis of the composition operator.
--
-- Subsequently, the positivity analysis for tabulate returns no
-- positivity info for all arguments, leading to a rejection of
-- Command₃.

-- {-# OPTIONS -v tc.pos:10 #-}

open import Common.Product
open import Common.List

record ⊤ {a} : Set a where

_∘_ : ∀ {a b c}
        {A : Set a} {B : A → Set b} {C : {x : A} → B x → Set c} →
        (∀ {x} (y : B x) → C y) → (g : (x : A) → B x) →
        ((x : A) → C (g x))
f ∘ g = λ x → f (g x)

postulate
  String : Set

USL = List String

data _∈_ a : USL → Set where
  z : ∀ {xs}             → a ∈ (a ∷ xs)
  s : ∀ {b xs} → a ∈ xs → a ∈ (b ∷ xs)

[Fields] : (args : USL) → Set₁
[Fields] []         =  ⊤
[Fields] (_ ∷ args) = Set × [Fields] args

[tabulate] : (args : USL) (ρ : {arg : _} (pr : arg ∈ args) → Set) → [Fields] args
[tabulate] []          ρ = _
[tabulate] (arg ∷ args) ρ = ρ z , [tabulate] args (λ x → ρ (s x))

[Record] : (args : USL) (f : [Fields] args) → Set
[Record] []          _        = ⊤
[Record] (hd ∷ args) (f , fs) = f × [Record] args fs

record Fields (args : USL) : Set₁ where
  constructor mkFields
  field
    fields : [Fields] args
open Fields public

record Record (args : USL) (f : Fields args) : Set where
  constructor mkRecord
  field
    content : [Record] args (fields f)
open Record public

module WORKS where

  tabulate : {args : USL} (ρ : {arg : _} (pr : arg ∈ args) → Set) → Fields args
  tabulate {args = args} ρ = mkFields ([tabulate] args ρ)  -- WORKS
  -- tabulate {args = args} = mkFields ∘ [tabulate] args -- FAILS

  mutual

    data Command₁ : Set where
      mkCommand : (modifierNames : USL) →
                  Record modifierNames (tabulate (λ {s} _ → Modifier s)) → Command₁

    record Command₂ : Set where
      inductive
      field
        modifierNames : USL
        modifiers     : [Record] modifierNames ([tabulate] _ (λ {s} _ → Modifier s))

    record Command₃ : Set where
      inductive
      field
        modifierNames : USL
        modifiers     : Record modifierNames (tabulate (λ {s} _ → Modifier s))

    data Modifier (name : String) : Set where
      command₁ : Command₁ → Modifier name
      command₂ : Command₂ → Modifier name
      command₃ : Command₃ → Modifier name

module FAILS where

  tabulate : {args : USL} (ρ : {arg : _} (pr : arg ∈ args) → Set) → Fields args
  -- tabulate {args = args} ρ = mkFields ([tabulate] args ρ)  -- WORKS
  tabulate {args = args} = mkFields ∘ [tabulate] args -- FAILS

  mutual

    data Command₁ : Set where
      mkCommand : (modifierNames : USL) →
                  Record modifierNames (tabulate (λ {s} _ → Modifier s)) → Command₁

    record Command₂ : Set where
      inductive
      field
        modifierNames : USL
        modifiers     : [Record] modifierNames ([tabulate] _ (λ {s} _ → Modifier s))

    record Command₃ : Set where
      inductive
      field
        modifierNames : USL
        modifiers     : Record modifierNames (tabulate (λ {s} _ → Modifier s))

    data Modifier (name : String) : Set where
      command₁ : Command₁ → Modifier name
      command₂ : Command₂ → Modifier name
      command₃ : Command₃ → Modifier name


module _ where

open import Issue1278.A Set
open import Agda.Builtin.Equality

test : (c : D) -> (c ≡ c)
test d = {!!} -- goal ".#A-60005532.d ≡ .#A-60005532.d"


open import Nat
open import Prelude
open import dynamics-core

open import lemmas-gcomplete

module lemmas-complete where
  -- no term is both complete and indeterminate
  lem-ind-comp : ∀{d} → d dcomplete → d indet → ⊥
  lem-ind-comp DCNum ()
  lem-ind-comp (DCPlus comp comp₁) (IPlus1 ind fin) = lem-ind-comp comp ind
  lem-ind-comp (DCPlus comp comp₁) (IPlus2 fin ind) = lem-ind-comp comp₁ ind
  lem-ind-comp DCVar ()
  lem-ind-comp (DCLam comp x₁) ()
  lem-ind-comp (DCAp comp comp₁) (IAp x ind x₁) = lem-ind-comp comp ind
  lem-ind-comp (DCCast comp x x₁) (ICastArr x₂ ind) = lem-ind-comp comp ind
  lem-ind-comp (DCCast comp x x₁) (ICastGroundHole x₂ ind) = lem-ind-comp comp ind
  lem-ind-comp (DCCast comp x x₁) (ICastHoleGround x₂ ind x₃) = lem-ind-comp comp ind
  lem-ind-comp (DCInl x comp) (IInl ind) = lem-ind-comp comp ind
  lem-ind-comp (DCInr x comp) (IInr ind) = lem-ind-comp comp ind
  lem-ind-comp (DCCase comp comp₁ comp₂) (ICase x x₁ x₂ ind) = lem-ind-comp comp ind
  lem-ind-comp (DCCast comp x x₁) (ICastSum x₂ ind) = lem-ind-comp comp ind
  lem-ind-comp (DCPair comp comp₁) (IPair1 ind x) = lem-ind-comp comp ind
  lem-ind-comp (DCPair comp comp₁) (IPair2 x ind) = lem-ind-comp comp₁ ind
  lem-ind-comp (DCFst comp) (IFst x x₁ ind) = lem-ind-comp comp ind
  lem-ind-comp (DCSnd comp) (ISnd x x₁ ind) = lem-ind-comp comp ind
  lem-ind-comp (DCCast comp x x₁) (ICastProd x₂ ind) = lem-ind-comp comp ind

  -- complete types that are consistent are equal
  complete-consistency : ∀{τ1 τ2} → τ1 ~ τ2 → τ1 tcomplete → τ2 tcomplete → τ1 == τ2
  complete-consistency TCRefl TCNum comp2 = refl
  complete-consistency TCRefl (TCArr comp1 comp2) comp3 = refl
  complete-consistency TCRefl (TCSum tc1 tc3) comp2 = refl
  complete-consistency TCHole1 comp1 ()
  complete-consistency (TCArr consis consis₁) (TCArr comp1 comp2) (TCArr comp3 comp4)
   with complete-consistency consis comp1 comp3 | complete-consistency consis₁ comp2 comp4
  ... | refl | refl = refl
  complete-consistency (TCSum consis consis₁) (TCSum comp1 comp2) (TCSum comp3 comp4)
    with complete-consistency consis comp1 comp3 | complete-consistency consis₁ comp2 comp4
  ... | refl | refl = refl
  complete-consistency TCRefl (TCProd comp comp₁) comp2 = refl
  complete-consistency TCHole2 () comp2
  complete-consistency (TCProd consis consis₁) (TCProd comp1 comp2) (TCProd comp3 comp4)
    with complete-consistency consis comp1 comp3 | complete-consistency consis₁ comp2 comp4
  ... | refl | refl = refl

  -- a well typed complete term is assigned a complete type
  complete-ta : ∀{Γ Δ d τ} → (Γ gcomplete) →
                             (Δ , Γ ⊢ d :: τ) →
                             d dcomplete →
                             τ tcomplete
  complete-ta gc TANum comp = TCNum
  complete-ta gc (TAPlus wt wt₁) comp = TCNum
  complete-ta gc (TAVar x₁) DCVar = gc _ _ x₁
  complete-ta gc (TALam a wt) (DCLam comp x₁) = TCArr x₁ (complete-ta (gcomp-extend gc x₁ a ) wt comp)
  complete-ta gc (TAAp wt wt₁) (DCAp comp comp₁)
    with complete-ta gc wt comp
  ... | TCArr qq qq₁ = qq₁
  complete-ta gc (TAEHole x x₁) ()
  complete-ta gc (TANEHole x wt x₁) ()
  complete-ta gc (TACast wt x) (DCCast comp x₁ x₂) = x₂
  complete-ta gc (TAFailedCast wt x x₁ x₂) ()
  complete-ta gc (TAInl wt) (DCInl x comp) = TCSum (complete-ta gc wt comp) x
  complete-ta gc (TAInr wt) (DCInr x comp) = TCSum x (complete-ta gc wt comp)
  complete-ta gc (TACase wt apt₁ wt₁ apt₂ wt₂) (DCCase comp comp₁ comp₂)
    with complete-ta gc wt comp
  ... | TCSum τc1 τc2 =  complete-ta (gcomp-extend gc τc1 apt₁) wt₁ comp₁
  complete-ta gc (TAPair wt wt₁) (DCPair comp comp₁) = TCProd (complete-ta gc wt comp) (complete-ta gc wt₁ comp₁)
  complete-ta gc (TAFst wt) (DCFst comp)
    with complete-ta gc wt comp
  ... | TCProd τc1 τc2 = τc1
  complete-ta gc (TASnd wt) (DCSnd comp)
    with complete-ta gc wt comp
  ... | TCProd τc1 τc2 = τc2

  -- a well typed term synthesizes a complete type
  comp-synth : ∀{Γ e τ} →
               Γ gcomplete →
               e ecomplete →
               Γ ⊢ e => τ →
               τ tcomplete
  comp-synth gc ec SNum = TCNum
  comp-synth gc ec (SPlus x x₁) = TCNum
  comp-synth gc (ECAsc x ec) (SAsc x₁) = x
  comp-synth gc ec (SVar x) = gc _ _ x
  comp-synth gc (ECAp ec ec₁) (SAp wt MAHole x₁) with comp-synth gc ec wt
  ... | ()
  comp-synth gc (ECAp ec ec₁) (SAp wt MAArr x₁) with comp-synth gc ec wt
  comp-synth gc (ECAp ec ec₁) (SAp wt MAArr x₁) | TCArr qq qq₁ = qq₁
  comp-synth gc () SEHole
  comp-synth gc () (SNEHole wt)
  comp-synth gc (ECLam2 ec x₁) (SLam x₂ wt) = TCArr x₁ (comp-synth (gcomp-extend gc x₁ x₂) ec wt)
  comp-synth gc (ECPair ec ec₁) (SPair wt wt₁)
    with comp-synth gc ec wt | comp-synth gc ec₁ wt₁
  ... | τc1 | τc2 = TCProd τc1 τc2
  comp-synth gc (ECFst ec) (SFst wt MPHole) with comp-synth gc ec wt
  ... | ()
  comp-synth gc (ECFst ec) (SFst wt MPProd) with comp-synth gc ec wt
  ... | TCProd τc1 τc2 = τc1
  comp-synth gc (ECSnd ec) (SSnd wt MPHole) with comp-synth gc ec wt
  ... | ()
  comp-synth gc (ECSnd ec) (SSnd wt MPProd) with comp-synth gc ec wt
  ... | TCProd τc1 τc2 = τc2


postulate
  A : Set
  P : A → Set
  a : A

  T    : Set → Set
  proj : (X : Set) → T X → X
  t    : T (∀ {x} → P x)

-- Checking target types first would prematurely solve the underscore
-- with `P a` instead of the correct `∀ {x} → P x`
fail : P a
fail = proj _ t


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

open import lib.Basics
open import lib.NType2
open import lib.types.Group
open import lib.types.Sigma
open import lib.types.Truncation

module lib.groups.SubgroupProp where

record SubgroupProp {i} (G : Group i) j : Type (lmax i (lsucc j)) where
  private
    module G = Group G
  field
    prop : G.El → Type j
    level : ∀ g → is-prop (prop g)
    -- In theory being inhabited implies that the identity is included,
    -- but in practice let's just prove the identity case.
    ident : prop G.ident
    diff : ∀ {g₁ g₂} → prop g₁ → prop g₂ → prop (G.diff g₁ g₂)

  subEl-prop : SubtypeProp G.El j
  subEl-prop = prop , level
  SubEl = Subtype subEl-prop

  abstract
    {-
      ident : prop G.ident
      ident = transport prop (G.inv-r (fst inhab)) (diff (snd inhab) (snd inhab))
    -}

    inv : ∀ {g} → prop g → prop (G.inv g)
    inv pg = transport prop (G.unit-l _) (diff ident pg)

    comp : ∀ {g₁ g₂} → prop g₁ → prop g₂ → prop (G.comp g₁ g₂)
    comp {g₁} {g₂} pg₁ pg₂ =
      transport prop (ap (G.comp g₁) (G.inv-inv g₂)) (diff pg₁ (inv pg₂))

is-fullᴳ : ∀ {i j} {G : Group i} → SubgroupProp G j → Type (lmax i j)
is-fullᴳ P = ∀ g → SubgroupProp.prop P g

-- Normal subgroups

is-normal : ∀ {i j} {G : Group i} → SubgroupProp G j → Type (lmax i j)
is-normal {G = G} P = ∀ g₁ {g₂} → P.prop g₂ → P.prop (Group.conj G g₁ g₂)
  where module P = SubgroupProp P

NormalSubgroupProp : ∀ {i} (G : Group i) j → Type (lmax i (lsucc j))
NormalSubgroupProp {i} G j = Σ (SubgroupProp G j) is-normal

module NormalSubgroupProp {i j} {G : Group i} (normal-prop : NormalSubgroupProp G j) where
  private
    module G = Group G

  propᴳ : SubgroupProp G j
  propᴳ = fst normal-prop
  open SubgroupProp propᴳ public

  conj : is-normal propᴳ
  conj = snd normal-prop

  abstract
    comm : ∀ g₁ g₂ → prop (G.comp g₁ g₂) → prop (G.comp g₂ g₁)
    comm g₁ g₂ pg₁g₂ = transport prop
      ( ap (λ g → G.comp g (G.inv g₂)) (! (G.assoc g₂ g₁ g₂))
      ∙ G.assoc (G.comp g₂ g₁) g₂ (G.inv g₂)
      ∙ ap (G.comp (G.comp g₂ g₁)) (G.inv-r g₂)
      ∙ G.unit-r (G.comp g₂ g₁))
      (conj g₂ pg₁g₂)
    {- So far this is not used.
    unconj : ∀ g₁ g₂ → prop (G.conj g₁ g₂) → prop g₂
    unconj g₁ g₂ pg₁g₂ = transport prop path (conj (G.inv g₁) pg₁g₂) where
      path : G.conj (G.inv g₁) (G.conj g₁ g₂) == g₂
      path = ! (G.conj-comp-l (G.inv g₁) g₁ g₂) ∙ ap (λ g → G.conj g g₂) (G.inv-l g₁) ∙ G.conj-unit-l g₂
    -}

abstract
  comm-is-normal : ∀ {i j} {G : Group i} (P : SubgroupProp G j)
    → (∀ g₁ g₂ → SubgroupProp.prop P (Group.comp G g₁ g₂)
               → SubgroupProp.prop P (Group.comp G g₂ g₁))
    → is-normal P
  comm-is-normal {G = G} P P-comm g₁ {g₂} Pg₂ =
    transport! P.prop (G.assoc g₁ g₂ (G.inv g₁)) $
      P-comm (G.diff g₂ g₁) g₁ $
        transport! P.prop
          ( G.assoc g₂ (G.inv g₁) g₁
          ∙ ap (G.comp g₂) (G.inv-l g₁)
          ∙ G.unit-r g₂)
          Pg₂
    where module G = Group G
          module P = SubgroupProp P

  sub-abelian-is-normal : ∀ {i j} {G : Group i}
    → (G-is-abelian : is-abelian G)
    → (P : SubgroupProp G j)
    → is-normal P
  sub-abelian-is-normal {G = G} G-is-abelian P =
    comm-is-normal P λ g₁ g₂ Pg₁g₂ → transport P.prop (G.comm g₁ g₂) Pg₁g₂
    where module G = AbGroup (G , G-is-abelian)
          module P = SubgroupProp P

sub-abelian-normal : ∀ {i j} {G : Group i}
  → (G-is-abelian : is-abelian G)
  → SubgroupProp G j
  → NormalSubgroupProp G j
sub-abelian-normal G-is-abelian P = P , sub-abelian-is-normal G-is-abelian P

{- Subgroups of subgroups -}

infix 40 _⊆ᴳ_
_⊆ᴳ_ : ∀ {i j k} {G : Group i}
  → SubgroupProp G j → SubgroupProp G k → Type (lmax i (lmax j k))
P ⊆ᴳ Q = ∀ g → P.prop g → Q.prop g
  where module P = SubgroupProp P
        module Q = SubgroupProp Q

{- triviality -}

trivial-propᴳ : ∀ {i} (G : Group i) → SubgroupProp G i
trivial-propᴳ {i} G = record {M} where
  module G = Group G
  module M where
    prop : G.El → Type i
    prop g = g == G.ident

    ident : prop G.ident
    ident = idp

    level : ∀ g → is-prop (prop g)
    level g = G.El-level g G.ident

    abstract
      diff : {g₁ g₂ : G.El} → prop g₁ → prop g₂ → prop (G.diff g₁ g₂)
      diff g₁=id g₂=id = ap2 G.comp g₁=id (ap G.inv g₂=id ∙ G.inv-ident)
                       ∙ G.unit-r G.ident

is-trivial-propᴳ : ∀ {i j} {G : Group i} → SubgroupProp G j → Type (lmax i j)
is-trivial-propᴳ {G = G} P = P ⊆ᴳ trivial-propᴳ G


module Prelude.Word where

import Agda.Builtin.Word as Word
open import Prelude.Nat
open import Prelude.Number
open import Prelude.Semiring
open import Prelude.Equality
open import Prelude.Equality.Unsafe
open import Prelude.Ord
open import Prelude.Unit
open import Prelude.Function
open import Prelude.Decidable

open Word public using (Word64) renaming (primWord64ToNat to word64ToNat;
                                          primWord64FromNat to word64FromNat)
open Word

private
  2⁶⁴ : Nat
  2⁶⁴ = 18446744073709551616
  {-# INLINE 2⁶⁴ #-}

inv-word64ToNat : ∀ {a} → word64FromNat (word64ToNat a) ≡ a
inv-word64ToNat = unsafeEqual

emb-word64FromNat : ∀ n → word64ToNat (word64FromNat n) ≡ n mod 2⁶⁴
emb-word64FromNat n = unsafeEqual

inj-word64ToNat : ∀ {a b} → word64ToNat a ≡ word64ToNat b → a ≡ b
inj-word64ToNat {a} {b} eq = eraseEquality (
  a ≡⟨ inv-word64ToNat ⟩ʳ
  word64FromNat (word64ToNat a)
    ≡⟨ word64FromNat $≡ eq ⟩
  word64FromNat (word64ToNat b)
    ≡⟨ inv-word64ToNat ⟩
  b ∎)

instance
  NumWord64 : Number Word64
  Number.Constraint NumWord64 _ = ⊤
  fromNat {{NumWord64}} n = word64FromNat n

  EqWord64 : Eq Word64
  _==_ {{EqWord64}} a b =
    case word64ToNat a == word64ToNat b of λ where
      (yes _) → yes unsafeEqual
      (no  _) → no  unsafeNotEqual

  OrdWord64 : Ord Word64
  OrdWord64 = OrdBy inj-word64ToNat

  OrdLawsWord64 : Ord/Laws Word64
  OrdLawsWord64 = OrdLawsBy inj-word64ToNat

-- Arithmetic --

private
  natOp : (Nat → Nat → Nat) → Word64 → Word64 → Word64
  natOp f a b = fromNat (f (word64ToNat a) (word64ToNat b))
  {-# INLINE natOp #-}

add64 : Word64 → Word64 → Word64
add64 = natOp _+_

sub64 : Word64 → Word64 → Word64
sub64 = natOp λ a b → a + 2⁶⁴ - b

mul64 : Word64 → Word64 → Word64
mul64 = natOp _*_

{-# INLINE add64 #-}
{-# INLINE sub64 #-}
{-# INLINE mul64 #-}

NonZero64 : Word64 → Set
NonZero64 a = NonZero (word64ToNat a)

infixl 7 divWord64 modWord64

syntax divWord64 b a = a div64 b
divWord64 : (b : Word64) {{nz : NonZero64 b}} → Word64 → Word64
divWord64 b a = fromNat (word64ToNat a div word64ToNat b)

syntax modWord64 b a = a mod64 b
modWord64 : (b : Word64) {{nz : NonZero64 b}} → Word64 → Word64
modWord64 b a = fromNat (word64ToNat a mod word64ToNat b)

{-# INLINE divWord64 #-}
{-# INLINE modWord64 #-}

instance
  SemiringWord64 : Semiring Word64
  Semiring.zro SemiringWord64 = 0
  Semiring.one SemiringWord64 = 1
  Semiring._+_ SemiringWord64 = add64
  Semiring._*_ SemiringWord64 = mul64

  NegWord64 : Negative Word64
  Negative.Constraint NegWord64 _ = ⊤
  fromNeg {{NegWord64}} n = sub64 0 (fromNat n)

  SubWord64 : Subtractive Word64
  _-_    {{SubWord64}} = sub64
  negate {{SubWord64}} = sub64 0


module StrongRMonads where

open import Library
open import Categories
open import Functors
open import MonoidalCat
open import RMonads

record SRMonad {a b c d}{M : Monoidal {a}{b}}{M' : Monoidal {c}{d}}
       (J : MonoidalFun M M') : Set (a ⊔ b ⊔ c ⊔ d) where
  constructor srmonad
  open MonoidalFun J
  field RM : RMonad F
  open RMonad RM
  open Cat
  open Monoidal
  open Fun
  field st : ∀{X Y} -> Hom (C M') (OMap (⊗ M') (T X , OMap F Y))
                                  (T (OMap (⊗ M) (X , Y)))
  -- laws later


------------------------------------------------------------------------
-- The Agda standard library
--
-- Indexed AVL trees
------------------------------------------------------------------------

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

open import Relation.Binary using (StrictTotalOrder)

module Data.AVL.Indexed
  {a ℓ₁ ℓ₂} (strictTotalOrder : StrictTotalOrder a ℓ₁ ℓ₂) where

open import Level using (_⊔_)
open import Data.Nat.Base using (ℕ; zero; suc; _+_)
open import Data.Product hiding (map)
open import Data.Maybe hiding (map)
open import Data.DifferenceList using (DiffList; []; _∷_; _++_)
open import Function as F hiding (const)
open import Relation.Unary
open import Relation.Binary using (_Respects_; Tri; tri<; tri≈; tri>)
open import Relation.Binary.PropositionalEquality using (_≡_; refl)

open StrictTotalOrder strictTotalOrder renaming (Carrier to Key)

------------------------------------------------------------------------
-- Re-export core definitions publicly

open import Data.AVL.Key strictTotalOrder public
open import Data.AVL.Value Eq.setoid public
open import Data.AVL.Height public

------------------------------------------------------------------------
-- Definitions of the tree

K&_ : ∀ {v} (V : Value v) → Set (a ⊔ v)
K& V = Σ Key (Value.family V)

-- The trees have three parameters/indices: a lower bound on the
-- keys, an upper bound, and a height.
--
-- (The bal argument is the balance factor.)

data Tree {v} (V : Value v) (l u : Key⁺) : ℕ → Set (a ⊔ v ⊔ ℓ₂) where
  leaf : (l<u : l <⁺ u) → Tree V l u 0
  node : ∀ {hˡ hʳ h}
         (k : K& V)
         (lk : Tree V l [ proj₁ k ] hˡ)
         (ku : Tree V [ proj₁ k ] u hʳ)
         (bal : hˡ ∼ hʳ ⊔ h) →
         Tree V l u (suc h)

module _ {v} {V : Value v} where

  private
    Val = Value.family V
    V≈  = Value.respects V

  leaf-injective : ∀ {l u} {p q : l <⁺ u} → (Tree V l u 0 ∋ leaf p) ≡ leaf q → p ≡ q
  leaf-injective refl = refl

  node-injective-key :
    ∀ {hˡ₁ hˡ₂ hʳ₁ hʳ₂ h l u k₁ k₂}
      {lk₁ : Tree V l [ proj₁ k₁ ] hˡ₁} {lk₂ : Tree V l [ proj₁ k₂ ] hˡ₂}
      {ku₁ : Tree V [ proj₁ k₁ ] u hʳ₁} {ku₂ : Tree V [ proj₁ k₂ ] u hʳ₂}
      {bal₁ : hˡ₁ ∼ hʳ₁ ⊔ h} {bal₂ : hˡ₂ ∼ hʳ₂ ⊔ h} →
    node k₁ lk₁ ku₁ bal₁ ≡ node k₂ lk₂ ku₂ bal₂ → k₁ ≡ k₂
  node-injective-key refl = refl

  -- See also node-injectiveˡ, node-injectiveʳ, and node-injective-bal
  -- in Data.AVL.Indexed.WithK.

  -- Cast operations. Logarithmic in the size of the tree, if we don't
  -- count the time needed to construct the new proofs in the leaf
  -- cases. (The same kind of caveat applies to other operations
  -- below.)
  --
  -- Perhaps it would be worthwhile changing the data structure so
  -- that the casts could be implemented in constant time (excluding
  -- proof manipulation). However, note that this would not change the
  -- worst-case time complexity of the operations below (up to Θ).

  castˡ : ∀ {l m u h} → l <⁺ m → Tree V m u h → Tree V l u h
  castˡ {l} l<m (leaf m<u)         = leaf (trans⁺ l l<m m<u)
  castˡ     l<m (node k mk ku bal) = node k (castˡ l<m mk) ku bal

  castʳ : ∀ {l m u h} → Tree V l m h → m <⁺ u → Tree V l u h
  castʳ {l} (leaf l<m)         m<u = leaf (trans⁺ l l<m m<u)
  castʳ     (node k lk km bal) m<u = node k lk (castʳ km m<u) bal

  -- Various constant-time functions which construct trees out of
  -- smaller pieces, sometimes using rotation.

  joinˡ⁺ : ∀ {l u hˡ hʳ h} →
           (k : K& V) →
           (∃ λ i → Tree V l [ proj₁ k ] (i ⊕ hˡ)) →
           Tree V [ proj₁ k ] u hʳ →
           (bal : hˡ ∼ hʳ ⊔ h) →
           ∃ λ i → Tree V l u (i ⊕ (1 + h))
  joinˡ⁺ k₆ (1# , node k₂ t₁
                    (node k₄ t₃ t₅ bal)
                                ∼+) t₇ ∼-  = (0# , node k₄
                                                        (node k₂ t₁ t₃ (max∼ bal))
                                                        (node k₆ t₅ t₇ (∼max bal))
                                                        ∼0)
  joinˡ⁺ k₄ (1# , node k₂ t₁ t₃ ∼-) t₅ ∼-  = (0# , node k₂ t₁ (node k₄ t₃ t₅ ∼0) ∼0)
  joinˡ⁺ k₄ (1# , node k₂ t₁ t₃ ∼0) t₅ ∼-  = (1# , node k₂ t₁ (node k₄ t₃ t₅ ∼-) ∼+)
  joinˡ⁺ k₂ (1# , t₁)               t₃ ∼0  = (1# , node k₂ t₁ t₃ ∼-)
  joinˡ⁺ k₂ (1# , t₁)               t₃ ∼+  = (0# , node k₂ t₁ t₃ ∼0)
  joinˡ⁺ k₂ (0# , t₁)               t₃ bal = (0# , node k₂ t₁ t₃ bal)
  joinˡ⁺ k₂ (## , t₁)               t₃ bal

  joinʳ⁺ : ∀ {l u hˡ hʳ h} →
           (k : K& V) →
           Tree V l [ proj₁ k ] hˡ →
           (∃ λ i → Tree V [ proj₁ k ] u (i ⊕ hʳ)) →
           (bal : hˡ ∼ hʳ ⊔ h) →
           ∃ λ i → Tree V l u (i ⊕ (1 + h))
  joinʳ⁺ k₂ t₁ (1# , node k₆
                       (node k₄ t₃ t₅ bal)
                                t₇ ∼-) ∼+  = (0# , node k₄
                                                        (node k₂ t₁ t₃ (max∼ bal))
                                                        (node k₆ t₅ t₇ (∼max bal))
                                                        ∼0)
  joinʳ⁺ k₂ t₁ (1# , node k₄ t₃ t₅ ∼+) ∼+  = (0# , node k₄ (node k₂ t₁ t₃ ∼0) t₅ ∼0)
  joinʳ⁺ k₂ t₁ (1# , node k₄ t₃ t₅ ∼0) ∼+  = (1# , node k₄ (node k₂ t₁ t₃ ∼+) t₅ ∼-)
  joinʳ⁺ k₂ t₁ (1# , t₃)               ∼0  = (1# , node k₂ t₁ t₃ ∼+)
  joinʳ⁺ k₂ t₁ (1# , t₃)               ∼-  = (0# , node k₂ t₁ t₃ ∼0)
  joinʳ⁺ k₂ t₁ (0# , t₃)               bal = (0# , node k₂ t₁ t₃ bal)
  joinʳ⁺ k₂ t₁ (## , t₃)               bal

  joinˡ⁻ : ∀ {l u} hˡ {hʳ h} →
           (k : K& V) →
           (∃ λ i → Tree V l [ proj₁ k ] pred[ i ⊕ hˡ ]) →
           Tree V [ proj₁ k ] u hʳ →
           (bal : hˡ ∼ hʳ ⊔ h) →
           ∃ λ i → Tree V l u (i ⊕ h)
  joinˡ⁻ zero    k₂ (0# , t₁) t₃ bal = (1# , node k₂ t₁ t₃ bal)
  joinˡ⁻ zero    k₂ (1# , t₁) t₃ bal = (1# , node k₂ t₁ t₃ bal)
  joinˡ⁻ (suc _) k₂ (0# , t₁) t₃ ∼+  = joinʳ⁺ k₂ t₁ (1# , t₃) ∼+
  joinˡ⁻ (suc _) k₂ (0# , t₁) t₃ ∼0  = (1# , node k₂ t₁ t₃ ∼+)
  joinˡ⁻ (suc _) k₂ (0# , t₁) t₃ ∼-  = (0# , node k₂ t₁ t₃ ∼0)
  joinˡ⁻ (suc _) k₂ (1# , t₁) t₃ bal = (1# , node k₂ t₁ t₃ bal)
  joinˡ⁻ n       k₂ (## , t₁) t₃ bal

  joinʳ⁻ : ∀ {l u hˡ} hʳ {h} →
           (k : K& V) →
           Tree V l [ proj₁ k ] hˡ →
           (∃ λ i → Tree V [ proj₁ k ] u pred[ i ⊕ hʳ ]) →
           (bal : hˡ ∼ hʳ ⊔ h) →
           ∃ λ i → Tree V l u (i ⊕ h)
  joinʳ⁻ zero    k₂ t₁ (0# , t₃) bal = (1# , node k₂ t₁ t₃ bal)
  joinʳ⁻ zero    k₂ t₁ (1# , t₃) bal = (1# , node k₂ t₁ t₃ bal)
  joinʳ⁻ (suc _) k₂ t₁ (0# , t₃) ∼-  = joinˡ⁺ k₂ (1# , t₁) t₃ ∼-
  joinʳ⁻ (suc _) k₂ t₁ (0# , t₃) ∼0  = (1# , node k₂ t₁ t₃ ∼-)
  joinʳ⁻ (suc _) k₂ t₁ (0# , t₃) ∼+  = (0# , node k₂ t₁ t₃ ∼0)
  joinʳ⁻ (suc _) k₂ t₁ (1# , t₃) bal = (1# , node k₂ t₁ t₃ bal)
  joinʳ⁻ n       k₂ t₁ (## , t₃) bal

  -- Extracts the smallest element from the tree, plus the rest.
  -- Logarithmic in the size of the tree.

  headTail : ∀ {l u h} → Tree V l u (1 + h) →
             ∃ λ (k : K& V) → l <⁺ [ proj₁ k ] ×
                            ∃ λ i → Tree V [ proj₁ k ] u (i ⊕ h)
  headTail (node k₁ (leaf l<k₁) t₂ ∼+) = (k₁ , l<k₁ , 0# , t₂)
  headTail (node k₁ (leaf l<k₁) t₂ ∼0) = (k₁ , l<k₁ , 0# , t₂)
  headTail (node {hˡ = suc _} k₃ t₁₂ t₄ bal) with headTail t₁₂
  ... | (k₁ , l<k₁ , t₂) = (k₁ , l<k₁ , joinˡ⁻ _ k₃ t₂ t₄ bal)

  -- Extracts the largest element from the tree, plus the rest.
  -- Logarithmic in the size of the tree.

  initLast : ∀ {l u h} → Tree V l u (1 + h) →
             ∃ λ (k : K& V) → [ proj₁ k ] <⁺ u ×
                            ∃ λ i → Tree V l [ proj₁ k ] (i ⊕ h)
  initLast (node k₂ t₁ (leaf k₂<u) ∼-) = (k₂ , k₂<u , (0# , t₁))
  initLast (node k₂ t₁ (leaf k₂<u) ∼0) = (k₂ , k₂<u , (0# , t₁))
  initLast (node {hʳ = suc _} k₂ t₁ t₃₄ bal) with initLast t₃₄
  ... | (k₄ , k₄<u , t₃) = (k₄ , k₄<u , joinʳ⁻ _ k₂ t₁ t₃ bal)

  -- Another joining function. Logarithmic in the size of either of
  -- the input trees (which need to have almost equal heights).

  join : ∀ {l m u hˡ hʳ h} →
         Tree V l m hˡ → Tree V m u hʳ → (bal : hˡ ∼ hʳ ⊔ h) →
         ∃ λ i → Tree V l u (i ⊕ h)
  join t₁ (leaf m<u) ∼0 = (0# , castʳ t₁ m<u)
  join t₁ (leaf m<u) ∼- = (0# , castʳ t₁ m<u)
  join {hʳ = suc _} t₁ t₂₃ bal with headTail t₂₃
  ... | (k₂ , m<k₂ , t₃) = joinʳ⁻ _ k₂ (castʳ t₁ m<k₂) t₃ bal

  -- An empty tree.

  empty : ∀ {l u} → l <⁺ u → Tree V l u 0
  empty = leaf

  -- A singleton tree.

  singleton : ∀ {l u} (k : Key) → Val k → l < k < u → Tree V l u 1
  singleton k v (l<k , k<u) = node (k , v) (leaf l<k) (leaf k<u) ∼0

  -- Inserts a key into the tree, using a function to combine any
  -- existing value with the new value. Logarithmic in the size of the
  -- tree (assuming constant-time comparisons and a constant-time
  -- combining function).

  insertWith : ∀ {l u h} (k : Key) → (Maybe (Val k) → Val k) →  -- Maybe old → result.
               Tree V l u h → l < k < u →
               ∃ λ i → Tree V l u (i ⊕ h)
  insertWith k f (leaf l<u) l<k<u = (1# , singleton k (f nothing) l<k<u)
  insertWith k f (node (k′ , v′) lp pu bal) (l<k , k<u) with compare k k′
  ... | tri< k<k′ _ _ = joinˡ⁺ (k′ , v′) (insertWith k f lp (l<k , [ k<k′ ]ᴿ)) pu bal
  ... | tri> _ _ k′<k = joinʳ⁺ (k′ , v′) lp (insertWith k f pu ([ k′<k ]ᴿ , k<u)) bal
  ... | tri≈ _ k≈k′ _ = (0# , node (k′ , V≈ k≈k′ (f (just (V≈ (Eq.sym k≈k′) v′)))) lp pu bal)

  -- Inserts a key into the tree. If the key already exists, then it
  -- is replaced. Logarithmic in the size of the tree (assuming
  -- constant-time comparisons).

  insert : ∀ {l u h} → (k : Key) → Val k → Tree V l u h → l < k < u →
           ∃ λ i → Tree V l u (i ⊕ h)
  insert k v = insertWith k (F.const v)

  -- Deletes the key/value pair containing the given key, if any.
  -- Logarithmic in the size of the tree (assuming constant-time
  -- comparisons).

  delete : ∀ {l u h} (k : Key) → Tree V l u h → l < k < u →
           ∃ λ i → Tree V l u pred[ i ⊕ h ]
  delete k (leaf l<u) l<k<u = (0# , leaf l<u)
  delete k (node p@(k′ , v) lp pu bal) (l<k , k<u) with compare k′ k
  ... | tri< k′<k _ _ = joinʳ⁻ _ p lp (delete k pu ([ k′<k ]ᴿ , k<u)) bal
  ... | tri> _ _ k′>k = joinˡ⁻ _ p (delete k lp (l<k , [ k′>k ]ᴿ)) pu bal
  ... | tri≈ _ k′≡k _ = join lp pu bal

  -- Looks up a key. Logarithmic in the size of the tree (assuming
  -- constant-time comparisons).

  lookup : ∀ {l u h} (k : Key) → Tree V l u h → l < k < u → Maybe (Val k)
  lookup k (leaf _) l<k<u = nothing
  lookup k (node (k′ , v) lk′ k′u _) (l<k , k<u) with compare k′ k
  ... | tri< k′<k _ _ = lookup k k′u ([ k′<k ]ᴿ , k<u)
  ... | tri> _ _ k′>k = lookup k lk′ (l<k , [ k′>k ]ᴿ)
  ... | tri≈ _ k′≡k _ = just (V≈ k′≡k v)

  -- Converts the tree to an ordered list. Linear in the size of the
  -- tree.

  toDiffList : ∀ {l u h} → Tree V l u h → DiffList (K& V)
  toDiffList (leaf _)       = []
  toDiffList (node k l r _) = toDiffList l ++ k ∷ toDiffList r

module _ {v w} {V : Value v} {W : Value w} where

  private
    Val = Value.family V
    Wal = Value.family W

  -- Maps a function over all values in the tree.

  map : ∀[ Val ⇒ Wal ] → ∀ {l u h} → Tree V l u h → Tree W l u h
  map f (leaf l<u)             = leaf l<u
  map f (node (k , v) l r bal) = node (k , f v) (map f l) (map f r) bal


------------------------------------------------------------------------
-- The Agda standard library
--
-- Bounded vectors, basic types and operations
------------------------------------------------------------------------

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

module Data.Vec.Bounded.Base where

open import Level using (Level)
open import Data.Nat.Base
import Data.Nat.Properties as ℕₚ
open import Data.List.Base as List using (List)
open import Data.List.Extrema ℕₚ.≤-totalOrder
open import Data.List.Relation.Unary.All as All using (All)
import Data.List.Relation.Unary.All.Properties as Allₚ
open import Data.List.Membership.Propositional using (mapWith∈)
open import Data.Product using (∃; _×_; _,_; proj₁; proj₂)
open import Data.Vec.Base as Vec using (Vec)
open import Data.These.Base as These using (These)
open import Function
open import Relation.Nullary
open import Relation.Unary
open import Relation.Binary.PropositionalEquality as P using (_≡_; refl)

private
  variable
    a b c p : Level
    A : Set a
    B : Set b
    C : Set c

------------------------------------------------------------------------
-- Types

infix 4 _,_
record Vec≤ (A : Set a) (n : ℕ) : Set a where
  constructor _,_
  field {length} : ℕ
        vec      : Vec A length
        .bound   : length ≤ n

------------------------------------------------------------------------
-- Conversion functions

fromVec : ∀ {n} → Vec A n → Vec≤ A n
fromVec v = v , ℕₚ.≤-refl

padRight : ∀ {n} → A → Vec≤ A n → Vec A n
padRight a (vs , m≤n)
  with recompute (_ ℕₚ.≤″? _) (ℕₚ.≤⇒≤″ m≤n)
... | less-than-or-equal refl = vs Vec.++ Vec.replicate a

padLeft : ∀ {n} → A → Vec≤ A n → Vec A n
padLeft a as@(vs , m≤n)
  with recompute (_ ℕₚ.≤″? _) (ℕₚ.≤⇒≤″ m≤n)
... | less-than-or-equal {k} ∣as∣+k≡n
  with P.trans (ℕₚ.+-comm k (Vec≤.length as)) ∣as∣+k≡n
... | refl = Vec.replicate a Vec.++ vs

private
  split : ∀ {m n} k → m + k ≡ n → ⌊ k /2⌋ + (m + ⌈ k /2⌉) ≡ n
  split {m} {n} k eq = begin
    ⌊ k /2⌋ + (m + ⌈ k /2⌉) ≡⟨ ℕₚ.+-comm ⌊ k /2⌋ _ ⟩
    m + ⌈ k /2⌉ + ⌊ k /2⌋   ≡⟨ ℕₚ.+-assoc m ⌈ k /2⌉ ⌊ k /2⌋ ⟩
    m + (⌈ k /2⌉ + ⌊ k /2⌋) ≡⟨ P.cong (m +_) (ℕₚ.+-comm ⌈ k /2⌉ ⌊ k /2⌋) ⟩
    m + (⌊ k /2⌋ + ⌈ k /2⌉) ≡⟨ P.cong (m +_) (ℕₚ.⌊n/2⌋+⌈n/2⌉≡n k) ⟩
    m + k                   ≡⟨ eq ⟩
    n                       ∎ where open P.≡-Reasoning

padBoth : ∀ {n} → A → A → Vec≤ A n → Vec A n
padBoth aₗ aᵣ as@(vs , m≤n)
  with recompute (_ ℕₚ.≤″? _) (ℕₚ.≤⇒≤″ m≤n)
... | less-than-or-equal {k} ∣as∣+k≡n
  with split k ∣as∣+k≡n
... | refl = Vec.replicate {n = ⌊ k /2⌋} aₗ
      Vec.++ vs
      Vec.++ Vec.replicate {n = ⌈ k /2⌉} aᵣ

fromList : (as : List A) → Vec≤ A (List.length as)
fromList = fromVec ∘ Vec.fromList

toList : ∀ {n} → Vec≤ A n → List A
toList = Vec.toList ∘ Vec≤.vec

------------------------------------------------------------------------
-- Creating new Vec≤ vectors

replicate : ∀ {m n} .(m≤n : m ≤ n) → A → Vec≤ A n
replicate m≤n a = Vec.replicate a , m≤n

[] : ∀ {n} → Vec≤ A n
[] = Vec.[] , z≤n

infixr 5 _∷_
_∷_ : ∀ {n} → A → Vec≤ A n → Vec≤ A (suc n)
a ∷ (as , p) = a Vec.∷ as , s≤s p

------------------------------------------------------------------------
-- Modifying Vec≤ vectors

≤-cast : ∀ {m n} → .(m≤n : m ≤ n) → Vec≤ A m → Vec≤ A n
≤-cast m≤n (v , p) = v , ℕₚ.≤-trans p m≤n

≡-cast : ∀ {m n} → .(eq : m ≡ n) → Vec≤ A m → Vec≤ A n
≡-cast m≡n = ≤-cast (ℕₚ.≤-reflexive m≡n)

map : (A → B) → ∀ {n} → Vec≤ A n → Vec≤ B n
map f (v , p) = Vec.map f v , p

reverse : ∀ {n} → Vec≤ A n → Vec≤ A n
reverse (v , p) = Vec.reverse v , p

-- Align and Zip.

alignWith : (These A B → C) → ∀ {n} → Vec≤ A n → Vec≤ B n → Vec≤ C n
alignWith f (as , p) (bs , q) = Vec.alignWith f as bs , ℕₚ.⊔-least p q

zipWith : (A → B → C) → ∀ {n} → Vec≤ A n → Vec≤ B n → Vec≤ C n
zipWith f (as , p) (bs , q) = Vec.restrictWith f as bs , ℕₚ.m≤n⇒m⊓o≤n _ p

zip : ∀ {n} → Vec≤ A n → Vec≤ B n → Vec≤ (A × B) n
zip = zipWith _,_

align : ∀ {n} → Vec≤ A n → Vec≤ B n → Vec≤ (These A B) n
align = alignWith id

-- take and drop

take : ∀ {m} n → Vec≤ A m → Vec≤ A (n ⊓ m)
take             zero    _                = []
take             (suc n) (Vec.[] , p)     = []
take {m = suc m} (suc n) (a Vec.∷ as , p) = a ∷ take n (as , ℕₚ.≤-pred p)

drop : ∀ {m} n → Vec≤ A m → Vec≤ A (m ∸ n)
drop             zero    v                = v
drop             (suc n) (Vec.[] , p)     = []
drop {m = suc m} (suc n) (a Vec.∷ as , p) = drop n (as , ℕₚ.≤-pred p)

------------------------------------------------------------------------
-- Lifting a collection of bounded vectors to the same size

rectangle : List (∃ (Vec≤ A)) → ∃ (List ∘ Vec≤ A)
rectangle {A = A} rows = width , padded where

  sizes = List.map proj₁ rows
  width = max 0 sizes

  all≤ : All (λ v → proj₁ v ≤ width) rows
  all≤ = Allₚ.map⁻ (xs≤max 0 sizes)

  padded : List (Vec≤ A width)
  padded = mapWith∈ rows $ λ {x} x∈rows →
    ≤-cast (All.lookup all≤ x∈rows) (proj₂ x)


------------------------------------------------------------------------
-- An implementation of the Fibonacci sequence using tail
------------------------------------------------------------------------

module SingletonChunks where

open import Codata.Musical.Notation
open import Codata.Musical.Stream as S using (Stream; _≈_; _∷_)
open import Data.Bool
open import Data.Nat
open import Data.Vec as V using (Vec; []; _∷_)
import Relation.Binary.PropositionalEquality as P

------------------------------------------------------------------------
-- Stream programs

-- StreamP b A encodes programs generating streams in chunks of size
-- (at least) 1. The first chunk may be empty if b is false.

infixr 5 _∷_

data StreamP : Bool → Set → Set₁ where
  [_]     : ∀ {A} (xs : ∞ (StreamP true A)) → StreamP false A
  _∷_     : ∀ {A} (x : A) (xs : StreamP false A) → StreamP true A
  forget  : ∀ {A} (xs : StreamP true A) → StreamP false A
  tail    : ∀ {A} (xs : StreamP true A) → StreamP false A
  zipWith : ∀ {b A B C} (f : A → B → C)
            (xs : StreamP b A) (ys : StreamP b B) → StreamP b C

data StreamW : Bool → Set → Set₁ where
  [_] : ∀ {A} (xs : StreamP true A) → StreamW false A
  _∷_ : ∀ {A} (x : A) (xs : StreamW false A) → StreamW true A

forgetW : ∀ {A} → StreamW true A → StreamW false A
forgetW (x ∷ [ xs ]) = [ x ∷ forget xs ]

tailW : ∀ {A} → StreamW true A → StreamW false A
tailW (x ∷ xs) = xs

zipWithW : ∀ {b A B C} → (A → B → C) →
           StreamW b A → StreamW b B → StreamW b C
zipWithW f [ xs ]   [ ys ]   = [ zipWith f xs ys ]
zipWithW f (x ∷ xs) (y ∷ ys) = f x y ∷ zipWithW f xs ys

whnf : ∀ {b A} → StreamP b A → StreamW b A
whnf [ xs ]            = [ ♭ xs ]
whnf (x ∷ xs)          = x ∷ whnf xs
whnf (forget xs)       = forgetW (whnf xs)
whnf (tail xs)         = tailW (whnf xs)
whnf (zipWith f xs ys) = zipWithW f (whnf xs) (whnf ys)

mutual

  ⟦_⟧W : ∀ {A} → StreamW true A → Stream A
  ⟦ x ∷ [ xs ] ⟧W = x ∷ ♯ ⟦ xs ⟧P

  ⟦_⟧P : ∀ {A} → StreamP true A → Stream A
  ⟦ xs ⟧P = ⟦ whnf xs ⟧W

------------------------------------------------------------------------
-- The Fibonacci sequence

fib : StreamP true ℕ
fib = 0 ∷ [ ♯ (1 ∷ zipWith _+_ (forget fib) (tail fib)) ]

------------------------------------------------------------------------
-- The definition of fib is correct

-- ⟦_⟧ is homomorphic with respect to zipWith/S.zipWith.

zipWith-hom : ∀ {A B C} (_∙_ : A → B → C) xs ys →
              ⟦ zipWith _∙_ xs ys ⟧P ≈ S.zipWith _∙_ ⟦ xs ⟧P ⟦ ys ⟧P
zipWith-hom _∙_ xs ys with whnf xs | whnf ys
zipWith-hom _∙_ xs ys | x ∷ [ xs′ ] | y ∷ [ ys′ ] =
  P.refl ∷ ♯ zipWith-hom _∙_ xs′ ys′

-- forget is the identity on streams.

open import MapIterate as M using (_≈P_; _∷_; _≈⟨_⟩_; _∎)
open import Relation.Binary.PropositionalEquality as P using (_≡_; [_])

forget-lemma : ∀ {A} x (xs : StreamP true A) →
               ⟦ x ∷ forget xs ⟧P ≈P x ∷ ♯ ⟦ xs ⟧P
forget-lemma x xs with whnf xs | P.inspect whnf xs
... | y ∷ [ ys ] | [ eq ] = x ∷ ♯ helper eq
  where
  helper : whnf xs ≡ y ∷ [ ys ] →
           ⟦ y ∷ forget ys ⟧P ≈P ⟦ xs ⟧P
  helper eq rewrite eq = _ ≈⟨ forget-lemma y ys ⟩ (y ∷ ♯ (_ ∎))

-- The stream ⟦ fib ⟧P satisfies its intended defining equation.

open import Relation.Binary
module SS {A : Set} = Setoid (S.setoid A)

fib-correct :
  ⟦ fib ⟧P ≈ 0 ∷ ♯ (1 ∷ ♯ S.zipWith _+_ ⟦ fib ⟧P (S.tail ⟦ fib ⟧P))
fib-correct =
  P.refl ∷ ♯ (P.refl ∷ ♯ SS.trans
   (zipWith-hom _+_ (0 ∷ forget fib′) fib′)
   (S.zipWith-cong _+_ (SS.trans (M.soundP (forget-lemma 0 fib′))
                                 (P.refl ∷ ♯ SS.refl)) SS.refl))
  where fib′ = 1 ∷ zipWith _+_ (forget fib) (tail fib)

------------------------------------------------------------------------
-- An equality proof language

infix  4 _≈[_]P_ _≈[_]W_
infix  3 _∎
infixr 2 _≈⟨_⟩_

data _≈[_]P_ : {A : Set} → Stream A → Bool → Stream A → Set₁ where
  [_]     : ∀ {A} {xs ys : Stream A}
            (xs≈ys : ∞ (xs ≈[ true ]P ys)) → xs ≈[ false ]P ys
  _∷_     : ∀ {b A} (x : A) {xs ys : ∞ (Stream A)}
            (xs≈ys : ♭ xs ≈[ b ]P ♭ ys) → x ∷ xs ≈[ true ]P x ∷ ys
  forget  : ∀ {A} {xs ys : Stream A}
            (xs≈ys : xs ≈[ true ]P ys) → xs ≈[ false ]P ys
  _≈⟨_⟩_  : ∀ {b A} (xs : Stream A) {ys zs}
            (xs≈ys : xs ≈[ b ]P ys) (ys≈zs : ys ≈[ b ]P zs) →
            xs ≈[ b ]P zs
  _∎      : ∀ {A} (xs : Stream A) → xs ≈[ true ]P xs
  tail    : ∀ {A} {xs ys : Stream A} (xs≈ys : xs ≈[ true ]P ys) →
            S.tail xs ≈[ false ]P S.tail ys
  zipWith : ∀ {b A B C} (f : A → B → C) {xs xs′ ys ys′}
            (xs≈xs′ : xs ≈[ b ]P xs′) (ys≈ys′ : ys ≈[ b ]P ys′) →
            S.zipWith f xs ys ≈[ b ]P S.zipWith f xs′ ys′

-- Completeness.

completeP : ∀ {A : Set} {xs ys : Stream A} →
            xs ≈ ys → xs ≈[ true ]P ys
completeP (P.refl ∷ xs≈ys) = _ ∷ [ ♯ completeP (♭ xs≈ys) ]

-- Weak head normal forms.

data _≈[_]W_ {A : Set} : Stream A → Bool → Stream A → Set₁ where
  [_]     : {xs ys : Stream A}
            (xs≈ys : xs ≈[ true ]P ys) → xs ≈[ false ]W ys
  _∷_     : ∀ (x : A) {xs ys}
            (xs≈ys : ♭ xs ≈[ true ]P ♭ ys) → x ∷ xs ≈[ true ]W x ∷ ys

consW≈ : ∀ {A b} (x : A) {xs ys} →
         ♭ xs ≈[ b ]W ♭ ys → x ∷ xs ≈[ true ]W x ∷ ys
consW≈ x xs≈ys = x ∷ helper xs≈ys
  where
  helper : ∀ {A b} {xs ys : Stream A} →
           xs ≈[ b ]W ys → xs ≈[ true ]P ys
  helper [ xs≈ys ]   = xs≈ys
  helper (x ∷ xs≈ys) = x ∷ xs≈ys

forgetW≈ : ∀ {A} {xs ys : Stream A} →
           xs ≈[ true ]W ys → xs ≈[ false ]W ys
forgetW≈ (x ∷ xs≈ys) = [ x ∷ forget xs≈ys ]

transW≈ : ∀ {A b} {xs ys zs : Stream A} →
          xs ≈[ b ]W ys → ys ≈[ b ]W zs → xs ≈[ b ]W zs
transW≈ [ xs≈ys ]   [ ys≈zs ]    = [ _ ≈⟨ xs≈ys ⟩ ys≈zs ]
transW≈ (x ∷ xs≈ys) (.x ∷ ys≈zs) = x ∷ (_ ≈⟨ xs≈ys ⟩ ys≈zs)

reflW≈ : ∀ {A} (xs : Stream A) → xs ≈[ true ]W xs
reflW≈ (x ∷ xs) = x ∷ (♭ xs ∎)

tailW≈ : ∀ {A} {xs ys : Stream A} →
         xs ≈[ true ]W ys → S.tail xs ≈[ false ]W S.tail ys
tailW≈ (x ∷ xs≈ys) = [ xs≈ys ]

zipWithW≈ : ∀ {A B C b} (_∙_ : A → B → C) {xs₁ ys₁ xs₂ ys₂} →
            xs₁ ≈[ b ]W ys₁ → xs₂ ≈[ b ]W ys₂ →
            S.zipWith _∙_ xs₁ xs₂ ≈[ b ]W S.zipWith _∙_ ys₁ ys₂
zipWithW≈ _∙_ [ xs₁≈ys₁ ]    [ xs₂≈ys₂ ]    = [ zipWith _∙_ xs₁≈ys₁ xs₂≈ys₂ ]
zipWithW≈ _∙_ (x₁ ∷ xs₁≈ys₁) (x₂ ∷ xs₂≈ys₂) =
  (x₁ ∙ x₂) ∷ zipWith _∙_ xs₁≈ys₁ xs₂≈ys₂

whnf≈ : ∀ {A : Set} {xs ys : Stream A} {b} →
        xs ≈[ b ]P ys → xs ≈[ b ]W ys
whnf≈ [ xs≈ys ]                 = [ ♭ xs≈ys ]
whnf≈ (x ∷ xs≈ys)               = consW≈ x (whnf≈ xs≈ys)
whnf≈ (forget xs≈ys)            = forgetW≈ (whnf≈ xs≈ys)
whnf≈ (xs ≈⟨ xs≈ys ⟩ ys≈zs)     = transW≈ (whnf≈ xs≈ys) (whnf≈ ys≈zs)
whnf≈ (xs ∎)                    = reflW≈ xs
whnf≈ (tail xs≈ys)              = tailW≈ (whnf≈ xs≈ys)
whnf≈ (zipWith f xs≈xs′ ys≈ys′) = zipWithW≈ f (whnf≈ xs≈xs′) (whnf≈ ys≈ys′)

-- Soundness.

mutual

  soundW : {A : Set} {xs ys : Stream A} → xs ≈[ true ]W ys → xs ≈ ys
  soundW (x ∷ xs≈ys) = P.refl ∷ ♯ soundP xs≈ys

  soundP : {A : Set} {xs ys : Stream A} → xs ≈[ true ]P ys → xs ≈ ys
  soundP xs≈ys = soundW (whnf≈ xs≈ys)

------------------------------------------------------------------------
-- The equation given for fib has a unique solution

fib-rhs : Stream ℕ → Stream ℕ
fib-rhs ns = 0 ∷ ♯ (1 ∷ ♯ S.zipWith _+_ ns (S.tail ns))

fib-unique :
  ∀ ms ns → ms ≈ fib-rhs ms → ns ≈ fib-rhs ns → ms ≈[ true ]P ns
fib-unique ms ns ms≈ ns≈ =
  ms         ≈⟨ completeP ms≈ ⟩
  fib-rhs ms ≈⟨ 0 ∷ [ ♯ (1 ∷ zipWith _+_ (forget (fib-unique ms ns ms≈ ns≈))
                                         (tail (fib-unique ms ns ms≈ ns≈))) ] ⟩
  fib-rhs ns ≈⟨ completeP (SS.sym ns≈) ⟩
  ns         ∎


-- Andreas, 2015-07-16
-- For printing lambda-bound names, name _ should behave as no name.

-- {-# OPTIONS -v tc.term.lambda:60 #-}

module _ where

Test = (A : Set) {A : Set} → A → A

works : Test
works = λ C x → {!!}

-- the goal should be displayed as ?0 : .A

g : Test
g = λ C {_} x → {!!}

-- the goal should be displayed as ?1 : .A
-- not ?1 : _ or ?1 : A

h : Test
h = λ C {_} → λ x → {!!}

-- the goal should be displayed as ?1 : .A
-- not ?1 : _ or ?1 : A


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

open import Level as Level using (zero)
open import Size
open import Function
open import Relation.Binary
open import Relation.Binary.PropositionalEquality as P
open ≡-Reasoning

open import Data.List using (List; module List; []; _∷_; _++_; length)
open import Data.Nat using (ℕ; zero; suc)
open import Data.Product renaming (map to pmap)

open import Relations

-- Sized streams via head/tail.

record Stream {i : Size} (A : Set) : Set where
  coinductive
  constructor _∷_
  field
    hd : A
    tl : ∀ {j : Size< i} → Stream {j} A
open Stream public

-- Shorthand
Str = Stream

tl' : ∀ {A} → Str A → Str A
tl' s = tl s {∞}

-- Constructor
scons : ∀{A} → A → Str A → Str A
hd (scons a s) = a
tl (scons a s) = s

-- | Corecursion
corec : ∀ {X A : Set} → (X → A) → (X → X) → (X → Str A)
hd (corec h s x) = h x
tl (corec h s x) = corec h s (s x)

-- Functoriality.

map : ∀ {i A B} (f : A → B) (s : Stream {i} A) → Stream {i} B
hd (map     f s)     = f (hd s)
tl (map {i} f s) {j} = map {j} f (tl s {j})

-- Derivative
δ : ∀{A} → ℕ → Stream A → Stream A
δ 0       s = s
δ (suc n) s = δ n (tl s)

-- Indexing
_at_ : ∀{A} → Stream A → ℕ → A
s at n = hd (δ n s)

fromStr = _at_

-- | Inverse for at
toStr : ∀ {A} → (ℕ → A) → Str A
hd (toStr f) = f 0
tl (toStr f) = toStr (λ n → f (suc n))

module Bisim (S : Setoid Level.zero Level.zero) where

  infix 2 _∼_

  open Setoid S renaming (Carrier to A; isEquivalence to S-equiv)
  module SE = IsEquivalence S-equiv

  -- Stream equality is bisimilarity
  record _∼_ {i : Size} (s t : Stream A) : Set where
    coinductive
    field
      hd≈ : hd s ≈ hd t
      tl∼ : ∀ {j : Size< i} → _∼_ {j} (tl s) (tl t)
  open _∼_ public

  _∼[_]_ : Stream A → Size → Stream A → Set
  s ∼[ i ] t = _∼_ {i} s t

  s-bisim-refl : ∀ {i} {s : Stream A} → s ∼[ i ] s
  hd≈ s-bisim-refl               = SE.refl
  tl∼ (s-bisim-refl {_} {s}) {j} = s-bisim-refl {j} {tl s}

  s-bisim-sym : ∀ {i} {s t : Stream A} → s ∼[ i ] t → t ∼[ i ] s
  hd≈ (s-bisim-sym             p)     = SE.sym (hd≈ p)
  tl∼ (s-bisim-sym {_} {s} {t} p) {j} =
    s-bisim-sym {j} {tl s} {tl t} (tl∼ p)

  s-bisim-trans : ∀ {i} {r s t : Stream A} →
                  r ∼[ i ] s → s ∼[ i ] t → r ∼[ i ] t
  hd≈ (s-bisim-trans                 p q)     = SE.trans (hd≈ p) (hd≈ q)
  tl∼ (s-bisim-trans {_} {r} {s} {t} p q) {j} =
    s-bisim-trans {j} {tl r} {tl s} {tl t} (tl∼ p) (tl∼ q)

  stream-setoid : Setoid _ _
  stream-setoid = record
    { Carrier = Stream A
    ; _≈_ = _∼_
    ; isEquivalence = record
      { refl  = s-bisim-refl
      ; sym   = s-bisim-sym
      ; trans = s-bisim-trans
      }
    }

  import Relation.Binary.EqReasoning as EqR

  module ∼-Reasoning where
    module _ where
      open EqR (stream-setoid) public
        hiding (_≡⟨_⟩_) renaming (_≈⟨_⟩_ to _∼⟨_⟩_; begin_ to begin_; _∎ to _∎)

  -- | As usual, bisimilarity implies equality at every index.
  bisim→ext-≡ : ∀ {s t : Stream A} → s ∼ t → ∀ {n} → s at n ≈ t at n
  bisim→ext-≡ p {zero}  = hd≈ p
  bisim→ext-≡ p {suc n} = bisim→ext-≡ (tl∼ p) {n}

  -- | Definition of bisimulation
  isBisim : Rel (Str A) Level.zero → Set
  isBisim R =
    (s t : Str A) → R s t → (hd s ≈ hd t) × R (tl s) (tl t)

  -- | Bisimulation proof principle
  ∃-bisim→∼ : ∀ {R} → isBisim R → (s t : Str A) → R s t → s ∼ t
  hd≈ (∃-bisim→∼ R-isBisim s t q) = proj₁ (R-isBisim s t q)
  tl∼ (∃-bisim→∼ R-isBisim s t q) =
    ∃-bisim→∼ R-isBisim (tl s) (tl t) (proj₂ (R-isBisim s t q))

  StrRel : Set₁
  StrRel = Rel (Str A) Level.zero

  -- | Relation transformer that characterises bisimulations
  Φ : Rel (Str A) Level.zero → Rel (Str A) Level.zero
  Φ R s t = (hd s ≈ hd t) × R (tl s) (tl t)

  isBisim' : Rel (Str A) Level.zero → Set
  isBisim' R = R ⇒ Φ R

  isBisim'→isBisim : ∀ {R} → isBisim' R → isBisim R
  isBisim'→isBisim p s t q = p q

  Φ-compat : RelTrans (Str A) → Set₁
  Φ-compat F = Monotone F × (∀ {R} → F (Φ R) ⇒ Φ (F R))

  isBisim-upto : RelTrans (Str A) → Rel (Str A) Level.zero → Set
  isBisim-upto F R = R ⇒ Φ (F R)

  Φ-compat-pres-upto : {F : RelTrans (Str A)} (P : Φ-compat F) {R : StrRel} →
                       isBisim-upto F R → isBisim-upto F (F R)
  Φ-compat-pres-upto (M , P) p = P ∘ (M p)

  iterTrans : RelTrans (Str A) → ℕ → StrRel → StrRel
  iterTrans F zero R = R
  iterTrans F (suc n) R = iterTrans F n (F R)

  -- Closure of up-to technique, which will be the the bisimulation we generate from it
  bisimCls : RelTrans (Str A) → StrRel → StrRel
  bisimCls F R s t = ∃ λ n → iterTrans F n R s t

  clsIsBisim : {F : RelTrans (Str A)} (P : Φ-compat F) {R : StrRel} →
               isBisim-upto F R → isBisim' (bisimCls F R)
  clsIsBisim P p {s} {t} (zero , sRt) =
    (proj₁ (p sRt) , 1 , proj₂ (p sRt))
  clsIsBisim {F} (M , P) {R} p {s} {t} (suc n , inFIter) =
    let
      foo = clsIsBisim (M , P) {F R} (Φ-compat-pres-upto (M , P) p) (n , inFIter)
    in (proj₁ foo , (pmap suc id) (proj₂ foo))

  -- Compatible up-to techniques are sound
  compat-sound : {F : RelTrans (Str A)} (P : Φ-compat F) {R : StrRel} →
                 isBisim-upto F R → (s t : Str A) → R s t → s ∼ t
  compat-sound {F} P {R} p s t sRt =
    ∃-bisim→∼ (isBisim'→isBisim {bisimCls F R} (clsIsBisim P p))
    s t (0 , sRt)

  -- | Useful general up-to technique: the equivalence closure is Φ-compatible.
  equivCls-compat : Φ-compat EquivCls
  equivCls-compat = equivCls-monotone , compat
    where
      compat : {R : StrRel} → EquivCls (Φ R) ⇒ Φ (EquivCls R)
      compat (cls-incl (h≈ , tR)) = (h≈ , cls-incl tR)
      compat cls-refl             = (SE.refl , cls-refl)
      compat {R} (cls-sym p)      =
        let (h≈ , tR) = compat {R} p
        in (SE.sym h≈ , cls-sym tR)
      compat {R} (cls-trans p q) =
        let (hx≈hy , txRty) = compat {R} p
            (hy≈hz , tyRtz) = compat {R} q
        in (SE.trans hx≈hy hy≈hz , cls-trans txRty tyRtz)

-- | Element repetition
repeat : ∀{A} → A → Stream A
hd (repeat a) = a
tl (repeat a) = repeat a

-- Streams and lists.

-- Prepending a list to a stream.

_++ˢ_ : ∀ {A} → List A → Stream A → Stream A
[]       ++ˢ s = s
(a ∷ as) ++ˢ s = a ∷ (as ++ˢ s)

-- Taking an initial segment of a stream.

takeˢ : ∀ {A} (n : ℕ) (s : Stream A) → List A
takeˢ 0       s = []
takeˢ (suc n) s = hd s ∷ takeˢ n (tl s)

_↓_ : ∀ {A} (s : Stream A) (n : ℕ) → List A
s ↓ n = takeˢ n s


-- Andreas, 2015-11-28  Check that postfix constructors are fine.
-- There was a TODO in Agda.Syntax.Concrete.Operators which claimed
-- there would be an ambiguity between `true` applied to variable `wrap`
-- and (_wrap true), and arity of constructors would have to be checked.
-- Parsing works fine, so I removed this TODO.

data Bool : Set where true false : Bool

record Wrap A : Set where
  constructor _wrap
  field wrapped : A

test : Wrap Bool → Set
test (true wrap) = Bool
test (false wrap) = Bool

test2 : {A : Set} → Wrap A → A
test2 y = let x wrap = y in x


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

open import Fragment.Equational.Theory.Base

module Fragment.Equational.Theory.Combinators (Θ : Theory) where

open import Fragment.Algebra.Signature
open import Fragment.Algebra.Properties
open import Fragment.Equational.Model
  using (Model; IsModel; Models)
open import Fragment.Equational.Model.Satisfaction

open import Level using (Level)
open import Function using (_∘_)

open import Data.Nat using (ℕ)

private
  variable
    a ℓ : Level

{-
forgetₒ' : ∀ {O} → Model (Θ ⦅ O ⦆ₒ) {a} {ℓ} → Model Θ {a} {ℓ}
forgetₒ' {O = O} A =
  record { ∥_∥/≈   = ∥ A ∥/≈
         ; isModel = forget-isModel
         }
  where open import Fragment.Equational.Model (Θ ⦅ O ⦆ₒ)
          using (∥_∥/≈; ∥_∥ₐ; ∥_∥ₐ-models)
        open import Fragment.Algebra.Algebra (Σ Θ)
          using (∥_∥/≈-isAlgebra)

        forget-⊨ : ∀ {θ eq} → ∥ A ∥ₐ ⊨⟨ θ ⟩ ((Θ ⦅ O ⦆ₒ) ⟦ {!oldₑ!} ⟧ₑ)
                            → forgetₒ ∥ A ∥ₐ ⊨⟨ θ ⟩ (Θ ⟦ eq ⟧ₑ)
        forget-⊨ = {!!}

        forget-models : Models Θ (forgetₒ ∥ A ∥ₐ)
        forget-models eq θ = {!!}

        forget-isModel : IsModel Θ ∥ A ∥/≈
        forget-isModel =
          record { isAlgebra = ∥ (forgetₒ ∥ A ∥ₐ) ∥/≈-isAlgebra
                 ; models    = forget-models
                 }

forgetₑ : ∀ {O E}
          → {X : ∀ {n} → E n → Eq ((Σ Θ) ⦅ O ⦆) n}
          → Model (Θ ⦅ O ∣ E / X ⦆) {a} {ℓ}
          → Model Θ {a} {ℓ}
forgetₑ {O = O} {E} {X} A =
  record { ∥_∥/≈   = {!!}
         ; isModel = {!!}
         }
-}

data HomOp : ℕ → Set where
  h : HomOp 1

data HomEq : ℕ → Set where
  hom : ∀ {n} → ops (Σ Θ) n → HomEq n

AddHom : Theory
AddHom = Θ ⦅ HomOp ∣ HomEq / hom' ⦆
  where import Fragment.Equational.Theory.Laws ((Σ Θ) ⦅ HomOp ⦆) as L

        hom' : ∀ {arity} → HomEq arity → Eq ((Σ Θ) ⦅ HomOp ⦆) arity
        hom' (hom f) = L.hom (newₒ h) (oldₒ f)

data IdOp : ℕ → Set where
  α : IdOp 0

data IdEq : ℕ → Set where
  idₗ : IdEq 1
  idᵣ : IdEq 1

AddId : ops (Σ Θ) 2 → Theory
AddId • = Θ ⦅ IdOp ∣ IdEq / id ⦆
  where import Fragment.Equational.Theory.Laws ((Σ Θ) ⦅ IdOp ⦆) as L

        id : ∀ {arity} → IdEq arity → Eq ((Σ Θ) ⦅ IdOp ⦆) arity
        id idₗ = L.idₗ (newₒ α) (oldₒ •)
        id idᵣ = L.idᵣ (newₒ α) (oldₒ •)

data AnOp : ℕ → Set where
  ω : AnOp 0

data AnEq : ℕ → Set where
  anₗ : AnEq 1
  anᵣ : AnEq 1

AddAn : ops (Σ Θ) 2 → Theory
AddAn • = Θ ⦅ AnOp ∣ AnEq / an ⦆
  where import Fragment.Equational.Theory.Laws ((Σ Θ) ⦅ AnOp ⦆) as L

        an : ∀ {arity} → AnEq arity → Eq ((Σ Θ) ⦅ AnOp ⦆) arity
        an anₗ = L.anₗ (newₒ ω) (oldₒ •)
        an anᵣ = L.anᵣ (newₒ ω) (oldₒ •)


module Utils.HaskellTypes where

postulate String : Set
{-# BUILTIN STRING String #-}

data Unit : Set where
  triv : Unit
{-# COMPILED_DATA Unit () () #-}

data Prod (A : Set) (B : Set) : Set where
  _,_ : A → B → Prod A B
{-# COMPILED_DATA Prod (,) (,) #-}

data Triple (A B C : Set) : Set where
  triple : A → B → C → Triple A B C
{-# COMPILED_DATA Triple (,,) (,,) #-}

infixr 20 _::_
data List (A : Set) : Set where
  [] : List A
  _::_ : A → List A → List A
{-# COMPILED_DATA List [] [] (:) #-}


{-# OPTIONS --cubical --no-import-sorts --safe #-}
module Cubical.Data.Sum.Properties where

open import Cubical.Core.Everything
open import Cubical.Foundations.Prelude
open import Cubical.Foundations.HLevels
open import Cubical.Functions.Embedding
open import Cubical.Foundations.Equiv
open import Cubical.Foundations.Isomorphism
open import Cubical.Data.Empty
open import Cubical.Data.Nat

open import Cubical.Data.Sum.Base

open Iso

private
  variable
    ℓa ℓb ℓc ℓd : Level
    A : Type ℓa
    B : Type ℓb
    C : Type ℓc
    D : Type ℓd

-- Path space of sum type
module ⊎Path {ℓ ℓ'} {A : Type ℓ} {B : Type ℓ'} where

  Cover : A ⊎ B → A ⊎ B → Type (ℓ-max ℓ ℓ')
  Cover (inl a) (inl a') = Lift {j = ℓ-max ℓ ℓ'} (a ≡ a')
  Cover (inl _) (inr _) = Lift ⊥
  Cover (inr _) (inl _) = Lift ⊥
  Cover (inr b) (inr b') = Lift {j = ℓ-max ℓ ℓ'} (b ≡ b')

  reflCode : (c : A ⊎ B) → Cover c c
  reflCode (inl a) = lift refl
  reflCode (inr b) = lift refl

  encode : ∀ c c' → c ≡ c' → Cover c c'
  encode c _ = J (λ c' _ → Cover c c') (reflCode c)

  encodeRefl : ∀ c → encode c c refl ≡ reflCode c
  encodeRefl c = JRefl (λ c' _ → Cover c c') (reflCode c)

  decode : ∀ c c' → Cover c c' → c ≡ c'
  decode (inl a) (inl a') (lift p) = cong inl p
  decode (inl a) (inr b') ()
  decode (inr b) (inl a') ()
  decode (inr b) (inr b') (lift q) = cong inr q

  decodeRefl : ∀ c → decode c c (reflCode c) ≡ refl
  decodeRefl (inl a) = refl
  decodeRefl (inr b) = refl

  decodeEncode : ∀ c c' → (p : c ≡ c') → decode c c' (encode c c' p) ≡ p
  decodeEncode c _ =
    J (λ c' p → decode c c' (encode c c' p) ≡ p)
      (cong (decode c c) (encodeRefl c) ∙ decodeRefl c)

  encodeDecode : ∀ c c' → (d : Cover c c') → encode c c' (decode c c' d) ≡ d
  encodeDecode (inl a) (inl _) (lift d) =
    J (λ a' p → encode (inl a) (inl a') (cong inl p) ≡ lift p) (encodeRefl (inl a)) d
  encodeDecode (inr a) (inr _) (lift d) =
    J (λ a' p → encode (inr a) (inr a') (cong inr p) ≡ lift p) (encodeRefl (inr a)) d

  Cover≃Path : ∀ c c' → Cover c c' ≃ (c ≡ c')
  Cover≃Path c c' =
    isoToEquiv (iso (decode c c') (encode c c') (decodeEncode c c') (encodeDecode c c'))

  isOfHLevelCover : (n : HLevel)
    → isOfHLevel (suc (suc n)) A
    → isOfHLevel (suc (suc n)) B
    → ∀ c c' → isOfHLevel (suc n) (Cover c c')
  isOfHLevelCover n p q (inl a) (inl a') = isOfHLevelLift (suc n) (p a a')
  isOfHLevelCover n p q (inl a) (inr b') =
    isOfHLevelLift (suc n) (isProp→isOfHLevelSuc n isProp⊥)
  isOfHLevelCover n p q (inr b) (inl a') =
    isOfHLevelLift (suc n) (isProp→isOfHLevelSuc n isProp⊥)
  isOfHLevelCover n p q (inr b) (inr b') = isOfHLevelLift (suc n) (q b b')

isEmbedding-inl : isEmbedding (inl {A = A} {B = B})
isEmbedding-inl w z = snd (compEquiv LiftEquiv (⊎Path.Cover≃Path (inl w) (inl z)))

isEmbedding-inr : isEmbedding (inr {A = A} {B = B})
isEmbedding-inr w z = snd (compEquiv LiftEquiv (⊎Path.Cover≃Path (inr w) (inr z)))

isOfHLevel⊎ : (n : HLevel)
  → isOfHLevel (suc (suc n)) A
  → isOfHLevel (suc (suc n)) B
  → isOfHLevel (suc (suc n)) (A ⊎ B)
isOfHLevel⊎ n lA lB c c' =
  isOfHLevelRetract (suc n)
    (⊎Path.encode c c')
    (⊎Path.decode c c')
    (⊎Path.decodeEncode c c')
    (⊎Path.isOfHLevelCover n lA lB c c')

isSet⊎ : isSet A → isSet B → isSet (A ⊎ B)
isSet⊎ = isOfHLevel⊎ 0

isGroupoid⊎ : isGroupoid A → isGroupoid B → isGroupoid (A ⊎ B)
isGroupoid⊎ = isOfHLevel⊎ 1

is2Groupoid⊎ : is2Groupoid A → is2Groupoid B → is2Groupoid (A ⊎ B)
is2Groupoid⊎ = isOfHLevel⊎ 2

⊎Iso : Iso A C → Iso B D → Iso (A ⊎ B) (C ⊎ D)
fun (⊎Iso iac ibd) (inl x) = inl (iac .fun x)
fun (⊎Iso iac ibd) (inr x) = inr (ibd .fun x)
inv (⊎Iso iac ibd) (inl x) = inl (iac .inv x)
inv (⊎Iso iac ibd) (inr x) = inr (ibd .inv x)
rightInv (⊎Iso iac ibd) (inl x) = cong inl (iac .rightInv x)
rightInv (⊎Iso iac ibd) (inr x) = cong inr (ibd .rightInv x)
leftInv (⊎Iso iac ibd) (inl x)  = cong inl (iac .leftInv x)
leftInv (⊎Iso iac ibd) (inr x)  = cong inr (ibd .leftInv x)

⊎-swap-Iso : Iso (A ⊎ B) (B ⊎ A)
fun ⊎-swap-Iso (inl x) = inr x
fun ⊎-swap-Iso (inr x) = inl x
inv ⊎-swap-Iso (inl x) = inr x
inv ⊎-swap-Iso (inr x) = inl x
rightInv ⊎-swap-Iso (inl _) = refl
rightInv ⊎-swap-Iso (inr _) = refl
leftInv ⊎-swap-Iso (inl _)  = refl
leftInv ⊎-swap-Iso (inr _)  = refl

⊎-swap-≃ : A ⊎ B ≃ B ⊎ A
⊎-swap-≃ = isoToEquiv ⊎-swap-Iso

⊎-assoc-Iso : Iso ((A ⊎ B) ⊎ C) (A ⊎ (B ⊎ C))
fun ⊎-assoc-Iso (inl (inl x)) = inl x
fun ⊎-assoc-Iso (inl (inr x)) = inr (inl x)
fun ⊎-assoc-Iso (inr x)       = inr (inr x)
inv ⊎-assoc-Iso (inl x)       = inl (inl x)
inv ⊎-assoc-Iso (inr (inl x)) = inl (inr x)
inv ⊎-assoc-Iso (inr (inr x)) = inr x
rightInv ⊎-assoc-Iso (inl _)       = refl
rightInv ⊎-assoc-Iso (inr (inl _)) = refl
rightInv ⊎-assoc-Iso (inr (inr _)) = refl
leftInv ⊎-assoc-Iso (inl (inl _))  = refl
leftInv ⊎-assoc-Iso (inl (inr _))  = refl
leftInv ⊎-assoc-Iso (inr _)        = refl

⊎-assoc-≃ : (A ⊎ B) ⊎ C ≃ A ⊎ (B ⊎ C)
⊎-assoc-≃ = isoToEquiv ⊎-assoc-Iso

⊎-⊥-Iso : Iso (A ⊎ ⊥) A
fun ⊎-⊥-Iso (inl x) = x
inv ⊎-⊥-Iso x       = inl x
rightInv ⊎-⊥-Iso x      = refl
leftInv ⊎-⊥-Iso (inl x) = refl

⊎-⊥-≃ : A ⊎ ⊥ ≃ A
⊎-⊥-≃ = isoToEquiv ⊎-⊥-Iso


module OldO where

open import Data.Product
open import Function renaming (_∘_ to _○_)

open import Circle

------------------------------------------------------------------------------
-- Abstract interpretation:
-- natural numbers with paths equating all even numbers in one
-- connected component and all odd numbers in another connected
-- component

-- module with 0,1,2,3,4 ... this is the concrete domain

data N : Set where
  Zero  : N
  One   : N
  Two   : N
  Three : N
  Four  : N

recN : (C : Set) → C → C → C → C → C → N → C
recN C c0 c1 c2 c3 c4 Zero = c0
recN C c0 c1 c2 c3 c4 One = c1
recN C c0 c1 c2 c3 c4 Two = c2
recN C c0 c1 c2 c3 c4 Three = c3
recN C c0 c1 c2 c3 c4 Four = c4

indN : (C : N → Set) → C Zero → C One → C Two → C Three → C Four → (n : N) → C n
indN C c0 c1 c2 c3 c4 Zero = c0
indN C c0 c1 c2 c3 c4 One = c1
indN C c0 c1 c2 c3 c4 Two = c2
indN C c0 c1 c2 c3 c4 Three = c3
indN C c0 c1 c2 c3 c4 Four = c4

-- module for the abstract domain {even, odd} except that we don't define it
-- this way: we simply add paths between the even elements and paths between
-- the odd elements

module Parity where

  private
    data N* : Set where
      Zero*  : N*
      One*   : N*
      Two*   : N*
      Three* : N*
      Four*  : N*

  NA : Set
  NA = N*

  zero : NA
  zero = Zero*

  one : NA
  one = One*

  two : NA
  two = Two*

  three : NA
  three = Three*

  four : NA
  four = Four*

  postulate
    even02 : Zero* ≡ Two*
    even04 : Zero* ≡ Four*
    odd13  : One* ≡ Three*

  recNA : (C : Set) → (c0 c1 c2 c3 c4 : C) →
    (ceven02 : c0 ≡ c2) → (ceven04 : c0 ≡ c4) → (codd13 : c1 ≡ c3) →
    NA → C
  recNA C c0 c1 c2 c3 c4 _ _ _ Zero* = c0
  recNA C c0 c1 c2 c3 c4 _ _ _ One* = c1
  recNA C c0 c1 c2 c3 c4 _ _ _ Two* = c2
  recNA C c0 c1 c2 c3 c4 _ _ _ Three* = c3
  recNA C c0 c1 c2 c3 c4 _ _ _ Four* = c4

  postulate
    αrecNA02 : (C : Set) → (c0 c1 c2 c3 c4 : C) →
      (ceven02 : c0 ≡ c2) → (ceven04 : c0 ≡ c4) → (codd13 : c1 ≡ c3) →
      ap (recNA C c0 c1 c2 c3 c4 ceven02 ceven04 codd13) even02 ≡ ceven02

    αrecNA04 : (C : Set) → (c0 c1 c2 c3 c4 : C) →
      (ceven02 : c0 ≡ c2) → (ceven04 : c0 ≡ c4) → (codd13 : c1 ≡ c3) →
      ap (recNA C c0 c1 c2 c3 c4 ceven02 ceven04 codd13) even04 ≡ ceven04

    αrecNA13 : (C : Set) → (c0 c1 c2 c3 c4 : C) →
      (ceven02 : c0 ≡ c2) → (ceven04 : c0 ≡ c4) → (codd13 : c1 ≡ c3) →
      ap (recNA C c0 c1 c2 c3 c4 ceven02 ceven04 codd13) odd13 ≡ codd13

  indNA : (C : NA → Set) →
    (c0 : C Zero*) →
    (c1 : C One*) →
    (c2 : C Two*) →
    (c3 : C Three*) →
    (c4 : C Four*) →
    (ceven02 : transport C even02 c0 ≡ c2) →
    (ceven04 : transport C even04 c0 ≡ c4) →
    (codd13 : transport C odd13 c1 ≡ c3) →
    (n : NA) → C n
  indNA C c0 c1 c2 c3 c4 ceven02 ceven04 codd13 Zero* = c0
  indNA C c0 c1 c2 c3 c4 ceven02 ceven04 codd13 One* = c1
  indNA C c0 c1 c2 c3 c4 ceven02 ceven04 codd13 Two* = c2
  indNA C c0 c1 c2 c3 c4 ceven02 ceven04 codd13 Three* = c3
  indNA C c0 c1 c2 c3 c4 ceven02 ceven04 codd13 Four* = c4

open Parity

-- Now we define functions back and forth

abs : N → NA
abs = recN NA zero one two three four

con : NA → N
con = recNA N Zero One Zero One Zero (refl Zero) (refl Zero) (refl One)

conEven02 : ap con even02 ≡ refl Zero
conEven02 = αrecNA02 N Zero One Zero One Zero (refl Zero) (refl Zero) (refl One)

conEven04 : ap con even04 ≡ refl Zero
conEven04 = αrecNA04 N Zero One Zero One Zero (refl Zero) (refl Zero) (refl One)

conOdd13 : ap con odd13 ≡ refl One
conOdd13 = αrecNA13 N Zero One Zero One Zero (refl Zero) (refl Zero) (refl One)

-- Compose both ways

absconeven02 : ap (abs ○ con) even02 ≡ refl zero
absconeven02 =
  ap (abs ○ con) even02
    ≡⟨ {!!} ⟩
  ap abs (ap con even02)
    ≡⟨ {!!} ⟩
  ap abs (refl Zero)
    ≡⟨ {!!} ⟩
  refl zero ∎

absconeven04 : ap (abs ○ con) even04 ≡ refl zero
absconeven04 =
  ap (abs ○ con) even04
    ≡⟨ {!!} ⟩
  ap abs (ap con even04)
    ≡⟨ {!!} ⟩
  ap abs (refl Zero)
    ≡⟨ {!!} ⟩
  refl zero ∎

absconodd13 : ap (abs ○ con) odd13 ≡ refl one
absconodd13 =
  ap (abs ○ con) odd13
    ≡⟨ {!!} ⟩
  ap abs (ap con odd13)
    ≡⟨ {!!} ⟩
  ap abs (refl One)
    ≡⟨ {!!} ⟩
  refl one ∎

αeven02 : transport (λ x → (abs ○ con) x ≡ x) even02 (refl zero) ≡ even02
αeven02 =
  transport (λ x → (abs ○ con) x ≡ x) even02 (refl zero)
    ≡⟨ {!!} ⟩
  ! (ap (abs ○ con) even02) ∘ refl zero ∘ ap id even02
    ≡⟨ {!!} ⟩
  ! (ap (abs ○ con) even02) ∘ refl zero ∘ even02
    ≡⟨ {!!} ⟩
  ! (ap (abs ○ con) even02) ∘ even02
    ≡⟨ {!!} ⟩
  refl zero ∘ even02
    ≡⟨ {!!} ⟩
  even02 ∎

αeven04 : transport (λ x → (abs ○ con) x ≡ x) even04 (refl zero) ≡ even04
αeven04 =
  transport (λ x → (abs ○ con) x ≡ x) even04 (refl zero)
    ≡⟨ {!!} ⟩
  even04 ∎

αodd13 : transport (λ x → (abs ○ con) x ≡ x) odd13 (refl one) ≡ odd13
αodd13 =
  transport (λ x → (abs ○ con) x ≡ x) odd13 (refl one)
    ≡⟨ {!!} ⟩
  odd13 ∎

-- Galois connections...

αN : con ○ abs ○ con ○ abs ∼ con ○ abs
αN = indN (λ x → (con ○ abs ○ con ○ abs) x ≡ (con ○ abs) x)
     (refl Zero) (refl One) (refl Zero) (refl One) (refl Zero)

αNA : abs ○ con ∼ id
αNA = indNA (λ x → (abs ○ con) x ≡ x)
        (refl zero) (refl one) even02 odd13 even04
        αeven02 αeven04 αodd13

-- Computations on N and NA can be related
-- Concrete computation

incN : N → N
incN Zero = One
incN One = Two
incN Two = Three
incN Three = Four
incN Four = Zero

addN : N → N → N
addN Zero b = b
addN a Zero = a
addN One One = Two
addN One Two = Three
addN One Three = Four
addN One Four = Zero
addN Two One = Three
addN Two Two = Four
addN Two Three = Zero
addN Two Four = One
addN Three One = Four
addN Three Two = Zero
addN Three Three = One
addN Three Four = Two
addN Four One = Zero
addN Four Two = One
addN Four Three = Two
addN Four Four = Three

-- we can apply an operation in the abstract domain and report the
-- approximate result

absF : (N → N) → (NA → NA)
absF f = abs ○ f ○ con

approx : (N → N) → (N → N)
approx f n = con ((absF f) (abs n))

test0 : approx incN Zero ≡ One
test0 = refl One

test1 : approx incN One ≡ Zero
test1 = refl Zero

test2 : approx incN Two ≡ One
test2 = refl One

test3 : approx incN Three ≡ Zero
test3 = refl Zero

test4 : approx incN Four ≡ One
test4 = refl One

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