{- Proof of the Universal Property of Our Fold -}

module FoldUniv where

open import Function using (id)
open import Data.Unit using (⊤ ; tt) public
open import Data.Empty using (⊥) public
open import Data.Sum using (_⊎_; [_,_]; inj₁ ; inj₂) public
open import Data.Product
open import Data.Nat using (ℕ)
open import Data.Bool using (Bool)
open import Data.List
open import Data.List.Any as Any
open import Data.Product
open Any.Membership-≡ hiding (_⊆_)
open import Relation.Binary.PropositionalEquality using (_≡_; refl; cong)

data PolyF : Set where
  Id    : PolyF
  K1    : PolyF
  Kℕ    : PolyF
  KB    : PolyF
  _∔_   : (F : PolyF) → (G : PolyF) → PolyF
  _⋆_   : (F : PolyF) → (G : PolyF) → PolyF

infixr 30 _⋆_
infixr 20 _∔_

⟦_⟧ : PolyF → Set → Set
⟦_⟧ Id A      = A
⟦_⟧ K1 A     = ⊤
⟦_⟧ Kℕ A     = ℕ
⟦_⟧ KB A     = Bool
⟦_⟧ (F ∔ G) A = ⟦ F ⟧ A ⊎ ⟦ G ⟧ A
⟦_⟧ (F ⋆ G) A = ⟦ F ⟧ A × ⟦ G ⟧ A

fmap : ∀ {A B} F → (A → B) → ⟦ F ⟧ A → ⟦ F ⟧ B
fmap Id f = f
fmap K1 f = id
fmap Kℕ f = id
fmap KB f = id
fmap (F ∔ G) f =
  Data.Sum.map (fmap F f) (fmap G f)
fmap (F ⋆ G) f =
  Data.Product.map (fmap F f) (fmap G f)

Algebras : List PolyF → Set → Set
Algebras []       A = ⊤
Algebras (F ∷ Fs) A = (⟦ F ⟧ A → A) × Algebras Fs A

extract : {F : PolyF} {Fs : List PolyF} {A : Set}
          → F ∈ Fs → Algebras Fs A → (⟦ F ⟧ A → A)
extract (here refl) (f , _ ) = f
extract (there f∈ ) (f , fs) = extract f∈ fs

data μ (Fs : List PolyF) : Set where
  In : ∀ {F} → F ∈ Fs → ⟦ F ⟧ (μ Fs) → μ Fs

mutual
  fold : ∀ Fs {A} → Algebras Fs A → μ Fs → A
  fold Fs fs (In {F} F∈ x) = extract F∈ fs (mapFold Fs fs F x)

  mapFold : (Fs : List PolyF) {A : Set}
          → Algebras Fs A → (G : PolyF) → ⟦ G ⟧ (μ Fs) → ⟦ G ⟧ A
  mapFold Fs fs Id       x          = fold Fs fs x
  mapFold Fs fs K1       b          = b
  mapFold Fs fs Kℕ       b          = b
  mapFold Fs fs KB       b          = b
  mapFold Fs fs (G ∔ G') (inj₁ xs)  = inj₁ (mapFold Fs fs G xs)
  mapFold Fs fs (G ∔ G') (inj₂ xs)  = inj₂ (mapFold Fs fs G' xs)
  mapFold Fs fs (G ⋆ G') (xs , xs') = mapFold Fs fs G xs , mapFold Fs fs G' xs'

mutual

 fold-universal : (Fs : List PolyF) → {A : Set}
                → (h : μ Fs → A) → (fs : Algebras Fs A)
                → (∀ F → (F∈ : F ∈ Fs) →
                   ∀ xs → h (In F∈ xs) ≡ extract F∈ fs (fmap F h xs))
                → (∀ xs → h xs ≡ fold Fs fs xs)
 fold-universal Fs h fs hom (In {F} F∈ xs)
   rewrite hom F F∈ xs = cong (extract F∈ fs) (mapFold-univ Fs F h fs hom xs)

 mapFold-univ : (Fs : List PolyF) (G : PolyF)
              → ∀ {A : Set}
              → (h : μ Fs → A) → (fs : Algebras Fs A)
              → (∀ F → (F∈ : F ∈ Fs) →
                   ∀ xs → h (In F∈ xs) ≡ extract F∈ fs (fmap F h xs))
              → (Gxs : ⟦ G ⟧ (μ Fs))
              → fmap G h Gxs ≡ mapFold Fs fs G Gxs
 mapFold-univ Fs Id h fs hom xs = fold-universal Fs h fs hom xs
 mapFold-univ Fs K1 h fs hom tt = refl
 mapFold-univ Fs Kℕ h fs hom n = refl
 mapFold-univ Fs KB h fs hom b = refl
 mapFold-univ Fs (G₁ ∔ G₂) h fs hom (inj₁ x) = cong inj₁ (mapFold-univ Fs G₁ h fs hom x)
 mapFold-univ Fs (G₁ ∔ G₂) h fs hom (inj₂ y) = cong inj₂ (mapFold-univ Fs G₂ h fs hom y)
 mapFold-univ Fs (G₁ ⋆ G₂) h fs hom (x , y)
     rewrite mapFold-univ Fs G₁ h fs hom x | mapFold-univ Fs G₂ h fs hom y = refl


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

module Categories where

open import Prelude
open import Cubical.Foundations.HLevels

record PreCategory ℓ₁ ℓ₂ : Type (ℓsuc (ℓ₁ ℓ⊔ ℓ₂)) where
  no-eta-equality
  field
    Ob    : Type ℓ₁
    Hom   : Ob → Ob → Type ℓ₂
    Id    : ∀ {X} → Hom X X
    Comp  : ∀ {X Y Z} → Hom Y Z → Hom X Y → Hom X Z
    assoc-Comp : ∀  {W X Y Z}
                    (f : Hom Y Z)
                    (g : Hom X Y)
                    (h : Hom W X) →
                    Comp f (Comp g h) ≡ Comp (Comp f g) h
    Comp-Id  : ∀ {X Y} (f : Hom X Y) → Comp f Id ≡ f
    Id-Comp  : ∀ {X Y} (f : Hom X Y) → Comp Id f ≡ f
    Hom-Set  : ∀ {X Y} → isSet (Hom X Y)

  infixr 0 _⟶_
  _⟶_ = Hom

  infixl 0 _⟵_
  _⟵_ = flip Hom

  infixr 9 _·_
  _·_ = Comp

  variable
    X Y Z : Ob

  infix 4 _≅_
  _≅_ : Ob → Ob → Type _

  Isomorphism : (X ⟶ Y) → Type ℓ₂
  Isomorphism {X} {Y} f = Σ[ g ⦂ Y ⟶ X ] × (g · f ≡ Id) × (f · g ≡ Id)

  X ≅ Y = Σ (X ⟶ Y) Isomorphism

  Domain : (X ⟶ Y) → Ob
  Domain {X} {Y} _ = X

  Codomain : (X ⟶ Y) → Ob
  Codomain {X} {Y} _ = Y

  module _ {X Y : Ob} where
    Monic : (X ⟶ Y) → Type _
    Monic f = ∀ {Z} → (g₁ g₂ : Z ⟶ X) → f · g₁ ≡ f · g₂ → g₁ ≡ g₂

    Epic : (X ⟶ Y) → Type _
    Epic f = ∀ {Z} → (g₁ g₂ : Y ⟶ Z) → g₁ · f ≡ g₂ · f → g₁ ≡ g₂

  IsInitial : Ob → Type _
  IsInitial I = ∀ {X} → isContr (I ⟶ X)

  IsTerminal : Ob → Type _
  IsTerminal T = ∀ {X} → isContr (X ⟶ T)

  Initial = ∃ x × IsInitial x
  Terminal = ∃ x × IsTerminal x

  refl-≅ : X ≅ X
  refl-≅ .fst = Id
  refl-≅ .snd .fst = Id
  refl-≅ .snd .snd .fst = Comp-Id Id
  refl-≅ .snd .snd .snd = Comp-Id Id

  sym-≅ : X ≅ Y → Y ≅ X
  sym-≅ X≅Y .fst = X≅Y .snd .fst
  sym-≅ X≅Y .snd .fst = X≅Y .fst
  sym-≅ X≅Y .snd .snd .fst = X≅Y .snd .snd .snd
  sym-≅ X≅Y .snd .snd .snd = X≅Y .snd .snd .fst

  open import Path.Reasoning

  trans-≅ : X ≅ Y → Y ≅ Z → X ≅ Z
  trans-≅ X≅Y Y≅Z .fst = Y≅Z .fst · X≅Y .fst
  trans-≅ X≅Y Y≅Z .snd .fst = X≅Y .snd .fst · Y≅Z .snd .fst
  trans-≅ X≅Y Y≅Z .snd .snd .fst =
    (X≅Y .snd .fst · Y≅Z .snd .fst) · (Y≅Z .fst · X≅Y .fst) ≡⟨ assoc-Comp _ _ _ ⟩
    ((X≅Y .snd .fst · Y≅Z .snd .fst) · Y≅Z .fst) · X≅Y .fst ≡˘⟨ cong (_· X≅Y .fst) (assoc-Comp _ _ _) ⟩
    (X≅Y .snd .fst · (Y≅Z .snd .fst · Y≅Z .fst)) · X≅Y .fst ≡⟨ cong (λ yz → (X≅Y .snd .fst · yz) · X≅Y .fst) (Y≅Z .snd .snd .fst) ⟩
    (X≅Y .snd .fst · Id) · X≅Y .fst ≡⟨ cong (_· X≅Y .fst) (Comp-Id (X≅Y .snd .fst)) ⟩
    X≅Y .snd .fst · X≅Y .fst ≡⟨ X≅Y .snd .snd .fst ⟩
    Id ∎
  trans-≅ X≅Y Y≅Z .snd .snd .snd =
    (Y≅Z .fst · X≅Y .fst) · (X≅Y .snd .fst · Y≅Z .snd .fst) ≡⟨ assoc-Comp _ _ _ ⟩
    ((Y≅Z .fst · X≅Y .fst) · X≅Y .snd .fst) · Y≅Z .snd .fst ≡˘⟨ cong (_· Y≅Z .snd .fst) (assoc-Comp _ _ _) ⟩
    (Y≅Z .fst · (X≅Y .fst · X≅Y .snd .fst)) · Y≅Z .snd .fst ≡⟨ cong (λ xy → (Y≅Z .fst · xy) · Y≅Z .snd .fst) (X≅Y .snd .snd .snd) ⟩
    (Y≅Z .fst · Id) · Y≅Z .snd .fst ≡⟨ cong (_· Y≅Z .snd .fst) (Comp-Id _) ⟩
    Y≅Z .fst · Y≅Z .snd .fst ≡⟨ Y≅Z .snd .snd .snd ⟩
    Id ∎

  idToIso : X ≡ Y → X ≅ Y
  idToIso {X} {Y} X≡Y = subst (X ≅_) X≡Y refl-≅

  ≅-set : isSet (X ≅ Y)
  ≅-set = isOfHLevelΣ 2 Hom-Set
    λ _ → isOfHLevelΣ 2 Hom-Set
    λ _ → isOfHLevelΣ 2 (isOfHLevelSuc 2 Hom-Set _ _)
    λ _ → isOfHLevelSuc 2 Hom-Set _ _

record Category ℓ₁ ℓ₂ : Type (ℓsuc (ℓ₁ ℓ⊔ ℓ₂)) where
  no-eta-equality
  field
    preCategory : PreCategory ℓ₁ ℓ₂
  open PreCategory preCategory public
  field
    univalent : {X Y : Ob} → (X ≡ Y) ≃ (X ≅ Y)

module _ {ℓ₁ ℓ₂} (C : Category ℓ₁ ℓ₂) where
  open Category C

  _[_,_] : Ob → Ob → Type ℓ₂
  _[_,_] = Hom
  {-# INLINE _[_,_] #-}

  _[_∘_] : (Y ⟶ Z) → (X ⟶ Y) → (X ⟶ Z)
  _[_∘_] = Comp
  {-# INLINE _[_∘_] #-}


open import Relation.Binary hiding (_⇒_)

module Experiments.Category {ℓ₁ ℓ₂ ℓ₃} (APO : Preorder ℓ₁ ℓ₂ ℓ₃) where

open import Level
open Preorder APO renaming (_∼_ to _≤_)

open import Function as Fun using (flip)
open import Relation.Unary using (Pred)
open import Data.Product as Prod using (_,_; _×_)
open import Relation.Binary.PropositionalEquality as PEq using (_≡_; cong)
open PEq.≡-Reasoning
open import Function.Inverse using (Inverse)
open import Algebra.FunctionProperties

record IsMP {ℓ}(P : Pred Carrier ℓ) : Set (ℓ ⊔ ℓ₁ ⊔ ℓ₃) where
  field
    monotone : ∀ {c c'} → c ≤ c' → P c → P c'

    monotone-refl  : ∀ {c} p → monotone (refl {c}) p PEq.≡ p
    monotone-trans : ∀ {c c' c''} p (c~c' : c ≤ c')(c'~c'' : c' ≤ c'') →
                     monotone (trans c~c' c'~c'') p
                     PEq.≡
                     monotone c'~c'' (monotone c~c' p)

-- monotone predicates over a fixed carrier
record MP ℓ : Set (suc ℓ ⊔ ℓ₁ ⊔ ℓ₃) where
  constructor mp
  field
    pred  : Pred Carrier ℓ
    is-mp : IsMP pred

  open IsMP is-mp public

MP₀ = MP zero

-- application
_·_ : ∀ {ℓ} → MP ℓ → Carrier → Set _
(mp P _) · c = P c

-- monotone-predicate equality
_≗_ : ∀ {ℓ₁} → MP ℓ₁ → MP ℓ₁ → Set _
P ≗ Q = ∀ {c} → P · c PEq.≡ Q · c

import Data.Unit as Unit

Const : ∀ {ℓ}(P : Set ℓ) → MP ℓ
Const P = mp (λ _ → P) (record {
    monotone = λ x p → p ;
    monotone-refl = λ p → PEq.refl ;
    monotone-trans = λ p c~c' c'~c'' → PEq.refl
  })

⊤ : MP zero
⊤ = Const Unit.⊤

-- we package the Agda function that represents morphisms
-- in this category in a record such that P ⇒ Q doesn't get
-- reduced to the simple underlying type of `apply`
infixl 30 _⇒_
record _⇒_ {p q}(P : MP p)(Q : MP q) : Set (p ⊔ q ⊔ ℓ₁ ⊔ ℓ₃) where
  constructor mk⇒

  field
    apply         : ∀ {c} → P · c → Q · c

    monotone-comm : ∀ {c c'}(c~c' : c ≤ c'){p : P · c} →
                    apply {c'} (MP.monotone P c~c' p) PEq.≡ MP.monotone Q c~c' (apply p)

open _⇒_ public

-- Const identifies objects that are terminal for this category
terminal : ∀ {ℓ a}{A : Set a}{P : MP ℓ} → A → P ⇒ Const A
terminal x = mk⇒ (λ _ → x) λ c~c' → λ {p} → PEq.refl

infixl 100 _∘_
_∘_ : ∀ {ℓ₁ ℓ₂ ℓ₃}{P : MP ℓ₁}{Q : MP ℓ₂}{R : MP ℓ₃} → Q ⇒ R → P ⇒ Q → P ⇒ R
_∘_ {P = P}{Q}{R} F G = mk⇒
  (λ p → apply F (apply G p))
  (λ c~c' →
    begin _
      ≡⟨ PEq.cong (λ e → apply F e) (monotone-comm G c~c') ⟩
    apply F (MP.monotone Q c~c' (apply G _))
      ≡⟨ monotone-comm F c~c' ⟩
    _ ∎
  )

id : ∀ {ℓ}(P : MP ℓ) → P ⇒ P
id P = mk⇒ Fun.id (λ _ → PEq.refl)

-- morphism equality
infixl 20 _⇒≡_
_⇒≡_  : ∀ {ℓ₁ ℓ₂}{P : MP ℓ₁}{Q : MP ℓ₂}(F G : P ⇒ Q) → Set _
_⇒≡_ {P = P}{Q} F G = ∀ {c}(p : P · c) → apply F p PEq.≡ apply G p

-- extensionality for morphisms
-- This should be provable from proof-irrelevance + extensionality.
⇒-Ext : ∀ (ℓ₁ ℓ₂ : Level) → Set _
⇒-Ext ℓ₁ ℓ₂ = ∀ {P : MP ℓ₁}{Q : MP ℓ₂}{F G : P ⇒ Q} → F ⇒≡ G → F PEq.≡ G

-- isomorphism
record _≅_ {ℓ}(P Q : MP ℓ) : Set (ℓ₁ ⊔ ℓ ⊔ ℓ₃) where
  field
    to    : P ⇒ Q
    from  : Q ⇒ P
    left-inv  : to ∘ from ⇒≡ id Q
    right-inv : from ∘ to ⇒≡ id P

∘-assoc : ∀ {p q r s}{P : MP p}{Q : MP q}{R : MP r}{S : MP s}
            {F : R ⇒ S}{G : Q ⇒ R}{H : P ⇒ Q} →
            F ∘ (G ∘ H) ⇒≡ (F ∘ G) ∘ H
∘-assoc _ = PEq.refl

∘-left-id : ∀ {P Q : MP ℓ₁}{F : P ⇒ Q} → (id Q) ∘ F ⇒≡ F
∘-left-id _ = PEq.refl

∘-right-id : ∀ {P Q : MP ℓ₁}{F : P ⇒ Q} → F ∘ (id P) ⇒≡ F
∘-right-id p = PEq.refl

module Product where
  -- within the category

  infixl 40 _⊗_
  _⊗_ : ∀ {ℓ₁ ℓ₂} → MP ℓ₁ → MP ℓ₂ → MP (ℓ₁ ⊔ ℓ₂)
  P ⊗ Q = mp
      (λ c → (P · c) × (Q · c))
      (record {
        monotone = λ{ c~c' (p , q) →
            MP.monotone P c~c' p
          , MP.monotone Q c~c' q
        };
        monotone-refl = λ _ → PEq.cong₂ _,_ (MP.monotone-refl P _) (MP.monotone-refl Q _) ;
        monotone-trans = λ _ _ _ → PEq.cong₂ _,_ (MP.monotone-trans P _ _ _) (MP.monotone-trans Q _ _ _)
      })

  ⟨_,_⟩ : ∀ {y p q}{Y : MP y}{P : MP p}{Q : MP q} → Y ⇒ P → Y ⇒ Q → Y ⇒ P ⊗ Q
  ⟨ F , G ⟩ = mk⇒
    (λ x → apply F x , apply G x)
    (λ c~c' → PEq.cong₂ _,_ (monotone-comm F c~c') (monotone-comm G c~c'))

  π₁ : ∀ {ℓ₁ ℓ₂}{P : MP ℓ₁}{Q : MP ℓ₂} → P ⊗ Q ⇒ P
  π₁ = mk⇒ (λ{ (pc , qc) → pc}) (λ c~c' → PEq.refl)

  π₂ : ∀ {ℓ₁ ℓ₂}{P : MP ℓ₁}{Q : MP ℓ₂} → P ⊗ Q ⇒ Q
  π₂ = mk⇒ (λ{ (pc , qc) → qc}) (λ c~c' → PEq.refl)

  swap : ∀ {ℓ₁ ℓ₂}(P : MP ℓ₁)(Q : MP ℓ₂) → P ⊗ Q ⇒ Q ⊗ P
  swap _ _ = mk⇒ Prod.swap λ c~c' → PEq.refl

  comm : ∀ {ℓ₁ ℓ₂ ℓ₃}(P : MP ℓ₁)(Q : MP ℓ₂)(R : MP ℓ₃) → (P ⊗ Q) ⊗ R ⇒ P ⊗ (Q ⊗ R)
  comm _ _ _ = mk⇒
    (λ{ ((p , q) , r) → p , (q , r) })
    (λ c~c' → PEq.refl)

  xmap : ∀ {ℓ₁ ℓ₂ ℓ₃ ℓ₄}{P : MP ℓ₁}{Q : MP ℓ₂}{R : MP ℓ₃}{S : MP ℓ₄} →
         (F : P ⇒ R)(G : Q ⇒ S) → P ⊗ Q ⇒ R ⊗ S
  xmap F G = ⟨ F ∘ π₁ , G ∘ π₂ ⟩

  uncurry₁ : ∀ {ℓ₁ ℓ₂ ℓ₃}{A : Set ℓ₁}{P : MP ℓ₂}{Q : MP ℓ₃} →
             (A → P ⇒ Q) → (Const A ⊗ P ⇒ Q)
  uncurry₁ {A = A}{P}{Q} f = mk⇒
    (λ{ (a , p) → apply (f a) p })
    (λ{ c~c' {a , p} → monotone-comm (f a) c~c' })

  module ⊗-Properties where
    π₁-comm : ∀ {y p q}{Y : MP y}{P : MP p}{Q : MP q}{F : Y ⇒ P}{G : Y ⇒ Q} →
            π₁ ∘ ⟨ F , G ⟩ ⇒≡ F
    π₁-comm _ = PEq.refl

    π₂-comm : ∀ {y p q}{Y : MP y}{P : MP p}{Q : MP q}{F : Y ⇒ P}{G : Y ⇒ Q} →
            π₂ ∘ ⟨ F , G ⟩ ⇒≡ G
    π₂-comm _ = PEq.refl

    unique : ∀ {y p q}{Y : MP y}{P : MP p}{Q : MP q}{g : Y ⇒ (P ⊗ Q)} → ⟨ π₁ ∘ g , π₂ ∘ g ⟩ ⇒≡ g
    unique _ = PEq.refl

module Forall (funext : ∀ {a b} → PEq.Extensionality a b) where
  -- ∀-quantification over Set

  Forall : ∀ {ℓ₁ ℓ₂}{I : Set ℓ₁}(P : I → MP ℓ₂) → MP _
  Forall {I = I} P = mp
    (λ c → ∀ (i : I) → P i · c)
    (record {
      monotone = λ x x₁ i → MP.monotone (P i) x (x₁ i) ;
      monotone-refl = λ p → funext λ i → MP.monotone-refl (P i) (p i) ;
      monotone-trans = λ p c~c' c'~c'' → funext λ i → MP.monotone-trans (P i) (p i) c~c' c'~c'' })

module ListAll where
  -- quantification over the elements in a list

  open import Data.Nat
  open import Data.List
  import Data.List.All as All
  open import Data.List.All.Properties
  open import Data.List.All.Properties.Extra

  module _ {a p} {A : Set a} {P : A → Set p} where

    map-id' : ∀ {xs} (pxs : All.All P xs) → All.map {P = P} {Q = P} (λ x → x) pxs ≡ pxs
    map-id' All.[]         = PEq.refl
    map-id' (px All.∷ pxs) = cong (px All.∷_)  (map-id' pxs)

  All : ∀ {ℓ₁}{I : Set ℓ₁}(P : I → MP ℓ₂) → List I → MP _
  All P xs = mp
    (λ c → All.All (λ x → P x · c) xs)
    (record {
      monotone = λ c~c' ps → All.map (λ {i} x → MP.monotone (P i) c~c' x ) ps ;
      monotone-refl = λ p → (begin
        All.map (λ {i} x → MP.monotone (P i) refl x) p
          ≡⟨ map-cong p (λ {i} px → MP.monotone-refl (P i) px) ⟩
        All.map (λ x → x) p
          ≡⟨ map-id' p ⟩
        p ∎) ;
      monotone-trans = λ p c~c' c'~c'' → (begin
       All.map (λ {i} x → MP.monotone (P i) (trans c~c' c'~c'') x) p
         ≡⟨ map-cong p (λ {i} p → MP.monotone-trans (P i) p c~c' c'~c'') ⟩
       All.map (λ {i} x → MP.monotone (P i) c'~c'' (MP.monotone (P i) c~c' x)) p
         ≡⟨ PEq.sym (map-map p) ⟩
       All.map (λ {i} x → MP.monotone (P i) c'~c'' x) (All.map (λ {i} x → MP.monotone (P i) c~c' x) p)
       ∎) })

module Exists where
  -- ∃-quantification over Set

  Exists : ∀ {ℓ₁ ℓ₂}{I : Set ℓ₁}(P : I → MP ℓ₂) → MP _
  Exists {I = I} P = mp (λ x → Prod.∃ λ (i : I) → P i · x) (record {
      monotone = λ{ c~c' (i , px) → i , MP.monotone (P i) c~c' px } ;
      monotone-refl = λ{
        (i , px) → PEq.cong (λ u → i , u) (MP.monotone-refl (P i) px) };
      monotone-trans = (λ {
        (i , px) p q → PEq.cong (λ u → i , u) (MP.monotone-trans (P i) px p q)})
    })

  elim : ∀ {ℓ₁ ℓ₂ ℓ₃}{I : Set ℓ₁}{P : I → MP ℓ₂}{Q : MP ℓ₃} →
         (∀ {i} → P i ⇒ Q) → Exists P ⇒ Q
  elim {P = P}{Q} F = mk⇒
    (λ{ (i , pi) → apply F pi})
    (λ{ c~c' {(i , pi)} → monotone-comm F c~c' })

  open Product
  ∃-⊗-comm : ∀ {ℓ₁ ℓ₂ ℓ₃}{I : Set ℓ₁}(P : I → MP ℓ₂)(Q : MP ℓ₃) →
             Exists (λ i → P i) ⊗ Q ⇒ Exists (λ i → P i ⊗ Q)
  ∃-⊗-comm _ _ = mk⇒
    (λ{ ((i , pi) , q) → (i , pi , q)})
    (λ c~c' → PEq.refl)

module Monoid where
  -- identifies _⊗_ as a tensor/monoidal product
  open Product

  -- associator
  assoc : ∀ {p q r}{P : MP p}{Q : MP q}{R : MP r} → (P ⊗ Q) ⊗ R ≅ P ⊗ (Q ⊗ R)
  assoc = record {
    to = mk⇒ (λ{ ((p , q) , r) → p , (q , r) }) (λ c~c' → PEq.refl) ;
    from = mk⇒ (λ{ (p , (q , r)) → (p , q) , r }) (λ c~c' → PEq.refl) ;
    left-inv = λ _ → PEq.refl ;
    right-inv = λ _ → PEq.refl }

  -- left unitor
  ⊗-left-id : ∀ {p}{P : MP p} → ⊤ ⊗ P ≅ P
  ⊗-left-id = record {
    to = π₂ {P = ⊤} ;
    from = ⟨ mk⇒ (λ x → Unit.tt) (λ c~c' → PEq.refl) , id _ ⟩ ;
    left-inv = λ p → PEq.refl ;
    right-inv = λ p → PEq.refl }

  -- right unitor
  ⊗-right-id : ∀ {p}{P : MP p} → P ⊗ ⊤ ≅ P
  ⊗-right-id = record {
    to = π₁ {Q = ⊤} ;
    from = ⟨ mk⇒ (λ {c} z → z) (λ c~c' → PEq.refl) , mk⇒ (λ {c} _ → Unit.tt) (λ c~c' → PEq.refl) ⟩ ;
    left-inv = λ p → PEq.refl ;
    right-inv = λ p → PEq.refl }

  -- TODO: coherence conditions

module Exponential
  (trans-assoc : ∀ {c c' c'' c'''}{p : c ≤ c'}{q : c' ≤ c''}{r : c'' ≤ c'''} →
                 trans (trans p q) r PEq.≡ trans p (trans q r))
  (trans-refl₁ : ∀ {c c'}{p : c ≤ c'} → trans refl p PEq.≡ p)
  (trans-refl₂ : ∀ {c c'}{p : c ≤ c'} → trans p refl PEq.≡ p)
  where

  -- for convencience we assume extensionality for morphisms here for now
  postulate ⇒-ext : ∀ {ℓ₁ ℓ₂} → ⇒-Ext ℓ₁ ℓ₂

  open Product

  -- the preorder that we have defined monotonicity by is itself
  -- a monotone predicate
  ≤mono : Carrier → MP _
  ≤mono c = mp (λ c' → c ≤ c' ) (record {
    monotone = flip trans  ;
    monotone-refl = λ _ → trans-refl₂ ;
    monotone-trans = λ _ _ _ → PEq.sym trans-assoc })

  -- ... such that we can define the notion of a monotone function as follows:
  Mono⇒ : ∀ {ℓ ℓ₂}(P : MP ℓ)(Q : MP ℓ₂)(c : Carrier) → Set _
  Mono⇒ P Q c = ≤mono c ⊗ P ⇒ Q
  -- the intuition here comes from the naive interpretation
  -- of the type of curry: (X ⊗ P ⇒ Q) → X ⇒ (Const (P ⇒ Q)).
  -- unfolding the return type you would get something like the following Agda type:
  --   ∀ c → X · c → (∀ c' → P · c' → Q · c')
  -- this is too weak, because c' and c are unrelated and thus we can't combine
  -- X · c and P · c' into a product (X ⊗ P) · c'.
  -- The above Mono⇒ fixes this by simply requiring the relation c ≤ c' as
  -- an additional argument.

  infixl 80 _^_
  _^_ : ∀ {ℓ₁ ℓ₂}(Q : MP ℓ₁)(P : MP ℓ₂) → MP _
  Q ^ P = mp
    (Mono⇒ P Q)
    (record {
      monotone = λ c~c' φ →
        mk⇒
          (λ p → apply φ (trans c~c' (Prod.proj₁ p) , Prod.proj₂ p))
          (λ{ c~c'' {w , p} → (begin
            apply φ (trans c~c' (MP.monotone (≤mono _) c~c'' w) , (MP.monotone P c~c'' p))
              ≡⟨ PEq.cong (λ u → apply φ (u , MP.monotone P c~c'' p)) (PEq.sym trans-assoc) ⟩
            apply φ (MP.monotone (≤mono _ ⊗ P) c~c'' (trans c~c' w , p))
              ≡⟨ monotone-comm φ c~c'' ⟩
            MP.monotone Q c~c'' (apply φ (trans c~c' w , p))
          ∎)});
      monotone-refl  = λ φ → ⇒-ext (λ p → PEq.cong (λ u → apply φ (u , (Prod.proj₂ p))) trans-refl₁);
      monotone-trans = λ φ w₀ w₁ → ⇒-ext λ p → PEq.cong (λ u → apply φ (u , Prod.proj₂ p)) trans-assoc
    })

  curry : ∀ {ℓ₁ ℓ₂ ℓ₃}{X : MP ℓ₁}{Y : MP ℓ₂}{Z : MP ℓ₃}(F : (X ⊗ Y) ⇒ Z) → X ⇒ (Z ^ Y)
  curry {X = X}{Y}{Z} F = mk⇒
    (λ xc → mk⇒
      (λ{ (w , yc) → apply F ((MP.monotone X w xc) , yc)})
      (λ{ c~c' {w , yc} → (begin
        apply F (MP.monotone X (trans w c~c') xc , MP.monotone Y c~c' yc)
          ≡⟨ PEq.cong (λ u → apply F (u , _)) (MP.monotone-trans X xc w c~c') ⟩
        apply F (MP.monotone X c~c' (MP.monotone X w xc) , MP.monotone Y c~c' yc)
          ≡⟨ monotone-comm F c~c' ⟩
        MP.monotone Z c~c' (apply F (MP.monotone X w xc , yc))
      ∎ )}))
    λ c~c' {xc} → ⇒-ext λ p →
      PEq.cong (λ u → apply F (u , _)) (PEq.sym (MP.monotone-trans X xc c~c' (Prod.proj₁ p)))

  ε : ∀ {ℓ₁ ℓ₂}{Y : MP ℓ₁}{Z : MP ℓ₂} → (Z ^ Y) ⊗ Y ⇒ Z
  ε {Y = Y}{Z} = mk⇒
    (λ zʸ×y → apply (Prod.proj₁ zʸ×y) (refl , Prod.proj₂ zʸ×y) )
    λ{ c~c' {φ@(F , p)} → (begin
      (apply F (trans c~c' refl , MP.monotone Y c~c' p))
        ≡⟨ PEq.cong (λ u → apply F (u , _)) trans-refl₂ ⟩
      (apply F (c~c' , MP.monotone Y c~c' p))
        ≡⟨ PEq.sym (PEq.cong (λ u → apply F (u , _)) trans-refl₁) ⟩
      (apply F (trans refl c~c' , MP.monotone Y c~c' p))
        ≡⟨ PEq.refl ⟩
      (apply F (MP.monotone (≤mono _ ⊗ Y) c~c' (refl , p)))
        ≡⟨ monotone-comm F c~c' ⟩
      MP.monotone Z c~c' (apply F (refl , p))
    ∎ )}

  uncurry : ∀ {ℓ₁ ℓ₂ ℓ₃}{X : MP ℓ₁}{Y : MP ℓ₂}{Z : MP ℓ₃}(F : X ⇒ (Z ^ Y)) → (X ⊗ Y) ⇒ Z
  uncurry {X = x}{Y}{Z} F = ε ∘ xmap F (id Y)

module Sum where
  open import Data.Sum as Sum using (_⊎_)

  infixl 30 _⊕_
  _⊕_ : ∀ {ℓ₁ ℓ₂} → MP ℓ₁ → MP ℓ₂ → MP (ℓ₁ ⊔ ℓ₂)
  P ⊕ Q = mp
      (λ c → (P · c) ⊎ (Q · c))
      (record {
        monotone = λ{
          c≤c' (Sum.inj₁ p) → Sum.inj₁ (MP.monotone P c≤c' p) ;
          c≤c' (Sum.inj₂ q) → Sum.inj₂ (MP.monotone Q c≤c' q)
        } ;
        monotone-refl = λ{
          (Sum.inj₁ p) → PEq.cong Sum.inj₁ (MP.monotone-refl P p) ;
          (Sum.inj₂ q) → PEq.cong Sum.inj₂ (MP.monotone-refl Q q) };
        monotone-trans = λ{
          (Sum.inj₁ p) c≤c' c'≤c'' → PEq.cong Sum.inj₁ (MP.monotone-trans P p c≤c' c'≤c'') ;
          (Sum.inj₂ q) c≤c' c'≤c'' → PEq.cong Sum.inj₂ (MP.monotone-trans Q q c≤c' c'≤c'') }
      })

  -- canonical injections
  inj₁ : ∀ {ℓ₁ ℓ₂}{P : MP ℓ₁}(Q : MP ℓ₂) → P ⇒ (P ⊕ Q)
  inj₁ Q = mk⇒ Sum.inj₁ λ c~c' → PEq.refl

  inj₂ : ∀ {ℓ₁ ℓ₂}(P : MP ℓ₁){Q : MP ℓ₂} → Q ⇒ (P ⊕ Q)
  inj₂ Q = mk⇒ Sum.inj₂ λ c~c' → PEq.refl

  [_,_] : ∀ {ℓ₁ ℓ₂ ℓ₃}{P : MP ℓ₁}{Q : MP ℓ₂}{R : MP ℓ₃} → P ⇒ R → Q ⇒ R → (P ⊕ Q) ⇒ R
  [_,_] F G = mk⇒
    (λ{ (Sum.inj₁ x) → apply F x ; (Sum.inj₂ y) → apply G y})
    (λ{
      c~c' {Sum.inj₁ x} → monotone-comm F c~c' ;
      c~c' {Sum.inj₂ y} → monotone-comm G c~c'
    })

  -- TODO [_,_] is unique

  [g,*]∘inj₁ : ∀ {ℓ₁ ℓ₂ ℓ₃}{P : MP ℓ₁}{Q : MP ℓ₂}{R : MP ℓ₃} → (F : P ⇒ R)(G : Q ⇒ R) → [ F , G ] ∘ inj₁ _ ⇒≡ F
  [g,*]∘inj₁ F G p = PEq.refl

  [*,g]∘inj₂ : ∀ {ℓ₁ ℓ₂ ℓ₃}{P : MP ℓ₁}{Q : MP ℓ₂}{R : MP ℓ₃} → (F : P ⇒ R)(G : Q ⇒ R) → [ F , G ] ∘ inj₂ _ ⇒≡ G
  [*,g]∘inj₂ F G p = PEq.refl


{-# OPTIONS --no-termination-check
  #-}

------------------------------------------------------------------------
-- A terminating parser data type and the accompanying interpreter
------------------------------------------------------------------------

-- This code is based on "Parallel Parsing Processes" by Koen
-- Claessen.

module Parallel where

open import Parallel.Index

open import Data.Product renaming (_,_ to pair)
open import Data.Bool
open import Data.Nat
open import Data.Product.Record using (_,_)
import Data.List as List
open List using (List; []; _∷_; _++_)
import Data.Vec as Vec
open Vec using (Vec; []; _∷_) renaming (_++_ to _<+>_)
open import Category.Monad.State
open import Data.Function
open import Data.Maybe
import Relation.Binary.PropositionalEquality as PropEq
open PropEq using (_≡_; refl)

------------------------------------------------------------------------
-- Parser monad

P : Set -> (Set -> Set)
P tok = StateT (List tok) List

------------------------------------------------------------------------
-- Basic parsers (no CPS)

private
 module Base where

  -- returnPlus below takes a _vector_ of immediate results, since
  -- otherwise the returnPlus/returnPlus case of _∣_ would not type
  -- check. (Its type would have to be changed.)
  --
  -- (The vector could just as well have been a list, if it were not
  -- for the unused module IncorrectBind below. However, documenting
  -- that this list is never empty is not a bad thing, and does not
  -- cost much.)

  codata Parser (tok r : Set) : Index -> Set where
    symbolBind : forall {i : tok -> Index} ->
                 ((c : tok) -> Parser tok r (i c)) -> Parser tok r 0I
    fail       : Parser tok r 0I
    returnPlus : forall {e d n} ->
                 Vec r (suc n) -> Parser tok r (e , d) ->
                 Parser tok r (true , suc d)

  -- Note that the type of this return function is not suitable if you
  -- want to state the monad laws (since (true , 1) is not a zero in
  -- the monoid which is used here). The return function defined below
  -- has a more suitable type, though.

  return : forall {tok r} -> r -> Parser tok r (true , 1)
  return x = returnPlus (Vec.[_] x) fail

  cast : forall {tok i₁ i₂ r} ->
         i₁ ≡ i₂ -> Parser tok r i₁ -> Parser tok r i₂
  cast refl p = p

  infixl 0 _∣_

  _∣_ : forall {tok r i₁ i₂} ->
        Parser tok r i₁ -> Parser tok r i₂ -> Parser tok r (i₁ ∣I i₂)
  fail              ∣ p₂                ~ p₂
  returnPlus xs p₁  ∣ fail              ~ returnPlus xs p₁
  symbolBind f₁     ∣ fail              ~ symbolBind f₁
  symbolBind f₁     ∣ symbolBind f₂     ~ symbolBind (\c -> f₁ c ∣ f₂ c)
  symbolBind f₁     ∣ returnPlus xs p₂  ~ returnPlus xs (symbolBind f₁ ∣ p₂)
  returnPlus xs p₁  ∣ symbolBind f₂     ~ returnPlus xs (symbolBind f₂ ∣ p₁)
  returnPlus xs₁ p₁ ∣ returnPlus xs₂ p₂ ~ returnPlus (xs₁ <+> xs₂) (p₁ ∣ p₂)

  -- parse is structurally recursive over the following lexicographic
  -- measure:
  --
  -- ⑴ The input string.
  -- ⑵ The Distance index.

  parse : forall {tok r e d} ->
          Parser tok r (e , d) -> P tok r
  parse (symbolBind f)    (c ∷ s) = parse (f c) s
  parse (symbolBind f)    []      = []
  parse fail              _       = []
  parse (returnPlus xs p) s       =
    List.map (\x -> pair x s) (Vec.toList xs) ++ parse p s

  -- It may be interesting to note that it is hard to define bind
  -- directly. Note that the module Incorrect is not used for
  -- anything; bind is defined further down using CPS.

  private
   module IncorrectBind where

    -- choice ≈ foldr₁ _∣_.

    choice : forall {tok r i n} ->
             Vec (Parser tok r i) (suc n) -> Parser tok r i
    choice {i = i} =
      Vec.foldr₁ (\p₁ p₂ -> cast (∣-idempotent i) (p₁ ∣ p₂))
      where open IndexSemiring

    -- This function is used to state the type of bind.

    bind-index : forall {tok r i} ->
                 Parser tok r i -> Index -> Index
    bind-index (symbolBind f)    _ = 0I
    bind-index fail              _ = 0I
    bind-index (returnPlus xs p) i = i

    open IndexSemiring

    bind-index-lemma : forall {tok r i₁} (p : Parser tok r i₁) i₂ ->
                       i₂ ∣I bind-index p i₂ ≡ i₂
    bind-index-lemma (symbolBind f)    i = proj₂ +-identity i
    bind-index-lemma fail              i = proj₂ +-identity i
    bind-index-lemma (returnPlus xs p) i = ∣-idempotent i

    -- Note that bind has a non-trivial type. This is not a
    -- fundamental problem, though. The big problem is that bind is
    -- not productive (in general). The recursive call p >>= g in the
    -- last line is not guarded if, for instance, g = const fail, in
    -- which case we have (ignoring some casts)
    --
    --   returnPlus xs p >>= g  =  p >>= g.
    --
    -- If furthermore p = returnPlus xs p, then we have a real
    -- problem.

    _>>=_ : forall {tok r₁ r₂ i₁ i₂} ->
            (p₁ : Parser tok r₁ i₁) -> (r₁ -> Parser tok r₂ i₂) ->
            Parser tok r₂ (bind-index p₁ i₂)
    symbolBind f    >>= g ~ symbolBind (\c -> f c >>= g)
    fail            >>= g ~ fail
    returnPlus xs p >>= g ~ cast (bind-index-lemma p _)
                                 (choice (Vec.map g xs) ∣ p >>= g)

------------------------------------------------------------------------
-- CPS transformation

-- The code below manually applies the continuation-passing monad
-- transformer to the Base parser above to improve the efficiency of
-- left-nested uses of bind. (And, in light of Base.Incorrect._>>=_,
-- to enable a well-founded definition of bind.)

data Parser (tok : Set) (i : Index) (r : Set) : Set1 where
  parser : (forall {i' r'} ->
            (r -> Base.Parser tok r' i') ->
            Base.Parser tok r' (i ·I i')) ->
           Parser tok i r

private

  unP : forall {tok r i r' i'} ->
        Parser tok i r ->
        (r -> Base.Parser tok r' i') ->
        Base.Parser tok r' (i ·I i')
  unP (parser p) = p

symbol : forall {tok} -> Parser tok 0I tok
symbol = parser Base.symbolBind

fail : forall {tok r} -> Parser tok 0I r
fail = parser \k -> Base.fail

-- A problematic variant of fail. See Parallel.Lib.

problematic : forall {tok r} -> r -> Parser tok 0I r
problematic x = parser (\k -> helper (k x))
  where
  helper : forall {tok r' i'} ->
           Base.Parser tok r' i' -> Base.Parser tok r' 0I
  helper (Base.symbolBind _)   = Base.fail
  helper Base.fail             = Base.fail
  helper (Base.returnPlus _ _) = Base.fail

return : forall {tok r} -> r -> Parser tok 1I r
return x = parser \k -> k x

-- Note that _>>=_ cannot easily be given a dependent type (where the
-- second argument has type (x : r₁) -> Parser tok r₂ (i₂ x)). What
-- would the type of the result of _>>=_ be? The type would depend on
-- the input string, which is not an argument to _>>=_.
--
-- Note also that the variant _!>>=_ from Parser/RecursiveDescent.Coinductive
-- cannot (?) be implemented, since the continuation given to p cannot
-- be dependently typed.

infixl 1 _>>=_

_>>=_ : forall {tok r₁ r₂ i₁ i₂} ->
        Parser tok i₁ r₁ -> (r₁ -> Parser tok i₂ r₂) ->
        Parser tok (i₁ ·I i₂) r₂
_>>=_ {i₁ = i₁} {i₂} (parser p) f = parser
  \{i₃} k -> Base.cast (sym $ *-assoc i₁ i₂ i₃)
                       (p \x -> unP (f x) k)
  where open IndexSemiring

infixl 0 _∣_

_∣_ : forall {tok r i₁ i₂} ->
      Parser tok i₁         r ->
      Parser tok i₂         r ->
      Parser tok (i₁ ∣I i₂) r
_∣_ {i₁ = i₁} {i₂ = i₂} (parser p₁) (parser p₂) =
  parser \{i₃} k ->
    Base.cast (sym $ proj₂ distrib i₃ i₁ i₂)
              (Base._∣_ (p₁ k) (p₂ k))
  where open IndexSemiring

-- Since _>>=_ has a non-dependent type it is hard to define sat
-- without using the underlying parsers in Base, and hence sat is
-- provided here.

sat : forall {tok r} ->
      (tok -> Maybe r) -> Parser tok 0I r
sat {tok} {r} p = parser \k -> Base.symbolBind (\c -> ok k (p c))
  where
  okIndex : Index -> Maybe r -> Index
  okIndex i' nothing  = 0I
  okIndex i' (just _) = i'

  ok : forall {r' i'} ->
       (r -> Base.Parser tok r' i') ->
       (x : Maybe r) -> Base.Parser tok r' (okIndex i' x)
  ok k nothing  = Base.fail
  ok k (just x) = k x

parse : forall {tok r i} ->
        Parser tok i r -> P tok r
parse (parser p) = Base.parse (p Base.return)

-- A variant which only returns parses which leave no remaining input.

parse-complete : forall {tok r i} ->
                 Parser tok i r -> List tok -> List r
parse-complete p s =
  List.map proj₁ (List.filter (List.null ∘ proj₂) (parse p s))


------------------------------------------------------------------------
-- INCREMENTAL λ-CALCULUS
--
-- Correctness of differentiation with the Nehemiah plugin.
------------------------------------------------------------------------

module Nehemiah.Change.Correctness where

-- The denotational properties of the `derive` transformation
-- for Calculus Nehemiah. In particular, the main theorem
-- about it producing the correct incremental behavior.

open import Nehemiah.Syntax.Type
open import Nehemiah.Syntax.Term
open import Nehemiah.Denotation.Value
open import Nehemiah.Denotation.Evaluation
open import Nehemiah.Change.Type
open import Nehemiah.Change.Term
open import Nehemiah.Change.Value
open import Nehemiah.Change.Evaluation
open import Nehemiah.Change.Validity
open import Nehemiah.Change.Derive
open import Nehemiah.Change.Implementation

open import Base.Denotation.Notation
open import Relation.Binary.PropositionalEquality
open import Data.Integer
open import Theorem.Groups-Nehemiah
open import Postulate.Extensionality

import Parametric.Change.Correctness
  Const ⟦_⟧Base ⟦_⟧Const ΔBase
  apply-base diff-base nil-base
  ⟦apply-base⟧ ⟦diff-base⟧ ⟦nil-base⟧
  meaning-⊕-base meaning-⊝-base meaning-onil-base
  derive-const implementation-structure as Correctness

open import Algebra.Structures

private
  flatmap-funarg-equal : ∀ (f : ℤ → Bag) (Δf : Δ₍ int ⇒ bag ₎ f) Δf′ (Δf≈Δf′ : Δf ≈₍ int ⇒ bag ₎ Δf′) →
    (f ⊞₍ int ⇒ bag ₎ Δf) ≡ (f ⟦⊕₍ int ⇒ bag ₎⟧ Δf′)
  flatmap-funarg-equal f Δf Δf′ Δf≈Δf′ = ext lemma
    where
    lemma : ∀ v → f v ++ FunctionChange.apply Δf v (+ 0) ≡ f v ++ Δf′ v (+ 0)
    lemma v rewrite Δf≈Δf′ v (+ 0) (+ 0) refl = refl

derive-const-correct : Correctness.Structure
derive-const-correct (intlit-const n) = refl
derive-const-correct add-const w Δw .Δw refl w₁ Δw₁ .Δw₁ refl
  rewrite mn·pq=mp·nq {w} {Δw} {w₁} {Δw₁}
  | associative-int (w + w₁) (Δw + Δw₁) (- (w + w₁))
  = n+[m-n]=m {w + w₁} {Δw + Δw₁}
derive-const-correct minus-const w Δw .Δw refl
  rewrite sym (-m·-n=-mn {w} {Δw})
  | associative-int (- w) (- Δw) (- (- w)) = n+[m-n]=m { - w} { - Δw}
derive-const-correct empty-const = refl
derive-const-correct insert-const w Δw .Δw refl w₁ Δw₁ .Δw₁ refl = refl
derive-const-correct union-const w Δw .Δw refl w₁ Δw₁ .Δw₁ refl
  rewrite ab·cd=ac·bd {w} {Δw} {w₁} {Δw₁}
  | associative-bag (w ++ w₁) (Δw ++ Δw₁) (negateBag (w ++ w₁))
  = a++[b\\a]=b {w ++ w₁} {Δw ++ Δw₁}
derive-const-correct negate-const w Δw .Δw refl
  rewrite sym (-a·-b=-ab {w} {Δw})
  | associative-bag (negateBag w) (negateBag Δw) (negateBag (negateBag w))
  = a++[b\\a]=b {negateBag w} {negateBag Δw}
derive-const-correct flatmap-const w Δw Δw′ Δw≈Δw′ w₁ Δw₁ .Δw₁ refl
  rewrite flatmap-funarg-equal w Δw Δw′ Δw≈Δw′ = refl
derive-const-correct sum-const w Δw .Δw refl
  rewrite homo-sum {w} {Δw}
  | associative-int (sumBag w) (sumBag Δw) (- sumBag w)
  = n+[m-n]=m {sumBag w} {sumBag Δw}

open Correctness.Structure derive-const-correct public


module _ where

-- Should not be able to give by name
id : {_ = A : Set} → A → A
id x = x

works : (X : Set) → X → X
works X = id {X}

fails : (X : Set) → X → X
fails X = id {A = X}


------------------------------------------------------------------------------
-- Distributive laws on a binary operation: Task B
------------------------------------------------------------------------------

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

module DistributiveLaws.TaskB-HalvedStepsATP where

open import DistributiveLaws.Base

open import Common.FOL.Relation.Binary.EqReasoning

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

-- We prove the half of the proof steps (skipping the even ones) of
-- DistributiveLaws.TaskB-I using the ATPs.

prop₂ : ∀ u x y z →
        (x · y · (z · u)) · ((x · y · (z · u)) · (x · z · (y · u))) ≡
          x · z · (y · u)
prop₂ u x y z =

-- The numbering of the proof step justifications are associated with
-- the numbers used in DistributiveLaws.TaskB-I.

  xy·zu · (xy·zu · xz·yu)                                       ≡⟨ j₁₋₃ ⟩
  xy·zu · (x·zu · xz·yu · (y·zu · xz·yu))                       ≡⟨ j₃₋₅ ⟩
  xy·zu · (xz · xu·yu · (y·zu · xz·yu))                         ≡⟨ j₅₋₇ ⟩
  xy·zu · (xz · xyu · (yz·yu · xz·yu))                          ≡⟨ j₇₋₉ ⟩
  xy·zu · (xz · xyu · (yxz · yu))                               ≡⟨ j₉₋₁₁ ⟩
  xy·zu · (xz · xyu · (y·xu · z·yu))                            ≡⟨ j₁₁₋₁₃ ⟩
  xz·yz · xyu · (xz · xyu · (y·xu · z·yu))                      ≡⟨ j₁₃₋₁₅ ⟩
  xz · xyu · (yz · xyu · (y·xu · z·yu))                         ≡⟨ j₁₅₋₁₇ ⟩
  xz · xyu · (y · xu·yu · (z · xu·yu) · (y·xu · z·yu))          ≡⟨ j₁₇₋₁₉ ⟩
  xz · xyu ·
  (y·xu · y·yu · (y·xu · z·yu) · (z · xu·yu · (y·xu · z·yu)))   ≡⟨ j₁₉₋₂₁ ⟩
  xz · xyu · (y·xu · yz·yu · (z · xu·yu · (y·xu · z·yu)))       ≡⟨ j₂₁₋₂₃ ⟩
  xz · xyu · (y · xu·zu · (z · xu·yu · (y·xu · z·yu)))          ≡⟨ j₂₃₋₂₅ ⟩
  (xz · xyu) · (y · xu·zu · (z·xu · y·xu · z·yu))               ≡⟨ j₂₅₋₂₇ ⟩
  xz · xyu · (y · xu·zu · (zy·xu · zy·zu))                      ≡⟨ j₂₇₋₂₉ ⟩
  xz · xyu · (y·zy · xu·zu)                                     ≡⟨ j₂₉₋₃₁ ⟩
  xz·xy · xzu · (y·zy · xzu)                                    ≡⟨ j₃₁₋₃₃ ⟩
  x·zy · y·zy · xzu                                             ≡⟨ j₃₃₋₃₅ ⟩
  xzy · xzu                                                     ≡⟨ j₃₅ ⟩
  xz·yu                                                         ∎
  where
  -- Two variables abbreviations

  xz = x · z
  yu = y · u
  yz = y · z
  zy = z · y
  {-# ATP definitions xz yu yz zy #-}

  -- Three variables abbreviations

  xyu = x · y · u
  xzu = x · z · u
  xzy = x · z · y
  yxz = y · x · z
  {-# ATP definitions xyu xzu xzy yxz #-}

  x·zu = x · (z · u)
  x·zy = x · (z · y)
  {-# ATP definitions x·zu x·zy #-}

  y·xu = y · (x · u)
  y·yu = y · (y · u)
  y·zu = y · (z · u)
  y·zy = y · (z · y)
  {-# ATP definitions y·xu y·yu y·zu y·zy #-}

  z·xu = z · (x · u)
  z·yu = z · (y · u)
  {-# ATP definitions z·xu z·yu #-}

  -- Four variables abbreviations

  xu·yu = x · u · (y · u)
  xu·zu = x · u · (z · u)
  {-# ATP definitions xu·yu xu·zu #-}

  xy·zu = x · y · (z · u)
  {-# ATP definition xy·zu #-}

  xz·xy = x · z · (x · y)
  xz·yu = x · z · (y · u)
  xz·yz = x · z · (y · z)
  {-# ATP definitions xz·xy xz·yu xz·yz #-}

  yz·yu = y · z · (y · u)
  {-# ATP definition yz·yu #-}

  zy·xu = z · y · (x · u)
  zy·zu = z · y · (z · u)
  {-# ATP definitions zy·xu zy·zu #-}

  -- Steps justifications

  postulate j₁₋₃ : xy·zu · (xy·zu · xz·yu) ≡
                   xy·zu · (x·zu · xz·yu · (y·zu · xz·yu))
  {-# ATP prove j₁₋₃ #-}

  postulate j₃₋₅ : xy·zu · (x·zu · xz·yu · (y·zu · xz·yu)) ≡
                   xy·zu · (xz · xu·yu · (y·zu · xz·yu))
  {-# ATP prove j₃₋₅ #-}

  postulate j₅₋₇ : xy·zu · (xz · xu·yu · (y·zu · xz·yu)) ≡
                   xy·zu · (xz · xyu · (yz·yu · xz·yu))
  {-# ATP prove j₅₋₇ #-}

  postulate j₇₋₉ : xy·zu · (xz · xyu · (yz·yu · xz·yu)) ≡
                   xy·zu · (xz · xyu · (yxz · yu))
  {-# ATP prove j₇₋₉ #-}

  postulate j₉₋₁₁ : xy·zu · (xz · xyu · (yxz · yu)) ≡
                    xy·zu · (xz · xyu · (y·xu · z·yu))
  {-# ATP prove j₉₋₁₁ #-}

  postulate j₁₁₋₁₃ : xy·zu · (xz · xyu · (y·xu · z·yu)) ≡
                     xz·yz · xyu · (xz · xyu · (y·xu · z·yu))
  {-# ATP prove j₁₁₋₁₃ #-}

  postulate j₁₃₋₁₅ : xz·yz · xyu · (xz · xyu · (y·xu · z·yu)) ≡
                     xz · xyu · (yz · xyu · (y·xu · z·yu))
  {-# ATP prove j₁₃₋₁₅ #-}

  postulate j₁₅₋₁₇ : xz · xyu · (yz · xyu · (y·xu · z·yu)) ≡
                     xz · xyu · (y · xu·yu · (z · xu·yu) · (y·xu · z·yu))
  {-# ATP prove j₁₅₋₁₇ #-}

  postulate j₁₇₋₁₉ : xz · xyu · (y · xu·yu · (z · xu·yu) · (y·xu · z·yu)) ≡
                     xz · xyu ·
                    (y·xu · y·yu · (y·xu · z·yu) · (z · xu·yu · (y·xu · z·yu)))
  {-# ATP prove j₁₇₋₁₉ #-}

  postulate
    j₁₉₋₂₁ : xz · xyu ·
             (y·xu · y·yu · (y·xu · z·yu) · (z · xu·yu · (y·xu · z·yu))) ≡
             xz · xyu · (y·xu · yz·yu · (z · xu·yu · (y·xu · z·yu)))
  {-# ATP prove j₁₉₋₂₁ #-}

  postulate
    j₂₁₋₂₃ : xz · xyu · (y·xu · yz·yu · (z · xu·yu · (y·xu · z·yu))) ≡
             xz · xyu · (y · xu·zu · (z · xu·yu · (y·xu · z·yu)))
  {-# ATP prove j₂₁₋₂₃ #-}

  postulate j₂₃₋₂₅ : xz · xyu · (y · xu·zu · (z · xu·yu · (y·xu · z·yu))) ≡
                     (xz · xyu) · (y · xu·zu · (z·xu · y·xu · z·yu))
  {-# ATP prove j₂₃₋₂₅ #-}

  postulate j₂₅₋₂₇ : (xz · xyu) · (y · xu·zu · (z·xu · y·xu · z·yu)) ≡
                     xz · xyu · (y · xu·zu · (zy·xu · zy·zu))
  {-# ATP prove j₂₅₋₂₇ #-}

  postulate j₂₇₋₂₉ : xz · xyu · (y · xu·zu · (zy·xu · zy·zu)) ≡
                     xz · xyu · (y·zy · xu·zu)
  {-# ATP prove j₂₇₋₂₉ #-}

  postulate j₂₉₋₃₁ : xz · xyu · (y·zy · xu·zu) ≡
                     xz·xy · xzu · (y·zy · xzu)
  {-# ATP prove j₂₉₋₃₁ #-}

  postulate j₃₁₋₃₃ : xz·xy · xzu · (y·zy · xzu) ≡
                     x·zy · y·zy · xzu
  {-# ATP prove j₃₁₋₃₃ #-}

  postulate j₃₃₋₃₅ : x·zy · y·zy · xzu ≡ xzy · xzu
  {-# ATP prove j₃₃₋₃₅ #-}

  postulate j₃₅ : xzy · xzu ≡ xz·yu
  {-# ATP prove j₃₅ #-}


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

open import Cubical.Foundations.Function
open import Cubical.Foundations.Prelude

open import Cubical.Core.Glue public
  using ( isEquiv ; equiv-proof ; _≃_ ; equivFun ; equivProof )

fiber : ∀ {ℓ ℓ'} {A : Type ℓ} {B : Type ℓ'} (f : A → B) (y : B) → Type (ℓ-max ℓ ℓ')
fiber {A = A} f y = Σ[ x ∈ A ] f x ≡ y

-- Helper function for constructing equivalences from pairs (f,g) that cancel each other up to definitional
-- equality. For such (f,g), the result type simplifies to isContr (fiber f b).
strictContrFibers : ∀ {ℓ ℓ'} {A : Type ℓ} {B : Type ℓ'} {f : A → B} (g : B → A) (b : B)
  → Σ[ t ∈ fiber f (f (g b)) ]
    ((t' : fiber f b) → Path (fiber f (f (g b))) t (g (f (t' .fst)) , cong (f ∘ g) (t' .snd)))
strictContrFibers {f = f} g b .fst = (g b , refl)
strictContrFibers {f = f} g b .snd (a , p) i = (g (p (~ i)) , λ j → f (g (p (~ i ∨ j))))

-- The identity equivalence
idIsEquiv : ∀ {ℓ} (A : Type ℓ) → isEquiv (idfun A)
idIsEquiv A .equiv-proof = strictContrFibers (idfun A)

idEquiv : ∀ {ℓ} (A : Type ℓ) → A ≃ A
idEquiv A .fst = idfun A
idEquiv A .snd = idIsEquiv A


module _ where

open import Haskell.Prelude
open import Agda.Builtin.Equality

-- ** Foreign HS code

-- language extensions
{-# FOREIGN AGDA2HS
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE FlexibleInstances #-}
#-}

-- imports
{-# FOREIGN AGDA2HS
import Data.Monoid
#-}

-- ** Datatypes & functions

data Exp (v : Set) : Set where
  Plus : Exp v → Exp v → Exp v
  Lit : Nat → Exp v
  Var : v → Exp v
{-# COMPILE AGDA2HS Exp deriving (Show,Eq) #-}

eval : (a → Nat) → Exp a → Nat
eval env (Plus a b) = eval env a + eval env b
eval env (Lit n) = n
eval env (Var x) = env x
{-# COMPILE AGDA2HS eval #-}

-- ** Natural numbers

listSum : List Int → Int
listSum []       = 0
listSum (x ∷ xs) = x + sum xs
{-# COMPILE AGDA2HS listSum #-}

monoSum : List Integer → Integer
monoSum xs = sum xs
{-# COMPILE AGDA2HS monoSum #-}

polySum : ⦃ iNum : Num a ⦄ → List a → a
polySum xs = sum xs
{-# COMPILE AGDA2HS polySum #-}

{-# FOREIGN AGDA2HS
-- comment
-- another comment
bla :: Int -> Int
bla n = n * 4

{- multi
   line
   comment
-}
#-}

-- ** Extra builtins

ex_float : Double
ex_float = 0.0
{-# COMPILE AGDA2HS ex_float #-}

postulate
  toInteger : Word → Integer

ex_word : Word
ex_word = fromInteger 0
{-# COMPILE AGDA2HS ex_word #-}

ex_char : Char
ex_char = 'a'
{-# COMPILE AGDA2HS ex_char #-}

char_d : Char
char_d = toEnum 100
{-# COMPILE AGDA2HS char_d #-}

-- ** Polymorphic functions

_+++_ : List a → List a → List a
[]       +++ ys = ys
(x ∷ xs) +++ ys = x ∷ (xs +++ ys)
{-# COMPILE AGDA2HS _+++_ #-}

listMap : (a → b) → List a → List b
listMap f [] = []
listMap f (x ∷ xs) = f x ∷ listMap f xs
{-# COMPILE AGDA2HS listMap #-}

mapTest : List Nat → List Nat
mapTest = map (id ∘ _+_ 5)
{-# COMPILE AGDA2HS mapTest #-}

-- ** Lambdas

plus3 : List Nat → List Nat
plus3 = map (λ n → n + 3)
{-# COMPILE AGDA2HS plus3 #-}

doubleLambda : Nat → Nat → Nat
doubleLambda = λ a b → a + 2 * b
{-# COMPILE AGDA2HS doubleLambda #-}

cnst : a → b → a
cnst = λ x _ → x
{-# COMPILE AGDA2HS cnst #-}

-- ** Constraints

second : (b → c) → a × b → a × c
second f (x , y) = x , f y
{-# COMPILE AGDA2HS second #-}

doubleTake : (n m : Int) → ⦃ IsNonNegativeInt n ⦄ → ⦃ IsNonNegativeInt m ⦄ → List a → List a × List a
doubleTake n m = second (take m) ∘ splitAt n
{-# COMPILE AGDA2HS doubleTake #-}

initLast : (xs : List a) → ⦃ NonEmpty xs ⦄ → List a × a
initLast xs = init xs , last xs
{-# COMPILE AGDA2HS initLast #-}

-- ** Proofs

assoc : (a b c : Nat) → a + (b + c) ≡ (a + b) + c
assoc zero    b c = refl
assoc (suc a) b c rewrite assoc a b c = refl

thm : (xs ys : List Nat) → sum (xs ++ ys) ≡ sum xs + sum ys
thm []       ys = refl
thm (x ∷ xs) ys rewrite thm xs ys | assoc x (sum xs) (sum ys) = refl

-- (custom) Monoid class

record MonoidX (a : Set) : Set where
  field memptyX  : a
        mappendX : a → a → a

open MonoidX {{...}} public

{-# COMPILE AGDA2HS MonoidX #-}

instance
  MonoidNat : MonoidX Nat
  memptyX  {{MonoidNat}}     = 0
  mappendX {{MonoidNat}} i j = i + j

{-# COMPILE AGDA2HS MonoidNat #-}

instance
  MonoidFunNat : {a : Set} → MonoidX (a → Nat)
  memptyX  {{MonoidFunNat}}     _ = memptyX
  mappendX {{MonoidFunNat}} f g x = mappendX (f x) (g x)

{-# COMPILE AGDA2HS MonoidFunNat #-}

instance
  MonoidFun : {a b : Set} → {{MonoidX b}} → MonoidX (a → b)
  memptyX  {{MonoidFun}}     _ = memptyX
  mappendX {{MonoidFun}} f g x = mappendX (f x) (g x)
{-# COMPILE AGDA2HS MonoidFun #-}

sumMonX : ∀{a} → {{MonoidX a}} → List a → a
sumMonX []       = memptyX
sumMonX (x ∷ xs) = mappendX x (sumMonX xs)
{-# COMPILE AGDA2HS sumMonX #-}

sumMon : ∀{a} → {{Monoid a}} → List a → a
sumMon []       = mempty
sumMon (x ∷ xs) = x <> sumMon xs
{-# COMPILE AGDA2HS sumMon #-}

-- Using the Monoid class from the Prelude

data NatSum : Set where
  MkSum : Nat → NatSum

{-# COMPILE AGDA2HS NatSum #-}

instance
  SemigroupNatSum : Semigroup NatSum
  SemigroupNatSum ._<>_ (MkSum a) (MkSum b) = MkSum (a + b)

  MonoidNatSum : Monoid NatSum
  MonoidNatSum .mempty = MkSum 0

double : ⦃ Monoid a ⦄ → a → a
double x = x <> x

doubleSum : NatSum → NatSum
doubleSum = double

{-# COMPILE AGDA2HS SemigroupNatSum #-}
{-# COMPILE AGDA2HS MonoidNatSum    #-}
{-# COMPILE AGDA2HS double          #-}
{-# COMPILE AGDA2HS doubleSum       #-}

-- Instance argument proof obligation that should not turn into a class constraint
hd : (xs : List a) → ⦃ NonEmpty xs ⦄ → a
hd []      = error "hd: empty list"
hd (x ∷ _) = x
{-# COMPILE AGDA2HS hd #-}

five : Int
five = hd (5 ∷ 3 ∷ [])
{-# COMPILE AGDA2HS five #-}

-- ** Booleans

ex_bool : Bool
ex_bool = true
{-# COMPILE AGDA2HS ex_bool #-}

ex_if : Nat
ex_if = if true then 1 else 0
{-# COMPILE AGDA2HS ex_if #-}

if_over : Nat
if_over = (if true then (λ x → x) else (λ x → x + 1)) 0
{-# COMPILE AGDA2HS if_over #-}

if_partial₁ : List Nat → List Nat
if_partial₁ = map (if true then 1 else_)
{-# COMPILE AGDA2HS if_partial₁ #-}

if_partial₂ : List Nat → List (Nat → Nat)
if_partial₂ = map (if true then_else_)
{-# COMPILE AGDA2HS if_partial₂ #-}

if_partial₃ : List Bool → List (Nat → Nat → Nat)
if_partial₃ = map if_then_else_
{-# COMPILE AGDA2HS if_partial₃ #-}

if_partial₄ : List Bool → List (Nat → Nat)
if_partial₄ = map (if_then 1 else_)
{-# COMPILE AGDA2HS if_partial₄ #-}

if_partial₅ : Bool → Nat → List Nat → List Nat
if_partial₅ b f = map (if b then f else_)
{-# COMPILE AGDA2HS if_partial₅ #-}


module root2 where

open import Data.Nat
open import Data.Nat.Properties
open import Data.Empty
open import Data.Unit using (⊤ ; tt)
open import Relation.Nullary
open import Relation.Binary.PropositionalEquality
open import Relation.Binary.Definitions

import gcd as GCD
open import even
open import nat
open import logic

record Rational : Set where
  field
    i j : ℕ
    coprime : GCD.gcd i j ≡ 1

-- record Dividable (n m : ℕ ) : Set where
--    field
--       factor : ℕ
--       is-factor : factor * n + 0 ≡ m

gcd : (i j : ℕ) → ℕ
gcd = GCD.gcd

gcd-euclid : ( p a b : ℕ )  → 1 < p  → 0 < a → 0 < b → ((i : ℕ ) → i < p → 0 < i   → gcd p i ≡ 1)
   →  Dividable p (a * b)  → Dividable p a ∨ Dividable p b
gcd-euclid = GCD.gcd-euclid

gcd-div1 : ( i j k : ℕ ) → k > 1 → (if : Dividable k i) (jf : Dividable k j )
   → Dividable k ( gcd i  j )
gcd-div1 = GCD.gcd-div

open _∧_

open import prime

divdable^2 : ( n k : ℕ ) → 1 < k → 1 < n → Prime k → Dividable k ( n * n ) → Dividable k n
divdable^2 zero zero () 1<n pk dn2
divdable^2 (suc n) (suc k) 1<k 1<n pk dn2 with decD {suc k} {suc n} 1<k
... | yes y = y
... | no non with gcd-euclid (suc k) (suc n) (suc n) 1<k (<-trans a<sa 1<n) (<-trans a<sa 1<n) (Prime.isPrime pk) dn2
... | case1 dn = dn
... | case2 dm = dm

-- p * n * n ≡ m * m means (m/n)^2 = p
-- rational m/n requires m and n is comprime each other which contradicts the condition

root-prime-irrational : ( n m p : ℕ ) → n > 1 → Prime p → m > 1  →  p * n * n ≡ m * m  → ¬ (gcd n m ≡ 1)
root-prime-irrational n m 0 n>1 pn m>1 pnm = ⊥-elim ( nat-≡< refl (<-trans a<sa (Prime.p>1 pn)))
root-prime-irrational n m (suc p0) n>1 pn m>1 pnm = rot13 ( gcd-div1 n m (suc p0) 1<sp dn dm ) where
    p = suc p0
    1<sp : 1 < p
    1<sp = Prime.p>1 pn
    rot13 : {m : ℕ } → Dividable (suc p0) m →  m ≡ 1 → ⊥
    rot13 d refl with Dividable.factor d | Dividable.is-factor d
    ... | zero | ()   -- gcd 0 m ≡ 1
    ... | suc n | x = ⊥-elim ( nat-≡< (sym x) rot17 ) where -- x : (suc n * p + 0) ≡ 1
        rot17 : suc n * (suc p0) + 0 > 1
        rot17 = begin
           2 ≡⟨ refl ⟩
           suc (1 * 1 ) ≤⟨ 1<sp  ⟩
           suc p0  ≡⟨ cong suc (+-comm 0 _) ⟩
           suc (p0 + 0) ≤⟨ s≤s (+-monoʳ-≤ p0 z≤n) ⟩
           suc (p0 + n * p )  ≡⟨ +-comm 0 _ ⟩
           suc n * p + 0 ∎   where open ≤-Reasoning
    dm : Dividable p m
    dm = divdable^2 m p 1<sp m>1 pn record { factor = n * n ; is-factor = begin
       (n * n) * p + 0 ≡⟨  +-comm _ 0 ⟩
       (n * n) * p  ≡⟨ *-comm (n * n) p ⟩
       p * (n * n)  ≡⟨ sym (*-assoc p n n)  ⟩
       (p * n) * n ≡⟨ pnm ⟩
       m * m ∎ }  where open ≡-Reasoning
     -- p * n * n = 2m' 2m'
     --  n * n = m' 2m'
    df = Dividable.factor dm
    dn : Dividable p n
    dn = divdable^2 n p 1<sp n>1 pn record { factor = df * df  ; is-factor = begin
        df * df * p + 0  ≡⟨ *-cancelʳ-≡ _ _ {p0} ( begin
          (df * df * p + 0) * p ≡⟨  cong (λ k → k * p)  (+-comm (df * df * p) 0)  ⟩
          ((df * df) * p  ) * p ≡⟨ cong (λ k → k * p) (*-assoc df df p ) ⟩
            (df * (df * p)) * p ≡⟨ cong (λ k → (df * k ) * p) (*-comm df p)  ⟩
            (df * (p * df)) * p ≡⟨ sym ( cong (λ k → k * p) (*-assoc df p df ) ) ⟩
            ((df * p) * df) * p ≡⟨ *-assoc (df * p) df p  ⟩
            (df * p) * (df * p) ≡⟨ cong₂ (λ j k → j * k ) (+-comm 0 (df * p)) (+-comm 0 _) ⟩
          (df * p + 0) * (df * p + 0)   ≡⟨ cong₂ (λ j k → j * k) (Dividable.is-factor dm ) (Dividable.is-factor dm )⟩
          m * m   ≡⟨ sym pnm ⟩
          p * n * n     ≡⟨ cong (λ k → k * n) (*-comm p n) ⟩
          n * p * n     ≡⟨ *-assoc n p n ⟩
          n * (p * n)   ≡⟨ cong (λ k → n * k) (*-comm p n) ⟩
          n * (n * p)   ≡⟨ sym (*-assoc n n p) ⟩
          n * n * p ∎  ) ⟩
       n * n ∎ }  where open ≡-Reasoning

Rational* : (r s : Rational) → Rational
Rational* r s = record  { i = {!!} ; j = {!!} ; coprime = {!!} }

_r=_ : Rational → ℕ → Set
r r= n  = (Rational.i r ≡ n) ∧ (Rational.j r ≡ 1)

root-prime-irrational1 : ( p : ℕ ) → Prime p → ¬ ( ( r  : Rational ) → Rational* r r r= p )
root-prime-irrational1 = {!!}


{-# OPTIONS --cubical #-}
module _ where

open import Agda.Builtin.Nat
open import Agda.Builtin.Cubical.Path

postulate
  admit : ∀ {A : Set} → A

data Z : Set where
  pos      : Nat → Z
  neg      : Nat → Z
  sameZero : pos 0 ≡ neg 0

_+Z_ : Z → Z → Z
pos x +Z pos x₁ = admit
pos x +Z neg x₁ = admit
pos x +Z sameZero x₁ = admit
neg x +Z z' = admit
sameZero x +Z z' = admit


module Array.APL where

open import Array.Base
open import Array.Properties
open import Data.Nat
open import Data.Nat.DivMod hiding (_/_)
open import Data.Nat.Properties
open import Data.Fin using (Fin; zero; suc; raise; toℕ; fromℕ≤)
open import Data.Fin.Properties using (toℕ<n)
open import Data.Vec
open import Data.Vec.Properties
open import Data.Product
open import Agda.Builtin.Float
open import Function
open import Relation.Binary.PropositionalEquality hiding (Extensionality)
open import Relation.Nullary
open import Relation.Nullary.Decidable
open import Relation.Nullary.Negation
--open import Relation.Binary

-- Now we start to introduce APL operators trying
-- to maintain syntactic rules and semantics.
-- We won't be able to mimic explicit concatenations
-- like 2 3 4 is a vector [2, 3, 4], as we would have
-- to overload the " " somehow.

-- This relation describes promotion of the scalar element in
-- dyadic operations.
data dy-args : ∀ n m k → (Vec ℕ n) → (Vec ℕ m) → (Vec ℕ k) → Set where
 instance
    n-n : ∀ {n}{s}    → dy-args n n n s s s
    n-0 : ∀ {n}{s}{s₁} → dy-args n 0 n s s₁ s
    0-n : ∀ {n}{s}{s₁} → dy-args 0 n n s s₁ s₁

dyadic-type : ∀ a → Set a → Set a
dyadic-type a X = ∀ {n m k}{s s₁ s₂}{{c : dy-args n m k s s₁ s₂}}
                  → Ar X n s → Ar X m s₁ → Ar X k s₂

lift-binary-op : ∀ {a}{X : Set a} → ∀ (op : X → X → X) → dyadic-type a X
lift-binary-op op ⦃ c = n-n ⦄ (imap f) (imap g) = imap λ iv → op (f iv) (g iv)
lift-binary-op op {s₁ = []} ⦃ c = n-0 ⦄ (imap f) (imap g) = imap λ iv → op (f iv) (g [])
lift-binary-op op {s = [] } ⦃ c = 0-n ⦄ (imap f) (imap g) = imap λ iv → op (f []) (g iv)

lift-unary-op : ∀ {a}{X : Set a} → ∀ (op : X → X)
              → ∀ {n s} → Ar X n s → Ar X n s
lift-unary-op f (imap g) = imap (λ iv → f (g iv))

dyadic-type-c : ∀ a → Set a → Set a
dyadic-type-c a X = ∀ {n m k}{s s₁ s₂}
                    → Ar X n s → dy-args n m k s s₁ s₂ → Ar X m s₁ → Ar X k s₂

-- Nat operations
infixr 20 _+ₙ_
infixr 20 _×ₙ_
_+ₙ_ = lift-binary-op _+_
_×ₙ_ = lift-binary-op _*_

_-safe-_ : (a : ℕ) → (b : ℕ) .{≥ : a ≥ b} → ℕ
a -safe- b = a ∸ b

-- FIXME As _-ₙ_ requires a proof, we won't consider yet
-- full dyadic types for _-ₙ_, as it would require us
-- to define dyadic types for ≥a.
infixr 20 _-ₙ_
_-ₙ_ : ∀ {n}{s}
     → (a : Ar ℕ n s) → (b : Ar ℕ n s)
     → .{≥ : a ≥a b}
     → Ar ℕ n s
(imap f -ₙ imap g) {≥} = imap λ iv → (f iv -safe- g iv) {≥ = ≥ iv}

--≢-sym : ∀ {X : Set}{a b : X} → a ≢ b → b ≢ a
--≢-sym pf = pf ∘ sym

infixr 20 _÷ₙ_
_÷ₙ_ : ∀ {n}{s}
     → (a : Ar ℕ n s) → (b : Ar ℕ n s)
     → {≥0 : cst 0 <a b}
     → Ar ℕ n s
_÷ₙ_ (imap f) (imap g) {≥0} = imap λ iv → (f iv div g iv) {≢0 = fromWitnessFalse (≢-sym $ <⇒≢ $ ≥0 iv) }

infixr 20 _+⟨_⟩ₙ_
infixr 20 _×⟨_⟩ₙ_
_+⟨_⟩ₙ_ : dyadic-type-c _ _
a +⟨ c ⟩ₙ b = _+ₙ_ {{c = c}} a b

_×⟨_⟩ₙ_ : dyadic-type-c _ _
a ×⟨ c ⟩ₙ b = _×ₙ_ {{c = c}} a b

-- Float operations
infixr 20 _+ᵣ_
_+ᵣ_ = lift-binary-op primFloatPlus
infixr 20 _-ᵣ_
_-ᵣ_ = lift-binary-op primFloatMinus
infixr 20 _×ᵣ_
_×ᵣ_ = lift-binary-op primFloatTimes

-- XXX we can request the proof that the right argument is not zero.
-- However, the current primFloatDiv has the type Float → Float → Float, so...
infixr 20 _÷ᵣ_
_÷ᵣ_ = lift-binary-op primFloatDiv

infixr 20 _×⟨_⟩ᵣ_
_×⟨_⟩ᵣ_ : dyadic-type-c _ _
a ×⟨ c ⟩ᵣ b = _×ᵣ_ {{c = c}} a b

infixr 20 _+⟨_⟩ᵣ_
_+⟨_⟩ᵣ_ : dyadic-type-c _ _
a +⟨ c ⟩ᵣ b = _+ᵣ_ {{c = c}} a b

infixr 20 _-⟨_⟩ᵣ_
_-⟨_⟩ᵣ_ : dyadic-type-c _ _
a -⟨ c ⟩ᵣ b = _-ᵣ_ {{c = c}} a b
infixr 20 _÷⟨_⟩ᵣ_
_÷⟨_⟩ᵣ_ : dyadic-type-c _ _
a ÷⟨ c ⟩ᵣ b = _÷ᵣ_ {{c = c}} a b

infixr 20 *ᵣ_
*ᵣ_ = lift-unary-op primFloatExp

module xx where
  a : Ar ℕ 2 (3 ∷ 3 ∷ [])
  a = cst 1

  s : Ar ℕ 0 []
  s = cst 2

  test₁ = a +ₙ a
  test₂ = a +ₙ s
  test₃ = s +ₙ a
  --test = (s +ₙ s)
  test₄ = s +⟨ n-n ⟩ₙ s

  test₅ : ∀ {n s} → Ar ℕ n s → Ar ℕ 0 [] → Ar ℕ n s
  test₅ = _+ₙ_

infixr 20 ρ_
ρ_ : ∀ {ℓ}{X : Set ℓ}{d s} → Ar X d s → Ar ℕ 1 (d ∷ [])
ρ_ {s = s} _  = s→a s

infixr 20 ,_
,_ : ∀ {a}{X : Set a}{n s} → Ar X n s → Ar X 1 (prod s ∷ [])
,_ {s = s} (p) = imap λ iv → unimap p (off→idx s iv)

-- Reshape
infixr 20 _ρ_
_ρ_ : ∀ {a}{X : Set a}{n}{sa}
    → (s : Ar ℕ 1 (n ∷ []))
    → (a  : Ar X n sa)
    -- if the `sh` is non-empty, `s` must be non-empty as well.
    → {s≢0⇒ρa≢0 : prod (a→s s) ≢ 0 → prod sa ≢ 0}
    → Ar X n (a→s s)
_ρ_ {sa = sa} s a {s≢0⇒ρa≢0} with  prod sa ≟ 0 | prod (a→s s) ≟ 0
_ρ_ {sa = sa} s a {s≢0⇒ρa≢0}     | _           | yes s≡0  = mkempty (a→s s) s≡0
_ρ_ {sa = sa} s a {s≢0⇒ρa≢0}     | yes ρa≡0    | no  s≢0  = contradiction ρa≡0 (s≢0⇒ρa≢0 s≢0)
_ρ_ {sa = sa} s a {s≢0⇒ρa≢0}     | no  ρa≢0    | _        = imap from-flat
  where
    from-flat : _
    from-flat iv = let
                     off  = idx→off (a→s s) iv --{!!} -- (ix-lookup iv zero)
                     flat = unimap $ , a
                     ix   = (toℕ (ix-lookup off zero) mod prod sa)
                            {≢0 = fromWitnessFalse ρa≢0}
                   in
                     flat (ix ∷ [])

reduce-1d : ∀ {a}{X : Set a}{n} → Ar X 1 (n ∷ []) → (X → X → X) → X → X
reduce-1d {n = zero}  (imap p) op neut = neut
reduce-1d {n = suc n} (imap p) op neut = op (p $ zero ∷ [])
                                            (reduce-1d (imap (λ iv → p (suc (ix-lookup iv zero) ∷ []))) op neut)

{-
  This goes right to left if we want to
  reduce-1d (imap λ iv → p ((raise 1 $ ix-lookup iv zero) ∷ []))
            op (op neut (p $ zero ∷ []))
-}

Scal : ∀ {a} → Set a → Set a
Scal X = Ar X 0 []

scal : ∀ {a}{X : Set a} → X → Scal X
scal = cst

unscal : ∀ {a}{X : Set a} → Scal X → X
unscal (imap f) = f []

module true-reduction where

  thm : ∀ {a}{X : Set a}{n m} → (s : Vec X (n + m)) → s ≡ take n s ++ drop n s
  thm {n = n} s  with splitAt n s
  thm {n = n} .(xs ++ ys) | xs , ys , refl = refl

  thm2 : ∀ {a}{X : Set a} → (v : Vec X 1) → v ≡ head v ∷ []
  thm2 (x ∷ []) = refl

  -- This is a variant with take
  _/⟨_⟩_ : ∀ {a}{X : Set a}{n}{s : Vec ℕ (n + 1)}
        → (X → X → X) → X
        → Ar X (n + 1) s
        → Ar X n (take n s)
  _/⟨_⟩_ {n = n} {s} f neut a = let
                x = nest {s = take n s} {s₁ = drop n s} $ subst (λ x → Ar _ _ x) (thm {n = n} s) a
                in imap λ iv → reduce-1d (subst (λ x → Ar _ _ x) (thm2 (drop n s)) $ unimap x iv) f neut

  _/₁⟨_⟩_ : ∀ {a}{X : Set a}{n}{s : Vec ℕ n}{m}
        → (X → X → X) → X
        → Ar X (n + 1) (s ++ (m ∷ []))
        → Ar X n s
  _/₁⟨_⟩_ {n = n} {s} f neut a = let
         x = nest {s = s} a
         in imap λ iv → reduce-1d (unimap x iv) f neut

  module test-reduce where
    a : Ar ℕ 2 (4 ∷ 4 ∷ [])
    a = cst 1

    b : Ar ℕ 1 (5 ∷ [])
    b = cst 2

    test₁ = _/⟨_⟩_ {n = 0} _+_ 0 (, a)
    test₂ = _/⟨_⟩_ {n = 0} _+_ 0 b

-- FIXME!  This reduction does not implement semantics of APL,
--         as it assumes that we always reduce to scalars!
--         Instead, in APL / reduce on the last axis only,
--         i.e. ⍴ +/3 4 5 ⍴ ⍳1 = 3 4

-- This is mimicing APL's f/ syntax, but with extra neutral
-- element.  We can later introduce the variant where certain
-- operations come with pre-defined neutral elements.
_/⟨_⟩_ : ∀ {a}{X : Set a}{n s}
      → (Scal X → Scal X → Scal X) → Scal X → Ar X n s → Scal X
f /⟨ neut ⟩ a = let
                    op x y = unscal $ f (scal x) (scal y)
                    a-1d = , a
                    neut = unscal neut
                in
                    scal $ reduce-1d a-1d op neut

-- XXX I somehow don't understand how to make X to be an arbitrary Set a...
data reduce-neut : {X : Set} → (Scal X → Scal X → Scal X) → Scal X → Set where
  instance
    plus-nat : reduce-neut  _+⟨ n-n ⟩ₙ_ (cst 0)
    mult-nat : reduce-neut _×⟨ n-n ⟩ₙ_ (cst 1)
    plus-flo : reduce-neut  (_+ᵣ_ {{c = n-n}}) (cst 0.0)
    mult-flo : reduce-neut  (_×ᵣ_ {{c = n-n}}) (cst 1.0)

infixr 20 _/_
_/_ : ∀ {X : Set}{n s neut}
      → (op : Scal X → Scal X → Scal X) → {{c : reduce-neut op neut}}
      → Ar X n s → Scal X
_/_ {neut = neut} f a = f /⟨ neut ⟩ a

module test-reduce where
  a = s→a $ 1 ∷ 2 ∷ 3 ∷ 4 ∷ []

  test₁ : reduce-1d a _+_ 0 ≡ 10
  test₁ = refl

  test₂ : _+⟨ n-n ⟩ₙ_ /⟨ scal 0 ⟩ a ≡ scal 10
  test₂ = refl

  test₃ : _+ₙ_ / a ≡ scal 10
  test₃ = refl

  -- This is somewhat semi-useful dot-product expressed
  -- pretty close to what you'd write in APL.
  dotp : ∀ {n s} → Ar ℕ n s → Ar ℕ n s → Scal ℕ
  dotp a b = _+ₙ_ / a ×ₙ b

  test₄ : dotp a a ≡ scal (1 + 4 + 9 + 16)
  test₄ = refl

-- The size of the leading axis.
infixr 20 ≢_
≢_ : ∀ {a}{X : Set a}{n s} → Ar X n s → Scal ℕ
≢_ {n = zero}      a = scal 1
≢_ {n = suc n} {s} a = scal $ head s

data iota-type : (d : ℕ) → (n : ℕ) → (Vec ℕ d) → Set where
  instance
    iota-scal : iota-type 0 1 []
    iota-vec  : ∀ {n} → iota-type 1 n (n ∷ [])

iota-res-t : ∀ {d n s} → iota-type d n s → (sh : Ar ℕ d s) → Set

iota-res-t {n = n} iota-scal sh = Ar (Σ ℕ λ x → x < unscal sh)
                                     1 (unscal sh ∷ [])

iota-res-t {n = n} iota-vec  sh = Ar (Σ (Ar ℕ 1 (n ∷ []))
                                      λ v → v <a sh)
                                     n (a→s sh)

a<b⇒b≡c⇒a<c : ∀ {a b c} → a < b → b ≡ c → a < c
a<b⇒b≡c⇒a<c a<b refl = a<b

infixr 20 ι_
ι_ : ∀ {d n s}{{c : iota-type d n s}}
   → (sh : Ar ℕ d s)
   → iota-res-t c sh
ι_ ⦃ c = iota-scal ⦄ s = (imap λ iv → (toℕ $ ix-lookup iv zero) , toℕ<n (ix-lookup iv zero))
ι_ {n = n} {s = s ∷ []} ⦃ c = iota-vec ⦄ (imap sh) = imap cast-ix→a
  where
    cast-ix→a : _
    cast-ix→a iv = let
                     ix , pf = ix→a iv
                   in ix , λ jv → a<b⇒b≡c⇒a<c (pf jv) (s→a∘a→s (imap sh) jv)

-- Zilde and comma
⍬ : ∀ {a}{X : Set a} → Ar X 1 (0 ∷ [])
⍬ = imap λ iv → magic-fin $ ix-lookup iv zero

-- XXX We are going to use _·_ instead of _,_ as the
-- latter is a constructor of dependent sum.  Renaming
-- all the occurrences to something else would take
-- a bit of work which we should do later.
infixr 30 _·_
_·_ : ∀ {a}{X : Set a}{n} → X → Ar X 1 (n ∷ []) → Ar X 1 (suc n ∷ [])
x · (imap p) = imap λ iv → case ix-lookup iv zero of λ where
                             zero     → x
                             (suc j) → p (j ∷ [])

-- Note that two dots in an upper register combined with
-- the underscore form the _̈  symbol.  When the symbol is
-- used on its own, it looks like ̈ which is the correct
-- "spelling".
infixr 20 _̈_
_̈_ : ∀ {a}{X Y : Set a}{n s}
    → (X → Y)
    → Ar X n s
    → Ar Y n s
f ̈ imap p = imap λ iv → f $ p iv

-- Take and Drop
ax+sh<s : ∀ {n}
        → (ax sh s : Ar ℕ 1 (n ∷ []))
        → (s≥sh : s ≥a sh)
        → (ax <a (s -ₙ sh) {≥ = s≥sh})
        → (ax +ₙ sh) <a s
ax+sh<s (imap ax) (imap sh) (imap s) s≥sh ax<s-sh iv =
    let
      ax+sh<s-sh+sh = +-monoˡ-< (sh iv) (ax<s-sh iv)
      s-sh+sh≡s     = m∸n+n≡m (s≥sh iv)
    in a<b⇒b≡c⇒a<c ax+sh<s-sh+sh s-sh+sh≡s

_↑_ : ∀ {a}{X : Set a}{n s}
    → (sh : Ar ℕ 1 (n ∷ []))
    → (a : Ar X n s)
    → {pf : s→a s ≥a sh}
    → Ar X n $ a→s sh
_↑_ {s = s} sh       (imap f) {pf}   with (prod $ a→s sh) ≟ 0
_↑_ {s = s} sh       (imap f) {pf} | yes Πsh≡0 = mkempty _ Πsh≡0
_↑_ {s = s} (imap q) (imap f) {pf} | no  Πsh≢0 = imap mtake
  where
    mtake : _
    mtake iv = let
                  ai , ai< = ix→a iv
                  ix<q jv = a<b⇒b≡c⇒a<c (ai< jv) (s→a∘a→s (imap q) jv)
                  ix = a→ix ai (s→a s) λ jv → ≤-trans (ix<q jv) (pf jv)
               in f (subst-ix (a→s∘s→a s) ix)

_↓_ : ∀ {a}{X : Set a}{n s}
    → (sh : Ar ℕ 1 (n ∷ []))
    → (a : Ar X n s)
    → {pf : (s→a s) ≥a sh}
    → Ar X n $ a→s $ (s→a s -ₙ sh) {≥ = pf}
_↓_ {s = s} sh (imap x) {pf} with
                             let p = prod $ a→s $ (s→a s -ₙ sh) {≥ = pf}
                             in  p ≟ 0
_↓_ {s = s} sh       (imap f) {pf} | yes Π≡0 = mkempty _ Π≡0
_↓_ {s = s} (imap q) (imap f) {pf} | no  Π≢0 = imap mkdrop
  where
    mkdrop : _
    mkdrop iv = let
                  ai , ai< = ix→a iv
                  ax = ai +ₙ (imap q)
                  thmx = ax+sh<s
                           ai (imap q) (s→a s) pf
                           λ jv → a<b⇒b≡c⇒a<c (ai< jv)
                                  (s→a∘a→s ((s→a s -ₙ (imap q)) {≥ = pf}) jv)
                  ix = a→ix ax (s→a s) thmx
                in f (subst-ix (a→s∘s→a s) ix)

_̈⟨_⟩_ : ∀ {a}{X Y Z : Set a}{n s}
     → Ar X n s
     → (X → Y → Z)
     → Ar Y n s → Ar Z n s
--(imap p) ̈⟨ f ⟩ (imap p₁) = imap λ iv → f (p iv) (p₁ iv)
p ̈⟨ f ⟩ p₁ = imap λ iv → f (unimap p iv) (unimap p₁ iv)


module Data.BitVector.ContainmentOrder where

open import Data.Empty
open import Data.Sum
open import Data.Vec

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

open import Data.Nat hiding (_≟_; _≤_; _≤?_) renaming (zero to Nzero; suc to Nsuc)

open import Data.BitVector

infix 4 _⊂_

data _⊂_ : ∀ {n} → BitVector n → BitVector n → Set where
  []⊂[] : [] ⊂ []
  0#⊂0# : ∀ {n} {x y : BitVector n}     → (x⊂y : x ⊂ y) → (0# ∷ x) ⊂ (0# ∷ y)
  b⊂1#  : ∀ {n} {x y : BitVector n} {b} → (x⊂y : x ⊂ y) → (b  ∷ x) ⊂ (1# ∷ y)

⊂-refl : ∀ {n} → _≡_ ⇒ (_⊂_ {n})
⊂-refl {0} {[]} refl = []⊂[]
⊂-refl {Nsuc n} {0# ∷ xs} refl = 0#⊂0# (⊂-refl refl)
⊂-refl {Nsuc n} {1# ∷ xs} refl = b⊂1# (⊂-refl refl)

⊂-antisym : ∀ {n} → Antisymmetric _≡_ (_⊂_ {n})
⊂-antisym []⊂[] []⊂[] = refl
⊂-antisym (0#⊂0# x⊂y) (0#⊂0# y⊂x) rewrite ⊂-antisym x⊂y y⊂x = refl
⊂-antisym (b⊂1#  x⊂y) (b⊂1#  y⊂x) rewrite ⊂-antisym x⊂y y⊂x = refl

⊂-trans : ∀ {n} → Transitive (_⊂_ {n})
⊂-trans []⊂[] []⊂[] = []⊂[]
⊂-trans (0#⊂0# x⊂y) (0#⊂0# y⊂z) = 0#⊂0# (⊂-trans x⊂y y⊂z)
⊂-trans (0#⊂0# x⊂y) (b⊂1#  y⊂z) = b⊂1#  (⊂-trans x⊂y y⊂z)
⊂-trans (b⊂1#  x⊂y) (b⊂1#  y⊂z) = b⊂1#  (⊂-trans x⊂y y⊂z)

_⊂?_ : ∀ {n} → Decidable (_⊂_ {n})
[] ⊂? [] = yes []⊂[]
(x ∷ xs) ⊂? (y ∷ ys) with xs ⊂? ys
(0# ∷ xs) ⊂? (0# ∷ ys)  | no  xs≢ys = no helper
  where helper : ¬ 0# ∷ xs ⊂ 0# ∷ ys
        helper (0#⊂0# pf) = xs≢ys pf
(x  ∷ xs) ⊂? (1# ∷ ys)  | no  xs≢ys = no helper
  where helper : ¬ x ∷ xs ⊂ 1# ∷ ys
        helper (b⊂1# pf) = xs≢ys pf
(1# ∷ xs) ⊂? (0# ∷ ys)  | no  xs≢ys = no (λ ())
(0# ∷ xs) ⊂? (0# ∷ ys)  | yes xs≡ys = yes (0#⊂0# xs≡ys)
(0# ∷ xs) ⊂? (1# ∷ ys)  | yes xs≡ys = yes (b⊂1#  xs≡ys)
(1# ∷ xs) ⊂? (0# ∷ ys)  | yes xs≡ys = no  (λ ())
(1# ∷ xs) ⊂? (1# ∷ ys)  | yes xs≡ys = yes (b⊂1#  xs≡ys)

decPoset : ∀ {n} → DecPoset _ _ _
decPoset {n} = record
  { Carrier = BitVector n
  ; _≈_ = _≡_
  ; _≤_ = _⊂_
  ; isDecPartialOrder = record
      { isPartialOrder = record
          { isPreorder = record
              { isEquivalence = isEquivalence
              ; reflexive = ⊂-refl
              ; trans = ⊂-trans
              }
          ; antisym = ⊂-antisym
          }
      ; _≟_ = _≟_
      ; _≤?_ = _⊂?_
      }
  }


{-# OPTIONS --prop --rewriting #-}

open import Examples.Sorting.Sequential.Comparable

module Examples.Sorting.Sequential.InsertionSort (M : Comparable) where

open Comparable M
open import Examples.Sorting.Sequential.Core M

open import Calf costMonoid
open import Calf.Types.Bool
open import Calf.Types.List
open import Calf.Types.Eq
open import Calf.Types.Bounded costMonoid
open import Calf.Types.BigO costMonoid

open import Relation.Nullary
open import Relation.Nullary.Negation
open import Relation.Binary.PropositionalEquality as Eq using (_≡_; refl; module ≡-Reasoning)
open import Data.Product using (_×_; _,_; ∃)
open import Data.Sum using (inj₁; inj₂)
open import Function
open import Data.Nat as Nat using (ℕ; zero; suc; z≤n; s≤s; _+_; _*_)
import Data.Nat.Properties as N
open import Data.Nat.Square

insert : cmp (Π A λ _ → Π (list A) λ _ → F (list A))
insert x []       = ret [ x ]
insert x (y ∷ ys) =
  bind (F (list A)) (x ≤ᵇ y)
    λ { false → bind (F (list A)) (insert x ys) (ret ∘ (y ∷_))
      ; true  → ret (x ∷ (y ∷ ys)) }

insert/correct : ∀ x l → Sorted l → ◯ (∃ λ l' → insert x l ≡ ret l' × SortedOf (x ∷ l) l')
insert/correct x []       []       u = [ x ] , refl , refl , [] ∷ []
insert/correct x (y ∷ ys) (h ∷ hs) u with h-cost x y
insert/correct x (y ∷ ys) (h ∷ hs) u | ⇓ b withCost q [ _ , h-eq ] rewrite eq/ref h-eq
  with ≤ᵇ-reflects-≤ u (Eq.trans (eq/ref h-eq) (step/ext (F bool) (ret b) q u)) | ≤-total x y
insert/correct x (y ∷ ys) (h ∷ hs) u | ⇓ false withCost q [ _ , _ ] | ofⁿ ¬x≤y | inj₁ x≤y = contradiction x≤y ¬x≤y
insert/correct x (y ∷ ys) (h ∷ hs) u | ⇓ false withCost q [ _ , _ ] | ofⁿ ¬x≤y | inj₂ x≤y =
  let (ys' , h-ys' , x∷ys↭ys' , sorted-ys') = insert/correct x ys hs u in
  y ∷ ys' , (
    let open ≡-Reasoning in
    begin
      step (F (list A)) q (bind (F (list A)) (insert x ys) (ret ∘ (y ∷_)))
    ≡⟨ step/ext (F (list A)) (bind (F (list A)) (insert x ys) (ret ∘ (y ∷_))) q u ⟩
      bind (F (list A)) (insert x ys) (ret ∘ (y ∷_))
    ≡⟨ Eq.cong (λ e → bind (F (list A)) e (ret ∘ (y ∷_))) h-ys' ⟩
      ret (y ∷ ys')
    ∎
  ) , (
    let open PermutationReasoning in
    begin
      x ∷ y ∷ ys
    <<⟨ refl ⟩
      y ∷ (x ∷ ys)
    <⟨ x∷ys↭ys' ⟩
      y ∷ ys'
    ∎
  ) , All-resp-↭ x∷ys↭ys' (x≤y ∷ h) ∷ sorted-ys'
insert/correct x (y ∷ ys) (h ∷ hs) u | ⇓ true withCost q [ _ , _ ] | ofʸ x≤y | _ =
  x ∷ (y ∷ ys) , step/ext (F (list A)) (ret _) q u , refl , (x≤y ∷ ≤-≤* x≤y h) ∷ (h ∷ hs)

insert/cost : cmp (Π A λ _ → Π (list A) λ _ → cost)
insert/cost x []       = zero
insert/cost x (y ∷ ys) with h-cost x y
... | ⇓ false withCost q [ q≤1 , h-eq ] = q + (insert/cost x ys + zero)
... | ⇓ true  withCost q [ q≤1 , h-eq ] = q + 0

insert/cost/closed : cmp (Π A λ _ → Π (list A) λ _ → cost)
insert/cost/closed x l = length l

insert/cost≤insert/cost/closed : ∀ x l → ◯ (insert/cost x l Nat.≤ insert/cost/closed x l)
insert/cost≤insert/cost/closed x []       u = N.≤-refl
insert/cost≤insert/cost/closed x (y ∷ ys) u with h-cost x y
... | ⇓ false withCost q [ q≤1 , h-eq ] =
  Eq.subst (λ n → (q + n) Nat.≤ (suc (length ys))) (Eq.sym (+-identityʳ (insert/cost x ys))) (
    N.≤-trans
      (+-monoˡ-≤ _ (q≤1 u))
      (s≤s (insert/cost≤insert/cost/closed x ys u))
  )
... | ⇓ true  withCost q [ q≤1 , h-eq ] =
  Eq.subst (Nat._≤ (suc (length ys))) (Eq.sym (+-identityʳ q)) (
    N.≤-trans (q≤1 u) (s≤s z≤n)
  )

insert≤insert/cost : ∀ x l → IsBounded (list A) (insert x l) (insert/cost x l)
insert≤insert/cost x []       = bound/ret
insert≤insert/cost x (y ∷ ys) with h-cost x y
... | ⇓ false withCost q [ q≤1 , h-eq ] rewrite eq/ref h-eq =
  bound/step q (insert/cost x ys + 0) (bound/bind/const (insert/cost x ys) 0 (insert≤insert/cost x ys) λ _ → bound/ret)
... | ⇓ true  withCost q [ q≤1 , h-eq ] rewrite eq/ref h-eq =
  bound/step q 0 bound/ret

insert≤insert/cost/closed : ∀ x l → IsBounded (list A) (insert x l) (insert/cost/closed x l)
insert≤insert/cost/closed x l = bound/relax (insert/cost≤insert/cost/closed x l) (insert≤insert/cost x l)

sort : cmp (Π (list A) λ _ → F (list A))
sort []       = ret []
sort (x ∷ xs) = bind (F (list A)) (sort xs) (insert x)

sort/correct : IsSort sort
sort/correct []       u = [] , refl , refl , []
sort/correct (x ∷ xs) u =
  let (xs'   , h-xs'   , xs↭xs'     , sorted-xs'  ) = sort/correct xs u in
  let (x∷xs' , h-x∷xs' , x∷xs↭x∷xs' , sorted-x∷xs') = insert/correct x xs' sorted-xs' u in
  x∷xs' , (
    let open ≡-Reasoning in
    begin
      sort (x ∷ xs)
    ≡⟨⟩
      bind (F (list A)) (sort xs) (insert x)
    ≡⟨ Eq.cong (λ e → bind (F (list A)) e (insert x)) h-xs' ⟩
      bind (F (list A)) (ret {list A} xs') (insert x)
    ≡⟨⟩
      insert x xs'
    ≡⟨ h-x∷xs' ⟩
      ret x∷xs'
    ∎
  ) , (
    let open PermutationReasoning in
    begin
      x ∷ xs
    <⟨ xs↭xs' ⟩
      x ∷ xs'
    ↭⟨ x∷xs↭x∷xs' ⟩
      x∷xs'
    ∎
  ) , sorted-x∷xs'

sort/cost : cmp (Π (list A) λ _ → cost)
sort/cost []       = 0
sort/cost (x ∷ xs) = bind cost (sort xs) (λ xs' → sort/cost xs + insert/cost/closed x xs')

sort/cost/closed : cmp (Π (list A) λ _ → cost)
sort/cost/closed l = length l ²

sort/cost≤sort/cost/closed : ∀ l → ◯ (sort/cost l Nat.≤ sort/cost/closed l)
sort/cost≤sort/cost/closed []       u = N.≤-refl
sort/cost≤sort/cost/closed (x ∷ xs) u =
  let (xs' , ≡ , ↭ , sorted) = sort/correct xs u in
  begin
    sort/cost (x ∷ xs)
  ≡⟨⟩
    bind cost (sort xs) (λ xs' → sort/cost xs + length xs')
  ≡⟨ Eq.cong (λ e → bind cost e λ xs' → sort/cost xs + length xs') (≡) ⟩
    sort/cost xs + length xs'
  ≡˘⟨ Eq.cong (sort/cost xs +_) (↭-length ↭) ⟩
    sort/cost xs + length xs
  ≤⟨ +-monoˡ-≤ (insert/cost/closed x xs) (sort/cost≤sort/cost/closed xs u) ⟩
    sort/cost/closed xs + insert/cost/closed x xs
  ≡⟨⟩
    length xs ² + length xs
  ≤⟨ lemma/arithmetic (length xs) ⟩
    length (x ∷ xs) ²
  ≡⟨⟩
    sort/cost/closed (x ∷ xs)
  ∎
    where
      open ≤-Reasoning

      lemma/arithmetic : ∀ n → n ² + n Nat.≤ suc n ²
      lemma/arithmetic n =
        begin
          n ² + n
        ≡⟨ N.+-comm (n ²) n ⟩
          n + n ²
        ≡⟨⟩
          n + n * n
        ≤⟨ N.m≤n+m (n + n * n) (suc n) ⟩
          suc n + (n + n * n)
        ≡⟨⟩
          suc (n + (n + n * n))
        ≡˘⟨ Eq.cong (λ m → suc (n + m)) (N.*-suc n n) ⟩
          suc (n + n * suc n)
        ≡⟨⟩
          suc n ²
        ∎

sort≤sort/cost : ∀ l → IsBounded (list A) (sort l) (sort/cost l)
sort≤sort/cost []       = bound/ret
sort≤sort/cost (x ∷ xs) = bound/bind (sort/cost xs) (insert/cost/closed x) (sort≤sort/cost xs) (insert≤insert/cost/closed x)

sort≤sort/cost/closed : ∀ l → IsBounded (list A) (sort l) (sort/cost/closed l)
sort≤sort/cost/closed l = bound/relax (sort/cost≤sort/cost/closed l) (sort≤sort/cost l)

sort/asymptotic : given (list A) measured-via length , sort ∈𝓞(λ n → n ²)
sort/asymptotic = 0 ≤n⇒f[n]≤g[n]via λ l _ → sort≤sort/cost/closed l


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

module SizedTypesLoopDueInadmissibility where

postulate
  Size : Set
  _^   : Size -> Size
  ∞    : Size

{-# BUILTIN SIZE Size  #-}
{-# BUILTIN SIZESUC _^ #-}
{-# BUILTIN SIZEINF ∞  #-}

data Nat : {size : Size} -> Set where
  zero : {size : Size} -> Nat {size ^}
  suc  : {size : Size} -> Nat {size} -> Nat {size ^}

data Maybe (A : Set) : Set where
  nothing : Maybe A
  just : A -> Maybe A

shift_case : {i : Size} -> Maybe (Nat {i ^}) -> Maybe (Nat {i})
shift_case nothing = nothing
shift_case (just zero) = nothing
shift_case (just (suc x)) = just x

shift  : {i : Size} -> (Nat -> Maybe (Nat {i ^})) ->
                       (Nat -> Maybe (Nat {i}))
shift f n = shift_case (f (suc n))

inc : Nat -> Maybe Nat
inc n = just (suc n)

-- the type of the following recursive function should be rejected!!
-- it is inadmissible (see Abel, RAIRO 2004 or CSL 2006)
loop : {i : Size} -> Nat {i} -> (Nat -> Maybe (Nat {i})) -> Set
loop (suc n) f = loop n (shift f)
loop zero f with (f zero)
... | nothing = Nat
... | (just zero) = Nat
... | (just (suc y)) = loop y (shift f)

{-
mutual

  loop : {i : Size} -> Nat {i} -> (Nat -> Maybe (Nat {i})) -> Set
  loop .{i ^} (suc {i} n) f = loop {i} n (shift {i} f)
  loop .{i ^} (zero {i}) f = loop_case {i ^} (f zero) f

  loop_case : {i : Size} -> Maybe (Nat {i}) -> (Nat -> Maybe (Nat {i})) -> Set
  loop_case nothing f = Nat
  loop_case (just zero) f = Nat
  loop_case (just (suc y)) f = loop y (shift f)
-}

diverge = loop zero inc