{- |
Module : Control.Comonad.Sheet.Manipulate
Description : Generic functions for manipulating multi-dimensional comonadic spreadsheets.
Copyright : Copyright (c) 2014 Kenneth Foner
Maintainer : kenneth.foner@gmail.com
Stability : experimental
Portability : non-portable
This module defines the 'take', 'view', 'go', and 'insert' functions generically for any dimensionality of sheet. These
constitute the preferred way of manipulating sheets, providing an interface to: take finite slices ('take'), infinite
slices ('view'), move to locations ('go'), and insert finite or infinite structures ('insert').
-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
module Control.Comonad.Sheet.Manipulate where
import Data.Stream.Tape
import Control.Comonad.Sheet.Indexed
import Data.Numeric.Witness.Peano
import Data.Functor.Nested
import Control.Comonad.Sheet.Reference
import Data.List.Indexed hiding ( replicate )
import Data.Stream ( Stream(..) , (<:>) )
import qualified Data.Stream as S
import Control.Applicative
import Prelude hiding ( take )
class Take r t where
-- | The type of an n-dimensional list extracted from an n-dimensional sheet. For instance:
--
-- > ListFrom Sheet2 a == [[a]]
type ListFrom t a
-- | Given a 'RefList' and an n-dimensional sheet, return an n-dimensional list corresponding to taking items from
-- the space until reaching the (relative or absolute) coordinates specified.
take :: RefList r -> t a -> ListFrom t a
class View r t where
-- | The type of an n-dimensional stream extracted from an n-dimensional sheet. For instance:
--
-- > StreamFrom Sheet2 a == Stream (Stream a)
type StreamFrom t a
-- | Given a 'RefList' and an n-dimensional sheet, return an n-dimensional stream corresponding to the "view" in the
-- direction specified by the sign of each of the coordinates. The direction implied by an absolute coordinate is
-- the direction from the current focus to that location.
view :: RefList r -> t a -> StreamFrom t a
class Go r t where
-- | Given a 'RefList' and an n-dimensional sheet, move to the location specified by the @RefList@ given.
go :: RefList r -> t a -> t a
-- | Combination of 'go' and 'take': moves to the location specified by the first argument, then takes the amount
-- specified by the second argument.
slice :: (Take r' t, Go r t) => RefList r -> RefList r' -> t a -> ListFrom t a
slice r r' = take r' . go r
-- | Use this to insert a (possibly nested) list-like structure into a (possibly many-dimensional) sheet.
-- Note that the depth of nesting of the structure being inserted must match the number of dimensions of the sheet
-- into which it is being inserted. Note also that the structure being inserted need not be a @Nested@ type; it
-- need only have enough levels of structure (i.e. number of nested lists) to match the dimensionality of the sheet.
insert :: (DimensionalAs x (t a), InsertNested l t, AsDimensionalAs x (t a) ~ l a) => x -> t a -> t a
insert l t = insertNested (l `asDimensionalAs` t) t
-- | Take (n + 1) things from a 'Tape', either in the rightward or leftward directions, depending on the sign of the
-- reference given. If the reference is @(Rel 0)@, return the empty list.
tapeTake :: Ref Relative -> Tape a -> [a]
tapeTake (Rel r) t | r > 0 = focus t : S.take r (viewR t)
tapeTake (Rel r) t | r < 0 = focus t : S.take (abs r) (viewL t)
tapeTake _ _ = []
instance Take Nil (Nested (Flat Tape)) where
type ListFrom (Nested (Flat Tape)) a = [a]
take _ _ = []
instance (Take Nil (Nested ts), Functor (Nested ts)) => Take Nil (Nested (Nest ts Tape)) where
type ListFrom (Nested (Nest ts Tape)) a = ListFrom (Nested ts) [a]
take _ = take (Rel 0 :-: ConicNil)
instance Take (Relative :-: Nil) (Nested (Flat Tape)) where
type ListFrom (Nested (Flat Tape)) a = [a]
take (r :-: _) (Flat t) = tapeTake r t
instance ( Functor (Nested ts), Take rs (Nested ts) )
=> Take (Relative :-: rs) (Nested (Nest ts Tape)) where
type ListFrom (Nested (Nest ts Tape)) a = ListFrom (Nested ts) [a]
take (r :-: rs) (Nest t) = take rs . fmap (tapeTake r) $ t
instance ( Take (Replicate (NestedCount ts) Relative) (Nested ts)
, Length r <= NestedCount ts
, ((NestedCount ts - Length r) + Length r) ~ NestedCount ts
) => Take r (Indexed ts) where
type ListFrom (Indexed ts) a = ListFrom (Nested ts) a
take r (Indexed i t) = take (heterogenize id (getMovement r i)) t
-- | Given a relative reference, either return the rightward-pointing stream or the leftward one, depending on the
-- sign of the reference. @(Rel 0)@ defaults to rightward.
tapeView :: Ref Relative -> Tape a -> Stream a
tapeView (Rel r) t | r >= 0 = focus t <:> viewR t
tapeView (Rel r) t | otherwise = focus t <:> viewL t
instance View Nil (Nested (Flat Tape)) where
type StreamFrom (Nested (Flat Tape)) a = Stream a
view _ (Flat t) = tapeView (Rel 0) t
instance (View Nil (Nested ts), Functor (Nested ts)) => View Nil (Nested (Nest ts Tape)) where
type StreamFrom (Nested (Nest ts Tape)) a = StreamFrom (Nested ts) (Stream a)
view _ = view (Rel 0 :-: ConicNil)
instance View (Relative :-: Nil) (Nested (Flat Tape)) where
type StreamFrom (Nested (Flat Tape)) a = (Stream a)
view (r :-: _) (Flat t) = tapeView r t
instance ( Functor (Nested ts), View rs (Nested ts) )
=> View (Relative :-: rs) (Nested (Nest ts Tape)) where
type StreamFrom (Nested (Nest ts Tape)) a = StreamFrom (Nested ts) (Stream a)
view (r :-: rs) (Nest t) = view rs . fmap (tapeView r) $ t
instance ( View (Replicate (NestedCount ts) Relative) (Nested ts)
, Length r <= NestedCount ts
, ((NestedCount ts - Length r) + Length r) ~ NestedCount ts
) => View r (Indexed ts) where
type StreamFrom (Indexed ts) a = StreamFrom (Nested ts) a
view r (Indexed i t) = view (heterogenize id (getMovement r i)) t
-- | Given a relative reference, move that much in a 'Tape', either rightward or leftward depending on sign.
tapeGo :: Ref Relative -> Tape a -> Tape a
tapeGo (Rel r) = fpow (abs r) (if r > 0 then moveR else moveL)
where fpow n = foldr (.) id . replicate n -- iterate a function n times
instance Go (Relative :-: Nil) (Nested (Flat Tape)) where
go (r :-: _) (Flat t) = Flat $ tapeGo r t
instance Go Nil (Nested ts) where go _ = id
instance (Go rs (Nested ts), Functor (Nested ts)) => Go (Relative :-: rs) (Nested (Nest ts Tape)) where
go (r :-: rs) (Nest t) = Nest . go rs . fmap (tapeGo r) $ t
instance ( Go (Replicate (NestedCount ts) Relative) (Nested ts)
, Length r <= NestedCount ts
, ((NestedCount ts - Length r) + Length r) ~ NestedCount ts
, ReifyNatural (NestedCount ts) )
=> Go r (Indexed ts) where
go r (Indexed i t) =
let move = getMovement r i
in Indexed (merge move i) (go (heterogenize id move) t)
-- | A @(Signed f a)@ is an @(f a)@ annotated with a sign: either @Positive@ or @Negative@. This is a useful type for
-- specifying the directionality of insertions into sheets. By wrapping a list or stream in a @Negative@ and then
-- inserting it into a sheet, you insert it in the opposite direction to the usual one: leftward, upward, inward...
data Signed f a = Positive (f a)
| Negative (f a)
deriving ( Eq , Ord , Show )
-- | In order to insert an n-dimensional list-like structure @(l a)@ into an n-dimensional @Tape@, it's only necessary
-- to define how to insert a 1-dimensional @(l a)@ into a 1-dimensional @Tape@. Add instances of this class if you
-- want to be able to insert custom types into a sheet.
class InsertBase l where
insertBase :: l a -> Tape a -> Tape a
-- | Inserting a @Tape@ into another @Tape@ replaces the latter with the former completely.
instance InsertBase Tape where
insertBase t _ = t
-- | Inserting a @Stream@ into a @Tape@ replaces the focus and right side of the @Tape@ with the contents of the stream.
instance InsertBase Stream where
insertBase (Cons x xs) (Tape ls _ _) = Tape ls x xs
-- | Inserting a @Signed Stream@ into a @Tape@ either behaves just like inserting a regular @Stream@, or (in the @Negative@ case) inserts the stream to the left.
instance InsertBase (Signed Stream) where
insertBase (Positive (Cons x xs)) (Tape ls _ _) = Tape ls x xs
insertBase (Negative (Cons x xs)) (Tape _ _ rs) = Tape xs x rs
-- | Inserting a list into a @Tape@ prepends the contents of the list rightwards in the @Tape@, pushing the old focus
-- element rightward (i.e. the head of the list becomes the new focus).
instance InsertBase [] where
insertBase [] t = t
insertBase (x : xs) (Tape ls c rs) =
Tape ls x (S.prefix xs (Cons c rs))
-- | Inserting a @Signed []@ into a @Tape@ either behaves just like inserting a regular list, or (in the @Negative@ case) inserts the list to the left.
instance InsertBase (Signed []) where
insertBase (Positive []) t = t
insertBase (Negative []) t = t
insertBase (Positive (x : xs)) (Tape ls c rs) =
Tape ls x (S.prefix xs (Cons c rs))
insertBase (Negative (x : xs)) (Tape ls c rs) =
Tape (S.prefix xs (Cons c ls)) x rs
-- | This typeclass is the inductive definition for inserting things into higher-dimensional spaces. To make new types
-- insertable, add instances of 'InsertBase', not @InsertNested@.
class InsertNested l t where
insertNested :: l a -> t a -> t a
instance (InsertBase l) => InsertNested (Nested (Flat l)) (Nested (Flat Tape)) where
insertNested (Flat l) (Flat t) = Flat $ insertBase l t
instance ( InsertBase l , InsertNested (Nested ls) (Nested ts)
, Functor (Nested ls) , Applicative (Nested ts) )
=> InsertNested (Nested (Nest ls l)) (Nested (Nest ts Tape)) where
insertNested (Nest l) (Nest t) =
Nest $ insertNested (insertBase <$> l) (pure id) <*> t
instance (InsertNested l (Nested ts)) => InsertNested l (Indexed ts) where
insertNested l (Indexed i t) = Indexed i (insertNested l t)
-- | @DimensionalAs@ provides a mechanism to "lift" an n-deep nested structure into an explicit @Nested@ type. This
-- is the way in which raw lists-of-lists-of-lists, etc. can be inserted (without manual annotation of nesting depth)
-- into a sheet.
class DimensionalAs x y where
type AsDimensionalAs x y
-- | @x `asDimensionalAs` y@ applies the appropriate constructors for 'Nested' to @x@ a number of times equal to
-- the number of dimensions of @y@. For instance:
--
-- > [['x']] `asDimensionalAs` Nest (Flat [['y']]) == Nest (Flat [['x']])
asDimensionalAs :: x -> y -> x `AsDimensionalAs` y
-- | In the case of a @Nested@ structure, @asDimensionalAs@ defaults to @asNestedAs@.
instance (NestedAs x (Nested ts y), AsDimensionalAs x (Nested ts y) ~ AsNestedAs x (Nested ts y)) => DimensionalAs x (Nested ts y) where
type x `AsDimensionalAs` (Nested ts a) = x `AsNestedAs` (Nested ts a)
asDimensionalAs = asNestedAs
-- | @DimensionalAs@ also knows the dimensionality of an 'Indexed' sheet as well as regular @Nested@ structures.
instance (NestedAs x (Nested ts y)) => DimensionalAs x (Indexed ts y) where
type x `AsDimensionalAs` (Indexed ts a) = x `AsNestedAs` (Nested ts a)
x `asDimensionalAs` (Indexed i t) = x `asNestedAs` t