------------------------------------------------------------------------
-- The Agda standard library
--
-- Consequences of a monomorphism between group-like structures
------------------------------------------------------------------------

-- See Data.Nat.Binary.Properties for examples of how this and similar
-- modules can be used to easily translate properties between types.

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

open import Algebra.Bundles
open import Algebra.Morphism.Structures
open import Relation.Binary.Core

module Algebra.Morphism.GroupMonomorphism
  {a b ℓ₁ ℓ₂} {G₁ : RawGroup a ℓ₁} {G₂ : RawGroup b ℓ₂} {⟦_⟧}
  (isGroupMonomorphism : IsGroupMonomorphism G₁ G₂ ⟦_⟧)
  where

open IsGroupMonomorphism isGroupMonomorphism
open RawGroup G₁ renaming
  (Carrier to A; _≈_ to _≈₁_; _∙_ to _∙_; _⁻¹ to _⁻¹₁; ε to ε₁)
open RawGroup G₂ renaming
  (Carrier to B; _≈_ to _≈₂_; _∙_ to _◦_; _⁻¹ to _⁻¹₂; ε to ε₂)

open import Algebra.Definitions
open import Algebra.Structures
open import Data.Product
import Relation.Binary.Reasoning.Setoid as SetoidReasoning

------------------------------------------------------------------------
-- Re-export all properties of monoid monomorphisms

open import Algebra.Morphism.MonoidMonomorphism
  isMonoidMonomorphism public

------------------------------------------------------------------------
-- Properties

module _ (◦-isMagma : IsMagma _≈₂_ _◦_) where

  open IsMagma ◦-isMagma renaming (∙-cong to ◦-cong)
  open SetoidReasoning setoid

  inverseˡ : LeftInverse _≈₂_ ε₂ _⁻¹₂ _◦_ → LeftInverse _≈₁_ ε₁ _⁻¹₁  _∙_
  inverseˡ invˡ x = injective (begin
    ⟦ x ⁻¹₁ ∙ x ⟧     ≈⟨ ∙-homo (x ⁻¹₁ ) x ⟩
    ⟦ x ⁻¹₁ ⟧ ◦ ⟦ x ⟧ ≈⟨ ◦-cong (⁻¹-homo x) refl ⟩
    ⟦ x ⟧ ⁻¹₂ ◦ ⟦ x ⟧ ≈⟨ invˡ ⟦ x ⟧ ⟩
    ε₂                ≈˘⟨ ε-homo ⟩
    ⟦ ε₁ ⟧ ∎)

  inverseʳ : RightInverse _≈₂_ ε₂ _⁻¹₂ _◦_ → RightInverse _≈₁_ ε₁ _⁻¹₁  _∙_
  inverseʳ invʳ x = injective (begin
    ⟦ x ∙ x ⁻¹₁ ⟧     ≈⟨ ∙-homo x (x ⁻¹₁) ⟩
    ⟦ x ⟧ ◦ ⟦ x ⁻¹₁ ⟧ ≈⟨ ◦-cong refl (⁻¹-homo x) ⟩
    ⟦ x ⟧ ◦ ⟦ x ⟧ ⁻¹₂ ≈⟨ invʳ ⟦ x ⟧ ⟩
    ε₂                ≈˘⟨ ε-homo ⟩
    ⟦ ε₁ ⟧ ∎)

  inverse : Inverse _≈₂_ ε₂ _⁻¹₂ _◦_ → Inverse _≈₁_ ε₁ _⁻¹₁  _∙_
  inverse (invˡ , invʳ) = inverseˡ invˡ , inverseʳ invʳ

  ⁻¹-cong : Congruent₁ _≈₂_ _⁻¹₂ → Congruent₁ _≈₁_ _⁻¹₁
  ⁻¹-cong  ⁻¹-cong {x} {y} x≈y = injective (begin
    ⟦ x ⁻¹₁ ⟧ ≈⟨ ⁻¹-homo x ⟩
    ⟦ x ⟧ ⁻¹₂ ≈⟨ ⁻¹-cong (⟦⟧-cong x≈y) ⟩
    ⟦ y ⟧ ⁻¹₂ ≈˘⟨ ⁻¹-homo y ⟩
    ⟦ y ⁻¹₁ ⟧ ∎)

isGroup : IsGroup _≈₂_ _◦_ ε₂ _⁻¹₂ → IsGroup _≈₁_ _∙_ ε₁ _⁻¹₁
isGroup isGroup = record
  { isMonoid = isMonoid G.isMonoid
  ; inverse  = inverse  G.isMagma G.inverse
  ; ⁻¹-cong  = ⁻¹-cong  G.isMagma G.⁻¹-cong
  } where module G = IsGroup isGroup

isAbelianGroup : IsAbelianGroup _≈₂_ _◦_ ε₂ _⁻¹₂ → IsAbelianGroup _≈₁_ _∙_ ε₁ _⁻¹₁
isAbelianGroup isAbelianGroup = record
  { isGroup = isGroup G.isGroup
  ; comm    = comm G.isMagma G.comm
  } where module G = IsAbelianGroup isAbelianGroup


{-# OPTIONS --copatterns #-}
{-# OPTIONS -v tc.constr.findInScope:15 #-}

-- One-place functors (decorations) on Set

module Control.Bug-Loop where

open import Function using (id; _∘_)
open import Relation.Binary.PropositionalEquality
open ≡-Reasoning

open import Control.Functor

open IsFunctor {{...}}

record IsDecoration (D : Set → Set) : Set₁ where
  field
    traverse    : ∀ {F} {{ functor : IsFunctor F }} {A B} →

        (A → F B) → D A → F (D B)

    traverse-id : ∀ {A} →

        traverse {F = λ A → A} {A = A} id ≡ id

    traverse-∘  :
      ∀ {F G} {{ funcF : IsFunctor F}} {{ funcG : IsFunctor G}} →
      ∀ {A B C} {f : A → F B} {g : B → G C} →

        traverse ((map g) ∘ f) ≡ map {{funcF}} (traverse g) ∘ traverse f

  isFunctor : IsFunctor D
  isFunctor = record
    { ops   = record { map    = traverse }
    ; laws  = record { map-id = traverse-id
                     ; map-∘  = traverse-∘
                     }
    }

open IsDecoration

idIsDecoration : IsDecoration (λ A → A)
traverse    idIsDecoration f = f
traverse-id idIsDecoration = refl
traverse-∘  idIsDecoration = refl

compIsDecoration : ∀ {D E} → IsDecoration D → IsDecoration E → IsDecoration (λ A → D (E A))
traverse    (compIsDecoration d e) f = traverse d (traverse e f)
traverse-id (compIsDecoration d e) = begin
    traverse d (traverse e id)
  ≡⟨ cong (traverse d) (traverse-id e) ⟩
    traverse d id
  ≡⟨ traverse-id d ⟩
    id
  ∎
traverse-∘ (compIsDecoration d e) {{funcF = funcF}} {{funcG = funcG}} {f = f} {g = g} = begin
    traverse (compIsDecoration d e) (map g ∘ f)
  ≡⟨⟩
    traverse d (traverse e (map g ∘ f))
  ≡⟨ cong (traverse d) (traverse-∘ e) ⟩
    traverse d (map (traverse e g) ∘ traverse e f)
  ≡⟨ traverse-∘ d ⟩
    map (traverse d (traverse e g)) ∘ traverse d (traverse e f)
  ≡⟨⟩
    map (traverse (compIsDecoration d e) g) ∘ traverse (compIsDecoration d e) f
  ∎


------------------------------------------------------------------------
-- The Agda standard library
--
-- Universes
------------------------------------------------------------------------

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

module Universe where

open import Data.Product
open import Function
open import Level

-- Universes.

record Universe u e : Set (suc (u ⊔ e)) where
  field
    -- Codes.
    U : Set u

    -- Decoding function.
    El : U → Set e

-- Indexed universes.

record Indexed-universe i u e : Set (suc (i ⊔ u ⊔ e)) where
  field
    -- Index set.
    I : Set i

    -- Codes.
    U : I → Set u

    -- Decoding function.
    El : ∀ {i} → U i → Set e

  -- An indexed universe can be turned into an unindexed one.

  unindexed-universe : Universe (i ⊔ u) e
  unindexed-universe = record
    { U  = ∃ λ i → U i
    ; El = El ∘ proj₂
    }


{-# OPTIONS --exact-split #-}

open import Agda.Builtin.Nat

data IsZero : Nat → Set where
  isZero : IsZero 0

test : (n m : Nat) → IsZero n → IsZero m → Nat
test zero zero _ _ = zero
test (suc _) _ () _
test _ (suc _) _ ()


data Nat : Set where
  zero : Nat
  suc  : Nat → Nat

{-# BUILTIN NATURAL Nat #-}

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

pred : Nat → Nat
pred zero = zero
pred (suc n) = n

{-# NON_TERMINATING #-}
loop : Nat → Nat
loop zero = zero
loop n = loop (pred n)

-- Non-terminating functions reduce when evaluated at top-level,
-- but not in a hole.
hole : Set
hole = {!!}


module STLCRef.Examples where

-- This file contains a few example programs for the definitional
-- interpreter for STLC+Ref using monadic strength, defined in Section
-- 3.

open import STLCRef.Semantics
open import Data.List
open import Data.List.Relation.Unary.Any
open import Data.List.Relation.Unary.All
open import Relation.Binary.PropositionalEquality
open import Data.Integer hiding (suc)
open import Agda.Builtin.Nat hiding (_+_)
open import Data.Maybe
open import Data.Product

-------------------
-- STLC FRAGMENT --
-------------------

-- The identity function: λ x . x
idexpr : Expr [] (unit ⇒ unit)
idexpr = ƛ (var (here refl))

-- id () = ()
test-idexpr : eval 2 (idexpr · unit) [] [] ≡ just (_ , [] , unit , _)
test-idexpr = refl

-- curried addition: λ x . λ y . y + x
curry+ : Expr [] (int ⇒ (int ⇒ int))
curry+ = ƛ (ƛ (iop _+_ (var (here refl)) (var (there (here refl)))))

-- 1 + 1 = 2
test-curry+ : eval 3 ((curry+ · (num (+ (suc zero)))) · (num (+ (suc zero)))) [] []
              ≡ just (_ , [] , num (+ (suc (suc zero))) , _)
test-curry+ = refl

------------------
-- REF FRAGMENT --
------------------

-- Sugar for let: LET e1 e2 = (λ x . e2) e1
LET : ∀ {Γ a b} → Expr Γ a → Expr (a ∷ Γ) b → Expr Γ b
LET bnd bod = (ƛ bod) · bnd

-- Factorial function, defined via Landin's knot:
--
-- let r = ref (λ x . x) in
-- let f = λ n . ifz n then 1 else n * (!r (n - 1)) in
-- let _ = r := f in
-- f 4
landin-fac : Expr [] int
landin-fac =
  LET (ref {t = int ⇒ int} (ƛ (var (here refl))))
  (LET (ƛ {a = int} (ifz (var (here refl))
                         (num (+ 1))
                         (iop (Data.Integer._*_) (var (here refl))
                              ((! (var (there (here refl)))) · (iop (Data.Integer._-_) (var (here refl)) (num (+ 1)))))))
  (LET ((var (there (here refl))) ≔ var (here refl))
  (var (there (here refl))) · (num (+ 4))))

test-landin-fac : eval 20 landin-fac [] [] ≡ just (_ , _ , num (+ 24) , _)
test-landin-fac = refl

-- Divergence via Landin's knot:
--
-- let r = ref (λ x . x) in
-- let f = λ x . !r 0 in
-- let _ = r := f in
-- f 0
landin-div : Expr [] int
landin-div =
  LET (ref {t = int ⇒ int} (ƛ (var (here refl))))
  (LET (ƛ {a = int} ((! (var (there (here refl)))) · num (+ zero)))
  (LET ((var (there (here refl))) ≔ var (here refl))
  (var (there (here refl))) · (num (+ zero))))

test-landin-div : eval 1337 landin-div [] [] ≡ nothing
test-landin-div = refl


------------------------------------------------------------------------------
-- Simple example of a nested recursive function
------------------------------------------------------------------------------

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

-- From: Ana Bove and Venanzio Capretta. Nested general recursion and
-- partiality in type theory. Vol. 2152 of LNCS. 2001.

module FOTC.Program.Nest.Nest where

open import FOTC.Base

------------------------------------------------------------------------------
-- The nest function.
postulate
  nest   : D → D
  nest-0 : nest zero            ≡ zero
  nest-S : ∀ n → nest (succ₁ n) ≡ nest (nest n)
{-# ATP axioms nest-0 nest-S #-}


------------------------------------------------------------------------
-- Products implemented using records
------------------------------------------------------------------------

-- It it ever becomes convenient to pattern match on records I might
-- make this the default implementation of products.

module Data.Product.Record where

open import Data.Function

infixr 4 _,_
infixr 2 _×_ _-×-_ _-,-_

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

record Σ (a : Set) (b : a → Set) : Set where
  field
    proj₁ : a
    proj₂ : b proj₁

open Σ public

_×_ : (a b : Set) → Set
a × b = Σ a (λ _ → b)

------------------------------------------------------------------------
-- Functions

_,_ : ∀ {a b} → (x : a) → b x → Σ a b
(x , y) = record {proj₁ = x; proj₂ = y}

<_,_> : ∀ {A} {B : A → Set} {C : ∀ {x} → B x → Set}
        (f : (x : A) → B x) → ((x : A) → C (f x)) →
        ((x : A) → Σ (B x) C)
< f , g > x = (f x , g x)

map : ∀ {A B P Q} →
      (f : A → B) → (∀ {x} → P x → Q (f x)) →
      Σ A P → Σ B Q
map f g = < f ∘ proj₁ , g ∘ proj₂ >

swap : ∀ {a b} → a × b → b × a
swap = < proj₂ , proj₁ >

_-×-_ : ∀ {a b} → (a → b → Set) → (a → b → Set) → (a → b → Set)
f -×- g = f -[ _×_ ]₁- g

_-,-_ : ∀ {a b c d} → (a → b → c) → (a → b → d) → (a → b → c × d)
f -,- g = f -[ _,_ ]- g

curry : {a : Set} {b : a → Set} {c : Σ a b → Set} →
        ((p : Σ a b) → c p) →
        ((x : a) → (y : b x) → c (x , y))
curry f x y = f (x , y)

uncurry : {a : Set} {b : a → Set} {c : Σ a b → Set} →
          ((x : a) → (y : b x) → c (x , y)) →
          ((p : Σ a b) → c p)
uncurry f p = f (proj₁ p) (proj₂ p)


------------------------------------------------------------------------
-- The Agda standard library
--
-- Properties satisfied by strict partial orders
------------------------------------------------------------------------

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

open import Relation.Binary

module Relation.Binary.Properties.StrictPartialOrder
       {s₁ s₂ s₃} (SPO : StrictPartialOrder s₁ s₂ s₃) where

open Relation.Binary.StrictPartialOrder SPO
  renaming (trans to <-trans)
open import Relation.Binary.Construct.StrictToNonStrict _≈_ _<_

------------------------------------------------------------------------
-- Strict partial orders can be converted to posets

poset : Poset _ _ _
poset = record
  { isPartialOrder = isPartialOrder isStrictPartialOrder
  }

open Poset poset public


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

module Cubical.Data.Fin where

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


data Bool : Set where
  true : Bool
  false : Bool

if_then_else : ∀ {l} {A : Set l} -> Bool -> A -> A -> A
if true then t else e = t
if false then t else e = e

if2_,_then_else1_else2_else_ : ∀ {l} {A : Set l} -> (b1 b2 : Bool) -> (t e1 e2 e : A) -> A
if2 true , true then t else1 e1 else2 e2 else e = t
if2 true , false then t else1 e1 else2 e2 else e = e1
if2 false , true then t else1 e1 else2 e2 else e = e2
if2 false , false then t else1 e1 else2 e2 else e = e

example : Bool
example = if2 true , false then true else1 false else2 true else false


{-# OPTIONS --safe #-}
module Cubical.Algebra.CommRing.QuotientRing where

open import Cubical.Foundations.Prelude

open import Cubical.HITs.SetQuotients hiding (_/_)

open import Cubical.Algebra.CommRing
open import Cubical.Algebra.CommRing.Ideal
open import Cubical.Algebra.Ring
open import Cubical.Algebra.Ring.QuotientRing renaming (_/_ to _/Ring_) hiding (asRing)

private
  variable
    ℓ : Level

_/_ : (R : CommRing ℓ) → (I : IdealsIn R) → CommRing ℓ
R / I =
  fst asRing , commringstr _ _ _ _ _
                 (iscommring (RingStr.isRing (snd asRing))
                             (elimProp2 (λ _ _ → squash/ _ _)
                                        commEq))
   where
       asRing = (CommRing→Ring R) /Ring (CommIdeal→Ideal I)
       _·/_ : fst asRing → fst asRing → fst asRing
       _·/_ = RingStr._·_ (snd asRing)
       commEq : (x y : fst R) → ([ x ] ·/ [ y ]) ≡ ([ y ] ·/ [ x ])
       commEq x y i = [ CommRingStr.·Comm (snd R) x y i ]

[_]/ : {R : CommRing ℓ} {I : IdealsIn R} → (a : fst R) → fst (R / I)
[ a ]/ = [ a ]


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

module Categories.Groupoid.Product where

open import Data.Product

open import Categories.Category
open import Categories.Groupoid
open import Categories.Morphisms
import Categories.Product as ProductC

Product : ∀ {o₁ ℓ₁ e₁ o₂ ℓ₂ e₂} {C : Category o₁ ℓ₁ e₁} {D : Category o₂ ℓ₂ e₂}
        → Groupoid C → Groupoid D → Groupoid (ProductC.Product C D)
Product c₁ c₂ = record
         { _⁻¹ = λ {(x₁ , x₂) → Groupoid._⁻¹ c₁ x₁
                              , Groupoid._⁻¹ c₂ x₂}
         ; iso = record { isoˡ = Iso.isoˡ (Groupoid.iso c₁)
                               , Iso.isoˡ (Groupoid.iso c₂)
                        ; isoʳ = Iso.isoʳ (Groupoid.iso c₁)
                               , Iso.isoʳ (Groupoid.iso c₂) } }


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

open import Cubical.Foundations.Prelude

open import Cubical.HITs.SetQuotients.Base

open import Cubical.Data.Prod
open import Cubical.Data.Nat

rel : (ℕ ×Σ ℕ) → (ℕ ×Σ ℕ) → Type₀
rel (a₀ , b₀) (a₁ , b₁) = x ≡ y
  where
    x = a₀ + b₁
    y = a₁ + b₀

ℤ = (ℕ ×Σ ℕ) / rel


{-# OPTIONS --allow-unsolved-metas #-}
module TermByFunctionNames where

open import OscarPrelude
open import VariableName
open import FunctionName

data TermByFunctionNames : Nat → Set
 where
  variable : VariableName → TermByFunctionNames zero
  function : FunctionName → {arity : Nat} → (τs : Vec (Σ Nat TermByFunctionNames) arity) → {n : Nat} → n ≡ sum (vecToList $ (fst <$> τs)) → TermByFunctionNames (suc n)

mutual
  eqTermByFunctionNames : ∀ {n} → (x y : TermByFunctionNames n) → Dec (x ≡ y)
  eqTermByFunctionNames = {!!}
{-
  eqTermByFunctionNames : ∀ {n} → (x y : TermByFunctionNames n) → Dec (x ≡ y)
  eqTermByFunctionNames {.0} (variable x) (variable x₁) = {!!}
  eqTermByFunctionNames {.(suc n)} (function x {arity = arity₁} τs {n = n} x₁) (function x₂ {arity = arity₂} τs₁ {n = .n} x₃) with x ≟ x₂ | arity₁ ≟ arity₂
  eqTermByFunctionNames {.(suc n)} (function x {arity₁} τs {n} x₄) (function .x {.arity₁} τs₁ {.n} x₅) | yes refl | (yes refl) with eqTermByFunctionNamess τs τs₁
  eqTermByFunctionNames {.(suc n)} (function x₁ {arity₁} τs {n} x₄) (function .x₁ {.arity₁} .τs {.n} x₅) | yes refl | (yes refl) | (yes refl) rewrite x₄ | x₅ = yes refl
  eqTermByFunctionNames {.(suc n)} (function x₁ {arity₁} τs {n} x₄) (function .x₁ {.arity₁} τs₁ {.n} x₅) | yes refl | (yes refl) | (no x) = {!!}
  eqTermByFunctionNames {.(suc n)} (function x {arity₁} τs {n} x₄) (function x₂ {arity₂} τs₁ {.n} x₅) | yes x₁ | (no x₃) = {!!}
  eqTermByFunctionNames {.(suc n)} (function x {arity₁} τs {n} x₄) (function x₂ {arity₂} τs₁ {.n} x₅) | no x₁ | (yes x₃) = {!!}
  eqTermByFunctionNames {.(suc n)} (function x {arity₁} τs {n} x₄) (function x₂ {arity₂} τs₁ {.n} x₅) | no x₁ | (no x₃) = {!!}
-}
  eqTermByFunctionNamess : ∀ {n} → (x y : Vec (Σ Nat TermByFunctionNames) n) → Dec (x ≡ y)
  eqTermByFunctionNamess {.0} [] [] = {!!}
  eqTermByFunctionNamess (_∷_ {n = n} (fst₁ , snd₁) x₁) (_∷_ {n = .n} (fst₂ , snd₂) y) with fst₁ ≟ fst₂
  eqTermByFunctionNamess (_∷_ {n = n} (fst₁ , snd₁) x₁) (_∷_ {n = .n} (fst₂ , snd₂) y) | yes refl with eqTermByFunctionNames snd₁ snd₂
  eqTermByFunctionNamess (_∷_ {n = n} (fst₁ , snd₁) x₁) (_∷_ {n = .n} (fst₂ , snd₂) y) | yes refl | yes refl with eqTermByFunctionNamess x₁ y
  eqTermByFunctionNamess (_∷_ {n = n} (fst₁ , snd₁) x₁) (_∷_ {n = .n} (fst₂ , snd₂) y) | yes refl | yes refl | yes refl = yes refl
  eqTermByFunctionNamess (_∷_ {n = n} (fst₁ , snd₁) x₁) (_∷_ {n = .n} (fst₂ , snd₂) y) | yes refl | yes refl | no ref = {!!}
  eqTermByFunctionNamess (_∷_ {n = n} (fst₁ , snd₁) x₁) (_∷_ {n = .n} (fst₂ , snd₂) y) | yes refl | no ref = {!!}
  eqTermByFunctionNamess (_∷_ {n = n} (fst₁ , snd₁) x₁) (_∷_ {n = .n} (fst₂ , snd₂) y) | no ref = {!!}

instance EqTermByFunctionNames : ∀ {n} → Eq (TermByFunctionNames n)
Eq._==_ EqTermByFunctionNames = eqTermByFunctionNames

{-
instance EqTermByFunctionNames : ∀ {n} → Eq (TermByFunctionNames n)
Eq._==_ EqTermByFunctionNames (variable x) (variable x₁) = {!!}
Eq._==_ EqTermByFunctionNames (function x {arity = arity₁} τs {n = n} x₁) (function x₂ {arity = arity₂} τs₁ {n = .n} x₃) with x ≟ x₂ | arity₁ ≟ arity₂
Eq._==_ EqTermByFunctionNames (function x {arity₁} τs {n} x₄) (function .x {.arity₁} τs₁ {.n} x₅) | yes refl | (yes refl) with τs ≟ τs₁
Eq._==_ EqTermByFunctionNames (function x {arity₁} τs {n} x₄) (function .x {.arity₁} τs₁ {.n} x₅) | yes refl | (yes refl) | τs≡τs₁ = {!!}
Eq._==_ EqTermByFunctionNames (function x {arity₁} τs {n} x₄) (function x₂ {arity₂} τs₁ {.n} x₅) | yes x₁ | (no x₃) = {!!}
Eq._==_ EqTermByFunctionNames (function x {arity₁} τs {n} x₄) (function x₂ {arity₂} τs₁ {.n} x₅) | no x₁ | (yes x₃) = {!!}
Eq._==_ EqTermByFunctionNames (function x {arity₁} τs {n} x₄) (function x₂ {arity₂} τs₁ {.n} x₅) | no x₁ | (no x₃) = {!!}
-}


open import Relation.Binary.Core
open import Level using (Level; _⊔_; suc)
open import Data.Product using (Σ; _×_; _,_; Σ-syntax;  ∃-syntax; proj₁; proj₂)
open import Function

open import DeBruijn
open import Beta
open import Takahashi
open import Z
open import ConfluenceTakahashi using (lemma3-3; lemma3-5)

star-left :  ∀ {n} {M L N : Term n}
  → M —→ L
  → Star _—→_ L N
    -------------
  → Star _—→_ M N
star-left ML ε = ε ▻ ML
star-left ML (L*N′ ▻ N′N) =
  star-left ML L*N′ ▻ N′N

betas-star : ∀ {n} {M N : Term n}
  → M —↠ N
    -------------
  → Star _—→_ M N
betas-star (M ∎) = ε
betas-star (M —→⟨ M—→M′ ⟩ M′—↠N) =
  star-left M—→M′ (betas-star M′—↠N)

z-confluence-beta : ∀ {n} → Confluence (_—→_ {n})
z-confluence-beta = z-confluence ( _*
                                 , betas-star ∘ lemma3-3
                                 , betas-star ∘ lemma3-5)


-- Step-indexed logical relations based on functional big-step semantics.
--
-- Goal for now: just prove the fundamental theorem of logical relations,
-- relating a term to itself in a different environments.
--
-- But to betray the eventual goal, I can also relate integer values with a
-- change in the relation witness. That was a completely local change. But that
-- might also be because we only have few primitives.
--
-- Because of closures, we need relations across different terms with different
-- contexts and environments.
--
-- This development is strongly inspired by "Imperative self-adjusting
-- computation" (ISAC below), POPL'08, in preference to Dargaye and Leroy (2010), "A verified
-- framework for higher-order uncurrying optimizations", but I deviate
-- somewhere, especially to try following "Functional Big-Step Semantics"),
-- though I deviate somewhere.

-- In fact, this development is typed, hence some parts of the model are closer
-- to Ahmed (ESOP 2006), "Step-Indexed Syntactic Logical Relations for Recursive
-- and Quantified Types". But for many relevant aspects, the two papers are
-- interchangeable.
--
-- The main insight from the ISAC paper missing from the other one is how to
-- step-index a big-step semantics correctly: just ensure that the steps in the
-- big-step semantics agree with the ones in the small-step semantics. *Then*
-- everything just works with big-step semantics. Quite a few other details are
-- fiddly, but those are the same in small-step semantics.
--
-- CHEATS:
-- "Fuctional big-step semantics" requires an external termination proof for the
-- semantics. There it is also mechanized, here it isn't. Worse, the same
-- termination problem affects some lemmas about the semantics.

module Thesis.FunBigStepSILR2 where

open import Data.Empty
open import Data.Unit.Base hiding (_≤_)
open import Data.Product
open import Relation.Binary.PropositionalEquality
open import Relation.Binary hiding (_⇒_)
open import Data.Nat -- using (ℕ; zero; suc; decTotalOrder; _<_; _≤_)
open import Data.Nat.Properties

data Type : Set where
  _⇒_ : (σ τ : Type) → Type
  nat : Type
infixr 20 _⇒_

⟦_⟧Type : Type → Set
⟦ σ ⇒ τ ⟧Type = ⟦ σ ⟧Type → ⟦ τ ⟧Type
⟦ nat ⟧Type = ℕ

open import Base.Syntax.Context Type public
open import Base.Syntax.Vars Type public

data Const : (τ : Type) → Set where
  lit : ℕ → Const nat
  -- succ : Const (int ⇒ int)

data Term (Γ : Context) :
  (τ : Type) → Set where
  -- constants aka. primitives
  const : ∀ {τ} →
    (c : Const τ) →
    Term Γ τ
  var : ∀ {τ} →
    (x : Var Γ τ) →
    Term Γ τ
  app : ∀ {σ τ}
    (s : Term Γ (σ ⇒ τ)) →
    (t : Term Γ σ) →
    Term Γ τ
  -- we use de Bruijn indices, so we don't need binding occurrences.
  abs : ∀ {σ τ}
    (t : Term (σ • Γ) τ) →
    Term Γ (σ ⇒ τ)

weaken : ∀ {Γ₁ Γ₂ τ} →
  (Γ₁≼Γ₂ : Γ₁ ≼ Γ₂) →
  Term Γ₁ τ →
  Term Γ₂ τ
weaken Γ₁≼Γ₂ (const c) = const c
weaken Γ₁≼Γ₂ (var x) = var (weaken-var Γ₁≼Γ₂ x)
weaken Γ₁≼Γ₂ (app s t) = app (weaken Γ₁≼Γ₂ s) (weaken Γ₁≼Γ₂ t)
weaken Γ₁≼Γ₂ (abs {σ} t) = abs (weaken (keep σ • Γ₁≼Γ₂) t)

data Val : Type → Set
open import Base.Denotation.Environment Type Val public
open import Base.Data.DependentList public

data Val where
  closure : ∀ {Γ σ τ} → (t : Term (σ • Γ) τ) → (ρ : ⟦ Γ ⟧Context) → Val (σ ⇒ τ)
  intV : ∀ (n : ℕ) → Val nat

import Base.Denotation.Environment
-- Den stands for Denotational semantics.
module Den = Base.Denotation.Environment Type ⟦_⟧Type

--
-- Functional big-step semantics
--

-- Termination is far from obvious to Agda once we use closures. So we use
-- step-indexing with a fuel value.

-- WARNING: ISAC's big-step semantics produces a step count as "output". But
-- that would not help Agda establish termination. That's only a problem for a
-- functional big-step semantics, not for a relational semantics.
--
-- So, instead, I tried to use a sort of writer monad: the interpreter gets fuel
-- and returns the remaining fuel. That's the same trick as in "functional
-- big-step semantics". That *makes* the function terminating, even though Agda
-- cannot see this because it does not know that the returned fuel is no bigger.

-- Since we focus for now on STLC, unlike that
-- paper, we could avoid error values because we keep types.
--
-- One could drop types and add error values instead.

data ErrVal (τ : Type) : Set where
  Done : (v : Val τ) → (n1 : ℕ) → ErrVal τ
  Error : ErrVal τ
  TimeOut : ErrVal τ

Res : Type → Set
Res τ = (n : ℕ) → ErrVal τ

_>>=_ : ∀ {σ τ} → Res σ → (Val σ → Res τ) → Res τ
(s >>= t) n0 with s n0
... | Done v n1 = t v n1
... | Error = Error
... | TimeOut = TimeOut

evalConst : ∀ {τ} → Const τ → Res τ
evalConst (lit v) n = Done (intV v) n

{-# TERMINATING #-}
eval : ∀ {Γ τ} → Term Γ τ → ⟦ Γ ⟧Context → Res τ

apply : ∀ {σ τ} → Val (σ ⇒ τ) → Val σ → Res τ
apply (closure t ρ) a n = eval t (a • ρ) n

eval (var x) ρ n = Done (⟦ x ⟧Var ρ) n
eval (abs t) ρ n = Done (closure t ρ) n
eval (const c) ρ n = evalConst c n
eval _ ρ zero = TimeOut
eval (app s t) ρ (suc n) = (eval s ρ >>= (λ sv → eval t ρ >>= λ tv → apply sv tv)) n

eval-const-dec : ∀ {τ} → (c : Const τ) → ∀ {v} n0 n1 → evalConst c n0 ≡ Done v n1 →  n1 ≤ n0
eval-const-dec (lit v) n0 .n0 refl = ≤-refl

{-# TERMINATING #-}
eval-dec : ∀ {Γ τ} → (t : Term Γ τ) → ∀ ρ v n0 n1 → eval t ρ n0 ≡ Done v n1 → n1 ≤ n0
eval-dec (const c) ρ v n0 n1 eq = eval-const-dec c n0 n1 eq
eval-dec (var x) ρ .(⟦ x ⟧Var ρ) n0 .n0 refl = ≤-refl
eval-dec (abs t) ρ .(closure t ρ) n0 .n0 refl = ≤-refl
eval-dec (app s t) ρ v zero n1 ()
eval-dec (app s t) ρ v (suc n0) n3 eq  with eval s ρ n0 | inspect (eval s ρ) n0
eval-dec (app s t) ρ v (suc n0) n3 eq | Done sv sn1 | [ seq ] with eval t ρ sn1 | inspect (eval t ρ) sn1
eval-dec (app s t) ρ v (suc n0) n3 eq | Done sv@(closure st sρ) sn1 | [ seq ] | (Done tv tn2) | [ teq ] = ≤-step (≤-trans (≤-trans (eval-dec st _ _ _ _ eq) (eval-dec t _ _ _ _ teq)) (eval-dec s _ _ _ _ seq))
eval-dec (app s t) ρ v (suc n0) n3 () | Done sv sn1 | [ seq ] | Error | [ teq ]
eval-dec (app s t) ρ v (suc n0) n3 () | Done sv sn1 | [ seq ] | TimeOut | [ teq ]
eval-dec (app s t) ρ v (suc n0) n3 () | Error | [ seq ]
eval-dec (app s t) ρ v (suc n0) n3 () | TimeOut | [ seq ]

eval-const-mono : ∀ {τ} → (c : Const τ) → ∀ {v} n0 n1 → evalConst c n0 ≡ Done v n1 → evalConst c (suc n0) ≡ Done v (suc n1)
eval-const-mono (lit v) n0 .n0 refl = refl

-- ARGH
{-# TERMINATING #-}
eval-mono : ∀ {Γ τ} → (t : Term Γ τ) → ∀ ρ v n0 n1 → eval t ρ n0 ≡ Done v n1 → eval t ρ (suc n0) ≡ Done v (suc n1)
eval-mono (const c) ρ v n0 n1 eq = eval-const-mono c n0 n1 eq
eval-mono (var x) ρ .(⟦ x ⟧Var ρ) n0 .n0 refl = refl
eval-mono (abs t) ρ .(closure t ρ) n0 .n0 refl = refl
eval-mono (app s t) ρ v zero n1 ()
eval-mono (app s t) ρ v (suc n0) n1 eq with eval s ρ n0 | inspect (eval s ρ) n0
eval-mono (app s t) ρ v (suc n0) n2 eq | Done sv n1 | [ seq ] with eval s ρ (suc n0) | eval-mono s ρ sv n0 n1 seq
eval-mono (app s t) ρ v (suc n0) n2 eq | Done sv n1 | [ seq ] | .(Done sv (suc n1)) | refl with eval t ρ n1 | inspect (eval t ρ) n1
eval-mono (app s t) ρ v (suc n0) n3 eq | Done sv n1 | [ seq ] | .(Done sv (suc n1)) | refl | Done tv n2 | [ teq ] with eval t ρ (suc n1) | eval-mono t ρ tv n1 n2 teq
eval-mono (app s t) ρ v (suc n0) n3 eq | Done (closure t₁ ρ₁) n1 | [ seq ] | .(Done (closure {Γ = _} {σ = _} {τ = _} t₁ ρ₁) (suc n1)) | refl | (Done tv n2) | [ teq ] | .(Done tv (suc n2)) | refl = eval-mono t₁ (tv • ρ₁) v n2 n3 eq
eval-mono (app s t) ρ v (suc n0) n2 () | Done sv n1 | [ seq ] | .(Done sv (suc n1)) | refl | Error | [ teq ]
eval-mono (app s t) ρ v (suc n0) n2 () | Done sv n1 | [ seq ] | .(Done sv (suc n1)) | refl | TimeOut | [ teq ]
eval-mono (app s t) ρ v (suc n0) n1 () | Error | [ seq ]
eval-mono (app s t) ρ v (suc n0) n1 () | TimeOut | [ seq ]

eval-adjust-plus : ∀ d {Γ τ} → (t : Term Γ τ) → ∀ ρ v n0 n1 → eval t ρ n0 ≡ Done v n1 → eval t ρ (d + n0) ≡ Done v (d + n1)
eval-adjust-plus zero t ρ v n0 n1 eq = eq
eval-adjust-plus (suc d) t ρ v n0 n1 eq = eval-mono t ρ v (d + n0) (d + n1) (eval-adjust-plus d t ρ v n0 n1 eq)

eval-const-strengthen : ∀ {τ} → (c : Const τ) → ∀ {v} n0 n1 → evalConst c (suc n0) ≡ Done v (suc n1) → evalConst c n0 ≡ Done v n1
eval-const-strengthen (lit v) n0 .n0 refl = refl

-- I started trying to prove eval-strengthen, which I appeal to informally
-- below, but I gave up. I still guess the lemma is true but proving it looks
-- too painful to bother.

-- Without this lemma, I can't fully prove that this logical relation is
-- equivalent to the original one.
-- But this one works (well, at least up to the fundamental theorem, haven't
-- attempted other lemmas), so it should be good enough.

-- eval-mono-err : ∀ {Γ τ} → (t : Term Γ τ) → ∀ ρ n → eval t ρ n ≡ Error → eval t ρ (suc n) ≡ Error
-- eval-mono-err (const (lit x)) ρ zero eq = {!!}
-- eval-mono-err (const (lit x)) ρ (suc n) eq = {!!}
-- eval-mono-err (var x) ρ n eq = {!!}
-- eval-mono-err (app t t₁) ρ n eq = {!!}
-- eval-mono-err (abs t) ρ n eq = {!!}

-- -- eval t ρ (suc n0) ≡ Done v (suc n1) → eval t ρ n0 ≡ Done v n
-- eval-aux : ∀ {Γ τ} → (t : Term Γ τ) → ∀ ρ n → (Σ[ res0 ∈ ErrVal τ ] eval t ρ n ≡ res0) × (Σ[ resS ∈ ErrVal τ ] eval t ρ n ≡ resS)
-- eval-aux t ρ n with
--   eval t ρ n | inspect (eval t ρ) n |
--   eval t ρ (suc n) | inspect (eval t ρ) (suc n)
-- eval-aux t ρ n | res0 | [ eq0 ] | (Done v1 n1) | [ eq1 ] = {!!}
-- eval-aux t ρ n | res0 | [ eq0 ] | Error | [ eq1 ] = {!!}
-- eval-aux t ρ n | Done v n1 | [ eq0 ] | TimeOut | [ eq1 ] = {!!}
-- eval-aux t ρ n | Error | [ eq0 ] | TimeOut | [ eq1 ] = {!!}
-- eval-aux t ρ n | TimeOut | [ eq0 ] | TimeOut | [ eq1 ] = (TimeOut , refl) , (TimeOut , refl)

-- {-# TERMINATING #-}
-- eval-strengthen : ∀ {Γ τ} → (t : Term Γ τ) → ∀ ρ v n0 n1 → eval t ρ (suc n0) ≡ Done v (suc n1) → eval t ρ n0 ≡ Done v n1
-- eval-strengthen (const c) ρ v n0 n1 eq = eval-const-strengthen c n0 n1 eq
-- eval-strengthen (var x) ρ .(⟦ x ⟧Var ρ) n0 .n0 refl = refl
-- eval-strengthen (abs t) ρ .(closure t ρ) n0 .n0 refl = refl
-- eval-strengthen (app s t) ρ v zero n1 eq with eval s ρ 0 | inspect (eval s ρ) 0
-- eval-strengthen (app s t) ρ v zero n1 eq | Done sv sn1 | [ seq ] with eval-dec s ρ sv 0 sn1 seq
-- eval-strengthen (app s t) ρ v zero n1 eq | Done sv .0 | [ seq ] | z≤n with eval t ρ 0 | inspect (eval t ρ) 0
-- eval-strengthen (app s t) ρ v zero n1 eq | Done sv _ | [ seq ] | z≤n | Done tv tn1 | [ teq ]  with eval-dec t ρ tv 0 tn1 teq
-- eval-strengthen (app s t) ρ v zero n1 eq | Done (closure st sρ) _ | [ seq ] | z≤n | (Done tv .0) | [ teq ] | z≤n with eval-dec st _ v 0 (suc n1) eq
-- eval-strengthen (app s t) ρ v zero n1 eq | Done (closure st sρ) _ | [ seq ] | z≤n | (Done tv _) | [ teq ] | z≤n | ()
-- eval-strengthen (app s t) ρ v zero n1 () | Done sv _ | [ seq ] | z≤n | Error | [ teq ]
-- eval-strengthen (app s t) ρ v zero n1 () | Done sv _ | [ seq ] | z≤n | TimeOut | [ teq ]
-- eval-strengthen (app s t) ρ v zero n1 () | Error | [ seq ]
-- eval-strengthen (app s t) ρ v zero n1 () | TimeOut | [ seq ]
-- -- eval-dec s ρ
-- --  {!eval-dec s ρ ? (suc zero) (suc n1) !}
-- -- eval-strengthen (app s t) ρ v (suc n0) n1 eq with eval s ρ (suc n0) | inspect (eval s ρ) (suc n0)
-- -- eval-strengthen (app s t) ρ v₁ (suc n0) n2 eq | Done sv n1 | [ seq ] with eval s ρ n0 = {!eval-strengthen s ρ v n0 n1 seq !}
-- -- eval-strengthen (app s t) ρ v (suc n0) n1 () | Error | [ seq ]
-- -- eval-strengthen (app s t) ρ v (suc n0) n1 () | TimeOut | [ seq ]
-- eval-strengthen (app s t) ρ v (suc n0) n1 eq with eval s ρ n0 | inspect (eval s ρ) n0
-- eval-strengthen (app s t) ρ v (suc n0) n2 eq | Done sv n1 | [ seq ] with eval s ρ (suc n0) | eval-mono s ρ sv n0 n1 seq
-- eval-strengthen (app s t) ρ v (suc n0) n2 eq | Done sv n1 | [ seq ] | .(Done sv (suc n1)) | refl with eval t ρ n1 | inspect (eval t ρ) n1
-- eval-strengthen (app s t) ρ v (suc n0) n3 eq | Done sv n1 | [ seq ] | .(Done sv (suc n1)) | refl | Done tv n2 | [ teq ] with eval t ρ (suc n1) | eval-mono t ρ tv n1 n2 teq
-- eval-strengthen (app s t) ρ v (suc n0) n3 eq | Done (closure t₁ ρ₁) n1 | [ seq ] | .(Done (closure {Γ = _} {σ = _} {τ = _} t₁ ρ₁) (suc n1)) | refl | (Done tv n2) | [ teq ] | .(Done tv (suc n2)) | refl = eval-strengthen t₁ (tv • ρ₁) v n2 n3 eq
-- eval-strengthen (app s t) ρ v (suc n0) n2 eq | Done sv n1 | [ seq ] | .(Done sv (suc n1)) | refl | Error | [ teq ] = {!!}
-- eval-strengthen (app s t) ρ v (suc n0) n2 eq | Done sv n1 | [ seq ] | .(Done sv (suc n1)) | refl | TimeOut | [ teq ] = {!!}
-- eval-strengthen (app s t) ρ v (suc n0) n1 eq | Error | [ seq ] = {!!}
-- eval-strengthen (app s t) ρ v (suc n0) n1 eq | TimeOut | [ seq ] = {!!}

-- eval-adjust-minus : ∀ d {Γ τ} → (t : Term Γ τ) → ∀ {ρ v} n0 n1 → eval t ρ (d + n0) ≡ Done v (d + n1) → eval t ρ n0 ≡ Done v n1
-- eval-adjust-minus zero t n0 n1 eq = eq
-- eval-adjust-minus (suc d) t n0 n1 eq = eval-adjust-minus d t n0 n1 (eval-strengthen t _ _ (d + n0) (d + n1) eq)

import Data.Integer as I
open I using (ℤ)
mutual
  -- Warning: compared to Ahmed's papers, this definition for relT also requires
  -- t1 to be well-typed, not just t2.
  --
  -- This difference might affect the status of some proofs in Ahmed's papers,
  -- but that's not a problem here.

  -- Also: can't confirm this in any of the papers I'm using, but I'd guess that
  -- all papers using environments allow to relate closures with different
  -- implementations and different hidden environments.
  --
  -- To check if the proof goes through with equal context, I changed the proof.
  -- Now a proof that two closures are equivalent contains a proof that their
  -- typing contexts are equivalent. The changes were limited softawre
  -- engineering, the same proofs go through.

  -- This is not the same definition of relT, but it is equivalent.
  relT : ∀ {τ Γ} (t1 : Term Γ τ) (t2 : Term Γ τ) (ρ1 : ⟦ Γ ⟧Context) (ρ2 : ⟦ Γ ⟧Context) → ℕ → Set
  -- This equation is a lemma in the original definition.
  relT t1 t2 ρ1 ρ2 zero = ⊤
  -- To compare this definition, note that the original k is suc n here.
  relT {τ} t1 t2 ρ1 ρ2 (suc n) =
    (v1 : Val τ) →
    -- Originally we have 0 ≤ j < k, so j < suc n, so k - j = suc n - j.
    -- It follows that 0 < k - j ≤ k, hence suc n - j ≤ suc n, or n - j ≤ n.
    -- Here, instead of binding j we bind n-j = n - j, require n - j ≤ n, and
    -- use suc n-j instead of k - j.
    ∀ n-j (n-j≤n : n-j ≤ n) →
    -- The next assumption is important. This still says that evaluation consumes j steps.
    -- Since j ≤ n, it is OK to start evaluation with n steps.
    -- Starting with (suc n) and getting suc n-j is equivalent, per eval-mono
    -- and eval-strengthen. But in practice this version is easier to use.
    (eq : eval t1 ρ1 n ≡ Done v1 n-j) →
    Σ[ v2 ∈ Val τ ] Σ[ n2 ∈ ℕ ] eval t2 ρ2 n2 ≡ Done v2 0 × relV τ v1 v2 (suc n-j)
    -- Here, computing t2 is allowed to take an unbounded number of steps. Having to write a number at all is annoying.

  relV : ∀ τ (v1 v2 : Val τ) → ℕ → Set
  -- Show the proof still goes through if we relate clearly different values by
  -- inserting changes in the relation.
  -- There's no syntax to produce such changes, but you can add changes to the
  -- environment.
  relV nat (intV v1) (intV v2) n = Σ[ dv ∈ ℤ ] dv I.+ (I.+ v1) ≡ (I.+ v2)
  relV (σ ⇒ τ) (closure {Γ1} t1 ρ1) (closure {Γ2} t2 ρ2) n =
    Σ (Γ1 ≡ Γ2) λ { refl →
      ∀ (k : ℕ) (k≤n : k < n) v1 v2 →
      relV σ v1 v2 k →
      relT t1 t2 (v1 • ρ1) (v2 • ρ2) k
    }
  -- Above, in the conclusion, I'm not relating app (closure t1 ρ1) v1 with app
  -- (closure t2 ρ2) v2 (or some encoding of that that actually works), but the
  -- result of taking a step from that configuration. That is important, because
  -- both Pitts' "Step-Indexed Biorthogonality: a Tutorial Example" and
  -- "Imperative Self-Adjusting Computation" do the same thing (and point out it's
  -- important).

Δτ : Type → Type
Δτ (σ ⇒ τ) = σ ⇒ (Δτ σ) ⇒ Δτ τ
Δτ nat = nat

mutual
  -- The original relation allows unrelated environments. However, while that is
  -- fine as a logical relation, it's not OK if we want to prove that validity
  -- agrees with oplus. We want a finer relation.
  -- Also: we still need to demand the actual environments to be related, and
  -- the bodies to match. Haven't done that yet. On the other hand, since we do want
  -- to allow for replacement changes, that would probably complicate the proof
  -- elsewhere.
  relT3 : ∀ {τ Γ ΔΓ} (t1 : Term Γ τ) (dt : Term ΔΓ (Δτ τ)) (t2 : Term Γ τ) (ρ1 : ⟦ Γ ⟧Context) (dρ : ⟦ ΔΓ ⟧Context) (ρ2 : ⟦ Γ ⟧Context) → ℕ → Set
  relT3 t1 dt t2 ρ1 dρ ρ2 zero = ⊤
  relT3 {τ} t1 dt t2 ρ1 dρ ρ2 (suc n) =
    (v1 : Val τ) →
    ∀ n-j (n-j≤n : n-j ≤ n) →
    (eq : eval t1 ρ1 n ≡ Done v1 n-j) →
    Σ[ v2 ∈ Val τ ] Σ[ n2 ∈ ℕ ] eval t2 ρ2 n2 ≡ Done v2 0 ×
    Σ[ dv ∈ Val (Δτ τ) ] Σ[ dn ∈ ℕ ] eval dt dρ dn ≡ Done dv 0 ×
    relV3 τ v1 dv v2 (suc n-j)

  -- Weakening in this definition is going to be annoying to use. And having to
  -- construct terms is ugly.
  -- Worse, evaluating the application consumes computation steps.

  -- Weakening could be avoided if we use a separate language of change terms
  -- with two environments, and with a dclosure binding two variables at once,
  -- and so on.
  relV3 : ∀ τ (v1 : Val τ) (dv : Val (Δτ τ)) (v2 : Val τ) → ℕ → Set
  relV3 nat (intV v1) (intV dv) (intV v2) n = dv + v1 ≡ v2
  relV3 (σ ⇒ τ) (closure {Γ1} t1 ρ1) (closure dt dρ) (closure {Γ2} t2 ρ2) n =
    Σ (Γ1 ≡ Γ2) λ { refl →
      ∀ (k : ℕ) (k<n : k < n) v1 dv v2 →
      relV3 σ v1 dv v2 k →
      relT3 t1 (app (weaken (drop (Δτ σ) • ≼-refl) dt) (var this)) t2 (v1 • ρ1) (dv • v1 • dρ) (v2 • ρ2) k
    }

  -- Relate λ x → 0 and λ x → 1 at any step count.
  example1 : ∀ n → relV (nat ⇒ nat) (closure (const (lit 0)) ∅) (closure (const (lit 1)) ∅) n
  example1 n = refl ,
    λ { zero k<n v1 v2 x → tt
      ; (suc k) k<n v1 v2 x .(intV 0) .k n-j≤n refl → intV 1 , 0 , refl , (I.+ 1 , refl)
      }

  -- Relate λ x → 0 and λ x → x at any step count.
  example2 : ∀ n → relV (nat ⇒ nat) (closure (const (lit 0)) ∅) (closure (var this) ∅) n
  example2 n = refl ,
    λ { zero k<n v1 v2 x → tt
      ; (suc k) k<n (intV v1) (intV v2) x .(intV 0) .k n-j≤n refl → intV v2 , 0 , refl , (I.+ v2 , cong I.+_ (+-identityʳ v2))
      }

relρ : ∀ Γ (ρ1 ρ2 : ⟦ Γ ⟧Context) → ℕ → Set
relρ ∅ ∅ ∅ n = ⊤
relρ (τ • Γ) (v1 • ρ1) (v2 • ρ2) n = relV τ v1 v2 n × relρ Γ ρ1 ρ2 n

relV-mono : ∀ m n → m ≤ n → ∀ τ v1 v2 → relV τ v1 v2 n → relV τ v1 v2 m
relV-mono m n m≤n nat (intV v1) (intV v2) vv = vv
relV-mono m n m≤n (σ ⇒ τ) (closure t1 ρ1) (closure t2 ρ2) (refl , ff) = refl , λ k k≤m → ff k (≤-trans k≤m m≤n)

relρ-mono : ∀ m n → m ≤ n → ∀ Γ ρ1 ρ2 → relρ Γ ρ1 ρ2 n → relρ Γ ρ1 ρ2 m
relρ-mono m n m≤n ∅ ∅ ∅ tt = tt
relρ-mono m n m≤n (τ • Γ) (v1 • ρ1) (v2 • ρ2) (vv , ρρ) = relV-mono m n m≤n _ v1 v2 vv , relρ-mono m n m≤n Γ ρ1 ρ2 ρρ

fundamentalV : ∀ {Γ τ} (x : Var Γ τ) → (n : ℕ) → (ρ1 ρ2 : ⟦ Γ ⟧Context) (ρρ : relρ Γ ρ1 ρ2 n) → relT (var x) (var x) ρ1 ρ2 n
fundamentalV x zero ρ1 ρ2 ρρ = tt
fundamentalV this (suc n) (v1 • ρ1) (v2 • ρ2) (vv , ρρ) .v1 .n n-j≤n refl = v2 , zero , refl , vv
fundamentalV (that x) (suc n) (v1 • ρ1) (v2 • ρ2) (vv , ρρ) = fundamentalV x (suc n) ρ1 ρ2 ρρ

lt1 : ∀ {k n} → k < n → k ≤ n
lt1 (s≤s p) = ≤-step p

fundamental : ∀ {Γ τ} (t : Term Γ τ) → (n : ℕ) → (ρ1 ρ2 : ⟦ Γ ⟧Context) (ρρ : relρ Γ ρ1 ρ2 n) → relT t t ρ1 ρ2 n
fundamental t zero ρ1 ρ2 ρρ = tt
fundamental (var x) (suc n) ρ1 ρ2 ρρ = fundamentalV x (suc n) ρ1 ρ2 ρρ
fundamental (const (lit v)) (suc n) ρ1 ρ2 ρρ .(intV v) .n n-j≤n refl = intV v , zero , refl , I.+ zero , refl
fundamental (abs t) (suc n) ρ1 ρ2 ρρ .(closure t ρ1) .n n-j≤n refl =  closure t ρ2 , zero , refl , refl , λ k k<n v1 v2 vv → fundamental t k (v1 • ρ1) (v2 • ρ2) (vv , relρ-mono k (suc n) (lt1 k<n) _ _ _ ρρ)
fundamental (app s t) (suc zero) ρ1 ρ2 ρρ v1 n-j n-j≤n ()
fundamental (app s t) (suc (suc n)) ρ1 ρ2 ρρ v1 n-j n-j≤n eq with eval s ρ1 n | inspect (eval s ρ1) n
fundamental (app s t) (suc (suc n)) ρ1 ρ2 ρρ v1 n-j n-j≤n eq | Done sv1 n1 | [ s1eq ] with eval-dec s _ _ n n1 s1eq | eval t ρ1 n1 | inspect (eval t ρ1) n1
fundamental (app s t) (suc (suc n)) ρ1 ρ2 ρρ v1 n-j n-j≤n eq | Done (closure st1 sρ1) n1 | [ s1eq ] | n1≤n | Done tv1 n2 | [ t1eq ] with eval-dec t _ _ n1 n2 t1eq
... | n2≤n1 with fundamental s (suc (suc n)) ρ1 ρ2 ρρ (closure st1 sρ1) (suc n1) (s≤s n1≤n) (eval-mono s ρ1 (closure st1 sρ1) n n1 s1eq)
  | fundamental t (suc (suc n1)) ρ1 ρ2 (relρ-mono (suc (suc n1)) (suc (suc n)) (s≤s (s≤s n1≤n)) _ _ _ ρρ) tv1 (suc n2) (s≤s n2≤n1) (eval-mono t ρ1 tv1 n1 n2 t1eq)
... | sv2@(closure st2 sρ2) , sn3 , s2eq , refl , svv | tv2 , tn3 , t2eq , tvv with svv (suc n2) (s≤s (s≤s n2≤n1)) tv1 tv2 (relV-mono (suc n2) (suc (suc n2)) (s≤s (n≤1+n n2)) _ tv1 tv2 tvv) v1 n-j (eval-dec st1 _ _ _ _ eq) eq
... | v2 , n3 , eq2 , vv = v2 , suc (sn3 + (tn3 + n3)) , comp , vv
  where
    s2eq-adj : eval s ρ2 (sn3 + (tn3 + n3)) ≡ Done (closure st2 sρ2) (tn3 + n3)
    s2eq-adj rewrite +-comm sn3 (tn3 + n3)| cong (Done (closure st2 sρ2)) (sym (+-identityʳ (tn3 + n3))) = eval-adjust-plus (tn3 + n3) s _ sv2 _ _ s2eq
    t2eq-adj : eval t ρ2 (tn3 + n3) ≡ Done tv2 n3
    t2eq-adj rewrite +-comm tn3 n3 | cong (Done tv2) (sym (+-identityʳ n3)) = eval-adjust-plus n3 t _ tv2 _ _ t2eq

    comp : (eval s ρ2 >>= (λ sv → eval t ρ2 >>= apply sv))
      (sn3 + (tn3 + n3))
      ≡ Done v2 0
    comp rewrite s2eq-adj | t2eq-adj = eq2

fundamental (app s t) (suc (suc n)) ρ1 ρ2 ρρ v1 n-j n-j≤n () | Done sv1 n1 | [ s1eq ] | n1≤n | Error | [ t1eq ]
fundamental (app s t) (suc (suc n)) ρ1 ρ2 ρρ v1 n-j n-j≤n () | Done sv1 n1 | [ s1eq ] | n1≤n | TimeOut | [ t1eq ]
fundamental (app s t) (suc (suc n)) ρ1 ρ2 ρρ v1 n-j n-j≤n () | Error | [ s1eq ]
fundamental (app s t) (suc (suc n)) ρ1 ρ2 ρρ v1 n-j n-j≤n () | TimeOut | [ s1eq ]


module Agda.Builtin.Float where

open import Agda.Builtin.Bool
open import Agda.Builtin.Nat
open import Agda.Builtin.Int
open import Agda.Builtin.String

postulate Float : Set
{-# BUILTIN FLOAT Float #-}

primitive
  primFloatEquality : Float → Float → Bool
  primFloatLess     : Float → Float → Bool
  primNatToFloat    : Nat → Float
  primFloatPlus     : Float → Float → Float
  primFloatMinus    : Float → Float → Float
  primFloatTimes    : Float → Float → Float
  primFloatDiv      : Float → Float → Float
  primFloatSqrt     : Float → Float
  primRound         : Float → Int
  primFloor         : Float → Int
  primCeiling       : Float → Int
  primExp           : Float → Float
  primLog           : Float → Float
  primSin           : Float → Float
  primShowFloat     : Float → String


module RAdjunctions where

open import Library
open import Categories
open import Functors

open Cat
open Fun

record RAdj {a b c d e f}{C : Cat {a}{b}}{D : Cat {c}{d}}
            (J : Fun C D)(E : Cat {e}{f}) : Set (a ⊔ b ⊔ c ⊔ d ⊔ e ⊔ f) where
  constructor radjunction
  field L        : Fun C E
        R        : Fun E D
        left     : {X : Obj C}{Y : Obj E} →
                    Hom E (OMap L X) Y → Hom D (OMap J X) (OMap R Y)
        right    : {X : Obj C}{Y : Obj E} →
                   Hom D (OMap J X) (OMap R Y) → Hom E (OMap L X) Y
        lawa     : {X : Obj C}{Y : Obj E}(f : Hom E (OMap L X) Y) →
                   right (left f) ≅ f
        lawb     : {X : Obj C}{Y : Obj E}(f : Hom D (OMap J X) (OMap R Y)) →
                    left (right f) ≅ f
        natleft  : {X X' : Obj C}{Y Y' : Obj E}
                   (f : Hom C X' X)(g : Hom E Y Y')
                   (h : Hom E (OMap L X) Y) →
                   comp D (HMap R g) (comp D (left h) (HMap J f))
                   ≅
                   left (comp E g (comp E h (HMap L f)))
        natright : {X X' : Obj C}{Y Y' : Obj E}
                   (f : Hom C X' X)(g : Hom E Y Y')
                   (h : Hom D (OMap J X) (OMap R Y)) →
                   right (comp D (HMap R g) (comp D h (HMap J f)))
                   ≅
                   comp E g (comp E (right h) (HMap L f))


-- Andreas, 2016-07-21
-- Test case to ensure postfix printing of projections.

{-# OPTIONS --postfix-projections #-}

open import Common.Product
open import Common.Equality

testProj : {A : Set}{B : A → Set}(y z : Σ A B) →
  let X : Σ A B
      X = _
  in X .proj₁ ≡ y .proj₁ → X .proj₂ ≡ z .proj₂
testProj y z = _ , _


open import Level using () renaming (_⊔_ to _⊔ˡ_)

open import Relation.Binary.Morphism.Structures using (IsRelHomomorphism)
open import Algebra.Bundles using (RawMonoid; RawGroup; RawRing)

open import Algebra.Morphism.Structures using (IsMonoidHomomorphism; IsMonoidMonomorphism)

module AKS.Algebra.Morphism.Structures where

module GroupMorphisms {c₁ c₂ ℓ₁ ℓ₂} (G₁ : RawGroup c₁ ℓ₁) (G₂ : RawGroup c₂ ℓ₂) where
  open RawGroup G₁ using () renaming (Carrier to C₁; _∙_ to _+₁_; _⁻¹ to -₁_; ε to ε₁; _≈_ to _≈₁_; rawMonoid to +₁-rawMonoid)
  open RawGroup G₂ using () renaming (Carrier to C₂; _∙_ to _+₂_; _⁻¹ to -₂_; ε to ε₂; _≈_ to _≈₂_; rawMonoid to +₂-rawMonoid)
  open import Algebra.Morphism.Definitions C₁ C₂ _≈₂_ using (Homomorphic₂; Homomorphic₁; Homomorphic₀)
  open import Function.Definitions _≈₁_ _≈₂_ using (Injective)

  record IsGroupHomomorphism (⟦_⟧ : C₁ → C₂) : Set (c₁ ⊔ˡ ℓ₁ ⊔ˡ ℓ₂) where
    field
      isRelHomomorphism : IsRelHomomorphism _≈₁_ _≈₂_ ⟦_⟧
      +-homo  : Homomorphic₂ ⟦_⟧ _+₁_ _+₂_
      -‿homo  : Homomorphic₁ ⟦_⟧ -₁_ -₂_
      ε-homo  : Homomorphic₀ ⟦_⟧ ε₁ ε₂

    open IsRelHomomorphism isRelHomomorphism public renaming (cong to ⟦⟧-cong)

    +-isMonoidHomomorphism : IsMonoidHomomorphism +₁-rawMonoid +₂-rawMonoid ⟦_⟧
    +-isMonoidHomomorphism = record
      { isMagmaHomomorphism = record
         { isRelHomomorphism = isRelHomomorphism
         ; homo = +-homo
         }
      ; ε-homo = ε-homo
      }

  record IsGroupMonomorphism (⟦_⟧ : C₁ → C₂) : Set (c₁ ⊔ˡ ℓ₁ ⊔ˡ ℓ₂) where
    field
      isGroupHomomorphism : IsGroupHomomorphism ⟦_⟧
      injective : Injective ⟦_⟧

    open IsGroupHomomorphism isGroupHomomorphism public

    +-isMonoidMonomorphism : IsMonoidMonomorphism +₁-rawMonoid +₂-rawMonoid ⟦_⟧
    +-isMonoidMonomorphism = record
      { isMonoidHomomorphism = +-isMonoidHomomorphism
      ; injective = injective
      }

open GroupMorphisms public

module RingMorphisms {c₁ c₂ ℓ₁ ℓ₂} (R₁ : RawRing c₁ ℓ₁) (R₂ : RawRing c₂ ℓ₂) where
  open RawRing R₁ using () renaming (Carrier to C₁; _+_ to _+₁_; _*_ to _*₁_; -_ to -₁_; 0# to 0#₁; 1# to 1#₁; _≈_ to _≈₁_)
  open RawRing R₂ using () renaming (Carrier to C₂; _+_ to _+₂_; _*_ to _*₂_; -_ to -₂_; 0# to 0#₂; 1# to 1#₂; _≈_ to _≈₂_)
  open import Algebra.Morphism.Definitions C₁ C₂ _≈₂_ using (Homomorphic₂; Homomorphic₁; Homomorphic₀)
  open import Function.Definitions _≈₁_ _≈₂_ using (Injective)

  +₁-rawGroup : RawGroup c₁ ℓ₁
  +₁-rawGroup = record { Carrier = C₁ ; _≈_ = _≈₁_ ; _∙_ = _+₁_ ; _⁻¹ = -₁_ ; ε = 0#₁ }

  +₂-rawGroup : RawGroup c₂ ℓ₂
  +₂-rawGroup = record { Carrier = C₂ ; _≈_ = _≈₂_ ; _∙_ = _+₂_ ; _⁻¹ = -₂_ ; ε = 0#₂ }

  *₁-rawMonoid : RawMonoid c₁ ℓ₁
  *₁-rawMonoid = record { Carrier = C₁ ; _≈_ = _≈₁_ ; _∙_ = _*₁_ ; ε = 1#₁ }

  *₂-rawMonoid : RawMonoid c₂ ℓ₂
  *₂-rawMonoid = record { Carrier = C₂ ; _≈_ = _≈₂_ ; _∙_ = _*₂_ ; ε = 1#₂ }

  record IsRingHomomorphism (⟦_⟧ : C₁ → C₂) : Set (c₁ ⊔ˡ ℓ₁ ⊔ˡ ℓ₂) where
    field
      isRelHomomorphism : IsRelHomomorphism _≈₁_ _≈₂_ ⟦_⟧
      +-homo  : Homomorphic₂ ⟦_⟧ _+₁_ _+₂_
      *-homo  : Homomorphic₂ ⟦_⟧ _*₁_ _*₂_
      -‿homo  : Homomorphic₁ ⟦_⟧ -₁_ -₂_
      0#-homo : Homomorphic₀ ⟦_⟧ 0#₁ 0#₂
      1#-homo : Homomorphic₀ ⟦_⟧ 1#₁ 1#₂

    open IsRelHomomorphism isRelHomomorphism public renaming (cong to ⟦⟧-cong)

    +-isGroupHomomorphism : IsGroupHomomorphism +₁-rawGroup +₂-rawGroup ⟦_⟧
    +-isGroupHomomorphism = record
      { isRelHomomorphism = isRelHomomorphism
      ; +-homo = +-homo
      ; -‿homo = -‿homo
      ; ε-homo = 0#-homo
      }

    *-isMonoidHomomorphism : IsMonoidHomomorphism *₁-rawMonoid *₂-rawMonoid ⟦_⟧
    *-isMonoidHomomorphism = record
      { isMagmaHomomorphism = record
        { isRelHomomorphism = isRelHomomorphism
        ; homo = *-homo
        }
      ; ε-homo = 1#-homo
      }

  record IsRingMonomorphism (⟦_⟧ : C₁ → C₂) : Set (c₁ ⊔ˡ ℓ₁ ⊔ˡ ℓ₂) where
    field
      isRingHomomorphism : IsRingHomomorphism ⟦_⟧
      injective : Injective ⟦_⟧

    open IsRingHomomorphism isRingHomomorphism public

    +-isGroupMonomorphism : IsGroupMonomorphism +₁-rawGroup +₂-rawGroup ⟦_⟧
    +-isGroupMonomorphism = record
      { isGroupHomomorphism = +-isGroupHomomorphism
      ; injective = injective
      }

    *-isMonoidMonomorphism : IsMonoidMonomorphism *₁-rawMonoid *₂-rawMonoid ⟦_⟧
    *-isMonoidMonomorphism = record
      { isMonoidHomomorphism = *-isMonoidHomomorphism
      ; injective = injective
      }

open RingMorphisms public


------------------------------------------------------------------------
-- Products (variants for Set₁)
------------------------------------------------------------------------

-- I want universe polymorphism.

module Data.Product1 where

open import Data.Function
open import Relation.Nullary

infixr 4 _,_
infixr 2 _×₀₁_ _×₁₀_ _×₁₁_

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

data Σ₀₁ (a : Set) (b : a → Set₁) : Set₁ where
  _,_ : (x : a) (y : b x) → Σ₀₁ a b

data Σ₁₀ (a : Set₁) (b : a → Set) : Set₁ where
  _,_ : (x : a) (y : b x) → Σ₁₀ a b

data Σ₁₁ (a : Set₁) (b : a → Set₁) : Set₁ where
  _,_ : (x : a) (y : b x) → Σ₁₁ a b

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

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

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

_×₀₁_ : Set → Set₁ → Set₁
A ×₀₁ B = Σ₀₁ A (λ _ → B)

_×₁₀_ : Set₁ → Set → Set₁
A ×₁₀ B = Σ₁₀ A (λ _ → B)

_×₁₁_ : Set₁ → Set₁ → Set₁
A ×₁₁ B = Σ₁₁ A (λ _ → B)

------------------------------------------------------------------------
-- Functions

proj₀₁₁ : ∀ {a b} → Σ₀₁ a b → a
proj₀₁₁ (x , y) = x

proj₀₁₂ : ∀ {a b} → (p : Σ₀₁ a b) → b (proj₀₁₁ p)
proj₀₁₂ (x , y) = y

proj₁₀₁ : ∀ {a b} → Σ₁₀ a b → a
proj₁₀₁ (x , y) = x

proj₁₀₂ : ∀ {a b} → (p : Σ₁₀ a b) → b (proj₁₀₁ p)
proj₁₀₂ (x , y) = y

proj₁₁₁ : ∀ {a b} → Σ₁₁ a b → a
proj₁₁₁ (x , y) = x

proj₁₁₂ : ∀ {a b} → (p : Σ₁₁ a b) → b (proj₁₁₁ p)
proj₁₁₂ (x , y) = y

map₀₁ : ∀ {A B P Q} →
        (f : A → B) → (∀ {x} → P x → Q (f x)) →
        Σ₀₁ A P → Σ₀₁ B Q
map₀₁ f g p = (f (proj₀₁₁ p) , g (proj₀₁₂ p))

map₁₀ : ∀ {A B P Q} →
        (f : A → B) → (∀ {x} → P x → Q (f x)) →
        Σ₁₀ A P → Σ₁₀ B Q
map₁₀ f g p = (f (proj₁₀₁ p) , g (proj₁₀₂ p))

map₁₁ : ∀ {A B P Q} →
        (f : A → B) → (∀ {x} → P x → Q (f x)) →
        Σ₁₁ A P → Σ₁₁ B Q
map₁₁ f g p = (f (proj₁₁₁ p) , g (proj₁₁₂ p))


module Types where

import Level
open import Data.Unit as Unit renaming (tt to ∗)
open import Data.List as List
open import Data.Product
open import Categories.Category using (Category)
open import Function

open import Relation.Binary.PropositionalEquality as PE hiding ([_]; subst)
open import Relation.Binary using (module IsEquivalence; Setoid; module Setoid)
open ≡-Reasoning

open import Common.Context as Context
-- open import Categories.Object.BinaryCoproducts ctx-cat

-- Codes
mutual
  data TermCtxCode : Set where
    emptyC : TermCtxCode
    cCtxC : (γ : TermCtxCode) → TypeCode γ → TermCtxCode

  TyCtxCode : Set

  data TypeCode (δ : TyCtxCode) (γ : TermCtxCode) : Set where
    closeAppTyC : TypeCode δ γ

  data TyFormerCode (γ : TermCtxCode) : Set where
    univ : TyFormerCode γ
    abs : (A : TypeCode γ) → (TyFormerCode (cCtxC γ A)) → TyFormerCode γ

  TyCtxCode = Ctx (Σ TermCtxCode TyFormerCode)
  TyVarCode : TyCtxCode → {γ : TermCtxCode} → TyFormerCode γ → Set
  TyVarCode δ {γ} T = Var δ (γ , T)
  emptyTy : TyCtxCode
  emptyTy = []

  {-
  ctxTyFormer : (γ : TermCtxCode) → TyFormerCode γ → TyFormerCode emptyC
  ctxTyFormer = ?
  -}

  data AppTypeCode (δ : TyCtxCode) (γ : TermCtxCode) : Set where
    varC  : (T : TyFormerCode γ) → (x : TyVarCode δ T) → AppTypeCode δ γ
    appTyC : (T : TyFormerCode γ) → AppTypeCode δ γ T
    μC : (γ₁ : TermCtxCode) → (t : TypeCode (ctxTyFormer γ univ ∷ δ) γ₁)
         → AppTypeCode δ γ

  {- (T : TyFormerCode) → (A : TypeCode δ γ univ)
            → (B : TypeCode δ γ (cCtxC γ A T)) → (t : TermCode γ A)
            → Type Δ Γ (subst B t) -}
    {-
    -- Just one constructor/destructor for now
    μ    : (Γ Γ₁ : TermCtx) → (t : Type (ctxTyFormer Γ univ ∷ Δ) Γ₁ univ)
         → Type Δ Γ (ctxTyFormer Γ univ)
    ν    : (Γ Γ₁ : TermCtx) → (t : Type (ctxTyFormer Γ univ ∷ Δ) Γ₁ univ)
         → Type Δ Γ (ctxTyFormer Γ univ)
  -}
{-

mutual
  data TermCtx : Set where
    empty : TermCtx
    cCtx : (Γ : TermCtx) → TypeCode Γ → TermCtx

  data TypeCode (Γ : TermCtx) : Set where
    appTy : TypeCode Γ

  Type : (Γ : TermCtx) → TypeCode Γ → Set

  data Term : (Γ : TermCtx) → TypeCode Γ → Set where

  data TyFormer (Γ : TermCtx) : Set where
    univ : TyFormer Γ
    abs : (A : TypeCode Γ) → (TyFormer (cCtx Γ A)) → TyFormer Γ

  subst : {Γ : TermCtx} → {A : TypeCode Γ}
          → TyFormer (cCtx Γ A) → Term Γ A → TyFormer Γ

  subst = {!!}

  Type Γ appTy = Σ (TypeCode Γ) (λ A →
                 Σ (AppType emptyTy Γ (abs A univ)) (λ B →
                 Term Γ A))

  ctxTyFormer : (Γ : TermCtx) → TyFormer Γ → TyFormer
  ctxTyFormer empty T = T
  ctxTyFormer (cCtx Γ A) T = ctxTyFormer Γ (abs Γ A)

  TyCtx : Set
  TyCtx = Ctx (Σ TermCtx TyFormer)
  TyVar : TyCtx → {Γ : TermCtx} → TyFormer Γ → Set
  TyVar Δ {Γ} T = Var Δ (Γ , T)
  emptyTy : TyCtx
  emptyTy = []

  -- | Type syntax
  data AppType (Δ : TyCtx) : (Γ : TermCtx) → TyFormer Γ → Set where
    var  : (Γ : TermCtx) → (T : TyFormer Γ) → (x : TyVar Δ T) → AppType Δ Γ T
    appTy : (Γ : TermCtx) → (T : TyFormer) → (A : Type Δ Γ univ)
            → (B : Type Δ Γ (cCtx Γ A T)) → (t : Term Γ)
            → Type Δ Γ (subst B t)
    -- Just one constructor/destructor for now
    μ    : (Γ Γ₁ : TermCtx) → (t : Type (ctxTyFormer Γ univ ∷ Δ) Γ₁ univ)
         → Type Δ Γ (ctxTyFormer Γ univ)
    ν    : (Γ Γ₁ : TermCtx) → (t : Type (ctxTyFormer Γ univ ∷ Δ) Γ₁ univ)
         → Type Δ Γ (ctxTyFormer Γ univ)
-}

{-
succ' : ∀{Δ} (x : TyVar Δ) → TyVar (∗ ∷ Δ)
succ' = Context.succ ∗
-}

{-
-- | Congruence for types
data _≅T_  {Γ Γ' : Ctx} : Type Γ → Type Γ' → Set where
  unit : unit ≅T unit
  var  : ∀{x : TyVar Γ} {x' : TyVar Γ'} → (x ≅V x') → var x ≅T var x'
  _⊕_  : ∀{t₁ t₂ : Type Γ} {t₁' t₂' : Type Γ'} →
         (t₁ ≅T t₁') → (t₂ ≅T t₂') →
         (t₁ ⊕ t₂) ≅T (t₁' ⊕ t₂')
  _⊗_  : ∀{t₁ t₂ : Type Γ} {t₁' t₂' : Type Γ'} →
         (t₁ ≅T t₁') → (t₂ ≅T t₂') →
         (t₁ ⊗ t₂) ≅T (t₁' ⊗ t₂')
  μ    : ∀{t : Type (∗ ∷ Γ)} {t' : Type (∗ ∷ Γ')} →
         (t ≅T t') →
         (μ t) ≅T (μ t')
  _⇒_  : ∀{t₁ t₁' : Type []} {t₂ : Type Γ} {t₂' : Type Γ'} →
         (t₁ ≅T t₁') → (t₂ ≅T t₂') →
         (t₁ ⇒ t₂) ≅T (t₁' ⇒ t₂')
  ν    : ∀{t : Type (∗ ∷ Γ)} {t' : Type (∗ ∷ Γ')} →
         (t ≅T t') →
         (ν t) ≅T (ν t')

Trefl : ∀ {Γ : Ctx} {t : Type Γ} → t ≅T t
Trefl {t = unit}    = unit
Trefl {t = var x}   = var e.refl
  where
    module s = Setoid
    module e = IsEquivalence (s.isEquivalence ≅V-setoid)
Trefl {t = t₁ ⊕ t₂} = Trefl ⊕ Trefl
Trefl {t = μ t}     = μ Trefl
Trefl {t = t ⊗ t₁}  = Trefl ⊗ Trefl
Trefl {t = t ⇒ t₁}  = Trefl ⇒ Trefl
Trefl {t = ν t}     = ν Trefl

Tsym : ∀ {Γ Γ' : Ctx} {t : Type Γ} {t' : Type Γ'} → t ≅T t' → t' ≅T t
Tsym unit      = unit
Tsym (var u)   = var (Vsym u)
Tsym (u₁ ⊕ u₂) = Tsym u₁ ⊕ Tsym u₂
Tsym (u₁ ⊗ u₂) = Tsym u₁ ⊗ Tsym u₂
Tsym (μ u)     = μ (Tsym u)
Tsym (u₁ ⇒ u₂) = Tsym u₁ ⇒ Tsym u₂
Tsym (ν u)     = ν (Tsym u)

Ttrans : ∀ {Γ₁ Γ₂ Γ₃ : Ctx} {t₁ : Type Γ₁} {t₂ : Type Γ₂} {t₃ : Type Γ₃} →
         t₁ ≅T t₂ → t₂ ≅T t₃ → t₁ ≅T t₃
Ttrans unit unit           = unit
Ttrans (var u₁) (var u₂)   = var (Vtrans u₁ u₂)
Ttrans (u₁ ⊕ u₂) (u₃ ⊕ u₄) = Ttrans u₁ u₃ ⊕ Ttrans u₂ u₄
Ttrans (u₁ ⊗ u₂) (u₃ ⊗ u₄) = Ttrans u₁ u₃ ⊗ Ttrans u₂ u₄
Ttrans (μ u₁) (μ u₂)       = μ (Ttrans u₁ u₂)
Ttrans (u₁ ⇒ u₂) (u₃ ⇒ u₄) = Ttrans u₁ u₃ ⇒ Ttrans u₂ u₄
Ttrans (ν u₁) (ν u₂)       = ν (Ttrans u₁ u₂)

≡→≅T : ∀ {Γ : Ctx} {t₁ t₂ : Type Γ} →
       t₁ ≡ t₂ → t₁ ≅T t₂
≡→≅T {Γ} {t₁} {.t₁} refl = Trefl

-- Note: makes the equality homogeneous in Γ
≅T-setoid : ∀ {Γ} → Setoid _ _
≅T-setoid {Γ} = record
  { Carrier = Type Γ
  ; _≈_ = _≅T_
  ; isEquivalence = record
    { refl = Trefl ; sym = Tsym ; trans = Ttrans }
  }

-- | Ground type
GType = Type []
unit′ : GType
unit′ = unit

-- | Variable renaming in types
rename : {Γ Δ : TyCtx} → (ρ : Γ ▹ Δ) → Type Γ → Type Δ
rename         ρ unit      = unit
rename         ρ (var x)   = var (ρ ∗ x)
rename         ρ (t₁ ⊕ t₂) = rename ρ t₁ ⊕ rename ρ t₂
rename {Γ} {Δ} ρ (μ t)     = μ (rename ρ' t)
  where
    ρ' : (∗ ∷ Γ) ▹ (∗ ∷ Δ)
    ρ' = ctx-id {[ ∗ ]} ⧻ ρ
rename         ρ (t₁ ⊗ t₂) = rename ρ t₁ ⊗ rename ρ t₂
rename         ρ (t₁ ⇒ t₂) = t₁ ⇒ rename ρ t₂
rename {Γ} {Δ} ρ (ν t)     = ν (rename ρ' t)
  where
    ρ' : (∗ ∷ Γ) ▹ (∗ ∷ Δ)
    ρ' = ctx-id {[ ∗ ]} ⧻ ρ

-------------------------
---- Generating structure on contexts (derived from renaming)

weaken : {Γ : TyCtx} (Δ : TyCtx) → Type Γ -> Type (Δ ∐ Γ)
weaken {Γ} Δ = rename {Γ} {Δ ∐ Γ} (i₂ {Δ} {Γ})

exchange : (Γ Δ : TyCtx) → Type (Γ ∐ Δ) -> Type (Δ ∐ Γ)
exchange Γ Δ = rename [ i₂ {Δ} {Γ} , i₁ {Δ} {Γ} ]

contract : {Γ : TyCtx} → Type (Γ ∐ Γ) -> Type Γ
contract = rename [ ctx-id , ctx-id ]

-- weaken-id-empty-ctx : (Δ : TyCtx) (t : GType) → weaken {[]} Δ t ≡ t
-- weaken-id-empty-ctx = ?

Subst : TyCtx → TyCtx → Set
Subst Γ Δ = TyVar Γ → Type Δ

id-subst : ∀{Γ : TyCtx} → Subst Γ Γ
id-subst x = var x

update : ∀{Γ Δ : TyCtx} → Subst Γ Δ → Type Δ → (Subst (∗ ∷ Γ) Δ)
update σ a zero        = a
update σ _ (succ′ _ x) = σ x

single-subst : ∀{Γ : TyCtx} → Type Γ → (Subst (∗ ∷ Γ) Γ)
single-subst a zero        = a
single-subst _ (succ′ _ x) = var x

lift : ∀{Γ Δ} → Subst Γ Δ → Subst (∗ ∷ Γ) (∗ ∷ Δ)
lift σ = update (weaken [ ∗ ] ∘ σ) (var zero)

-- | Simultaneous substitution
subst : {Γ Δ : TyCtx} → (σ : Subst Γ Δ) → Type Γ → Type Δ
subst         σ unit      = unit
subst         σ (var x)   = σ x
subst         σ (t₁ ⊕ t₂) = subst σ t₁ ⊕ subst σ t₂
subst {Γ} {Δ} σ (μ t)     = μ (subst (lift σ) t)
subst         σ (t₁ ⊗ t₂) = subst σ t₁ ⊗ subst σ t₂
subst         σ (t₁ ⇒ t₂) = t₁ ⇒ subst σ t₂
subst {Γ} {Δ} σ (ν t)     = ν (subst (lift σ) t)

subst₀ : {Γ : TyCtx} → Type Γ → Type (∗ ∷ Γ) → Type Γ
subst₀ {Γ} a = subst (update id-subst a)

rename′ : {Γ Δ : TyCtx} → (ρ : Γ ▹ Δ) → Type Γ → Type Δ
rename′ ρ = subst (var ∘ (ρ ∗))

-- | Unfold lfp
unfold-μ : (Type [ ∗ ]) → GType
unfold-μ a = subst₀ (μ a) a

-- | Unfold gfp
unfold-ν : (Type [ ∗ ]) → GType
unfold-ν a = subst₀ (ν a) a

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

Nat : Type []
Nat = μ (unit ⊕ x)
  where x = var zero

Str-Fun : {Γ : TyCtx} → Type Γ → Type (∗ ∷ Γ)
Str-Fun a = (weaken [ ∗ ] a ⊗ x)
  where x = var zero

Str : {Γ : TyCtx} → Type Γ → Type Γ
Str a = ν (Str-Fun a)

lemma : ∀ {Γ : Ctx} {a b : Type Γ} {σ : Subst Γ Γ} →
        subst (update σ b) (weaken [ ∗ ] a) ≅T subst σ a
lemma {a = unit}    = unit
lemma {a = var x}   = Trefl
lemma {a = a₁ ⊕ a₂} = lemma {a = a₁} ⊕ lemma {a = a₂}
lemma {a = μ a}     = μ {!!}
lemma {a = a₁ ⊗ a₂} = lemma {a = a₁} ⊗ lemma {a = a₂}
lemma {a = a₁ ⇒ a₂} = Trefl ⇒ lemma {a = a₂}
lemma {a = ν a}     = ν {!!}

lift-id-is-id-ext : ∀ {Γ : Ctx} (x : TyVar (∗ ∷ Γ)) →
                    (lift (id-subst {Γ})) x ≡ id-subst x
lift-id-is-id-ext zero        = refl
lift-id-is-id-ext (succ′ ∗ x) = refl

lift-id-is-id : ∀ {Γ : Ctx} → lift (id-subst {Γ}) ≡ id-subst
lift-id-is-id = η-≡ lift-id-is-id-ext

id-subst-id : ∀ {Γ : Ctx} {a : Type Γ} →
              subst id-subst a ≅T a
id-subst-id {a = unit}   = unit
id-subst-id {a = var x}  = var Vrefl
id-subst-id {a = a ⊕ a₁} = id-subst-id ⊕ id-subst-id
id-subst-id {a = μ a}    =
  μ (Ttrans (≡→≅T (cong (λ u → subst u a) lift-id-is-id)) id-subst-id)
id-subst-id {a = a ⊗ a₁} = id-subst-id ⊗ id-subst-id
id-subst-id {a = a ⇒ a₁} = Trefl ⇒ id-subst-id
id-subst-id {a = ν a}    =
  ν (Ttrans (≡→≅T (cong (λ u → subst u a) lift-id-is-id)) id-subst-id)

lemma₂ : ∀ {Γ : Ctx} {a b : Type Γ} →
        subst (update id-subst b) (weaken [ ∗ ] a) ≅T a
lemma₂ {Γ} {a} {b} = Ttrans (lemma {Γ} {a} {b} {σ = id-subst}) id-subst-id

unfold-str : ∀{a : Type []} → (unfold-ν (Str-Fun a)) ≅T (a ⊗ Str a)
unfold-str {a} = lemma₂ ⊗ Trefl

LFair : {Γ : TyCtx} → Type Γ → Type Γ → Type Γ
LFair a b = ν (μ ((w a ⊗ x) ⊕ (w b ⊗ y)))
  where
    x = var zero
    y = var (succ zero)
    Δ = ∗ ∷ [ ∗ ]
    w = weaken Δ
-}


-- Andreas, 2015-08-27 Rewrite rules in parametrized modules are fine.
-- Jesper, 2015-10-14 Semantics of rewrite rules in parametrized modules has
--                    changed (see issue 1652)
-- Jesper, 2015-11-9  Rewrite rules in parametrized modules are now
--                    generalized to the top-context automatically

{-# OPTIONS --rewriting #-}

open import Common.Nat
open import Common.Equality

{-# BUILTIN REWRITE _≡_ #-}

module _ (y z : Nat) where

  assoc+ : ∀ x → (x + y) + z ≡ x + (y + z)
  assoc+ zero = refl
  assoc+ (suc x) rewrite assoc+ x = refl

  {-# REWRITE assoc+ #-}

test : ∀{x y} → (x + 0) + y ≡ x + y
test = refl


{-# OPTIONS --safe #-}
module Cubical.Data.Maybe.Base where

open import Cubical.Core.Everything

private
  variable
    ℓ ℓA ℓB : Level
    A : Type ℓA
    B : Type ℓB

data Maybe (A : Type ℓ) : Type ℓ where
  nothing : Maybe A
  just    : A → Maybe A

caseMaybe : (n j : B) → Maybe A → B
caseMaybe n _ nothing  = n
caseMaybe _ j (just _) = j

map-Maybe : (A → B) → Maybe A → Maybe B
map-Maybe _ nothing  = nothing
map-Maybe f (just x) = just (f x)

rec : B → (A → B) → Maybe A → B
rec n j nothing = n
rec n j (just a) = j a

elim : ∀ {A : Type ℓA} (B : Maybe A → Type ℓB) → B nothing → ((x : A) → B (just x)) → (mx : Maybe A) → B mx
elim B n j nothing = n
elim B n j (just a) = j a


module Luau.TypeNormalization where

open import Luau.Type using (Type; nil; number; string; boolean; never; unknown; _⇒_; _∪_; _∩_)

-- Operations on normalized types
_∪ᶠ_ : Type → Type → Type
_∪ⁿˢ_ : Type → Type → Type
_∩ⁿˢ_ : Type → Type → Type
_∪ⁿ_ : Type → Type → Type
_∩ⁿ_ : Type → Type → Type

-- Union of function types
(F₁ ∩ F₂) ∪ᶠ G = (F₁ ∪ᶠ G) ∩ (F₂ ∪ᶠ G)
F ∪ᶠ (G₁ ∩ G₂) = (F ∪ᶠ G₁) ∩ (F ∪ᶠ G₂)
(R ⇒ S) ∪ᶠ (T ⇒ U) = (R ∩ⁿ T) ⇒ (S ∪ⁿ U)
F ∪ᶠ G = F ∪ G

-- Union of normalized types
S ∪ⁿ (T₁ ∪ T₂) = (S ∪ⁿ T₁) ∪ T₂
S ∪ⁿ unknown = unknown
S ∪ⁿ never = S
never ∪ⁿ T = T
unknown ∪ⁿ T = unknown
(S₁ ∪ S₂) ∪ⁿ G = (S₁ ∪ⁿ G) ∪ S₂
F ∪ⁿ G = F ∪ᶠ G

-- Intersection of normalized types
S ∩ⁿ (T₁ ∪ T₂) = (S ∩ⁿ T₁) ∪ⁿˢ (S ∩ⁿˢ T₂)
S ∩ⁿ unknown = S
S ∩ⁿ never = never
(S₁ ∪ S₂) ∩ⁿ G = (S₁ ∩ⁿ G)
unknown ∩ⁿ G = G
never ∩ⁿ G = never
F ∩ⁿ G = F ∩ G

-- Intersection of normalized types with a scalar
(S₁ ∪ nil) ∩ⁿˢ nil = nil
(S₁ ∪ boolean) ∩ⁿˢ boolean = boolean
(S₁ ∪ number) ∩ⁿˢ number = number
(S₁ ∪ string) ∩ⁿˢ string = string
(S₁ ∪ S₂) ∩ⁿˢ T = S₁ ∩ⁿˢ T
unknown ∩ⁿˢ T = T
F ∩ⁿˢ T = never

-- Union of normalized types with an optional scalar
S ∪ⁿˢ never = S
unknown ∪ⁿˢ T = unknown
(S₁ ∪ nil) ∪ⁿˢ nil = S₁ ∪ nil
(S₁ ∪ boolean) ∪ⁿˢ boolean = S₁ ∪ boolean
(S₁ ∪ number) ∪ⁿˢ number = S₁ ∪ number
(S₁ ∪ string) ∪ⁿˢ string = S₁ ∪ string
(S₁ ∪ S₂) ∪ⁿˢ T = (S₁ ∪ⁿˢ T) ∪ S₂
F ∪ⁿˢ T = F ∪ T

-- Normalize!
normalize : Type → Type
normalize nil = never ∪ nil
normalize (S ⇒ T) = (normalize S ⇒ normalize T)
normalize never = never
normalize unknown = unknown
normalize boolean = never ∪ boolean
normalize number = never ∪ number
normalize string = never ∪ string
normalize (S ∪ T) = normalize S ∪ⁿ normalize T
normalize (S ∩ T) = normalize S ∩ⁿ normalize T


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

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Isomorphism
open import Cubical.Foundations.Equiv
open import Cubical.Foundations.Equiv.HalfAdjoint
open import Cubical.Foundations.HLevels
open import Cubical.Foundations.Univalence
open import Cubical.Foundations.SIP
open import Cubical.Foundations.Function using (_∘_; id)
open import Cubical.Foundations.GroupoidLaws
open import Cubical.Functions.Embedding
open import Cubical.Data.Sigma
open import Cubical.Data.Prod using (isPropProd)

open import Cubical.Algebra
open import Cubical.Algebra.Properties
open import Cubical.Algebra.Magma.Morphism

open import Cubical.Structures.Axioms
open import Cubical.Structures.Auto
open import Cubical.Structures.Record

open import Cubical.Relation.Binary.Reasoning.Equality

open Iso

private
  variable
    ℓ ℓ′ ℓ′′ : Level
    L : Magma ℓ
    M : Magma ℓ′
    N : Magma ℓ′′

isPropIsMagmaHom : ∀ (M : Magma ℓ) (N : Magma ℓ′) f → isProp (IsMagmaHom M N f)
isPropIsMagmaHom M N f = isPropHomomorphic₂ (Magma.is-set N) f (Magma._•_ M) (Magma._•_ N)

isSetMagmaHom : isSet (M ⟶ᴴ N)
isSetMagmaHom {M = M} {N = N} = isOfHLevelRespectEquiv 2 equiv
                                (isSetΣ (isSetΠ λ _ → is-set N)
                                        (λ f → isProp→isSet (isPropIsMagmaHom M N f)))
  where
    open Magma
    equiv : (Σ[ g ∈ (⟨ M ⟩ → ⟨ N ⟩) ] IsMagmaHom M N g) ≃ MagmaHom M N
    equiv = isoToEquiv (iso (λ (g , m) → magmahom g m)
                            (λ (magmahom g m) → g , m)
                            (λ _ → refl) λ _ → refl)

isMagmaHomComp : {f : ⟨ L ⟩ → ⟨ M ⟩} {g : ⟨ M ⟩ → ⟨ N ⟩} →
                  IsMagmaHom L M f → IsMagmaHom M N g → IsMagmaHom L N (g ∘ f)
isMagmaHomComp {g = g} fHom gHom _ _ = cong g (fHom _ _) ∙ gHom _ _

private
  isMagmaHomComp′ : (f : L ⟶ᴴ M) (g : M ⟶ᴴ N) →
                    IsMagmaHom L N (MagmaHom.fun g ∘ MagmaHom.fun f)
  isMagmaHomComp′ (magmahom f fHom) (magmahom g gHom) _ _ = cong g (fHom _ _) ∙ gHom _ _

compMagmaHom : (L ⟶ᴴ M) → (M ⟶ᴴ N) → (L ⟶ᴴ N)
compMagmaHom f g = magmahom _ (isMagmaHomComp′ f g)

compMagmaEquiv : L ≃ᴴ M → M ≃ᴴ N → L ≃ᴴ N
compMagmaEquiv f g = magmaequiv (compEquiv f.eq g.eq) (isMagmaHomComp′ f.hom g.hom)
  where
    module f = MagmaEquiv f
    module g = MagmaEquiv g

isMagmaHomId : (M : Magma ℓ) → IsMagmaHom M M id
isMagmaHomId M _ _ = refl

idMagmaHom : (M : Magma ℓ) → (M ⟶ᴴ M)
idMagmaHom M = record
  { fun   = id
  ; isHom = isMagmaHomId M
  }

idMagmaEquiv : (M : Magma ℓ) → M ≃ᴴ M
idMagmaEquiv M = record
  { eq    = idEquiv ⟨ M ⟩
  ; isHom = isMagmaHomId M
  }

-- Isomorphism inversion
isMagmaHomInv : (eqv : M ≃ᴴ N) → IsMagmaHom N M (invEq (MagmaEquiv.eq eqv))
isMagmaHomInv {M = M} {N = N} (magmaequiv eq isHom) x y = isInj-f _ _ (
  f (f⁻¹ (x •ᴺ y))       ≡⟨ retEq eq _ ⟩
  x •ᴺ y                 ≡˘⟨ cong₂ _•ᴺ_ (retEq eq x) (retEq eq y) ⟩
  f (f⁻¹ x) •ᴺ f (f⁻¹ y) ≡˘⟨ isHom (f⁻¹ x) (f⁻¹ y) ⟩
  f (f⁻¹ x •ᴹ f⁻¹ y)     ∎)
  where
    _•ᴹ_ = Magma._•_ M
    _•ᴺ_ = Magma._•_ N
    f = equivFun eq
    f⁻¹ = invEq eq
    isInj-f : (x y : ⟨ M ⟩) → f x ≡ f y → x ≡ y
    isInj-f x y = invEq (_ , isEquiv→isEmbedding (eq .snd) x y)

invMagmaHom : M ≃ᴴ N → (N ⟶ᴴ M)
invMagmaHom eq = record { isHom = isMagmaHomInv eq }

invMagmaEquiv : (M ≃ᴴ N) → (N ≃ᴴ M)
invMagmaEquiv eq = record
  { eq    = invEquiv (MagmaEquiv.eq eq)
  ; isHom = isMagmaHomInv eq
  }

magmaHomEq : {f g : M ⟶ᴴ N} → (MagmaHom.fun f ≡ MagmaHom.fun g) → f ≡ g
magmaHomEq {M = M} {N = N} {magmahom f fm} {magmahom g gm} p i = magmahom (p i) (p-hom i)
  where
    p-hom : PathP (λ i → IsMagmaHom M N (p i)) fm gm
    p-hom = toPathP (isPropIsMagmaHom M N _ _ _)

magmaEquivEq : {f g : M ≃ᴴ N} → (MagmaEquiv.eq f ≡ MagmaEquiv.eq g) → f ≡ g
magmaEquivEq {M = M} {N = N} {magmaequiv f fm} {magmaequiv g gm} p i = magmaequiv (p i) (p-hom i)
  where
    p-hom : PathP (λ i → IsMagmaHom M N (p i .fst)) fm gm
    p-hom = toPathP (isPropIsMagmaHom M N _ _ _)

module MagmaΣTheory {ℓ} where

  RawMagmaStructure : Type ℓ → Type ℓ
  RawMagmaStructure A = A → A → A

  RawMagmaEquivStr = AutoEquivStr RawMagmaStructure

  rawMagmaUnivalentStr : UnivalentStr _ RawMagmaEquivStr
  rawMagmaUnivalentStr = autoUnivalentStr RawMagmaStructure

  MagmaAxioms : (A : Type ℓ) → RawMagmaStructure A → Type ℓ
  MagmaAxioms A _•_ = isSet A

  MagmaStructure : Type ℓ → Type ℓ
  MagmaStructure = AxiomsStructure RawMagmaStructure MagmaAxioms

  MagmaΣ : Type (ℓ-suc ℓ)
  MagmaΣ = TypeWithStr ℓ MagmaStructure

  isPropMagmaAxioms : (A : Type ℓ) (_•_ : RawMagmaStructure A)
                      → isProp (MagmaAxioms A _•_)
  isPropMagmaAxioms _ _ = isPropIsSet

  MagmaEquivStr : StrEquiv MagmaStructure ℓ
  MagmaEquivStr = AxiomsEquivStr RawMagmaEquivStr MagmaAxioms

  MagmaAxiomsIsoIsMagma : {A : Type ℓ} (_•_ : RawMagmaStructure A)
                              → Iso (MagmaAxioms A _•_) (IsMagma A _•_)
  fun (MagmaAxiomsIsoIsMagma s) x           = ismagma x
  inv (MagmaAxiomsIsoIsMagma s) (ismagma x) = x
  rightInv (MagmaAxiomsIsoIsMagma s) _      = refl
  leftInv (MagmaAxiomsIsoIsMagma s) _       = refl

  MagmaAxioms≡IsMagma : {A : Type ℓ} (_•_ : RawMagmaStructure A)
                              → MagmaAxioms A _•_ ≡ IsMagma A _•_
  MagmaAxioms≡IsMagma s = isoToPath (MagmaAxiomsIsoIsMagma s)

  Magma→MagmaΣ : Magma ℓ → MagmaΣ
  Magma→MagmaΣ (mkmagma A _•_ isMagma) =
    A , _•_ , MagmaAxiomsIsoIsMagma _ .inv isMagma

  MagmaΣ→Magma : MagmaΣ → Magma ℓ
  MagmaΣ→Magma (A , _•_ , isMagma•) =
    mkmagma A _•_ (MagmaAxiomsIsoIsMagma _ .fun isMagma•)

  MagmaIsoMagmaΣ : Iso (Magma ℓ) MagmaΣ
  MagmaIsoMagmaΣ =
    iso Magma→MagmaΣ MagmaΣ→Magma (λ _ → refl) (λ _ → refl)

  magmaUnivalentStr : UnivalentStr MagmaStructure MagmaEquivStr
  magmaUnivalentStr = axiomsUnivalentStr _ isPropMagmaAxioms rawMagmaUnivalentStr

  MagmaΣPath : (M N : MagmaΣ) → (M ≃[ MagmaEquivStr ] N) ≃ (M ≡ N)
  MagmaΣPath = SIP magmaUnivalentStr

  MagmaEquivΣ : (M N : Magma ℓ) → Type ℓ
  MagmaEquivΣ M N = Magma→MagmaΣ M ≃[ MagmaEquivStr ] Magma→MagmaΣ N

  MagmaIsoΣPath : {M N : Magma ℓ} → Iso (MagmaEquiv M N) (MagmaEquivΣ M N)
  fun MagmaIsoΣPath (magmaequiv e h)   = (e , h)
  inv MagmaIsoΣPath (e , h)            = magmaequiv e h
  rightInv MagmaIsoΣPath _             = refl
  leftInv MagmaIsoΣPath _              = refl

  MagmaPath : (M N : Magma ℓ) → (MagmaEquiv M N) ≃ (M ≡ N)
  MagmaPath M N =
    MagmaEquiv M N                    ≃⟨ isoToEquiv MagmaIsoΣPath ⟩
    MagmaEquivΣ M N                   ≃⟨ MagmaΣPath _ _ ⟩
    Magma→MagmaΣ M ≡ Magma→MagmaΣ N   ≃⟨ isoToEquiv (invIso (congIso MagmaIsoMagmaΣ)) ⟩
    M ≡ N                             ■

  RawMagmaΣ : Type (ℓ-suc ℓ)
  RawMagmaΣ = TypeWithStr ℓ RawMagmaStructure

  Magma→RawMagmaΣ : Magma ℓ → RawMagmaΣ
  Magma→RawMagmaΣ M = (⟨ M ⟩ , Magma._•_ M)

  InducedMagma : (M : Magma ℓ) (N : RawMagmaΣ) (e : ⟨ M ⟩ ≃ ⟨ N ⟩)
                 → RawMagmaEquivStr (Magma→RawMagmaΣ M) N e → Magma ℓ
  InducedMagma M N e r =
    MagmaΣ→Magma (inducedStructure rawMagmaUnivalentStr (Magma→MagmaΣ M) N (e , r))

  InducedMagmaPath : (M : Magma ℓ) (N : RawMagmaΣ) (e : ⟨ M ⟩ ≃ ⟨ N ⟩)
                      (E : RawMagmaEquivStr (Magma→RawMagmaΣ M) N e)
                    → M ≡ InducedMagma M N e E
  InducedMagmaPath M N e E =
    MagmaPath M (InducedMagma M N e E) .fst (magmaequiv e E)

open MagmaΣTheory public using (InducedMagma; InducedMagmaPath)

MagmaPath : (M ≃ᴴ N) ≃ (M ≡ N)
MagmaPath = MagmaΣTheory.MagmaPath _ _

open Magma

uaMagma : M ≃ᴴ N → M ≡ N
uaMagma = equivFun MagmaPath

carac-uaMagma : {M N : Magma ℓ} (f : M ≃ᴴ N) → cong Carrier (uaMagma f) ≡ ua (MagmaEquiv.eq f)
carac-uaMagma (magmaequiv f m) =
  (refl ∙∙ ua f ∙∙ refl)
    ≡˘⟨ rUnit (ua f) ⟩
  ua f ∎

Magma≡ : (M N : Magma ℓ) → (
  Σ[ p ∈ ⟨ M ⟩ ≡ ⟨ N ⟩ ]
  Σ[ q ∈ PathP (λ i → p i → p i → p i) (_•_ M) (_•_ N) ]
  PathP (λ i → IsMagma (p i) (q i)) (isMagma M) (isMagma N))
  ≃ (M ≡ N)
Magma≡ M N = isoToEquiv (iso
  (λ (p , q , r) i → mkmagma (p i) (q i) (r i))
  (λ p → cong Carrier p , cong _•_ p , cong isMagma p)
  (λ _ → refl) (λ _ → refl))

caracMagma≡ : (p q : M ≡ N) → cong Carrier p ≡ cong Carrier q → p ≡ q
caracMagma≡ {M = M} {N = N} p q t = cong (Magma≡ M N .fst) (Σ≡Prop (λ _ →
    isPropΣ
    (isOfHLevelPathP' 1 (isSetΠ2 λ _ _ → is-set N) _ _) λ _ →
    isOfHLevelPathP 1 (λ { (ismagma x) (ismagma y) → cong ismagma (isPropIsSet x y) }) _ _)
  t)

uaMagmaId : (M : Magma ℓ) → uaMagma (idMagmaEquiv M) ≡ refl
uaMagmaId M = caracMagma≡ _ _ (carac-uaMagma (idMagmaEquiv M) ∙ uaIdEquiv)

uaCompMagmaEquiv : {L M N : Magma ℓ} (f : L ≃ᴴ M) (g : M ≃ᴴ N)
                    → uaMagma (compMagmaEquiv f g) ≡ uaMagma f ∙ uaMagma g
uaCompMagmaEquiv f g = caracMagma≡ _ _ (
  cong Carrier (uaMagma (compMagmaEquiv f g))
    ≡⟨ carac-uaMagma (compMagmaEquiv f g) ⟩
  ua (eq (compMagmaEquiv f g))
    ≡⟨ uaCompEquiv _ _ ⟩
  ua (eq f) ∙ ua (eq g)
    ≡⟨ cong (_∙ ua (eq g)) (sym (carac-uaMagma f)) ⟩
  cong Carrier (uaMagma f) ∙ ua (eq g)
    ≡⟨ cong (cong Carrier (uaMagma f) ∙_) (sym (carac-uaMagma g)) ⟩
  cong Carrier (uaMagma f) ∙ cong Carrier (uaMagma g)
    ≡⟨ sym (cong-∙ Carrier (uaMagma f) (uaMagma g)) ⟩
  cong Carrier (uaMagma f ∙ uaMagma g) ∎)
  where open MagmaEquiv


module Basic.EqvSemantics where

open import Data.Vec
open import Function
open import Data.Product
open import Data.Maybe

open import Utils.Decidable
open import Basic.AST
open import Basic.BigStep
open import Basic.SmallStep

{-

Equivalence of big step and small step semantics (Theorem 2.26 in the book).

The main difference from the book is the proof for the

  ⟨ S , s ⟩ k ⟶ s' → ⟨ S , s ⟩⟱ s'

direction. The book does case analysis directly on the transition the
"cons" case of the computation sequence, and then uses Lemma 2.19 (which
I named "seq-split" in the SmallStep module) to split the sequence into
two parts corresponding to the two parts of a composite statement.

The problem with this is that it relies on the usual well-ordering of natural
numbers, and it's not immediately structurally recursive. In other words, it relies
on the fact that the resulting parts of a split sequence are both shorter than the
original sequence.

However, the book omits the proof that no splitting ever produces computation
sequences of length zero. This is required for the recursion to be well-founded,
and in Agda we would indeed have to prove this too.

It's simpler to use "prepend". It essentially digs down to the leftmost "edge" of
a small-step transition, and composes it with a big-step derivation. It's evidently
structurally recursive and I find it a bit neater than the proof in the book.

-}

Small≡Big : ∀ {n}{S : St n}{s s'} → ⟨ S , s ⟩⟱ s' ⇔ ⟨ S , s ⟩⟶* s'
Small≡Big {n} = to , from ∘ proj₂
  where
  to : ∀ {S s s'} → ⟨ S , s ⟩⟱ s' → ⟨ S , s ⟩⟶* s'
  to ass                 = , ass stop
  to skip                = , skip stop
  to (A , B)             = , append (proj₂ $ to A) (proj₂ $ to B)
  to (if-true x p)       = , if-true x ∷ proj₂ (to p)
  to (if-false x p)      = , if-false x ∷ proj₂ (to p)
  to (while-true x p p₁) = , while ∷ if-true x ∷ append (proj₂ $ to p) (proj₂ $ to p₁)
  to (while-false x)     = , while ∷ if-false x ∷ skip stop

  mutual
    prepend :
      ∀ {s₁ s₂ s₃}{S₁ S₂ : St n}
      → ⟨ S₁ , s₁ ⟩⟶⟨ S₂ , s₂ ⟩
      → ⟨ S₂ , s₂ ⟩⟱ s₃
      → ⟨ S₁ , s₁ ⟩⟱ s₃
    prepend (p1 ◄) (p2 , p3)            = prepend p1 p2 , p3
    prepend (x ∙) p2                    = from (x stop) , p2
    prepend (if-true x) p2              = if-true x p2
    prepend (if-false x) p2             = if-false x p2
    prepend while (if-true x (p2 , p3)) = while-true x p2 p3
    prepend while (if-false x skip)     = while-false x

    from : ∀ {k S s s'} → ⟨ S , s ⟩ k ⟶ s' → ⟨ S , s ⟩⟱ s'
    from (ass stop)  = ass
    from (skip stop) = skip
    from (x ∷ p)     = prepend x (from p)


{-# OPTIONS --without-K --safe #-}
module Util.Prelude where

open import Data.Bool public using
  (Bool ; true ; false)
open import Data.Empty public using
  (⊥ ; ⊥-elim)
open import Data.Fin public using
  (Fin ; zero ; suc)
open import Data.List public using
  (List ; [] ; _∷_)
open import Data.Maybe public using
  (Maybe ; just ; nothing)
open import Data.Nat public using
  (ℕ ; zero ; suc)
open import Data.Product public using
  (Σ ; ∃ ; Σ-syntax ; ∃-syntax ; _×_ ; _,_ ; proj₁ ; proj₂)
open import Data.Sum public using
  (_⊎_ ; inj₁ ; inj₂)
open import Data.Unit public using
  (⊤)
open import Data.Vec public using
  (Vec ; [] ; _∷_)
open import Function public using
  (id ; _∘_ ; _∘′_ ; _$_ ; _on_)
open import Level public using
  (Level ; 0ℓ) renaming
  (zero to lzero ; suc to lsuc ; _⊔_ to _⊔ℓ_)
open import Relation.Nullary public using
  (¬_ ; Dec ; yes ; no)
open import Relation.Binary.PropositionalEquality public using
  ( _≡_ ; _≢_ ; refl ; sym ; trans ; cong ; cong₂ ; subst ; subst₂
  ; module ≡-Reasoning )

infix 1 triangle⟨_⟩⟨_⟩⟨_⟩

triangle⟨_⟩⟨_⟩⟨_⟩ : ∀ {a} {A : Set a} x {y z : A}
  → y ≡ x
  → z ≡ x
  → y ≡ z
triangle⟨ x ⟩⟨ y≡x ⟩⟨ z≡x ⟩ = trans y≡x (sym z≡x)


------------------------------------------------------------------------
-- The Agda standard library
--
-- Properties of operations on strings
------------------------------------------------------------------------

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

module Data.String.Properties where

open import Data.Bool.Base using (Bool)
import Data.Char.Properties as Charₚ
import Data.List.Properties as Listₚ
import Data.List.Relation.Binary.Pointwise as Pointwise
import Data.List.Relation.Binary.Lex.Strict as StrictLex
open import Data.String.Base
open import Function
open import Relation.Nullary using (yes; no)
open import Relation.Nullary.Decidable using (map′; isYes)
open import Relation.Binary
open import Relation.Binary.PropositionalEquality.Core
import Relation.Binary.Construct.On as On
import Relation.Binary.PropositionalEquality as PropEq

------------------------------------------------------------------------
-- Primitive properties

open import Agda.Builtin.String.Properties public
  renaming ( primStringToListInjective to toList-injective)

------------------------------------------------------------------------
-- Properties of _≈_

≈⇒≡ : _≈_ ⇒ _≡_
≈⇒≡ = toList-injective _ _
    ∘ Pointwise.Pointwise-≡⇒≡
    ∘ Pointwise.map Charₚ.≈⇒≡

≈-reflexive : _≡_ ⇒ _≈_
≈-reflexive = Pointwise.map Charₚ.≈-reflexive
            ∘ Pointwise.≡⇒Pointwise-≡
            ∘ cong toList

≈-refl : Reflexive _≈_
≈-refl {x} = ≈-reflexive {x} {x} refl

≈-sym : Symmetric _≈_
≈-sym = Pointwise.symmetric (λ {i j} → Charₚ.≈-sym {i} {j})

≈-trans : Transitive _≈_
≈-trans = Pointwise.transitive (λ {i j k} → Charₚ.≈-trans {i} {j} {k})

≈-subst : ∀ {ℓ} → Substitutive _≈_ ℓ
≈-subst P x≈y p = subst P (≈⇒≡ x≈y) p

infix 4 _≈?_
_≈?_ : Decidable _≈_
x ≈? y = Pointwise.decidable Charₚ._≈?_ (toList x) (toList y)

≈-isEquivalence : IsEquivalence _≈_
≈-isEquivalence = record
  { refl  = λ {i} → ≈-refl {i}
  ; sym   = λ {i j} → ≈-sym {i} {j}
  ; trans = λ {i j k} → ≈-trans {i} {j} {k}
  }

≈-setoid : Setoid _ _
≈-setoid = record
  { isEquivalence = ≈-isEquivalence
  }

≈-isDecEquivalence : IsDecEquivalence _≈_
≈-isDecEquivalence = record
  { isEquivalence = ≈-isEquivalence
  ; _≟_           = _≈?_
  }

≈-decSetoid : DecSetoid _ _
≈-decSetoid = record
  { isDecEquivalence = ≈-isDecEquivalence
  }

-----------------------------------------------------------------------
-- Properties of _≡_

infix 4 _≟_

_≟_ : Decidable _≡_
x ≟ y = map′ ≈⇒≡ ≈-reflexive $ x ≈? y

≡-setoid : Setoid _ _
≡-setoid = PropEq.setoid String

≡-decSetoid : DecSetoid _ _
≡-decSetoid = PropEq.decSetoid _≟_

------------------------------------------------------------------------
-- Properties of _<_

infix 4 _<?_
_<?_ : Decidable _<_
x <? y = StrictLex.<-decidable Charₚ._≈?_ Charₚ._<?_ (toList x) (toList y)

<-isStrictPartialOrder-≈ : IsStrictPartialOrder _≈_ _<_
<-isStrictPartialOrder-≈ =
  On.isStrictPartialOrder
    toList
    (StrictLex.<-isStrictPartialOrder Charₚ.<-isStrictPartialOrder-≈)

<-isStrictTotalOrder-≈ : IsStrictTotalOrder _≈_ _<_
<-isStrictTotalOrder-≈ =
  On.isStrictTotalOrder
    toList
    (StrictLex.<-isStrictTotalOrder Charₚ.<-isStrictTotalOrder-≈)

<-strictPartialOrder-≈ : StrictPartialOrder _ _ _
<-strictPartialOrder-≈ =
  On.strictPartialOrder
    (StrictLex.<-strictPartialOrder Charₚ.<-strictPartialOrder-≈)
    toList

<-strictTotalOrder-≈ : StrictTotalOrder _ _ _
<-strictTotalOrder-≈ =
  On.strictTotalOrder
    (StrictLex.<-strictTotalOrder Charₚ.<-strictTotalOrder-≈)
    toList

------------------------------------------------------------------------
-- Alternative Boolean equality test.
--
-- Why is the definition _==_ = primStringEquality not used? One
-- reason is that the present definition can sometimes improve type
-- inference, at least with the version of Agda that is current at the
-- time of writing: see unit-test below.

infix 4 _==_
_==_ : String → String → Bool
s₁ == s₂ = isYes (s₁ ≟ s₂)

private

  -- The following unit test does not type-check (at the time of
  -- writing) if _==_ is replaced by primStringEquality.

  data P : (String → Bool) → Set where
    p : (c : String) → P (_==_ c)

  unit-test : P (_==_ "")
  unit-test = p _

-- Version 1.1

setoid = ≡-setoid
{-# WARNING_ON_USAGE setoid
"Warning: setoid was deprecated in v1.1.
Please use ≡-setoid instead."
#-}

decSetoid = ≡-decSetoid
{-# WARNING_ON_USAGE decSetoid
"Warning: decSetoid was deprecated in v1.1.
Please use ≡-decSetoid instead."
#-}

strictTotalOrder = <-strictTotalOrder-≈
{-# WARNING_ON_USAGE strictTotalOrder
"Warning: strictTotalOrder was deprecated in v1.1.
Please use <-strictTotalOrder-≈ instead."
#-}


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

-- AVL trees are balanced binary search trees.

-- The search tree invariant is specified using the technique
-- described by Conor McBride in his talk "Pivotal pragmatism".

open import Relation.Binary
open import Relation.Binary.PropositionalEquality as P using (_≡_)

module Data.AVL
  {k v ℓ}
  {Key : Set k} (Value : Key → Set v)
  {_<_ : Rel Key ℓ}
  (isStrictTotalOrder : IsStrictTotalOrder _≡_ _<_)
  where

open import Data.Bool
import Data.DifferenceList as DiffList
open import Data.Empty
open import Data.List as List using (List)
open import Data.Maybe hiding (map)
open import Data.Nat hiding (_<_; compare; _⊔_)
open import Data.Product hiding (map)
open import Data.Unit
open import Function
open import Level using (_⊔_; Lift; lift)

open IsStrictTotalOrder isStrictTotalOrder

------------------------------------------------------------------------
-- Extended keys

module Extended-key where

  -- The key type extended with a new minimum and maximum.

  data Key⁺ : Set k where
    ⊥⁺ ⊤⁺ : Key⁺
    [_]   : (k : Key) → Key⁺

  -- An extended strict ordering relation.

  infix 4 _<⁺_

  _<⁺_ : Key⁺ → Key⁺ → Set ℓ
  ⊥⁺    <⁺ [ _ ] = Lift ⊤
  ⊥⁺    <⁺ ⊤⁺    = Lift ⊤
  [ x ] <⁺ [ y ] = x < y
  [ _ ] <⁺ ⊤⁺    = Lift ⊤
  _     <⁺ _     = Lift ⊥

  -- A pair of ordering constraints.

  infix 4 _<_<_

  _<_<_ : Key⁺ → Key → Key⁺ → Set ℓ
  l < x < u = l <⁺ [ x ] × [ x ] <⁺ u

  -- _<⁺_ is transitive.

  trans⁺ : ∀ l {m u} → l <⁺ m → m <⁺ u → l <⁺ u

  trans⁺ [ l ] {m = [ m ]} {u = [ u ]} l<m m<u = trans l<m m<u

  trans⁺ ⊥⁺    {u = [ _ ]} _ _ = _
  trans⁺ ⊥⁺    {u = ⊤⁺}    _ _ = _
  trans⁺ [ _ ] {u = ⊤⁺}    _ _ = _

  trans⁺ _     {m = ⊥⁺}    {u = ⊥⁺}    _ (lift ())
  trans⁺ _     {m = [ _ ]} {u = ⊥⁺}    _ (lift ())
  trans⁺ _     {m = ⊤⁺}    {u = ⊥⁺}    _ (lift ())
  trans⁺ [ _ ] {m = ⊥⁺}    {u = [ _ ]} (lift ()) _
  trans⁺ [ _ ] {m = ⊤⁺}    {u = [ _ ]} _ (lift ())
  trans⁺ ⊤⁺    {m = ⊥⁺}                (lift ()) _
  trans⁺ ⊤⁺    {m = [ _ ]}             (lift ()) _
  trans⁺ ⊤⁺    {m = ⊤⁺}                (lift ()) _

------------------------------------------------------------------------
-- Types and functions which are used to keep track of height
-- invariants

module Height-invariants where

  -- Bits. (I would use Fin 2 instead if Agda had "defined patterns",
  -- so that I could pattern match on 1# instead of suc zero; the text
  -- "suc zero" takes up a lot more space.)

  data ℕ₂ : Set where
    0# : ℕ₂
    1# : ℕ₂

  -- Addition.

  infixl 6 _⊕_

  _⊕_ : ℕ₂ → ℕ → ℕ
  0# ⊕ n = n
  1# ⊕ n = 1 + n

  -- i ⊕ n -1 = pred (i ⊕ n).

  _⊕_-1 : ℕ₂ → ℕ → ℕ
  i ⊕ zero  -1 = 0
  i ⊕ suc n -1 = i ⊕ n

  infix 4 _∼_

  -- If m ∼ n, then the difference between m and n is at most 1. _∼_
  -- is used to record the balance factor of the AVL trees, and also
  -- to ensure that the absolute value of the balance factor is never
  -- more than 1.

  data _∼_ : ℕ → ℕ → Set where
    ∼+ : ∀ {n} →     n ∼ 1 + n
    ∼0 : ∀ {n} →     n ∼ n
    ∼- : ∀ {n} → 1 + n ∼ n

  -- The maximum of m and n.

  max : ∀ {m n} → m ∼ n → ℕ
  max (∼+ {n}) = 1 + n
  max (∼0 {n}) =     n
  max (∼- {n}) = 1 + n

  -- Some lemmas.

  1+ : ∀ {m n} → m ∼ n → 1 + m ∼ 1 + n
  1+ ∼+ = ∼+
  1+ ∼0 = ∼0
  1+ ∼- = ∼-

  max∼ : ∀ {i j} (bal : i ∼ j) → max bal ∼ i
  max∼ ∼+ = ∼-
  max∼ ∼0 = ∼0
  max∼ ∼- = ∼0

  ∼max : ∀ {i j} (bal : i ∼ j) → j ∼ max bal
  ∼max ∼+ = ∼0
  ∼max ∼0 = ∼0
  ∼max ∼- = ∼+

  max∼max : ∀ {i j} (bal : i ∼ j) → max (max∼ bal) ∼ max (∼max bal)
  max∼max ∼+ = ∼0
  max∼max ∼0 = ∼0
  max∼max ∼- = ∼0

  max-lemma : ∀ {m n} (bal : m ∼ n) →
              1 + max (1+ (max∼max bal)) ≡ 2 + max bal
  max-lemma ∼+ = P.refl
  max-lemma ∼0 = P.refl
  max-lemma ∼- = P.refl

------------------------------------------------------------------------
-- AVL trees

-- Key/value pairs.

KV : Set (k ⊔ v)
KV = Σ Key Value

module Indexed where

  open Extended-key
  open Height-invariants

  -- 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 (l u : Key⁺) : ℕ → Set (k ⊔ v ⊔ ℓ) where
    leaf : (l<u : l <⁺ u) → Tree l u 0
    node : ∀ {hˡ hʳ}
           (k : KV)
           (lk : Tree l [ proj₁ k ] hˡ)
           (ku : Tree [ proj₁ k ] u hʳ) (bal : hˡ ∼ hʳ) →
           Tree l u (1 + max bal)

  -- 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 m u h → Tree 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 l m h → m <⁺ u → Tree 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ʳ} →
           (k : KV) →
           (∃ λ i → Tree l [ proj₁ k ] (i ⊕ hˡ)) →
           Tree [ proj₁ k ] u hʳ →
           (bal : hˡ ∼ hʳ) →
           ∃ λ i → Tree l u (i ⊕ (1 + max bal))
  joinˡ⁺ k₆ (1# , node k₂ t₁
                    (node k₄ t₃ t₅ bal)
                                ∼+) t₇ ∼-  = (0# , P.subst (Tree _ _) (max-lemma bal)
                                                     (node k₄
                                                           (node k₂ t₁ t₃ (max∼ bal))
                                                           (node k₆ t₅ t₇ (∼max bal))
                                                           (1+ (max∼max bal))))
  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ʳ⁺ : ∀ {l u hˡ hʳ} →
           (k : KV) →
           Tree l [ proj₁ k ] hˡ →
           (∃ λ i → Tree [ proj₁ k ] u (i ⊕ hʳ)) →
           (bal : hˡ ∼ hʳ) →
           ∃ λ i → Tree l u (i ⊕ (1 + max bal))
  joinʳ⁺ k₂ t₁ (1# , node k₆
                       (node k₄ t₃ t₅ bal)
                                t₇ ∼-) ∼+  = (0# , P.subst (Tree _ _) (max-lemma bal)
                                                     (node k₄
                                                           (node k₂ t₁ t₃ (max∼ bal))
                                                           (node k₆ t₅ t₇ (∼max bal))
                                                           (1+ (max∼max bal))))
  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ˡ⁻ : ∀ {l u} hˡ {hʳ} →
           (k : KV) →
           (∃ λ i → Tree l [ proj₁ k ] (i ⊕ hˡ -1)) →
           Tree [ proj₁ k ] u hʳ →
           (bal : hˡ ∼ hʳ) →
           ∃ λ i → Tree l u (i ⊕ max bal)
  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ʳ⁻ : ∀ {l u hˡ} hʳ →
           (k : KV) →
           Tree l [ proj₁ k ] hˡ →
           (∃ λ i → Tree [ proj₁ k ] u (i ⊕ hʳ -1)) →
           (bal : hˡ ∼ hʳ) →
           ∃ λ i → Tree l u (i ⊕ max bal)
  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)

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

  headTail : ∀ {l u h} → Tree l u (1 + h) →
             ∃ λ (k : KV) → l <⁺ [ proj₁ k ] ×
                            ∃ λ i → Tree [ 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 l u (1 + h) →
             ∃ λ (k : KV) → [ proj₁ k ] <⁺ u ×
                            ∃ λ i → Tree 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ʳ} →
         Tree l m hˡ → Tree m u hʳ → (bal : hˡ ∼ hʳ) →
         ∃ λ i → Tree l u (i ⊕ max bal)
  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 l u 0
  empty = leaf

  -- A singleton tree.

  singleton : ∀ {l u} (k : Key) → Value k → l < k < u → Tree 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) → Value k →
               (Value k → Value k → Value k) →  -- New → old → result.
               Tree l u h → l < k < u →
               ∃ λ i → Tree l u (i ⊕ h)
  insertWith k v f (leaf l<u) l<k<u = (1# , singleton k v l<k<u)
  insertWith k v f (node (k′ , v′) lp pu bal) (l<k , k<u) with compare k k′
  ... | tri< k<k′ _ _ = joinˡ⁺ (k′ , v′) (insertWith k v f lp (l<k , k<k′)) pu bal
  ... | tri> _ _ k′<k = joinʳ⁺ (k′ , v′) lp (insertWith k v f pu (k′<k , k<u)) bal
  ... | tri≈ _ k≡k′ _ rewrite P.sym k≡k′ = (0# , node (k , f v 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) → Value k → Tree l u h → l < k < u →
           ∃ λ i → Tree l u (i ⊕ h)
  insert k v = insertWith k v const

  -- 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} → Key → Tree l u h →
           ∃ λ i → Tree l u (i ⊕ h -1)
  delete k (leaf l<u)         = (0# , leaf l<u)
  delete k (node p lp pu bal) with compare k (proj₁ p)
  ... | tri< _ _ _ = joinˡ⁻ _ p (delete k lp) pu bal
  ... | tri> _ _ _ = joinʳ⁻ _ p lp (delete k pu) bal
  ... | tri≈ _ _ _ = 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 l u h → Maybe (Value k)
  lookup k (leaf _)                  = nothing
  lookup k (node (k′ , v) lk′ k′u _) with compare k k′
  ... | tri< _ _  _ = lookup k lk′
  ... | tri> _ _  _ = lookup k k′u
  ... | tri≈ _ eq _ rewrite eq = just v

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

  map : (∀ {k} → Value k → Value k) →
        ∀ {l u h} → Tree l u h → Tree 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

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

  open DiffList

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

------------------------------------------------------------------------
-- Types and functions with hidden indices

data Tree : Set (k ⊔ v ⊔ ℓ) where
  tree : let open Extended-key in
         ∀ {h} → Indexed.Tree ⊥⁺ ⊤⁺ h → Tree

empty : Tree
empty = tree (Indexed.empty _)

singleton : (k : Key) → Value k → Tree
singleton k v = tree (Indexed.singleton k v _)

insert : (k : Key) → Value k → Tree → Tree
insert k v (tree t) = tree $ proj₂ $ Indexed.insert k v t _

insertWith : (k : Key) → Value k → (Value k → Value k → Value k) →
             Tree → Tree
insertWith k v f (tree t) = tree $ proj₂ $ Indexed.insertWith k v f t _

delete : Key → Tree → Tree
delete k (tree t) = tree $ proj₂ $ Indexed.delete k t

lookup : (k : Key) → Tree → Maybe (Value k)
lookup k (tree t) = Indexed.lookup k t

map : ({k : Key} → Value k → Value k) → Tree → Tree
map f (tree t) = tree $ Indexed.map f t

_∈?_ : Key → Tree → Bool
k ∈? t = is-just (lookup k t)

headTail : Tree → Maybe (KV × Tree)
headTail (tree (Indexed.leaf _)) = nothing
headTail (tree {h = suc _} t)    with Indexed.headTail t
... | (k , _ , _ , t′) = just (k , tree (Indexed.castˡ _ t′))

initLast : Tree → Maybe (Tree × KV)
initLast (tree (Indexed.leaf _)) = nothing
initLast (tree {h = suc _} t)    with Indexed.initLast t
... | (k , _ , _ , t′) = just (tree (Indexed.castʳ t′ _) , k)

-- The input does not need to be ordered.

fromList : List KV → Tree
fromList = List.foldr (uncurry insert) empty

-- Returns an ordered list.

toList : Tree → List KV
toList (tree t) = DiffList.toList (Indexed.toDiffList t)

-- Naive implementations of union.

unionWith : (∀ {k} → Value k → Value k → Value k) →
            -- Left → right → result.
            Tree → Tree → Tree
unionWith f t₁ t₂ =
  List.foldr (λ { (k , v) → insertWith k v f }) t₂ (toList t₁)

-- Left-biased.

union : Tree → Tree → Tree
union = unionWith const

unionsWith : (∀ {k} → Value k → Value k → Value k) → List Tree → Tree
unionsWith f ts = List.foldr (unionWith f) empty ts

-- Left-biased.

unions : List Tree → Tree
unions = unionsWith const