Vec: map2*-++

Vec: map2*-++

{-# OPTIONS --copatterns #-}
-- NOTE with-K
module Data.Vec.NP where

open import Algebra
open import Algebra.Structures
import Algebra.FunctionProperties
import Algebra.FunctionProperties.Eq
open import Type hiding (Type)
import Level as L
open import Category.Applicative
open import Data.Nat.NP using (ℕ; suc; zero; _+_; _*_; 2*_; module ℕ° ; +-interchange ; _≤_)
open import Data.Nat.Properties using (_+-mono_)
open import Data.Fin hiding (_≤_) renaming (_+_ to _+ᶠ_)
open import Data.Vec using (Vec; []; _∷_; head; tail; replicate; tabulate; foldr; _++_; lookup; splitAt; take; drop; sum; _∷ʳ_; concat)
import Data.Fin.Properties as F
open import Data.Bit
open import Data.Bool using (Bool; if_then_else_)
open import Data.Product hiding (zip; swap) renaming (proj₁ to fst; proj₂ to snd; map to ×-map)
open import Function.NP
open import Relation.Binary
import Relation.Binary.PropositionalEquality.NP as ≡
open ≡ using (_≡_; _≗_; ap; ap₂; _∙_; !_) renaming (refl to idp)
import Data.Vec.Equality

module FunVec {a} {A : Type a} where
    _→ᵛ_ : ℕ → ℕ → Type a
    i →ᵛ o = Vec A i → Vec A o

ap-∷ : ∀ {a} {A : Type a} {n}
         {x y : A} {xs ys : Vec A n} → x ≡ y → xs ≡ ys → x ∷ xs ≡ y ∷ ys
ap-∷ = ap₂ _∷_

module waiting-for-a-fix-in-the-stdlib where

    infixl 4 _⊛_

    _⊛_ : ∀ {a b n} {A : Type a} {B : Type b} →
          Vec (A → B) n → Vec A n → Vec B n
    _⊛_ {n = zero}  fs xs = []
    _⊛_ {n = suc n} fs xs = head fs (head xs) ∷ (tail fs ⊛ tail xs)

    applicative : ∀ {a n} → RawApplicative (λ (A : Type a) → Vec A n)
    applicative = record
      { pure = replicate
      ; _⊛_  = _⊛_
      }

    map : ∀ {a b n} {A : Type a} {B : Type b} →
          (A → B) → Vec A n → Vec B n
    map f xs = replicate f ⊛ xs

    zipWith : ∀ {a b c n} {A : Type a} {B : Type b} {C : Type c} →
              (A → B → C) → Vec A n → Vec B n → Vec C n
    zipWith _⊕_ xs ys = replicate _⊕_ ⊛ xs ⊛ ys

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

    tabulate-∘ : ∀ {n a b} {A : Type a} {B : Type b}
                 (f : A → B) (g : Fin n → A) →
                 tabulate (f ∘ g) ≡ map f (tabulate g)
    tabulate-∘ {zero}  f g = idp
    tabulate-∘ {suc n} f g = ap (_∷_ _) (tabulate-∘ f (g ∘ suc))

    tabulate-ext : ∀ {n a}{A : Type a}{f g : Fin n → A} → f ≗ g → tabulate f ≡ tabulate g
    tabulate-ext {zero}  f≗g = idp
    tabulate-ext {suc n} f≗g = ap-∷ (f≗g zero) (tabulate-ext (f≗g ∘ suc))

    -- map is functorial.

    map-id= : ∀ {a n} {A : Type a}{f : A → A}
             → f ≗ id → map f ≗ id {A = Vec A n}
    map-id= f= []       = idp
    map-id= f= (x ∷ xs) = ap-∷ (f= x) (map-id= f= xs)

    map-id : ∀ {a n} {A : Type a} → map id ≗ id {A = Vec A n}
    map-id = map-id= (λ _ → idp)

    map-∘= : ∀ {a b c n} {A : Type a} {B : Type b} {C : Type c}
               {f : B → C}{g : A → B}{h : A → C} →
               f ∘ g ≗ h →
               _≗_ {A = Vec A n} (map f ∘ map g) (map h)
    map-∘= fg= []       = idp
    map-∘= fg= (x ∷ xs) = ap-∷ (fg= x) (map-∘= fg= xs)

    map-∘ : ∀ {a b c n} {A : Type a} {B : Type b} {C : Type c}
              (f : B → C) (g : A → B) →
              _≗_ {A = Vec A n} (map (f ∘ g)) (map f ∘ map g)
    map-∘ f g v = ! map-∘= (λ _ → idp) v

    map-ext : ∀ {a b} {A : Type a} {B : Type b} {f g : A → B} {n} → f ≗ g → map f ≗ map {n = n} g
    map-ext f≗g []       = idp
    map-ext f≗g (x ∷ xs) = ap-∷ (f≗g x) (map-ext f≗g xs)

open waiting-for-a-fix-in-the-stdlib public

module With≈
    {a ℓ ℓ'}{A : Type a}
    (_≈_ : A → A → Type ℓ)
    {_≈ᵛ_ : ∀ {n}(xs ys : Vec A n) → Type ℓ'}
    ([]-cong  : [] ≈ᵛ [])
    (_∷-cong_ : ∀ {n} {x¹} {xs¹ : Vec A n} {x²} {xs² : Vec A n}
                  (x¹≈x² : x¹ ≈ x²) (xs¹≈xs² : xs¹ ≈ᵛ xs²) →
                  (x¹ ∷ xs¹) ≈ᵛ (x² ∷ xs²))
  where
  open Algebra.FunctionProperties

  module _ {_∙_ _∙∙_ : A → A → A}
           (assoc : ∀ x y z → ((x ∙ y) ∙∙ z) ≈ (x ∙ (y ∙∙ z))) where
    private
      _∙ᵛ_ _∙∙ᵛ_ : ∀ {n}(xs ys : Vec A n) → Vec A n
      _∙ᵛ_  = zipWith _∙_
      _∙∙ᵛ_ = zipWith _∙∙_

    zipWith-assoc : ∀ {n} (xs ys zs : Vec A n) → ((xs ∙ᵛ ys) ∙∙ᵛ zs) ≈ᵛ (xs ∙ᵛ (ys ∙∙ᵛ zs))
    zipWith-assoc [] [] [] = []-cong
    zipWith-assoc (x ∷ xs) (y ∷ ys) (z ∷ zs)
       = assoc x y z ∷-cong (zipWith-assoc xs ys zs)

  module _ {_∙_ : A → A → A} where
    module _ (∙-comm : Commutative _≈_ _∙_) where
      zipWith-comm : ∀ {n} → Commutative _≈ᵛ_ (zipWith {n = n} _∙_)
      zipWith-comm [] [] = []-cong
      zipWith-comm (x ∷ xs) (y ∷ ys) = ∙-comm x y ∷-cong zipWith-comm xs ys

    module _ {ε : A} where
      module _ (∙-id-left : LeftIdentity _≈_ ε _∙_) where
        zipWith-id-left : ∀ {n} → LeftIdentity _≈ᵛ_ (replicate ε) (zipWith {n = n} _∙_)
        zipWith-id-left [] = []-cong
        zipWith-id-left (x ∷ xs) = ∙-id-left x ∷-cong zipWith-id-left xs

      module _ (∙-id-right : RightIdentity _≈_ ε _∙_) where
        zipWith-id-right : ∀ {n} → RightIdentity _≈ᵛ_ (replicate ε) (zipWith {n = n} _∙_)
        zipWith-id-right [] = []-cong
        zipWith-id-right (x ∷ xs) = ∙-id-right x ∷-cong zipWith-id-right xs

      module _ {_⁻¹ : A → A}
               (inverse : LeftInverse _≈_ ε _⁻¹ _∙_) where
        zipWith-left-inverse : ∀ {n} → LeftInverse _≈ᵛ_ (replicate ε) (map _⁻¹) (zipWith {n = n} _∙_)
        zipWith-left-inverse [] = []-cong
        zipWith-left-inverse (x ∷ xs) = inverse x ∷-cong zipWith-left-inverse xs

      module _ {_⁻¹ : A → A}
               (inverse : RightInverse _≈_ ε _⁻¹ _∙_) where
        zipWith-right-inverse : ∀ {n} → RightInverse _≈ᵛ_ (replicate ε) (map _⁻¹) (zipWith {n = n} _∙_)
        zipWith-right-inverse [] = []-cong
        zipWith-right-inverse (x ∷ xs) = inverse x ∷-cong zipWith-right-inverse xs

module WithSetoid {c ℓ} (S : Setoid c ℓ) where
  A = Setoid.Carrier S
  open Setoid S
  V = Vec A
  module V≈ = Data.Vec.Equality.Equality S
  open Algebra.FunctionProperties
  open V≈ hiding (_≈_)
  _≈ᵛ_ : ∀ {n} → V n → V n → Type _
  xs ≈ᵛ ys = V≈._≈_ xs ys

  open With≈ _≈_ {_≈ᵛ_} []-cong (λ x y → x ∷-cong y) public

  module _ {f : A → A} (f-cong : f Preserves _≈_ ⟶ _≈_) where
    map-cong : ∀ {n} → map {n = n} f Preserves _≈ᵛ_ ⟶ _≈ᵛ_
    map-cong []-cong = []-cong
    map-cong (x≈y ∷-cong xs≈ys) = f-cong x≈y ∷-cong map-cong xs≈ys

  module _ {f : A → A → A} (f-cong : f Preserves₂ _≈_ ⟶ _≈_ ⟶ _≈_) where
    zipWith-cong : ∀ {n} → zipWith {n = n} f Preserves₂ _≈ᵛ_ ⟶ _≈ᵛ_ ⟶ _≈ᵛ_
    zipWith-cong []-cong []-cong = []-cong
    zipWith-cong (x≈y ∷-cong xs≈ys) (z≈t ∷-cong zs≈ts) = f-cong x≈y z≈t ∷-cong zipWith-cong xs≈ys zs≈ts

∷= : ∀ {a}{A : Type a}{n x} {xs : Vec A n} {y} {ys : Vec A n}
       (p : x ≡ y) (q : xs ≡ ys) →
        x ∷ xs ≡ y ∷ ys
∷= idp idp = idp

module With≡ {a}{A : Type a} where
  open With≈ (_≡_ {A = A}) {_≡_} idp (λ x¹≈x² xs¹≈xs² → ∷= x¹≈x² xs¹≈xs²) public

module LiftSemigroup {c ℓ} (Sg : Semigroup c ℓ) where
    module Sg = Semigroup Sg
    open WithSetoid Sg.setoid public

    _∙ᵛ_ : ∀ {n} → V n → V n → V n
    _∙ᵛ_ = zipWith Sg._∙_

    -- this should be in Data.Vec.Equality
    isEquivalence : ∀ {n} → IsEquivalence (_≈ᵛ_ {n})
    isEquivalence = record { refl = λ {xs} → V≈.refl xs
                           ; sym = V≈.sym ; trans = V≈.trans }

    isSemigroup : ∀ {n} → IsSemigroup (_≈ᵛ_ {n}) _∙ᵛ_
    isSemigroup = record { isEquivalence = isEquivalence
                                       ; assoc = zipWith-assoc Sg.assoc
                                       ; ∙-cong = zipWith-cong Sg.∙-cong }

    semigroup : ∀ n → Semigroup c (ℓ L.⊔ c)
    semigroup n = record { isSemigroup = isSemigroup {n} }

module LiftMonoid {c ℓ} (M : Monoid c ℓ) where
    module M = Monoid M
    open LiftSemigroup M.semigroup public

    εᵛ : ∀ {n} → V n
    εᵛ = replicate M.ε

    isMonoid : ∀ {n} → IsMonoid (_≈ᵛ_ {n}) _∙ᵛ_ εᵛ
    isMonoid = record { isSemigroup = isSemigroup
                      ; identity = zipWith-id-left (fst M.identity)
                                 , zipWith-id-right (snd M.identity) }

    monoid : ℕ → Monoid c (ℓ L.⊔ c)
    monoid n = record { isMonoid = isMonoid {n} }

module LiftCommutativeMonoid {c ℓ} (CM : CommutativeMonoid c ℓ) where
    module CM = CommutativeMonoid CM
    open LiftMonoid CM.monoid public

    isCommutativeMonoid : ∀ {n} → IsCommutativeMonoid (_≈ᵛ_ {n}) _∙ᵛ_ εᵛ
    isCommutativeMonoid =
       record { isSemigroup = isSemigroup
                  ; identityˡ = zipWith-id-left  CM.identityˡ
                  ; comm = zipWith-comm CM.comm }

    commutative-monoid : ℕ → CommutativeMonoid c (ℓ L.⊔ c)
    commutative-monoid n = record { isCommutativeMonoid = isCommutativeMonoid {n} }

module LiftGroup {c ℓ} (G : Group c ℓ) where
    module G = Group G
    open LiftMonoid G.monoid public

    _⁻¹ᵛ : ∀ {n} → V n → V n
    _⁻¹ᵛ = map G._⁻¹

    isGroup : ∀ {n} → IsGroup (_≈ᵛ_ {n}) _∙ᵛ_ εᵛ _⁻¹ᵛ
    isGroup = record { isMonoid = isMonoid
                                ; inverse = (zipWith-left-inverse (fst G.inverse))
                                                , (zipWith-right-inverse (snd G.inverse))
                                ; ⁻¹-cong = map-cong G.⁻¹-cong }

    group : ℕ → Group c _
    group n = record { isGroup = isGroup {n} }

module LiftAbelianGroup {c ℓ} (AG : AbelianGroup c ℓ) where
    module AG = AbelianGroup AG
    open LiftGroup AG.group public

    isAbelianGroup : ∀ {n} → IsAbelianGroup (_≈ᵛ_ {n}) _∙ᵛ_ εᵛ _⁻¹ᵛ
    isAbelianGroup = record { isGroup = isGroup ; comm = zipWith-comm AG.comm }

    abelianGroup : ℕ → AbelianGroup c _
    abelianGroup n = record { isAbelianGroup = isAbelianGroup {n} }

open Algebra.FunctionProperties.Eq.Implicits

-- Trying to get rid of the foldl in the definition of reverse and
-- without using equations on natural numbers.
-- In the end that's not very convincing.
module Alternative-Reverse where
    rev-+ : ℕ → ℕ → ℕ
    rev-+ zero    = id
    rev-+ (suc x) = rev-+ x ∘ suc

    rev-app : ∀ {a} {A : Type a} {m n} →
              Vec A n → Vec A m → Vec A (rev-+ n m)
    rev-app []       = id
    rev-app (x ∷ xs) = rev-app xs ∘ _∷_ x

    rev-aux : ∀ {a} {A : Type a} {m} n →
              Vec A (rev-+ n zero) →
              (∀ {m} → A → Vec A (rev-+ n m) → Vec A (rev-+ n (suc m))) →
              Vec A m → Vec A (rev-+ n m)
    rev-aux m acc op []       = acc
    rev-aux m acc op (x ∷ xs) = rev-aux (suc m) (op x acc) op xs

    alt-reverse : ∀ {a n} {A : Type a} → Vec A n → Vec A n
    alt-reverse = rev-aux 0 [] _∷_

countᶠ : ∀ {n a} {A : Type a} → (A → Bool) → Vec A n → Fin (suc n)
countᶠ pred = foldr (Fin ∘ suc) (λ x → if pred x then suc else inject₁) zero

count : ∀ {n a} {A : Type a} → (A → Bool) → Vec A n → ℕ
count pred = toℕ ∘ countᶠ pred

RewireTbl : (i o : ℕ) → ★₀
RewireTbl i o = Vec (Fin i) o

sum-∷ʳ : ∀ {n} x (xs : Vec ℕ n) → sum (xs ∷ʳ x) ≡ sum xs + x
sum-∷ʳ x []        = ℕ°.+-comm x 0
sum-∷ʳ x (x₁ ∷ xs) = ap (_+_ x₁) (sum-∷ʳ x xs) ∙ !(ℕ°.+-assoc x₁ (sum xs) x)

sum-distribˡ : ∀ {A : ★₀} {n} f k (xs : Vec A n) → sum (map (λ x → k * f x) xs) ≡ k * sum (map f xs)
sum-distribˡ f k [] = ℕ°.*-comm 0 k
sum-distribˡ f k (x ∷ xs) rewrite sum-distribˡ f k xs = !(fst ℕ°.distrib k _ _)

sum-linear : ∀ {A : ★₀} {n} f g (xs : Vec A n) → sum (map (λ x → f x + g x) xs) ≡ sum (map f xs) + sum (map g xs)
sum-linear f g [] = idp
sum-linear f g (x ∷ xs) rewrite sum-linear f g xs = +-interchange (f x) (g x) (sum (map f xs)) (sum (map g xs))

sum-mono : ∀ {A : ★₀} {n f g} (mono : ∀ x → f x ≤ g x)(xs : Vec A n) → sum (map f xs) ≤ sum (map g xs)
sum-mono f≤°g [] = Data.Nat.NP.z≤n
sum-mono f≤°g (x ∷ xs) = f≤°g x +-mono sum-mono f≤°g xs

module _ {a} {A : Type a} where
  -- Exchange elements at positions 0 and 1 of a given vector
  -- (this only apply if the vector is long enough).
  0↔1 : ∀ {n} → Vec A n → Vec A n
  0↔1 (x₀ ∷ x₁ ∷ xs) = x₁ ∷ x₀ ∷ xs
  0↔1 xs = xs

module _ {a} {A : Type a} where
  count-++ : ∀ {m n} (pred : A → Bool) (xs : Vec A m) (ys : Vec A n)
              → count pred (xs ++ ys) ≡ count pred xs + count pred ys
  count-++ pred [] ys = idp
  count-++ pred (x ∷ xs) ys with pred x
  ... | 1b rewrite count-++ pred xs ys = idp
  ... | 0b rewrite F.inject₁-lemma (countᶠ pred (xs ++ ys))
                    | F.inject₁-lemma (countᶠ pred xs) | count-++ pred xs ys = idp

  ext-countᶠ : ∀ {n} {f g : A → Bool} → f ≗ g → (xs : Vec A n) → countᶠ f xs ≡ countᶠ g xs
  ext-countᶠ f≗g [] = idp
  ext-countᶠ f≗g (x ∷ xs) rewrite ext-countᶠ f≗g xs | f≗g x = idp

  filter : ∀ {n} (pred : A → Bool) (xs : Vec A n) → Vec A (count pred xs)
  filter pred [] = []
  filter pred (x ∷ xs) with pred x
  ... | 1b = x ∷ filter pred xs
  ... | 0b rewrite F.inject₁-lemma (countᶠ pred xs) = filter pred xs

  transpose : ∀ {m n} → Vec (Vec A m) n → Vec (Vec A n) m
  transpose [] = replicate []
  transpose (xs ∷ xss) = zipWith _∷_ xs (transpose xss)

  vap : ∀ {m b} {B : Type b} (f : Vec A m → B)
          → ∀ {n} → Vec (Vec A n) m → Vec B n
  vap f = map f ∘ transpose

  infixl 2 _‼_
  _‼_ : ∀ {n} → Vec A n → Fin n → A
  _‼_ = flip lookup

  η : ∀ {n} → Vec A n → Vec A n
  η = tabulate ∘ _‼_

  η′ : ∀ {n} → Vec A n → Vec A n
  η′ {zero}  = λ _ → []
  η′ {suc n} = λ xs → head xs ∷ η (tail xs)

  shallow-η : ∀ {n} (xs : Vec A (1 + n)) → xs ≡ head xs ∷ tail xs
  shallow-η (x ∷ xs) = idp

  uncons : ∀ {n} → Vec A (1 + n) → (A × Vec A n)
  uncons (x ∷ xs) = x , xs

  ∷-uncons : ∀ {n} (xs : Vec A (1 + n)) → uncurry _∷_ (uncons xs) ≡ xs
  ∷-uncons (x ∷ xs) = idp

  splitAt′ : ∀ m {n} → Vec A (m + n) → Vec A m × Vec A n
  splitAt′ m xs = case splitAt m xs of λ { (ys , zs , _) → (ys , zs) }

  group : ∀ n k → Vec A (n * k) → Vec (Vec A k) n
  group zero    k v = []
  group (suc n) k v = take k v ∷ group n k (drop k v)

  map2* : ∀ m n (f : Vec A m → Vec A n) → Vec A (2* m) → Vec A (2* n)
  map2* m _ f xs = f (take m xs) ++ f (drop m xs)

  map* : ∀ k {m n}(f : Vec A m → Vec A n) → Vec A (k * m) → Vec A (k * n)
  map* k f xs = concat (map f (group k _ xs))

  take2* : ∀ n → Bit → Vec A (2* n) → Vec A n
  take2* n 0b v = take n v
  take2* n 1b v = drop n v

  ++-decomp : ∀ {m n} {xs zs : Vec A m} {ys ts : Vec A n}
             → (xs ++ ys) ≡ (zs ++ ts) → (xs ≡ zs × ys ≡ ts)
  ++-decomp {zero} {xs = []} {[]} p = idp , p
  ++-decomp {suc m} {xs = x ∷ xs} {z ∷ zs} eq with ++-decomp {m} {xs = xs} {zs} (ap tail eq)
  ... | (q₁ , q₂) = (ap-∷ (ap head eq) q₁) , q₂

  ++-inj₁ : ∀ {m n} {xs ys : Vec A m} {zs ts : Vec A n} → xs ++ zs ≡ ys ++ ts → xs ≡ ys
  ++-inj₁ eq = fst (++-decomp eq)

  ++-inj₂ : ∀ {m n} (xs ys : Vec A m) {zs ts : Vec A n} → xs ++ zs ≡ ys ++ ts → zs ≡ ts
  ++-inj₂ xs ys eq = snd (++-decomp {xs = xs} {zs = ys} eq)

  take-∷ : ∀ {m} n x (xs : Vec A (n + m)) → take (suc n) (x ∷ xs) ≡ x ∷ take n xs
  take-∷ n x xs with splitAt n xs
  take-∷ _ _ ._ | _ , _ , idp = idp

  drop-∷ : ∀ {m} n x (xs : Vec A (n + m)) → drop (suc n) (x ∷ xs) ≡ drop n xs
  drop-∷ n x xs with splitAt n xs
  drop-∷ _ _ ._ | _ , _ , idp = idp

  take-++ : ∀ m {n} (xs : Vec A m) (ys : Vec A n) → take m (xs ++ ys) ≡ xs
  take-++ m xs ys with xs ++ ys | ≡.inspect (_++_ xs) ys
  ... | zs | eq with splitAt m zs
  take-++ m xs₁ ys₁ | .(xs ++ ys) | ≡.[ eq ] | xs , ys , idp = !(++-inj₁ eq)

  drop-++ : ∀ m {n} (xs : Vec A m) (ys : Vec A n) → drop m (xs ++ ys) ≡ ys
  drop-++ m xs ys with xs ++ ys | ≡.inspect (_++_ xs) ys
  ... | zs | eq with splitAt m zs
  drop-++ m xs₁ ys₁ | .(xs ++ ys) | ≡.[ eq ] | xs , ys , idp = !(++-inj₂ xs₁ xs eq)

  take-drop-lem : ∀ m {n} (xs : Vec A (m + n)) → take m xs ++ drop m xs ≡ xs
  take-drop-lem m xs with splitAt m xs
  take-drop-lem m .(ys ++ zs) | ys , zs , idp = idp

  take-them-all : ∀ n (xs : Vec A (n + 0)) → take n xs ++ [] ≡ xs
  take-them-all n xs with splitAt n xs
  take-them-all n .(ys ++ []) | ys , [] , idp = idp

  drop′ : ∀ m {n} → Vec A (m + n) → Vec A n
  drop′ zero    = id
  drop′ (suc m) = drop′ m ∘ tail

  map2*-++ : ∀ {m n}(f : Vec A m → Vec A n) → map2* m n f ∘ uncurry _++_ ≗ uncurry _++_ ∘ ×-map f f
  map2*-++ {m} f (x , y) rewrite take-++ m x y | drop-++ m x y = idp

  drop′-spec : ∀ m {n} → drop′ m {n} ≗ drop m {n}
  drop′-spec zero    _        = idp
  drop′-spec (suc m) (x ∷ xs) = drop′-spec m xs ∙ !(drop-∷ m x xs)

  take′ : ∀ m {n} → Vec A (m + n) → Vec A m
  take′ zero    _  = []
  take′ (suc m) xs = head xs ∷ take′ m (tail xs)

  take′-spec : ∀ m {n} → take′ m {n} ≗ take m {n}
  take′-spec zero    xs       = idp
  take′-spec (suc m) (x ∷ xs) = ap (_∷_ x) (take′-spec m xs) ∙ !(take-∷ m x xs)

  swap : ∀ m {n} → Vec A (m + n) → Vec A (n + m)
  swap m xs = drop m xs ++ take m xs

  swap-++ : ∀ m {n} (xs : Vec A m) (ys : Vec A n) → swap m (xs ++ ys) ≡ ys ++ xs
  swap-++ m xs ys = ap₂ _++_ (drop-++ m xs ys) (take-++ m xs ys)

  rewire : ∀ {i o} → (Fin o → Fin i) → Vec A i → Vec A o
  rewire f v = tabulate (_‼_ v ∘ f)

  take-drop= : ∀ m {n} (xs ys : Vec A (m + n))
                 → take m xs ≡ take m ys
                 → drop m xs ≡ drop m ys
                 → xs ≡ ys
  take-drop= m xs ys take= drop= =
    ! take-drop-lem m xs ∙ ap₂ _++_ take= drop= ∙ take-drop-lem m ys

  rewireTbl : ∀ {i o} → RewireTbl i o → Vec A i → Vec A o
  rewireTbl tbl v = map (_‼_ v) tbl

  onᵢ : ∀ (f : A → A) {n} (i : Fin n) → Vec A n → Vec A n
  onᵢ f zero    (x ∷ xs) = f x ∷ xs
  onᵢ f (suc i) (x ∷ xs) = x ∷ onᵢ f i xs

  ⊛-dist-0↔1 : ∀ {n}(fs : Vec (Endo A) n) xs → 0↔1 fs ⊛ 0↔1 xs ≡ 0↔1 (fs ⊛ xs)
  ⊛-dist-0↔1 _           []          = idp
  ⊛-dist-0↔1 (_ ∷ [])    (_ ∷ [])    = idp
  ⊛-dist-0↔1 (_ ∷ _ ∷ _) (_ ∷ _ ∷ _) = idp

  map-tail : ∀ {m n} → (Vec A m → Vec A n) → Vec A (suc m) → Vec A (suc n)
  map-tail f (x ∷ xs) = x ∷ f xs

  map-tail-id : ∀ {n} → map-tail id ≗ id {A = Vec A (suc n)}
  map-tail-id (x ∷ xs) = idp

  map-tail∘map-tail : ∀ {m n o}
                        (f : Vec A o → Vec A m)
                        (g : Vec A n → Vec A o)
                      → map-tail f ∘ map-tail g ≗ map-tail (f ∘ g)
  map-tail∘map-tail f g (x ∷ xs) = idp

  map-tail-≗ : ∀ {m n}(f g : Vec A m → Vec A n) → f ≗ g → map-tail f ≗ map-tail g
  map-tail-≗ f g f≗g (x ∷ xs) = ap (_∷_ x) (f≗g xs)

  dup : ∀ {n} → Vec A n → Vec A (n + n)
  dup xs = xs ++ xs

  dup-inj : ∀ {n} → Injective (dup {n})
  dup-inj = ++-inj₁

  rot₁ : ∀ {n} → Vec A n → Vec A n
  rot₁ []       = []
  rot₁ (x ∷ xs) = xs ∷ʳ x

  rot : ∀ {n} → ℕ → Vec A n → Vec A n
  rot zero    xs = xs
  rot (suc n) xs = rot n (rot₁ xs)

  map-∷ʳ : ∀ {n}(f : A → ℕ) x (xs : Vec A n) → map f (xs ∷ʳ x) ≡ map f xs ∷ʳ f x
  map-∷ʳ f x []       = idp
  map-∷ʳ f x (_ ∷ xs) = ap (_∷_ _) (map-∷ʳ f x xs)

  sum-map-rot₁ : ∀ {n}(f : A → ℕ) (xs : Vec A n) → sum (map f (rot₁ xs)) ≡ sum (map f xs)
  sum-map-rot₁ f [] = idp
  sum-map-rot₁ f (x ∷ xs) = ap sum (map-∷ʳ f x xs)
                          ∙ sum-∷ʳ (f x) (map f xs)
                          ∙ ℕ°.+-comm (sum (map f xs)) (f x)

  vec= : ∀ {n}{xs ys : Vec A n} → (∀ i → (xs ‼ i) ≡ (ys ‼ i)) → xs ≡ ys
  vec= {xs = []}     {[]}     f= = idp
  vec= {xs = x ∷ xs} {y ∷ ys} f= = ap-∷ (f= zero) (vec= (f= ∘ suc))

  concat-group : ∀ m n (xs : Vec A (m * n)) → concat (group m n xs) ≡ xs
  concat-group zero    n [] = idp
  concat-group (suc m) n xs rewrite concat-group m n (drop n xs) = take-drop-lem n xs

  group-concat : ∀ {m n}(xss : Vec (Vec A n) m) → group m n (concat xss) ≡ xss
  group-concat [] = idp
  group-concat (xs ∷ xss)
    rewrite take-++ _ xs (concat xss)
          | drop-++ _ xs (concat xss)
          | group-concat xss
          = idp

  -- These are also in the stdlib as Data.Vec.Properties.lookup-morphism
  ‼-replicate : ∀ {n}(i : Fin n)(x : A) → (replicate x ‼ i) ≡ x
  ‼-replicate zero    = λ _ → idp
  ‼-replicate (suc i) = ‼-replicate i

module _ {a b}{A : Type a}{B : Type b} where
  ‼-⊛= : ∀ {n} i {fs : Vec (A → B) n}{xs : Vec A n}{f x}
           (fs= : (fs ‼ i) ≡ f)
           (xs= : (xs ‼ i) ≡ x)
         → (fs ⊛ xs ‼ i) ≡ f x
  ‼-⊛= zero    {f ∷ fs} {x ∷ xs} f= xs= = ap₂ _$_ f= xs=
  ‼-⊛= (suc i) {f ∷ fs} {x ∷ xs} f= xs= = ‼-⊛= i f= xs=

  ‼-⊛ : ∀ {n} i (fs : Vec (A → B) n) (xs : Vec A n) →
          (fs ⊛ xs ‼ i) ≡ (fs ‼ i) (xs ‼ i)
  ‼-⊛ i fs xs = ‼-⊛= i idp idp

  ‼-map= : ∀ {n} i (f : A → B) {xs : Vec A n}{x : A}
             (xs= : (xs ‼ i) ≡ x)
           → (map f xs ‼ i) ≡ f x
  ‼-map= i f = ‼-⊛= i (‼-replicate i f)

  ‼-map : ∀ {n} i (f : A → B) (xs : Vec A n) →
            (map f xs ‼ i) ≡ f (xs ‼ i)
  ‼-map i f xs = ‼-map= i f idp

  vuncurry : ∀ {n}(f : A → Vec A n → B) → Vec A (1 + n) → B
  vuncurry f (x ∷ xs) = f x xs

  count-∘ : ∀ {n}(f : A → B)(pred : B → Bool) →
              count {n} (pred ∘ f) ≗ count pred ∘ map f
  count-∘ f pred [] = idp
  count-∘ f pred (x ∷ xs) with pred (f x)
  ... | 1b rewrite count-∘ f pred xs = idp
  ... | 0b rewrite F.inject₁-lemma (countᶠ pred (map f xs))
                 | F.inject₁-lemma (countᶠ (pred ∘ f) xs)
                 | count-∘ f pred xs = idp

sum-rot₁ : ∀ {n} (xs : Vec ℕ n) → sum xs ≡ sum (rot₁ xs)
sum-rot₁ []       = idp
sum-rot₁ (x ∷ xs) = ℕ°.+-comm x (sum xs) ∙ !(sum-∷ʳ x xs)

open import Data.Vec public hiding (_⊛_; zipWith; zip; map; applicative; group)
-- -}
-- -}
-- -}
-- -}

{-# OPTIONS --copatterns #-}
-- NOTE with-K
module Data.Vec.NP where

open import Algebra
open import Algebra.Structures
import Algebra.FunctionProperties
import Algebra.FunctionProperties.Eq
open import Type hiding (Type)
import Level as L
open import Category.Applicative
open import Data.Nat.NP using (ℕ; suc; zero; _+_; _*_; 2*_; module ℕ° ; +-interchange ; _≤_)
open import Data.Nat.Properties using (_+-mono_)
open import Data.Fin hiding (_≤_) renaming (_+_ to _+ᶠ_)
open import Data.Vec using (Vec; []; _∷_; head; tail; replicate; tabulate; foldr; _++_; lookup; splitAt; take; drop; sum; _∷ʳ_; concat)
import Data.Fin.Properties as F
open import Data.Bit
open import Data.Bool using (Bool; if_then_else_)
open import Data.Product hiding (map; zip; swap) renaming (proj₁ to fst; proj₂ to snd)
open import Function.NP
open import Relation.Binary
import Relation.Binary.PropositionalEquality.NP as ≡
open ≡ using (_≡_; _≗_; ap; ap₂; _∙_; !_) renaming (refl to idp)
import Data.Vec.Equality

module FunVec {a} {A : Type a} where
    _→ᵛ_ : ℕ → ℕ → Type a
    i →ᵛ o = Vec A i → Vec A o

ap-∷ : ∀ {a} {A : Type a} {n}
         {x y : A} {xs ys : Vec A n} → x ≡ y → xs ≡ ys → x ∷ xs ≡ y ∷ ys
ap-∷ = ap₂ _∷_

module waiting-for-a-fix-in-the-stdlib where

    infixl 4 _⊛_

    _⊛_ : ∀ {a b n} {A : Type a} {B : Type b} →
          Vec (A → B) n → Vec A n → Vec B n
    _⊛_ {n = zero}  fs xs = []
    _⊛_ {n = suc n} fs xs = head fs (head xs) ∷ (tail fs ⊛ tail xs)

    applicative : ∀ {a n} → RawApplicative (λ (A : Type a) → Vec A n)
    applicative = record
      { pure = replicate
      ; _⊛_  = _⊛_
      }

    map : ∀ {a b n} {A : Type a} {B : Type b} →
          (A → B) → Vec A n → Vec B n
    map f xs = replicate f ⊛ xs

    zipWith : ∀ {a b c n} {A : Type a} {B : Type b} {C : Type c} →
              (A → B → C) → Vec A n → Vec B n → Vec C n
    zipWith _⊕_ xs ys = replicate _⊕_ ⊛ xs ⊛ ys

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

    tabulate-∘ : ∀ {n a b} {A : Type a} {B : Type b}
                 (f : A → B) (g : Fin n → A) →
                 tabulate (f ∘ g) ≡ map f (tabulate g)
    tabulate-∘ {zero}  f g = idp
    tabulate-∘ {suc n} f g = ap (_∷_ _) (tabulate-∘ f (g ∘ suc))

    tabulate-ext : ∀ {n a}{A : Type a}{f g : Fin n → A} → f ≗ g → tabulate f ≡ tabulate g
    tabulate-ext {zero}  f≗g = idp
    tabulate-ext {suc n} f≗g = ap-∷ (f≗g zero) (tabulate-ext (f≗g ∘ suc))

    -- map is functorial.

    map-id= : ∀ {a n} {A : Type a}{f : A → A}
             → f ≗ id → map f ≗ id {A = Vec A n}
    map-id= f= []       = idp
    map-id= f= (x ∷ xs) = ap-∷ (f= x) (map-id= f= xs)

    map-id : ∀ {a n} {A : Type a} → map id ≗ id {A = Vec A n}
    map-id = map-id= (λ _ → idp)

    map-∘= : ∀ {a b c n} {A : Type a} {B : Type b} {C : Type c}
               {f : B → C}{g : A → B}{h : A → C} →
               f ∘ g ≗ h →
               _≗_ {A = Vec A n} (map f ∘ map g) (map h)
    map-∘= fg= []       = idp
    map-∘= fg= (x ∷ xs) = ap-∷ (fg= x) (map-∘= fg= xs)

    map-∘ : ∀ {a b c n} {A : Type a} {B : Type b} {C : Type c}
              (f : B → C) (g : A → B) →
              _≗_ {A = Vec A n} (map (f ∘ g)) (map f ∘ map g)
    map-∘ f g v = ! map-∘= (λ _ → idp) v

    map-ext : ∀ {a b} {A : Type a} {B : Type b} {f g : A → B} {n} → f ≗ g → map f ≗ map {n = n} g
    map-ext f≗g []       = idp
    map-ext f≗g (x ∷ xs) = ap-∷ (f≗g x) (map-ext f≗g xs)

open waiting-for-a-fix-in-the-stdlib public

module With≈
    {a ℓ ℓ'}{A : Type a}
    (_≈_ : A → A → Type ℓ)
    {_≈ᵛ_ : ∀ {n}(xs ys : Vec A n) → Type ℓ'}
    ([]-cong  : [] ≈ᵛ [])
    (_∷-cong_ : ∀ {n} {x¹} {xs¹ : Vec A n} {x²} {xs² : Vec A n}
                  (x¹≈x² : x¹ ≈ x²) (xs¹≈xs² : xs¹ ≈ᵛ xs²) →
                  (x¹ ∷ xs¹) ≈ᵛ (x² ∷ xs²))
  where
  open Algebra.FunctionProperties

  module _ {_∙_ _∙∙_ : A → A → A}
           (assoc : ∀ x y z → ((x ∙ y) ∙∙ z) ≈ (x ∙ (y ∙∙ z))) where
    private
      _∙ᵛ_ _∙∙ᵛ_ : ∀ {n}(xs ys : Vec A n) → Vec A n
      _∙ᵛ_  = zipWith _∙_
      _∙∙ᵛ_ = zipWith _∙∙_

    zipWith-assoc : ∀ {n} (xs ys zs : Vec A n) → ((xs ∙ᵛ ys) ∙∙ᵛ zs) ≈ᵛ (xs ∙ᵛ (ys ∙∙ᵛ zs))
    zipWith-assoc [] [] [] = []-cong
    zipWith-assoc (x ∷ xs) (y ∷ ys) (z ∷ zs)
       = assoc x y z ∷-cong (zipWith-assoc xs ys zs)

  module _ {_∙_ : A → A → A} where
    module _ (∙-comm : Commutative _≈_ _∙_) where
      zipWith-comm : ∀ {n} → Commutative _≈ᵛ_ (zipWith {n = n} _∙_)
      zipWith-comm [] [] = []-cong
      zipWith-comm (x ∷ xs) (y ∷ ys) = ∙-comm x y ∷-cong zipWith-comm xs ys

    module _ {ε : A} where
      module _ (∙-id-left : LeftIdentity _≈_ ε _∙_) where
        zipWith-id-left : ∀ {n} → LeftIdentity _≈ᵛ_ (replicate ε) (zipWith {n = n} _∙_)
        zipWith-id-left [] = []-cong
        zipWith-id-left (x ∷ xs) = ∙-id-left x ∷-cong zipWith-id-left xs

      module _ (∙-id-right : RightIdentity _≈_ ε _∙_) where
        zipWith-id-right : ∀ {n} → RightIdentity _≈ᵛ_ (replicate ε) (zipWith {n = n} _∙_)
        zipWith-id-right [] = []-cong
        zipWith-id-right (x ∷ xs) = ∙-id-right x ∷-cong zipWith-id-right xs

      module _ {_⁻¹ : A → A}
               (inverse : LeftInverse _≈_ ε _⁻¹ _∙_) where
        zipWith-left-inverse : ∀ {n} → LeftInverse _≈ᵛ_ (replicate ε) (map _⁻¹) (zipWith {n = n} _∙_)
        zipWith-left-inverse [] = []-cong
        zipWith-left-inverse (x ∷ xs) = inverse x ∷-cong zipWith-left-inverse xs

      module _ {_⁻¹ : A → A}
               (inverse : RightInverse _≈_ ε _⁻¹ _∙_) where
        zipWith-right-inverse : ∀ {n} → RightInverse _≈ᵛ_ (replicate ε) (map _⁻¹) (zipWith {n = n} _∙_)
        zipWith-right-inverse [] = []-cong
        zipWith-right-inverse (x ∷ xs) = inverse x ∷-cong zipWith-right-inverse xs

module WithSetoid {c ℓ} (S : Setoid c ℓ) where
  A = Setoid.Carrier S
  open Setoid S
  V = Vec A
  module V≈ = Data.Vec.Equality.Equality S
  open Algebra.FunctionProperties
  open V≈ hiding (_≈_)
  _≈ᵛ_ : ∀ {n} → V n → V n → Type _
  xs ≈ᵛ ys = V≈._≈_ xs ys

  open With≈ _≈_ {_≈ᵛ_} []-cong (λ x y → x ∷-cong y) public

  module _ {f : A → A} (f-cong : f Preserves _≈_ ⟶ _≈_) where
    map-cong : ∀ {n} → map {n = n} f Preserves _≈ᵛ_ ⟶ _≈ᵛ_
    map-cong []-cong = []-cong
    map-cong (x≈y ∷-cong xs≈ys) = f-cong x≈y ∷-cong map-cong xs≈ys

  module _ {f : A → A → A} (f-cong : f Preserves₂ _≈_ ⟶ _≈_ ⟶ _≈_) where
    zipWith-cong : ∀ {n} → zipWith {n = n} f Preserves₂ _≈ᵛ_ ⟶ _≈ᵛ_ ⟶ _≈ᵛ_
    zipWith-cong []-cong []-cong = []-cong
    zipWith-cong (x≈y ∷-cong xs≈ys) (z≈t ∷-cong zs≈ts) = f-cong x≈y z≈t ∷-cong zipWith-cong xs≈ys zs≈ts

∷= : ∀ {a}{A : Type a}{n x} {xs : Vec A n} {y} {ys : Vec A n}
       (p : x ≡ y) (q : xs ≡ ys) →
        x ∷ xs ≡ y ∷ ys
∷= idp idp = idp

module With≡ {a}{A : Type a} where
  open With≈ (_≡_ {A = A}) {_≡_} idp (λ x¹≈x² xs¹≈xs² → ∷= x¹≈x² xs¹≈xs²) public

module LiftSemigroup {c ℓ} (Sg : Semigroup c ℓ) where
    module Sg = Semigroup Sg
    open WithSetoid Sg.setoid public

    _∙ᵛ_ : ∀ {n} → V n → V n → V n
    _∙ᵛ_ = zipWith Sg._∙_

    -- this should be in Data.Vec.Equality
    isEquivalence : ∀ {n} → IsEquivalence (_≈ᵛ_ {n})
    isEquivalence = record { refl = λ {xs} → V≈.refl xs
                           ; sym = V≈.sym ; trans = V≈.trans }

    isSemigroup : ∀ {n} → IsSemigroup (_≈ᵛ_ {n}) _∙ᵛ_
    isSemigroup = record { isEquivalence = isEquivalence
                                       ; assoc = zipWith-assoc Sg.assoc
                                       ; ∙-cong = zipWith-cong Sg.∙-cong }

    semigroup : ∀ n → Semigroup c (ℓ L.⊔ c)
    semigroup n = record { isSemigroup = isSemigroup {n} }

module LiftMonoid {c ℓ} (M : Monoid c ℓ) where
    module M = Monoid M
    open LiftSemigroup M.semigroup public

    εᵛ : ∀ {n} → V n
    εᵛ = replicate M.ε

    isMonoid : ∀ {n} → IsMonoid (_≈ᵛ_ {n}) _∙ᵛ_ εᵛ
    isMonoid = record { isSemigroup = isSemigroup
                      ; identity = zipWith-id-left (fst M.identity)
                                 , zipWith-id-right (snd M.identity) }

    monoid : ℕ → Monoid c (ℓ L.⊔ c)
    monoid n = record { isMonoid = isMonoid {n} }

module LiftCommutativeMonoid {c ℓ} (CM : CommutativeMonoid c ℓ) where
    module CM = CommutativeMonoid CM
    open LiftMonoid CM.monoid public

    isCommutativeMonoid : ∀ {n} → IsCommutativeMonoid (_≈ᵛ_ {n}) _∙ᵛ_ εᵛ
    isCommutativeMonoid =
       record { isSemigroup = isSemigroup
                  ; identityˡ = zipWith-id-left  CM.identityˡ
                  ; comm = zipWith-comm CM.comm }

    commutative-monoid : ℕ → CommutativeMonoid c (ℓ L.⊔ c)
    commutative-monoid n = record { isCommutativeMonoid = isCommutativeMonoid {n} }

module LiftGroup {c ℓ} (G : Group c ℓ) where
    module G = Group G
    open LiftMonoid G.monoid public

    _⁻¹ᵛ : ∀ {n} → V n → V n
    _⁻¹ᵛ = map G._⁻¹

    isGroup : ∀ {n} → IsGroup (_≈ᵛ_ {n}) _∙ᵛ_ εᵛ _⁻¹ᵛ
    isGroup = record { isMonoid = isMonoid
                                ; inverse = (zipWith-left-inverse (fst G.inverse))
                                                , (zipWith-right-inverse (snd G.inverse))
                                ; ⁻¹-cong = map-cong G.⁻¹-cong }

    group : ℕ → Group c _
    group n = record { isGroup = isGroup {n} }

module LiftAbelianGroup {c ℓ} (AG : AbelianGroup c ℓ) where
    module AG = AbelianGroup AG
    open LiftGroup AG.group public

    isAbelianGroup : ∀ {n} → IsAbelianGroup (_≈ᵛ_ {n}) _∙ᵛ_ εᵛ _⁻¹ᵛ
    isAbelianGroup = record { isGroup = isGroup ; comm = zipWith-comm AG.comm }

    abelianGroup : ℕ → AbelianGroup c _
    abelianGroup n = record { isAbelianGroup = isAbelianGroup {n} }

open Algebra.FunctionProperties.Eq.Implicits

-- Trying to get rid of the foldl in the definition of reverse and
-- without using equations on natural numbers.
-- In the end that's not very convincing.
module Alternative-Reverse where
    rev-+ : ℕ → ℕ → ℕ
    rev-+ zero    = id
    rev-+ (suc x) = rev-+ x ∘ suc

    rev-app : ∀ {a} {A : Type a} {m n} →
              Vec A n → Vec A m → Vec A (rev-+ n m)
    rev-app []       = id
    rev-app (x ∷ xs) = rev-app xs ∘ _∷_ x

    rev-aux : ∀ {a} {A : Type a} {m} n →
              Vec A (rev-+ n zero) →
              (∀ {m} → A → Vec A (rev-+ n m) → Vec A (rev-+ n (suc m))) →
              Vec A m → Vec A (rev-+ n m)
    rev-aux m acc op []       = acc
    rev-aux m acc op (x ∷ xs) = rev-aux (suc m) (op x acc) op xs

    alt-reverse : ∀ {a n} {A : Type a} → Vec A n → Vec A n
    alt-reverse = rev-aux 0 [] _∷_

countᶠ : ∀ {n a} {A : Type a} → (A → Bool) → Vec A n → Fin (suc n)
countᶠ pred = foldr (Fin ∘ suc) (λ x → if pred x then suc else inject₁) zero

count : ∀ {n a} {A : Type a} → (A → Bool) → Vec A n → ℕ
count pred = toℕ ∘ countᶠ pred

RewireTbl : (i o : ℕ) → ★₀
RewireTbl i o = Vec (Fin i) o

sum-∷ʳ : ∀ {n} x (xs : Vec ℕ n) → sum (xs ∷ʳ x) ≡ sum xs + x
sum-∷ʳ x []        = ℕ°.+-comm x 0
sum-∷ʳ x (x₁ ∷ xs) = ap (_+_ x₁) (sum-∷ʳ x xs) ∙ !(ℕ°.+-assoc x₁ (sum xs) x)

sum-distribˡ : ∀ {A : ★₀} {n} f k (xs : Vec A n) → sum (map (λ x → k * f x) xs) ≡ k * sum (map f xs)
sum-distribˡ f k [] = ℕ°.*-comm 0 k
sum-distribˡ f k (x ∷ xs) rewrite sum-distribˡ f k xs = !(fst ℕ°.distrib k _ _)

sum-linear : ∀ {A : ★₀} {n} f g (xs : Vec A n) → sum (map (λ x → f x + g x) xs) ≡ sum (map f xs) + sum (map g xs)
sum-linear f g [] = idp
sum-linear f g (x ∷ xs) rewrite sum-linear f g xs = +-interchange (f x) (g x) (sum (map f xs)) (sum (map g xs))

sum-mono : ∀ {A : ★₀} {n f g} (mono : ∀ x → f x ≤ g x)(xs : Vec A n) → sum (map f xs) ≤ sum (map g xs)
sum-mono f≤°g [] = Data.Nat.NP.z≤n
sum-mono f≤°g (x ∷ xs) = f≤°g x +-mono sum-mono f≤°g xs

module _ {a} {A : Type a} where
  -- Exchange elements at positions 0 and 1 of a given vector
  -- (this only apply if the vector is long enough).
  0↔1 : ∀ {n} → Vec A n → Vec A n
  0↔1 (x₀ ∷ x₁ ∷ xs) = x₁ ∷ x₀ ∷ xs
  0↔1 xs = xs

module _ {a} {A : Type a} where
  count-++ : ∀ {m n} (pred : A → Bool) (xs : Vec A m) (ys : Vec A n)
              → count pred (xs ++ ys) ≡ count pred xs + count pred ys
  count-++ pred [] ys = idp
  count-++ pred (x ∷ xs) ys with pred x
  ... | 1b rewrite count-++ pred xs ys = idp
  ... | 0b rewrite F.inject₁-lemma (countᶠ pred (xs ++ ys))
                    | F.inject₁-lemma (countᶠ pred xs) | count-++ pred xs ys = idp

  ext-countᶠ : ∀ {n} {f g : A → Bool} → f ≗ g → (xs : Vec A n) → countᶠ f xs ≡ countᶠ g xs
  ext-countᶠ f≗g [] = idp
  ext-countᶠ f≗g (x ∷ xs) rewrite ext-countᶠ f≗g xs | f≗g x = idp

  filter : ∀ {n} (pred : A → Bool) (xs : Vec A n) → Vec A (count pred xs)
  filter pred [] = []
  filter pred (x ∷ xs) with pred x
  ... | 1b = x ∷ filter pred xs
  ... | 0b rewrite F.inject₁-lemma (countᶠ pred xs) = filter pred xs

  transpose : ∀ {m n} → Vec (Vec A m) n → Vec (Vec A n) m
  transpose [] = replicate []
  transpose (xs ∷ xss) = zipWith _∷_ xs (transpose xss)

  vap : ∀ {m b} {B : Type b} (f : Vec A m → B)
          → ∀ {n} → Vec (Vec A n) m → Vec B n
  vap f = map f ∘ transpose

  infixl 2 _‼_
  _‼_ : ∀ {n} → Vec A n → Fin n → A
  _‼_ = flip lookup

  η : ∀ {n} → Vec A n → Vec A n
  η = tabulate ∘ _‼_

  η′ : ∀ {n} → Vec A n → Vec A n
  η′ {zero}  = λ _ → []
  η′ {suc n} = λ xs → head xs ∷ η (tail xs)

  shallow-η : ∀ {n} (xs : Vec A (1 + n)) → xs ≡ head xs ∷ tail xs
  shallow-η (x ∷ xs) = idp

  uncons : ∀ {n} → Vec A (1 + n) → (A × Vec A n)
  uncons (x ∷ xs) = x , xs

  ∷-uncons : ∀ {n} (xs : Vec A (1 + n)) → uncurry _∷_ (uncons xs) ≡ xs
  ∷-uncons (x ∷ xs) = idp

  splitAt′ : ∀ m {n} → Vec A (m + n) → Vec A m × Vec A n
  splitAt′ m xs = case splitAt m xs of λ { (ys , zs , _) → (ys , zs) }

  group : ∀ n k → Vec A (n * k) → Vec (Vec A k) n
  group zero    k v = []
  group (suc n) k v = take k v ∷ group n k (drop k v)

  map2* : ∀ m n (f : Vec A m → Vec A n) → Vec A (2* m) → Vec A (2* n)
  map2* m _ f xs = f (take m xs) ++ f (drop m xs)

  map* : ∀ k {m n}(f : Vec A m → Vec A n) → Vec A (k * m) → Vec A (k * n)
  map* k f xs = concat (map f (group k _ xs))

  take2* : ∀ n → Bit → Vec A (2* n) → Vec A n
  take2* n 0b v = take n v
  take2* n 1b v = drop n v

  ++-decomp : ∀ {m n} {xs zs : Vec A m} {ys ts : Vec A n}
             → (xs ++ ys) ≡ (zs ++ ts) → (xs ≡ zs × ys ≡ ts)
  ++-decomp {zero} {xs = []} {[]} p = idp , p
  ++-decomp {suc m} {xs = x ∷ xs} {z ∷ zs} eq with ++-decomp {m} {xs = xs} {zs} (ap tail eq)
  ... | (q₁ , q₂) = (ap-∷ (ap head eq) q₁) , q₂

  ++-inj₁ : ∀ {m n} {xs ys : Vec A m} {zs ts : Vec A n} → xs ++ zs ≡ ys ++ ts → xs ≡ ys
  ++-inj₁ eq = fst (++-decomp eq)

  ++-inj₂ : ∀ {m n} (xs ys : Vec A m) {zs ts : Vec A n} → xs ++ zs ≡ ys ++ ts → zs ≡ ts
  ++-inj₂ xs ys eq = snd (++-decomp {xs = xs} {zs = ys} eq)

  take-∷ : ∀ {m} n x (xs : Vec A (n + m)) → take (suc n) (x ∷ xs) ≡ x ∷ take n xs
  take-∷ n x xs with splitAt n xs
  take-∷ _ _ ._ | _ , _ , idp = idp

  drop-∷ : ∀ {m} n x (xs : Vec A (n + m)) → drop (suc n) (x ∷ xs) ≡ drop n xs
  drop-∷ n x xs with splitAt n xs
  drop-∷ _ _ ._ | _ , _ , idp = idp

  take-++ : ∀ m {n} (xs : Vec A m) (ys : Vec A n) → take m (xs ++ ys) ≡ xs
  take-++ m xs ys with xs ++ ys | ≡.inspect (_++_ xs) ys
  ... | zs | eq with splitAt m zs
  take-++ m xs₁ ys₁ | .(xs ++ ys) | ≡.[ eq ] | xs , ys , idp = !(++-inj₁ eq)

  drop-++ : ∀ m {n} (xs : Vec A m) (ys : Vec A n) → drop m (xs ++ ys) ≡ ys
  drop-++ m xs ys with xs ++ ys | ≡.inspect (_++_ xs) ys
  ... | zs | eq with splitAt m zs
  drop-++ m xs₁ ys₁ | .(xs ++ ys) | ≡.[ eq ] | xs , ys , idp = !(++-inj₂ xs₁ xs eq)

  take-drop-lem : ∀ m {n} (xs : Vec A (m + n)) → take m xs ++ drop m xs ≡ xs
  take-drop-lem m xs with splitAt m xs
  take-drop-lem m .(ys ++ zs) | ys , zs , idp = idp

  take-them-all : ∀ n (xs : Vec A (n + 0)) → take n xs ++ [] ≡ xs
  take-them-all n xs with splitAt n xs
  take-them-all n .(ys ++ []) | ys , [] , ≡.refl = ≡.refl

  drop′ : ∀ m {n} → Vec A (m + n) → Vec A n
  drop′ zero    = id
  drop′ (suc m) = drop′ m ∘ tail

  drop′-spec : ∀ m {n} → drop′ m {n} ≗ drop m {n}
  drop′-spec zero    _        = idp
  drop′-spec (suc m) (x ∷ xs) = drop′-spec m xs ∙ !(drop-∷ m x xs)

  take′ : ∀ m {n} → Vec A (m + n) → Vec A m
  take′ zero    _  = []
  take′ (suc m) xs = head xs ∷ take′ m (tail xs)

  take′-spec : ∀ m {n} → take′ m {n} ≗ take m {n}
  take′-spec zero    xs       = idp
  take′-spec (suc m) (x ∷ xs) = ap (_∷_ x) (take′-spec m xs) ∙ !(take-∷ m x xs)

  swap : ∀ m {n} → Vec A (m + n) → Vec A (n + m)
  swap m xs = drop m xs ++ take m xs

  swap-++ : ∀ m {n} (xs : Vec A m) (ys : Vec A n) → swap m (xs ++ ys) ≡ ys ++ xs
  swap-++ m xs ys = ap₂ _++_ (drop-++ m xs ys) (take-++ m xs ys)

  rewire : ∀ {i o} → (Fin o → Fin i) → Vec A i → Vec A o
  rewire f v = tabulate (_‼_ v ∘ f)

  take-drop= : ∀ m {n} (xs ys : Vec A (m + n))
                 → take m xs ≡ take m ys
                 → drop m xs ≡ drop m ys
                 → xs ≡ ys
  take-drop= m xs ys take= drop= =
    ! take-drop-lem m xs ∙ ap₂ _++_ take= drop= ∙ take-drop-lem m ys

  rewireTbl : ∀ {i o} → RewireTbl i o → Vec A i → Vec A o
  rewireTbl tbl v = map (_‼_ v) tbl

  onᵢ : ∀ (f : A → A) {n} (i : Fin n) → Vec A n → Vec A n
  onᵢ f zero    (x ∷ xs) = f x ∷ xs
  onᵢ f (suc i) (x ∷ xs) = x ∷ onᵢ f i xs

  ⊛-dist-0↔1 : ∀ {n}(fs : Vec (Endo A) n) xs → 0↔1 fs ⊛ 0↔1 xs ≡ 0↔1 (fs ⊛ xs)
  ⊛-dist-0↔1 _           []          = idp
  ⊛-dist-0↔1 (_ ∷ [])    (_ ∷ [])    = idp
  ⊛-dist-0↔1 (_ ∷ _ ∷ _) (_ ∷ _ ∷ _) = idp

  map-tail : ∀ {m n} → (Vec A m → Vec A n) → Vec A (suc m) → Vec A (suc n)
  map-tail f (x ∷ xs) = x ∷ f xs

  map-tail-id : ∀ {n} → map-tail id ≗ id {A = Vec A (suc n)}
  map-tail-id (x ∷ xs) = idp

  map-tail∘map-tail : ∀ {m n o}
                        (f : Vec A o → Vec A m)
                        (g : Vec A n → Vec A o)
                      → map-tail f ∘ map-tail g ≗ map-tail (f ∘ g)
  map-tail∘map-tail f g (x ∷ xs) = idp

  map-tail-≗ : ∀ {m n}(f g : Vec A m → Vec A n) → f ≗ g → map-tail f ≗ map-tail g
  map-tail-≗ f g f≗g (x ∷ xs) = ap (_∷_ x) (f≗g xs)

  dup : ∀ {n} → Vec A n → Vec A (n + n)
  dup xs = xs ++ xs

  dup-inj : ∀ {n} → Injective (dup {n})
  dup-inj = ++-inj₁

  rot₁ : ∀ {n} → Vec A n → Vec A n
  rot₁ []       = []
  rot₁ (x ∷ xs) = xs ∷ʳ x

  rot : ∀ {n} → ℕ → Vec A n → Vec A n
  rot zero    xs = xs
  rot (suc n) xs = rot n (rot₁ xs)

  map-∷ʳ : ∀ {n}(f : A → ℕ) x (xs : Vec A n) → map f (xs ∷ʳ x) ≡ map f xs ∷ʳ f x
  map-∷ʳ f x []       = idp
  map-∷ʳ f x (_ ∷ xs) = ap (_∷_ _) (map-∷ʳ f x xs)

  sum-map-rot₁ : ∀ {n}(f : A → ℕ) (xs : Vec A n) → sum (map f (rot₁ xs)) ≡ sum (map f xs)
  sum-map-rot₁ f [] = idp
  sum-map-rot₁ f (x ∷ xs) = ap sum (map-∷ʳ f x xs)
                          ∙ sum-∷ʳ (f x) (map f xs)
                          ∙ ℕ°.+-comm (sum (map f xs)) (f x)

  vec= : ∀ {n}{xs ys : Vec A n} → (∀ i → (xs ‼ i) ≡ (ys ‼ i)) → xs ≡ ys
  vec= {xs = []}     {[]}     f= = idp
  vec= {xs = x ∷ xs} {y ∷ ys} f= = ap-∷ (f= zero) (vec= (f= ∘ suc))

  concat-group : ∀ m n (xs : Vec A (m * n)) → concat (group m n xs) ≡ xs
  concat-group zero    n [] = idp
  concat-group (suc m) n xs rewrite concat-group m n (drop n xs) = take-drop-lem n xs

  group-concat : ∀ {m n}(xss : Vec (Vec A n) m) → group m n (concat xss) ≡ xss
  group-concat [] = idp
  group-concat (xs ∷ xss)
    rewrite take-++ _ xs (concat xss)
          | drop-++ _ xs (concat xss)
          | group-concat xss
          = idp

  -- These are also in the stdlib as Data.Vec.Properties.lookup-morphism
  ‼-replicate : ∀ {n}(i : Fin n)(x : A) → (replicate x ‼ i) ≡ x
  ‼-replicate zero    = λ _ → idp
  ‼-replicate (suc i) = ‼-replicate i

module _ {a b}{A : Type a}{B : Type b} where
  ‼-⊛= : ∀ {n} i {fs : Vec (A → B) n}{xs : Vec A n}{f x}
           (fs= : (fs ‼ i) ≡ f)
           (xs= : (xs ‼ i) ≡ x)
         → (fs ⊛ xs ‼ i) ≡ f x
  ‼-⊛= zero    {f ∷ fs} {x ∷ xs} f= xs= = ap₂ _$_ f= xs=
  ‼-⊛= (suc i) {f ∷ fs} {x ∷ xs} f= xs= = ‼-⊛= i f= xs=

  ‼-⊛ : ∀ {n} i (fs : Vec (A → B) n) (xs : Vec A n) →
          (fs ⊛ xs ‼ i) ≡ (fs ‼ i) (xs ‼ i)
  ‼-⊛ i fs xs = ‼-⊛= i idp idp

  ‼-map= : ∀ {n} i (f : A → B) {xs : Vec A n}{x : A}
             (xs= : (xs ‼ i) ≡ x)
           → (map f xs ‼ i) ≡ f x
  ‼-map= i f = ‼-⊛= i (‼-replicate i f)

  ‼-map : ∀ {n} i (f : A → B) (xs : Vec A n) →
            (map f xs ‼ i) ≡ f (xs ‼ i)
  ‼-map i f xs = ‼-map= i f idp

  vuncurry : ∀ {n}(f : A → Vec A n → B) → Vec A (1 + n) → B
  vuncurry f (x ∷ xs) = f x xs

  count-∘ : ∀ {n}(f : A → B)(pred : B → Bool) →
              count {n} (pred ∘ f) ≗ count pred ∘ map f
  count-∘ f pred [] = idp
  count-∘ f pred (x ∷ xs) with pred (f x)
  ... | 1b rewrite count-∘ f pred xs = idp
  ... | 0b rewrite F.inject₁-lemma (countᶠ pred (map f xs))
                 | F.inject₁-lemma (countᶠ (pred ∘ f) xs)
                 | count-∘ f pred xs = idp

sum-rot₁ : ∀ {n} (xs : Vec ℕ n) → sum xs ≡ sum (rot₁ xs)
sum-rot₁ []       = idp
sum-rot₁ (x ∷ xs) = ℕ°.+-comm x (sum xs) ∙ !(sum-∷ʳ x xs)

open import Data.Vec public hiding (_⊛_; zipWith; zip; map; applicative; group)
-- -}
-- -}
-- -}
-- -}


Removed FOTC dependency in issue #8.

Removed FOTC dependency in issue #8.

{-# OPTIONS --no-universe-polymorphism #-}
{-# OPTIONS --without-K #-}

module Issue8 where

postulate D : Set

-- The existential quantifier type on D.
data ∃ (A : D → Set) : Set where
  _,_ : (t : D) → A t → ∃ A

postulate foo : (A : D → Set) → (∃ λ x → A x) → (∃ λ x → A x)
{-# ATP prove foo #-}

{-# OPTIONS --no-universe-polymorphism #-}
{-# OPTIONS --without-K #-}

module Issue8 where

open import Common.FOL.FOL

postulate foo : (A : D → Set) → (∃ λ x → A x) → (∃ λ x → A x)
{-# ATP prove foo #-}


every case except for holes, which require thinking about substitition things to cough up the type and i dont know that my encoding of that is correct yet

open import Nat
open import Prelude
open import List
open import core
open import contexts

module type-assignment-unicity where
  type-assignment-unicity : {Γ : tctx} {d : dhexp} {τ' τ : htyp} {Δ : hctx} →
                              Δ , Γ ⊢ d :: τ →
                              Δ , Γ ⊢ d :: τ' →
                              τ == τ'
  type-assignment-unicity TAConst TAConst = refl
  type-assignment-unicity {Γ = Γ} (TAVar x₁) (TAVar x₂) = ctxunicity {Γ = Γ} x₁ x₂
  type-assignment-unicity (TALam d1) (TALam d2)
    with type-assignment-unicity d1 d2
  ... | refl = refl
  type-assignment-unicity (TAAp d3 MAHole d4) (TAAp d5 MAHole d6) = refl
  type-assignment-unicity (TAAp d3 MAHole d4) (TAAp d5 MAArr d6)
      with type-assignment-unicity d3 d5
  ... | ()
  type-assignment-unicity (TAAp d3 MAArr d4) (TAAp d5 MAHole d6)
    with type-assignment-unicity d3 d5
  ... | ()
  type-assignment-unicity (TAAp d3 MAArr d4) (TAAp d5 MAArr d6)
    with type-assignment-unicity d3 d5 | type-assignment-unicity d4 d6
  ... | refl | refl = refl
  type-assignment-unicity (TAEHole x) d2 = {!!}
  type-assignment-unicity (TANEHole d1 x) d2 = {!!}
  type-assignment-unicity (TACast d1 x) (TACast d2 x₁)
    with type-assignment-unicity d1 d2
  ... | refl = refl

open import Nat
open import Prelude
open import List
open import core

module type-assignment-unicity where
  type-assignment-unicity : (Γ : tctx) (d : dhexp) (τ' τ : htyp) (Δ : hctx) →
                              Δ , Γ ⊢ d :: τ →
                              Δ , Γ ⊢ d :: τ' →
                              τ == τ'
  type-assignment-unicity = {!!}


+-interchange is now with implicit arguments...

{-# OPTIONS --copatterns #-}
open import Algebra

open import Function

open import Data.Nat.NP
open import Data.Nat.Distance
open import Data.Nat.Properties
open import Data.Two
open import Data.Zero
open import Data.Product

open import Relation.Binary
open import Relation.Binary.PropositionalEquality.NP

open import HoTT
open Equivalences

open import Explore.Core
open import Explore.Universe.Type {𝟘}
open import Explore.Universe.Base

module Neglible where

module prop = CommutativeSemiring commutativeSemiring
module OR = Poset (DecTotalOrder.poset decTotalOrder)

≤-*-cancel : ∀ {x m n} → 1 ≤ x →  x * m ≤ x * n → m ≤ n
≤-*-cancel {suc x} {m} {n} (s≤s le) mn
  rewrite prop.*-comm (suc x) m | prop.*-comm (suc x) n = cancel-*-right-≤ _ _ _ mn

record ℕ→ℚ : Set where
  constructor _/_[_]
  field
    εN : (n : ℕ) → ℕ
    εD : (n : ℕ) → ℕ
    εD-pos : ∀ n → εD n > 0

record Is-Neg (ε : ℕ→ℚ) : Set where
  constructor mk
  open ℕ→ℚ ε
  field
    cₙ : (c : ℕ) → ℕ
    prf : ∀(c n : ℕ) → n > cₙ n → n ^ c * εN n ≤ εD n
open Is-Neg

0ℕℚ : ℕ→ℚ
ℕ→ℚ.εN 0ℕℚ _ = 0
ℕ→ℚ.εD 0ℕℚ _ = 1
ℕ→ℚ.εD-pos 0ℕℚ _ = s≤s z≤n

0ℕℚ-neg : Is-Neg 0ℕℚ
cₙ 0ℕℚ-neg _ = 0
prf 0ℕℚ-neg c n x = OR.trans (OR.reflexive (proj₂ prop.zero (n ^ c))) z≤n

_+ℕℚ_ : ℕ→ℚ → ℕ→ℚ → ℕ→ℚ
ℕ→ℚ.εN ((εN / εD [ _ ]) +ℕℚ (μN / μD [ _ ])) n = εN n * μD n + μN n * εD n
ℕ→ℚ.εD ((εN / εD [ _ ]) +ℕℚ (μN / μD [ _ ])) n = εD n * μD n
ℕ→ℚ.εD-pos ((εN / εD [ εD+ ]) +ℕℚ (μN / μD [ μD+ ])) n = εD+ n *-mono μD+ n

+ℕℚ-neg : {ε μ : ℕ→ℚ} → Is-Neg ε → Is-Neg μ → Is-Neg (ε +ℕℚ μ)
cₙ (+ℕℚ-neg ε μ) n = 1 + cₙ ε n + cₙ μ n
prf (+ℕℚ-neg {εM} {μM} ε μ) c n n>nc = ≤-*-cancel {x = n} (OR.trans (s≤s z≤n) n>nc) lemma
  where

  open ≤-Reasoning
  open ℕ→ℚ εM
  open ℕ→ℚ μM renaming (εN to μN; εD to μD; εD-pos to μD-pos)

  lemma =  n * (n ^ c * (εN n * μD n + μN n * εD n))
        ≡⟨ ! prop.*-assoc n (n ^ c) _
         ∙ proj₁ prop.distrib (n ^ (1 + c)) (εN n * μD n) (μN n * εD n)
         ∙ ap₂ _+_ (! prop.*-assoc (n ^ (1 + c)) (εN n) (μD n))
                   (! (prop.*-assoc (n ^ (1 + c)) (μN n) (εD n))) ⟩
           n ^ (1 + c) * εN n * μD n + n ^ (1 + c) * μN n * εD n
        ≤⟨     (prf ε (1 + c) n (OR.trans (s≤s (≤-step (m≤m+n (cₙ ε n) (cₙ μ n)))) n>nc) *-mono (μD n ∎))
        +-mono (prf μ (1 + c) n (OR.trans (s≤s (≤-step (n≤m+n (cₙ ε n) (cₙ μ n)))) n>nc) *-mono (εD n ∎)) ⟩
           εD n * μD n + μD n * εD n
        ≡⟨ ap₂ _+_ (refl {x = εD n * μD n}) (prop.*-comm (μD n) (εD n) ∙ ! proj₂ prop.+-identity (εD n * μD n)) ⟩
           2 * (εD n * μD n)
        ≤⟨ OR.trans (s≤s (s≤s z≤n)) n>nc *-mono (εD n * μD n ∎) ⟩
           n * (εD n * μD n)
        ∎

infix 4 _≤→_
record _≤→_ (f g : ℕ→ℚ) : Set where
  constructor mk
  open ℕ→ℚ f renaming (εN to fN; εD to fD)
  open ℕ→ℚ g renaming (εN to gN; εD to gD)
  field
    -- fN k / fD k ≤ gN k / gD k
    ≤→ : ∀ k → fN k * gD k ≤ gN k * fD k

≤→-trans : ∀ {f g h} → f ≤→ g → g ≤→ h → f ≤→ h
_≤→_.≤→ (≤→-trans {fN / fD [ fD-pos ]} {gN / gD [ gD-pos ]} {hN / hD [ hD-pos ]} (mk fg) (mk gh)) k
  = ≤-*-cancel (gD-pos k) lemma
  where
    open ≤-Reasoning
    lemma : gD k * (fN k * hD k) ≤ gD k * (hN k * fD k)
    lemma = gD k * (fN k * hD k)
          ≡⟨ ! prop.*-assoc (gD k) (fN k) (hD k)
             ∙ ap (flip _*_ (hD k)) (prop.*-comm (gD k) (fN k))
           ⟩
            (fN k * gD k) * hD k
          ≤⟨ fg k *-mono OR.refl ⟩
            (gN k * fD k) * hD k
          ≡⟨ prop.*-assoc (gN k) (fD k) (hD k)
             ∙ ap (_*_ (gN k)) (prop.*-comm (fD k) (hD k))
             ∙ ! prop.*-assoc (gN k) (hD k) (fD k)
           ⟩
            (gN k * hD k) * fD k
          ≤⟨ gh k *-mono OR.refl ⟩
            (hN k * gD k) * fD k
          ≡⟨ ap (flip _*_ (fD k)) (prop.*-comm (hN k) (gD k))
             ∙ prop.*-assoc (gD k) (hN k) (fD k)
           ⟩
            gD k * (hN k * fD k)
          ∎

+ℕℚ-mono : ∀ {f f' g g'} → f ≤→ f' → g ≤→ g' → f +ℕℚ g ≤→ f' +ℕℚ g'
_≤→_.≤→ (+ℕℚ-mono {fN / fD [ _ ]} {f'N / f'D [ _ ]} {gN / gD [ _ ]} {g'N / g'D [ _ ]} (mk ff) (mk gg)) k
  = (fN k * gD k + gN k * fD k) * (f'D k * g'D k)
  ≡⟨ proj₂ prop.distrib (f'D k * g'D k) (fN k * gD k) (gN k * fD k)  ⟩
    fN k * gD k * (f'D k * g'D k) + gN k * fD k * (f'D k * g'D k)
  ≡⟨ ap₂ _+_ (*-interchange {fN k} {gD k} {f'D k} {g'D k} ∙ ap (_*_ (fN k * f'D k)) (prop.*-comm (gD k) (g'D k)))
             (ap (_*_ (gN k * fD k)) (prop.*-comm (f'D k) (g'D k)) ∙ *-interchange {gN k} {fD k} {g'D k} {f'D k})
   ⟩
    fN k * f'D k * (g'D k * gD k) + gN k * g'D k * (fD k * f'D k)
  ≤⟨ (ff k *-mono OR.refl) +-mono (gg k *-mono OR.refl) ⟩
    f'N k * fD k * (g'D k * gD k) + g'N k * gD k * (fD k * f'D k)
  ≡⟨ ap₂ _+_ (*-interchange {f'N k} {fD k} {g'D k} {gD k})
             (ap (_*_ (g'N k * gD k)) (prop.*-comm (fD k) (f'D k))
             ∙ *-interchange {g'N k} {gD k} {f'D k} {fD k}
             ∙ ap (_*_ (g'N k * f'D k)) (prop.*-comm (gD k) (fD k)))
   ⟩
    f'N k * g'D k * (fD k * gD k) + g'N k * f'D k * (fD k * gD k)
  ≡⟨ ! proj₂ prop.distrib (fD k * gD k) (f'N k * g'D k) (g'N k * f'D k) ⟩
    (f'N k * g'D k + g'N k * f'D k) * (fD k * gD k)
  ∎
  where
    open ≤-Reasoning

record NegBounded (f : ℕ→ℚ) : Set where
    constructor mk
    field
      ε : ℕ→ℚ
      ε-neg : Is-Neg ε
      bounded : f ≤→ ε

module _ where
  open NegBounded
  ≤-NB : {f g : ℕ→ℚ} → f ≤→ g → NegBounded g → NegBounded f
  ε (≤-NB le nb) = ε nb
  ε-neg (≤-NB le nb) = ε-neg nb
  bounded (≤-NB le nb) = ≤→-trans le (bounded nb)

  _+NB_ : {f g : ℕ→ℚ} → NegBounded f → NegBounded g → NegBounded (f +ℕℚ g)
  ε (fNB +NB gNB) = ε fNB +ℕℚ ε gNB
  ε-neg (fNB +NB gNB) = +ℕℚ-neg (ε-neg fNB) (ε-neg gNB)
  bounded (fNB +NB gNB) = +ℕℚ-mono (bounded fNB) (bounded gNB)

module ~-NegBounded (Rᵁ : ℕ → U)(let R = λ n → El (Rᵁ n))(inh : ∀ x → 0 < Card (Rᵁ x)) where

  # : ∀ {n} → Count (R n)
  # {n} = count (Rᵁ n)

  ~dist : (f g : (x : ℕ) → R x → 𝟚) → ℕ→ℚ
  ℕ→ℚ.εN (~dist f g) n = dist (# (f n)) (# (g n))
  ℕ→ℚ.εD (~dist f g) n = Card (Rᵁ n)
  ℕ→ℚ.εD-pos (~dist f g) n = inh n

  ~dist-sum : ∀ f g h → ~dist f h ≤→ ~dist f g +ℕℚ ~dist g h
  _≤→_.≤→ (~dist-sum f g h) k
      = #fh * (|R| * |R|)
      ≤⟨ dist-sum #f #g #h *-mono OR.refl ⟩
        (#fg + #gh) * (|R| * |R|)
      ≡⟨ ! prop.*-assoc (#fg + #gh) |R| |R| ∙ ap (flip _*_ |R|) (proj₂ prop.distrib |R| #fg #gh) ⟩
        (#fg * |R| + #gh * |R|) * |R|
      ∎
    where
      open ≤-Reasoning
      |R| = Card (Rᵁ k)
      #f = # (f k)
      #g = # (g k)
      #h = # (h k)
      #fh = dist #f #h
      #fg = dist #f #g
      #gh = dist #g #h

  record _~_ (f g : (x : ℕ) → R x → 𝟚) : Set where
    constructor mk
    field
      ~ : NegBounded (~dist f g)

  ~-trans : Transitive _~_
  _~_.~ (~-trans {f}{g}{h} (mk fg) (mk gh)) = ≤-NB (~dist-sum f g h) (fg +NB gh)

module ~-Inlined (Rᵁ : ℕ → U)(let R = λ n → El (Rᵁ n)) where

  # : ∀ {n} → Count (R n)
  # {n} = count (Rᵁ n)

  record _~_ (f g : (x : ℕ) → R x → 𝟚) : Set where
    constructor mk
    field
      ε : ℕ→ℚ
    open ℕ→ℚ ε
    field
      ε-neg : Is-Neg ε
      bounded : ∀ k → εD k * dist (# (f k)) (# (g k)) ≤ Card (Rᵁ k) * εN k

  ~-trans : Transitive _~_
  _~_.ε (~-trans x x₁) = _
  _~_.ε-neg (~-trans x x₁) = +ℕℚ-neg (_~_.ε-neg x) (_~_.ε-neg x₁)
  _~_.bounded (~-trans {f}{g}{h}(mk ε₀ ε₀-neg fg) (mk ε₁ ε₁-neg gh)) k
      = (b * d) * dist #f #h
      ≤⟨ (b * d ∎) *-mono dist-sum #f #g #h ⟩
        (b * d) * (dist #f #g + dist #g #h)
      ≡⟨ proj₁ prop.distrib (b * d) (dist #f #g) (dist #g #h)
         ∙ ap₂ _+_ (ap₂ _*_ (prop.*-comm b d) refl
         ∙ prop.*-assoc d b (dist #f #g)) (prop.*-assoc b d (dist #g #h))
       ⟩
        d * (b * dist #f #g) + b * (d * dist #g #h)
      ≤⟨ ((d ∎) *-mono fg k) +-mono ((b ∎) *-mono gh k) ⟩
        d * (|R| * a) + b * (|R| * c)
      ≡⟨ ap₂ _+_ (rot d |R| a) (rot b |R| c) ∙ ! proj₁ prop.distrib |R| (a * d) (c * b) ⟩
        |R| * ℕ→ℚ.εN (ε₀ +ℕℚ ε₁) k
      ∎
   where
     open ≤-Reasoning
     rot : ∀ x y z → x * (y * z) ≡ y * (z * x)
     rot x y z = prop.*-comm x (y * z) ∙ prop.*-assoc y z x
     |R| = Card (Rᵁ k)
     #f = # (f k)
     #g = # (g k)
     #h = # (h k)
     a = ℕ→ℚ.εN ε₀ k
     b = ℕ→ℚ.εD ε₀ k
     c = ℕ→ℚ.εN ε₁ k
     d = ℕ→ℚ.εD ε₁ k
-- -}
-- -}
-- -}
-- -}
-- -}
-- -}

{-# OPTIONS --copatterns #-}
open import Algebra

open import Function

open import Data.Nat.NP
open import Data.Nat.Distance
open import Data.Nat.Properties
open import Data.Two
open import Data.Zero
open import Data.Product

open import Relation.Binary
open import Relation.Binary.PropositionalEquality.NP

open import HoTT
open Equivalences

open import Explore.Core
open import Explore.Universe.Type {𝟘}
open import Explore.Universe.Base

module Neglible where

module prop = CommutativeSemiring commutativeSemiring
module OR = Poset (DecTotalOrder.poset decTotalOrder)

≤-*-cancel : ∀ {x m n} → 1 ≤ x →  x * m ≤ x * n → m ≤ n
≤-*-cancel {suc x} {m} {n} (s≤s le) mn
  rewrite prop.*-comm (suc x) m | prop.*-comm (suc x) n = cancel-*-right-≤ _ _ _ mn

record ℕ→ℚ : Set where
  constructor _/_[_]
  field
    εN : (n : ℕ) → ℕ
    εD : (n : ℕ) → ℕ
    εD-pos : ∀ n → εD n > 0

record Is-Neg (ε : ℕ→ℚ) : Set where
  constructor mk
  open ℕ→ℚ ε
  field
    cₙ : (c : ℕ) → ℕ
    prf : ∀(c n : ℕ) → n > cₙ n → n ^ c * εN n ≤ εD n
open Is-Neg

0ℕℚ : ℕ→ℚ
ℕ→ℚ.εN 0ℕℚ _ = 0
ℕ→ℚ.εD 0ℕℚ _ = 1
ℕ→ℚ.εD-pos 0ℕℚ _ = s≤s z≤n

0ℕℚ-neg : Is-Neg 0ℕℚ
cₙ 0ℕℚ-neg _ = 0
prf 0ℕℚ-neg c n x = OR.trans (OR.reflexive (proj₂ prop.zero (n ^ c))) z≤n

_+ℕℚ_ : ℕ→ℚ → ℕ→ℚ → ℕ→ℚ
ℕ→ℚ.εN ((εN / εD [ _ ]) +ℕℚ (μN / μD [ _ ])) n = εN n * μD n + μN n * εD n
ℕ→ℚ.εD ((εN / εD [ _ ]) +ℕℚ (μN / μD [ _ ])) n = εD n * μD n
ℕ→ℚ.εD-pos ((εN / εD [ εD+ ]) +ℕℚ (μN / μD [ μD+ ])) n = εD+ n *-mono μD+ n

+ℕℚ-neg : {ε μ : ℕ→ℚ} → Is-Neg ε → Is-Neg μ → Is-Neg (ε +ℕℚ μ)
cₙ (+ℕℚ-neg ε μ) n = 1 + cₙ ε n + cₙ μ n
prf (+ℕℚ-neg {εM} {μM} ε μ) c n n>nc = ≤-*-cancel {x = n} (OR.trans (s≤s z≤n) n>nc) lemma
  where

  open ≤-Reasoning
  open ℕ→ℚ εM
  open ℕ→ℚ μM renaming (εN to μN; εD to μD; εD-pos to μD-pos)

  lemma =  n * (n ^ c * (εN n * μD n + μN n * εD n))
        ≡⟨ ! prop.*-assoc n (n ^ c) _
         ∙ proj₁ prop.distrib (n ^ (1 + c)) (εN n * μD n) (μN n * εD n)
         ∙ ap₂ _+_ (! prop.*-assoc (n ^ (1 + c)) (εN n) (μD n))
                   (! (prop.*-assoc (n ^ (1 + c)) (μN n) (εD n))) ⟩
           n ^ (1 + c) * εN n * μD n + n ^ (1 + c) * μN n * εD n
        ≤⟨     (prf ε (1 + c) n (OR.trans (s≤s (≤-step (m≤m+n (cₙ ε n) (cₙ μ n)))) n>nc) *-mono (μD n ∎))
        +-mono (prf μ (1 + c) n (OR.trans (s≤s (≤-step (n≤m+n (cₙ ε n) (cₙ μ n)))) n>nc) *-mono (εD n ∎)) ⟩
           εD n * μD n + μD n * εD n
        ≡⟨ ap₂ _+_ (refl {x = εD n * μD n}) (prop.*-comm (μD n) (εD n) ∙ ! proj₂ prop.+-identity (εD n * μD n)) ⟩
           2 * (εD n * μD n)
        ≤⟨ OR.trans (s≤s (s≤s z≤n)) n>nc *-mono (εD n * μD n ∎) ⟩
           n * (εD n * μD n)
        ∎

infix 4 _≤→_
record _≤→_ (f g : ℕ→ℚ) : Set where
  constructor mk
  open ℕ→ℚ f renaming (εN to fN; εD to fD)
  open ℕ→ℚ g renaming (εN to gN; εD to gD)
  field
    -- fN k / fD k ≤ gN k / gD k
    ≤→ : ∀ k → fN k * gD k ≤ gN k * fD k

≤→-trans : ∀ {f g h} → f ≤→ g → g ≤→ h → f ≤→ h
_≤→_.≤→ (≤→-trans {fN / fD [ fD-pos ]} {gN / gD [ gD-pos ]} {hN / hD [ hD-pos ]} (mk fg) (mk gh)) k
  = ≤-*-cancel (gD-pos k) lemma
  where
    open ≤-Reasoning
    lemma : gD k * (fN k * hD k) ≤ gD k * (hN k * fD k)
    lemma = gD k * (fN k * hD k)
          ≡⟨ ! prop.*-assoc (gD k) (fN k) (hD k)
             ∙ ap (flip _*_ (hD k)) (prop.*-comm (gD k) (fN k))
           ⟩
            (fN k * gD k) * hD k
          ≤⟨ fg k *-mono OR.refl ⟩
            (gN k * fD k) * hD k
          ≡⟨ prop.*-assoc (gN k) (fD k) (hD k)
             ∙ ap (_*_ (gN k)) (prop.*-comm (fD k) (hD k))
             ∙ ! prop.*-assoc (gN k) (hD k) (fD k)
           ⟩
            (gN k * hD k) * fD k
          ≤⟨ gh k *-mono OR.refl ⟩
            (hN k * gD k) * fD k
          ≡⟨ ap (flip _*_ (fD k)) (prop.*-comm (hN k) (gD k))
             ∙ prop.*-assoc (gD k) (hN k) (fD k)
           ⟩
            gD k * (hN k * fD k)
          ∎

+ℕℚ-mono : ∀ {f f' g g'} → f ≤→ f' → g ≤→ g' → f +ℕℚ g ≤→ f' +ℕℚ g'
_≤→_.≤→ (+ℕℚ-mono {fN / fD [ _ ]} {f'N / f'D [ _ ]} {gN / gD [ _ ]} {g'N / g'D [ _ ]} (mk ff) (mk gg)) k
  = (fN k * gD k + gN k * fD k) * (f'D k * g'D k)
  ≡⟨ proj₂ prop.distrib (f'D k * g'D k) (fN k * gD k) (gN k * fD k)  ⟩
    fN k * gD k * (f'D k * g'D k) + gN k * fD k * (f'D k * g'D k)
  ≡⟨ ap₂ _+_ (*-interchange (fN k) (gD k) (f'D k) (g'D k) ∙ ap (_*_ (fN k * f'D k)) (prop.*-comm (gD k) (g'D k)))
             (ap (_*_ (gN k * fD k)) (prop.*-comm (f'D k) (g'D k)) ∙ *-interchange (gN k) (fD k) (g'D k) (f'D k))
   ⟩
    fN k * f'D k * (g'D k * gD k) + gN k * g'D k * (fD k * f'D k)
  ≤⟨ (ff k *-mono OR.refl) +-mono (gg k *-mono OR.refl) ⟩
    f'N k * fD k * (g'D k * gD k) + g'N k * gD k * (fD k * f'D k)
  ≡⟨ ap₂ _+_ (*-interchange (f'N k) (fD k) (g'D k) (gD k))
             (ap (_*_ (g'N k * gD k)) (prop.*-comm (fD k) (f'D k))
             ∙ *-interchange (g'N k) (gD k) (f'D k) (fD k)
             ∙ ap (_*_ (g'N k * f'D k)) (prop.*-comm (gD k) (fD k)))
   ⟩
    f'N k * g'D k * (fD k * gD k) + g'N k * f'D k * (fD k * gD k)
  ≡⟨ ! proj₂ prop.distrib (fD k * gD k) (f'N k * g'D k) (g'N k * f'D k) ⟩
    (f'N k * g'D k + g'N k * f'D k) * (fD k * gD k)
  ∎
  where
    open ≤-Reasoning

record NegBounded (f : ℕ→ℚ) : Set where
    constructor mk
    field
      ε : ℕ→ℚ
      ε-neg : Is-Neg ε
      bounded : f ≤→ ε

module _ where
  open NegBounded
  ≤-NB : {f g : ℕ→ℚ} → f ≤→ g → NegBounded g → NegBounded f
  ε (≤-NB le nb) = ε nb
  ε-neg (≤-NB le nb) = ε-neg nb
  bounded (≤-NB le nb) = ≤→-trans le (bounded nb)

  _+NB_ : {f g : ℕ→ℚ} → NegBounded f → NegBounded g → NegBounded (f +ℕℚ g)
  ε (fNB +NB gNB) = ε fNB +ℕℚ ε gNB
  ε-neg (fNB +NB gNB) = +ℕℚ-neg (ε-neg fNB) (ε-neg gNB)
  bounded (fNB +NB gNB) = +ℕℚ-mono (bounded fNB) (bounded gNB)

module ~-NegBounded (Rᵁ : ℕ → U)(let R = λ n → El (Rᵁ n))(inh : ∀ x → 0 < Card (Rᵁ x)) where

  # : ∀ {n} → Count (R n)
  # {n} = count (Rᵁ n)

  ~dist : (f g : (x : ℕ) → R x → 𝟚) → ℕ→ℚ
  ℕ→ℚ.εN (~dist f g) n = dist (# (f n)) (# (g n))
  ℕ→ℚ.εD (~dist f g) n = Card (Rᵁ n)
  ℕ→ℚ.εD-pos (~dist f g) n = inh n

  ~dist-sum : ∀ f g h → ~dist f h ≤→ ~dist f g +ℕℚ ~dist g h
  _≤→_.≤→ (~dist-sum f g h) k
      = #fh * (|R| * |R|)
      ≤⟨ dist-sum #f #g #h *-mono OR.refl ⟩
        (#fg + #gh) * (|R| * |R|)
      ≡⟨ ! prop.*-assoc (#fg + #gh) |R| |R| ∙ ap (flip _*_ |R|) (proj₂ prop.distrib |R| #fg #gh) ⟩
        (#fg * |R| + #gh * |R|) * |R|
      ∎
    where
      open ≤-Reasoning
      |R| = Card (Rᵁ k)
      #f = # (f k)
      #g = # (g k)
      #h = # (h k)
      #fh = dist #f #h
      #fg = dist #f #g
      #gh = dist #g #h

  record _~_ (f g : (x : ℕ) → R x → 𝟚) : Set where
    constructor mk
    field
      ~ : NegBounded (~dist f g)

  ~-trans : Transitive _~_
  _~_.~ (~-trans {f}{g}{h} (mk fg) (mk gh)) = ≤-NB (~dist-sum f g h) (fg +NB gh)

module ~-Inlined (Rᵁ : ℕ → U)(let R = λ n → El (Rᵁ n)) where

  # : ∀ {n} → Count (R n)
  # {n} = count (Rᵁ n)

  record _~_ (f g : (x : ℕ) → R x → 𝟚) : Set where
    constructor mk
    field
      ε : ℕ→ℚ
    open ℕ→ℚ ε
    field
      ε-neg : Is-Neg ε
      bounded : ∀ k → εD k * dist (# (f k)) (# (g k)) ≤ Card (Rᵁ k) * εN k

  ~-trans : Transitive _~_
  _~_.ε (~-trans x x₁) = _
  _~_.ε-neg (~-trans x x₁) = +ℕℚ-neg (_~_.ε-neg x) (_~_.ε-neg x₁)
  _~_.bounded (~-trans {f}{g}{h}(mk ε₀ ε₀-neg fg) (mk ε₁ ε₁-neg gh)) k
      = (b * d) * dist #f #h
      ≤⟨ (b * d ∎) *-mono dist-sum #f #g #h ⟩
        (b * d) * (dist #f #g + dist #g #h)
      ≡⟨ proj₁ prop.distrib (b * d) (dist #f #g) (dist #g #h)
         ∙ ap₂ _+_ (ap₂ _*_ (prop.*-comm b d) refl
         ∙ prop.*-assoc d b (dist #f #g)) (prop.*-assoc b d (dist #g #h))
       ⟩
        d * (b * dist #f #g) + b * (d * dist #g #h)
      ≤⟨ ((d ∎) *-mono fg k) +-mono ((b ∎) *-mono gh k) ⟩
        d * (|R| * a) + b * (|R| * c)
      ≡⟨ ap₂ _+_ (rot d |R| a) (rot b |R| c) ∙ ! proj₁ prop.distrib |R| (a * d) (c * b) ⟩
        |R| * ℕ→ℚ.εN (ε₀ +ℕℚ ε₁) k
      ∎
   where
     open ≤-Reasoning
     rot : ∀ x y z → x * (y * z) ≡ y * (z * x)
     rot x y z = prop.*-comm x (y * z) ∙ prop.*-assoc y z x
     |R| = Card (Rᵁ k)
     #f = # (f k)
     #g = # (g k)
     #h = # (h k)
     a = ℕ→ℚ.εN ε₀ k
     b = ℕ→ℚ.εD ε₀ k
     c = ℕ→ℚ.εN ε₁ k
     d = ℕ→ℚ.εD ε₁ k
-- -}
-- -}
-- -}
-- -}
-- -}
-- -}


#3 scraps

#3 scraps

open import Nat
open import Prelude
open import List
open import core
open import contexts
open import lemmas-consistency

open import canonical-boxed-forms
open import canonical-indeterminate-forms

module progress where
  -- this is a little bit of syntactic sugar to avoid many layer nested Inl
  -- and Inrs that you would get from the more literal transcription of the
  -- consequent of progress as:
  --
  -- d boxedval + d indet + d casterr[ Δ ] + Σ[ d' ∈ dhexp ] (d ↦ d')
  data ok : (d : dhexp) (Δ : hctx) → Set where
    S : ∀{d Δ} → Σ[ d' ∈ dhexp ] (d ↦ d') → ok d Δ
    E : ∀{d Δ} → d casterr → ok d Δ
    I : ∀{d Δ} → d indet → ok d Δ
    V : ∀{d Δ} → d boxedval → ok d Δ

  progress : {Δ : hctx} {d : dhexp} {τ : htyp} →
             Δ , ∅ ⊢ d :: τ →
             ok d Δ
    -- constants
  progress TAConst = V (BVVal VConst)

    -- variables
  progress (TAVar x₁) = abort (somenotnone (! x₁))

    -- lambdas
  progress (TALam wt) = V (BVVal VLam)

    -- applications
  progress (TAAp wt1 wt2)
    with progress wt1 | progress wt2
    -- if the left steps, the whole thing steps
  progress (TAAp wt1 wt2) | S (_ , Step x y z) | _ = S (_ , Step (FHAp1 x) y (FHAp1 z))
    -- if the left is an error, the whole thing is an error
  progress (TAAp wt1 wt2) | E x | _ = E (CECong (FHAp1 FHOuter) x)
    -- if the left is indeterminate, inspect the right
  progress (TAAp wt1 wt2) | I i | S (_ , Step x y z) = S (_ , Step (FHAp2 x) y (FHAp2  z))
  progress (TAAp wt1 wt2) | I x | E x₁ = E (CECong (FHAp2 FHOuter) x₁)
  progress (TAAp wt1 wt2) | I x | I x₁ = {!!} -- I (IAp {!!} x (FIndet x₁)) -- todo: check that it's not that form, otherwise the cast can progress maybe
  progress (TAAp wt1 wt2) | I x | V x₁ = I (IAp {!!} x (FBoxed x₁)) --
    -- if the left is a boxed value, inspect the right
  progress (TAAp wt1 wt2) | V v | S (_ , Step x y z) = S (_ , Step (FHAp2  x) y (FHAp2  z))
  progress (TAAp wt1 wt2) | V v | E e = E (CECong (FHAp2 FHOuter) e)
  progress (TAAp wt1 wt2) | V v | I i
    with canonical-boxed-forms-arr wt1 v
  ... | Inl (x , d' , refl , qq) = S (_ , Step FHOuter ITLam FHOuter)
  ... | Inr (d' , τ1' , τ2' , refl , neq , qq) = I (IAp {!!} (ICastArr neq {!!}) (FIndet i)) --cyrus, as below
  progress (TAAp wt1 wt2) | V v | V v₂
    with canonical-boxed-forms-arr wt1 v
  ... | Inl (x , d' , refl , qq) = S (_ , Step FHOuter ITLam FHOuter)
  ... | Inr (d' , τ1' , τ2' , refl , neq , qq) = I (IAp {!!} (ICastArr neq {!!}) (FBoxed v₂)) --cyrus

    -- empty holes
  progress (TAEHole x x₁) = I IEHole

    -- nonempty holes
  progress (TANEHole xin wt x₁)
    with progress wt
  ... | S (_ , Step x y z) = S (_ , Step (FHNEHole x) y (FHNEHole z))
  ... | E x = E (CECong (FHNEHole FHOuter) x)
  ... | I x = I (INEHole (FIndet x))
  ... | V x = I (INEHole (FBoxed x))

    -- casts
  progress (TACast wt con)
    with progress wt
  ... | S (_ , Step x y z) = S (_ , Step (FHCast x) y (FHCast z))
  ... | E x = E (CECong (FHCast FHOuter) x)
  -- indet cases, inspect how the casts are realted by consistency
  progress (TACast wt TCRefl)  | I x = S (_ , Step FHOuter ITCastID FHOuter)
  progress (TACast wt TCHole1) | I x = I (ICastGroundHole {!!} x) -- cyrus
  progress (TACast wt TCHole2) | I x = I (ICastHoleGround {!!} x {!!}) -- cyrus
  progress (TACast wt (TCArr c1 c2)) | I x = I (ICastArr {!!} x) -- cyrus
  -- boxed value cases, inspect how the casts are realted by consistency
  progress (TACast wt TCRefl)  | V x = S (_ , Step FHOuter ITCastID FHOuter)
  progress (TACast wt TCHole1) | V x = V (BVHoleCast {!!} x) -- cyrus
  progress (TACast wt TCHole2) | V x = V {!!} -- cyrus: missing rule for boxed values?
  progress (TACast wt (TCArr c1 c2)) | V x = V (BVArrCast {!!} x) -- cyrus

open import Nat
open import Prelude
open import List
open import core
open import contexts
open import lemmas-consistency

open import canonical-boxed-forms
open import canonical-indeterminate-forms

module progress where
  -- this is a little bit of syntactic sugar to avoid many layer nested Inl
  -- and Inrs that you would get from the more literal transcription of the
  -- consequent of progress as:
  --
  -- d boxedval + d indet + d casterr[ Δ ] + Σ[ d' ∈ dhexp ] (d ↦ d')
  data ok : (d : dhexp) (Δ : hctx) → Set where
    S : ∀{d Δ} → Σ[ d' ∈ dhexp ] (d ↦ d') → ok d Δ
    E : ∀{d Δ} → d casterr → ok d Δ
    I : ∀{d Δ} → d indet → ok d Δ
    V : ∀{d Δ} → d boxedval → ok d Δ

  progress : {Δ : hctx} {d : dhexp} {τ : htyp} →
             Δ , ∅ ⊢ d :: τ →
             ok d Δ
    -- constants
  progress TAConst = V (BVVal VConst)

    -- variables
  progress (TAVar x₁) = abort (somenotnone (! x₁))

    -- lambdas
  progress (TALam wt) = V (BVVal VLam)

    -- applications
  progress (TAAp wt1 wt2)
    with progress wt1 | progress wt2
    -- if the left steps, the whole thing steps
  progress (TAAp wt1 wt2) | S (_ , Step x y z) | _ = S (_ , Step (FHAp1 x) y (FHAp1 z))
    -- if the left is an error, the whole thing is an error
  progress (TAAp wt1 wt2) | E x | _ = E (CECong (FHAp1 FHOuter) x)
    -- if the left is indeterminate, inspect the right
  progress (TAAp wt1 wt2) | I i | S (_ , Step x y z) = S (_ , Step (FHAp2 x) y (FHAp2  z))
  progress (TAAp wt1 wt2) | I x | E x₁ = E (CECong (FHAp2 FHOuter) x₁)
  progress (TAAp wt1 wt2) | I x | I x₁ = I (IAp {!!} x (FIndet x₁)) -- todo: check that it's not that form, otherwise the cast can progress maybe
  progress (TAAp wt1 wt2) | I x | V x₁ = I (IAp {!!} x (FBoxed x₁)) --
    -- if the left is a boxed value, inspect the right
  progress (TAAp wt1 wt2) | V v | S (_ , Step x y z) = S (_ , Step (FHAp2  x) y (FHAp2  z))
  progress (TAAp wt1 wt2) | V v | E e = E (CECong (FHAp2 FHOuter) e)
  progress (TAAp wt1 wt2) | V v | I i
    with canonical-boxed-forms-arr wt1 v
  ... | Inl (x , d' , refl , qq) = S (_ , Step FHOuter ITLam FHOuter)
  ... | Inr (d' , τ1' , τ2' , refl , neq , qq) = I (IAp {!!} (ICastArr neq {!!}) (FIndet i)) --cyrus, as below
  progress (TAAp wt1 wt2) | V v | V v₂
    with canonical-boxed-forms-arr wt1 v
  ... | Inl (x , d' , refl , qq) = S (_ , Step FHOuter ITLam FHOuter)
  ... | Inr (d' , τ1' , τ2' , refl , neq , qq) = I (IAp {!!} (ICastArr neq {!!}) (FBoxed v₂)) --cyrus

    -- empty holes
  progress (TAEHole x x₁) = I IEHole

    -- nonempty holes
  progress (TANEHole xin wt x₁)
    with progress wt
  ... | S (_ , Step x y z) = S (_ , Step (FHNEHole x) y (FHNEHole z))
  ... | E x = E (CECong (FHNEHole FHOuter) x)
  ... | I x = I (INEHole (FIndet x))
  ... | V x = I (INEHole (FBoxed x))

    -- casts
  progress (TACast wt con)
    with progress wt
  ... | S (_ , Step x y z) = S (_ , Step (FHCast x) y (FHCast z))
  ... | E x = E (CECong (FHCast FHOuter) x)
  -- indet cases, inspect how the casts are realted by consistency
  progress (TACast wt TCRefl)  | I x = S (_ , Step FHOuter ITCastID FHOuter)
  progress (TACast wt TCHole1) | I x = I (ICastGroundHole {!!} x) -- cyrus
  progress (TACast wt TCHole2) | I x = I (ICastHoleGround {!!} x {!!}) -- cyrus
  progress (TACast wt (TCArr c1 c2)) | I x = I (ICastArr {!!} x) -- cyrus
  -- boxed value cases, inspect how the casts are realted by consistency
  progress (TACast wt TCRefl)  | V x = S (_ , Step FHOuter ITCastID FHOuter)
  progress (TACast wt TCHole1) | V x = V (BVHoleCast {!!} x) -- cyrus
  progress (TACast wt TCHole2) | V x = V {!!} -- cyrus: missing rule for boxed values?
  progress (TACast wt (TCArr c1 c2)) | V x = V (BVArrCast {!!} x) -- cyrus


fussing with whitespace and name spaces

fussing with whitespace and name spaces

open import Nat
open import Prelude
open import List
open import core
open import contexts
open import lemmas-consistency
open import lemmas-ground

open import progress-checks

open import canonical-boxed-forms
open import canonical-value-forms
open import canonical-indeterminate-forms

open import ground-decidable
open import htype-decidable

module progress where
  -- this is a little bit of syntactic sugar to avoid many layer nested Inl
  -- and Inrs that you would get from the more literal transcription of the
  -- consequent of progress
  data ok : (d : dhexp) (Δ : hctx) → Set where
    S  : ∀{d Δ} → Σ[ d' ∈ dhexp ] (d ↦ d') → ok d Δ
    I  : ∀{d Δ} → d indet → ok d Δ
    BV : ∀{d Δ} → d boxedval → ok d Δ

  progress : {Δ : hctx} {d : dhexp} {τ : htyp} →
             Δ , ∅ ⊢ d :: τ →
             ok d Δ
    -- constants
  progress TAConst = BV (BVVal VConst)

    -- variables
  progress (TAVar x₁) = abort (somenotnone (! x₁))

    -- lambdas
  progress (TALam wt) = BV (BVVal VLam)

    -- applications
  progress (TAAp wt1 wt2)
    with progress wt1 | progress wt2
    -- if the left steps, the whole thing steps
  progress (TAAp wt1 wt2) | S (_ , Step x y z) | _ = S (_ , Step (FHAp1 x) y (FHAp1 z))
    -- if the left is indeterminate, step the right
  progress (TAAp wt1 wt2) | I i | S (_ , Step x y z) = S (_ , Step (FHAp2 x) y (FHAp2  z))
    -- if they're both indeterminate, step when the cast steps and indet otherwise
  progress (TAAp wt1 wt2) | I x | I x₁
    with canonical-indeterminate-forms-arr wt1 x
  progress (TAAp wt1 wt2) | I x | I y | CIFACast (_ , _ , _ , _ , _ , refl , _ , _ ) = S (_ , Step FHOuter ITApCast FHOuter)
  progress (TAAp wt1 wt2) | I x | I y | CIFAEHole (_ , _ , _ , refl , _)             = I (IAp (λ _ _ _ _ _ ()) x (FIndet y))
  progress (TAAp wt1 wt2) | I x | I y | CIFANEHole (_ , _ , _ , _ , _ , refl , _)    = I (IAp (λ _ _ _ _ _ ()) x (FIndet y))
  progress (TAAp wt1 wt2) | I x | I y | CIFAAp (_ , _ , _ , _ , _ , refl , _)        = I (IAp (λ _ _ _ _ _ ()) x (FIndet y))
  progress (TAAp wt1 wt2) | I x | I y | CIFACastHole (_ , refl , refl , refl , _ )   = I (IAp (λ _ _ _ _ _ ()) x (FIndet y))
  progress (TAAp wt1 wt2) | I x | I y | CIFAFailedCast (_ , _ , refl , _ )           = I (IAp (λ _ _ _ _ _ ()) x (FIndet y))
    -- similar if the left is indetermiante but the right is a boxed val
  progress (TAAp wt1 wt2) | I x | BV x₁
    with canonical-indeterminate-forms-arr wt1 x
  progress (TAAp wt1 wt2) | I x | BV y | CIFACast (_ , _ , _ , _ , _ , refl , _ , _ ) = S (_ , Step FHOuter ITApCast FHOuter)
  progress (TAAp wt1 wt2) | I x | BV y | CIFAEHole (_ , _ , _ , refl , _)             = I (IAp (λ _ _ _ _ _ ()) x (FBoxed y))
  progress (TAAp wt1 wt2) | I x | BV y | CIFANEHole (_ , _ , _ , _ , _ , refl , _)    = I (IAp (λ _ _ _ _ _ ()) x (FBoxed y))
  progress (TAAp wt1 wt2) | I x | BV y | CIFAAp (_ , _ , _ , _ , _ , refl , _)        = I (IAp (λ _ _ _ _ _ ()) x (FBoxed y))
  progress (TAAp wt1 wt2) | I x | BV y | CIFACastHole (_ , refl , refl , refl , _ )   = I (IAp (λ _ _ _ _ _ ()) x (FBoxed y))
  progress (TAAp wt1 wt2) | I x | BV y | CIFAFailedCast (_ , _ , refl , _ )           = I (IAp (λ _ _ _ _ _ ()) x (FBoxed y))
    -- if the left is a boxed value, inspect the right
  progress (TAAp wt1 wt2) | BV v | S (_ , Step x y z) = S (_ , Step (FHAp2  x) y (FHAp2  z))
  progress (TAAp wt1 wt2) | BV v | I i
    with canonical-boxed-forms-arr wt1 v
  ... | CBFLam (_ , _ , refl , _)             = S (_ , Step FHOuter ITLam FHOuter)
  ... | CBFCastArr (_ , _ , _ , refl , _ , _) = S (_ , Step FHOuter ITApCast FHOuter)
  progress (TAAp wt1 wt2) | BV v | BV v₂
    with canonical-boxed-forms-arr wt1 v
  ... | CBFLam (_ , _ , refl , _)             = S (_ , Step FHOuter ITLam FHOuter)
  ... | CBFCastArr (_ , _ , _ , refl , _ , _) = S (_ , Step FHOuter ITApCast FHOuter)

    -- empty holes are indeterminate
  progress (TAEHole _ _ ) = I IEHole

    -- nonempty holes step if the innards step, indet otherwise
  progress (TANEHole xin wt x₁)
    with progress wt
  ... | S (_ , Step x y z) = S (_ , Step (FHNEHole x) y (FHNEHole z))
  ... | I  x = I (INEHole (FIndet x))
  ... | BV x = I (INEHole (FBoxed x))

    -- casts
  progress (TACast wt con)
    with progress wt
    -- step if the innards step
  progress (TACast wt con) | S (_ , Step x y z) = S (_ , Step (FHCast x) y (FHCast z))
    -- if indet, inspect how the types in the cast are realted by consistency:
    -- if they're the same, step by ID
  progress (TACast wt TCRefl)  | I x = S (_ , Step FHOuter ITCastID FHOuter)
    -- if first type is hole
  progress (TACast {τ1 = τ1} wt TCHole1) | I x
    with τ1
  progress (TACast wt TCHole1) | I x | b = I (ICastGroundHole GBase x)
  progress (TACast wt TCHole1) | I x | ⦇⦈ = S (_ , Step FHOuter ITCastID FHOuter)
  progress (TACast wt TCHole1) | I x | τ11 ==> τ12
    with ground-decidable (τ11 ==> τ12)
  progress (TACast wt TCHole1) | I x₁ | .⦇⦈ ==> .⦇⦈ | Inl GHole = I (ICastGroundHole GHole x₁)
  progress (TACast wt TCHole1) | I x₁ | τ11 ==> τ12 | Inr x =  S (_ , Step FHOuter (ITGround (MGArr (ground-arr-not-hole x))) FHOuter)
    -- if second type is hole
  progress (TACast wt (TCHole2 {b})) | I x
    with canonical-indeterminate-forms-hole wt x
  progress (TACast wt (TCHole2 {b})) | I x | CIFHEHole (_ , _ , _ , refl , f)           = I (ICastHoleGround (λ _ _ ()) x GBase)
  progress (TACast wt (TCHole2 {b})) | I x | CIFHNEHole (_ , _ , _ , _ , _ , refl , _ ) = I (ICastHoleGround (λ _ _ ()) x GBase)
  progress (TACast wt (TCHole2 {b})) | I x | CIFHAp (_ , _ , _ , refl , _ )             = I (ICastHoleGround (λ _ _ ()) x GBase)
  progress (TACast wt (TCHole2 {b})) | I x | CIFHCast (_ , τ , refl , _)
    with htype-dec τ b
  progress (TACast wt (TCHole2 {b})) | I x₁ | CIFHCast (_ , .b , refl , π2 , _) | Inl refl = S (_ , Step FHOuter (ITCastSucceed π2) FHOuter)
  progress (TACast wt (TCHole2 {b})) | I x₁ | CIFHCast (_ , _ , refl , π2 , _)  | Inr x =    S (_ , Step FHOuter (ITCastFail π2 GBase x) FHOuter)
  progress (TACast wt (TCHole2 {⦇⦈}))| I x = S (_ , Step FHOuter ITCastID FHOuter)
  progress (TACast wt (TCHole2 {τ11 ==> τ12})) | I x
    with ground-decidable (τ11 ==> τ12)
  progress (TACast wt (TCHole2 {.⦇⦈ ==> .⦇⦈})) | I x₁ | Inl GHole
    with canonical-indeterminate-forms-hole wt x₁
  progress (TACast wt (TCHole2 {.⦇⦈ ==> .⦇⦈})) | I x | Inl GHole | CIFHEHole (_ , _ , _ , refl , _)          = I (ICastHoleGround (λ _ _ ()) x GHole)
  progress (TACast wt (TCHole2 {.⦇⦈ ==> .⦇⦈})) | I x | Inl GHole | CIFHNEHole (_ , _ , _ , _ , _ , refl , _) = I (ICastHoleGround (λ _ _ ()) x GHole)
  progress (TACast wt (TCHole2 {.⦇⦈ ==> .⦇⦈})) | I x | Inl GHole | CIFHAp (_ , _ , _ , refl , _ )            = I (ICastHoleGround (λ _ _ ()) x GHole)
  progress (TACast wt (TCHole2 {.⦇⦈ ==> .⦇⦈})) | I x | Inl GHole | CIFHCast (_ , ._ , refl , GBase , _)      = S (_ , Step FHOuter (ITCastFail GBase GHole (λ ())) FHOuter )
  progress (TACast wt (TCHole2 {.⦇⦈ ==> .⦇⦈})) | I x | Inl GHole | CIFHCast (_ , ._ , refl , GHole , _)      = S (_ , Step FHOuter (ITCastSucceed GHole) FHOuter)
  progress (TACast wt (TCHole2 {τ11 ==> τ12})) | I x₁ | Inr x = S (_ , Step FHOuter (ITExpand (MGArr (ground-arr-not-hole x))) FHOuter)
    -- if both are arrows
  progress (TACast wt (TCArr {τ1} {τ2} {τ1'} {τ2'} c1 c2)) | I x
    with htype-dec (τ1 ==> τ2)  (τ1' ==> τ2')
  progress (TACast wt (TCArr c1 c2)) | I x₁ | Inl refl = S (_ , Step FHOuter ITCastID FHOuter)
  progress (TACast wt (TCArr c1 c2)) | I x₁ | Inr x = I (ICastArr x x₁)
    -- boxed value cases, inspect how the casts are realted by consistency
    -- step by ID if the casts are the same
  progress (TACast wt TCRefl)  | BV x = S (_ , Step FHOuter ITCastID FHOuter)
    -- if left is hole
  progress (TACast wt (TCHole1 {τ = τ})) | BV x
    with ground-decidable τ
  progress (TACast wt TCHole1) | BV x₁ | Inl g = BV (BVHoleCast g x₁)
  progress (TACast wt (TCHole1 {b})) | BV x₁ | Inr x = abort (x GBase)
  progress (TACast wt (TCHole1 {⦇⦈})) | BV x₁ | Inr x = S (_ , Step FHOuter ITCastID FHOuter)
  progress (TACast wt (TCHole1 {τ1 ==> τ2})) | BV x₁ | Inr x
    with (htype-dec  (τ1 ==> τ2) (⦇⦈ ==> ⦇⦈))
  progress (TACast wt (TCHole1 {.⦇⦈ ==> .⦇⦈})) | BV x₂ | Inr x₁ | Inl refl = BV (BVHoleCast GHole x₂)
  progress (TACast wt (TCHole1 {τ1 ==> τ2})) | BV x₂ | Inr x₁ | Inr x = S (_ , Step FHOuter (ITGround (MGArr x)) FHOuter)
    -- if right is hole
  progress {τ = τ} (TACast wt TCHole2) | BV x
    with canonical-boxed-forms-hole wt x
  progress {τ = τ} (TACast wt TCHole2) | BV x | d' , τ' , refl , gnd , wt'
    with htype-dec τ τ'
  progress (TACast wt TCHole2) | BV x₁ | d' , τ , refl , gnd , wt' | Inl refl = S (_  , Step FHOuter (ITCastSucceed gnd) FHOuter)
  progress {τ = τ} (TACast wt TCHole2) | BV x₁ | _ , _ , refl , _ , _ | Inr _
    with ground-decidable τ
  progress (TACast wt TCHole2) | BV x₂ | _ , _ , refl , gnd , _ | Inr x₁ | Inl x = S(_ , Step FHOuter (ITCastFail gnd x (flip x₁)) FHOuter)
  progress (TACast wt TCHole2) | BV x₂ | _ , _ , refl , _ , _ | Inr x₁ | Inr x
    with notground x
  progress (TACast wt TCHole2) | BV x₃ | _ , _ , refl , _ , _ | Inr _ | Inr _ | Inl refl = S (_ , Step FHOuter ITCastID FHOuter)
  progress (TACast wt TCHole2) | BV x₃ | _ , _ , refl , _ , _ | Inr _ | Inr x | Inr (_ , _ , refl) = S(_ , Step FHOuter (ITExpand (MGArr (ground-arr-not-hole x))) FHOuter )
    -- if both arrows
  progress (TACast wt (TCArr {τ1} {τ2} {τ1'} {τ2'} c1 c2)) | BV x
    with htype-dec (τ1 ==> τ2) (τ1' ==> τ2')
  progress (TACast wt (TCArr c1 c2)) | BV x₁ | Inl refl = S (_ , Step FHOuter ITCastID FHOuter)
  progress (TACast wt (TCArr c1 c2)) | BV x₁ | Inr x = BV (BVArrCast x x₁)

   -- failed casts
  progress (TAFailedCast wt y z w)
    with progress wt
  progress (TAFailedCast wt y z w) | S (d' , Step x a q) = S (_ , Step (FHFailedCast x) a (FHFailedCast q))
  progress (TAFailedCast wt y z w) | I x = I (IFailedCast (FIndet x) y z w)
  progress (TAFailedCast wt y z w) | BV x = I (IFailedCast (FBoxed x) y z w)

open import Nat
open import Prelude
open import List
open import core
open import contexts
open import lemmas-consistency
open import lemmas-ground

open import progress-checks

open import canonical-boxed-forms
open import canonical-value-forms
open import canonical-indeterminate-forms

open import ground-decidable
open import htype-decidable

module progress where
  -- this is a little bit of syntactic sugar to avoid many layer nested Inl
  -- and Inrs that you would get from the more literal transcription of the
  -- consequent of progress as:
  --
  -- d boxedval + d indet + Σ[ d' ∈ dhexp ] (d ↦ d')
  data ok : (d : dhexp) (Δ : hctx) → Set where
    S : ∀{d Δ} → Σ[ d' ∈ dhexp ] (d ↦ d') → ok d Δ
    I : ∀{d Δ} → d indet → ok d Δ
    BV : ∀{d Δ} → d boxedval → ok d Δ

  progress : {Δ : hctx} {d : dhexp} {τ : htyp} →
             Δ , ∅ ⊢ d :: τ →
             ok d Δ
    -- constants
  progress TAConst = BV (BVVal VConst)

    -- variables
  progress (TAVar x₁) = abort (somenotnone (! x₁))

    -- lambdas
  progress (TALam wt) = BV (BVVal VLam)

    -- applications
  progress (TAAp wt1 wt2)
    with progress wt1 | progress wt2
    -- if the left steps, the whole thing steps
  progress (TAAp wt1 wt2) | S (_ , Step x y z) | _ = S (_ , Step (FHAp1 x) y (FHAp1 z))
    -- if the left is indeterminate, step the right
  progress (TAAp wt1 wt2) | I i | S (_ , Step x y z) = S (_ , Step (FHAp2 x) y (FHAp2  z))
    -- if they're both indeterminate, step when the cast steps and indet otherwise
  progress (TAAp wt1 wt2) | I x | I x₁
    with canonical-indeterminate-forms-arr wt1 x
  progress (TAAp wt1 wt2) | I x | I y | CIFACast (_ , _ , _ , _ , _ , refl , _ , _ ) = S (_ , Step FHOuter ITApCast FHOuter)
  progress (TAAp wt1 wt2) | I x | I y | CIFAEHole (_ , _ , _ , refl , _)             = I (IAp (λ _ _ _ _ _ ()) x (FIndet y))
  progress (TAAp wt1 wt2) | I x | I y | CIFANEHole (_ , _ , _ , _ , _ , refl , _)    = I (IAp (λ _ _ _ _ _ ()) x (FIndet y))
  progress (TAAp wt1 wt2) | I x | I y | CIFAAp (_ , _ , _ , _ , _ , refl , _)        = I (IAp (λ _ _ _ _ _ ()) x (FIndet y))
  progress (TAAp wt1 wt2) | I x | I y | CIFACastHole (_ , refl , refl , refl , _ )   = I (IAp (λ _ _ _ _ _ ()) x (FIndet y))
  progress (TAAp wt1 wt2) | I x | I y | CIFAFailedCast (_ , _ , refl , _ )           = I (IAp (λ _ _ _ _ _ ()) x (FIndet y))
    -- if the left is indetermiante but the right is a value
  progress (TAAp wt1 wt2) | I x | BV x₁
    with canonical-indeterminate-forms-arr wt1 x
  progress (TAAp wt1 wt2) | I x | BV y | CIFACast (_ , _ , _ , _ , _ , refl , _ , _ ) = S (_ , Step FHOuter ITApCast FHOuter)
  progress (TAAp wt1 wt2) | I x | BV y | CIFAEHole (_ , _ , _ , refl , _)             = I (IAp (λ _ _ _ _ _ ()) x (FBoxed y))
  progress (TAAp wt1 wt2) | I x | BV y | CIFANEHole (_ , _ , _ , _ , _ , refl , _)    = I (IAp (λ _ _ _ _ _ ()) x (FBoxed y))
  progress (TAAp wt1 wt2) | I x | BV y | CIFAAp (_ , _ , _ , _ , _ , refl , _)        = I (IAp (λ _ _ _ _ _ ()) x (FBoxed y))
  progress (TAAp wt1 wt2) | I x | BV y | CIFACastHole (_ , refl , refl , refl , _ )   = I (IAp (λ _ _ _ _ _ ()) x (FBoxed y))
  progress (TAAp wt1 wt2) | I x | BV y | CIFAFailedCast (_ , _ , refl , _ )           = I (IAp (λ _ _ _ _ _ ()) x (FBoxed y))
    -- if the left is a boxed value, inspect the right
  progress (TAAp wt1 wt2) | BV v | S (_ , Step x y z) = S (_ , Step (FHAp2  x) y (FHAp2  z))
  progress (TAAp wt1 wt2) | BV v | I i
    with canonical-boxed-forms-arr wt1 v
  ... | CBFLam (_ , _ , refl , _)             = S (_ , Step FHOuter ITLam FHOuter)
  ... | CBFCastArr (_ , _ , _ , refl , _ , _) = S (_ , Step FHOuter ITApCast FHOuter)
  progress (TAAp wt1 wt2) | BV v | BV v₂
    with canonical-boxed-forms-arr wt1 v
  ... | CBFLam (_ , _ , refl , _)             = S (_ , Step FHOuter ITLam FHOuter)
  ... | CBFCastArr (_ , _ , _ , refl , _ , _) = S (_ , Step FHOuter ITApCast FHOuter)

    -- empty holes
  progress (TAEHole x x₁) = I IEHole

    -- nonempty holes
  progress (TANEHole xin wt x₁)
    with progress wt
  ... | S (_ , Step x y z) = S (_ , Step (FHNEHole x) y (FHNEHole z))
  ... | I x = I (INEHole (FIndet x))
  ... | BV x = I (INEHole (FBoxed x))

    -- casts
  progress (TACast wt con)
    with progress wt
  ... | S (_ , Step x y z) = S (_ , Step (FHCast x) y (FHCast z))
  -- indet cases, inspect how the casts are realted by consistency
  progress (TACast wt TCRefl)  | I x = S (_ , Step FHOuter ITCastID FHOuter)
  progress (TACast {τ1 = τ1} wt TCHole1) | I x
    with τ1
  progress (TACast wt TCHole1) | I x | b = I (ICastGroundHole GBase x)
  progress (TACast wt TCHole1) | I x | ⦇⦈ = S (_ , Step FHOuter ITCastID FHOuter)
  progress (TACast wt TCHole1) | I x | τ11 ==> τ12
    with ground-decidable (τ11 ==> τ12)
  progress (TACast wt TCHole1) | I x₁ | .⦇⦈ ==> .⦇⦈ | Inl GHole = I (ICastGroundHole GHole x₁)
  progress (TACast wt TCHole1) | I x₁ | τ11 ==> τ12 | Inr x =  S (_ , Step FHOuter (ITGround (MGArr (ground-arr-not-hole x))) FHOuter)
  progress (TACast wt (TCHole2 {b})) | I x
    with canonical-indeterminate-forms-hole wt x
  progress (TACast wt (TCHole2 {b})) | I x | CIFHEHole (_ , _ , _ , refl , f)           = I (ICastHoleGround (λ _ _ ()) x GBase)
  progress (TACast wt (TCHole2 {b})) | I x | CIFHNEHole (_ , _ , _ , _ , _ , refl , _ ) = I (ICastHoleGround (λ _ _ ()) x GBase)
  progress (TACast wt (TCHole2 {b})) | I x | CIFHAp (_ , _ , _ , refl , _ )             = I (ICastHoleGround (λ _ _ ()) x GBase)
  progress (TACast wt (TCHole2 {b})) | I x | CIFHCast (_ , τ , refl , _)
    with htype-dec τ b
  progress (TACast wt (TCHole2 {b})) | I x₁ | CIFHCast (_ , .b , refl , π2 , _) | Inl refl = S (_ , Step FHOuter (ITCastSucceed π2) FHOuter)
  progress (TACast wt (TCHole2 {b})) | I x₁ | CIFHCast (_ , _ , refl , π2 , _)  | Inr x =    S (_ , Step FHOuter (ITCastFail π2 GBase x) FHOuter)

  progress (TACast wt (TCHole2 {⦇⦈})) | I x = S (_ , Step FHOuter ITCastID FHOuter)

  progress (TACast wt (TCHole2 {τ11 ==> τ12})) | I x
    with ground-decidable (τ11 ==> τ12)
  progress (TACast wt (TCHole2 {.⦇⦈ ==> .⦇⦈})) | I x₁ | Inl GHole
    with canonical-indeterminate-forms-hole wt x₁
  progress (TACast wt (TCHole2 {.⦇⦈ ==> .⦇⦈})) | I x | Inl GHole | CIFHEHole (_ , _ , _ , refl , _)          = I (ICastHoleGround (λ _ _ ()) x GHole)
  progress (TACast wt (TCHole2 {.⦇⦈ ==> .⦇⦈})) | I x | Inl GHole | CIFHNEHole (_ , _ , _ , _ , _ , refl , _) = I (ICastHoleGround (λ _ _ ()) x GHole)
  progress (TACast wt (TCHole2 {.⦇⦈ ==> .⦇⦈})) | I x | Inl GHole | CIFHAp (_ , _ , _ , refl , _ )            = I (ICastHoleGround (λ _ _ ()) x GHole)
  progress (TACast wt (TCHole2 {.⦇⦈ ==> .⦇⦈})) | I x | Inl GHole | CIFHCast (_ , ._ , refl , GBase , _)      = S (_ , Step FHOuter (ITCastFail GBase GHole (λ ())) FHOuter )
  progress (TACast wt (TCHole2 {.⦇⦈ ==> .⦇⦈})) | I x | Inl GHole | CIFHCast (_ , ._ , refl , GHole , _)      = S (_ , Step FHOuter (ITCastSucceed GHole) FHOuter)

  progress (TACast wt (TCHole2 {τ11 ==> τ12})) | I x₁ | Inr x = S (_ , Step FHOuter (ITExpand (MGArr (ground-arr-not-hole x))) FHOuter)

  progress (TACast wt (TCArr {τ1} {τ2} {τ1'} {τ2'} c1 c2)) | I x
    with htype-dec (τ1 ==> τ2)  (τ1' ==> τ2')
  progress (TACast wt (TCArr c1 c2)) | I x₁ | Inl refl = S (_ , Step FHOuter ITCastID FHOuter)
  progress (TACast wt (TCArr c1 c2)) | I x₁ | Inr x = I (ICastArr x x₁)

  -- boxed value cases, inspect how the casts are realted by consistency
  progress (TACast wt TCRefl)  | BV x = S (_ , Step FHOuter ITCastID FHOuter)
  progress (TACast wt (TCHole1 {τ = τ})) | BV x
    with ground-decidable τ
  progress (TACast wt TCHole1) | BV x₁ | Inl g = BV (BVHoleCast g x₁)
  progress (TACast wt (TCHole1 {b})) | BV x₁ | Inr x = abort (x GBase)
  progress (TACast wt (TCHole1 {⦇⦈})) | BV x₁ | Inr x = S (_ , Step FHOuter ITCastID FHOuter)
  progress (TACast wt (TCHole1 {τ1 ==> τ2})) | BV x₁ | Inr x
    with (htype-dec  (τ1 ==> τ2) (⦇⦈ ==> ⦇⦈))
  progress (TACast wt (TCHole1 {.⦇⦈ ==> .⦇⦈})) | BV x₂ | Inr x₁ | Inl refl = BV (BVHoleCast GHole x₂)
  progress (TACast wt (TCHole1 {τ1 ==> τ2})) | BV x₂ | Inr x₁ | Inr x = S (_ , Step FHOuter (ITGround (MGArr x)) FHOuter)
  progress {τ = τ} (TACast wt TCHole2) | BV x
    with canonical-boxed-forms-hole wt x
  progress {τ = τ} (TACast wt TCHole2) | BV x | d' , τ' , refl , gnd , wt'
    with htype-dec τ τ'
  progress (TACast wt TCHole2) | BV x₁ | d' , τ , refl , gnd , wt' | Inl refl = S (_  , Step FHOuter (ITCastSucceed gnd) FHOuter)
  progress {τ = τ} (TACast wt TCHole2) | BV x₁ | d' , τ' , refl , gnd , wt' | Inr x
    with ground-decidable τ
  progress (TACast wt TCHole2) | BV x₂ | d' , τ' , refl , gnd , wt' | Inr x₁ | Inl x = S(_ , Step FHOuter (ITCastFail gnd x (flip x₁)) FHOuter)
  progress (TACast wt TCHole2) | BV x₂ | d' , τ' , refl , gnd , wt' | Inr x₁ | Inr x
    with notground x
  progress (TACast wt TCHole2) | BV x₃ | d' , τ' , refl , gnd , wt' | Inr x₂ | Inr x | Inl refl = S (_ , Step FHOuter ITCastID FHOuter)
  progress (TACast wt TCHole2) | BV x₃ | d' , τ' , refl , gnd , wt' | Inr x₂ | Inr x | Inr (τ1 , τ2 , refl) = S(_ , Step FHOuter (ITExpand (MGArr (ground-arr-not-hole x))) FHOuter )

  progress (TACast wt (TCArr {τ1} {τ2} {τ1'} {τ2'} c1 c2)) | BV x
    with htype-dec (τ1 ==> τ2) (τ1' ==> τ2')
  progress (TACast wt (TCArr c1 c2)) | BV x₁ | Inl refl = S (_ , Step FHOuter ITCastID FHOuter)
  progress (TACast wt (TCArr c1 c2)) | BV x₁ | Inr x = BV (BVArrCast x x₁)

   -- failed casts
  progress (TAFailedCast wt y z w)
    with progress wt
  progress (TAFailedCast wt y z w) | S (d' , Step x a q) = S (_ , Step (FHFailedCast x) a (FHFailedCast q))
  progress (TAFailedCast wt y z w) | I x = I (IFailedCast (FIndet x) y z w)
  progress (TAFailedCast wt y z w) | BV x = I (IFailedCast (FBoxed x) y z w)


Working in issue #8.

Working in issue #8.

{-# OPTIONS --no-universe-polymorphism #-}
{-# OPTIONS --without-K #-}

module Issue8 where

postulate
  D : Set
  ∃ : (A : D → Set) → Set

postulate foo : (A : D → Set) → ∃ A → ∃ A
{-# ATP prove foo #-}

-- 25 February 2013: The issue is due to the η-expansion.
-- $ agda2atp -v 20 Issue8.agda
--- ...
--- The type and the eta-expanded type: equals

{-# OPTIONS --no-universe-polymorphism #-}
{-# OPTIONS --without-K #-}

module Issue8 where

postulate D : Set

-- The existential quantifier type on D.
data ∃ (A : D → Set) : Set where
  _,_ : (t : D) → A t → ∃ A

postulate foo : (A : D → Set) → (∃ λ x → A x) → (∃ λ x → A x)
{-# ATP prove foo #-}


Typo.

Typo.

Ignore-this: 203292a98a6e474e921983623c84ada7

darcs-hash:20110216162043-3bd4e-98383cda71486452f52845f4a8f3bac848b29de9.gz


Derive elim specialized to types in examples.

{-# OPTIONS --type-in-type --no-pattern-matching #-}
open import Spire.DarkwingDuck.Primitive
open import Spire.DarkwingDuck.Derived
module Spire.DarkwingDuck.Examples where

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

NatN : String
NatN = "Nat"

NatP : Tel
NatP = Emp

NatI : Scope NatP → Tel
NatI _ = Emp

NatE : Enum
NatE = "zero" ∷ "suc" ∷ []

NatB : (p : Scope NatP) → BranchesD NatE (NatI p)
NatB _ = End tt , Rec tt (End tt) , tt

Nat : Set
Nat = Form NatN NatP NatI NatE NatB

injNat : CurriedScope NatP λ p
  → CurriedFunc (Scope (NatI p))
      (sumD NatE (NatI p) (NatB p))
      (FormUncurried NatN NatP NatI NatE NatB p)
injNat = inj NatN NatP NatI NatE NatB

elimNat : CurriedScope NatP λ p
  → (M : CurriedScope (NatI p) (λ i → FormUncurried NatN NatP NatI NatE NatB p i → Set))
  → let unM = uncurryScope (NatI p) (λ i → FormUncurried NatN NatP NatI NatE NatB p i → Set) M
  in CurriedBranches NatE
     (SumCurriedHyps NatN NatP NatI NatE NatB p M)
     (CurriedScope (NatI p) (λ i → (x : FormUncurried NatN NatP NatI NatE NatB p i) → unM i x))
elimNat = elim NatN NatP NatI NatE NatB

zero : Nat
zero = injNat here

suc : Nat → Nat
suc = injNat (there here)

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

VecN : String
VecN = "Vec"

VecP : Tel
VecP = Ext Set λ _ → Emp

VecI : Scope VecP → Tel
VecI _ = Ext Nat λ _ → Emp

VecE : Enum
VecE = "nil" ∷ "cons" ∷ []

VecB : (p : Scope VecP) → BranchesD VecE (VecI p)
VecB = uncurryScope VecP (λ p → BranchesD VecE (VecI p)) λ A
  → End (zero , tt)
  , Arg Nat (λ n → Arg A λ _ → Rec (n , tt) (End (suc n , tt)))
  , tt

Vec : (A : Set) → Nat → Set
Vec = Form VecN VecP VecI VecE VecB

injVec : CurriedScope VecP λ p
  → CurriedFunc (Scope (VecI p))
      (sumD VecE (VecI p) (VecB p))
      (FormUncurried VecN VecP VecI VecE VecB p)
injVec = inj VecN VecP VecI VecE VecB

elimVec : CurriedScope VecP λ p
  → (M : CurriedScope (VecI p) (λ i → FormUncurried VecN VecP VecI VecE VecB p i → Set))
  → let unM = uncurryScope (VecI p) (λ i → FormUncurried VecN VecP VecI VecE VecB p i → Set) M
  in CurriedBranches VecE
     (SumCurriedHyps VecN VecP VecI VecE VecB p M)
     (CurriedScope (VecI p) (λ i → (x : FormUncurried VecN VecP VecI VecE VecB p i) → unM i x))
elimVec = elim VecN VecP VecI VecE VecB

nil : (A : Set) → Vec A zero
nil A = injVec A here

cons : (A : Set) (n : Nat) (x : A) (xs : Vec A n) → Vec A (suc n)
cons A = injVec A (there here)

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

add : Nat → Nat → Nat
add = elimNat
  (λ n → Nat → Nat)
  (λ n → n)
  (λ m ih n → suc (ih n))

mult : Nat → Nat → Nat
mult = elimNat
  (λ n → Nat → Nat)
  (λ n → zero)
  (λ m ih n → add n (ih n))

append : (A : Set) (m n : Nat) (xs : Vec A m) (ys : Vec A n) → Vec A (add m n)
append A m n = elimVec A
  (λ m xs → (ys : Vec A n) → Vec A (add m n))
  (λ ys → ys)
  (λ m' x xs ih ys → cons A (add m' n) x (ih ys))
  m

concat : (A : Set) (m n : Nat) (xss : Vec (Vec A m) n) → Vec A (mult n m)
concat A m n = elimVec (Vec A m)
  (λ n xss → Vec A (mult n m))
  (nil A)
  (λ m' xs xss ih → append A m (mult m' m) xs ih)
  n

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

one : Nat
one = suc zero

two : Nat
two = suc one

three : Nat
three = suc two

[1,2] : Vec Nat two
[1,2] = cons Nat one one (cons Nat zero two (nil Nat))

[3] : Vec Nat one
[3] = cons Nat zero three (nil Nat)

[1,2,3] : Vec Nat three
[1,2,3] = cons Nat two one (cons Nat one two (cons Nat zero three (nil Nat)))

test-append : [1,2,3] ≡ append Nat two one [1,2] [3]
test-append = refl

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

{-# OPTIONS --type-in-type --no-pattern-matching #-}
open import Spire.DarkwingDuck.Primitive
open import Spire.DarkwingDuck.Derived
module Spire.DarkwingDuck.Examples where

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

NatN : String
NatN = "Nat"

NatP : Tel
NatP = Emp

NatI : Scope NatP → Tel
NatI _ = Emp

NatE : Enum
NatE = "zero" ∷ "suc" ∷ []

NatB : (p : Scope NatP) → BranchesD NatE (NatI p)
NatB _ = End tt , Rec tt (End tt) , tt

Nat : Set
Nat = Form NatN NatP NatI NatE NatB

zero : Nat
zero = inj NatN NatP NatI NatE NatB here

suc : Nat → Nat
suc = inj NatN NatP NatI NatE NatB (there here)

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

VecN : String
VecN = "Vec"

VecP : Tel
VecP = Ext Set λ _ → Emp

VecI : Scope VecP → Tel
VecI _ = Ext Nat λ _ → Emp

VecE : Enum
VecE = "nil" ∷ "cons" ∷ []

VecB : (p : Scope VecP) → BranchesD VecE (VecI p)
VecB = uncurryScope VecP (λ p → BranchesD VecE (VecI p)) λ A
  → End (zero , tt)
  , Arg Nat (λ n → Arg A λ _ → Rec (n , tt) (End (suc n , tt)))
  , tt

Vec : (A : Set) → Nat → Set
Vec = Form VecN VecP VecI VecE VecB

nil : (A : Set) → Vec A zero
nil A = inj VecN VecP VecI VecE VecB A here

cons : (A : Set) (n : Nat) (x : A) (xs : Vec A n) → Vec A (suc n)
cons A = inj VecN VecP VecI VecE VecB A (there here)

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

add : Nat → Nat → Nat
add = elim NatN NatP NatI NatE NatB
  (λ n → Nat → Nat)
  (λ n → n)
  (λ m ih n → suc (ih n))

mult : Nat → Nat → Nat
mult = elim NatN NatP NatI NatE NatB
  (λ n → Nat → Nat)
  (λ n → zero)
  (λ m ih n → add n (ih n))

append : (A : Set) (m n : Nat) (xs : Vec A m) (ys : Vec A n) → Vec A (add m n)
append A m n = elim VecN VecP VecI VecE VecB A
  (λ m xs → (ys : Vec A n) → Vec A (add m n))
  (λ ys → ys)
  (λ m' x xs ih ys → cons A (add m' n) x (ih ys))
  m

concat : (A : Set) (m n : Nat) (xss : Vec (Vec A m) n) → Vec A (mult n m)
concat A m n = elim VecN VecP VecI VecE VecB (Vec A m)
  (λ n xss → Vec A (mult n m))
  (nil A)
  (λ m' xs xss ih → append A m (mult m' m) xs ih)
  n

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

one : Nat
one = suc zero

two : Nat
two = suc one

three : Nat
three = suc two

[1,2] : Vec Nat two
[1,2] = cons Nat one one (cons Nat zero two (nil Nat))

[3] : Vec Nat one
[3] = cons Nat zero three (nil Nat)

[1,2,3] : Vec Nat three
[1,2,3] = cons Nat two one (cons Nat one two (cons Nat zero three (nil Nat)))

test-append : [1,2,3] ≡ append Nat two one [1,2] [3]
test-append = refl

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