Vector: magnitude and direction; Oh, YEAH!

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
module Data.Vector where

import Prelude hiding (last, (!!))
import Data.Foldable
import Data.Monoid
import Data.Traversable

import Control.Applicative

import Control.Comonad             -- http://lpaste.net/107661
import Data.Deque                  -- http://lpaste.net/106780
import Data.Peano                  -- http://lpaste.net/107204

-- the class of vectors have both magnitude and direction, OH, YEAH!
-- ... quote from the movie Despicable Me

class Vectortude v where 
   lengthV :: v a -> Int              -- magnitude, ...
   (<|) :: v a -> a -> v a            -- ... and direction!
   putToBackV :: v a -> a -> v a
   putToBackV = (<|)
   (|>) :: a -> v a -> v a            -- OH, YEAH!
   -- get operations:
   (!!) :: v a -> Int -> a
   v !! 0 = headV v
   v !! n = tailV v !! pred n
   headV :: v a -> a
   firstV :: v a -> a
   firstV = headV
   tailV :: v a -> v a
   lastV :: v a -> a
   isEmpty :: v a -> Bool
   isEmpty vect = lengthV vect == 0
   toListV :: v a -> [a]
   toListV = foldrV (:) []
   
data Vector a = Vect Int (Deque a)
   deriving Show

instance Eq a => Eq (Vector a) where
   (Vect n d1) == (Vect m d2) = n == m && d1 == d2
   (Vect n d1) /= (Vect m d2) = n /= m || d1 /= d2

newVector :: Vector a
newVector = Vect 0 Empty

instance Vectortude Vector where
   (Vect sz deck) <| elt = Vect (succ sz) (deck |< elt)
   elt |> (Vect sz deck) = Vect (succ sz) (elt >| deck)
   lengthV (Vect sz _) = sz       -- length in constant time
   headV (Vect 0 _) = error "calling headV on empty vector"
   headV (Vect _ deck) = first deck
   tailV (Vect 0 _) = error "calling tailV on empty vector"
   tailV (Vect sz deck) = let (_, rest) = nab deck
                          in  Vect (pred sz) rest
   lastV (Vect 0 _) = error "calling lastV on empty vector"
   lastV (Vect _ deck) = Data.Deque.last deck

foldrV :: Vectortude v => (a -> b -> b) -> b -> v a -> b
foldrV f z vect = if isEmpty vect then z
                  else f (headV vect) $ foldrV f z $ tailV vect

takeV :: Vectortude v => Int -> v a -> [a]
takeV sz vect = t' (fromInt sz) vect
   where t' Z _ = []
         t' (S n) vect | isEmpty vect = []
                       | otherwise    = headV vect : t' n (tailV vect)

dropWhileV :: Vectortude v => (a -> Bool) -> v a -> v a
dropWhileV fn vect | isEmpty vect = vect
                   | otherwise    = d' (ht vect) vect
   where d' (h, rest) vect = if fn h then dropWhileV fn rest else vect
         ht vect = (headV vect, tailV vect)

-- standard instantial extensions:

instance Functor Vector where
   fmap f (Vect sz deck) = Vect sz (fmap f deck)

instance Copointed Vector where
   extract vec = headV vec

instance Foldable Vector where
   foldMap f (Vect sz deck) = foldMap f deck

instance Traversable Vector where
   traverse f (Vect sz deck) = Vect sz <$> traverse f deck

-- Bonus: -------------------------------------------------------------

data Quark = Up | Down -- standard model, gives us which way to iterate

data BidirectionalVector a = Bvect Int Quark (Deque a)

newBvect :: BidirectionalVector a
newBvect = Bvect 0 Down Empty

instance Vectortude BidirectionalVector where
   (Bvect sz Down deck) <| elt = Bvect (succ sz) Down (deck |< elt)
   (Bvect sz Up deck) <| elt = Bvect (succ sz) Up (elt >| deck)
   elt |> (Bvect sz Down deck) = Bvect (succ sz) Down (elt >| deck)
   elt |> (Bvect sz Up deck)   = Bvect (succ sz) Up (deck |< elt)
   lengthV (Bvect sz _ _) = sz
   headV (Bvect 0 _ _) = error "calling headV on empty vector"
   headV (Bvect _ Up deck) = Data.Deque.last deck
   headV (Bvect _ Down deck) = first deck
   tailV (Bvect 0 _ _) = error "calling tailV on empty vector"
   tailV (Bvect sz Down deck) = let (_, rest) = nab deck
                                in  Bvect (pred sz) Down rest
   tailV (Bvect sz Up deck) = let (_, rest) = ban deck
                              in  Bvect (pred sz) Up rest
   lastV (Bvect 0 _ _) = error "calling lastV on empty vector"
   lastV (Bvect sz Down deck) = Data.Deque.last deck
   lastV (Bvect sz Up deck) = first deck

instance Functor BidirectionalVector where -- order not important here
   fmap f (Bvect sz direction deck) = Bvect sz direction $ fmap f deck

instance Copointed BidirectionalVector where
   extract (Bvect _ Up deck) = last deck
   extract (Bvect _ Down deck) = first deck

instance Foldable BidirectionalVector where
   foldr = foldrV

instance Traversable BidirectionalVector where
   traverse f (Bvect sz dir deck) = Bvect sz dir <$> traverse f deck

-- reverseV in constant time:

reverseV :: BidirectionalVector a -> BidirectionalVector a
reverseV (Bvect sz Down deck) = Bvect sz Up deck
reverseV (Bvect sz Up deck) = Bvect sz Down deck

-- proof that reverseV is constant: by definition

-- and the proof in the pudding (by ‘Show’ing):

showStart :: BidirectionalVector a -> String
showStart (Bvect sz _ _) = "Vect " ++ show sz ++ " "

show' :: Show a => Deque a -> String
show' Empty = "<|>"
show' (FirstAndLast x) = "<|" ++ show x ++ "|>"
show' (Deck a b c) = "<|" ++ show c ++ ", " ++ show'' b ++ show a ++ "|>"
   where show'' Empty = ""
         show'' (FirstAndLast x) = show x ++ ", "
         show'' (Deck a b c) = show c ++ ", " ++ show'' b ++ show a ++ ", "

instance Show a => Show (BidirectionalVector a) where
    show v@(Bvect sz Down deck) = showStart v ++ show deck
    show v@(Bvect sz Up deck) = showStart v ++ show' deck
81:4: Error: Eta reduce
Found:
extract vec = headV vec
Why not:
extract = headV