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

module Space where

open import Data.Empty using (⊥; ⊥-elim)
open import Data.Nat using (ℕ; suc)
  renaming (_+_ to _ℕ+_; _*_ to _ℕ*_; _⊔_ to _ℕ⊔_)
open import Data.Nat.Properties
open import Data.Integer as ℤ using (ℤ; +_; -[1+_]; ∣_∣; _+_; _⊔_; -_)
open import Data.Rational
  using (ℚ)
  renaming (1/_ to recip)
open import Data.Sum using (_⊎_; inj₁; inj₂)
open import Data.Product using (_×_; _,_; proj₁; proj₂)
open import Data.Maybe
open import Relation.Nullary using (¬_; yes; no)
open import Relation.Binary.PropositionalEquality
  renaming ([_] to R[_])
  using (_≡_; refl; sym; trans; cong; inspect)
open import Data.Unit using (⊤; tt)

open import Singleton
open import PiFrac

------------------------------------------------------------------------------
-- Space denotational semantics

-- for each type, we calculate its memory requirements which are two
-- numbers (m , z). The number m represents the amount of space needed
-- to store values of the type. The number z represents the effect of
-- the value on space when it is interpreted. Ex. a gc process needs m
-- bits to be stored but when run it releases z bits.

-- Number of points in type
card : (t : 𝕌) → ℕ
card 𝟘 = 0
card 𝟙 = 1
card (t₁ +ᵤ t₂) = card t₁ ℕ+ card t₂
card (t₁ ×ᵤ t₂) = card t₁ ℕ* card t₂
card ● t [ v ] = 1
card 𝟙/● t [ v ] = 1

-- If number of points is zero then it is impossible to find a value
-- of the type
0empty : {t : 𝕌} → card t ≡ 0 → (v : ⟦ t ⟧) → ⊥
0empty {𝟘} _ ()
0empty {𝟙} () tt
0empty {t₁ +ᵤ t₂} s (inj₁ v₁)
  with card t₁ | card t₂ | inspect card t₁
0empty {t₁ +ᵤ t₂} refl (inj₁ v₁) | ℕ.zero | ℕ.zero | R[ s₁ ] =
  0empty {t₁} s₁ v₁
0empty {t₁ +ᵤ t₂} s (inj₂ v₂)
  with card t₁ | card t₂ | inspect card t₂
0empty {t₁ +ᵤ t₂} refl (inj₂ v₂) | ℕ.zero | ℕ.zero | R[ s₂ ] =
  0empty {t₂} s₂ v₂
0empty {t₁ ×ᵤ t₂} s (v₁ , v₂)
  with card t₁ | card t₂ | inspect card t₁ | inspect card t₂
0empty {t₁ ×ᵤ t₂} refl (v₁ , v₂) | ℕ.zero | _ | R[ s₁ ] | _ =
  0empty {t₁} s₁ v₁
0empty {t₁ ×ᵤ t₂} s (v₁ , v₂) | ℕ.suc n₁ | ℕ.zero | R[ s₁ ] | R[ s₂ ] =
  0empty {t₂} s₂ v₂
0empty {● t [ v ]} () (.v , refl)
0empty {𝟙/● t [ v ]} () f

-- Space effects

-- For a pointed type, even though we only have one value, that value
-- could be large and we need just as much space to store it as we
-- would need for any value of the given type. For a fractional type,
-- the effect is to de-allocate the space above.

space : (t : 𝕌) → {¬t≡0 : ¬ card t ≡ 0} → ℤ
space 𝟘 {0ne} = ⊥-elim (0ne refl)
space 𝟙 = + 0
space (t₁ +ᵤ t₂) {pne} with card t₁ | card t₂ | inspect card t₁ | inspect card t₂
... | 0 | 0 | R[ s₁ ] | R[ s₂ ] = ⊥-elim (pne refl)
... | 0 | suc n | R[ s₁ ] | R[ s₂ ] =
  space t₂ {λ t2≡0 → ⊥-elim (pne (trans (sym s₂) t2≡0))}
... | suc m | 0 | R[ s₁ ] | R[ s₂ ] =
  space t₁
    {λ t1≡0 →
      ⊥-elim (pne (trans (sym (trans s₁ (sym (+-identityʳ (suc m))))) t1≡0))}
... | suc m | suc n | R[ s₁ ] | R[ s₂ ] =
  + 1 + (space t₁ {λ t1≡0 → ⊥-elim (1+n≢0 (trans (sym s₁) t1≡0))} ⊔
         space t₂ {λ t2≡0 → ⊥-elim ((1+n≢0 (trans (sym s₂) t2≡0)))})
space (t₁ ×ᵤ t₂) {pne} with card t₁ | card t₂ | inspect card t₁ | inspect card t₂
... | 0 | 0 | R[ s₁ ] | R[ s₂ ] = ⊥-elim (pne refl)
... | 0 | suc n | R[ s₁ ] | R[ s₂ ] = ⊥-elim (pne refl)
... | suc m | 0 | R[ s₁ ] | R[ s₂ ] = ⊥-elim (pne (*-zeroʳ (suc m)))
... | suc m | suc n | R[ s₁ ] | R[ s₂ ] =
  space t₁ {λ t1≡0 → ⊥-elim (1+n≢0 (trans (sym s₁) t1≡0))} +
  space t₂ {λ t2≡0 → ⊥-elim (1+n≢0 (trans (sym s₂) t2≡0))}
space ● t [ v ]   = space t {λ t≡0 → 0empty t≡0 v}
space 𝟙/● t [ v ] = - space t {λ t≡0 → 0empty t≡0 v}

-- TODO

-- Every combinator preserves space effects

card= : (t₁ t₂ : 𝕌) (C : t₁ ⟷ t₂) → (card t₁ ≡ card t₂)
card= .(𝟘 +ᵤ t₂) t₂ unite₊l  = refl
card= t₁ .(𝟘 +ᵤ t₁) uniti₊l  = refl
card= .(t₂ +ᵤ 𝟘) t₂ unite₊r  rewrite +-identityʳ (card t₂) = refl
card= t₁ .(t₁ +ᵤ 𝟘) uniti₊r  rewrite +-identityʳ (card t₁) = refl
card= (t₁ +ᵤ t₂) _ swap₊  rewrite +-comm (card t₁) (card t₂) = refl
card= (t₁ +ᵤ t₂ +ᵤ t₃) _ assocl₊  rewrite +-assoc (card t₁) (card t₂) (card t₃) = refl
card= ((t₁ +ᵤ t₂) +ᵤ t₃) _ assocr₊  rewrite +-assoc (card t₁) (card t₂) (card t₃) = refl
card= (𝟙 ×ᵤ t₂) t₂ unite⋆l  rewrite +-identityʳ (card t₂) = refl
card= t₁ (𝟙 ×ᵤ t₁) uniti⋆l  rewrite +-identityʳ (card t₁) = refl
card= (t₂ ×ᵤ 𝟙) t₂ unite⋆r  rewrite *-identityʳ (card t₂) = refl
card= t₁ (t₁ ×ᵤ 𝟙) uniti⋆r  rewrite *-identityʳ (card t₁) = refl
card= (t₁ ×ᵤ t₂) _ swap⋆  rewrite *-comm (card t₁) (card t₂) = refl
card= (t₁ ×ᵤ t₂ ×ᵤ t₃) _ assocl⋆  rewrite *-assoc (card t₁) (card t₂) (card t₃) = refl
card= ((t₁ ×ᵤ t₂) ×ᵤ t₃) _ assocr⋆  rewrite *-assoc (card t₁) (card t₂) (card t₃) = refl
card= .(𝟘 ×ᵤ _) .𝟘 absorbr  = refl
card= (t ×ᵤ 𝟘) .𝟘 absorbl  rewrite *-zeroʳ (card t) = refl
card= .𝟘 (t ×ᵤ 𝟘) factorzr  rewrite *-zeroʳ (card t) = refl
card= .𝟘 .(𝟘 ×ᵤ _) factorzl  = refl
card= ((t₁ +ᵤ t₂) ×ᵤ t₃) _ dist  rewrite *-distribʳ-+ (card t₃) (card t₁) (card t₂) = refl
card= _ ((t₁ +ᵤ t₂) ×ᵤ t₃) factor  rewrite *-distribʳ-+ (card t₃) (card t₁) (card t₂) = refl
card= (t₃ ×ᵤ (t₁ +ᵤ t₂)) _ distl  rewrite *-distribˡ-+ (card t₃) (card t₁) (card t₂) = refl
card= _ (t₃ ×ᵤ (t₁ +ᵤ t₂)) factorl  rewrite *-distribˡ-+ (card t₃) (card t₁) (card t₂) = refl
card= t₁ .t₁ id⟷  = refl
card= t₁ t₂ (c₁ ⊚ c₂)  rewrite card= _ _ c₁ | card= _ _ c₂ = refl
card= (t₁ +ᵤ t₂) (t₃ +ᵤ t₄) (c₁ ⊕ c₂) rewrite card= _ _ c₁ | card= _ _ c₂ = refl
card= (t₁ ×ᵤ t₂) (t₃ ×ᵤ t₄) (c₁ ⊗ c₂) rewrite card= _ _ c₁ | card= _ _ c₂ = refl
card= .(● _ [ _ ]) .(● _ [ eval c _ ]) (lift c)  = refl
card= .(● _ ×ᵤ _ [ _ , _ ]) .(● _ [ _ ] ×ᵤ ● _ [ _ ]) tensorl  = refl
card= .(● _ [ _ ] ×ᵤ ● _ [ _ ]) .(● _ ×ᵤ _ [ _ , _ ]) tensorr  = refl
card= .(● _ +ᵤ _ [ inj₁ _ ]) .(● _ [ _ ]) plusll  = refl
card= .(● _ [ _ ]) .(● _ +ᵤ _ [ inj₁ _ ]) pluslr = refl
card= .(● _ +ᵤ _ [ inj₂ _ ]) .(● _ [ _ ]) plusrl  = refl
card= .(● _ [ _ ]) .(● _ +ᵤ _ [ inj₂ _ ]) plusrr = refl
card= .(𝟙/● _ ×ᵤ _ [ _ , _ ]) .(𝟙/● _ [ _ ] ×ᵤ 𝟙/● _ [ _ ]) fracl  = refl
card= .(𝟙/● _ [ _ ] ×ᵤ 𝟙/● _ [ _ ]) .(𝟙/● _ ×ᵤ _ [ _ , _ ]) fracr  = refl
card= .𝟙 .(● _ [ v ] ×ᵤ 𝟙/● _ [ v ]) (η v)  = refl
card= .(● _ [ v ] ×ᵤ 𝟙/● _ [ v ]) .𝟙 (ε v)  = refl
card= .(● _ [ _ ]) .(● _ [ _ ]) (== c x)  = refl
card= .(● (● t [ v ]) [ w ]) .(● t [ v ]) (ll {t} {v} {w}) = refl

space= : (t₁ t₂ : 𝕌) → (c : t₁ ⟷ t₂) → Set
space= t₁ t₂ c with card t₁ ≟ 0
space= t₁ t₂ c | yes _ = ⊤
space= t₁ t₂ c | no  nz₁ = space t₁ {nz₁} ≡ space t₂ {λ nz₂ → nz₁ (trans (card= _ _ c) nz₂)}

space≡ : (t₁ t₂ : 𝕌) → (c : t₁ ⟷ t₂) → space= t₁ t₂ c
space≡ t₁ t₂ c with card t₁ ≟ 0
space≡ t₁ t₂ c | yes _ = tt
space≡ t₁ t₂ c | no nz₁ = {!!}

-- Groupoid interpretation ???? Groupoid for pointed 1/A is point and
-- (size A) loops on point labeled (= a1), (= a2), (= a3), etc.

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


{-# OPTIONS --no-positivity-check #-}

module Section4a where

open import Section3 public

-- 4. The semantic model
-- =====================
--
-- As we want to deal with full conversion on open terms and the η-rule, we choose to describe
-- the semantics in a Kripke style model [6, 11, 15].  A Kripke model is a set of possible worlds,
-- `𝒲 : Set`, with a partial ordering `⊒ : 𝒲 → 𝒲 → Set`, of extensions of worlds.  We also have
-- a family of ground sets `𝒢 : 𝒲 → Set` over possible worlds which are the interpretation of
-- the base type.  We also need independence of the proof of `_⊒_`, i.e., if `c₁, c₂ : w′ ⊒ w`, then
-- `c₁ ≡ c₂`.  (…)

record Model : Set₁ where
  infix 3 _⊒_
  field
    𝒲     : Set
    _⊒_   : 𝒲 → 𝒲 → Set
    refl⊒ : ∀ {w} → w ⊒ w
    _◇_   : ∀ {w w′ w″} → w′ ⊒ w → w″ ⊒ w′ → w″ ⊒ w
    uniq⊒ : ∀ {w w′} → (c c′ : w′ ⊒ w) → c ≡ c′
    𝒢     : 𝒲 → Set
open Model {{…}} public

module _ {{_ : Model}} where
  trans⊒ : ∀ {w w′ w″} → w″ ⊒ w′ → w′ ⊒ w → w″ ⊒ w
  trans⊒ = flip _◇_

  id₁◇ : ∀ {w w′} → (c : w ⊒ w) (c′ : w′ ⊒ w) → c ◇ c′ ≡ c′
  id₁◇ c c′ = uniq⊒ (c ◇ c′) c′

  id₂◇ : ∀ {w w′} → (c : w′ ⊒ w) (c′ : w′ ⊒ w′) → c ◇ c′ ≡ c
  id₂◇ c c′ = uniq⊒ (c ◇ c′) c

  assoc◇ : ∀ {w w′ w″ w‴} → (c : w′ ⊒ w) (c′ : w″ ⊒ w′) (c″ : w‴ ⊒ w″) →
             c ◇ (c′ ◇ c″) ≡ (c ◇ c′) ◇ c″
  assoc◇ c c′ c″ = uniq⊒ (c ◇ (c′ ◇ c″)) ((c ◇ c′) ◇ c″)

  comp◇ : ∀ {w w′ w″} → (c : w′ ⊒ w) (c′ : w″ ⊒ w′) (c″ : w″ ⊒ w) →
            c ◇ c′ ≡ c″
  comp◇ c c′ c″ = uniq⊒ (c ◇ c′) c″

-- 4.1. Semantic objects
-- ---------------------
--
-- We define the set of semantic objects as usual in Kripke semantics.
--
-- Forcing is written `w ⊩ A`.  For the base type an element in `w ⊩ •` is a family of
-- elements in `𝒢 w′`, `w′ ⊒ w`.  For the type `A ⊃ B` an element in `w ⊩ A ⊃ B` is a family of
-- functions from `w′ ⊩ A` to `w′ ⊩ B`, `w′ ⊒ w`.  (…)

module _ {{_ : Model}} where
  -- TODO: Replace with strictly positive definition
  infix 3 _⊩_
  data _⊩_ : 𝒲 → 𝒯 → Set where
    ⟦𝒢⟧ : ∀ {w} →
            (∀ {w′} → w′ ⊒ w → 𝒢 w′) →
            w ⊩ •
    ⟦ƛ⟧ : ∀ {w A B} →
            (∀ {w′} → w′ ⊒ w → w′ ⊩ A → w′ ⊩ B) →
            w ⊩ A ⊃ B

-- We use the notational convention `⟦𝒢⟧` for the semantics of the ground type and
-- `⟦ƛ⟧` for the semantics of the function type.
--
-- We define the following two elimination rules:  (…)

module _ {{_ : Model}} where
  _⟦g⟧⟨_⟩ : ∀ {w w′} → w ⊩ • → w′ ⊒ w → 𝒢 w′
  (⟦𝒢⟧ f) ⟦g⟧⟨ c ⟩ = f c

  _⟦∙⟧⟨_⟩_ : ∀ {w w′ A B} → w ⊩ A ⊃ B → w′ ⊒ w → w′ ⊩ A → w′ ⊩ B
  (⟦ƛ⟧ f) ⟦∙⟧⟨ c ⟩ a = f c a

-- The monotonicity function `↑⟨_⟩⊩` lifts a semantic object in one world into a semantic object
-- in a bigger world and is defined by induction on the type.  (…)

module _ {{_ : Model}} where
  ↑⟨_⟩⊩ : ∀ {A w w′} → w′ ⊒ w → w ⊩ A → w′ ⊩ A
  ↑⟨_⟩⊩ {•}     c f = ⟦𝒢⟧ (λ c′   → f ⟦g⟧⟨ c ◇ c′ ⟩)
  ↑⟨_⟩⊩ {A ⊃ B} c f = ⟦ƛ⟧ (λ c′ a → f ⟦∙⟧⟨ c ◇ c′ ⟩ a)

  instance
    raise⊩ : ∀ {A} → Raiseable (_⊩ A)
    raise⊩ = record { ↑⟨_⟩ = ↑⟨_⟩⊩ }

-- We also need to define an equality, `Eq`, on semantic objects.  For the soundness of the
-- η-rule we need `f : w ⊩ A ⊃ B` to be equal to `⟦ƛ⟧ (λ c a → f ⟦∙⟧⟨ c ⟩ a)`, which corresponds
-- to η-expansion on the semantic level.  This means that the equality on our model must be
-- extensional and that application and the monotonicity function commutes, i.e., lifting the
-- result of an application up to a bigger world should be equal to first lifting the arguments and
-- then doing the application.  We say that a semantic object is uniform, `𝒰`, if the application and
-- monotonicity functions commute for this object (see Scott [17] for a discussion regarding
-- commutativity).  The predicates `Eq` and `𝒰` are mutually defined.
--
-- They both are defined by induction on the types; this way of defining extensionality is
-- presented by Gandy [10].  Two semantic objects of base type are equal if they are intensionally
-- equal in all bigger worlds and two semantic objects of function type are equal if the
-- application of them to a uniform semantic object in a bigger world is extensionally equal.
--
-- A semantic object of base type is always uniform.  A semantic object of function type is uniform
-- if it sends a uniform semantic object in a bigger world to a uniform semantic object,
-- if it sends two extensionally equal uniform objects in a bigger worlds to extensionally equal
-- semantic objects and if application and monotonicity commute for the semantic object.
--
-- The sets `Eq` and `𝒰` are defined by:  (…)

module _ {{_ : Model}} where
  mutual
    data Eq : ∀ {A w} → w ⊩ A → w ⊩ A → Set where
      eq• : ∀ {w} {f f′ : w ⊩ •} →
              (∀ {w′} →
                 (c : w′ ⊒ w) →
                 f ⟦g⟧⟨ c ⟩ ≡ f′ ⟦g⟧⟨ c ⟩) →
              Eq f f′
      eq⊃ : ∀ {A B w} {f f′ : w ⊩ A ⊃ B} →
              (∀ {w′} →
                 (c : w′ ⊒ w) → {a : w′ ⊩ A} → 𝒰 a →
                 Eq (f ⟦∙⟧⟨ c ⟩ a) (f′ ⟦∙⟧⟨ c ⟩ a)) →
              Eq f f′

    data 𝒰 : ∀ {A w} → w ⊩ A → Set where
      𝓊• : ∀ {w} {f : w ⊩ •} →
             𝒰 f
      𝓊⊃ : ∀ {A B w} {f : w ⊩ A ⊃ B} →
             (∀ {w′} →
                (c : w′ ⊒ w) → {a : w′ ⊩ A} → 𝒰 a →
                𝒰 (f ⟦∙⟧⟨ c ⟩ a)) →
             (∀ {w′} →
                (c : w′ ⊒ w) → {a a′ : w′ ⊩ A} → Eq a a′ → 𝒰 a → 𝒰 a′ →
                Eq (f ⟦∙⟧⟨ c ⟩ a) (f ⟦∙⟧⟨ c ⟩ a′)) →
             (∀ {w′ w″} →
                (c : w′ ⊒ w) (c′ : w″ ⊒ w′) (c″ : w″ ⊒ w) → {a : w′ ⊩ A} → 𝒰 a →
                Eq (↑⟨ c′ ⟩ (f ⟦∙⟧⟨ c ⟩ a)) (f ⟦∙⟧⟨ c″ ⟩ (↑⟨ c′ ⟩ a))) →
             𝒰 f

-- The equality `Eq` is transitive and symmetric and it is reflexive for uniform objects.

module _ {{_ : Model}} where
  reflEq : ∀ {A w} {a : w ⊩ A} → 𝒰 a → Eq a a
  reflEq 𝓊•            = eq• (λ c    → refl)
  reflEq (𝓊⊃ h₀ h₁ h₂) = eq⊃ (λ c uₐ → reflEq (h₀ c uₐ))

  -- TODO: Why do we restrict `Eq` so that it is reflexive only for uniform objects?
  reflEq′ : ∀ {A w} {a : w ⊩ A} → Eq a a
  reflEq′ {•}     = eq• (λ c    → refl)
  reflEq′ {A ⊃ B} = eq⊃ (λ c uₐ → reflEq′)

  symEq : ∀ {A w} {a a′ : w ⊩ A} → Eq a a′ → Eq a′ a
  symEq {•}     (eq• h) = eq• (λ c    → sym (h c))
  symEq {A ⊃ B} (eq⊃ h) = eq⊃ (λ c uₐ → symEq (h c uₐ))

  transEq : ∀ {A w} {a a′ a″ : w ⊩ A} → Eq a a′ → Eq a′ a″ → Eq a a″
  transEq {•}     (eq• h) (eq• h′) = eq• (λ c    → trans (h c) (h′ c))
  transEq {A ⊃ B} (eq⊃ h) (eq⊃ h′) = eq⊃ (λ c uₐ → transEq (h c uₐ) (h′ c uₐ))

module _ {{_ : Model}} where
  ≡→Eq : ∀ {A w} {a a′ : w ⊩ A} → 𝒰 a → a ≡ a′ → Eq a a′
  ≡→Eq u refl = reflEq u

  module EqReasoning where
    infix 1 begin_
    begin_ : ∀ {A w} {a a′ : w ⊩ A} → Eq a a′ → Eq a a′
    begin eq = eq

    infixr 2 _Eq⟨⟩_
    _Eq⟨⟩_ : ∀ {A w} (a {a′} : w ⊩ A) → Eq a a′ → Eq a a′
    a Eq⟨⟩ eq = eq

    infixr 2 _Eq⟨_⟩_
    _Eq⟨_⟩_ : ∀ {A w} (a {a′ a″} : w ⊩ A) → Eq a a′ → Eq a′ a″ → Eq a a″
    a Eq⟨ eq ⟩ eq′ = transEq eq eq′

    infixr 2 _≡⟨⟩_
    _≡⟨⟩_ : ∀ {A w} (a {a′} : w ⊩ A) → Eq a a′ → Eq a a′
    a ≡⟨⟩ eq = eq

    infixr 2 _≡⟨_∣_⟩_
    _≡⟨_∣_⟩_ : ∀ {A w} (a {a′ a″} : w ⊩ A) → a ≡ a′ → 𝒰 a → Eq a′ a″ → Eq a a″
    a ≡⟨ eq ∣ u ⟩ eq′ = transEq (≡→Eq u eq) eq′

    infix 3 _∎⟨_⟩
    _∎⟨_⟩ : ∀ {A w} (a : w ⊩ A) → 𝒰 a → Eq a a
    a ∎⟨ u ⟩ = reflEq u

-- Equal uniform values can be substituted in `⟦∙⟧⟨_⟩` and the function `↑⟨_⟩` returns uniform objects
-- for uniform input and equal results for equal input.

module _ {{_ : Model}} where
  cong⟦∙⟧⟨_⟩Eq : ∀ {A B w w′} {f f′ : w ⊩ A ⊃ B} {a a′ : w′ ⊩ A} →
                   (c : w′ ⊒ w) → Eq f f′ → 𝒰 f → 𝒰 f′ → Eq a a′ → 𝒰 a → 𝒰 a′ →
                   Eq (f ⟦∙⟧⟨ c ⟩ a) (f′ ⟦∙⟧⟨ c ⟩ a′)
  cong⟦∙⟧⟨ c ⟩Eq (eq⊃ h) (𝓊⊃ h₀ h₁ h₂) (𝓊⊃ h₀′ h₁′ h₂′) eqₐ uₐ uₐ′ =
    transEq (h₁ c eqₐ uₐ uₐ′) (h c uₐ′)

  cong↑⟨_⟩Eq : ∀ {A w w′} {a a′ : w ⊩ A} →
                 (c : w′ ⊒ w) → Eq a a′ →
                 Eq (↑⟨ c ⟩ a) (↑⟨ c ⟩ a′)
  cong↑⟨ c ⟩Eq (eq• h) = eq• (λ c′    → h (c ◇ c′))
  cong↑⟨ c ⟩Eq (eq⊃ h) = eq⊃ (λ c′ uₐ → h (c ◇ c′) uₐ)

  cong↑⟨_⟩𝒰 : ∀ {A w w′} {a : w ⊩ A} →
                (c : w′ ⊒ w) → 𝒰 a →
                𝒰 (↑⟨ c ⟩ a)
  cong↑⟨ c ⟩𝒰 𝓊•            = 𝓊•
  cong↑⟨ c ⟩𝒰 (𝓊⊃ h₀ h₁ h₂) = 𝓊⊃ (λ c′ uₐ         → h₀ (c ◇ c′) uₐ)
                                 (λ c′ eqₐ uₐ uₐ′ → h₁ (c ◇ c′) eqₐ uₐ uₐ′)
                                 (λ c′ c″ c‴ uₐ   → h₂ (c ◇ c′) c″ (c ◇ c‴) uₐ)

-- We also need to prove the following properties about `Eq` and `𝒰` which are used in the proofs of
-- soundness and completeness below.

module _ {{_ : Model}} where
  aux₄₁₁⟨_⟩ : ∀ {A w} →
                (c : w ⊒ w) → {a : w ⊩ A} → 𝒰 a →
                Eq (↑⟨ c ⟩ a) a
  aux₄₁₁⟨ c ⟩ {f} 𝓊•            = eq• (λ c′        → cong (f ⟦g⟧⟨_⟩)
                                                        (id₁◇ c c′))
  aux₄₁₁⟨ c ⟩ {f} (𝓊⊃ h₀ h₁ h₂) = eq⊃ (λ c′ {a} uₐ → ≡→Eq (h₀ (c ◇ c′) uₐ)
                                                        (cong (f ⟦∙⟧⟨_⟩ a)
                                                          (id₁◇ c c′)))

  aux₄₁₂ : ∀ {A w w′ w″} →
             (c : w′ ⊒ w) (c′ : w″ ⊒ w′) (c″ : w″ ⊒ w) → {a : w ⊩ A} → 𝒰 a →
             Eq (↑⟨ c′ ⟩ (↑⟨ c ⟩ a)) (↑⟨ c″ ⟩ a)
  aux₄₁₂ c c′ c″ {f} 𝓊•            = eq• (λ c‴        → cong (f ⟦g⟧⟨_⟩)
                                                           (trans (assoc◇ c c′ c‴)
                                                                  (comp◇ (c ◇ c′) c‴ (c″ ◇ c‴))))
  aux₄₁₂ c c′ c″ {f} (𝓊⊃ h₀ h₁ h₂) = eq⊃ (λ c‴ {a} uₐ → ≡→Eq (h₀ (c ◇ (c′ ◇ c‴)) uₐ)
                                                           (cong (f ⟦∙⟧⟨_⟩ a)
                                                             (trans (assoc◇ c c′ c‴)
                                                                    (comp◇ (c ◇ c′) c‴ (c″ ◇ c‴)))))
  aux₄₁₃ : ∀ {A B w w′} →
             (c : w′ ⊒ w) (c′ : w′ ⊒ w′) → {f : w ⊩ A ⊃ B} → 𝒰 f → {a : w′ ⊩ A} → 𝒰 a →
             Eq (f ⟦∙⟧⟨ c ⟩ a) (↑⟨ c ⟩ f ⟦∙⟧⟨ c′ ⟩ a)
  aux₄₁₃ c c′ {f} (𝓊⊃ h₀ h₁ h₂) {a} uₐ = ≡→Eq (h₀ c uₐ)
                                           (cong (f ⟦∙⟧⟨_⟩ a)
                                             (sym (id₂◇ c c′)))

-- 4.2. Semantic environments
-- --------------------------
--
-- We define the set of environments `_⊩⋆_`
-- where each variable in a context is associated with a semantic object.  (…)
--
-- The set is introduced by:  (…)

module _ {{_ : Model}} where
  infix 3 _⊩⋆_
  data _⊩⋆_ : 𝒲 → 𝒞 → Set where
    []      : ∀ {w} →
                w ⊩⋆ []
    [_,_≔_] : ∀ {Γ A w} →
                w ⊩⋆ Γ → (x : Name) {{_ : T (fresh x Γ)}} → w ⊩ A →
                w ⊩⋆ [ Γ , x ∷ A ]

-- We write `[]` for the empty environment and `[ ρ , x ≔ a ]` for updating an environment.
-- We define the following operations on semantic environments:
--
-- The function `lookup` is defined by induction on the environment.  (…)

module _ {{_ : Model}} where
  lookup : ∀ {Γ A w x} → w ⊩⋆ Γ → Γ ∋ x ∷ A → w ⊩ A
  lookup [ ρ , x ≔ a ] zero    = a
  lookup [ ρ , y ≔ b ] (suc i) = lookup ρ i

-- The function `↑⟨_⟩⊩⋆` that lifts
-- an environment into a bigger world is also defined by induction on the environment.  (…)

module _ {{_ : Model}} where
  ↑⟨_⟩⊩⋆ : ∀ {Γ w w′} → w′ ⊒ w → w ⊩⋆ Γ → w′ ⊩⋆ Γ
  ↑⟨ c ⟩⊩⋆ []            = []
  ↑⟨ c ⟩⊩⋆ [ ρ , x ≔ a ] = [ ↑⟨ c ⟩⊩⋆ ρ , x ≔ ↑⟨ c ⟩ a ]

  instance
    raise⊩⋆ : ∀ {Γ} → Raiseable (_⊩⋆ Γ)
    raise⊩⋆ = record { ↑⟨_⟩ = ↑⟨_⟩⊩⋆ }

-- The last function `↓⟨_⟩⊩⋆` is the projection on
-- environments and it is defined by induction on the proof of `Γ ⊇ Δ`.  (…)

module _ {{_ : Model}} where
  ↓⟨_⟩⊩⋆ : ∀ {Γ Δ w} → Γ ⊇ Δ → w ⊩⋆ Γ → w ⊩⋆ Δ
  ↓⟨ done ⟩⊩⋆             ρ = []
  ↓⟨ step {x = x} c i ⟩⊩⋆ ρ = [ ↓⟨ c ⟩⊩⋆ ρ , x ≔ lookup ρ i ]

  instance
    lower⊩⋆ : ∀ {w} → Lowerable (w ⊩⋆_)
    lower⊩⋆ = record { ↓⟨_⟩ = ↓⟨_⟩⊩⋆ }

-- We say that an environment is uniform `𝒰⋆ ρ : Set`, where `ρ : w ⊩⋆ Γ`, if each semantic
-- object in the environment is uniform.  Two environments are equal `Eq⋆ ρ ρ′ : Set`,
-- where `ρ, ρ′ : w ⊩⋆ Γ`, if they are equal component-wise.

module _ {{_ : Model}} where
  data Eq⋆ : ∀ {Γ w} → w ⊩⋆ Γ → w ⊩⋆ Γ → Set where
    eq⋆[] : ∀ {w} →
              Eq⋆ ([] {w}) ([] {w})
    eq⋆≔  : ∀ {Γ A w x} {{_ : T (fresh x Γ)}} {ρ ρ′ : w ⊩⋆ Γ} {a a′ : w ⊩ A} →
              Eq⋆ ρ ρ′ → Eq a a′ →
              Eq⋆ [ ρ , x ≔ a ] [ ρ′ , x ≔ a′ ]

  data 𝒰⋆ : ∀ {Γ w} → w ⊩⋆ Γ → Set where
    𝓊⋆[] : ∀ {w} →
             𝒰⋆ ([] {w})
    𝓊⋆≔  : ∀ {Γ A w x} {{_ : T (fresh x Γ)}} {ρ : w ⊩⋆ Γ} {a : w ⊩ A} →
             𝒰⋆ ρ → 𝒰 a →
             𝒰⋆ [ ρ , x ≔ a ]

-- The equality on semantic environments, `Eq⋆`, is transitive, symmetric, and for uniform
-- environments also reflexive.

module _ {{_ : Model}} where
  reflEq⋆ : ∀ {Γ w} {ρ : w ⊩⋆ Γ} → 𝒰⋆ ρ → Eq⋆ ρ ρ
  reflEq⋆ 𝓊⋆[]       = eq⋆[]
  reflEq⋆ (𝓊⋆≔ u⋆ u) = eq⋆≔ (reflEq⋆ u⋆) (reflEq u)

  symEq⋆ : ∀ {Γ w} {ρ ρ′ : w ⊩⋆ Γ} → Eq⋆ ρ ρ′ → Eq⋆ ρ′ ρ
  symEq⋆ eq⋆[]         = eq⋆[]
  symEq⋆ (eq⋆≔ eq⋆ eq) = eq⋆≔ (symEq⋆ eq⋆) (symEq eq)

  transEq⋆ : ∀ {Γ w} {ρ ρ′ ρ″ : w ⊩⋆ Γ} → Eq⋆ ρ ρ′ → Eq⋆ ρ′ ρ″ → Eq⋆ ρ ρ″
  transEq⋆ eq⋆[]         eq⋆[]           = eq⋆[]
  transEq⋆ (eq⋆≔ eq⋆ eq) (eq⋆≔ eq⋆′ eq′) = eq⋆≔ (transEq⋆ eq⋆ eq⋆′) (transEq eq eq′)

module _ {{_ : Model}} where
  ≡→Eq⋆ : ∀ {Γ w} {ρ ρ′ : w ⊩⋆ Γ} → 𝒰⋆ ρ → ρ ≡ ρ′ → Eq⋆ ρ ρ′
  ≡→Eq⋆ u⋆ refl = reflEq⋆ u⋆

  module Eq⋆Reasoning where
    infix 1 begin_
    begin_ : ∀ {Γ w} {ρ ρ′ : w ⊩⋆ Γ} → Eq⋆ ρ ρ′ → Eq⋆ ρ ρ′
    begin eq⋆ = eq⋆

    infixr 2 _Eq⋆⟨⟩_
    _Eq⋆⟨⟩_ : ∀ {Γ w} (ρ {ρ′} : w ⊩⋆ Γ) → Eq⋆ ρ ρ′ → Eq⋆ ρ ρ′
    ρ Eq⋆⟨⟩ eq⋆ = eq⋆

    infixr 2 _Eq⋆⟨_⟩_
    _Eq⋆⟨_⟩_ : ∀ {Γ w} (ρ {ρ′ ρ″} : w ⊩⋆ Γ) → Eq⋆ ρ ρ′ → Eq⋆ ρ′ ρ″ → Eq⋆ ρ ρ″
    ρ Eq⋆⟨ eq⋆ ⟩ eq⋆′ = transEq⋆ eq⋆ eq⋆′

    infixr 2 _≡⟨⟩_
    _≡⟨⟩_ : ∀ {Γ w} (ρ {ρ′} : w ⊩⋆ Γ) → Eq⋆ ρ ρ′ → Eq⋆ ρ ρ′
    ρ ≡⟨⟩ eq⋆ = eq⋆

    infixr 2 _≡⟨_∣_⟩_
    _≡⟨_∣_⟩_ : ∀ {Γ w} (ρ {ρ′ ρ″} : w ⊩⋆ Γ) → ρ ≡ ρ′ → 𝒰⋆ ρ → Eq⋆ ρ′ ρ″ → Eq⋆ ρ ρ″
    ρ ≡⟨ eq⋆ ∣ u⋆ ⟩ eq⋆′ = transEq⋆ (≡→Eq⋆ u⋆ eq⋆) eq⋆′

    infix 3 _∎⟨_⟩
    _∎⟨_⟩ : ∀ {Γ w} (ρ : w ⊩⋆ Γ) → 𝒰⋆ ρ → Eq⋆ ρ ρ
    ρ ∎⟨ u⋆ ⟩ = reflEq⋆ u⋆

-- We can substitute equal semantic environments in `lookup`, `↑⟨_⟩`, `↓⟨_⟩`
-- and the result of applying these functions to uniform environments is also uniform.

module _ {{_ : Model}} where
  conglookupEq : ∀ {Γ A w x} →
                   {ρ ρ′ : w ⊩⋆ Γ} → Eq⋆ ρ ρ′ → (i : Γ ∋ x ∷ A) →
                   Eq (lookup ρ i) (lookup ρ′ i)
  conglookupEq eq⋆[]         ()
  conglookupEq (eq⋆≔ eq⋆ eq) zero    = eq
  conglookupEq (eq⋆≔ eq⋆ eq) (suc i) = conglookupEq eq⋆ i

  cong↑⟨_⟩Eq⋆ : ∀ {Γ w w′} →
                  (c : w′ ⊒ w) → {ρ ρ′ : w ⊩⋆ Γ} → Eq⋆ ρ ρ′ →
                  Eq⋆ (↑⟨ c ⟩ ρ) (↑⟨ c ⟩ ρ′)
  cong↑⟨ c ⟩Eq⋆ eq⋆[]         = eq⋆[]
  cong↑⟨ c ⟩Eq⋆ (eq⋆≔ eq⋆ eq) = eq⋆≔ (cong↑⟨ c ⟩Eq⋆ eq⋆) (cong↑⟨ c ⟩Eq eq)

  cong↓⟨_⟩Eq⋆ : ∀ {Γ Δ w} →
                  (c : Γ ⊇ Δ) → {ρ ρ′ : w ⊩⋆ Γ} → Eq⋆ ρ ρ′ →
                  Eq⋆ (↓⟨ c ⟩ ρ) (↓⟨ c ⟩ ρ′)
  cong↓⟨ done ⟩Eq⋆     eq⋆ = eq⋆[]
  cong↓⟨ step c i ⟩Eq⋆ eq⋆ = eq⋆≔ (cong↓⟨ c ⟩Eq⋆ eq⋆) (conglookupEq eq⋆ i)

  conglookup𝒰 : ∀ {Γ A w x} →
                  {ρ : w ⊩⋆ Γ} → 𝒰⋆ ρ → (i : Γ ∋ x ∷ A) →
                  𝒰 (lookup ρ i)
  conglookup𝒰 𝓊⋆[]       ()
  conglookup𝒰 (𝓊⋆≔ u⋆ u) zero    = u
  conglookup𝒰 (𝓊⋆≔ u⋆ u) (suc i) = conglookup𝒰 u⋆ i

  cong↑⟨_⟩𝒰⋆ : ∀ {Γ w w′} →
                 (c : w′ ⊒ w) → {ρ : w ⊩⋆ Γ} → 𝒰⋆ ρ →
                 𝒰⋆ (↑⟨ c ⟩ ρ)
  cong↑⟨ c ⟩𝒰⋆ 𝓊⋆[]       = 𝓊⋆[]
  cong↑⟨ c ⟩𝒰⋆ (𝓊⋆≔ u⋆ u) = 𝓊⋆≔ (cong↑⟨ c ⟩𝒰⋆ u⋆) (cong↑⟨ c ⟩𝒰 u)

  cong↓⟨_⟩𝒰⋆ : ∀ {Γ Δ w} →
                 (c : Γ ⊇ Δ) → {ρ : w ⊩⋆ Γ} → 𝒰⋆ ρ →
                 𝒰⋆ (↓⟨ c ⟩ ρ)
  cong↓⟨ done ⟩𝒰⋆     u⋆ = 𝓊⋆[]
  cong↓⟨ step c i ⟩𝒰⋆ u⋆ = 𝓊⋆≔ (cong↓⟨ c ⟩𝒰⋆ u⋆) (conglookup𝒰 u⋆ i)

-- We also
-- need to prove the following properties about `Eq⋆` for semantic environments which basically
-- say that it doesn’t matter in which order we lift and project the substitution:

module _ {{_ : Model}} where
  aux₄₂₁⟨_⟩ : ∀ {Γ Δ A w x} →
                (c : Γ ⊇ Δ) → {ρ : w ⊩⋆ Γ} → 𝒰⋆ ρ → (i : Γ ∋ x ∷ A) (j : Δ ∋ x ∷ A) →
                Eq (lookup ρ i) (lookup (↓⟨ c ⟩ ρ) j)
  aux₄₂₁⟨ done ⟩      u⋆ i ()
  aux₄₂₁⟨ step c i′ ⟩ u⋆ i zero    rewrite uniq∋ i′ i
                                   = conglookupEq (reflEq⋆ u⋆) i
  aux₄₂₁⟨ step c i′ ⟩ u⋆ i (suc j) = aux₄₂₁⟨ c ⟩ u⋆ i j

  conglookup↑⟨_⟩Eq : ∀ {Γ A w w′ x} {ρ : w ⊩⋆ Γ} →
                       (c : w′ ⊒ w) → 𝒰⋆ ρ → (i : Γ ∋ x ∷ A) →
                       Eq (↑⟨ c ⟩ (lookup ρ i)) (lookup (↑⟨ c ⟩ ρ) i)
  conglookup↑⟨ c ⟩Eq 𝓊⋆[]       ()
  conglookup↑⟨ c ⟩Eq (𝓊⋆≔ u⋆ u) zero    = cong↑⟨ c ⟩Eq (reflEq u)
  conglookup↑⟨ c ⟩Eq (𝓊⋆≔ u⋆ u) (suc i) = conglookup↑⟨ c ⟩Eq u⋆ i

  aux₄₂₃ : ∀ {Γ Δ A w x} {{_ : T (fresh x Δ)}} {{_ : T (fresh x Γ)}} →
             (c : Γ ⊇ Δ) (c′ : [ Γ , x ∷ A ] ⊇ Δ) → {ρ : w ⊩⋆ Γ} → 𝒰⋆ ρ → {a : w ⊩ A} →
             Eq⋆ (↓⟨ c′ ⟩ [ ρ , x ≔ a ]) (↓⟨ c ⟩ ρ)
  aux₄₂₃               done       done               u⋆ = eq⋆[]
  aux₄₂₃ {x = x} {{φ}} (step c i) (step c′ zero)     u⋆ = elim⊥ (freshlem₁ x φ)
  aux₄₂₃ {x = x} {{φ}} (step c i) (step c′ (suc i′)) u⋆ rewrite uniq∋ i′ i
                                                        = eq⋆≔ (aux₄₂₃ {{freshlem₂ x φ}} c c′ u⋆)
                                                               (reflEq (conglookup𝒰 u⋆ i))

  aux₄₂₄⟨_⟩ : ∀ {Γ w} →
                (c : Γ ⊇ Γ) → {ρ : w ⊩⋆ Γ} → 𝒰⋆ ρ →
                Eq⋆ (↓⟨ c ⟩ ρ) ρ
  aux₄₂₄⟨ done ⟩     𝓊⋆[]       = eq⋆[]
  aux₄₂₄⟨ step c i ⟩ (𝓊⋆≔ u⋆ u) = eq⋆≔ (transEq⋆ (aux₄₂₃ refl⊇ c u⋆)
                                                 (aux₄₂₄⟨ refl⊇ ⟩ u⋆))
                                       (aux₄₂₁⟨ refl⊇ ⟩ (𝓊⋆≔ u⋆ u) i zero)

  aux₄₂₅⟨_⟩ : ∀ {Γ w} →
                (c : w ⊒ w) → {ρ : w ⊩⋆ Γ} → 𝒰⋆ ρ →
                Eq⋆ (↑⟨ c ⟩ ρ) ρ
  aux₄₂₅⟨ c ⟩ 𝓊⋆[]       = eq⋆[]
  aux₄₂₅⟨ c ⟩ (𝓊⋆≔ u⋆ u) = eq⋆≔ (aux₄₂₅⟨ c ⟩ u⋆) (aux₄₁₁⟨ c ⟩ u)

  aux₄₂₆ : ∀ {Γ Δ Θ w} →
             (c : Δ ⊇ Γ) (c′ : Θ ⊇ Δ) (c″ : Θ ⊇ Γ) → {ρ : w ⊩⋆ Θ} → 𝒰⋆ ρ →
             Eq⋆ (↓⟨ c ⟩ (↓⟨ c′ ⟩ ρ)) (↓⟨ c″ ⟩ ρ)
  aux₄₂₆ done        c′ done         u⋆ = eq⋆[]
  aux₄₂₆ (step c i)  c′ (step c″ i″) u⋆ = eq⋆≔ (aux₄₂₆ c c′ c″ u⋆)
                                               (symEq (aux₄₂₁⟨ c′ ⟩ u⋆ i″ i))

  aux₄₂₇ : ∀ {Γ w w′ w″} →
             (c : w′ ⊒ w) (c′ : w″ ⊒ w′) (c″ : w″ ⊒ w) → {ρ : w ⊩⋆ Γ} → 𝒰⋆ ρ →
             Eq⋆ (↑⟨ c′ ⟩ (↑⟨ c ⟩ ρ)) (↑⟨ c″ ⟩ ρ)
  aux₄₂₇ c c′ c″ 𝓊⋆[]       = eq⋆[]
  aux₄₂₇ c c′ c″ (𝓊⋆≔ u⋆ u) = eq⋆≔ (aux₄₂₇ c c′ c″ u⋆) (aux₄₁₂ c c′ c″ u)

  aux₄₂₈ : ∀ {Γ Δ w w′} →
             (c : Δ ⊇ Γ) (c′ : w′ ⊒ w) → {ρ : w ⊩⋆ Δ} → 𝒰⋆ ρ →
             Eq⋆ (↑⟨ c′ ⟩ (↓⟨ c ⟩ ρ)) (↓⟨ c ⟩ (↑⟨ c′ ⟩ ρ))
  aux₄₂₈ done       c′ u⋆ = eq⋆[]
  aux₄₂₈ (step c i) c′ u⋆ = eq⋆≔ (aux₄₂₈ c c′ u⋆) (conglookup↑⟨ c′ ⟩Eq u⋆ i)

-- These properties are used in the proofs of soundness and completeness below.

-- 4.3. The semantics of the λ-calculus
-- ------------------------------------
--
-- We define evaluation functions for proof trees and substitutions in a given environment:  (…)

module _ {{_ : Model}} where
  mutual
    ⟦_⟧ : ∀ {Γ A w} → Γ ⊢ A → w ⊩⋆ Γ → w ⊩ A
    ⟦ ν x i ⟧ ρ = lookup ρ i
    ⟦ ƛ x M ⟧ ρ = ⟦ƛ⟧ (λ c a → ⟦ M ⟧ [ ↑⟨ c ⟩ ρ , x ≔ a ])
    ⟦ M ∙ N ⟧ ρ = ⟦ M ⟧ ρ ⟦∙⟧⟨ refl⊒ ⟩ ⟦ N ⟧ ρ
    ⟦ M ▶ γ ⟧ ρ = ⟦ M ⟧ (⟦ γ ⟧ₛ ρ)

    ⟦_⟧ₛ : ∀ {Γ Δ w} → Δ ⋙ Γ → w ⊩⋆ Δ → w ⊩⋆ Γ
    ⟦ π⟨ c ⟩ ⟧ₛ        ρ = ↓⟨ c ⟩ ρ
    ⟦ γ ● γ′ ⟧ₛ        ρ = ⟦ γ ⟧ₛ (⟦ γ′ ⟧ₛ ρ)
    ⟦ [ γ , x ≔ M ] ⟧ₛ ρ = [ ⟦ γ ⟧ₛ ρ , x ≔ ⟦ M ⟧ ρ ]


------------------------------------------------------------------------
-- The Agda standard library
--
-- Basic lemmas showing that various types are related (isomorphic or
-- equivalent or…)
------------------------------------------------------------------------

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

module Function.Related.TypeIsomorphisms where

open import Algebra
import Algebra.FunctionProperties as FP
open import Axiom.Extensionality.Propositional using (Extensionality)
open import Algebra.Structures
open import Data.Empty using (⊥; ⊥-elim)
open import Data.Product as Prod hiding (swap)
open import Data.Product.Function.NonDependent.Propositional
open import Data.Sum as Sum
open import Data.Sum.Properties using (swap-involutive)
open import Data.Sum.Function.Propositional using (_⊎-cong_)
open import Data.Unit using (⊤)
open import Level using (Level; Lift; lower; 0ℓ; suc)
open import Function
open import Function.Equality using (_⟨$⟩_)
open import Function.Equivalence as Eq using (_⇔_; Equivalence)
open import Function.Inverse as Inv using (_↔_; Inverse; inverse)
open import Function.Related
open import Relation.Binary
open import Relation.Binary.PropositionalEquality as P using (_≡_; _≗_)
open import Relation.Nullary using (Dec; ¬_; yes; no)
open import Relation.Nullary.Decidable using (True)

------------------------------------------------------------------------
-- Properties of Σ and _×_

-- Σ is associative
Σ-assoc : ∀ {a b c}
            {A : Set a} {B : A → Set b} {C : (a : A) → B a → Set c} →
          Σ (Σ A B) (uncurry C) ↔ Σ A (λ a → Σ (B a) (C a))
Σ-assoc = inverse (λ where ((a , b) , c) → (a , b , c))
                  (λ where (a , b , c) → ((a , b) , c))
                  (λ _ → P.refl) (λ _ → P.refl)

-- × is commutative

×-comm : ∀ {a b} (A : Set a) (B : Set b) → (A × B) ↔ (B × A)
×-comm _ _ = inverse Prod.swap Prod.swap (λ _ → P.refl) λ _ → P.refl

-- × has ⊤ as its identity

×-identityˡ : ∀ ℓ → FP.LeftIdentity _↔_ (Lift ℓ ⊤) _×_
×-identityˡ _ _ = inverse proj₂ -,_ (λ _ → P.refl) (λ _ → P.refl)

×-identityʳ : ∀ ℓ → FP.RightIdentity _↔_ (Lift ℓ ⊤) _×_
×-identityʳ _ _ = inverse proj₁ (_, _) (λ _ → P.refl) (λ _ → P.refl)

×-identity : ∀ ℓ → FP.Identity _↔_ (Lift ℓ ⊤) _×_
×-identity ℓ = ×-identityˡ ℓ , ×-identityʳ ℓ

-- × has ⊥ has its zero

×-zeroˡ : ∀ ℓ → FP.LeftZero _↔_ (Lift ℓ ⊥) _×_
×-zeroˡ ℓ A = inverse proj₁ (⊥-elim ∘′ lower)
                      (⊥-elim ∘ lower ∘ proj₁) (⊥-elim ∘ lower)

×-zeroʳ : ∀ ℓ → FP.RightZero _↔_ (Lift ℓ ⊥) _×_
×-zeroʳ ℓ A = inverse proj₂ (⊥-elim ∘′ lower)
                     (⊥-elim ∘ lower ∘ proj₂) (⊥-elim ∘ lower)

×-zero : ∀ ℓ → FP.Zero _↔_ (Lift ℓ ⊥) _×_
×-zero ℓ  = ×-zeroˡ ℓ , ×-zeroʳ ℓ

------------------------------------------------------------------------
-- Properties of ⊎

-- ⊎ is associative

⊎-assoc : ∀ ℓ → FP.Associative {ℓ = ℓ} _↔_ _⊎_
⊎-assoc ℓ _ _ _ = inverse
  [ [ inj₁ , inj₂ ∘′ inj₁ ]′ , inj₂ ∘′ inj₂ ]′
  [ inj₁ ∘′ inj₁ , [ inj₁ ∘′ inj₂ , inj₂ ]′ ]′
  [ [ (λ _ → P.refl) , (λ _ → P.refl) ] , (λ _ → P.refl) ]
  [ (λ _ → P.refl) , [ (λ _ → P.refl) , (λ _ → P.refl) ] ]

-- ⊎ is commutative

⊎-comm : ∀ {a b} (A : Set a) (B : Set b) → (A ⊎ B) ↔ (B ⊎ A)
⊎-comm _ _ = inverse swap swap swap-involutive swap-involutive

-- ⊎ has ⊥ as its identity

⊎-identityˡ : ∀ ℓ → FP.LeftIdentity _↔_ (Lift ℓ ⊥) _⊎_
⊎-identityˡ _ _ = inverse [ (λ ()) , id ]′ inj₂
                          [ (λ ()) , (λ _ → P.refl) ] (λ _ → P.refl)

⊎-identityʳ : ∀ ℓ → FP.RightIdentity _↔_ (Lift ℓ ⊥) _⊎_
⊎-identityʳ _ _ = inverse [ id , (λ ()) ]′ inj₁
                          [ (λ _ → P.refl) , (λ ()) ] (λ _ → P.refl)

⊎-identity : ∀ ℓ → FP.Identity _↔_ (Lift ℓ ⊥) _⊎_
⊎-identity ℓ = ⊎-identityˡ ℓ , ⊎-identityʳ ℓ

------------------------------------------------------------------------
-- Properties of × and ⊎

-- × distributes over ⊎

×-distribˡ-⊎ : ∀ ℓ → FP._DistributesOverˡ_ {ℓ = ℓ} _↔_ _×_ _⊎_
×-distribˡ-⊎ ℓ _ _ _ = inverse
  (uncurry λ x → [ inj₁ ∘′ (x ,_) , inj₂ ∘′ (x ,_) ]′)
  [ Prod.map₂ inj₁ , Prod.map₂ inj₂ ]′
  (uncurry λ _ → [ (λ _ → P.refl) , (λ _ → P.refl) ])
  [ (λ _ → P.refl) , (λ _ → P.refl) ]

×-distribʳ-⊎ : ∀ ℓ → FP._DistributesOverʳ_ {ℓ = ℓ} _↔_ _×_ _⊎_
×-distribʳ-⊎ ℓ _ _ _ = inverse
  (uncurry [ curry inj₁ , curry inj₂ ]′)
  [ Prod.map₁ inj₁ , Prod.map₁ inj₂ ]′
  (uncurry [ (λ _ _ → P.refl) , (λ _ _ → P.refl) ])
  [ (λ _ → P.refl) , (λ _ → P.refl) ]

×-distrib-⊎ : ∀ ℓ → FP._DistributesOver_ {ℓ = ℓ} _↔_ _×_ _⊎_
×-distrib-⊎ ℓ = ×-distribˡ-⊎ ℓ , ×-distribʳ-⊎ ℓ

------------------------------------------------------------------------
-- ⊥, ⊤, _×_ and _⊎_ form a commutative semiring

-- ⊤, _×_ form a commutative monoid

×-isMagma : ∀ k ℓ → IsMagma {Level.suc ℓ} (Related ⌊ k ⌋) _×_
×-isMagma k ℓ = record
  { isEquivalence = SK-isEquivalence k ℓ
  ; ∙-cong        = _×-cong_
  }

×-magma : Symmetric-kind → (ℓ : Level) → Magma _ _
×-magma k ℓ = record
  { isMagma = ×-isMagma k ℓ
  }

×-isSemigroup : ∀ k ℓ → IsSemigroup {Level.suc ℓ} (Related ⌊ k ⌋) _×_
×-isSemigroup k ℓ = record
  { isMagma = ×-isMagma k ℓ
  ; assoc   = λ _ _ _ → ↔⇒ Σ-assoc
  }

×-semigroup : Symmetric-kind → (ℓ : Level) → Semigroup _ _
×-semigroup k ℓ = record
  { isSemigroup = ×-isSemigroup k ℓ
  }

×-isMonoid : ∀ k ℓ → IsMonoid (Related ⌊ k ⌋) _×_ (Lift ℓ ⊤)
×-isMonoid k ℓ = record
  { isSemigroup = ×-isSemigroup k ℓ
  ; identity    = (↔⇒ ∘ ×-identityˡ ℓ) , (↔⇒ ∘ ×-identityʳ ℓ)
  }

×-monoid : Symmetric-kind → (ℓ : Level) → Monoid _ _
×-monoid k ℓ = record
  { isMonoid = ×-isMonoid k ℓ
  }

×-isCommutativeMonoid : ∀ k ℓ → IsCommutativeMonoid (Related ⌊ k ⌋) _×_ (Lift ℓ ⊤)
×-isCommutativeMonoid k ℓ = record
  { isSemigroup = ×-isSemigroup k ℓ
  ; identityˡ   = ↔⇒ ∘ ×-identityˡ ℓ
  ; comm        = λ _ _ → ↔⇒ (×-comm _ _)
  }

×-commutativeMonoid : Symmetric-kind → (ℓ : Level) → CommutativeMonoid _ _
×-commutativeMonoid k ℓ = record
  { isCommutativeMonoid = ×-isCommutativeMonoid k ℓ
  }

-- ⊥, _⊎_ form a commutative monoid

⊎-isMagma : ∀ k ℓ → IsMagma {Level.suc ℓ} (Related ⌊ k ⌋) _⊎_
⊎-isMagma k ℓ = record
  { isEquivalence = SK-isEquivalence k ℓ
  ; ∙-cong        = _⊎-cong_
  }

⊎-magma : Symmetric-kind → (ℓ : Level) → Magma _ _
⊎-magma k ℓ = record
  { isMagma = ⊎-isMagma k ℓ
  }

⊎-isSemigroup : ∀ k ℓ → IsSemigroup {Level.suc ℓ} (Related ⌊ k ⌋) _⊎_
⊎-isSemigroup k ℓ = record
  { isMagma = ⊎-isMagma k ℓ
  ; assoc   = λ A B C → ↔⇒ (⊎-assoc ℓ A B C)
  }

⊎-semigroup : Symmetric-kind → (ℓ : Level) → Semigroup _ _
⊎-semigroup k ℓ = record
  { isSemigroup = ⊎-isSemigroup k ℓ
  }

⊎-isMonoid : ∀ k ℓ → IsMonoid (Related ⌊ k ⌋) _⊎_ (Lift ℓ ⊥)
⊎-isMonoid k ℓ = record
  { isSemigroup = ⊎-isSemigroup k ℓ
  ; identity    = (↔⇒ ∘ ⊎-identityˡ ℓ) , (↔⇒ ∘ ⊎-identityʳ ℓ)
  }

⊎-monoid : Symmetric-kind → (ℓ : Level) → Monoid _ _
⊎-monoid k ℓ = record
  { isMonoid = ⊎-isMonoid k ℓ
  }

⊎-isCommutativeMonoid : ∀ k ℓ → IsCommutativeMonoid (Related ⌊ k ⌋) _⊎_ (Lift ℓ ⊥)
⊎-isCommutativeMonoid k ℓ = record
  { isSemigroup = ⊎-isSemigroup k ℓ
  ; identityˡ   = ↔⇒ ∘ ⊎-identityˡ ℓ
  ; comm        = λ _ _ → ↔⇒ (⊎-comm _ _)
  }

⊎-commutativeMonoid : Symmetric-kind → (ℓ : Level) →
                      CommutativeMonoid _ _
⊎-commutativeMonoid k ℓ = record
  { isCommutativeMonoid = ⊎-isCommutativeMonoid k ℓ
  }

×-⊎-isCommutativeSemiring : ∀ k ℓ →
  IsCommutativeSemiring (Related ⌊ k ⌋) _⊎_ _×_ (Lift ℓ ⊥) (Lift ℓ ⊤)
×-⊎-isCommutativeSemiring k ℓ = record
  { +-isCommutativeMonoid = ⊎-isCommutativeMonoid k ℓ
  ; *-isCommutativeMonoid = ×-isCommutativeMonoid k ℓ
  ; distribʳ              = λ A B C → ↔⇒ (×-distribʳ-⊎ ℓ A B C)
  ; zeroˡ                 = ↔⇒ ∘ ×-zeroˡ ℓ
  }

×-⊎-commutativeSemiring : Symmetric-kind → (ℓ : Level) →
                          CommutativeSemiring (Level.suc ℓ) ℓ
×-⊎-commutativeSemiring k ℓ = record
  { isCommutativeSemiring = ×-⊎-isCommutativeSemiring k ℓ
  }

------------------------------------------------------------------------
-- Some reordering lemmas

ΠΠ↔ΠΠ : ∀ {a b p} {A : Set a} {B : Set b} (P : A → B → Set p) →
        ((x : A) (y : B) → P x y) ↔ ((y : B) (x : A) → P x y)
ΠΠ↔ΠΠ _ = inverse flip flip (λ _ → P.refl) (λ _ → P.refl)

∃∃↔∃∃ : ∀ {a b p} {A : Set a} {B : Set b} (P : A → B → Set p) →
        (∃₂ λ x y → P x y) ↔ (∃₂ λ y x → P x y)
∃∃↔∃∃ P = inverse to from (λ _ → P.refl) (λ _ → P.refl)
  where
  to : (∃₂ λ x y → P x y) → (∃₂ λ y x → P x y)
  to (x , y , Pxy) = (y , x , Pxy)

  from : (∃₂ λ y x → P x y) → (∃₂ λ x y → P x y)
  from (y , x , Pxy) = (x , y , Pxy)

------------------------------------------------------------------------
-- Implicit and explicit function spaces are isomorphic

Π↔Π : ∀ {a b} {A : Set a} {B : A → Set b} →
      ((x : A) → B x) ↔ ({x : A} → B x)
Π↔Π = inverse (λ f {x} → f x) (λ f x → f) (λ _ → P.refl) (λ _ → P.refl)

------------------------------------------------------------------------
-- _→_ preserves the symmetric relations

_→-cong-⇔_ :
  ∀ {a b c d} {A : Set a} {B : Set b} {C : Set c} {D : Set d} →
  A ⇔ B → C ⇔ D → (A → C) ⇔ (B → D)
A⇔B →-cong-⇔ C⇔D = Eq.equivalence
  (λ f x → Equivalence.to   C⇔D ⟨$⟩ f (Equivalence.from A⇔B ⟨$⟩ x))
  (λ f x → Equivalence.from C⇔D ⟨$⟩ f (Equivalence.to   A⇔B ⟨$⟩ x))

→-cong :
  ∀ {a b c d} →
  Extensionality a c → Extensionality b d →
  ∀ {k} {A : Set a} {B : Set b} {C : Set c} {D : Set d} →
  A ∼[ ⌊ k ⌋ ] B → C ∼[ ⌊ k ⌋ ] D → (A → C) ∼[ ⌊ k ⌋ ] (B → D)
→-cong extAC extBD {equivalence} A⇔B C⇔D = A⇔B →-cong-⇔ C⇔D
→-cong extAC extBD {bijection}   A↔B C↔D = record
  { to         = Equivalence.to   A→C⇔B→D
  ; from       = Equivalence.from A→C⇔B→D
  ; inverse-of = record
    { left-inverse-of  = λ f → extAC λ x → begin
        Inverse.from C↔D ⟨$⟩ (Inverse.to C↔D ⟨$⟩
          f (Inverse.from A↔B ⟨$⟩ (Inverse.to A↔B ⟨$⟩ x)))  ≡⟨ Inverse.left-inverse-of C↔D _ ⟩
        f (Inverse.from A↔B ⟨$⟩ (Inverse.to A↔B ⟨$⟩ x))     ≡⟨ P.cong f $ Inverse.left-inverse-of A↔B x ⟩
        f x                                                 ∎
    ; right-inverse-of = λ f → extBD λ x → begin
        Inverse.to C↔D ⟨$⟩ (Inverse.from C↔D ⟨$⟩
          f (Inverse.to A↔B ⟨$⟩ (Inverse.from A↔B ⟨$⟩ x)))  ≡⟨ Inverse.right-inverse-of C↔D _ ⟩
        f (Inverse.to A↔B ⟨$⟩ (Inverse.from A↔B ⟨$⟩ x))     ≡⟨ P.cong f $ Inverse.right-inverse-of A↔B x ⟩
        f x                                                 ∎
    }
  }
  where
  open P.≡-Reasoning
  A→C⇔B→D = ↔⇒ A↔B →-cong-⇔ ↔⇒ C↔D

------------------------------------------------------------------------
-- ¬_ preserves the symmetric relations

¬-cong-⇔ : ∀ {a b} {A : Set a} {B : Set b} →
           A ⇔ B → (¬ A) ⇔ (¬ B)
¬-cong-⇔ A⇔B = A⇔B →-cong-⇔ (⊥ ∎)
  where open EquationalReasoning

¬-cong : ∀ {a b} → Extensionality a 0ℓ → Extensionality b 0ℓ →
         ∀ {k} {A : Set a} {B : Set b} →
         A ∼[ ⌊ k ⌋ ] B → (¬ A) ∼[ ⌊ k ⌋ ] (¬ B)
¬-cong extA extB A≈B = →-cong extA extB A≈B (⊥ ∎)
  where open EquationalReasoning

------------------------------------------------------------------------
-- _⇔_ preserves _⇔_

-- The type of the following proof is a bit more general.

Related-cong :
  ∀ {k a b c d} {A : Set a} {B : Set b} {C : Set c} {D : Set d} →
  A ∼[ ⌊ k ⌋ ] B → C ∼[ ⌊ k ⌋ ] D → (A ∼[ ⌊ k ⌋ ] C) ⇔ (B ∼[ ⌊ k ⌋ ] D)
Related-cong {A = A} {B} {C} {D} A≈B C≈D =
  Eq.equivalence (λ A≈C → B  ∼⟨ SK-sym A≈B ⟩
                          A  ∼⟨ A≈C ⟩
                          C  ∼⟨ C≈D ⟩
                          D  ∎)
                 (λ B≈D → A  ∼⟨ A≈B ⟩
                          B  ∼⟨ B≈D ⟩
                          D  ∼⟨ SK-sym C≈D ⟩
                          C  ∎)
  where open EquationalReasoning

------------------------------------------------------------------------
-- A lemma relating True dec and P, where dec : Dec P

True↔ : ∀ {p} {P : Set p}
        (dec : Dec P) → ((p₁ p₂ : P) → p₁ ≡ p₂) → True dec ↔ P
True↔ (yes p) irr = inverse (λ _ → p) (λ _ → _) (λ _ → P.refl) (irr p)
True↔ (no ¬p) _   = inverse (λ()) ¬p (λ()) (⊥-elim ∘ ¬p)

------------------------------------------------------------------------
-- Equality between pairs can be expressed as a pair of equalities

Σ-≡,≡↔≡ : ∀ {a b} {A : Set a} {B : A → Set b} {p₁ p₂ : Σ A B} →
          (∃ λ (p : proj₁ p₁ ≡ proj₁ p₂) →
             P.subst B p (proj₂ p₁) ≡ proj₂ p₂) ↔
          (p₁ ≡ p₂)
Σ-≡,≡↔≡ {A = A} {B} = inverse to from left-inverse-of right-inverse-of
  where
  to : {p₁ p₂ : Σ A B} →
       Σ (proj₁ p₁ ≡ proj₁ p₂)
         (λ p → P.subst B p (proj₂ p₁) ≡ proj₂ p₂) →
       p₁ ≡ p₂
  to (P.refl , P.refl) = P.refl

  from : {p₁ p₂ : Σ A B} →
         p₁ ≡ p₂ →
         Σ (proj₁ p₁ ≡ proj₁ p₂)
           (λ p → P.subst B p (proj₂ p₁) ≡ proj₂ p₂)
  from P.refl = P.refl , P.refl

  left-inverse-of : {p₁ p₂ : Σ A B}
                    (p : Σ (proj₁ p₁ ≡ proj₁ p₂)
                           (λ x → P.subst B x (proj₂ p₁) ≡ proj₂ p₂)) →
                    from (to p) ≡ p
  left-inverse-of (P.refl , P.refl) = P.refl

  right-inverse-of : {p₁ p₂ : Σ A B} (p : p₁ ≡ p₂) → to (from p) ≡ p
  right-inverse-of P.refl = P.refl

×-≡,≡↔≡ : ∀ {a b} {A : Set a} {B : Set b} {p₁ p₂ : A × B} →
          (proj₁ p₁ ≡ proj₁ p₂ × proj₂ p₁ ≡ proj₂ p₂) ↔ p₁ ≡ p₂
×-≡,≡↔≡ {A = A} {B} = inverse to from left-inverse-of right-inverse-of
  where
  to : {p₁ p₂ : A × B} →
       (proj₁ p₁ ≡ proj₁ p₂) × (proj₂ p₁ ≡ proj₂ p₂) → p₁ ≡ p₂
  to (P.refl , P.refl) = P.refl

  from : {p₁ p₂ : A × B} → p₁ ≡ p₂ →
         (proj₁ p₁ ≡ proj₁ p₂) × (proj₂ p₁ ≡ proj₂ p₂)
  from P.refl = P.refl , P.refl

  left-inverse-of : {p₁ p₂ : A × B} →
                    (p : (proj₁ p₁ ≡ proj₁ p₂) × (proj₂ p₁ ≡ proj₂ p₂)) →
                    from (to p) ≡ p
  left-inverse-of (P.refl , P.refl) = P.refl

  right-inverse-of : {p₁ p₂ : A × B} (p : p₁ ≡ p₂) → to (from p) ≡ p
  right-inverse-of P.refl = P.refl

×-≡×≡↔≡,≡ : ∀ {a b} {A : Set a} {B : Set b} {x y} (p : A × B) →
            (x ≡ proj₁ p × y ≡ proj₂ p) ↔ (x , y) ≡ p
×-≡×≡↔≡,≡ {x = x} {y} p = inverse to from from∘to to∘from
   where
   to : (x ≡ proj₁ p × y ≡ proj₂ p) → (x , y) ≡ p
   to = uncurry $ P.cong₂ _,_

   from : (x , y) ≡ p → (x ≡ proj₁ p × y ≡ proj₂ p)
   from = < P.cong proj₁ , P.cong proj₂ >

   from∘to : ∀ v → from (to v) ≡ v
   from∘to (P.refl , P.refl) = P.refl

   to∘from : ∀ v → to (from v) ≡ v
   to∘from P.refl = P.refl

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

-- Version 0.17

×-CommutativeMonoid = ×-commutativeMonoid
{-# WARNING_ON_USAGE ×-CommutativeMonoid
"Warning: ×-CommutativeMonoid was deprecated in v0.17.
Please use ×-commutativeMonoid instead."
#-}
⊎-CommutativeMonoid = ⊎-commutativeMonoid
{-# WARNING_ON_USAGE ⊎-CommutativeMonoid
"Warning: ⊎-CommutativeMonoid was deprecated in v0.17.
Please use ⊎-commutativeMonoid instead."
#-}
×⊎-CommutativeSemiring = ×-⊎-commutativeSemiring
{-# WARNING_ON_USAGE ×⊎-CommutativeSemiring
"Warning: ×⊎-CommutativeSemiring was deprecated in v0.17.
Please use ×-⊎-commutativeSemiring instead."
#-}


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

module Perm where

-- Definitions for permutations in the Cauchy representation

open import Level using (Level; _⊔_) renaming (zero to lzero; suc to lsuc)

open import Relation.Unary using (Pred)
  renaming (Decidable to UnaryDecidable)
open import Relation.Binary.PropositionalEquality
  using (_≡_; refl; sym; trans; subst; subst₂; cong; cong₂; setoid;
        proof-irrelevance; module ≡-Reasoning)
open import Relation.Binary.PropositionalEquality.TrustMe
  using (trustMe)
open import Relation.Nullary using (Dec; yes; no; ¬_)
open import Data.Nat.Properties
  using (cancel-+-left; n∸n≡0; +-∸-assoc; m+n∸n≡m; 1+n≰n; m≤m+n;
         n≤m+n; n≤1+n; cancel-*-right-≤; ≰⇒>; ¬i+1+j≤i)
open import Data.Nat.Properties.Simple
  using (+-right-identity; +-suc; +-assoc; +-comm;
        *-assoc; *-comm; *-right-zero; distribʳ-*-+; +-*-suc)
open import Data.Nat.DivMod using (DivMod; result; _divMod_; _div_; _mod_)
open import Relation.Binary using (Rel; Decidable; Setoid)
open import Relation.Binary.Core using (REL; Transitive; _⇒_)

open import Data.String using (String)
  renaming (_++_ to _++S_)
open import Data.Nat.Show using (show)
open import Data.Bool using (Bool; false; true)
open import Data.Nat using (ℕ; suc; _+_; _∸_; _*_; _<_; _≮_; _≤_; _≰_;
  _≥_; z≤n; s≤s; _≟_; _≤?_; ≤-pred; module ≤-Reasoning)
open import Data.Fin
  using (Fin; zero; suc; toℕ; fromℕ; fromℕ≤; _ℕ-_; _≺_; reduce≥;
         raise; inject+; inject₁; inject≤; _≻toℕ_)
  renaming (_+_ to _F+_)
open import Data.Fin.Properties
  using (bounded; to-from; inject+-lemma; inject≤-lemma; toℕ-injective;
         toℕ-raise; toℕ-fromℕ≤)
open import Data.Vec.Properties
  using (lookup∘tabulate; tabulate∘lookup; lookup-allFin; tabulate-∘;
         tabulate-allFin; allFin-map; lookup-++-inject+; lookup-++-≥;
         lookup-++-<)
open import Data.Product using (Σ; swap)

open import Data.List
  using (List; []; _∷_; _∷ʳ_; foldl; replicate; reverse; downFrom;
         concatMap; gfilter; initLast; InitLast; _∷ʳ'_)
  renaming (_++_ to _++L_; map to mapL; concat to concatL; zip to zipL)
open import Data.List.NonEmpty
  using (List⁺; [_]; _∷⁺_; head; last; _⁺++_)
  renaming (toList to nonEmptyListtoList; _∷ʳ_ to _n∷ʳ_; tail to ntail)
open import Data.List.Any using (Any; here; there; any; module Membership)
open import Data.Maybe using (Maybe; nothing; just; maybe′)
open import Data.Vec
  using (Vec; tabulate; []; _∷_; tail; lookup; zip; zipWith; splitAt;
         _[_]≔_; allFin; toList)
  renaming (_++_ to _++V_; map to mapV; concat to concatV)
open import Function using (id; _∘_; _$_; flip)
open import Data.Maybe using (Maybe; just; nothing)

open import Data.Empty   using (⊥; ⊥-elim)
open import Data.Unit    using (⊤; tt)
open import Data.Sum     using (_⊎_; inj₁; inj₂)
open import Data.Product using (_×_; _,_; proj₁; proj₂)

open import Proofs
open import Cauchy

------------------------------------------------------------------------------
-- What JC thinks will actually work
-- we need injectivity.  surjectivity ought to be provable.

Permutation : ℕ → Set
Permutation n = Σ (Cauchy n) (λ v → ∀ {i j} → lookup i v ≡ lookup j v → i ≡ j)

------------------------------------------------------------------------------
-- Iso between Fin (m * n) and Fin m × Fin n

absurd-quotient : (m n q : ℕ) (r : Fin (suc n)) (k : Fin (suc (n + m * suc n)))
         (k≡r+q*sn : toℕ k ≡ toℕ r + q * suc n) (p : suc m ≤ q) → ⊥
absurd-quotient m n q r k k≡r+q*sn p = ¬i+1+j≤i (toℕ k) {toℕ r} k≥k+sr
  where k≥k+sr : toℕ k ≥ toℕ k + suc (toℕ r)
        k≥k+sr = begin (toℕ k + suc (toℕ r)
                   ≡⟨ +-suc (toℕ k) (toℕ r) ⟩
                 suc (toℕ k) + toℕ r
                   ≤⟨ cong+r≤ (bounded k) (toℕ r) ⟩
                 (suc n + m * suc n) + toℕ r
                   ≡⟨ +-comm (suc n + m * suc n) (toℕ r) ⟩
                 toℕ r + (suc n + m * suc n)
                   ≡⟨ refl ⟩
                 toℕ r + suc m * suc n
                   ≤⟨ cong+l≤ (cong*r≤ p (suc n)) (toℕ r) ⟩
                 toℕ r + q * suc n
                   ≡⟨ sym k≡r+q*sn ⟩
                 toℕ k ∎)
                  where open ≤-Reasoning

Fin0-⊥ : Fin 0 → ⊥
Fin0-⊥ ()

fin-project : (m n : ℕ) → Fin (m * n) → Fin m × Fin n
fin-project 0 n ()
fin-project (suc m) 0 k =  ⊥-elim (Fin0-⊥ (subst Fin (*-right-zero (suc m)) k))
fin-project (suc m) (suc n) k with (toℕ k) divMod (suc n)
... | result q r k≡r+q*sn = (fromℕ≤ {q} {suc m} (s≤s q≤m) , r)
  where q≤m : q ≤ m
        q≤m with suc m ≤? q
        ... | yes p = ⊥-elim (absurd-quotient m n q r k k≡r+q*sn p)
        ... | no ¬p = ≤-pred (≰⇒> ¬p)

fin-proj-lem : (m n : ℕ) (k : Fin (m * n)) →
  k ≡ let (b , d) = fin-project m n k in
      inject≤ (fromℕ (toℕ b * n + toℕ d)) (i*n+k≤m*n b d)
fin-proj-lem 0 n ()
fin-proj-lem (suc m) 0 k = ⊥-elim (Fin0-⊥ (subst Fin (*-right-zero (suc m)) k))
fin-proj-lem (suc m) (suc n) k with _divMod_ (toℕ k) (suc n) {_}
... | result q r k≡r+q*sn with suc m ≤? q
... | yes p = ⊥-elim (absurd-quotient m n q r k k≡r+q*sn p)
... | no ¬p = toℕ-injective toℕk≡
  where q≡ : (m : ℕ) (q : ℕ) (¬p : ¬ suc m ≤ q) →
             q ≡ toℕ (fromℕ≤ (s≤s (≤-pred (≰⇒> ¬p))))
        q≡ m q ¬p = sym (toℕ-fromℕ≤ (s≤s (≤-pred (≰⇒> ¬p))))
        toℕk≡ = begin (toℕ k
                  ≡⟨ k≡r+q*sn ⟩
                       toℕ r + q * suc n
                  ≡⟨ +-comm (toℕ r) (q * suc n) ⟩
                       q * suc n + toℕ r
                  ≡⟨ cong
                        (λ x → x * suc n + toℕ r)
                        (q≡ m q ¬p) ⟩
                       toℕ (fromℕ≤ (s≤s (≤-pred (≰⇒> ¬p)))) * suc n + toℕ r
                  ≡⟨ sym (to-from
                           (toℕ (fromℕ≤ (s≤s (≤-pred (≰⇒> ¬p)))) * suc n + toℕ r)) ⟩
                       toℕ (fromℕ
                             (toℕ (fromℕ≤ (s≤s (≤-pred (≰⇒> ¬p)))) * suc n + toℕ r))
                  ≡⟨ sym
                       (inject≤-lemma
                         (fromℕ
                           (toℕ (fromℕ≤ (s≤s (≤-pred (≰⇒> ¬p)))) * suc n + toℕ r))
                         (i*n+k≤m*n (fromℕ≤ (s≤s (≤-pred (≰⇒> ¬p)))) r)) ⟩
                       toℕ
                         (inject≤
                           (fromℕ
                             (toℕ (fromℕ≤ (s≤s (≤-pred (≰⇒> ¬p)))) * suc n + toℕ r))
                           (i*n+k≤m*n
                             (fromℕ≤ {q} {suc m} (s≤s (≤-pred (≰⇒> ¬p)))) r)) ∎)
                where open ≡-Reasoning

fin-proj-lem2 : (m n : ℕ) (b : Fin m) (d : Fin n) →
  (b , d) ≡ fin-project m n
              (inject≤ (fromℕ (toℕ b * n + toℕ d)) (i*n+k≤m*n b d))
fin-proj-lem2 m 0 b ()
fin-proj-lem2 0 (suc n) () d
fin-proj-lem2 (suc m) (suc n) b d with
 (toℕ (inject≤ (fromℕ (toℕ b * suc n + toℕ d)) (i*n+k≤m*n b d))) divMod (suc n)
... | result q r eq =
  begin ((b , d)
        ≡⟨ cong₂ _,_
            (toℕ-injective
              (sym
                (trans
                  (toℕ-fromℕ≤ (s≤s (trans≤ (refl′ (proj₁ eq')) (bounded' m b))))
                  (proj₁ eq'))) )
            (sym (proj₂ eq')) ⟩
        (fromℕ≤ (s≤s (trans≤ (refl′ (proj₁ eq')) (bounded' m b))) , r)
        ≡⟨ cong₂ _,_ (cong fromℕ≤ (≤-proof-irrelevance _ _)) refl ⟩
        (fromℕ≤ _ , r) ∎)
  where open ≡-Reasoning
        eq' : q ≡ toℕ b × r ≡ d
        eq' = swap
                (addMul-lemma′ q (toℕ b) n r d
                  (trans
                    (trans (+-comm (q * suc n) (toℕ r)) (sym eq))
                    (trans (inject≤-lemma _ _) (to-from _))))

-- The actual isomorphism

record Fin-Product-Iso (m n : ℕ) : Set where
  constructor iso
  field
    split   : Fin (m * n) → Fin m × Fin n
    combine : Fin m × Fin n → Fin (m * n)
    inv     : (i : Fin (m * n)) → combine (split i) ≡ i
    inv'    : (bd : Fin m × Fin n) → split (combine bd) ≡ bd

fin-product-iso : (m n : ℕ) → Fin-Product-Iso m n
fin-product-iso m n =
  iso
    (fin-project m n)
    (λ {(b , d) → inject≤ (fromℕ (toℕ b * n + toℕ d)) (i*n+k≤m*n b d)})
    (λ k → sym (fin-proj-lem m n k))
    ((λ {(b , d) → sym (fin-proj-lem2 m n b d)}))

record Fin-DivMod (m n : ℕ) (i : Fin (m * n)) : Set where
  constructor fin-result
  field
    b    : Fin m
    d    : Fin n
    dec  : toℕ i ≡ toℕ d + toℕ b * n
    dec' : i ≡ inject≤ (fromℕ (toℕ b * n + toℕ d)) (i*n+k≤m*n b d)

fin-divMod : (m n : ℕ) (i : Fin (m * n)) → Fin-DivMod m n i
fin-divMod m n i = fin-result b d dec dec'
  where
    bd = Fin-Product-Iso.split (fin-product-iso m n) i
    b = proj₁ bd
    d = proj₂ bd
    dec' = sym (Fin-Product-Iso.inv (fin-product-iso m n) i)
    dec = begin (toℕ i
                ≡⟨ cong toℕ (sym (inv (fin-product-iso m n) i)) ⟩
                toℕ (inject≤ (fromℕ (toℕ b * n + toℕ d)) (i*n+k≤m*n b d))
                ≡⟨ inject≤-lemma (fromℕ (toℕ b * n + toℕ d)) (i*n+k≤m*n b d) ⟩
                toℕ (fromℕ (toℕ b * n + toℕ d))
                ≡⟨ to-from (toℕ b * n + toℕ d) ⟩
                toℕ b * n + toℕ d
                ≡⟨ +-comm (toℕ b * n) (toℕ d) ⟩
                toℕ d + toℕ b * n ∎)
          where open ≡-Reasoning
                open Fin-Product-Iso

fin-addMul-lemma : (m n : ℕ) (b b' : Fin m) (d d' : Fin n) →
  toℕ b * n + toℕ d ≡ toℕ b' * n + toℕ d' → b ≡ b' × d ≡ d'
fin-addMul-lemma m 0 _ _ ()
fin-addMul-lemma m (suc n) b b' d d' p =
  let (d≡ , b≡) = addMul-lemma′ (toℕ b) (toℕ b') n d d' p
  in (toℕ-injective b≡ , d≡)

------------------------------------------------------------------------------
-- Vec lemmas

fi≡fj : {m : ℕ} → (i j : Fin m) (f : Fin m → Fin m) →
        (p : lookup i (tabulate f) ≡ lookup j (tabulate f)) → (f i ≡ f j)
fi≡fj i j f p = trans
                  (sym (lookup∘tabulate f i))
                  (trans p (lookup∘tabulate f j))

lookup-bounded : (m n : ℕ) (i : Fin n) (v : Vec (Fin m) n) → toℕ (lookup i v) < m
lookup-bounded m 0 () v
lookup-bounded m (suc n) zero (x ∷ v) = bounded x
lookup-bounded m (suc n) (suc i) (x ∷ v) = lookup-bounded m n i v

lookup-concat-left : ∀ {ℓ} {A : Set ℓ} {m n : ℕ} →
  (d : Fin n) (leq : suc (toℕ d) ≤ n + m) (vs : Vec A n) (ws : Vec A m) →
  lookup (inject≤ (fromℕ (toℕ d)) leq) (vs ++V ws) ≡ lookup d vs
lookup-concat-left zero (s≤s z≤n) (x ∷ vs) ws = refl
lookup-concat-left (suc d) (s≤s leq) (x ∷ vs) ws = lookup-concat-left d leq vs ws

lookup-concat-right : ∀ {ℓ} {A : Set ℓ} {m n : ℕ} →
  (j : ℕ) (leq : suc (n + j) ≤ n + m) (leq' : suc j ≤ m)
  (vs : Vec A n) (ws : Vec A m) →
  lookup (inject≤ (fromℕ (n + j)) leq) (vs ++V ws) ≡
  lookup (inject≤ (fromℕ j) leq') ws
lookup-concat-right {n = 0} j leq leq' [] ws =
  cong
    (λ x → lookup (inject≤ (fromℕ j) x) ws)
    (≤-proof-irrelevance leq leq')
lookup-concat-right {n = suc n} j (s≤s leq) leq' (v ∷ vs) ws =
  lookup-concat-right j leq leq' vs ws

lookup-concat-right' : ∀ {ℓ} {A : Set ℓ} {m n : ℕ} →
  (j k : ℕ) (leq : suc ((n + j) + k) ≤ n + m) (leq' : suc (j + k) ≤ m)
  (vs : Vec A n) (ws : Vec A m) →
  lookup (inject≤ (fromℕ ((n + j) + k)) leq) (vs ++V ws) ≡
  lookup (inject≤ (fromℕ (j + k)) leq') ws
lookup-concat-right' {n = 0} j k leq leq' [] ws =
  cong
    (λ x → lookup (inject≤ (fromℕ (j + k)) x) ws)
    (≤-proof-irrelevance leq leq')
lookup-concat-right' {n = suc n} j k (s≤s leq) leq' (v ∷ vs) ws =
  lookup-concat-right' j k leq leq' vs ws

helper-leq : (m n : ℕ) → (b : Fin m) →
  suc (n + toℕ b * suc n) ≤ n + m * suc n
helper-leq m n b =
  begin (suc (n + toℕ b * suc n)
       ≡⟨ cong suc (+-comm n (toℕ b * suc n)) ⟩
         suc (toℕ b * suc n + n)
       ≡⟨ cong (λ x → suc (toℕ b * suc n + x)) (sym (to-from n)) ⟩
         suc (toℕ b * suc n + toℕ (fromℕ n))
       ≤⟨ i*n+k≤m*n b (fromℕ n) ⟩
         m * suc n
       ≤⟨ n≤m+n n (m * suc n) ⟩
         n + m * suc n ∎)
  where open ≤-Reasoning

helper-leq' : (m n : ℕ) → (b : Fin m) →
  suc (toℕ b * suc n) ≤ m * suc n
helper-leq' 0 n ()
helper-leq' (suc m) n zero = s≤s z≤n
helper-leq' (suc m) n (suc b) = s≤s (helper-leq m n b)

lookup-concat-inner : {ℓ₁ ℓ₂ ℓ₃ : Level} {A : Set ℓ₁} {B : Set ℓ₂} {C : Set ℓ₃} →
  (m n : ℕ) (b : Fin m) (j : B)
  (leq : suc (toℕ b * suc n) ≤ m * suc n)
  (f : A × B → C) (pm : Vec A m) (pn : Vec B n) →
  lookup
     (inject≤ (fromℕ (toℕ b * suc n)) leq)
     (concatV (mapV (λ b → mapV (λ d → f (b , d)) (j ∷ pn)) pm))
   ≡ f (lookup b pm , j)
lookup-concat-inner 0 n () j leq f pm pn
lookup-concat-inner (suc m) n zero j (s≤s z≤n) f (i ∷ pm) pn = refl
lookup-concat-inner (suc m) n (suc b) j (s≤s leq) f (i ∷ pm) pn =
  begin (lookup
           (inject≤ (fromℕ (n + toℕ b * suc n)) leq)
           (mapV (λ d → f (i , d)) pn ++V
            concatV (mapV (λ b → mapV (λ d → f (b , d)) (j ∷ pn)) pm))
       ≡⟨ lookup-concat-right (toℕ b * suc n) leq (helper-leq' m n b)
           (mapV (λ d → f (i , d)) pn)
           (concatV (mapV (λ b → mapV (λ d → f (b , d)) (j ∷ pn)) pm)) ⟩
         lookup
           (inject≤ (fromℕ (toℕ b * suc n)) (helper-leq' m n b))
           (concatV (mapV (λ b → mapV (λ d → f (b , d)) (j ∷ pn)) pm))
       ≡⟨ lookup-concat-inner m n b j (helper-leq' m n b) f pm pn ⟩
         f (lookup b pm , j) ∎)
  where open ≡-Reasoning

lookup-concat' : ∀ {ℓ₁ ℓ₂ ℓ₃} {A : Set ℓ₁} {B : Set ℓ₂} {C : Set ℓ₃} →
  (m n : ℕ) (b : Fin m) (d : Fin n) →
  (leq : suc (toℕ b * n + toℕ d) ≤ m * n) →
  (f : A × B → C) (pm : Vec A m) (pn : Vec B n) →
  lookup
    (inject≤ (fromℕ (toℕ b * n + toℕ d)) leq)
    (concatV (mapV (λ b → mapV (λ d → f (b , d)) pn) pm)) ≡
  f (lookup b pm , lookup d pn)
lookup-concat' 0 n () d leq f pm pn
lookup-concat' (suc m) n zero d leq f (i ∷ pm) pn =
  begin (lookup
           (inject≤ (fromℕ (toℕ d)) leq)
           (concatV (mapV (λ b → mapV (λ d → f (b , d)) pn) (i ∷ pm)))
       ≡⟨ refl ⟩
         lookup
           (inject≤ (fromℕ (toℕ d)) leq)
           (concatV (mapV (λ d → f (i , d)) pn ∷
                     mapV (λ b → mapV (λ d → f (b , d)) pn) pm))
       ≡⟨ refl ⟩
         lookup
           (inject≤ (fromℕ (toℕ d)) leq)
           (mapV (λ d → f (i , d)) pn ++V
            concatV (mapV (λ b → mapV (λ d → f (b , d)) pn) pm))
       ≡⟨ lookup-concat-left d leq
            (mapV (λ d → f (i , d)) pn)
            (concatV (mapV (λ b → mapV (λ d → f (b , d)) pn) pm)) ⟩
         lookup d (mapV (λ d → f (i , d)) pn)
       ≡⟨ lookup-map d (λ d → f (i , d)) pn ⟩
         f (i , lookup d pn) ∎)
  where open ≡-Reasoning
lookup-concat' (suc m) 0 (suc b) () leq f (i ∷ pm) pn
lookup-concat' (suc m) (suc n) (suc b) zero (s≤s leq) f (i ∷ pm) (j ∷ pn) =
  begin (lookup
           (inject≤ (fromℕ ((n + toℕ b * suc n) + 0)) leq)
           (mapV (λ d → f (i , d)) pn ++V
            concatV (mapV (λ b → mapV (λ d → f (b , d)) (j ∷ pn)) pm))
       ≡⟨ cong₂D!
            (λ x y →
              lookup
                (inject≤ (fromℕ x) y)
                (mapV (λ d → f (i , d)) pn ++V
                 concatV (mapV (λ b → mapV (λ d → f (b , d)) (j ∷ pn)) pm)))
            (sym (+-right-identity (n + toℕ b * suc n)))
            (≤-proof-irrelevance
              (subst
                 (λ z → suc z ≤ n + m * suc n)
                 (sym (+-right-identity (n + toℕ b * suc n)))
                 (helper-leq m n b))
              leq) ⟩
         lookup
           (inject≤
             (fromℕ (n + toℕ b * suc n))
             (helper-leq m n b))
           (mapV (λ d → f (i , d)) pn ++V
            concatV (mapV (λ b → mapV (λ d → f (b , d)) (j ∷ pn)) pm))
       ≡⟨ lookup-concat-right
             (toℕ b * suc n)
             (helper-leq m n b)
             (helper-leq' m n b)
             (mapV (λ d → f (i , d)) pn)
             (concatV (mapV (λ b → mapV (λ d → f (b , d)) (j ∷ pn)) pm)) ⟩
         lookup
           (inject≤ (fromℕ (toℕ b * suc n)) (helper-leq' m n b))
           (concatV (mapV (λ b → mapV (λ d → f (b , d)) (j ∷ pn)) pm))
       ≡⟨ lookup-concat-inner m n b j (helper-leq' m n b) f pm pn ⟩
         f (lookup b pm , j) ∎)
  where open ≡-Reasoning
lookup-concat' (suc m) (suc n) (suc b) (suc d) (s≤s leq) f (i ∷ pm) (j ∷ pn) =
  begin (lookup
           (inject≤ (fromℕ ((n + toℕ b * suc n) + toℕ (suc d))) leq)
           (mapV (λ d → f (i , d)) pn ++V
            concatV (mapV (λ b → mapV (λ d → f (b , d)) (j ∷ pn)) pm))
       ≡⟨ lookup-concat-right' (toℕ b * suc n) (toℕ (suc d)) leq (i*n+k≤m*n b (suc d))
            (mapV (λ d → f (i , d)) pn)
            (concatV (mapV (λ b → mapV (λ d → f (b , d)) (j ∷ pn)) pm)) ⟩
         lookup
           (inject≤ (fromℕ (toℕ b * suc n + toℕ (suc d))) (i*n+k≤m*n b (suc d)))
           (concatV (mapV (λ b → mapV (λ d → f (b , d)) (j ∷ pn)) pm))
       ≡⟨ lookup-concat' m (suc n) b (suc d) (i*n+k≤m*n b (suc d)) f pm (j ∷ pn) ⟩
         f (lookup b pm , lookup d pn) ∎)
  where open ≡-Reasoning

lookup-2d : (m n : ℕ) (i : Fin (m * n)) (α : Cauchy m) (β : Cauchy n) →
  (h : (Fin m × Fin n) → Fin (m * n)) →
  lookup i (concatV (mapV (λ b → mapV (λ d → h (b , d)) β) α)) ≡
  let fin-result b d _ _ = fin-divMod m n i in h (lookup b α , lookup d β)
lookup-2d m n i α β h =
  let fin-result b d dec dec' = fin-divMod m n i in
  begin (lookup i (concatV (mapV (λ b → mapV (λ d → h (b , d)) β) α))
         ≡⟨ cong
              (λ x → lookup x (concatV (mapV (λ b → mapV (λ d → h (b , d)) β) α)))
              dec' ⟩
         lookup
           (inject≤ (fromℕ (toℕ b * n + toℕ d)) (i*n+k≤m*n b d))
           (concatV (mapV (λ b → mapV (λ d → h (b , d)) β) α))
         ≡⟨ lookup-concat' m n b d (i*n+k≤m*n b d) h α β ⟩
         h (lookup b α , lookup d β) ∎)
  where open ≡-Reasoning

------------------------------------------------------------------------------
-- Elementary permutations in the Cauchy representation

emptyperm : Permutation 0
emptyperm = (emptycauchy , f)
  where f : {i j : Fin 0} → (lookup i emptycauchy ≡ lookup j emptycauchy) → (i ≡ j)
        f {()}

idperm : (n : ℕ) → Permutation n
idperm n = (idcauchy n , λ {i} {j} p → fi≡fj i j id p)

-- Sequential composition

scompperm : ∀ {n} → Permutation n → Permutation n → Permutation n
scompperm {n} (α , f) (β , g) =
  (scompcauchy α β ,
   λ {i} {j} p → f (g (fi≡fj i j (λ i → lookup (lookup i α) β) p)))

-- swap the first m elements with the last n elements
-- [ v₀ , v₁   , v₂   , ... , vm-1 ,     vm , vm₊₁ , ... , vm+n-1 ]
-- ==>
-- [ vm , vm₊₁ , ... , vm+n-1 ,     v₀ , v₁   , v₂   , ... , vm-1 ]

swap+cauchy< : (m n : ℕ) (i : Fin (m + n)) (i< : toℕ i < m) →
  lookup i (swap+cauchy m n) ≡ id+ {m} (raise n (fromℕ≤ i<))
swap+cauchy< m n i i< =
  let j = fromℕ≤ i< in
  let eq = inj₁-≡ i i< in
  begin
    (lookup i (splitVOp+ {m} {n} {f = id+ {m}})
         ≡⟨ cong (flip lookup (splitVOp+ {m} {n} {f = id+ {m}})) eq ⟩
    lookup (inject+ n j)  (splitVOp+ {m} {n} {f = id+ {m}})
         ≡⟨ lookup-++-inject+  (tabulate (id+ {m} ∘ raise n)) (tabulate (id+ {m} ∘ inject+ m)) j ⟩
     lookup j (tabulate {m} (id+ {m} ∘ raise n))
          ≡⟨ lookup∘tabulate (id+ {m} ∘ raise n) j ⟩
     id+ {m} (raise n j) ∎)
  where open ≡-Reasoning

swap+cauchy≥ : (m n : ℕ) (i : Fin (m + n)) (i≥ : m ≤ toℕ i) →
  lookup i (swap+cauchy m n) ≡ subst Fin (+-comm n m) (inject+ m (reduce≥ i i≥))
swap+cauchy≥ m n i i≥ =
  let j = reduce≥ i i≥ in
  let eq = inj₂-≡ i i≥ in
  let v = splitVOp+ {m} {f = id+ {m}} in
  begin (
    lookup i v
        ≡⟨ cong (flip lookup v) eq ⟩
    lookup (raise m j) v
        ≡⟨ lookup-++-raise (tabulate (id+ {m} ∘ raise n)) (tabulate (id+ {m} ∘ inject+ m)) j ⟩
    lookup j (tabulate (id+ {m} ∘ inject+ m))
        ≡⟨ lookup∘tabulate (id+ {m} ∘ inject+ m) j ⟩
    id+ {m} (inject+ m j) ∎)
  where open ≡-Reasoning

swap+perm' : (m n : ℕ) (i j : Fin (m + n))
  (p : lookup i (swap+cauchy m n) ≡ lookup j (swap+cauchy m n)) → (i ≡ j)
swap+perm' m n i j p with toℕ i <? m | toℕ j <? m
... | yes i< | yes j< = toℕ-injective (cancel-+-left n {toℕ i} {toℕ j} ni≡nj)
  where ni≡nj = begin (n + toℕ i
                     ≡⟨ sym (raise< m n i i<)  ⟩
                       toℕ (subst Fin (+-comm n m) (raise n (fromℕ≤ i<)))
                     ≡⟨ cong toℕ (sym (swap+cauchy< m n i i<)) ⟩
                       toℕ (lookup i (swap+cauchy m n))
                     ≡⟨ cong toℕ p ⟩
                       toℕ (lookup j (swap+cauchy m n))
                     ≡⟨ cong toℕ (swap+cauchy< m n j j<) ⟩
                       toℕ (subst Fin (+-comm n m) (raise n (fromℕ≤ j<)))
                     ≡⟨ raise< m n j j< ⟩
                       n + toℕ j ∎)
               where open ≡-Reasoning
... | yes i< | no j≥ = ⊥-elim (1+n≰n contra')
  where contra : n + toℕ i ≡ toℕ j ∸ m
        contra = begin (n + toℕ i
                       ≡⟨ sym (raise< m n i i<) ⟩
                       toℕ (subst Fin (+-comm n m) (raise n (fromℕ≤ i<)))
                       ≡⟨ cong toℕ (sym (swap+cauchy< m n i i<)) ⟩
                       toℕ (lookup i (swap+cauchy m n))
                       ≡⟨ cong toℕ p ⟩
                       toℕ (lookup j (swap+cauchy m n))
                       ≡⟨ cong toℕ (swap+cauchy≥ m n j (≤-pred (≰⇒> j≥))) ⟩
                       toℕ (subst Fin (+-comm n m)
                             (inject+ m (reduce≥ j (≤-pred (≰⇒> j≥)))))
                       ≡⟨ inject≥ m n j (≤-pred (≰⇒> j≥)) ⟩
                       toℕ j ∸ m ∎)
                 where open ≡-Reasoning
        contra' : suc (m + n) ≤ m + n
        contra' = begin (suc (m + n)
                        ≤⟨ m≤m+n (suc (m + n)) (toℕ i) ⟩
                        suc (m + n) + toℕ i
                        ≡⟨ +-assoc (suc m) n (toℕ i) ⟩
                        suc (m + (n + toℕ i))
                        ≡⟨ cong (λ x → suc m + x) contra ⟩
                        suc (m + (toℕ j ∸ m))
                        ≡⟨ cong suc (sym (+-∸-assoc m (≤-pred (≰⇒> j≥))))  ⟩
                        suc ((m + toℕ j) ∸ m)
                        ≡⟨ cong (λ x → suc (x ∸ m)) (+-comm m (toℕ j)) ⟩
                        suc ((toℕ j + m) ∸ m)
                        ≡⟨ cong suc (m+n∸n≡m (toℕ j) m) ⟩
                        suc (toℕ j)
                        ≤⟨ bounded j ⟩
                        m + n ∎)
                  where open ≤-Reasoning
... | no i≥ | yes j< = ⊥-elim (1+n≰n contra')
  where contra : n + toℕ j ≡ toℕ i ∸ m
        contra = begin (n + toℕ j
                       ≡⟨ sym (raise< m n j j<) ⟩
                       toℕ (subst Fin (+-comm n m) (raise n (fromℕ≤ j<)))
                       ≡⟨ cong toℕ (sym (swap+cauchy< m n j j<)) ⟩
                       toℕ (lookup j (swap+cauchy m n))
                       ≡⟨ cong toℕ (sym p) ⟩
                       toℕ (lookup i (swap+cauchy m n))
                       ≡⟨ cong toℕ (swap+cauchy≥ m n i (≤-pred (≰⇒> i≥))) ⟩
                       toℕ (subst Fin (+-comm n m)
                             (inject+ m (reduce≥ i (≤-pred (≰⇒> i≥)))))
                       ≡⟨ inject≥ m n i (≤-pred (≰⇒> i≥)) ⟩
                       toℕ i ∸ m ∎)
                 where open ≡-Reasoning
        contra' : suc (m + n) ≤ m + n
        contra' = begin (suc (m + n)
                        ≤⟨ m≤m+n (suc (m + n)) (toℕ j) ⟩
                        suc (m + n) + toℕ j
                        ≡⟨ +-assoc (suc m) n (toℕ j) ⟩
                        suc (m + (n + toℕ j))
                        ≡⟨ cong (λ x → suc m + x) contra ⟩
                        suc (m + (toℕ i ∸ m))
                        ≡⟨ cong suc (sym (+-∸-assoc m (≤-pred (≰⇒> i≥))))  ⟩
                        suc ((m + toℕ i) ∸ m)
                        ≡⟨ cong (λ x → suc (x ∸ m)) (+-comm m (toℕ i)) ⟩
                        suc ((toℕ i + m) ∸ m)
                        ≡⟨ cong suc (m+n∸n≡m (toℕ i) m) ⟩
                        suc (toℕ i)
                        ≤⟨ bounded i ⟩
                        m + n ∎)
                  where open ≤-Reasoning
... | no i≥ | no j≥ = ∸≡ m n i j (≤-pred (≰⇒> i≥)) (≤-pred (≰⇒> j≥)) ri≡rj
  where ri≡rj = begin (toℕ i ∸ m
                       ≡⟨ sym (inject≥ m n i (≤-pred (≰⇒> i≥))) ⟩
                       toℕ (subst Fin (+-comm n m)
                             (inject+ m (reduce≥ i (≤-pred (≰⇒> i≥)))))
                       ≡⟨ cong toℕ (sym (swap+cauchy≥ m n i (≤-pred (≰⇒> i≥)))) ⟩
                       toℕ (lookup i (swap+cauchy m n))
                       ≡⟨ cong toℕ p ⟩
                       toℕ (lookup j (swap+cauchy m n))
                       ≡⟨ cong toℕ (swap+cauchy≥ m n j (≤-pred (≰⇒> j≥)))  ⟩
                       toℕ (subst Fin (+-comm n m)
                             (inject+ m (reduce≥ j (≤-pred (≰⇒> j≥)))))
                       ≡⟨ inject≥ m n j (≤-pred (≰⇒> j≥)) ⟩
                       toℕ j ∸ m ∎)
                where open ≡-Reasoning

swap+perm : (m n : ℕ) → Permutation (m + n)
swap+perm m n = (swap+cauchy m n , λ {i} {j} p → swap+perm' m n i j p)

-- Parallel additive composition
-- append both permutations but adjust the indices in the second
-- permutation by the size of the first type so that it acts on the
-- second part of the vector

pcompperm' : (m n : ℕ) (i j : Fin (m + n))
  (α : Cauchy m) (β : Cauchy n)
  (p : lookup i (pcompcauchy α β) ≡ lookup j (pcompcauchy α β))
  (f : {i j : Fin m} → lookup i α ≡ lookup j α → i ≡ j)
  (g : {i j : Fin n} → lookup i β ≡ lookup j β → i ≡ j) → i ≡ j
pcompperm' m n i j α β p f g with toℕ i <? m | toℕ j <? m
... | yes i< | yes j< = fromℕ≤-inj m (m + n) i j i< j< (f (toℕ-injective li≡lj))
  where li≡lj = begin (toℕ (lookup (fromℕ≤ i<) α)
                       ≡⟨ inject+-lemma n (lookup (fromℕ≤ i<) α) ⟩
                       toℕ (inject+ n (lookup (fromℕ≤ i<) α))
                       ≡⟨ cong toℕ (sym (lookup-map (fromℕ≤ i<) (inject+ n) α)) ⟩
                       toℕ (lookup (fromℕ≤ i<) (mapV (inject+ n) α))
                       ≡⟨ cong toℕ (sym (lookup-++-<
                                      (mapV (inject+ n) α)
                                      (mapV (raise m) β)
                                      i i<)) ⟩
                       toℕ (lookup i (mapV (inject+ n) α ++V mapV (raise m) β))
                       ≡⟨ cong toℕ p ⟩
                       toℕ (lookup j (mapV (inject+ n) α ++V mapV (raise m) β))
                       ≡⟨ cong toℕ (lookup-++-<
                                     (mapV (inject+ n) α)
                                     (mapV (raise m) β)
                                     j j<) ⟩
                       toℕ (lookup (fromℕ≤ j<) (mapV (inject+ n) α))
                       ≡⟨ cong toℕ (lookup-map (fromℕ≤ j<) (inject+ n) α) ⟩
                       toℕ (inject+ n (lookup (fromℕ≤ j<) α))
                       ≡⟨ sym (inject+-lemma n (lookup (fromℕ≤ j<) α)) ⟩
                       toℕ (lookup (fromℕ≤ j<) α) ∎)
                where open ≡-Reasoning
... | yes i< | no j≥ = ⊥-elim (1+n≰n contra')
  where contra = begin (toℕ (lookup (fromℕ≤ i<) α)
                       ≡⟨ inject+-lemma n (lookup (fromℕ≤ i<) α) ⟩
                       toℕ (inject+ n (lookup (fromℕ≤ i<) α))
                       ≡⟨ cong toℕ (sym (lookup-map (fromℕ≤ i<) (inject+ n) α)) ⟩
                       toℕ (lookup (fromℕ≤ i<) (mapV (inject+ n) α))
                       ≡⟨ cong toℕ (sym (lookup-++-<
                                      (mapV (inject+ n) α)
                                      (mapV (raise m) β)
                                      i i<)) ⟩
                       toℕ (lookup i (mapV (inject+ n) α ++V mapV (raise m) β))
                       ≡⟨ cong toℕ p ⟩
                       toℕ (lookup j (mapV (inject+ n) α ++V mapV (raise m) β))
                       ≡⟨ cong toℕ (lookup-++-≥
                                     (mapV (inject+ n) α)
                                     (mapV (raise m) β)
                                     j (≤-pred (≰⇒> j≥))) ⟩
                       toℕ (lookup (reduce≥ j (≤-pred (≰⇒> j≥))) (mapV (raise m) β))
                       ≡⟨ cong toℕ
                           (lookup-map (reduce≥ j (≤-pred (≰⇒> j≥))) (raise m) β) ⟩
                       toℕ (raise m (lookup (reduce≥ j (≤-pred (≰⇒> j≥))) β))
                       ≡⟨ toℕ-raise m (lookup (reduce≥ j (≤-pred (≰⇒> j≥))) β) ⟩
                       m + toℕ (lookup (reduce≥ j (≤-pred (≰⇒> j≥))) β) ∎)
                 where open ≡-Reasoning
        contra' = begin (suc (toℕ (lookup (fromℕ≤ i<) α))
                        ≤⟨ lookup-bounded m m (fromℕ≤ i<) α ⟩
                        m
                        ≤⟨ m≤m+n m (toℕ (lookup (reduce≥ j (≤-pred (≰⇒> j≥))) β)) ⟩
                        m + toℕ (lookup (reduce≥ j (≤-pred (≰⇒> j≥))) β)
                        ≡⟨ sym contra ⟩
                        toℕ (lookup (fromℕ≤ i<) α) ∎)
                  where open ≤-Reasoning
... | no i≥ | yes j< = ⊥-elim (1+n≰n contra')
  where contra = begin (m + toℕ (lookup (reduce≥ i (≤-pred (≰⇒> i≥))) β)
                       ≡⟨ sym (toℕ-raise m (lookup (reduce≥ i (≤-pred (≰⇒> i≥))) β)) ⟩
                       toℕ (raise m (lookup (reduce≥ i (≤-pred (≰⇒> i≥))) β))
                       ≡⟨ cong toℕ
                           (sym (lookup-map (reduce≥ i (≤-pred (≰⇒> i≥))) (raise m) β)) ⟩
                       toℕ (lookup (reduce≥ i (≤-pred (≰⇒> i≥))) (mapV (raise m) β))
                       ≡⟨ cong toℕ (sym (lookup-++-≥
                                      (mapV (inject+ n) α)
                                      (mapV (raise m) β)
                                      i (≤-pred (≰⇒> i≥)))) ⟩
                       toℕ (lookup i (mapV (inject+ n) α ++V mapV (raise m) β))
                       ≡⟨ cong toℕ p ⟩
                       toℕ (lookup j (mapV (inject+ n) α ++V mapV (raise m) β))
                       ≡⟨ cong toℕ (lookup-++-<
                                     (mapV (inject+ n) α)
                                     (mapV (raise m) β)
                                     j j<) ⟩
                       toℕ (lookup (fromℕ≤ j<) (mapV (inject+ n) α))
                       ≡⟨ cong toℕ (lookup-map (fromℕ≤ j<) (inject+ n) α) ⟩
                       toℕ (inject+ n (lookup (fromℕ≤ j<) α))
                       ≡⟨ sym (inject+-lemma n (lookup (fromℕ≤ j<) α)) ⟩
                        toℕ (lookup (fromℕ≤ j<) α) ∎)
                 where open ≡-Reasoning
        contra' = begin (suc (toℕ (lookup (fromℕ≤ j<) α))
                        ≤⟨ lookup-bounded m m (fromℕ≤ j<) α ⟩
                        m
                        ≤⟨ m≤m+n m (toℕ (lookup (reduce≥ i (≤-pred (≰⇒> i≥))) β)) ⟩
                        m + toℕ (lookup (reduce≥ i (≤-pred (≰⇒> i≥))) β)
                        ≡⟨ contra ⟩
                        toℕ (lookup (fromℕ≤ j<) α) ∎)
                  where open ≤-Reasoning
... | no i≥ | no j≥ =
  reduce≥-inj m n i j (≤-pred (≰⇒> i≥)) (≤-pred (≰⇒> j≥))
    (g (toℕ-injective (cancel-+-left m li≡lj)))
  where li≡lj = begin (m + toℕ (lookup (reduce≥ i (≤-pred (≰⇒> i≥))) β)
                       ≡⟨ sym (toℕ-raise m (lookup (reduce≥ i (≤-pred (≰⇒> i≥))) β)) ⟩
                       toℕ (raise m (lookup (reduce≥ i (≤-pred (≰⇒> i≥))) β))
                       ≡⟨ cong toℕ
                           (sym (lookup-map (reduce≥ i (≤-pred (≰⇒> i≥))) (raise m) β)) ⟩
                       toℕ (lookup (reduce≥ i (≤-pred (≰⇒> i≥))) (mapV (raise m) β))
                       ≡⟨ cong toℕ (sym (lookup-++-≥
                                      (mapV (inject+ n) α)
                                      (mapV (raise m) β)
                                      i (≤-pred (≰⇒> i≥)))) ⟩
                       toℕ (lookup i (mapV (inject+ n) α ++V mapV (raise m) β))
                       ≡⟨ cong toℕ p ⟩
                       toℕ (lookup j (mapV (inject+ n) α ++V mapV (raise m) β))
                       ≡⟨ cong toℕ (lookup-++-≥
                                     (mapV (inject+ n) α)
                                     (mapV (raise m) β)
                                     j (≤-pred (≰⇒> j≥))) ⟩
                       toℕ (lookup (reduce≥ j (≤-pred (≰⇒> j≥))) (mapV (raise m) β))
                       ≡⟨ cong toℕ
                           (lookup-map (reduce≥ j (≤-pred (≰⇒> j≥))) (raise m) β) ⟩
                       toℕ (raise m (lookup (reduce≥ j (≤-pred (≰⇒> j≥))) β))
                       ≡⟨ toℕ-raise m (lookup (reduce≥ j (≤-pred (≰⇒> j≥))) β) ⟩
                       m + toℕ (lookup (reduce≥ j (≤-pred (≰⇒> j≥))) β) ∎)
                where open ≡-Reasoning

pcompperm : ∀ {m n} → Permutation m → Permutation n → Permutation (m + n)
pcompperm {m} {n} (α , f) (β , g) =
  (pcompcauchy α β , λ {i} {j} p → pcompperm' m n i j α β p f g)

-- Tensor multiplicative composition
-- Transpositions in α correspond to swapping entire rows
-- Transpositions in β correspond to swapping entire columns

tcompperm' : (m n : ℕ) (i j : Fin (m * n)) (α : Cauchy m) (β : Cauchy n)
  (f : {i j : Fin m} → lookup i α ≡ lookup j α → i ≡ j)
  (g : {i j : Fin n} → lookup i β ≡ lookup j β → i ≡ j)
  (p : lookup i (tcompcauchy α β) ≡ lookup j (tcompcauchy α β)) → (i ≡ j)
tcompperm' m n i j α β f g p =
  let fin-result bi di deci deci' = fin-divMod m n i
      fin-result bj dj decj decj' = fin-divMod m n j
      (lookb≡ , lookd≡) = fin-addMul-lemma
                            m n (lookup bi α) (lookup bj α)
                            (lookup di β) (lookup dj β) sp
      (b≡ , d≡) = (f {bi} {bj} lookb≡ , g {di} {dj} lookd≡)
      bn+d≡ = cong₂ (λ b d → toℕ d + toℕ b * n) b≡ d≡
  in toℕ-injective (trans deci (trans bn+d≡ (sym decj)))
  where sp = let fin-result bi di deci deci' = fin-divMod m n i
                 fin-result bj dj decj decj' = fin-divMod m n j in
             begin (let b' = lookup bi α
                        d' = lookup di β
                     in toℕ b' * n + toℕ d'
                   ≡⟨ sym (to-from _) ⟩
                   toℕ
                     (let b' = lookup bi α
                          d' = lookup di β
                      in fromℕ (toℕ b' * n + toℕ d'))
                   ≡⟨ sym (inject≤-lemma _ _) ⟩
                   toℕ
                     (let b' = lookup bi α
                          d' = lookup di β
                      in inject≤
                           (fromℕ (toℕ b' * n + toℕ d'))
                           (i*n+k≤m*n b' d'))
                   ≡⟨ cong toℕ
                        (sym (lookup-2d m n i α β
                             (λ {(b , d) → inject≤
                                             (fromℕ (toℕ b * n + toℕ d))
                                             (i*n+k≤m*n b d)}))) ⟩
                   toℕ (lookup i (tcompcauchy α β))
                   ≡⟨ cong toℕ p ⟩
                   toℕ (lookup j (tcompcauchy α β))
                   ≡⟨ cong toℕ
                        (lookup-2d m n j α β
                          (λ {(b , d) → inject≤
                                          (fromℕ (toℕ b * n + toℕ d))
                                          (i*n+k≤m*n b d)})) ⟩
                   toℕ
                     (let b' = lookup bj α
                          d' = lookup dj β
                      in inject≤
                           (fromℕ (toℕ b' * n + toℕ d'))
                           (i*n+k≤m*n b' d'))
                   ≡⟨ inject≤-lemma _ _ ⟩
                   toℕ
                     (let b' = lookup bj α
                          d' = lookup dj β
                      in fromℕ (toℕ b' * n + toℕ d'))
                   ≡⟨ to-from _ ⟩
                   let b' = lookup bj α
                       d' = lookup dj β
                   in toℕ b' * n + toℕ d' ∎)
             where open ≡-Reasoning

tcompperm : ∀ {m n} → Permutation m → Permutation n → Permutation (m * n)
tcompperm {m} {n} (α , f) (β , g) =
  (tcompcauchy α β , λ {i} {j} p → tcompperm' m n i j α β f g p)

-- swap⋆
--
-- This is essentially the classical problem of in-place matrix transpose:
-- "http://en.wikipedia.org/wiki/In-place_matrix_transposition"
-- Given m and n, the desired permutation in Cauchy representation is:
-- P(i) = m*n-1 if i=m*n-1
--      = m*i mod m*n-1 otherwise

transpose≡ : (m n : ℕ) (i j : Fin (m * n)) (bi bj : Fin m) (di dj : Fin n)
             (deci : toℕ i ≡ toℕ di + toℕ bi * n)
             (decj : toℕ j ≡ toℕ dj + toℕ bj * n)
             (tpr : transposeIndex m n bi di ≡ transposeIndex m n bj dj) → (i ≡ j)
transpose≡ m n i j bi bj di dj deci decj tpr =
  let (d≡ , b≡) = fin-addMul-lemma n m di dj bi bj stpr
      d+bn≡ = cong₂ (λ x y → toℕ x + toℕ y * n) d≡ b≡
  in toℕ-injective (trans deci (trans d+bn≡ (sym decj)))
  where stpr = begin (toℕ di * m + toℕ bi
                      ≡⟨ sym (to-from _) ⟩
                      toℕ (fromℕ (toℕ di * m + toℕ bi))
                      ≡⟨ sym (inject≤-lemma _ _) ⟩
                      toℕ (inject≤
                        (fromℕ (toℕ di * m + toℕ bi))
                        (trans≤
                          (i*n+k≤m*n di bi)
                          (refl′ (*-comm n m))))
                      ≡⟨ cong toℕ tpr ⟩
                      toℕ (inject≤
                        (fromℕ (toℕ dj * m + toℕ bj))
                        (trans≤
                          (i*n+k≤m*n dj bj)
                          (refl′ (*-comm n m))))
                      ≡⟨ inject≤-lemma _ _ ⟩
                      toℕ (fromℕ (toℕ dj * m + toℕ bj))
                      ≡⟨ to-from _ ⟩
                      toℕ dj * m + toℕ bj ∎)
               where open ≡-Reasoning

swap⋆perm' : (m n : ℕ) (i j : Fin (m * n))
             (p : lookup i (swap⋆cauchy m n) ≡ lookup j (swap⋆cauchy m n)) → (i ≡ j)
swap⋆perm' m n i j p =
  let fin-result bi di deci _ = fin-divMod m n i
      fin-result bj dj decj _ = fin-divMod m n j
  in transpose≡ m n i j bi bj di dj deci decj pr
  where pr = let fin-result bi di _ _ = fin-divMod m n i
                 fin-result bj dj _ _ = fin-divMod m n j in
             begin (transposeIndex m n bi di
                    ≡⟨ cong₂ (transposeIndex m n)
                         (sym (lookup-allFin bi)) (sym (lookup-allFin di)) ⟩
                    transposeIndex m n (lookup bi (allFin m)) (lookup di (allFin n))
                    ≡⟨ sym (lookup-2d m n i (allFin m) (allFin n)
                             (λ {(b , d) → transposeIndex m n b d})) ⟩
                    lookup i
                      (concatV (mapV
                        (λ b → mapV (λ d → transposeIndex m n b d) (allFin n))
                        (allFin m)))
                    ≡⟨ p ⟩
                    lookup j
                      (concatV (mapV
                        (λ b → mapV (λ d → transposeIndex m n b d) (allFin n))
                        (allFin m)))
                    ≡⟨ lookup-2d m n j (allFin m) (allFin n)
                         (λ {(b , d) → transposeIndex m n b d}) ⟩
                    transposeIndex m n (lookup bj (allFin m)) (lookup dj (allFin n))
                    ≡⟨ cong₂ (transposeIndex m n)
                         (lookup-allFin bj) (lookup-allFin dj) ⟩
                    transposeIndex m n bj dj ∎)
             where open ≡-Reasoning

swap⋆perm : (m n : ℕ) → Permutation (m * n)
swap⋆perm m n = (swap⋆cauchy m n , λ {i} {j} p → swap⋆perm' m n i j p)

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


--{-# OPTIONS --rewriting  #-}
module Array.Rewrites where

open import Array.Base
open import Data.Nat
open import Data.Fin using (Fin; zero; suc)
open import Data.Vec
open import Data.Vec.Properties
open import Relation.Binary.PropositionalEquality

open import Function

--{-# BUILTIN REWRITE _≡_ #-}

thm : ∀ {a}{X : Set a}{s : Vec X 1} →  head s ∷ [] ≡ s
thm {s = x ∷ []} = refl

expand-s→a∘a→s : ∀ {el}{ar : Ar ℕ 1 (el ∷ [])} → ∀ (iv : Ix 1 (el ∷ []))
               → lookup (a→s ar) (ix-lookup iv zero) ≡ unimap ar iv
expand-s→a∘a→s {ar = imap f} (x ∷ []) rewrite (lookup∘tabulate (f ∘ (_∷ [])) x) = refl

imap∘unimap : ∀ {a}{X : Set a}{d s} → (ar : Ar X d s) → imap (λ iv → unimap ar iv) ≡ ar
imap∘unimap (imap ar) = refl

--{-# REWRITE expand-s→a∘a→s     #-}
--{-# REWRITE imap∘unimap        #-}
--{-# REWRITE tabulate∘lookup    #-}
--{-# REWRITE lookup∘tabulate    #-}

n+0≡n : ∀ n → n + 0 ≡ n
n+0≡n zero = refl
n+0≡n (suc n) = cong suc (n+0≡n n)

--{-# REWRITE n+0≡n     #-}

test = λ x → x + 0


{-# OPTIONS -v treeless.opt:20 #-}

module _ where

open import Common.Prelude
open import Common.Equality

data Dec {a} (A : Set a) : Set a where
  yes : A → Dec A
  no  : (A → ⊥) → Dec A

decEq₂ : ∀ {a b c} {A : Set a} {B : Set b} {C : Set c} {f : A → B → C} →
           (∀ {x y z w} → f x y ≡ f z w → x ≡ z) →
           (∀ {x y z w} → f x y ≡ f z w → y ≡ w) →
           ∀ {x y z w} → Dec (x ≡ y) → Dec (z ≡ w) → Dec (f x z ≡ f y w)
decEq₂ f-inj₁ f-inj₂ (no neq)    _         = no λ eq → neq (f-inj₁ eq)
decEq₂ f-inj₁ f-inj₂  _         (no neq)   = no λ eq → neq (f-inj₂ eq)
decEq₂ f-inj₁ f-inj₂ (yes refl) (yes refl) = yes refl

main : IO Unit
main = putStrLn ""


-- A variant of code reported by Andreas Abel.

{-# OPTIONS --guardedness --sized-types #-}

open import Common.Coinduction renaming (∞ to Delay)
open import Common.Size
open import Common.Product

data ⊥ : Set where

record Stream (A : Set) : Set where
  inductive
  constructor delay
  field
    force : Delay (A × Stream A)
open Stream

head : ∀{A} → Stream A → A
head s = proj₁ (♭ (force s))

-- This type should be empty, as Stream A is isomorphic to ℕ → A.
data D : (i : Size) → Set where
  lim : ∀ i → Stream (D i) → D (↑ i)

-- Emptiness witness for D.
empty : ∀ i → D i → ⊥
empty .(↑ i) (lim i s) = empty i (head s)

-- BAD: But we can construct an inhabitant.
inh : Stream (D ∞)
inh = delay (♯ (lim ∞ inh , inh)) -- Should be rejected by termination checker.

absurd : ⊥
absurd = empty ∞ (lim ∞ inh)


{-# OPTIONS --allow-unsolved-metas #-}
open import Agda.Builtin.Equality
open import Agda.Builtin.List

postulate
  A : Set
  nilA : A
  consA : A → List A → A
  w/e : {x y : A} → x ≡ y

data D : List A → Set where
  nil  : D []
  cons : (x : A) (xs : List A) → D (x ∷ xs)

foo : ∀ {xs} (d : D xs)
      (let f : D xs → A
           f = λ where nil         → nilA
                       (cons y ys) → consA y ys) →
      f d ≡ nilA
foo nil        = {!!}
foo (cons _ _) = w/e


-- Andreas, 2020-05-19, issue #4157, reported by nad

-- In old-style mutual blocks, it should be possible to have
-- several anonymous definitions.

open import Agda.Builtin.Equality

mutual

  _ : Set₁
  _ = Set

  _ : Set → Set
  _ = λ A → A

mutual

  F : Set → Set
  F = _

  _ : F ≡ λ A → A
  _ = refl

  G : Set → Set
  G = _

  _ : G ≡ λ A → A → A
  _ = refl

-- Should pass


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

module Instances where

open import Cubical.Foundations.Everything renaming (_⁻¹ to _⁻¹ᵖ)
open import Agda.Primitive renaming (_⊔_ to ℓ-max; lsuc to ℓ-suc; lzero to ℓ-zero)
open import Cubical.Relation.Nullary.Base -- ¬_
open import Cubical.Relation.Binary.Base
open import Cubical.Data.Sum.Base renaming (_⊎_ to infixr 4 _⊎_)
open import Cubical.Data.Sigma.Base renaming (_×_ to infixr 4 _×_)
open import Cubical.Foundations.Logic
open import Agda.Builtin.Equality  renaming (_≡_ to _≡ᵢ_; refl to reflₚ)

variable
  ℓ ℓ' ℓ'' : Level

-- hProp is just the propertie's target type A with ≡ for all inhabitants attached
_ : (hProp ℓ) ≡ (Σ[ A ∈ Type ℓ ] (∀(x y : A) → x ≡ y))
_ = refl

_ : (hProp ℓ) ≡ (Σ[ A ∈ Type ℓ ] isProp A)
_ = refl

-- PropRel is just the relation R with ≡ for all inhabitants of all target types R a b attached
PropRel' : ∀ {ℓ} (A B : Type ℓ) (ℓ' : Level) → Type (ℓ-max ℓ (ℓ-suc ℓ'))
PropRel' A B ℓ' = Σ[ R ∈ Rel A B ℓ' ] ∀ a b → isProp (R a b)

#-coerceₚ' : ∀{ℓ'} → {P Q : hProp ℓ'} → [ P ] → {{[ P ] ≡ [ Q ]}} → [ Q ]
#-coerceₚ' {ℓ} {[p] , p-isProp} {[q] , q-isProp} p {{ p≡q }} = transport p≡q p

path-to-id : ∀{ℓ} {A : Type ℓ} {x y : A} → x ≡ y → x ≡ᵢ y
path-to-id p = {!!}

-- just for the explanation
record PoorField : Type (ℓ-suc (ℓ-max ℓ ℓ')) where
  field
    F : Type ℓ
    0f 1f : F
    _#_ : Rel F F ℓ'
    #-isprop : ∀ x y → isProp (x # y)
    instance
      #-isprop' : ∀{x y} {p q : x # y} → p ≡ q -- could we use this in some way?

    -- #-rel : PropRel F F ℓ'

  _#ₚ_ : F → F → hProp ℓ'
  x #ₚ y = (x # y) , #-isprop x y

  -- NOTE: this creates a `Goal: fst #-rel ...` everywhere
  --       we might just separate the relation from the isprop
  --       i.e. directly define _#_ and #-isprop
  -- _#_      = fst #-rel
  -- #-isprop = snd #-rel

  -- NOTE: there is an email on the agda mailing list 08.11.18, 21:16 by Martin Escardo "I want implicit coercions in Agda"
  --       although this email thread is about more general coercions which are not straight forward, where hProp should be less of an issue
  #-coerce : ∀{ℓ x y} → ∀{p q} {R : x # y → Type ℓ} → R p → R q
  #-coerce {ℓ} {x} {y} {p} {q} {R} rp = transport (cong R (#-isprop x y p q))rp

  #-coerceₚ : ∀{ℓ x y} → ∀{p q} {R : [ x #ₚ y ] → Type ℓ} → R p → R q
  #-coerceₚ {ℓ} {x} {y} {p} {q} {R} rp = transport (cong R (#-isprop x y p q)) rp

  field
    _+_ _·_ : F → F → F
    _⁻¹ᶠ    : (x : F) → {{ x # 0f }} → F
    ·-rinv  : (x : F) → (p : x # 0f) → x · (_⁻¹ᶠ x {{p}}) ≡ 1f

   -- for the purposes of explanation we just assume two different proofs of `1 # 0`
    1#0     : 1f # 0f
    1#0'    : 1f # 0f

    -- maybe there is some clever way to define _⁻¹ᶠ in a way where it accepts different proofs
    _⁻¹ᶠ'   : (x : F) → {{ [ x #ₚ 0f ] }} → F
    ·-rinv' : (x : F) → (p : [ x #ₚ 0f ]) → x · (_⁻¹ᶠ' x {{p}}) ≡ 1f

    1#0ₚ     : [ 1f #ₚ 0f ]
    1#0ₚ'    : [ 1f #ₚ 0f ]

    _⁻¹ᶠ''   : (x : F) → {{ [ x #ₚ 0f ] }} → F

  -- infix  9 _⁻¹ᶠ
  -- infixl 7 _·_
  -- infixl 5 _+_
  -- infixl 4 _#_

module test-hProp (PF : PoorField {ℓ} {ℓ'}) where
  open PoorField PF

  -- of course, this works
  test0 : let instance _ = 1#0 in 1f · (1f ⁻¹ᶠ) ≡ 1f
  test0 = ·-rinv 1f 1#0

  -- now, we try passing in 1#0'
  test1 : let instance _ = 1#0 in 1f · (1f ⁻¹ᶠ) ≡ 1f
  -- ERROR:
  -- PoorField.1#0' /= PoorField.1#0
  -- when checking that the expression 1#0' has type fst #-rel 1f 0f
  test1 = ·-rinv 1f ( #-coerceₚ {_} {1f} {0f} {_} {_} {_} 1#0')

  -- #-coerce seems to have troubles resolving the R
  test2 : let instance _ = 1#0 in 1f · (1f ⁻¹ᶠ) ≡ 1f
  -- ERROR:
  -- Failed to solve the following constraints:
  -- _R_161 _q_160 =< (1f · (1f ⁻¹ᶠ)) ≡ 1f
  -- (1f · (1f ⁻¹ᶠ)) ≡ 1f =< _R_161 _p_159
  test2 = #-coerce (·-rinv 1f 1#0') -- this line is yellow in emacs

  -- it works when we give R explicitly
  test3 : let instance _ = 1#0 in 1f · (1f ⁻¹ᶠ) ≡ 1f
  test3 = #-coerce {R = λ r → 1f · (_⁻¹ᶠ 1f {{r}}) ≡ 1f} (·-rinv 1f 1#0')

  -- a different "result" of this consideration might be that Goals involving hProp-instances need to be formulated in a different way

  test4 : let instance _ = 1#0ₚ in 1f · (1f ⁻¹ᶠ') ≡ 1f
  test4 =   ·-rinv' 1f ( #-coerceₚ' 1#0ₚ' {{{!!}}} )

  test5 : let instance _ = 1#0ₚ in 1f · (1f ⁻¹ᶠ') ≡ 1f
  test5 with 1#0ₚ' | path-to-id {ℓ'} {x = 1#0ₚ} {y = 1#0ₚ'} (#-isprop 1f 0f 1#0ₚ 1#0ₚ')
  ... | .(PoorField.1#0ₚ PF) | reflₚ = {! ·-rinv' 1f 1#0ₚ' !}

-- when using Prop this would be less of an issue
-- but how does it interact with the hProp based cubical library?
record ImpredicativePoorField : Type (ℓ-suc (ℓ-max ℓ ℓ')) where
  field
    F : Type ℓ
    0f 1f : F
    _#_ : F → F → Prop ℓ'
    _+_ _·_ : F → F → F
    _⁻¹ᶠ    : (x : F) → {{ x # 0f }} → F
    ·-rinv  : (x : F) → (p : x # 0f) → x · (_⁻¹ᶠ x {{p}}) ≡ 1f

   -- for the purposes of explanation we just assume two different proofs of `1 # 0`
    1#0     : 1f # 0f
    1#0'    : 1f # 0f

module test-impredicative (PF : ImpredicativePoorField {ℓ} {ℓ'}) where
  open ImpredicativePoorField PF

  -- now, we try passing in 1#0'
  test1 : let instance _ = 1#0 in 1f · (1f ⁻¹ᶠ) ≡ 1f
  test1 = ·-rinv 1f 1#0' -- just works


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

open import Level
open import Ordinals
module OPair {n : Level } (O : Ordinals {n})   where

open import zf
open import logic
import OD
import ODUtil
import OrdUtil

open import Relation.Nullary
open import Relation.Binary
open import Data.Empty
open import Relation.Binary
open import Relation.Binary.Core
open import  Relation.Binary.PropositionalEquality
open import Data.Nat renaming ( zero to Zero ; suc to Suc ;  ℕ to Nat ; _⊔_ to _n⊔_ )

open OD O
open OD.OD
open OD.HOD
open ODAxiom odAxiom

open Ordinals.Ordinals  O
open Ordinals.IsOrdinals isOrdinal
open Ordinals.IsNext isNext
open OrdUtil O
open ODUtil O

open _∧_
open _∨_
open Bool

open _==_

<_,_> : (x y : HOD) → HOD
< x , y > = (x , x ) , (x , y )

exg-pair : { x y : HOD } → (x , y ) =h= ( y , x )
exg-pair {x} {y} = record { eq→ = left ; eq← = right } where
    left : {z : Ordinal} → odef (x , y) z → odef (y , x) z
    left (case1 t) = case2 t
    left (case2 t) = case1 t
    right : {z : Ordinal} → odef (y , x) z → odef (x , y) z
    right (case1 t) = case2 t
    right (case2 t) = case1 t

ord≡→≡ : { x y : HOD } → & x ≡ & y → x ≡ y
ord≡→≡ eq = subst₂ (λ j k → j ≡ k ) *iso *iso ( cong ( λ k → * k ) eq )

od≡→≡ : { x y : Ordinal } → * x ≡ * y → x ≡ y
od≡→≡ eq = subst₂ (λ j k → j ≡ k ) &iso &iso ( cong ( λ k → & k ) eq )

eq-prod : { x x' y y' : HOD } → x ≡ x' → y ≡ y' → < x , y > ≡ < x' , y' >
eq-prod refl refl = refl

xx=zy→x=y : {x y z : HOD } → ( x , x ) =h= ( z , y ) → x ≡ y
xx=zy→x=y {x} {y} eq with trio< (& x) (& y)
xx=zy→x=y {x} {y} eq | tri< a ¬b ¬c with eq← eq {& y} (case2 refl)
xx=zy→x=y {x} {y} eq | tri< a ¬b ¬c | case1 s = ⊥-elim ( o<¬≡ (sym s) a )
xx=zy→x=y {x} {y} eq | tri< a ¬b ¬c | case2 s = ⊥-elim ( o<¬≡ (sym s) a )
xx=zy→x=y {x} {y} eq | tri≈ ¬a b ¬c = ord≡→≡ b
xx=zy→x=y {x} {y} eq | tri> ¬a ¬b c  with eq← eq {& y} (case2 refl)
xx=zy→x=y {x} {y} eq | tri> ¬a ¬b c | case1 s = ⊥-elim ( o<¬≡ s c )
xx=zy→x=y {x} {y} eq | tri> ¬a ¬b c | case2 s = ⊥-elim ( o<¬≡ s c )

prod-eq : { x x' y y' : HOD } → < x , y > =h= < x' , y' > → (x ≡ x' ) ∧ ( y ≡ y' )
prod-eq {x} {x'} {y} {y'} eq = ⟪ lemmax , lemmay ⟫ where
    lemma2 : {x y z : HOD } → ( x , x ) =h= ( z , y ) → z ≡ y
    lemma2 {x} {y} {z} eq = trans (sym (xx=zy→x=y lemma3 )) ( xx=zy→x=y eq )  where
        lemma3 : ( x , x ) =h= ( y , z )
        lemma3 = ==-trans eq exg-pair
    lemma1 : {x y : HOD } → ( x , x ) =h= ( y , y ) → x ≡ y
    lemma1 {x} {y} eq with eq← eq {& y} (case2 refl)
    lemma1 {x} {y} eq | case1 s = ord≡→≡ (sym s)
    lemma1 {x} {y} eq | case2 s = ord≡→≡ (sym s)
    lemma4 : {x y z : HOD } → ( x , y ) =h= ( x , z ) → y ≡ z
    lemma4 {x} {y} {z} eq with eq← eq {& z} (case2 refl)
    lemma4 {x} {y} {z} eq | case1 s with ord≡→≡ s -- x ≡ z
    ... | refl with lemma2 (==-sym eq )
    ... | refl = refl
    lemma4 {x} {y} {z} eq | case2 s = ord≡→≡ (sym s) -- y ≡ z
    lemmax : x ≡ x'
    lemmax with eq→ eq {& (x , x)} (case1 refl)
    lemmax | case1 s = lemma1 (ord→== s )  -- (x,x)≡(x',x')
    lemmax | case2 s with lemma2 (ord→== s ) -- (x,x)≡(x',y') with x'≡y'
    ... | refl = lemma1 (ord→== s )
    lemmay : y ≡ y'
    lemmay with lemmax
    ... | refl with lemma4 eq -- with (x,y)≡(x,y')
    ... | eq1 = lemma4 (ord→== (cong (λ  k → & k )  eq1 ))

--
-- unlike ordered pair, ZFProduct is not a HOD

data ord-pair : (p : Ordinal) → Set n where
   pair : (x y : Ordinal ) → ord-pair ( & ( < * x , * y > ) )

ZFProduct : OD
ZFProduct = record { def = λ x → ord-pair x }

-- open import Relation.Binary.HeterogeneousEquality as HE using (_≅_ )
-- eq-pair : { x x' y y' : Ordinal } → x ≡ x' → y ≡ y' → pair x y ≅ pair x' y'
-- eq-pair refl refl = HE.refl

pi1 : { p : Ordinal } →   ord-pair p →  Ordinal
pi1 ( pair x y) = x

π1 : { p : HOD } → def ZFProduct (& p) → HOD
π1 lt = * (pi1 lt )

pi2 : { p : Ordinal } →   ord-pair p →  Ordinal
pi2 ( pair x y ) = y

π2 : { p : HOD } → def ZFProduct (& p) → HOD
π2 lt = * (pi2 lt )

op-cons :  { ox oy  : Ordinal } → def ZFProduct (& ( < * ox , * oy >   ))
op-cons {ox} {oy} = pair ox oy

def-subst :  {Z : OD } {X : Ordinal  }{z : OD } {x : Ordinal  }→ def Z X → Z ≡ z  →  X ≡ x  →  def z x
def-subst df refl refl = df

p-cons :  ( x y  : HOD ) → def ZFProduct (& ( < x , y >))
p-cons x y = def-subst {_} {_} {ZFProduct} {& (< x , y >)} (pair (& x) ( & y )) refl (
   let open ≡-Reasoning in begin
       & < * (& x) , * (& y) >
   ≡⟨ cong₂ (λ j k → & < j , k >) *iso *iso ⟩
       & < x , y >
   ∎ )

op-iso :  { op : Ordinal } → (q : ord-pair op ) → & < * (pi1 q) , * (pi2 q) > ≡ op
op-iso (pair ox oy) = refl

p-iso :  { x  : HOD } → (p : def ZFProduct (&  x) ) → < π1 p , π2 p > ≡ x
p-iso {x} p = ord≡→≡ (op-iso p)

p-pi1 :  { x y : HOD } → (p : def ZFProduct (&  < x , y >) ) →  π1 p ≡ x
p-pi1 {x} {y} p = proj1 ( prod-eq ( ord→== (op-iso p) ))

p-pi2 :  { x y : HOD } → (p : def ZFProduct (&  < x , y >) ) →  π2 p ≡ y
p-pi2 {x} {y} p = proj2 ( prod-eq ( ord→== (op-iso p)))

ω-pair :  {x y : HOD} → {m : Ordinal} → & x o< next m → & y o< next m → & (x , y) o< next m
ω-pair lx ly = next< (omax<nx lx ly ) ho<

ω-opair : {x y : HOD} → {m : Ordinal} → & x o< next m → & y o< next m → & < x , y > o< next m
ω-opair {x} {y} {m} lx ly = lemma0 where
    lemma0 : & < x , y > o< next m
    lemma0 = osucprev (begin
         osuc (& < x , y >)
       <⟨ osuc<nx ho< ⟩
         next (omax (& (x , x)) (& (x , y)))
       ≡⟨ cong (λ k → next k) (sym ( omax≤ _ _ pair-xx<xy )) ⟩
         next (osuc (& (x , y)))
       ≡⟨ sym (nexto≡) ⟩
         next (& (x , y))
       ≤⟨ x<ny→≤next (ω-pair lx ly) ⟩
         next m
       ∎ ) where
          open o≤-Reasoning O

_⊗_ : (A B : HOD) → HOD
A ⊗ B  = Union ( Replace B (λ b → Replace A (λ a → < a , b > ) ))

product→ : {A B a b : HOD} → A ∋ a → B ∋ b  → ( A ⊗ B ) ∋ < a , b >
product→ {A} {B} {a} {b} A∋a B∋b = λ t → t (& (Replace A (λ a → < a , b >)))
             ⟪ lemma1 , subst (λ k → odef k (& < a , b >)) (sym *iso) lemma2 ⟫ where
    lemma1 :  odef (Replace B (λ b₁ → Replace A (λ a₁ → < a₁ , b₁ >))) (& (Replace A (λ a₁ → < a₁ , b >)))
    lemma1 = replacement← B b B∋b
    lemma2 : odef (Replace A (λ a₁ → < a₁ , b >)) (& < a , b >)
    lemma2 = replacement← A a A∋a

x<nextA : {A x : HOD} → A ∋ x →  & x o< next (odmax A)
x<nextA {A} {x} A∋x = ordtrans (c<→o< {x} {A} A∋x) ho<

A<Bnext : {A B x : HOD} → & A o< & B → A ∋ x → & x o< next (odmax B)
A<Bnext {A} {B} {x} lt A∋x = osucprev (begin
          osuc (& x)
       <⟨ osucc (c<→o< A∋x) ⟩
          osuc (& A)
       <⟨ osucc lt ⟩
          osuc (& B)
       <⟨ osuc<nx ho<  ⟩
          next (odmax B)
       ∎ ) where open o≤-Reasoning O

ZFP  : (A B : HOD) → HOD
ZFP  A B = record { od = record { def = λ x → ord-pair x ∧ ((p : ord-pair x ) → odef A (pi1 p) ∧ odef B (pi2 p) )} ;
        odmax = omax (next (odmax A)) (next (odmax B)) ; <odmax = λ {y} px → lemma y px }
   where
       lemma : (y : Ordinal) → ( ord-pair y ∧ ((p : ord-pair y) → odef A (pi1 p) ∧ odef B (pi2 p))) → y o< omax (next (odmax A)) (next (odmax B))
       lemma y lt with proj1 lt
       lemma p lt | pair x y with trio< (& A) (& B)
       lemma p lt | pair x y | tri< a ¬b ¬c = ordtrans (ω-opair (A<Bnext a (subst (λ k → odef A k ) (sym &iso)
           (proj1 (proj2 lt (pair x y))))) (lemma1 (proj2 (proj2 lt (pair x y))))) (omax-y _ _ ) where
               lemma1 : odef B y → & (* y) o< next (HOD.odmax B)
               lemma1 lt = x<nextA {B} (d→∋ B lt)
       lemma p lt | pair x y | tri≈ ¬a b ¬c = ordtrans (ω-opair (x<nextA {A} (d→∋ A ((proj1 (proj2 lt (pair x y)))))) lemma2 ) (omax-x _ _ ) where
                lemma2 :  & (* y) o< next (HOD.odmax A)
                lemma2 = ordtrans ( subst (λ k → & (* y) o< k ) (sym b) (c<→o< (d→∋ B ((proj2 (proj2 lt (pair x y))))))) ho<
       lemma p lt | pair x y | tri> ¬a ¬b c = ordtrans (ω-opair  (x<nextA {A} (d→∋ A ((proj1 (proj2 lt (pair x y))))))
           (A<Bnext c (subst (λ k → odef B k ) (sym &iso) (proj2 (proj2 lt (pair x y)))))) (omax-x _ _ )

ZFP⊆⊗ :  {A B : HOD} {x : Ordinal} → odef (ZFP A B) x → odef (A ⊗ B) x
ZFP⊆⊗ {A} {B} {px} ⟪ (pair x y) ,  p2 ⟫ = product→ (d→∋ A (proj1 (p2 (pair x y) ))) (d→∋ B (proj2 (p2 (pair x y) )))

-- axiom of choice required
-- ⊗⊆ZFP : {A B x : HOD} → ( A ⊗ B ) ∋ x → def ZFProduct (& x)
-- ⊗⊆ZFP {A} {B} {x} lt = subst (λ k → ord-pair (& k )) {!!} op-cons


------------------------------------------------------------------------------
-- The program to sort a list is correct
------------------------------------------------------------------------------

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

-- This module prove the correctness of a program which sorts a list
-- by converting it into an ordered tree and then back to a list
-- (Burstall 1969, p. 45).

module FOTC.Program.SortList.CorrectnessProofI where

open import FOTC.Base
open import FOTC.Data.Nat.List.Type
open import FOTC.Program.SortList.PropertiesI
open import FOTC.Program.SortList.Properties.Totality.TreeI
open import FOTC.Program.SortList.SortList

------------------------------------------------------------------------------
-- Main theorem: The sort program generates an ordered list.
sortCorrect : ∀ {is} → ListN is → OrdList (sort is)
sortCorrect {is} Lis =
  subst OrdList
        refl
        (flatten-OrdList (makeTree-Tree Lis) (makeTree-OrdTree Lis))

------------------------------------------------------------------------------
-- References
--
-- Burstall, R. M. (1969). Proving properties of programs by
-- structural induction. The Computer Journal 12.1, pp. 41–48.