------------------------------------------------------------------------
-- Call-by-value (CBV) reduction in Fω with interval kinds.
------------------------------------------------------------------------

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

module FOmegaInt.Reduction.Cbv where

open import Data.Fin.Substitution
open import Data.Fin.Substitution.ExtraLemmas
import Relation.Binary.Construct.Closure.Equivalence as EqClos
open import Relation.Binary.Construct.Closure.ReflexiveTransitive
  using (map; gmap)
import Relation.Binary.PropositionalEquality as PropEq
open import Relation.Binary.Reduction

open import FOmegaInt.Syntax
open import FOmegaInt.Reduction.Full

open Syntax
open Substitution using (_[_])

----------------------------------------------------------------------
-- Call-by-value (CBV) reduction and equivalence relations

-- Untyped term values with up to n free variables.
data Val {n} : Term n → Set where
  Λ : ∀ k a → Val (Λ k a)   -- type abstraction
  ƛ : ∀ a b → Val (ƛ a b)   -- term abstraction

infixl 9  _·₁_ _·₂_ _⊡_
infix  5  _→v_

-- One-step CBV reduction.
data _→v_ {n} : Term n → Term n → Set where
  cont-· : ∀ a b {c} (v : Val c)              → (ƛ a b) · c →v b [ c ]
  cont-⊡ : ∀ k a b                            → (Λ k a) ⊡ b →v a [ b ]
  _·₁_   : ∀ {a₁ a₂} → a₁ →v a₂ → ∀ b         →      a₁ · b →v a₂ · b
  _·₂_   : ∀ {a b₁ b₂} (v : Val a) → b₁ →v b₂ →      a · b₁ →v a · b₂
  _⊡_    : ∀ {a₁ a₂} → a₁ →v a₂ → ∀ b         →      a₁ ⊡ b →v a₂ ⊡ b

reduction : Reduction Term
reduction = record { _→1_ = _→v_ }

-- CBV reduction and equivalence.
open Reduction reduction public renaming (_→*_ to _→v*_; _↔_ to _≡v_)

----------------------------------------------------------------------
-- Simple properties of the CBV reductions/equivalence

-- Inclusions.
→v⇒→v* = →1⇒→* reduction
→v*⇒≡v = →*⇒↔  reduction
→v⇒≡v  = →1⇒↔  reduction

-- CBV reduction is a preorder.
→v*-predorder = →*-preorder reduction

-- Preorder reasoning for CBV reduction.
module →v*-Reasoning = →*-Reasoning reduction

-- Terms together with CBV equivalence form a setoid.
≡v-setoid = ↔-setoid reduction

-- Equational reasoning for CBV equivalence.
module ≡v-Reasoning = ↔-Reasoning reduction

----------------------------------------------------------------------
-- Relationships between CBV reduction and full β-reduction

-- One-step CBV reduction implies one-step β-reduction.
→v⇒→β : ∀ {n} {a b : Term n} → a →v b → a →β b
→v⇒→β (cont-· a b c) = ⌈ cont-Tm· a b _ ⌉
→v⇒→β (cont-⊡ k a b) = ⌈ cont-⊡ k a b ⌉
→v⇒→β (a₁→a₂ ·₁ b) = →v⇒→β a₁→a₂ ·₁ b
→v⇒→β (a ·₂ b₁→b₂) = _ ·₂ →v⇒→β b₁→b₂
→v⇒→β (a₁→a₂ ⊡ b)  = →v⇒→β a₁→a₂ ⊡₁ b

-- CBV reduction implies β-reduction.
→v*⇒→β* : ∀ {n} {a b : Term n} → a →v* b → a →β* b
→v*⇒→β* = map →v⇒→β

-- CBV equivalence implies β-equivalence.
≡v⇒≡β : ∀ {n} {a b : Term n} → a ≡v b → a ≡β b
≡v⇒≡β = EqClos.map →v⇒→β


{-# OPTIONS --show-implicit #-}
{-# OPTIONS -v tc.interaction:20 #-}

------------------------------------------------------------------------
-- Library

id : ∀ {X : Set} → X → X
id x = x

infixr 9 _∘_

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

record Σ (X : Set) (Y : X → Set) : Set where
  constructor _,_
  field
    proj₁ : X
    proj₂ : Y proj₁

open Σ public

syntax Σ X (λ x → Y) = Σ[ x ∈ X ] Y

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

subst : ∀ {A} (P : A → Set) {x y} → x ≡ y → P x → P y
subst P refl p = p

record _▷_ (I O : Set) : Set₁ where
  constructor _◃_/_
  field
    Parameter  : (o : O) → Set
    Arity      : ∀ {o} (p : Parameter o) → Set
    input      : ∀ {o} (p : Parameter o) (a : Arity p) → I

open _▷_ public

Pow : Set → Set₁
Pow X = X → Set

infix 4 _⊆_

_⊆_ : ∀ {X} → Pow X → Pow X → Set
P ⊆ Q = ∀ {x} → P x → Q x

⟦_⟧ : ∀ {I O} → I ▷ O → (Pow I → Pow O)
⟦ P ◃ A / s ⟧ X o = Σ[ p ∈ P o ] ((a : A p) → X (s p a))

Alg : ∀ {O} → O ▷ O → Pow O → Set
Alg Σ X = ⟦ Σ ⟧ X ⊆ X

module _ {I₁ I₂ O₁ O₂} where

  record ContainerMorphism
         (C₁ : I₁ ▷ O₁) (C₂ : I₂ ▷ O₂)
         (f : I₁ → I₂) (g : O₁ → O₂)
         (_∼_ : I₂ → I₂ → Set) (_≈_ : Set → Set → Set)
         (_·_ : ∀ {A B} → A ≈ B → A → B) :
         Set where
    field
      parameter  : Parameter C₁ ⊆ Parameter C₂ ∘ g
      arity      : ∀ {o} {p₁ : Parameter C₁ o} →
                   Arity C₂ (parameter p₁) ≈ Arity C₁ p₁
      coherent   : ∀ {o} {p₁ : Parameter C₁ o} {a₂ : Arity C₂ (parameter p₁)} →
                   f (input C₁ p₁ (arity · a₂)) ∼ input C₂ (parameter p₁) a₂

  open ContainerMorphism public

  _⇒[_/_]_ : I₁ ▷ O₁ → (I₁ → I₂) → (O₁ → O₂) →
             I₂ ▷ O₂ → Set
  C₁ ⇒[ f / g ] C₂ = ContainerMorphism C₁ C₂ f g _≡_  (λ R₂ R₁ → R₂ → R₁)
                                                      (λ f x → f x)

⟪_⟫ : ∀ {I} {C₁ C₂ : I ▷ I} →
      C₁ ⇒[ id / id ] C₂ → (X : Pow I) → ⟦ C₁ ⟧ X ⊆ ⟦ C₂ ⟧ X
⟪ m ⟫ X (c , k) = parameter m c , λ a₂ →
  subst X (coherent m) (k (arity m a₂))

------------------------------------------------------------------------
-- Example

weaken : ∀ {I} {Ω : I ▷ I} {Ψ : I ▷ I} {X : Pow I} →
         Alg Ψ X → Ω ⇒[ id / id ] Ψ → Alg Ω X
weaken {I}{Ω}{Ψ}{X = X} φ m {i} (p , k) = φ {x = i} (⟪ m ⟫ {!X!} (p , k))

weaken2 : ∀ {I} {Ω : I ▷ I} {Ψ : I ▷ I} {X : Pow I} →
          Alg Ψ X → Ω ⇒[ id / id ] Ψ → Alg Ω X
weaken2 {I}{Ω}{Ψ}{X = X} φ m {i} (p , k) = φ {i} (⟪ m ⟫ X (p , k))


module StronglyRigidOccurrence where

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

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

test : let X : Nat; X = _ in X ≡ suc X
test = refl
-- this gives an error in the occurs checker


{-# OPTIONS --cubical --rewriting #-}

open import Agda.Primitive.Cubical public

postulate
  Int : Set
  _↦_ : {A : Set} → A → A → Set
  id↦ : {A : Set} {a : A} → a ↦ a

{-# BUILTIN REWRITE _↦_ #-}

postulate
  hcompIntEmpty : (n : Int) → primHComp (λ _ → isOneEmpty) n ↦ n

{-# REWRITE hcompIntEmpty #-}

test : (n : Int) → primHComp (λ _ → isOneEmpty) n ↦ n
test n = id↦


{-# OPTIONS --cubical #-}

module Computability.Enumeration.Univalence where

open import Cubical.Core.Everything
open import Computability.Prelude
open import Computability.Enumeration.Base


{-# OPTIONS --cubical-compatible #-}

open import Agda.Primitive

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


variable {A} : Set _

id : A → A
id a = a

test : Set₁
test = id {A = Set₁} Set


module Structure.Logic where


------------------------------------------------------------------------
-- The Agda standard library
--
-- Properties of permutation
------------------------------------------------------------------------

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

module Data.List.Relation.Binary.Permutation.Inductive.Properties where

open import Algebra
open import Algebra.FunctionProperties
open import Algebra.Structures
open import Data.List.Base as List
open import Data.List.Relation.Binary.Permutation.Inductive
open import Data.List.Relation.Unary.Any using (Any; here; there)
open import Data.List.Relation.Unary.All using (All; []; _∷_)
open import Data.List.Membership.Propositional
open import Data.List.Membership.Propositional.Properties
open import Data.List.Relation.Binary.BagAndSetEquality
  using (bag; _∼[_]_; empty-unique; drop-cons; commutativeMonoid)
import Data.List.Properties as Lₚ
open import Data.Product using (_,_; _×_; ∃; ∃₂)
open import Function using (_∘_)
open import Function.Equality using (_⟨$⟩_)
open import Function.Inverse as Inv using (inverse)
open import Relation.Unary using (Pred)
open import Relation.Binary
open import Relation.Binary.PropositionalEquality as ≡
  using (_≡_ ; refl ; cong; cong₂; _≢_; inspect)

open PermutationReasoning

------------------------------------------------------------------------
-- sym

module _ {a} {A : Set a} where

  ↭-sym-involutive : ∀ {xs ys : List A} (p : xs ↭ ys) → ↭-sym (↭-sym p) ≡ p
  ↭-sym-involutive refl          = refl
  ↭-sym-involutive (prep x ↭)    = cong (prep x) (↭-sym-involutive ↭)
  ↭-sym-involutive (swap x y ↭)  = cong (swap x y) (↭-sym-involutive ↭)
  ↭-sym-involutive (trans ↭₁ ↭₂) =
    cong₂ trans (↭-sym-involutive ↭₁) (↭-sym-involutive ↭₂)

------------------------------------------------------------------------
-- Relationships to other predicates

module _ {a} {A : Set a} where

  All-resp-↭ : ∀ {ℓ} {P : Pred A ℓ} → (All P) Respects _↭_
  All-resp-↭ refl wit                     = wit
  All-resp-↭ (prep x p) (px ∷ wit)        = px ∷ All-resp-↭ p wit
  All-resp-↭ (swap x y p) (px ∷ py ∷ wit) = py ∷ px ∷ All-resp-↭ p wit
  All-resp-↭ (trans p₁ p₂) wit            = All-resp-↭ p₂ (All-resp-↭ p₁ wit)

  Any-resp-↭ : ∀ {ℓ} {P : Pred A ℓ} → (Any P) Respects _↭_
  Any-resp-↭ refl         wit                 = wit
  Any-resp-↭ (prep x p)   (here px)           = here px
  Any-resp-↭ (prep x p)   (there wit)         = there (Any-resp-↭ p wit)
  Any-resp-↭ (swap x y p) (here px)           = there (here px)
  Any-resp-↭ (swap x y p) (there (here px))   = here px
  Any-resp-↭ (swap x y p) (there (there wit)) = there (there (Any-resp-↭ p wit))
  Any-resp-↭ (trans p p₁) wit                 = Any-resp-↭ p₁ (Any-resp-↭ p wit)

  ∈-resp-↭ : ∀ {x : A} → (x ∈_) Respects _↭_
  ∈-resp-↭ = Any-resp-↭

------------------------------------------------------------------------
-- map

module _ {a b} {A : Set a} {B : Set b} (f : A → B) where

  map⁺ : ∀ {xs ys} → xs ↭ ys → map f xs ↭ map f ys
  map⁺ refl          = refl
  map⁺ (prep x p)    = prep _ (map⁺ p)
  map⁺ (swap x y p)  = swap _ _ (map⁺ p)
  map⁺ (trans p₁ p₂) = trans (map⁺ p₁) (map⁺ p₂)

------------------------------------------------------------------------
-- _++_

module _ {a} {A : Set a} where

  ++⁺ˡ : ∀ xs {ys zs : List A} → ys ↭ zs → xs ++ ys ↭ xs ++ zs
  ++⁺ˡ []       ys↭zs = ys↭zs
  ++⁺ˡ (x ∷ xs) ys↭zs = prep x (++⁺ˡ xs ys↭zs)

  ++⁺ʳ : ∀ {xs ys : List A} zs → xs ↭ ys → xs ++ zs ↭ ys ++ zs
  ++⁺ʳ zs refl          = refl
  ++⁺ʳ zs (prep x ↭)    = prep x (++⁺ʳ zs ↭)
  ++⁺ʳ zs (swap x y ↭)  = swap x y (++⁺ʳ zs ↭)
  ++⁺ʳ zs (trans ↭₁ ↭₂) = trans (++⁺ʳ zs ↭₁) (++⁺ʳ zs ↭₂)

  ++⁺ : _++_ Preserves₂ _↭_ ⟶ _↭_ ⟶ _↭_
  ++⁺ ws↭xs ys↭zs = trans (++⁺ʳ _ ws↭xs) (++⁺ˡ _ ys↭zs)

  -- Some useful lemmas

  zoom : ∀ h {t xs ys : List A} → xs ↭ ys → h ++ xs ++ t ↭ h ++ ys ++ t
  zoom h {t} = ++⁺ˡ h ∘ ++⁺ʳ t

  inject : ∀  (v : A) {ws xs ys zs} → ws ↭ ys → xs ↭ zs →
           ws ++ [ v ] ++ xs ↭ ys ++ [ v ] ++ zs
  inject v ws↭ys xs↭zs = trans (++⁺ˡ _ (prep v xs↭zs)) (++⁺ʳ _ ws↭ys)

  shift : ∀ v (xs ys : List A) → xs ++ [ v ] ++ ys ↭ v ∷ xs ++ ys
  shift v []       ys = refl
  shift v (x ∷ xs) ys = begin
    x ∷ (xs ++ [ v ] ++ ys) <⟨ shift v xs ys ⟩
    x ∷ v ∷ xs ++ ys        <<⟨ refl ⟩
    v ∷ x ∷ xs ++ ys        ∎

  drop-mid-≡ : ∀ {x} ws xs {ys} {zs} →
               ws ++ [ x ] ++ ys ≡ xs ++ [ x ] ++ zs →
               ws ++ ys ↭ xs ++ zs
  drop-mid-≡ []       []       eq   with cong tail eq
  drop-mid-≡ []       []       eq   | refl = refl
  drop-mid-≡ []       (x ∷ xs) refl = shift _ xs _
  drop-mid-≡ (w ∷ ws) []       refl = ↭-sym (shift _ ws _)
  drop-mid-≡ (w ∷ ws) (x ∷ xs) eq with Lₚ.∷-injective eq
  ... | refl , eq′ = prep w (drop-mid-≡ ws xs eq′)

  drop-mid : ∀ {x} ws xs {ys zs} →
             ws ++ [ x ] ++ ys ↭ xs ++ [ x ] ++ zs →
             ws ++ ys ↭ xs ++ zs
  drop-mid {x} ws xs p = drop-mid′ p ws xs refl refl
    where
    drop-mid′ : ∀ {l′ l″ : List A} → l′ ↭ l″ →
                ∀ ws xs {ys zs : List A} →
                ws ++ [ x ] ++ ys ≡ l′ →
                xs ++ [ x ] ++ zs ≡ l″ →
                ws ++ ys ↭ xs ++ zs
    drop-mid′ refl         ws           xs           refl eq   = drop-mid-≡ ws xs (≡.sym eq)
    drop-mid′ (prep x p)   []           []           refl eq   with cong tail eq
    drop-mid′ (prep x p)   []           []           refl eq   | refl = p
    drop-mid′ (prep x p)   []           (x ∷ xs)     refl refl = trans p (shift _ _ _)
    drop-mid′ (prep x p)   (w ∷ ws)     []           refl refl = trans (↭-sym (shift _ _ _)) p
    drop-mid′ (prep x p)   (w ∷ ws)     (x ∷ xs)     refl refl = prep _ (drop-mid′ p ws xs refl refl)
    drop-mid′ (swap y z p) []           []           refl refl = prep _ p
    drop-mid′ (swap y z p) []           (x ∷ [])     refl eq   with cong {B = List _}
                                                                         (λ { (x ∷ _ ∷ xs) → x ∷ xs
                                                                            ; _            → []
                                                                            })
                                                                         eq
    drop-mid′ (swap y z p) []           (x ∷ [])     refl eq   | refl = prep _ p
    drop-mid′ (swap y z p) []           (x ∷ _ ∷ xs) refl refl = prep _ (trans p (shift _ _ _))
    drop-mid′ (swap y z p) (w ∷ [])     []           refl eq   with cong tail eq
    drop-mid′ (swap y z p) (w ∷ [])     []           refl eq   | refl = prep _ p
    drop-mid′ (swap y z p) (w ∷ x ∷ ws) []           refl refl = prep _ (trans (↭-sym (shift _ _ _)) p)
    drop-mid′ (swap y y p) (y ∷ [])     (y ∷ [])     refl refl = prep _ p
    drop-mid′ (swap y z p) (y ∷ [])     (z ∷ y ∷ xs) refl refl = begin
        _ ∷ _             <⟨ p ⟩
        _ ∷ (xs ++ _ ∷ _) <⟨ shift _ _ _ ⟩
        _ ∷ _ ∷ xs ++ _   <<⟨ refl ⟩
        _ ∷ _ ∷ xs ++ _   ∎
    drop-mid′ (swap y z p) (y ∷ z ∷ ws) (z ∷ [])     refl refl = begin
        _ ∷ _ ∷ ws ++ _   <<⟨ refl ⟩
        _ ∷ (_ ∷ ws ++ _) <⟨ ↭-sym (shift _ _ _) ⟩
        _ ∷ (ws ++ _ ∷ _) <⟨ p ⟩
        _ ∷ _             ∎
    drop-mid′ (swap y z p) (y ∷ z ∷ ws) (z ∷ y ∷ xs) refl refl = swap y z (drop-mid′ p _ _ refl refl)
    drop-mid′ (trans p₁ p₂) ws  xs refl refl with ∈-∃++ (∈-resp-↭ p₁ (∈-insert ws))
    ... | (h , t , refl) = trans (drop-mid′ p₁ ws h refl refl) (drop-mid′ p₂ h xs refl refl)

  -- Algebraic properties

  ++-identityˡ : LeftIdentity {A = List A} _↭_ [] _++_
  ++-identityˡ xs = refl

  ++-identityʳ : RightIdentity {A = List A} _↭_ [] _++_
  ++-identityʳ xs = ↭-reflexive (Lₚ.++-identityʳ xs)

  ++-identity : Identity {A = List A} _↭_ [] _++_
  ++-identity = ++-identityˡ , ++-identityʳ

  ++-assoc : Associative {A = List A} _↭_ _++_
  ++-assoc xs ys zs = ↭-reflexive (Lₚ.++-assoc xs ys zs)

  ++-comm : Commutative _↭_ _++_
  ++-comm []       ys = ↭-sym (++-identityʳ ys)
  ++-comm (x ∷ xs) ys = begin
    x ∷ xs ++ ys         ↭⟨ prep x (++-comm xs ys) ⟩
    x ∷ ys ++ xs         ≡⟨ cong (λ v → x ∷ v ++ xs) (≡.sym (Lₚ.++-identityʳ _)) ⟩
    (x ∷ ys ++ []) ++ xs ↭⟨ ++⁺ʳ xs (↭-sym (shift x ys [])) ⟩
    (ys ++ [ x ]) ++ xs  ↭⟨ ++-assoc ys [ x ] xs ⟩
    ys ++ ([ x ] ++ xs)  ≡⟨⟩
    ys ++ (x ∷ xs)       ∎

  ++-isMagma : IsMagma _↭_ _++_
  ++-isMagma = record
    { isEquivalence = ↭-isEquivalence
    ; ∙-cong        = ++⁺
    }

  ++-magma : Magma _ _
  ++-magma = record
    { isMagma = ++-isMagma
    }

  ++-isSemigroup : IsSemigroup _↭_ _++_
  ++-isSemigroup = record
    { isMagma = ++-isMagma
    ; assoc   = ++-assoc
    }

  ++-semigroup : Semigroup a _
  ++-semigroup = record
    { isSemigroup = ++-isSemigroup
    }

  ++-isMonoid : IsMonoid _↭_ _++_ []
  ++-isMonoid = record
    { isSemigroup = ++-isSemigroup
    ; identity    = ++-identity
    }

  ++-monoid : Monoid a _
  ++-monoid = record
    { isMonoid = ++-isMonoid
    }

  ++-isCommutativeMonoid : IsCommutativeMonoid _↭_ _++_ []
  ++-isCommutativeMonoid = record
    { isSemigroup = ++-isSemigroup
    ; identityˡ   = ++-identityˡ
    ; comm        = ++-comm
    }

  ++-commutativeMonoid : CommutativeMonoid _ _
  ++-commutativeMonoid = record
    { isCommutativeMonoid = ++-isCommutativeMonoid
    }

------------------------------------------------------------------------
-- _∷_

module _ {a} {A : Set a} where

  drop-∷ : ∀ {x : A} {xs ys} → x ∷ xs ↭ x ∷ ys → xs ↭ ys
  drop-∷ = drop-mid [] []

------------------------------------------------------------------------
-- _∷ʳ_

module _ {a} {A : Set a} where

  ∷↭∷ʳ : ∀ (x : A) xs → x ∷ xs ↭ xs ∷ʳ x
  ∷↭∷ʳ x xs = ↭-sym (begin
    xs ++ [ x ]   ↭⟨ shift x xs [] ⟩
    x ∷ xs ++ []  ≡⟨ Lₚ.++-identityʳ _ ⟩
    x ∷ xs        ∎)

------------------------------------------------------------------------
-- Relationships to other relations

module _ {a} {A : Set a} where

  ↭⇒∼bag : _↭_ ⇒ _∼[ bag ]_
  ↭⇒∼bag xs↭ys {v} = inverse (to xs↭ys) (from xs↭ys) (from∘to xs↭ys) (to∘from xs↭ys)
    where
    to : ∀ {xs ys} → xs ↭ ys → v ∈ xs → v ∈ ys
    to xs↭ys = Any-resp-↭ {A = A} xs↭ys

    from : ∀ {xs ys} → xs ↭ ys → v ∈ ys → v ∈ xs
    from xs↭ys = Any-resp-↭ (↭-sym xs↭ys)

    from∘to : ∀ {xs ys} (p : xs ↭ ys) (q : v ∈ xs) → from p (to p q) ≡ q
    from∘to refl          v∈xs                 = refl
    from∘to (prep _ _)    (here refl)          = refl
    from∘to (prep _ p)    (there v∈xs)         = cong there (from∘to p v∈xs)
    from∘to (swap x y p)  (here refl)          = refl
    from∘to (swap x y p)  (there (here refl))  = refl
    from∘to (swap x y p)  (there (there v∈xs)) = cong (there ∘ there) (from∘to p v∈xs)
    from∘to (trans p₁ p₂) v∈xs
      rewrite from∘to p₂ (Any-resp-↭ p₁ v∈xs)
            | from∘to p₁ v∈xs                  = refl

    to∘from : ∀ {xs ys} (p : xs ↭ ys) (q : v ∈ ys) → to p (from p q) ≡ q
    to∘from p with from∘to (↭-sym p)
    ... | res rewrite ↭-sym-involutive p = res

  ∼bag⇒↭ : _∼[ bag ]_ ⇒ _↭_
  ∼bag⇒↭ {[]} eq with empty-unique (Inv.sym eq)
  ... | refl = refl
  ∼bag⇒↭ {x ∷ xs} eq with ∈-∃++ (to ⟨$⟩ (here ≡.refl))
    where open Inv.Inverse (eq {x})
  ... | zs₁ , zs₂ , p rewrite p = begin
    x ∷ xs           <⟨ ∼bag⇒↭ (drop-cons (Inv._∘_ (comm zs₁ (x ∷ zs₂)) eq)) ⟩
    x ∷ (zs₂ ++ zs₁) <⟨ ++-comm zs₂ zs₁ ⟩
    x ∷ (zs₁ ++ zs₂) ↭˘⟨ shift x zs₁ zs₂ ⟩
    zs₁ ++ x ∷ zs₂   ∎
    where open CommutativeMonoid (commutativeMonoid bag A)

------------------------------------------------------------------------
-- DEPRECATED NAMES
------------------------------------------------------------------------
-- Please use the new names as continuing support for the old names is
-- not guaranteed.

-- Version 1.0

↭⇒~bag = ↭⇒∼bag
{-# WARNING_ON_USAGE ↭⇒~bag
"Warning: ↭⇒~bag was deprecated in v1.0.
Please use ? instead (now typed with '\\sim' rather than '~')."
#-}

~bag⇒↭ = ∼bag⇒↭
{-# WARNING_ON_USAGE ~bag⇒↭
"Warning: ~bag⇒↭ was deprecated in v1.0.
Please use ? instead (now typed with '\\sim' rather than '~')."
#-}


{-# OPTIONS --exact-split #-}
module Issue1383 where

data Bool : Set where
  true false : Bool

xor : Bool → Bool → Bool
xor = \ { true  true  -> false ;
          false false -> false ;
          {-# CATCHALL #-}
          _     _     -> true  }


{-# OPTIONS --safe --experimental-lossy-unification #-}
{-
This file contains:
1. An iso πₙ'(Sⁿ) ≅ ℤ, where πₙ'(Sⁿ) = ∥ Sⁿ →∙ Sⁿ ∥₀
2. A proof that idfun∙ : Sⁿ →∙ Sⁿ is the generator of πₙ'(Sⁿ)
-}
module Cubical.Homotopy.Group.PinSn where

open import Cubical.Homotopy.Loopspace
open import Cubical.Homotopy.Group.Base
open import Cubical.Homotopy.Group.SuspensionMap
open import Cubical.Homotopy.Connected

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Pointed
open import Cubical.Foundations.Equiv.HalfAdjoint
open import Cubical.Foundations.HLevels
open import Cubical.Foundations.GroupoidLaws
open import Cubical.Foundations.Path
open import Cubical.Foundations.Isomorphism

open import Cubical.HITs.SetTruncation
  renaming (elim to sElim ; elim2 to sElim2
          ; map to sMap)
open import Cubical.HITs.Truncation renaming
  (elim to trElim ; elim2 to trElim2)
open import Cubical.HITs.S1
open import Cubical.HITs.Sn
open import Cubical.HITs.Susp

open import Cubical.Data.Sigma
open import Cubical.Data.Nat
open import Cubical.Data.Int renaming (_+_ to _+ℤ_)

open import Cubical.ZCohomology.Properties

open import Cubical.Algebra.Group
open import Cubical.Algebra.Group.Instances.Int
open import Cubical.Algebra.Group.ZAction
open import Cubical.Algebra.Group.Morphisms
open import Cubical.Algebra.Group.MorphismProperties

open Iso

-- The goal is to prove that πₙSⁿ ≅ ℤ. This is of course trivial, given
-- that ΩⁿK(ℤ,n) ≅ ℤ is already proved. However, we would like to do
-- this for πₙSⁿ defined via (Sⁿ →∙ Sⁿ) and prove that the generator
-- of this group is idfun∙ : Sⁿ → Sⁿ.

private
  suspMapS^ : (n : ℕ) → (S₊∙ (suc n) →∙ S₊∙ (suc n))
                        → S₊∙ (2 + n) →∙ S₊∙ (2 + n)
  suspMapS^ n = suspMap {A = S₊∙ (suc n)} n

is2ConnectedSuspMap : (n : ℕ) → isConnectedFun 2 (suspMapS^ (suc n))
is2ConnectedSuspMap n =
  isConnectedFunSubtr 2 n _
    (subst (λ x → isConnectedFun x (suspMapS^ (suc n)))
                   (subtrLem n (suc (suc n)) ∙ +-comm 2 n)
      (isConnectedSuspMap (suc n) (suc n)))
  where
  subtrLem : (n m : ℕ) → (n + m ∸ n) ≡ m
  subtrLem zero m = refl
  subtrLem (suc n) m = subtrLem n m

-- From the connectedness of the suspension map,
--  we get an iso πₙSⁿ ≅ πₙ₊₁(Sⁿ⁺¹) for n ≥ 2.
SphereSuspIso : (n : ℕ)
  → Iso (π' (2 + n) (S₊∙ (2 + n))) (π' (3 + n) (S₊∙ (3 + n)))
SphereSuspIso n =
  compIso setTruncTrunc2Iso
   (compIso
     (connectedTruncIso 2
       (suspMap {A = S₊∙ (suc (suc n))} (suc n)) (is2ConnectedSuspMap n))
     (invIso (setTruncTrunc2Iso)))

SphereSuspGrIso : (n : ℕ)
  → GroupIso (π'Gr (suc n) (S₊∙ (2 + n))) (π'Gr (2 + n) (S₊∙ (3 + n)))
fst (SphereSuspGrIso n) = SphereSuspIso n
snd (SphereSuspGrIso n) =
  makeIsGroupHom (sElim2 (λ _ _ → isSetPathImplicit)
    λ f g → IsGroupHom.pres· (suspMapπ'Hom (suc n) .snd) ∣ f ∣₂ ∣ g ∣₂)

private
  stLoop₁ : π 2 (S₊∙ 2)
  stLoop₁ = ∣ sym (rCancel (merid base))
          ∙∙ (λ i → merid (loop i) ∙ sym (merid base))
          ∙∙ rCancel (merid base) ∣₂

  stLoop₁flip : π 2 (S₊∙ 2)
  stLoop₁flip = sMap flipSquare stLoop₁

flipSquareIso : ∀ {ℓ} {A : Pointed ℓ} (n : ℕ)
  → GroupIso (πGr (suc n) A) (πGr (suc n) A)
fun (fst (flipSquareIso n)) = sMap flipSquare
inv (fst (flipSquareIso n)) = sMap flipSquare
rightInv (fst (flipSquareIso n)) =
  sElim (λ _ → isSetPathImplicit) λ _ → refl
leftInv (fst (flipSquareIso n)) =
  sElim (λ _ → isSetPathImplicit) λ _ → refl
snd (flipSquareIso n) =
  makeIsGroupHom
    (sElim2 (λ _ _ → isSetPathImplicit)
      λ f g → cong ∣_∣₂
        ((sym (sym≡flipSquare (f ∙ g))
      ∙∙ symDistr f g
      ∙∙ cong₂ _∙_ (sym≡flipSquare g) (sym≡flipSquare f)
       ∙ EH n (flipSquare g) (flipSquare f))))

-- We now want to prove π₁S¹≅π₂S². This will be done by passing through
-- The loop space defintion of the groups
π'₂S²≅π₂S² : GroupIso (π'Gr 1 (S₊∙ 2)) (πGr 1 (S₊∙ 2))
π'₂S²≅π₂S² = π'Gr≅πGr 1 (S₊∙ 2)

{- We now define the iso π₂S² ≅ π₁S¹ -}
π₂S²≅π₁S¹ : GroupIso (πGr 1 (S₊∙ 2)) (πGr 0 (S₊∙ 1))
fst π₂S²≅π₁S¹ =
  compIso setTruncTrunc2Iso
   (compIso
    (compIso (invIso (PathIdTruncIso 2))
     (compIso (congIso (invIso (PathIdTruncIso 3)))
      (compIso
        (congIso (invIso (Iso-Kn-ΩKn+1 1)))
        (PathIdTruncIso 2))))
    (invIso setTruncTrunc2Iso))
snd π₂S²≅π₁S¹ =
  makeIsGroupHom
    (sElim2 (λ _ _ → isSetPathImplicit)
      λ f g →
        cong (inv setTruncTrunc2Iso)
          (cong (fun (PathIdTruncIso 2))
            (cong (cong (ΩKn+1→Kn 1))
              (cong (cong (inv (PathIdTruncIso 3)))
                (cong (inv (PathIdTruncIso 2))
                  (refl {x = ∣ f ∙ g ∣})
               ∙ cong-∙ ∣_∣ₕ f g)
             ∙ cong-∙ (inv (PathIdTruncIso 3)) (cong ∣_∣ₕ f) (cong ∣_∣ₕ g))
           ∙ cong-∙ (ΩKn+1→Kn 1)
              (cong (inv (PathIdTruncIso 3)) (cong ∣_∣ₕ f))
              (cong (inv (PathIdTruncIso 3)) (cong ∣_∣ₕ g)))
         ∙ PathIdTruncIsoFunct 1
            (cong (ΩKn+1→Kn 1) (λ i → inv (PathIdTruncIso 3) ∣ f i ∣ₕ))
            (cong (ΩKn+1→Kn 1) (λ i → inv (PathIdTruncIso 3) ∣ g i ∣ₕ)))
         ∙ setTruncTrunc2IsoFunct
            ((fun (PathIdTruncIso 2))
             (cong (ΩKn+1→Kn 1) (λ i → inv (PathIdTruncIso 3) ∣ f i ∣ₕ)))
            ((fun (PathIdTruncIso 2))
             (cong (ΩKn+1→Kn 1) (λ i → inv (PathIdTruncIso 3) ∣ g i ∣ₕ))))
  where
  setTruncTrunc2IsoFunct : ∀ {ℓ} {A : Type ℓ} {x : A}
    (p q : hLevelTrunc 2 (x ≡ x))
    → inv setTruncTrunc2Iso
         (Cubical.HITs.Truncation.map2 _∙_ p q)
       ≡ ·π 0 (inv setTruncTrunc2Iso p) (inv setTruncTrunc2Iso q)
  setTruncTrunc2IsoFunct =
    trElim2 (λ  _ _ → isSetPathImplicit) λ _ _ → refl

π₂'S²≅π₁'S¹ : GroupIso (π'Gr 1 (S₊∙ 2)) (π'Gr 0 (S₊∙ 1))
π₂'S²≅π₁'S¹ =
  compGroupIso (π'Gr≅πGr 1 (S₊∙ 2))
    (compGroupIso (flipSquareIso 0)
      (compGroupIso π₂S²≅π₁S¹
        (invGroupIso (π'Gr≅πGr 0 (S₊∙ 1)))))

-- We get our iso
πₙ'Sⁿ≅ℤ : (n : ℕ) → GroupIso (π'Gr n (S₊∙ (suc n))) ℤGroup
πₙ'Sⁿ≅ℤ zero =
  compGroupIso (π'Gr≅πGr zero (S₊∙ 1))
    ((compIso (setTruncIdempotentIso (isGroupoidS¹ _ _)) ΩS¹Isoℤ)
      , makeIsGroupHom (sElim2 (λ _ _ → isProp→isSet (isSetℤ _ _))
           winding-hom))
πₙ'Sⁿ≅ℤ (suc zero) = compGroupIso π₂'S²≅π₁'S¹ (πₙ'Sⁿ≅ℤ zero)
πₙ'Sⁿ≅ℤ (suc (suc n)) =
  compGroupIso (invGroupIso (SphereSuspGrIso n)) (πₙ'Sⁿ≅ℤ (suc n))

-- Same thing for the loop space definition
πₙSⁿ≅ℤ : (n : ℕ) → GroupIso (πGr n (S₊∙ (suc n))) ℤGroup
πₙSⁿ≅ℤ n =
  compGroupIso (invGroupIso (π'Gr≅πGr n (S₊∙ (suc n)))) (πₙ'Sⁿ≅ℤ n)

-- The goal now is to show that πₙ'Sⁿ≅ℤ takes idfun∙ : Sⁿ → Sⁿ to 1.
-- For this, we need a bunch of identities:
private
  Isoπ₁S¹ℤ = (compIso (setTruncIdempotentIso (isGroupoidS¹ _ _)) ΩS¹Isoℤ)

  π'₂S²≅π₂S²⁻-stLoop' : inv (fst (π'₂S²≅π₂S²)) stLoop₁flip ≡ ∣ idfun∙ _ ∣₂
  π'₂S²≅π₂S²⁻-stLoop' =
    cong ∣_∣₂ (ΣPathP ((funExt
      (λ { north → refl
         ; south → merid base
         ; (merid base i) j →
           hcomp (λ k
             → λ {(i = i0) → north
                 ; (i = i1) → merid base (j ∧ k)
                 ; (j = i0) → rUnit (λ _ → north) k i
                 ; (j = i1) → merid base (i ∧ k)})
                 north
         ; (merid (loop k) i) j
                  → hcomp (λ r
                    → λ {(i = i0) → north
                        ; (i = i1) → merid base (j ∧ r)
                        ; (j = i0) →
                          rUnit (funExt⁻ (cong fst (cong (Ω→SphereMap 1)
                              (flipSquare (sym (rCancel (merid base))
                            ∙∙ (λ i₁ → merid (loop i₁)
                             ∙ sym (merid base))
                            ∙∙ rCancel (merid base))))) (loop k)) r i
                        ; (j = i1) → lem₂ r i k})
                 (((sym (rCancel (merid base)) ∙∙
                    (λ i₁ → merid (loop i₁) ∙ sym (merid base)) ∙∙
                    rCancel (merid base))) k i)})) , refl))
    where
    genBot+side : ∀ {ℓ} {A : Type ℓ} {x y : A} (p : x ≡ y)
                → Cube {A = A} (λ j r → x) (λ j r → p (~ j ∨ r))
                                (λ i r → p i) (λ i r → p (i ∧ r))
                                (λ i j → p (i ∧ ~ j)) (λ i j → p i)
                 × Cube {A = A} (λ j r → p (~ j ∨ r)) (λ j r → p (r ∧ j))
                                (λ k r → p (~ k)) (λ k r → p r)
                                (λ k j → p (~ k ∧ ~ j)) λ k j → p (j ∨ ~ k)
    genBot+side {A = A} {x = x} =
      J (λ y p → Cube {A = A} (λ j r → x) (λ j r → p (~ j ∨ r))
                                (λ i r → p i) (λ i r → p (i ∧ r))
                                (λ i j → p (i ∧ ~ j)) (λ i j → p i)
                 × Cube {A = A} (λ j r → p (~ j ∨ r)) (λ j r → p (r ∧ j))
                                (λ k r → p (~ k)) (λ k r → p r)
                                (λ k j → p (~ k ∧ ~ j)) λ k j → p (j ∨ ~ k))
         (refl , refl)

    lem₁ : I → I → I → S₊ 2
    lem₁ j i r =
      hcomp (λ k → λ {(i = i0) → north
                     ; (i = i1) → genBot+side (merid base) .snd k j r
                     ; (j = i0) → compPath-filler
                                    (merid base) (sym (merid base)) k i
                     ; (j = i1) → merid base (i ∧ r)
                     ; (r = i0) → rCancel-filler (merid base) k j i
                     ; (r = i1) → compPath-filler
                                   (merid base) (sym (merid base)) (~ j ∧ k) i})
            (genBot+side (merid base) .fst i j r)

    lem₂ : I → I → I → S₊ 2
    lem₂ r i k =
      hcomp (λ j → λ {(i = i0) → north
                     ; (i = i1) → merid base (r ∧ j)
                     ; (r = i0) → doubleCompPath-filler
                                    (sym (rCancel (merid base)))
                                    (λ i₁ → merid (loop i₁) ∙ sym (merid base))
                                    (rCancel (merid base)) j k i
                     ; (r = i1) → compPath-filler
                                   (merid (loop k)) (sym (merid base)) (~ j) i
                     ; (k = i0) → lem₁ j i r
                     ; (k = i1) → lem₁ j i r})
            ((merid (loop k) ∙ sym (merid base)) i)

  π₂S²≅π₁S¹-stLoop : fun (fst π₂S²≅π₁S¹) stLoop₁ ≡ ∣ loop ∣₂
  π₂S²≅π₁S¹-stLoop =
      sym (leftInv Isoπ₁S¹ℤ
          (fun (fst π₂S²≅π₁S¹) stLoop₁))
   ∙∙ cong (inv Isoπ₁S¹ℤ) compute
   ∙∙ leftInv (compIso (setTruncIdempotentIso (isGroupoidS¹ _ _)) ΩS¹Isoℤ)
              ∣ loop ∣₂
    where
    compute : fun Isoπ₁S¹ℤ (fun (fst π₂S²≅π₁S¹) stLoop₁)
            ≡ fun Isoπ₁S¹ℤ ∣ loop ∣₂
    compute = refl

  π₂'S²≅π₁'S¹≡ : fun (fst π₂'S²≅π₁'S¹) ∣ idfun∙ _ ∣₂ ≡ ∣ idfun∙ _ ∣₂
  π₂'S²≅π₁'S¹≡ =
    lem₁ ∣ idfun∙ _ ∣₂ stLoop₁
      (sym π'₂S²≅π₂S²⁻-stLoop')
      (cong (inv (fst (π'Gr≅πGr zero (S₊∙ 1)))) π₂S²≅π₁S¹-stLoop
     ∙ lem₂)
    where
    lem₁ : (x : _) (y : π 2 (S₊∙ 2))
       → (x ≡ inv (fst π'₂S²≅π₂S²) (fun (fst (flipSquareIso 0)) y))
       → inv (fst (π'Gr≅πGr zero (S₊∙ 1))) (fun (fst π₂S²≅π₁S¹) y)
          ≡ ∣ idfun∙ _ ∣₂
       → fun (fst π₂'S²≅π₁'S¹) x ≡ ∣ idfun∙ _ ∣₂
    lem₁ x y p q =
         cong (fun (fst π₂'S²≅π₁'S¹)) p
      ∙∙ (λ i → inv (fst (π'Gr≅πGr zero (S₊∙ (suc zero)))) (fun (fst π₂S²≅π₁S¹)
          (fun (fst (flipSquareIso zero))
            (rightInv
              (fst (π'Gr≅πGr (suc zero) (S₊∙ (suc (suc zero)))))
              (inv (fst (flipSquareIso zero)) y) i)
          )))
      ∙∙ cong (inv (fst (π'Gr≅πGr zero (S₊∙ (suc zero)))))
              (cong (fun (fst π₂S²≅π₁S¹))
                (rightInv (fst (flipSquareIso zero)) y))
       ∙ q

    lem₂ : inv (fst (π'Gr≅πGr zero (S₊∙ 1))) ∣ loop ∣₂ ≡ ∣ idfun∙ _ ∣₂
    lem₂ =
      cong ∣_∣₂ (ΣPathP (funExt (λ { base → refl ; (loop i) → refl}) , refl))

  suspPresIdfun : (n : ℕ) → suspMap n (idfun∙ (S₊∙ (suc n))) ≡ idfun∙ _
  suspPresIdfun n =
    ΣPathP ((funExt
      (λ { north → refl
         ; south → merid (ptSn (suc n))
         ; (merid a i) j
           → compPath-filler (merid a) (sym (merid (ptSn (suc n)))) (~ j) i}))
        , refl)

  suspPresIdfun2 : (n : ℕ)
    → fun (fst (invGroupIso (SphereSuspGrIso n)))
        ∣ idfun∙ (S₊∙ (suc (suc (suc n)))) ∣₂
    ≡ ∣ idfun∙ _ ∣₂
  suspPresIdfun2 n =
      sym (cong (fun (fst (invGroupIso (SphereSuspGrIso n))))
          (cong ∣_∣₂ (suspPresIdfun (suc n))))
    ∙ leftInv (SphereSuspIso n) ∣ idfun∙ _ ∣₂

-- We finally have our results
πₙ'Sⁿ≅ℤ-idfun∙ : (n : ℕ)
  → fun (fst (πₙ'Sⁿ≅ℤ n)) ∣ idfun∙ _ ∣₂ ≡ (pos (suc zero))
πₙ'Sⁿ≅ℤ-idfun∙ zero = refl
πₙ'Sⁿ≅ℤ-idfun∙ (suc zero) = speedUp ∣ idfun∙ _ ∣₂ π₂'S²≅π₁'S¹≡
  where
  speedUp : (x : _) -- stated like this for faster type checking
     → fun (fst π₂'S²≅π₁'S¹) x ≡ ∣ idfun∙ _ ∣₂
     → fun (fst (πₙ'Sⁿ≅ℤ (suc zero))) x ≡ pos (suc zero)
  speedUp x p = cong (fun (fst (πₙ'Sⁿ≅ℤ zero))) p
πₙ'Sⁿ≅ℤ-idfun∙ (suc (suc n)) =
  cong (fun (fst (πₙ'Sⁿ≅ℤ (suc n)))) (suspPresIdfun2 n)
  ∙ πₙ'Sⁿ≅ℤ-idfun∙ (suc n)

πₙ'Sⁿ-gen-by-idfun : (n : ℕ) → gen₁-by (π'Gr n (S₊∙ (suc n))) ∣ idfun∙ _ ∣₂
πₙ'Sⁿ-gen-by-idfun n =
  subst (gen₁-by (π'Gr n (S₊∙ (suc n))))
        (sym (cong (inv (fst (πₙ'Sⁿ≅ℤ n))) (πₙ'Sⁿ≅ℤ-idfun∙ n))
        ∙ leftInv (fst (πₙ'Sⁿ≅ℤ n)) ∣ idfun∙ _ ∣₂)
        (Iso-pres-gen₁ ℤGroup (π'Gr n (S₊∙ (suc n)))
          (pos (suc zero))
          (λ h → h , (sym (·Comm h (pos 1)) ∙ ℤ·≡· h (pos 1)))
          (invGroupIso (πₙ'Sⁿ≅ℤ n)))


-- {-# OPTIONS -v tc.lhs.unify:100 #-}
module Issue811 where

module ParamIndex where
  -- Report by stevan:
  -- When case-splitting, I think dots end up at the wrong places,
  -- consider:

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

  -- If you case-split on p in:
  dot : ∀ {A}(x : A)(y : A) → x ≡ y → Set
  dot x y p = {!p!}

  {- You get:
  dot′ : ∀ {A}(x y : A) → x ≡ y → Set
  dot′ .y y refl = {!!}

  -- This seems the wrong way around to me, because we say that the first
  -- argument has to be something, namely y, before that something has
  -- been introduced.

  -- If I'd do the case-splitting manually, I would write:
  dot″ : ∀ {A}(x y : A) → x ≡ y → Set
  dot″ x .x refl = {!!}
  -}

  -- Andreas, 2013-03-05 This is indeed what you get now, since
  -- Agda now prefers the more left variables.

  -- Unfortunately, this leads to bad behavior in this case:
  dot1 : ∀ {A}{x : A}(y : A) → x ≡ y → Set
  dot1 y p = {!p!}

  -- This one works nicely
  dot2 : ∀ {A}(x : A){y : A} → x ≡ y → Set
  dot2 x p = {!p!}

module AllIndices where

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

  dot : ∀ {A}(x : A)(y : A) → x ≡ y → Set
  dot x y p = {!p!}

  -- Same problem here:
  dot1 : ∀ {A}{x : A}(y : A) → x ≡ y → Set
  dot1 y p = {!p!}

  dot2 : ∀ {A}(x : A){y : A} → x ≡ y → Set
  dot2 x p = {!p!}


open import Nat
open import Prelude
open import List
open import judgemental-erase
open import moveerase
open import sensibility
open import statics-checks
open import statics-core

module reachability where
  -- algorithmically, we break reachability into two halves: first you
  -- produce a list of actions that are all "move parent" to pull the cursor
  -- to the very top of the expression in question. then, you go back down
  -- into the expression with a sequence of move firstChild and move
  -- nextSibs as appropriate. the append of these two lists will reach from
  -- one expression to the other.
  --
  -- there may well be a shorter list of actions that does the same thing;
  -- the expression with top-level cursor may not be the Least Common
  -- Ancestor in the expression tree of the given pair. however, the work
  -- of this less minimal thing and corresponding size of the proof term is
  -- still bounded linearly by the size of the expression, and is far
  -- easier to maniupulate judgementally.

  reachup-type : {t : ztyp} {t' : htyp} →
                 erase-t t t' →
                 Σ[ L ∈ List action ] (runtype t L (▹ t' ◃) × movements L)
  reachup-type ETTop = [] , DoRefl , AM[]
  reachup-type (ETArrL er) with reachup-type er
  ... | (l , ih , m ) = l ++ [ move parent ] ,
                        runtype++ (ziplem-tmarr1 ih) (DoType TMArrParent1 DoRefl) ,
                        movements++ m (AM:: AM[])
  reachup-type (ETArrR er) with reachup-type er
  ... | (l , ih , m ) = l ++ [ move parent ] ,
                        runtype++ (ziplem-tmarr2 ih) (DoType TMArrParent2 DoRefl) ,
                        movements++ m (AM:: AM[])
  reachup-type (ETPlusL er) with reachup-type er
  ... | (l , ih , m ) = l ++ [ move parent ] ,
                        runtype++ (ziplem-tmplus1 ih) (DoType TMPlusParent1 DoRefl) ,
                        movements++ m (AM:: AM[])
  reachup-type (ETPlusR er) with reachup-type er
  ... | (l , ih , m ) = l ++ [ move parent ] ,
                        runtype++ (ziplem-tmplus2 ih) (DoType TMPlusParent2 DoRefl) ,
                        movements++ m (AM:: AM[])
  reachup-type (ETProdL er) with reachup-type er
  ... | (l , ih , m) =  l ++ [ move parent ] ,
                        runtype++ (ziplem-tmprod1 ih) (DoType TMProdParent1 DoRefl) ,
                        movements++ m (AM:: AM[])
  reachup-type (ETProdR er) with reachup-type er
  ... | (l , ih , m) =  l ++ [ move parent ] ,
                        runtype++ (ziplem-tmprod2 ih) (DoType TMProdParent2 DoRefl) ,
                        movements++ m (AM:: AM[])

  mutual
    reachup-synth : {Γ : tctx} {e : zexp} {t : htyp} {e' : hexp} →
                      erase-e e e' →
                      Γ ⊢ e' => t →
                     Σ[ L ∈ List action ] (runsynth Γ e t L ▹ e' ◃ t × movements L)
    reachup-synth (EELam _) ()
    reachup-synth (EEInl er) ()
    reachup-synth (EEInr er) ()
    reachup-synth (EECase1 er) ()
    reachup-synth (EECase2 er) ()
    reachup-synth (EECase3 er) ()

    reachup-synth EETop _ = [] , DoRefl , AM[]
    reachup-synth (EEPlusL er) (SPlus x x₁) with reachup-ana er x
    ... | l , ih , m = l ++ [ move parent ] ,
                       runsynth++ (ziplem-plus1 ih) (DoSynth (SAMove EMPlusParent1) DoRefl) ,
                       movements++ m (AM:: AM[])
    reachup-synth (EEPlusR er) (SPlus x x₁) with reachup-ana er x₁
    ... | l , ih , m = l ++ [ move parent ] ,
                       runsynth++ (ziplem-plus2 ih) (DoSynth (SAMove EMPlusParent2) DoRefl) ,
                       movements++ m (AM:: AM[])
    reachup-synth (EEAscL er) (SAsc x) with reachup-ana er x
    ... | l , ih , m = l ++ [ move parent ] ,
                       runsynth++ (ziplem-asc1 ih) (DoSynth (SAMove EMAscParent1) DoRefl) ,
                       movements++ m (AM:: AM[])
    reachup-synth (EEAscR er) (SAsc x₁) with reachup-type er
    ... | l , ih , m = l ++ [ move parent ] ,
                       runsynth++ {L1 = l} (ziplem-moves-asc2 m er x₁ ih)
                                  (DoSynth (SAMove EMAscParent2) DoRefl) ,
                       movements++ m (AM:: AM[])
    reachup-synth (EEHalfLamL er) (SLam x wt) with reachup-type er
    ... | l , ih , m = l ++ [ move parent ] ,
                       runsynth++ {L1 = l}
                                  (ziplem-moves-halflam1 x er ETTop m ih wt wt)
                                  (DoSynth (SAMove EMHalfLamParent1) DoRefl) ,
                       movements++ m (AM:: AM[])
    reachup-synth (EEHalfLamR er) (SLam x wt) with reachup-synth er wt
    ... | l , ih , m = l ++ [ move parent ] ,
                       runsynth++ {L1 = l}
                                  (ziplem-halflam2 x er wt ih)
                                  (DoSynth (SAMove EMHalfLamParent2) DoRefl) ,
                       movements++ m (AM:: AM[])
    reachup-synth (EEApL er) (SAp wt x x₁) with reachup-synth er wt
    ... | l , ih , m = l ++ [ move parent ] ,
                       runsynth++ {L1 = l}
                                  (ziplem-moves-ap1 (lem-erase-synth er wt) x x₁ m ih)
                                                    (DoSynth (SAMove EMApParent1) DoRefl) ,
                       movements++ m (AM:: AM[])
    reachup-synth (EEApR er) (SAp wt x x₁) with reachup-ana er x₁
    ... | l , ih , m = l ++ [ move parent ] ,
                       runsynth++ (ziplem-ap2 wt x ih) (DoSynth (SAMove EMApParent2) DoRefl) ,
                       movements++ m (AM:: AM[])
    reachup-synth (EENEHole er) (SNEHole wt) with reachup-synth er wt
    ... | l , ih , m = l ++ [ move parent ] ,
                       runsynth++ (ziplem-nehole-a (lem-erase-synth er wt) ih)
                                                   (DoSynth (SAMove EMNEHoleParent) DoRefl) ,
                       movements++ m (AM:: AM[])
    reachup-synth (EEFst er) (SFst wt pr) with reachup-synth er wt
    ... | l , ih , m = (l ++ [ move parent ]) ,
                       runsynth++ (ziplem-moves-fst pr pr er wt m ih)
                                  (DoSynth (SAMove EMFstParent) DoRefl) ,
                       movements++ m (AM:: AM[])
    reachup-synth (EESnd er) (SSnd wt pr) with reachup-synth er wt
    ... | l , ih , m = (l ++ [ move parent ]) ,
                       runsynth++ (ziplem-moves-snd pr pr er wt m ih)
                                  (DoSynth (SAMove EMSndParent) DoRefl) ,
                       movements++ m (AM:: AM[])
    reachup-synth (EEPairL er) (SPair wt wt₁) with reachup-synth er wt
    ... | l , ih , m = l ++ [ move parent ] ,
                       runsynth++ (ziplem-pair1 er wt ih wt₁)
                                  (DoSynth (SAMove EMPairParent1) DoRefl) ,
                       movements++ m (AM:: AM[])
    reachup-synth (EEPairR er) (SPair wt wt₁) with reachup-synth er wt₁
    ... | l , ih , m = l ++ [ move parent ] ,
                       runsynth++ (ziplem-pair2 wt er wt₁ ih)
                                  (DoSynth (SAMove EMPairParent2) DoRefl) ,
                       movements++ m (AM:: AM[])

    reachup-ana : {Γ : tctx} {e : zexp} {t : htyp} {e' : hexp} →
                  erase-e e e' →
                  Γ ⊢ e' <= t →
                  Σ[ L ∈ List action ] (runana Γ e L ▹ e' ◃ t × movements L)
    reachup-ana EETop _ = [] , DoRefl , AM[]
    reachup-ana er (ASubsume x x₁) with reachup-synth er x
    ... | l , ih , m = l ,
                       synthana-moves (lem-erase-synth er x) m x₁ ih ,
                       m
    reachup-ana (EELam er) (ALam x₁ x₂ wt) with reachup-ana er wt
    ... | l , ih , m = l ++ [ move parent ] ,
                       runana++ (ziplem-lam x₁ x₂ ih) (DoAna (AAMove EMLamParent) DoRefl) ,
                       movements++ m (AM:: AM[])
    reachup-ana (EEInl er) (AInl x wt) with reachup-ana er wt
    ... | l , ih , m = l ++ [ move parent ] ,
                       runana++ (ziplem-inl x ih) (DoAna (AAMove EMInlParent) DoRefl) ,
                       movements++ m (AM:: AM[])
    reachup-ana (EEInr er) (AInr x wt) with reachup-ana er wt
    ... | l , ih , m = l ++ [ move parent ] ,
                       runana++ (ziplem-inr x ih) (DoAna (AAMove EMInrParent) DoRefl) ,
                       movements++ m (AM:: AM[])
    reachup-ana (EECase1 er) (ACase x₁ x₂ x₃ x₄ wt wt₁) with reachup-synth er x₄
    ... | l , ih , m = l ++ [ move parent ] ,
                       runana++ {L1 = l} (ziplem-case1a x₁ x₂ er x₄ ih x₃ wt wt₁ m)
                                (DoAna (AAMove EMCaseParent1) DoRefl) ,
                       movements++ m (AM:: AM[])
    reachup-ana (EECase2 er) (ACase x₁ x₂ x₃ x₄ wt wt₁) with reachup-ana er wt
    ... | l , ih , m = l ++ [ move parent ] ,
                       runana++ (ziplem-case2 x₁ x₂ x₄ wt₁ x₃ ih)
                                (DoAna (AAMove EMCaseParent2) DoRefl) ,
                       movements++ m (AM:: AM[])
    reachup-ana (EECase3 er) (ACase x₁ x₂ x₃ x₄ wt wt₁) with reachup-ana er wt₁
    ... | l , ih , m = l ++ [ move parent ] ,
                       runana++ (ziplem-case3 x₁ x₂ x₄ wt x₃ ih)
                                (DoAna (AAMove EMCaseParent3) DoRefl) ,
                       movements++ m (AM:: AM[])

  reachdown-type : {t : htyp} {t' : ztyp} → (p : erase-t t' t) →
                   Σ[ L ∈ List action ] (runtype (▹ t ◃) L t' × movements L)
  reachdown-type ETTop = [] , DoRefl , AM[]
  reachdown-type (ETArrL er) with reachdown-type er
  ... | (l , ih , m ) = move (child 1) :: l ,
                        DoType TMArrChild1 (ziplem-tmarr1 ih) ,
                        AM:: m
  reachdown-type (ETArrR er) with reachdown-type er
  ... | (l , ih , m ) = move (child 2) :: l ,
                        DoType TMArrChild2 (ziplem-tmarr2 ih) ,
                        AM:: m
  reachdown-type (ETPlusL er) with reachdown-type er
  ... | (l , ih , m ) = move (child 1) :: l ,
                        DoType TMPlusChild1 (ziplem-tmplus1 ih) ,
                        AM:: m
  reachdown-type (ETPlusR er) with reachdown-type er
  ... | (l , ih , m ) = move (child 2) :: l ,
                        DoType TMPlusChild2 (ziplem-tmplus2 ih) ,
                        AM:: m
  reachdown-type (ETProdL er) with reachdown-type er
  ... | (l , ih , m ) = move (child 1) :: l ,
                        DoType TMProdChild1 (ziplem-tmprod1 ih) ,
                        AM:: m
  reachdown-type (ETProdR er) with reachdown-type er
  ... | (l , ih , m ) = move (child 2) :: l ,
                        DoType TMProdChild2 (ziplem-tmprod2 ih) ,
                        AM:: m

  mutual
    reachdown-synth : {Γ : tctx} {e : zexp} {t : htyp} {e' : hexp} →
                      (p : erase-e e e') →
                      (wt : Γ ⊢ e' => t) →
                      Σ[ L ∈ List action ] (runsynth Γ ▹ e' ◃ t L e t × movements L)
    reachdown-synth (EELam _) ()
    reachdown-synth (EEInl er) ()
    reachdown-synth (EEInr er) ()
    reachdown-synth (EECase1 er) ()
    reachdown-synth (EECase2 er) ()
    reachdown-synth (EECase3 er) ()

    reachdown-synth EETop _ = [] , DoRefl , AM[]
    reachdown-synth (EEAscL er) (SAsc x) with reachdown-ana er x
    ... | l , ih , m = move (child 1) :: l ,
                       DoSynth (SAMove EMAscChild1) (ziplem-asc1 ih) ,
                       AM:: m
    reachdown-synth (EEAscR er) (SAsc x₁) with reachdown-type er
    ... | l , ih , m = move (child 2) :: l ,
                       DoSynth (SAMove EMAscChild2) (ziplem-moves-asc2 m ETTop x₁ ih) ,
                       AM:: m
    reachdown-synth (EEHalfLamL er) (SLam x wt) with reachdown-type er
    ... | l , ih , m = move (child 1) :: l ,
                       DoSynth (SAMove EMHalfLamChild1)
                               (ziplem-moves-halflam1 x ETTop er m ih wt wt) ,
                       AM:: m
    reachdown-synth (EEHalfLamR er) (SLam x wt) with reachdown-synth er wt
    ... | l , ih , m = move (child 2) :: l ,
                       DoSynth (SAMove EMHalfLamChild2) (ziplem-halflam2 x EETop wt ih) ,
                       AM:: m
    reachdown-synth (EEApL er) (SAp wt x x₁) with reachdown-synth er wt
    ... | l , ih , m = move (child 1) :: l ,
                       DoSynth (SAMove EMApChild1) (ziplem-moves-ap1 wt x x₁ m ih) ,
                       AM:: m
    reachdown-synth (EEApR er) (SAp wt x x₁) with reachdown-ana er x₁
    ... | l , ih , m = move (child 2) :: l ,
                       DoSynth (SAMove EMApChild2) (ziplem-ap2 wt x ih) ,
                       AM:: m
    reachdown-synth (EEPlusL er) (SPlus x x₁) with reachdown-ana er x
    ... | l , ih , m = move (child 1) :: l ,
                       DoSynth (SAMove EMPlusChild1) (ziplem-plus1 ih) ,
                       AM:: m
    reachdown-synth (EEPlusR er) (SPlus x x₁) with reachdown-ana er x₁
    ... | l , ih , m = move (child 2) :: l ,
                       DoSynth (SAMove EMPlusChild2) (ziplem-plus2 ih) ,
                       AM:: m
    reachdown-synth (EENEHole er) (SNEHole wt) with reachdown-synth er wt
    ... | l , ih , m = move (child 1) :: l ,
                       DoSynth (SAMove EMNEHoleChild1) (ziplem-nehole-a wt ih) ,
                       AM:: m
    reachdown-synth (EEPairL er) (SPair wt wt₁) with reachdown-synth er wt
    ... | l , ih , m = move (child 1) :: l ,
                       DoSynth (SAMove EMPairChild1) (ziplem-pair1 EETop wt ih wt₁) ,
                       AM:: m
    reachdown-synth (EEPairR er) (SPair wt wt₁)
      with reachdown-synth er wt₁
    ... | l , ih , m = move (child 2) :: l ,
                       DoSynth (SAMove EMPairChild2) (ziplem-pair2 wt EETop wt₁ ih) ,
                       AM:: m
    reachdown-synth (EEFst er) (SFst wt pr) with reachdown-synth er wt
    ... | l , ih , m = move (child 1) :: l ,
                       DoSynth (SAMove EMFstChild1)
                               (ziplem-moves-fst pr pr EETop wt m ih) ,
                       AM:: m
    reachdown-synth (EESnd er) (SSnd wt pr) with reachdown-synth er wt
    ... | l , ih , m = move (child 1) :: l ,
                       DoSynth (SAMove EMSndChild1)
                               (ziplem-moves-snd pr pr EETop wt m ih) ,
                       AM:: m

    reachdown-ana : {Γ : tctx} {e : zexp} {t : htyp} {e' : hexp} →
                    (p : erase-e e e') →
                    (wt : Γ ⊢ e' <= t) →
                    Σ[ L ∈ List action ] (runana Γ ▹ e' ◃ L e  t × movements L)
    reachdown-ana EETop _ = [] , DoRefl , AM[]
    reachdown-ana er (ASubsume x x₁) with reachdown-synth er x
    ... | l , ih , m = l ,
                       synthana-moves x m x₁ ih ,
                       m
    reachdown-ana (EELam er) (ALam x₁ x₂ wt) with reachdown-ana er wt
    ... | l , ih , m = move (child 1) :: l ,
                       DoAna (AAMove EMLamChild1) (ziplem-lam x₁ x₂ ih) ,
                       AM:: m
    reachdown-ana (EEInl er) (AInl x wt) with reachdown-ana er wt
    ... | l , ih , m = move (child 1) :: l ,
                       DoAna (AAMove EMInlChild1) (ziplem-inl x ih) ,
                       AM:: m
    reachdown-ana (EEInr er) (AInr x wt) with reachdown-ana er wt
    ... | l , ih , m = move (child 1) :: l ,
                       DoAna (AAMove EMInrChild1) (ziplem-inr x ih) ,
                       AM:: m
    reachdown-ana (EECase1 er) (ACase x₁ x₂ x₃ x₄ wt wt₁) with reachdown-synth er x₄
    ... | l , ih , m = move (child 1) :: l ,
                       DoAna (AAMove EMCaseChild1)
                             (ziplem-case1a x₁ x₂ EETop x₄ ih x₃ wt wt₁ m) ,
                       AM:: m
    reachdown-ana (EECase2 er) (ACase x₁ x₂ x₃ x₄ wt wt₁) with reachdown-ana er wt
    ... | l , ih , m = move (child 2) :: l ,
                       DoAna (AAMove EMCaseChild2) (ziplem-case2 x₁ x₂ x₄ wt₁ x₃ ih) ,
                       AM:: m
    reachdown-ana (EECase3 er) (ACase x₁ x₂ x₃ x₄ wt wt₁) with reachdown-ana er wt₁
    ... | l , ih , m = move (child 3)  :: l ,
                       DoAna (AAMove EMCaseChild3) (ziplem-case3 x₁ x₂ x₄ wt x₃ ih) ,
                       AM:: m

  -- this is the final statement of the reachability triplet. the movement
  -- between judgemental and metafunctional erasure happens internally to
  -- theses statements to present a consistent interface with the text of
  -- the paper, while also allowing easy pattern matching in the proofs.
  --
  -- the intuition for these statements is that the cursor cannot change
  -- the type of things because the typing judgement is defined on the
  -- cursor-erased terms and types.
  reachability-types : (t1 t2 : ztyp) → (t1 ◆t) == (t2 ◆t) →
                       Σ[ L ∈ List action ] (runtype t1 L t2 × movements L)
  reachability-types t1 t2 eq
    with ◆erase-t t1 (t2 ◆t) eq | ◆erase-t t2 (t1 ◆t) (! eq)
  ... | er1 | er2 with reachup-type er1 | reachdown-type er2
  ... | (lup , rup , mvup)  | (ldwn , rdwn , mvdwn) =
        lup ++ ldwn ,
        runtype++ rup (tr (λ x → runtype ▹ x ◃ ldwn t2) eq rdwn) ,
        movements++ mvup mvdwn

  reachability-synth : (Γ : tctx) (t : htyp) (e1 e2 : zexp) →
                       Γ ⊢ e1 ◆e => t →
                       e1 ◆e == e2 ◆e →
                       Σ[ L ∈ List action ] (runsynth Γ e1 t L e2 t × movements L)
  reachability-synth Γ t e1 e2 wt1 eq
    with ◆erase-e e1 (e2 ◆e) eq | ◆erase-e e2 (e1 ◆e) (! eq)
  ... | er1 | er2 with reachup-synth er1 (tr (λ x → Γ ⊢ x => t) eq wt1)
                     | reachdown-synth er2 wt1
  ... | (lup , rup , mvup)  | (ldwn , rdwn , mvdwn) =
      (lup ++ ldwn) ,
      runsynth++ rup (tr (λ x → runsynth Γ ▹ x ◃ t ldwn e2 t) eq rdwn) ,
      movements++ mvup mvdwn

  reachability-ana : (Γ : tctx) (t : htyp) (e1 e2 : zexp) →
                     Γ ⊢ e1 ◆e <= t →
                     e1 ◆e == e2 ◆e →
                     Σ[ L ∈ List action ] (runana Γ e1 L e2 t × movements L)
  reachability-ana Γ t e1 e2 wt1 eq
    with ◆erase-e e1 (e2 ◆e) eq | ◆erase-e e2 (e1 ◆e) (! eq)
  ... | er1 | er2 with reachup-ana er1 (tr (λ x → Γ ⊢ x <= t) eq wt1)
                     | reachdown-ana er2 wt1
  ... | (lup , rup , mvup)  | (ldwn , rdwn , mvdwn) =
      lup ++ ldwn ,
      (runana++ rup (tr (λ x → runana Γ ▹ x ◃ ldwn e2 t) eq rdwn)) ,
      (movements++ mvup mvdwn)


module Numeral.Integer.Relation where


------------------------------------------------------------------------
-- Fixity and associativity
------------------------------------------------------------------------

module Mixfix.Fixity where

open import Data.Fin using (Fin; zero; suc; #_)
open import Data.Fin.Properties using (eq?)
open import Function.LeftInverse
open import Relation.Binary
open import Relation.Binary.PropositionalEquality as Eq

data Associativity : Set where
  left  : Associativity
  right : Associativity
  non   : Associativity

-- A combination of fixity and associativity. Only infix operators
-- have associativity.

-- Note that infix is a reserved word.

data Fixity : Set where
  prefx  : Fixity
  infx   : (assoc : Associativity) → Fixity
  postfx : Fixity
  closed : Fixity

Fixity-is-finite : LeftInverse (Eq.setoid Fixity) (Eq.setoid (Fin 6))
Fixity-is-finite = record
  { from            = Eq.→-to-⟶ from
  ; to              = Eq.→-to-⟶ to
  ; left-inverse-of = left-inverse-of
  }
  where
  to : Fixity → Fin 6
  to prefx        = # 0
  to (infx left)  = # 1
  to (infx right) = # 2
  to (infx non)   = # 3
  to postfx       = # 4
  to closed       = # 5

  from : Fin 6 → Fixity
  from zero                                   = prefx
  from (suc zero)                             = infx left
  from (suc (suc zero))                       = infx right
  from (suc (suc (suc zero)))                 = infx non
  from (suc (suc (suc (suc zero))))           = postfx
  from (suc (suc (suc (suc (suc zero)))))     = closed
  from (suc (suc (suc (suc (suc (suc ()))))))

  left-inverse-of : Eq.→-to-⟶ from LeftInverseOf Eq.→-to-⟶ to
  left-inverse-of prefx        = refl
  left-inverse-of (infx left)  = refl
  left-inverse-of (infx right) = refl
  left-inverse-of (infx non)   = refl
  left-inverse-of postfx       = refl
  left-inverse-of closed       = refl

_≟_ : Decidable (_≡_ {A = Fixity})
_≟_ = eq? injection
  where open LeftInverse Fixity-is-finite


------------------------------------------------------------------------
-- A small prelude
------------------------------------------------------------------------

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

-- Note that parts of Agda's standard library make use of the K rule.

module Prelude where

------------------------------------------------------------------------
-- Universes

-- Basic type universes and universe levels.

open import Agda.Primitive public
  renaming (Set to Type)
  using (Prop; Level; _⊔_; lzero; lsuc)

private
  variable
    a b c ℓ p                       : Level
    @0 A A₁ A₂ B B₁ B₂ C D Whatever : Type a
    @0 P Q R                        : A → Type p

-- Lifting.

record ↑ ℓ (A : Type a) : Type (a ⊔ ℓ) where
  constructor lift
  field lower : A

open ↑ public

------------------------------------------------------------------------
-- Strings

open import Agda.Builtin.String public using (String)

------------------------------------------------------------------------
-- The unit type

-- A variant of the unit type with η-equality.

open import Agda.Builtin.Unit public using (⊤; tt)

-- A variant without η-equality.

data Unit : Type where
  unit : Unit

-- Block s is used to block unfolding (for performance reasons). The
-- string can be used to indicate what it is that is blocked.

Block : String → Type
Block _ = Unit

pattern ⊠ = unit

-- A function that can be used to locally block something.

block : (Unit → A) → A
block f = f ⊠

-- A function that can be used to unblock something.

unblock : (b : Unit) (@0 P : Unit → Type p) → P ⊠ → P b
unblock ⊠ _ p = p

------------------------------------------------------------------------
-- The empty type

data ⊥ {ℓ} : Type ℓ where

⊥-elim : ⊥ {ℓ = ℓ} → Whatever
⊥-elim ()

-- A version of the empty type that is not universe-polymorphic.

⊥₀ : Type
⊥₀ = ⊥

-- Negation.

infix 3 ¬_

¬_ : Type ℓ → Type ℓ
¬ P = P → ⊥₀

------------------------------------------------------------------------
-- Natural numbers

open import Agda.Builtin.Nat public
  using (zero; suc; _+_; _*_)
  renaming (Nat to ℕ; _-_ to _∸_)

-- Dependent eliminator.

ℕ-rec : P 0 → (∀ n → P n → P (suc n)) → ∀ n → P n
ℕ-rec z s zero    = z
ℕ-rec z s (suc n) = s n (ℕ-rec z s n)

-- A non-recursive variant of ℕ-rec.

ℕ-case : P 0 → (∀ n → P (suc n)) → ∀ n → P n
ℕ-case z s = ℕ-rec z (λ n _ → s n)

-- Exponentiation.

infixr 8 _^_

_^_ : ℕ → ℕ → ℕ
m ^ zero  = 1
m ^ suc n = m * m ^ n

-- Factorial.

infix 9 _!

_! : ℕ → ℕ
zero  ! = 1
suc n ! = suc n * n !

-- Translation from natural numbers to levels.

# : ℕ → Level
# zero    = lzero
# (suc n) = lsuc (# n)

------------------------------------------------------------------------
-- Combinators defined using only abstraction and application

infixr 9 _∘_
infixl 1 _on_
infixr 0 _$_

-- The identity function.

id : A → A
id x = x

-- Composition.

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

-- "Equational" reasoning combinators.

infix  -1 finally-→
infixr -2 step-→

-- For an explanation of why step-⇔ is defined in this way, see
-- Equality.step-≡.

step-→ : (@0 A : Type a) → (B → C) → (A → B) → A → C
step-→ _ f g = f ∘ g

syntax step-→ A B→C A→B = A →⟨ A→B ⟩ B→C

finally-→ : (@0 A : Type a) (@0 B : Type b) → (A → B) → A → B
finally-→ _ _ A→B = A→B

syntax finally-→ A B A→B = A →⟨ A→B ⟩□ B □

-- Application.

_$_ :
  {@0 B : A → Type b} →
  ((x : A) → B x) → ((x : A) → B x)
f $ x = f x

-- Constant functions.

const : A → (B → A)
const x = λ _ → x

{-# DISPLAY const x y = x #-}

-- Flips the first two arguments.

flip :
  {@0 C : A → B → Type c} →
  ((x : A) (y : B) → C x y) → ((y : B) (x : A) → C x y)
flip f = λ x y → f y x

-- Applies the unary function to each argument and combines the
-- results using the binary function.

_on_ :
  {@0 C : B → B → Type c} →
  ((x y : B) → C x y) →
  (f : A → B) →
  ((x y : A) → C (f x) (f y))
_*_ on f = λ x y → f x * f y

-- A term's type.

Type-of : {A : Type a} → A → Type a
Type-of {A = A} _ = A

-- Type signatures.

infix 0 type-signature

type-signature : (@0 A : Type a) → A → A
type-signature _ a = a

syntax type-signature A a = a ⦂ A

-- The it function can be used to instantiate an argument by using
-- instance search.

it : ⦃ _ : A ⦄ → A
it ⦃ x ⦄ = x

-- Case expressions (to be used with pattern-matching lambdas).

infix 0 case_return_of_ case_of_

case_return_of_ :
  (x : A) (@0 B : A → Type b) → ((x : A) → B x) → B x
case x return B of f = f x

case_of_ : A → (A → B) → B
case x of f = case x return _ of f

------------------------------------------------------------------------
-- Σ-types

infixr 4 _,′_
infixr 2 _×_

open import Agda.Builtin.Sigma public
  using (Σ; _,_)
  hiding (module Σ)
  renaming (fst to proj₁; snd to proj₂)

module Σ where

  open Agda.Builtin.Sigma.Σ public
    using ()
    renaming (fst to proj₁; snd to proj₂)

  -- Variants of the projections with erased type arguments.

  proj₁₀ :
    {@0 B : A → Type b} →
    Σ A B → A
  proj₁₀ (x , y) = x

  proj₂₀ :
    {@0 B : A → Type b}
    (p : Σ A B) → B (proj₁ p)
  proj₂₀ (x , y) = y

open Σ public using (proj₁₀; proj₂₀)

-- A variant where the first argument is implicit.

∃ : {A : Type a} → (A → Type b) → Type (a ⊔ b)
∃ = Σ _

-- Binary products.

_×_ : (A : Type a) (B : Type b) → Type (a ⊔ b)
A × B = Σ A (const B)

-- A variant of _,_ that is specialised to _×_. Use of this variant
-- can make type-inference easier.

_,′_ : A → B → A × B
x ,′ y = x , y

-- A map function.

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

-- Zip.

Σ-zip :
  (f : A → B → C) → (∀ {x y} → P x → Q y → R (f x y)) →
  Σ A P → Σ B Q → Σ C R
Σ-zip f g = λ p q → (f (proj₁₀ p) (proj₁₀ q) , g (proj₂₀ p) (proj₂₀ q))

-- Curry and uncurry.

curry :
  {@0 B : A → Type b} {@0 C : Σ A B → Type c} →
  ((p : Σ A B) → C p) →
  ((x : A) (y : B x) → C (x , y))
curry f x y = f (x , y)

uncurry :
  {@0 B : A → Type b} {@0 C : Σ A B → Type c} →
  ((x : A) (y : B x) → C (x , y)) →
  ((p : Σ A B) → C p)
uncurry f (x , y) = f x y

-- Swaps the two components of the pair.

swap : A × B → B × A
swap (x , y) = y , x

------------------------------------------------------------------------
-- W-types

data W (A : Type a) (B : A → Type b) : Type (a ⊔ b) where
  sup : (x : A) (f : B x → W A B) → W A B

-- Projections.

headᵂ :
  {@0 B : A → Type b} →
  W A B → A
headᵂ (sup x f) = x

tailᵂ :
  {@0 B : A → Type b} →
  (x : W A B) → B (headᵂ x) → W A B
tailᵂ (sup x f) = f

-- If B is always inhabited, then W A B is empty.

abstract

  inhabited⇒W-empty :
    {@0 B : A → Type b} →
    (∀ x → B x) → ¬ W A B
  inhabited⇒W-empty b (sup x f) = inhabited⇒W-empty b (f (b x))

------------------------------------------------------------------------
-- Binary sums

infixr 1 _⊎_

data _⊎_ (A : Type a) (B : Type b) : Type (a ⊔ b) where
  inj₁ : (x : A) → A ⊎ B
  inj₂ : (y : B) → A ⊎ B

-- Eliminator for binary sums.

[_,_] :
  {@0 C : A ⊎ B → Type c} →
  ((x : A) → C (inj₁ x)) → ((x : B) → C (inj₂ x)) →
  ((x : A ⊎ B) → C x)
[ f , g ] (inj₁ x) = f x
[ f , g ] (inj₂ y) = g y

-- A generalisation of if-then-else.

infix 5 if_then_else_

if_then_else_ : A ⊎ B → C → C → C
if x then t else f = [ const t , const f ] x

-- A generalisation of not.

not : A ⊎ B → B ⊎ A
not (inj₁ x) = inj₂ x
not (inj₂ x) = inj₁ x

-- A map function.

⊎-map : (A₁ → A₂) → (B₁ → B₂) → A₁ ⊎ B₁ → A₂ ⊎ B₂
⊎-map f g = [ (λ x → inj₁ (f x)) , (λ x → inj₂ (g x)) ]

-- The function from-⊎ is a safe analogue of fromJust. For an example
-- of how from-⊎ can be used, see
-- Quotient.equivalence-but-not-strong-equivalence.

From-⊎ : {A B : Type ℓ} → A ⊎ B → Type ℓ
From-⊎ {A = A} (inj₁ _) = A
From-⊎ {B = B} (inj₂ _) = B

from-⊎ : (x : A ⊎ B) → From-⊎ x
from-⊎ (inj₁ x) = x
from-⊎ (inj₂ y) = y

-- A special case of binary sums: decided predicates.

Dec : Type p → Type p
Dec P = P ⊎ ¬ P

pattern yes p = inj₁ p
pattern no  p = inj₂ p

-- Decidable relations.

Decidable : {A : Type a} {B : Type b} →
            (A → B → Type ℓ) → Type (a ⊔ b ⊔ ℓ)
Decidable _∼_ = ∀ x y → Dec (x ∼ y)

-- Exclusive or.

infixr 1 _Xor_

_Xor_ : Type a → Type b → Type (a ⊔ b)
A Xor B = (A × ¬ B) ⊎ (¬ A × B)

-- Maybe.

Maybe : Type a → Type a
Maybe A = ⊤ ⊎ A

pattern nothing = inj₁ tt
pattern just x  = inj₂ x

-- The truth predicate T is only inhabited when its argument is
-- inj₁ something.

T : A ⊎ B → Type
T b = if b then ⊤ else ⊥

------------------------------------------------------------------------
-- Booleans

-- Booleans.

Bool : Type
Bool = ⊤ ⊎ ⊤

pattern true  = inj₁ tt
pattern false = inj₂ tt

-- And.

infixr 6 _∧_

_∧_ : Bool → Bool → Bool
b₁ ∧ b₂ = if b₁ then b₂ else false

-- Or.

infixr 5 _∨_

_∨_ : Bool → Bool → Bool
b₁ ∨ b₂ = if b₁ then true else b₂

------------------------------------------------------------------------
-- Lists

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

------------------------------------------------------------------------
-- Finite sets

Fin : ℕ → Type
Fin zero    = ⊥
Fin (suc n) = ⊤ ⊎ Fin n

pattern fzero  = inj₁ tt
pattern fsuc i = inj₂ i

------------------------------------------------------------------------
-- Some relation combinators

-- Combines two relations into a relation on functions.

_→-rel_ : {A : Type a} {C : Type c} →
          (A → C → Type ℓ) → (B → D → Type ℓ) →
          (A → B) → (C → D) → Type (a ⊔ c ⊔ ℓ)
(P →-rel Q) f g = ∀ x y → P x y → Q (f x) (g y)

-- Combines two relations into a relation on products.

_×-rel_ : (A → C → Type ℓ) → (B → D → Type ℓ) → A × B → C × D → Type ℓ
(P ×-rel Q) (x , u) (y , v) = P x y × Q u v

-- Combines two relations into a relation on sums.

_⊎-rel_ : (A → C → Type ℓ) → (B → D → Type ℓ) → A ⊎ B → C ⊎ D → Type ℓ
(P ⊎-rel Q) (inj₁ x) (inj₁ y) = P x y
(P ⊎-rel Q) (inj₁ x) (inj₂ v) = ⊥
(P ⊎-rel Q) (inj₂ u) (inj₁ y) = ⊥
(P ⊎-rel Q) (inj₂ u) (inj₂ v) = Q u v


{- LEMMAS FOR BOUNDING THEOREM WITH NEW COMPLEXITY LANGUAGE -}

open import Preliminaries
open import Source
open import Pilot
open import Translation-New

module Bounding-Lemmas-New where

  mutual
    valBound : ∀{τ} → (e : [] Source.|- τ) → val e → [] Pilot.|- ⟨⟨ τ ⟩⟩ → Set
    valBound .z z-isval E = z ≤s E
    valBound .(suc e) (suc-isval e v) E = Σ (λ E' → valBound e v E' × s E' ≤s E)
    valBound .(prod e1 e2) (pair-isval e1 e2 v1 v2) E = valBound e1 v1 (l-proj E) × valBound e2 v2 (r-proj E)
    valBound {τ1 ->s τ2} .(lam e) (lam-isval e) E = (v₁ : [] Source.|- τ1) (vv : val v₁)
                                                    (E1 : [] Pilot.|- ⟨⟨ τ1 ⟩⟩) →
                                                    valBound v₁ vv E1 →
                                                    expBound (Source.subst e (Source.q v₁)) (app E E1)
    valBound .unit unit-isval E = Unit
    valBound .(delay e) (delay-isval e) E = expBound e E
    valBound .nil nil-isval E = nil ≤s E
    valBound .(x ::s xs) (cons-isval x xs v v₁) E = Σ (λ E' → Σ (λ E'' → (valBound x v E' × valBound xs v₁ E'') × (E' ::c E'') ≤s E))
    valBound .true true-isval E = true ≤s E
    valBound .false false-isval E = false ≤s E

    expBound : ∀{τ} → [] Source.|- τ → [] Pilot.|- || τ || → Set
    expBound {τ} e b = (v₁ : [] Source.|- τ) (vv : val v₁) (n : Cost) →
                         evals e v₁ n → interp-Cost n ≤s l-proj b × valBound v₁ vv (r-proj b)

  mutual
    weakeningExp : ∀{τ} → (e : [] Source.|- τ) → (E E' : [] Pilot.|- || τ ||) → expBound e E → E ≤s E' → expBound e E'
    weakeningExp e c1 c2 d c1≤c2 e' ve' n i = trans-s (fst (d e' ve' n i)) (cong-lproj c1≤c2) ,
                                                      weakeningVal e' ve' (r-proj c1) (r-proj c2) (snd (d e' ve' n i)) (cong-rproj c1≤c2)

    weakeningVal : ∀{τ} → (v : [] Source.|- τ) → (vv : val v) → (E E' : [] Pilot.|- ⟨⟨ τ ⟩⟩) → valBound v vv E → E ≤s E' → valBound v vv E'
    weakeningVal {unit} unit unit-isval E E' vb e≤e' = <>
    weakeningVal {nat} .z z-isval E E' vb e≤e' = vb trans e≤e'
    weakeningVal {nat} .(suc e) (suc-isval e vv) E E' (i , vbi , si≤se) e≤e' = i , (vbi , (trans-s si≤se e≤e'))
    weakeningVal {susp τ} .(delay e) (delay-isval e) E E' vb e≤e' v₁ vv n x = weakeningExp e _ E' vb e≤e' v₁ vv n x
    weakeningVal {τ ->s τ₁} .(lam e) (lam-isval e) E E' vb e≤e' v₁ vv c1 x v₂ vv₁ n x₁ = (λ a va a' vba b b' n₁ x₂ →
                                                                                fst (vb a va a' vba b b' n₁ x₂) trans cong-lproj (cong-app e≤e') ,
                                                                                weakeningVal b b' (r-proj (app E a')) (r-proj (app E' a'))
                                                                                (snd (vb a va a' vba b b' n₁ x₂)) (cong-rproj (cong-app e≤e')))
                                                                                v₁ vv c1 x v₂ vv₁ n x₁
    weakeningVal {τ ×s τ₁} .(prod e1 e2) (pair-isval e1 e2 vv1 vv2) E E' vb e≤e' =
                    weakeningVal e1 vv1 (l-proj E) (l-proj E') (fst vb) (cong-lproj e≤e') ,
                    weakeningVal e2 vv2 (r-proj E) (r-proj E') (snd vb) (cong-rproj e≤e')
    weakeningVal {list τ} .nil nil-isval E E' vb e≤e' = vb trans e≤e'
    weakeningVal {list τ} .(x ::s xs) (cons-isval x xs vv vv₁) E E' (h , t , (hvb , tvb) , steps) e≤e' = h , (t , ((hvb , tvb) , (steps trans e≤e')))
    weakeningVal {bool} .true true-isval E E' vb e≤e' = vb trans e≤e'
    weakeningVal {bool} .false false-isval E E' vb e≤e' = vb trans e≤e'

  weakeningExp' : ∀{τ} {e : [] Source.|- τ} {E E' : [] Pilot.|- || τ ||} → expBound e E → E ≤s E' → expBound e E'
  weakeningExp' eb e≤ = weakeningExp _ _ _ eb e≤

  weakeningVal' : ∀{τ} { v : [] Source.|- τ} (vv : val v) {E E' : [] Pilot.|- ⟨⟨ τ ⟩⟩}
                → valBound v vv E → E ≤s E' → valBound v vv E'
  weakeningVal' vv v e = weakeningVal _ vv _ _ v e

  substVal : ∀{Γ} → (Θ : Source.sctx [] Γ) → Set
  substVal {Γ} Θ = {τ : _} (x : τ Source.∈ Γ) → val (Θ x)

  extend-substVal : ∀ {Γ' τ} {Θ : Source.sctx [] Γ'} {e : [] Source.|- τ}
                  → substVal Θ
                  → val e
                  → substVal (Source.lem3' Θ e)
  extend-substVal sv vv i0 = vv
  extend-substVal sv vv (iS x) = sv x

  extend-substVal2 : ∀ {Γ' τ1 τ2} {Θ : Source.sctx [] Γ'} {e : [] Source.|- τ1} {e' : [] Source.|- τ2}
                   → substVal Θ
                   → val e → val e'
                   → substVal (Source.lem4' Θ e e')
  extend-substVal2 sv vv vv' i0 = vv
  extend-substVal2 sv vv vv' (iS i0) = vv'
  extend-substVal2 sv vv vv' (iS (iS x)) = sv x

  extend-substVal3 : ∀ {Γ' τ1 τ2 τ3} {Θ : Source.sctx [] Γ'} {e : [] Source.|- τ1} {e' : [] Source.|- τ2} {e'' : [] Source.|- τ3}
                   → substVal Θ
                   → val e → val e' → val e''
                   → substVal (Source.lem5' Θ e e' e'')
  extend-substVal3 sv vv vv' vv'' i0 = vv
  extend-substVal3 sv vv vv' vv'' (iS i0) = vv'
  extend-substVal3 sv vv vv' vv'' (iS (iS i0)) = vv''
  extend-substVal3 sv vv vv' vv'' (iS (iS (iS x))) = sv x

  substBound : ∀{Γ} → (Θ : Source.sctx [] Γ) → substVal Θ → (Θ' : Pilot.sctx [] ⟨⟨ Γ ⟩⟩c) → Set
  substBound {Γ} Θ vΘ Θ' = {τ : _} (x : τ Source.∈ Γ) → valBound (Θ x) (vΘ x) (Θ' (lookup x))

  extend-substBound : ∀{Γ τ} → {Θ : Source.sctx [] Γ} {vΘ : substVal Θ} {Θ' : Pilot.sctx [] ⟨⟨ Γ ⟩⟩c}
                    → {e : [] Source.|- τ} {ve : val e} {E : [] Pilot.|- ⟨⟨ τ ⟩⟩}
                    → substBound Θ vΘ Θ'
                    → valBound e ve E
                    → substBound (Source.lem3' Θ e) (extend-substVal vΘ ve) (Pilot.lem3' Θ' E)
  extend-substBound sb vb i0 = vb
  extend-substBound sb vb (iS x) = sb x

  extend-substBound2 : ∀{Γ τ1 τ2} → {Θ : Source.sctx [] Γ} {vΘ : substVal Θ} {Θ' : Pilot.sctx [] ⟨⟨ Γ ⟩⟩c}
                     → {e : [] Source.|- τ1} {ve : val e} {e' : [] Source.|- τ2} {ve' : val e'}
                       {E : [] Pilot.|- ⟨⟨ τ1 ⟩⟩} {E' : [] Pilot.|- ⟨⟨ τ2 ⟩⟩}
                     → substBound Θ vΘ Θ'
                     → valBound e ve E → valBound e' ve' E'
                     → substBound (Source.lem4' Θ e e') (extend-substVal2 vΘ ve ve') (Pilot.lem4' Θ' E E')
  extend-substBound2 sb vbE vbE' i0 = vbE
  extend-substBound2 sb vbE vbE' (iS i0) = vbE'
  extend-substBound2 sb vbE vbE' (iS (iS x)) = sb x

  extend-substBound3 : ∀{Γ τ1 τ2 τ3} → {Θ : Source.sctx [] Γ} {vΘ : substVal Θ} {Θ' : Pilot.sctx [] ⟨⟨ Γ ⟩⟩c}
                     → {e : [] Source.|- τ1} {ve : val e} {e' : [] Source.|- τ2} {ve' : val e'} {e'' : [] Source.|- τ3} {ve'' : val e''}
                       {E : [] Pilot.|- ⟨⟨ τ1 ⟩⟩} {E' : [] Pilot.|- ⟨⟨ τ2 ⟩⟩} {E'' : [] Pilot.|- ⟨⟨ τ3 ⟩⟩}
                     → substBound Θ vΘ Θ'
                     → valBound e ve E → valBound e' ve' E' → valBound e'' ve'' E''
                     → substBound (Source.lem5' Θ e e' e'') (extend-substVal3 vΘ ve ve' ve'') (Pilot.lem5' Θ' E E' E'')
  extend-substBound3 sb vbE vbE' vbE'' i0 = vbE
  extend-substBound3 sb vbE vbE' vbE'' (iS i0) = vbE'
  extend-substBound3 sb vbE vbE' vbE'' (iS (iS i0)) = vbE''
  extend-substBound3 sb vbE vbE' vbE'' (iS (iS (iS x))) = sb x

  -- inversion lemma
  inv1 : ∀ {τ} {v v' : [] Source.|- τ} {n : Cost} → val v → evals v v' n → _≤s_{[]} (interp-Cost n) 0C
  inv1 z-isval z-evals = refl-s
  inv1 (suc-isval e v) (s-evals evals) = inv1 v evals
  inv1 (pair-isval e1 e2 v v₁) (pair-evals evals evals₁) = cong-+ (inv1 v evals) (inv1 v₁ evals₁) trans +-unit-l trans refl-s
  inv1 (lam-isval e) lam-evals = refl-s
  inv1 unit-isval unit-evals = refl-s
  inv1 (delay-isval e) delay-evals = refl-s
  inv1 nil-isval nil-evals = refl-s
  inv1 (cons-isval x xs v v₁) (cons-evals evals evals₁) = cong-+ (inv1 v evals) (inv1 v₁ evals₁) trans +-unit-l
  inv1 true-isval true-evals = refl-s
  inv1 false-isval false-evals = refl-s

  inv2 : ∀ {τ} {v e : [] Source.|- τ} {n : Cost} -> val v → evals v e n → v == e
  inv2 z-isval z-evals = Refl
  inv2 (suc-isval e₁ v) (s-evals evals) = ap suc (inv2 v evals)
  inv2 (pair-isval e1 e2 v v₁) (pair-evals evals evals₁) = ap2 prod (inv2 v evals) (inv2 v₁ evals₁)
  inv2 (lam-isval e₁) lam-evals = Refl
  inv2 unit-isval unit-evals = Refl
  inv2 (delay-isval e₁) delay-evals = Refl
  inv2 nil-isval nil-evals = Refl
  inv2 (cons-isval x xs v v₁) (cons-evals evals evals₁) = ap2 _::s_ (inv2 v evals) (inv2 v₁ evals₁)
  inv2 true-isval true-evals = Refl
  inv2 false-isval false-evals = Refl

  val-hprop : ∀ {τ} {v : [] Source.|- τ} → (d1 d2 : val v) → d1 == d2
  val-hprop z-isval z-isval = Refl
  val-hprop (suc-isval e d1) (suc-isval .e d2) = ap (suc-isval e) (val-hprop d1 d2)
  val-hprop (pair-isval e1 e2 d1 d2) (pair-isval .e1 .e2 d3 d4) = ap2 (pair-isval e1 e2) (val-hprop d1 d3) (val-hprop d2 d4)
  val-hprop (lam-isval e) (lam-isval .e) = Refl
  val-hprop unit-isval unit-isval = Refl
  val-hprop (delay-isval e) (delay-isval .e) = Refl
  val-hprop nil-isval nil-isval = Refl
  val-hprop (cons-isval x xs d1 d2) (cons-isval .x .xs d3 d4) = ap2 (cons-isval x xs) (val-hprop d1 d3) (val-hprop d2 d4)
  val-hprop true-isval true-isval = Refl
  val-hprop false-isval false-isval = Refl

  transport-valBound :  ∀{τ} {e e' : [] Source.|- τ} {d : val e} {d' : val e'}
                     → (α : e == e')
                     → transport val α d == d'
                     → (E : [] Pilot.|- ⟨⟨ τ ⟩⟩)
                     → valBound e d E → valBound e' d' E
  transport-valBound Refl Refl E vb = vb

  Eq0C-≤0 : ∀ {n} → Equals0c n → _≤s_{[]} (interp-Cost n) 0C
  Eq0C-≤0 Eq0-0c = refl-s
  Eq0C-≤0 (Eq0-+c e e₁) = cong-+ (Eq0C-≤0 e) (Eq0C-≤0 e₁) trans +-unit-l


open import Prelude
open import core

module grounding where
  grounding : ∀{ τ1 τ2} →
                             τ1 ▸gnd τ2 →
                             ((τ2 ground) × (τ1 ~ τ2) × (τ1 ≠ τ2))
  grounding (MGArr x) = GHole , TCArr TCHole1 TCHole1 , x


-- A formalised proof of the soundness and completeness of
-- a simply typed lambda-calculus with explicit substitutions
--
-- Catarina Coquand
--
-- Higher-Order and Symbolic Computation, 15, 57-90, 2002
--
-- http://dx.doi.org/10.1023/A:1019964114625

module Everything where

-- 1. Introduction
import Section1

-- 2. The proof editor
-- NOTE: Not relevant to this formalisation

-- 3. The calculus of proof trees
import Section3

-- 4. The semantic model
import Section4a
import Section4b

-- 5. Normal form
import Section5

-- 6. Application to terms
import Section6

-- 7. Correspondence between proof trees and terms
import Section7

-- 8. Correctness of conversion between terms
import Section8

-- 9. A decision algorithm for terms
import Section9

-- 10. Conclusions
import Section10


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

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

coe : {A B : Set} → A ≡ B → A → B
coe refl x = x

{-# BUILTIN REWRITE _≡_ #-}

Tel = Set
U = Set

variable
  Δ : Tel
  A B : Δ → U
  δ₀ δ₁ : Δ

postulate
  IdTel : (Δ : Tel)(δ₀ δ₁ : Δ) → Tel
  Id : (A : Δ → U){δ₀ δ₁ : Δ}(δ₂ : IdTel Δ δ₀ δ₁) → A δ₀ → A δ₁ → U
  ap : {A : Δ → U}(a : (δ : Δ) → A δ)
       → {δ₀ δ₁ : Δ}(δ₂ : IdTel Δ δ₀ δ₁) → Id A δ₂ (a δ₀) (a δ₁)

  idTel-sigma : {a₀ : A δ₀}{a₁ : A δ₁}
                → IdTel (Σ Δ A) (δ₀ , a₀) (δ₁ , a₁)
                  ≡ Σ (IdTel Δ δ₀ δ₁) (λ δ₂ → Id A δ₂ a₀ a₁)
  {-# REWRITE idTel-sigma #-}

  id-u : {A₀ A₁ : U}{δ₂ : IdTel Δ δ₀ δ₁}
         → Id {Δ = Δ}(λ _ → U) δ₂ A₀ A₁ ≡ (A₀ → A₁ → U)
  {-# REWRITE id-u #-}

  id-ap : {δ₂ : IdTel Δ δ₀ δ₁}{a₀ : A δ₀}{a₁ : A δ₁}
          → Id A δ₂ a₀ a₁ ≡ ap {A = λ _ → U} A δ₂ a₀ a₁

  ap-sigma : {δ₂ : IdTel Δ δ₀ δ₁}{a₀ : A δ₀}{a₁ : A δ₁}
             {B : (δ : Δ) → A δ → U}
             {b₀ : B δ₀ a₀}{b₁ : B δ₁ a₁}→
             ap {Δ = Δ}{A = λ _ → U} (λ δ → Σ (A δ) (B δ))
                δ₂ (a₀ , b₀) (a₁ , b₁) ≡
                Σ (Id A δ₂ a₀ a₁) λ a₂ → Id {Δ = Σ Δ A} (λ (δ , a) → B δ a) (δ₂ , a₂) b₀ b₁
  {-# REWRITE ap-sigma #-}
  {-# REWRITE id-ap #-}

  ap-proj₁ : {δ₂ : IdTel Δ δ₀ δ₁}
             {B : (δ : Δ) → A δ → U}
             {ab : (δ : Δ) → Σ (A δ) (B δ)}
             → ap {Δ = Δ}{A = A}(λ δ → fst (ab δ)) δ₂
               ≡ fst (ap ab δ₂)


-- Andreas, 2015-05-28 example by Andrea Vezzosi

open import Common.Size

data Nat (i : Size) : Set where
  zero : ∀ {j : Size< i} → Nat i
  suc  : ∀ {j : Size< i} → Nat j → Nat i

{-# TERMINATING #-}
-- This definition is fine, the termination checker is too strict at the moment.
fix : ∀ {C : Size → Set}
  → (∀{i} → (∀ {j : Size< i} → Nat j -> C j) → Nat i → C i)
  → ∀{i} → Nat i → C i
fix t zero    = t (fix t) zero
fix t (suc n) = t (fix t) (suc n)

case : ∀ {i} {C : Set} (n : Nat i) (z : C) (s : ∀ {j : Size< i} → Nat j → C) → C
case zero    z s = z
case (suc n) z s = s n

applyfix : ∀ {C : Size → Set} {i} (n : Nat i)
  → (∀{i} → (∀ {j : Size< i} → Nat j -> C j) → Nat i → C i)
  → C i
applyfix n f = fix f n

module M (i0 : Size) (bot : ∀{i} → Nat i) (A : Set) (default : A) where

  loops : A
  loops = applyfix (zero {i = ↑ i0}) λ {i} r _ →
      case {i} bot default λ n →   -- Size< i is possibly empty, should be rejected
      case     n   default λ _ →
      r zero

  -- loops
  -- --> fix t zero
  -- --> t (fix t) zero
  -- --> case bot default λ n → case n default λ _ → fix t zero
  -- and we have reproduced (modulo sizes) what we started with


{-
This second-order term syntax was created from the following second-order syntax description:

syntax Sub | S

type
  L : 0-ary
  T : 0-ary

term
  vr : L  ->  T
  sb : L.T  T  ->  T

theory
  (C) x y : T |> sb (a. x[], y[]) = x[]
  (L) x : T |> sb (a. vr(a), x[]) = x[]
  (R) a : L  x : L.T |> sb (b. x[b], vr(a[])) = x[a[]]
  (A) x : (L,L).T  y : L.T  z : T |> sb (a. sb (b. x[a,b], y[a]), z[]) = sb (b. sb (a. x[a, b], z[]), sb (a. y[a], z[]))
-}

module Sub.Syntax where

open import SOAS.Common
open import SOAS.Context
open import SOAS.Variable
open import SOAS.Families.Core
open import SOAS.Construction.Structure
open import SOAS.ContextMaps.Inductive

open import SOAS.Metatheory.Syntax

open import Sub.Signature

private
  variable
    Γ Δ Π : Ctx
    α : ST
    𝔛 : Familyₛ

-- Inductive term declaration
module S:Terms (𝔛 : Familyₛ) where

  data S : Familyₛ where
    var  : ℐ ⇾̣ S
    mvar : 𝔛 α Π → Sub S Π Γ → S α Γ

    vr : S L Γ → S T Γ
    sb : S T (L ∙ Γ) → S T Γ → S T Γ

  open import SOAS.Metatheory.MetaAlgebra ⅀F 𝔛

  Sᵃ : MetaAlg S
  Sᵃ = record
    { 𝑎𝑙𝑔 = λ where
      (vrₒ ⋮ a)     → vr a
      (sbₒ ⋮ a , b) → sb a b
    ; 𝑣𝑎𝑟 = var ; 𝑚𝑣𝑎𝑟 = λ 𝔪 mε → mvar 𝔪 (tabulate mε) }

  module Sᵃ = MetaAlg Sᵃ

  module _ {𝒜 : Familyₛ}(𝒜ᵃ : MetaAlg 𝒜) where

    open MetaAlg 𝒜ᵃ

    𝕤𝕖𝕞 : S ⇾̣ 𝒜
    𝕊 : Sub S Π Γ → Π ~[ 𝒜 ]↝ Γ
    𝕊 (t ◂ σ) new = 𝕤𝕖𝕞 t
    𝕊 (t ◂ σ) (old v) = 𝕊 σ v
    𝕤𝕖𝕞 (mvar 𝔪 mε) = 𝑚𝑣𝑎𝑟 𝔪 (𝕊 mε)
    𝕤𝕖𝕞 (var v) = 𝑣𝑎𝑟 v

    𝕤𝕖𝕞 (vr a)   = 𝑎𝑙𝑔 (vrₒ ⋮ 𝕤𝕖𝕞 a)
    𝕤𝕖𝕞 (sb a b) = 𝑎𝑙𝑔 (sbₒ ⋮ 𝕤𝕖𝕞 a , 𝕤𝕖𝕞 b)

    𝕤𝕖𝕞ᵃ⇒ : MetaAlg⇒ Sᵃ 𝒜ᵃ 𝕤𝕖𝕞
    𝕤𝕖𝕞ᵃ⇒ = record
      { ⟨𝑎𝑙𝑔⟩ = λ{ {t = t} → ⟨𝑎𝑙𝑔⟩ t }
      ; ⟨𝑣𝑎𝑟⟩ = refl
      ; ⟨𝑚𝑣𝑎𝑟⟩ = λ{ {𝔪 = 𝔪}{mε} → cong (𝑚𝑣𝑎𝑟 𝔪) (dext (𝕊-tab mε)) }  }
      where
      open ≡-Reasoning
      ⟨𝑎𝑙𝑔⟩ : (t : ⅀ S α Γ) → 𝕤𝕖𝕞 (Sᵃ.𝑎𝑙𝑔 t) ≡ 𝑎𝑙𝑔 (⅀₁ 𝕤𝕖𝕞 t)
      ⟨𝑎𝑙𝑔⟩ (vrₒ ⋮ _) = refl
      ⟨𝑎𝑙𝑔⟩ (sbₒ ⋮ _) = refl

      𝕊-tab : (mε : Π ~[ S ]↝ Γ)(v : ℐ α Π) → 𝕊 (tabulate mε) v ≡ 𝕤𝕖𝕞 (mε v)
      𝕊-tab mε new = refl
      𝕊-tab mε (old v) = 𝕊-tab (mε ∘ old) v

    module _ (g : S ⇾̣ 𝒜)(gᵃ⇒ : MetaAlg⇒ Sᵃ 𝒜ᵃ g) where

      open MetaAlg⇒ gᵃ⇒

      𝕤𝕖𝕞! : (t : S α Γ) → 𝕤𝕖𝕞 t ≡ g t
      𝕊-ix : (mε : Sub S Π Γ)(v : ℐ α Π) → 𝕊 mε v ≡ g (index mε v)
      𝕊-ix (x ◂ mε) new = 𝕤𝕖𝕞! x
      𝕊-ix (x ◂ mε) (old v) = 𝕊-ix mε v
      𝕤𝕖𝕞! (mvar 𝔪 mε) rewrite cong (𝑚𝑣𝑎𝑟 𝔪) (dext (𝕊-ix mε))
        = trans (sym ⟨𝑚𝑣𝑎𝑟⟩) (cong (g ∘ mvar 𝔪) (tab∘ix≈id mε))
      𝕤𝕖𝕞! (var v) = sym ⟨𝑣𝑎𝑟⟩

      𝕤𝕖𝕞! (vr a) rewrite 𝕤𝕖𝕞! a = sym ⟨𝑎𝑙𝑔⟩
      𝕤𝕖𝕞! (sb a b) rewrite 𝕤𝕖𝕞! a | 𝕤𝕖𝕞! b = sym ⟨𝑎𝑙𝑔⟩

-- Syntax instance for the signature
S:Syn : Syntax
S:Syn = record
  { ⅀F = ⅀F
  ; ⅀:CS = ⅀:CompatStr
  ; mvarᵢ = S:Terms.mvar
  ; 𝕋:Init = λ 𝔛 → let open S:Terms 𝔛 in record
    { ⊥ = S ⋉ Sᵃ
    ; ⊥-is-initial = record { ! = λ{ {𝒜 ⋉ 𝒜ᵃ} → 𝕤𝕖𝕞 𝒜ᵃ ⋉ 𝕤𝕖𝕞ᵃ⇒ 𝒜ᵃ }
    ; !-unique = λ{ {𝒜 ⋉ 𝒜ᵃ} (f ⋉ fᵃ⇒) {x = t} → 𝕤𝕖𝕞! 𝒜ᵃ f fᵃ⇒ t } } } }

-- Instantiation of the syntax and metatheory
open Syntax S:Syn public
open S:Terms public
open import SOAS.Families.Build public
open import SOAS.Syntax.Shorthands Sᵃ public
open import SOAS.Metatheory S:Syn public


------------------------------------------------------------------------
-- The Agda standard library
--
-- Lexicographic products of binary relations
------------------------------------------------------------------------

-- The definition of lexicographic product used here is suitable if
-- the left-hand relation is a (non-strict) partial order.

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

module Data.Product.Relation.Binary.Lex.NonStrict where

open import Data.Product using (_×_; _,_; proj₁; proj₂)
open import Data.Sum.Base using (inj₁; inj₂)
open import Level using (Level)
open import Relation.Binary
open import Relation.Binary.Consequences
import Relation.Binary.Construct.NonStrictToStrict as Conv
open import Data.Product.Relation.Binary.Pointwise.NonDependent as Pointwise
  using (Pointwise)
import Data.Product.Relation.Binary.Lex.Strict as Strict

private
  variable
    a b ℓ₁ ℓ₂ ℓ₃ ℓ₄ : Level
    A : Set a
    B : Set b

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

×-Lex : (_≈₁_ : Rel A ℓ₁) (_≤₁_ : Rel A ℓ₂) (_≤₂_ : Rel B ℓ₃) →
        Rel (A × B) _
×-Lex _≈₁_ _≤₁_ _≤₂_ = Strict.×-Lex _≈₁_ (Conv._<_ _≈₁_ _≤₁_) _≤₂_

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

×-reflexive : (_≈₁_ : Rel A ℓ₁) (_≤₁_ : Rel A ℓ₂)
              {_≈₂_ : Rel B ℓ₃} (_≤₂_ : Rel B ℓ₄) →
              _≈₂_ ⇒ _≤₂_ →
              (Pointwise _≈₁_ _≈₂_) ⇒ (×-Lex _≈₁_ _≤₁_ _≤₂_)
×-reflexive _≈₁_ _≤₁_ _≤₂_ refl₂ =
  Strict.×-reflexive _≈₁_ (Conv._<_ _≈₁_ _≤₁_) _≤₂_ refl₂

module _ {_≈₁_ : Rel A ℓ₁} {_≤₁_ : Rel A ℓ₂} {_≤₂_ : Rel B ℓ₃} where

  private
    _≤ₗₑₓ_ = ×-Lex _≈₁_ _≤₁_ _≤₂_

  ×-transitive : IsPartialOrder _≈₁_ _≤₁_ → Transitive _≤₂_ →
                 Transitive _≤ₗₑₓ_
  ×-transitive po₁ trans₂ =
    Strict.×-transitive {_≈₁_ = _≈₁_} {_<₂_ = _≤₂_}
      isEquivalence (Conv.<-resp-≈ _ _ isEquivalence ≤-resp-≈)
      (Conv.<-trans _ _ po₁)
      trans₂
    where open IsPartialOrder po₁

  ×-total : Symmetric _≈₁_ → Decidable _≈₁_ → Antisymmetric _≈₁_ _≤₁_ →
            Total _≤₁_ → Total _≤₂_ → Total _≤ₗₑₓ_
  ×-total sym₁ dec₁ antisym₁ total₁ total₂ =
    total
    where
    tri₁ : Trichotomous _≈₁_ (Conv._<_ _≈₁_ _≤₁_)
    tri₁ = Conv.<-trichotomous _ _ sym₁ dec₁ antisym₁ total₁

    total : Total _≤ₗₑₓ_
    total x y with tri₁ (proj₁ x) (proj₁ y)
    ... | tri< x₁<y₁ x₁≉y₁ x₁≯y₁ = inj₁ (inj₁ x₁<y₁)
    ... | tri> x₁≮y₁ x₁≉y₁ x₁>y₁ = inj₂ (inj₁ x₁>y₁)
    ... | tri≈ x₁≮y₁ x₁≈y₁ x₁≯y₁ with total₂ (proj₂ x) (proj₂ y)
    ...   | inj₁ x₂≤y₂ = inj₁ (inj₂ (x₁≈y₁ , x₂≤y₂))
    ...   | inj₂ x₂≥y₂ = inj₂ (inj₂ (sym₁ x₁≈y₁ , x₂≥y₂))

  ×-decidable : Decidable _≈₁_ → Decidable _≤₁_ → Decidable _≤₂_ →
                Decidable _≤ₗₑₓ_
  ×-decidable dec-≈₁ dec-≤₁ dec-≤₂ =
    Strict.×-decidable dec-≈₁ (Conv.<-decidable _ _ dec-≈₁ dec-≤₁)
                       dec-≤₂

module _ {_≈₁_ : Rel A ℓ₁} {_≤₁_ : Rel A ℓ₂}
         {_≈₂_ : Rel B ℓ₃} {_≤₂_ : Rel B ℓ₄}
         where

  private
    _≤ₗₑₓ_ = ×-Lex _≈₁_ _≤₁_ _≤₂_
    _≋_    = Pointwise _≈₁_ _≈₂_

  ×-antisymmetric : IsPartialOrder _≈₁_ _≤₁_ → Antisymmetric _≈₂_ _≤₂_ →
                   Antisymmetric _≋_ _≤ₗₑₓ_
  ×-antisymmetric po₁ antisym₂ =
    Strict.×-antisymmetric {_≈₁_ = _≈₁_} {_<₂_ = _≤₂_}
       ≈-sym₁ irrefl₁ asym₁ antisym₂
    where
    open IsPartialOrder po₁
    open Eq renaming (refl to ≈-refl₁; sym to ≈-sym₁)

    irrefl₁ : Irreflexive _≈₁_ (Conv._<_ _≈₁_ _≤₁_)
    irrefl₁ = Conv.<-irrefl _≈₁_ _≤₁_

    asym₁ : Asymmetric (Conv._<_ _≈₁_ _≤₁_)
    asym₁ = trans∧irr⟶asym {_≈_ = _≈₁_}
                           ≈-refl₁ (Conv.<-trans _ _ po₁) irrefl₁

  ×-respects₂ : IsEquivalence _≈₁_ →
                _≤₁_ Respects₂ _≈₁_ → _≤₂_ Respects₂ _≈₂_ →
                _≤ₗₑₓ_ Respects₂ _≋_
  ×-respects₂ eq₁ resp₁ resp₂ =
    Strict.×-respects₂ eq₁ (Conv.<-resp-≈ _ _ eq₁ resp₁) resp₂

------------------------------------------------------------------------
-- Structures

  ×-isPartialOrder : IsPartialOrder _≈₁_ _≤₁_ →
                     IsPartialOrder _≈₂_ _≤₂_ →
                     IsPartialOrder _≋_ _≤ₗₑₓ_
  ×-isPartialOrder po₁ po₂ = record
    { isPreorder = record
        { isEquivalence = Pointwise.×-isEquivalence
                            (isEquivalence po₁)
                            (isEquivalence po₂)
        ; reflexive     = ×-reflexive _≈₁_ _≤₁_ _≤₂_ (reflexive po₂)
        ; trans         = ×-transitive {_≤₂_ = _≤₂_} po₁ (trans po₂)
        }
    ; antisym = ×-antisymmetric po₁ (antisym po₂)
    }
    where open IsPartialOrder

  ×-isTotalOrder : Decidable _≈₁_ →
                   IsTotalOrder _≈₁_ _≤₁_ →
                   IsTotalOrder _≈₂_ _≤₂_ →
                   IsTotalOrder _≋_ _≤ₗₑₓ_
  ×-isTotalOrder ≈₁-dec to₁ to₂ = record
    { isPartialOrder = ×-isPartialOrder
                         (isPartialOrder to₁) (isPartialOrder to₂)
    ; total          = ×-total (Eq.sym to₁) ≈₁-dec
                                             (antisym to₁) (total to₁)
                               (total to₂)
    }
    where open IsTotalOrder

  ×-isDecTotalOrder : IsDecTotalOrder _≈₁_ _≤₁_ →
                      IsDecTotalOrder _≈₂_ _≤₂_ →
                      IsDecTotalOrder _≋_ _≤ₗₑₓ_
  ×-isDecTotalOrder to₁ to₂ = record
    { isTotalOrder = ×-isTotalOrder (_≟_ to₁)
                                    (isTotalOrder to₁)
                                    (isTotalOrder to₂)
    ; _≟_          = Pointwise.×-decidable (_≟_ to₁) (_≟_ to₂)
    ; _≤?_         = ×-decidable (_≟_ to₁) (_≤?_ to₁) (_≤?_ to₂)
    }
    where open IsDecTotalOrder

------------------------------------------------------------------------
-- Bundles

×-poset : Poset a ℓ₁ ℓ₂ → Poset b ℓ₃ ℓ₄ → Poset _ _ _
×-poset p₁ p₂ = record
  { isPartialOrder = ×-isPartialOrder O₁.isPartialOrder O₂.isPartialOrder
  } where module O₁ = Poset p₁; module O₂ = Poset p₂

×-totalOrder : DecTotalOrder a ℓ₁ ℓ₂ →
               TotalOrder b ℓ₃ ℓ₄ →
               TotalOrder _ _ _
×-totalOrder t₁ t₂ = record
  { isTotalOrder = ×-isTotalOrder T₁._≟_ T₁.isTotalOrder T₂.isTotalOrder
  } where module T₁ = DecTotalOrder t₁; module T₂ = TotalOrder t₂

×-decTotalOrder : DecTotalOrder a ℓ₁ ℓ₂ →
                  DecTotalOrder b ℓ₃ ℓ₄ →
                  DecTotalOrder _ _ _
×-decTotalOrder t₁ t₂ = record
  { isDecTotalOrder = ×-isDecTotalOrder O₁.isDecTotalOrder O₂.isDecTotalOrder
  } where module O₁ = DecTotalOrder t₁; module O₂ = DecTotalOrder t₂

------------------------------------------------------------------------
-- DEPRECATED NAMES
------------------------------------------------------------------------
-- Please use the new names as continuing support for the old names is
-- not guaranteed.

-- Version 0.15

_×-isPartialOrder_  = ×-isPartialOrder
{-# WARNING_ON_USAGE _×-isPartialOrder_
"Warning: _×-isPartialOrder_ was deprecated in v0.15.
Please use ×-isPartialOrder instead."
#-}
_×-isDecTotalOrder_ = ×-isDecTotalOrder
{-# WARNING_ON_USAGE _×-isDecTotalOrder_
"Warning: _×-isDecTotalOrder_ was deprecated in v0.15.
Please use ×-isDecTotalOrder instead."
#-}
_×-poset_           = ×-poset
{-# WARNING_ON_USAGE _×-poset_
"Warning: _×-poset_ was deprecated in v0.15.
Please use ×-poset instead."
#-}
_×-totalOrder_      = ×-totalOrder
{-# WARNING_ON_USAGE _×-totalOrder_
"Warning: _×-totalOrder_ was deprecated in v0.15.
Please use ×-totalOrder instead."
#-}
_×-decTotalOrder_   = ×-decTotalOrder
{-# WARNING_ON_USAGE _×-decTotalOrder_
"Warning: _×-decTotalOrder_ was deprecated in v0.15.
Please use ×-decTotalOrder instead."
#-}
×-≈-respects₂       = ×-respects₂
{-# WARNING_ON_USAGE ×-≈-respects₂
"Warning: ×-≈-respects₂ was deprecated in v0.15.
Please use ×-respects₂ instead."
#-}