------------------------------------------------------------------------
-- An implementation of the Fibonacci sequence using tail
------------------------------------------------------------------------

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; []; _∷_)

------------------------------------------------------------------------
-- Stream programs

-- StreamP b A encodes programs generating streams in chunks of size
-- (at least) 1. The first chunk may be empty if b is false.

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

------------------------------------------------------------------------
-- The Fibonacci sequence

fib : StreamP true 
fib = 0  [  (1  zipWith _+_ (forget fib) (tail fib)) ]

------------------------------------------------------------------------
-- The definition of fib is correct

-- ⟦_⟧ is homomorphic with respect to zipWith/S.zipWith.

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′

-- forget is the identity on streams.

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   (_ ))

-- The stream ⟦ fib ⟧P satisfies its intended defining equation.

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)

------------------------------------------------------------------------
-- An equality proof language

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′

-- Completeness.

completeP :  {A : Set} {xs ys : Stream A} 
            xs  ys  xs ≈[ true ]P ys
completeP (x  xs≈ys) = x  [  completeP ( xs≈ys) ]

-- Weak head normal forms.

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′)

-- Soundness.

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)

------------------------------------------------------------------------
-- The equation given for fib has a unique solution

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