module SingletonChunks where
open import Coinduction
open import Data.Bool
open import Data.Nat
open import Data.Stream as S using (Stream; _≈_; _∷_)
open import Data.Vec as V using (Vec; []; _∷_)
infixr 5 _∷_
data StreamP : Bool → Set → Set₁ where
[_] : ∀ {A} (xs : ∞ (StreamP true A)) → StreamP false A
_∷_ : ∀ {A} (x : A) (xs : StreamP false A) → StreamP true A
forget : ∀ {A} (xs : StreamP true A) → StreamP false A
tail : ∀ {A} (xs : StreamP true A) → StreamP false A
zipWith : ∀ {b A B C} (f : A → B → C)
(xs : StreamP b A) (ys : StreamP b B) → StreamP b C
data StreamW : Bool → Set → Set₁ where
[_] : ∀ {A} (xs : StreamP true A) → StreamW false A
_∷_ : ∀ {A} (x : A) (xs : StreamW false A) → StreamW true A
forgetW : ∀ {A} → StreamW true A → StreamW false A
forgetW (x ∷ [ xs ]) = [ x ∷ forget xs ]
tailW : ∀ {A} → StreamW true A → StreamW false A
tailW (x ∷ xs) = xs
zipWithW : ∀ {b A B C} → (A → B → C) →
StreamW b A → StreamW b B → StreamW b C
zipWithW f [ xs ] [ ys ] = [ zipWith f xs ys ]
zipWithW f (x ∷ xs) (y ∷ ys) = f x y ∷ zipWithW f xs ys
whnf : ∀ {b A} → StreamP b A → StreamW b A
whnf [ xs ] = [ ♭ xs ]
whnf (x ∷ xs) = x ∷ whnf xs
whnf (forget xs) = forgetW (whnf xs)
whnf (tail xs) = tailW (whnf xs)
whnf (zipWith f xs ys) = zipWithW f (whnf xs) (whnf ys)
mutual
⟦_⟧W : ∀ {A} → StreamW true A → Stream A
⟦ x ∷ [ xs ] ⟧W = x ∷ ♯ ⟦ xs ⟧P
⟦_⟧P : ∀ {A} → StreamP true A → Stream A
⟦ xs ⟧P = ⟦ whnf xs ⟧W
fib : StreamP true ℕ
fib = 0 ∷ [ ♯ (1 ∷ zipWith _+_ (forget fib) (tail fib)) ]
zipWith-hom : ∀ {A B C} (_∙_ : A → B → C) xs ys →
⟦ zipWith _∙_ xs ys ⟧P ≈ S.zipWith _∙_ ⟦ xs ⟧P ⟦ ys ⟧P
zipWith-hom _∙_ xs ys with whnf xs | whnf ys
zipWith-hom _∙_ xs ys | x ∷ [ xs′ ] | y ∷ [ ys′ ] =
(x ∙ y) ∷ ♯ zipWith-hom _∙_ xs′ ys′
open import MapIterate as M using (_≈P_; _∷_; _≈⟨_⟩_; _∎)
open import Relation.Binary.PropositionalEquality as P
using (_≡_; _with-≡_)
forget-lemma : ∀ {A} x (xs : StreamP true A) →
⟦ x ∷ forget xs ⟧P ≈P x ∷ ♯ ⟦ xs ⟧P
forget-lemma x xs with P.inspect (whnf xs)
... | (y ∷ [ ys ]) with-≡ eq rewrite eq = x ∷ ♯ helper
where
helper : ⟦ y ∷ forget ys ⟧P ≈P ⟦ xs ⟧P
helper rewrite eq = _ ≈⟨ forget-lemma y ys ⟩ (y ∷ ♯ (_ ∎))
open import Relation.Binary
module SS {A : Set} = Setoid (S.setoid A)
fib-correct :
⟦ fib ⟧P ≈ 0 ∷ ♯ (1 ∷ ♯ S.zipWith _+_ ⟦ fib ⟧P (S.tail ⟦ fib ⟧P))
fib-correct =
0 ∷ ♯ (1 ∷ ♯ SS.trans
(zipWith-hom _+_ (0 ∷ forget fib′) fib′)
(S.zipWith-cong _+_ (SS.trans (M.soundP (forget-lemma 0 fib′))
(0 ∷ ♯ SS.refl)) SS.refl))
where fib′ = 1 ∷ zipWith _+_ (forget fib) (tail fib)
infix 4 _≈[_]P_ _≈[_]W_
infix 3 _∎
infixr 2 _≈⟨_⟩_
data _≈[_]P_ : {A : Set} → Stream A → Bool → Stream A → Set₁ where
[_] : ∀ {A} {xs ys : Stream A}
(xs≈ys : ∞ (xs ≈[ true ]P ys)) → xs ≈[ false ]P ys
_∷_ : ∀ {b A} (x : A) {xs ys : ∞ (Stream A)}
(xs≈ys : ♭ xs ≈[ b ]P ♭ ys) → x ∷ xs ≈[ true ]P x ∷ ys
forget : ∀ {A} {xs ys : Stream A}
(xs≈ys : xs ≈[ true ]P ys) → xs ≈[ false ]P ys
_≈⟨_⟩_ : ∀ {b A} (xs : Stream A) {ys zs}
(xs≈ys : xs ≈[ b ]P ys) (ys≈zs : ys ≈[ b ]P zs) →
xs ≈[ b ]P zs
_∎ : ∀ {A} (xs : Stream A) → xs ≈[ true ]P xs
tail : ∀ {A} {xs ys : Stream A} (xs≈ys : xs ≈[ true ]P ys) →
S.tail xs ≈[ false ]P S.tail ys
zipWith : ∀ {b A B C} (f : A → B → C) {xs xs′ ys ys′}
(xs≈xs′ : xs ≈[ b ]P xs′) (ys≈ys′ : ys ≈[ b ]P ys′) →
S.zipWith f xs ys ≈[ b ]P S.zipWith f xs′ ys′
completeP : ∀ {A : Set} {xs ys : Stream A} →
xs ≈ ys → xs ≈[ true ]P ys
completeP (x ∷ xs≈ys) = x ∷ [ ♯ completeP (♭ xs≈ys) ]
data _≈[_]W_ {A : Set} : Stream A → Bool → Stream A → Set₁ where
[_] : {xs ys : Stream A}
(xs≈ys : xs ≈[ true ]P ys) → xs ≈[ false ]W ys
_∷_ : ∀ (x : A) {xs ys}
(xs≈ys : ♭ xs ≈[ true ]P ♭ ys) → x ∷ xs ≈[ true ]W x ∷ ys
consW≈ : ∀ {A b} (x : A) {xs ys} →
♭ xs ≈[ b ]W ♭ ys → x ∷ xs ≈[ true ]W x ∷ ys
consW≈ x xs≈ys = x ∷ helper xs≈ys
where
helper : ∀ {A b} {xs ys : Stream A} →
xs ≈[ b ]W ys → xs ≈[ true ]P ys
helper [ xs≈ys ] = xs≈ys
helper (x ∷ xs≈ys) = x ∷ xs≈ys
forgetW≈ : ∀ {A} {xs ys : Stream A} →
xs ≈[ true ]W ys → xs ≈[ false ]W ys
forgetW≈ (x ∷ xs≈ys) = [ x ∷ forget xs≈ys ]
transW≈ : ∀ {A b} {xs ys zs : Stream A} →
xs ≈[ b ]W ys → ys ≈[ b ]W zs → xs ≈[ b ]W zs
transW≈ [ xs≈ys ] [ ys≈zs ] = [ _ ≈⟨ xs≈ys ⟩ ys≈zs ]
transW≈ (x ∷ xs≈ys) (.x ∷ ys≈zs) = x ∷ (_ ≈⟨ xs≈ys ⟩ ys≈zs)
reflW≈ : ∀ {A} (xs : Stream A) → xs ≈[ true ]W xs
reflW≈ (x ∷ xs) = x ∷ (♭ xs ∎)
tailW≈ : ∀ {A} {xs ys : Stream A} →
xs ≈[ true ]W ys → S.tail xs ≈[ false ]W S.tail ys
tailW≈ (x ∷ xs≈ys) = [ xs≈ys ]
zipWithW≈ : ∀ {A B C b} (_∙_ : A → B → C) {xs₁ ys₁ xs₂ ys₂} →
xs₁ ≈[ b ]W ys₁ → xs₂ ≈[ b ]W ys₂ →
S.zipWith _∙_ xs₁ xs₂ ≈[ b ]W S.zipWith _∙_ ys₁ ys₂
zipWithW≈ _∙_ [ xs₁≈ys₁ ] [ xs₂≈ys₂ ] = [ zipWith _∙_ xs₁≈ys₁ xs₂≈ys₂ ]
zipWithW≈ _∙_ (x₁ ∷ xs₁≈ys₁) (x₂ ∷ xs₂≈ys₂) =
(x₁ ∙ x₂) ∷ zipWith _∙_ xs₁≈ys₁ xs₂≈ys₂
whnf≈ : ∀ {A : Set} {xs ys : Stream A} {b} →
xs ≈[ b ]P ys → xs ≈[ b ]W ys
whnf≈ [ xs≈ys ] = [ ♭ xs≈ys ]
whnf≈ (x ∷ xs≈ys) = consW≈ x (whnf≈ xs≈ys)
whnf≈ (forget xs≈ys) = forgetW≈ (whnf≈ xs≈ys)
whnf≈ (xs ≈⟨ xs≈ys ⟩ ys≈zs) = transW≈ (whnf≈ xs≈ys) (whnf≈ ys≈zs)
whnf≈ (xs ∎) = reflW≈ xs
whnf≈ (tail xs≈ys) = tailW≈ (whnf≈ xs≈ys)
whnf≈ (zipWith f xs≈xs′ ys≈ys′) = zipWithW≈ f (whnf≈ xs≈xs′) (whnf≈ ys≈ys′)
mutual
soundW : {A : Set} {xs ys : Stream A} → xs ≈[ true ]W ys → xs ≈ ys
soundW (x ∷ xs≈ys) = x ∷ ♯ soundP xs≈ys
soundP : {A : Set} {xs ys : Stream A} → xs ≈[ true ]P ys → xs ≈ ys
soundP xs≈ys = soundW (whnf≈ xs≈ys)
fib-rhs : Stream ℕ → Stream ℕ
fib-rhs ns = 0 ∷ ♯ (1 ∷ ♯ S.zipWith _+_ ns (S.tail ns))
fib-unique :
∀ ms ns → ms ≈ fib-rhs ms → ns ≈ fib-rhs ns → ms ≈[ true ]P ns
fib-unique ms ns ms≈ ns≈ =
ms ≈⟨ completeP ms≈ ⟩
fib-rhs ms ≈⟨ 0 ∷ [ ♯ (1 ∷ zipWith _+_ (forget (fib-unique ms ns ms≈ ns≈))
(tail (fib-unique ms ns ms≈ ns≈))) ] ⟩
fib-rhs ns ≈⟨ completeP (SS.sym ns≈) ⟩
ns ∎