fixed-length vectors

11 May 2005

      {-
Half a year ago, I was teaching on a short FP course for postgrads,
and there I used a different approach to fixed-length vectors:
The code below was part of a larger set that overall implemented Minesweeper,
using these kinds of vectors.
-}

infixr :.
infixl !.
data Cons b a = a :. b a
data NIL a = NIL

instance Functor NIL where fmap _ NIL = NIL
instance Functor v => Functor (Cons v) where
    fmap f (x :. xs) = f x :. fmap f xs

class Indexable v where
    update :: Int -> (a->a) -> v a -> v a
    (!.) :: v a -> Int -> a
instance Indexable NIL where
    update n f NIL = NIL
    NIL !. _ = error "index out of bounds"
instance Indexable v => Indexable (Cons v) where
    update 0 f (x:.xs) = f x :. xs
    update n f (x:.xs) = x :. update (n-1) f xs
    (x:.xs) !. 0 = x
    (x:.xs) !. n = xs !. (n-1)
class Zip v where
    zipw2 :: (a->b->c)->v a -> v b -> v c
    zipw3 :: (a->b->c->d)->v a -> v b -> v c -> v d
instance Zip NIL where
    zipw2 f NIL NIL = NIL
    zipw3 f NIL NIL NIL = NIL
instance Zip v => Zip (Cons v) where
    zipw2 f (x:.xs)(y:.ys) = f x y :. zipw2 f xs ys
    zipw3 f (x:.xs)(y:.ys)(z:.zs) = f x y z :. zipw3 f xs ys zs

class (Zip v,Functor v,Indexable v,Shift v,Fold1 v) => Vector v where
    listify :: v a -> [a]
    fromList :: [a] -> v a

instance Vector NIL where
    listify NIL = []
    fromList _ = NIL

instance Vector w => Vector (Cons w)
    where
    listify (x :. xs) = x : listify xs
    fromList [] = error "list too short"
    fromList (x:xs) = x:. fromList xs

-- Update an array to have value x at position (n,m)			

update2D :: (Indexable v,Indexable w) => Int -> Int -> a -> v(w a) -> v(w a)
update2D n m x xss = update n (update m (const x)) xss

lookup2D :: (Vector v, Vector w) => v(w a) -> Int -> Int -> a
lookup2D xs i j = xs !. i !. j

class Shift v where
	shiftleft :: a -> Cons v a -> Cons v a
	shiftright :: a -> Cons v a -> Cons v a
	snoc :: a -> v a -> Cons v a

instance Shift NIL where
	shiftleft x (y:.NIL) = x:.NIL
	shiftright = shiftleft
	snoc = (:.)

instance Shift v => Shift (Cons v) where
	shiftleft x (y:.ys) = snoc x ys
	shiftright x (y:.ys) = x :. shiftright y ys
	snoc x (y :. ys) = y :. snoc x ys

class Fold1 v where
	fold1 :: (a->a->a) -> Cons v a -> a

instance Fold1 NIL where
	fold1 f (x:.NIL) = x
instance Fold1 v => Fold1 (Cons v) where
	fold1 f (x:.xs) = f x (fold1 f xs)

{- in order to have a common type for vectors, use existentials : -}

data Anyrow a = forall v. Vector v => Anyrow(v a)
buildrow :: [a] -> Anyrow a
buildrow [] = Anyrow NIL
buildrow (x:xs) = xcons x (buildrow xs)

xcons :: a -> Anyrow a -> Anyrow a
xcons a (Anyrow xs) = Anyrow (a :. xs)

ncons :: a -> Anyrow a -> NErow a
ncons a (Anyrow xs) = NErow (a :. xs)

data NErow a = forall v.Vector v => NErow(Cons v a)
buildnerow :: [a] -> NErow a
buildnerow [] = error "non-empty vector from empty list"
buildnerow (x:xs) = ncons x (buildrow xs)

data NEmatrix a = forall v w.(Vector v,Vector w)=>NEmatrix(Cons v(Cons w a))

singleton :: NErow a -> NEmatrix a
singleton (NErow bs) = NEmatrix (bs :. NIL)

mcons:: [a] -> NEmatrix a -> NEmatrix a
mcons xs (NEmatrix m) = NEmatrix(fromList xs :. m)

buildnematrix :: [[a]] -> NEmatrix a
buildnematrix [] = error "empty matrix"
buildnematrix [bs] = singleton(buildnerow bs)
buildnematrix (b:bs) = mcons b (buildnematrix bs)

S.M.Kahrs

tags

participants (1)