apart 0.1.0 → 0.1.1

raw patch · 13 files changed

+212/−33 lines, 13 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• Data/Apart/Apart.hs +5/−1
• Data/Apart/Combinators.hs +10/−7
• Data/Apart/Machinery/Moore.hs +8/−0
• Data/Apart/Shape.hs +11/−0
• Data/Apart/Structures/Stack.hs +10/−2
• Data/Apart/Structures/Tree/Binary/Rotation.hs +29/−0
• Data/Apart/Structures/Tree/Prefix.hs +46/−14
• Data/Apart/Structures/Tree/Rose.hs +4/−1
• Data/Apart/Usage/Blockchain.hs +51/−0
• Data/Apart/Usage/LRU.hs +21/−0
• Example/Main.hs +5/−5
• Test/Apart.hs +5/−0
• apart.cabal +7/−3

@@ -4,16 +4,20 @@ import Data.Bifoldable (Bifoldable (..)) import Data.Bifunctor (Bifunctor (..)) import Data.Bitraversable (Bitraversable (..))+import Data.Functor.Apply (Apply (..)) import Data.Kind (Type)  import Data.Apart.Shape (Shape (..))  -- | Structure with scattered segments.-data Apart t raw value = Apart+newtype Apart t raw value = Apart 	{ part :: (Cofree (Shape t raw) value) }  instance Functor t => Functor (Apart t raw) where 	fmap f (Apart structure) = Apart $ f <$> structure++instance Apply t => Apply (Apart t raw) where+	Apart fs <.> Apart structure = Apart $ fs <.> structure  instance Functor t => Bifunctor (Apart t) where 	bimap g f (Apart (x :< Ready values)) = Apart $

@@ -1,5 +1,6 @@-module Data.Apart.Combinators (Restorer, Materializer, recover, limit, fluent) where+module Data.Apart.Combinators (Restorer, Materializer, recover, limit, throughout, inmemory) where +import Control.Applicative (Alternative (..)) import Control.Comonad.Cofree (Cofree (..)) import Control.Monad (join) @@ -29,9 +30,11 @@ 	((<$>) . (<$>)) part $ traverse (limit (n - 1) convert) rest  -- | Traverse over scattered structure, including with all restored segments.-fluent :: (Traversable t, Monad g) => (value -> g res) -> Restorer g t raw value-	-> (Scattered (Cofree t) value raw) -> g (Cofree t res)-fluent for_value for_raw (Apart (x :< Ready values)) = (:<) <$> for_value x-	<*> (traverse (fluent for_value for_raw . Apart) values)-fluent for_value for_raw (Apart (x :< Converted raw)) = join $-	traverse for_value <$> ((:<) x <$> for_raw raw)+throughout :: (Traversable t, Monad g) => (value -> g result) -> Restorer g t raw value+	-> (Scattered (Cofree t) value raw) -> g (Cofree t result)+throughout f g (Apart (x :< Ready vs)) = (:<) <$> f x <*> (traverse (throughout f g . Apart) vs)+throughout f g (Apart (x :< Converted r)) = join $ traverse f <$> ((:<) x <$> g r)++inmemory :: (Functor t, Alternative t) => Apart t raw value -> Cofree t value+inmemory (Apart (x :< Ready xs)) = (:<) x $ inmemory . Apart <$> xs+inmemory (Apart (x :< Converted _)) = x :< empty

@@ -0,0 +1,8 @@+module Data.Apart.Machinery.Moore (Moore, dumb) where++import Control.Comonad.Cofree (Cofree (..))++type Moore a b = Cofree ((->) b) a++dumb :: a -> Moore a a+dumb x = x :< (const $ dumb x)

@@ -3,6 +3,8 @@ import Data.Bifoldable (Bifoldable (..)) import Data.Bifunctor (Bifunctor (..)) import Data.Bitraversable (Bitraversable (..))+import Data.Functor.Apply (Apply (..))+import Data.Functor.Alt (Alt (..)) import Data.Semigroup (Semigroup (..))  -- | Type that can tell you about aggregate state of your structure.@@ -17,6 +19,15 @@ instance Functor t => Functor (Shape t raw) where 	fmap f (Ready values)  = Ready $ f <$> values 	fmap f (Converted raw) = Converted raw++instance Apply t => Apply (Shape t raw) where+	Ready fs <.> Ready xs = Ready $ fs <.> xs+	Ready fs <.> Converted raw = Converted raw+	Converted raw <.> _ = Converted raw++instance Alt t => Alt (Shape t raw) where+	Converted raw <!> x = x+	Ready xs <!> _ = Ready xs  instance Foldable t => Foldable (Shape t raw) where 	foldr f acc (Ready values)  = foldr f acc values

@@ -1,12 +1,17 @@-module Data.Apart.Structures.Stack (Stack, insert, foldaway) where+module Data.Apart.Structures.Stack+	(Stack, insert, singleton, foldaway, final) where -import Control.Comonad.Cofree (Cofree (..))+import Control.Comonad.Cofree (Cofree (..), unwrap)+import Data.Functor.Contravariant (Predicate (..))  import Data.Apart.Apart (Segment (..))  -- | Or non-empty list. type Stack = Cofree Maybe +singleton :: a -> Stack a+singleton x = x :< Nothing+ insert :: a -> Stack a -> Stack a insert x = (:<) x . Just @@ -15,3 +20,6 @@ -- slightly as natural transformation foldaway :: Foldable t => t a -> Segment Stack a foldaway = foldr (\el -> Just . (:<) el) Nothing++final :: Eq a => Predicate (Stack a)+final = Predicate $ \s -> unwrap s == Nothing

@@ -0,0 +1,29 @@+module Data.Apart.Structures.Tree.Binary.Rotation+	(Rotate (..), rtt) where++import Control.Comonad (Comonad (..))+import Control.Comonad.Cofree (Cofree (..))+import Control.Lens ((<&>))+import Data.Functor.Bind (Bind (..))+import Data.Semigroup (Semigroup (..))++import Data.Apart.Apart (Segment (..))+import Data.Apart.Structures.Tree.Binary (Binary, Branches (..), ls, gt, height)++data Rotate+	= L -- ^ Simple left (AVL), left zig (Splay)+	| R -- ^ Simple right (AVL), right zig (Splay)+	| LR -- ^ Double right (AVL), right zig-zag (Splay)+	| RL -- ^ Double left (AVL), left zig-zag (Splay)+	| LL -- ^ Left zig-zig (Splay)+	| RR -- ^ Right zig-zig (Splay)++rtt :: Rotate -> Binary a -> Segment Binary a+rtt L t = (<&>) (extract <$> ls t) $ flip (:<) $ (gt t >>- gt)+	<> (Less $ (extract t) :< (ls t <> (gt t >>- ls)))+rtt R t = (<&>) (extract <$> gt t) $ flip (:<) $ (ls t >>- ls)+	<> (Greater $ (extract t) :< ((ls t >>- gt ) <> gt t))+rtt RL t = gt t >>- rtt L . (:<) (extract t) . (<>) (ls t) . rtt R+rtt LR t = ls t >>- rtt R . (:<) (extract t) . (<>) (gt t) . rtt L+rtt LL t = gt t >>- rtt L . (:<) (extract t) . (<>) (gt t) . rtt L+rtt RR t = ls t >>- rtt R . (:<) (extract t) . (<>) (ls t) . rtt R

@@ -1,12 +1,16 @@-module Data.Apart.Structures.Tree.Prefix (Prefix, Labeled (..), seek, insert) where+module Data.Apart.Structures.Tree.Prefix+	(Prefix, Labeled (..), singleton, seek, insert, crumbs) where  import Control.Applicative (Alternative (..))+import Control.Arrow ((&&&)) import Control.Comonad (Comonad (..)) import Control.Comonad.Cofree (Cofree (..), unwrap) import Control.Lens (Lens', (^.), (%~)) import Data.Maybe (isJust)-import Data.Function ((&)) import Data.Foldable (find)+import Data.Function ((&))+import Data.Functor.Contravariant (Predicate (..))+import Data.Functor.Contravariant.Divisible (Divisible (..)) import Data.Monoid (Monoid (..), (<>))  import Data.Apart.Structures.Stack (Stack)@@ -15,9 +19,6 @@  data Labeled s t a = Hop s (t a) deriving Show -symbol :: Lens' (Prefix s t a) s-symbol f (x :< Hop s ns) = (\new -> x :< Hop new ns) <$> f s- nodes :: Lens' (Prefix s t a) (t (Prefix s t a)) nodes f (x :< Hop s ns) = (\new -> x :< Hop s new) <$> f ns @@ -30,17 +31,48 @@ instance Traversable t => Traversable (Labeled s t) where 	traverse f (Hop s as) = Hop s <$> traverse f as -seek :: (Functor t, Foldable t, Eq s) => Stack s -> Prefix s t v -> Maybe v-seek (s :< Just ss) prefix@((==) s . flip (^.) symbol -> True) =+singleton :: Alternative t => s -> a -> Prefix s t a+singleton s v = v :< Hop s empty++-- | Prefix tree haven't nodes+deadend :: Foldable t => Predicate (Prefix s t a)+deadend = Predicate $ \(_ :< Hop _ ns) -> length ns == 0++-- | Key and current key of root matched+progress :: (Eq s, Foldable t) => Predicate (s, Prefix s t a)+progress = Predicate $ \(s, _ :< Hop s' ns) -> s == s'++-- | Keys matched and this is the end+exactly :: (Eq s, Foldable t) => Predicate (s, Prefix s t a)+exactly = divide (snd &&& id) deadend progress++seek :: (Functor t, Foldable t, Eq s)+	=> Stack s -> Prefix s t v -> Maybe v+seek (s :< Just ss) prefix@(getPredicate progress . (s,) -> True) = 	(<$>) extract $ find (isJust . seek ss) $ unwrap prefix-seek (s :< Nothing) prefix@((==) s . flip (^.) symbol -> True) = Just $ extract prefix-seek (s :< _) prefix@((==) s . flip (^.) symbol -> False) = Nothing+seek (s :< Nothing) prefix@(getPredicate progress . (s,) -> True) = Just $ extract prefix+seek (s :< _) prefix@(getPredicate progress . (s,) -> False) = Nothing  -- | You can insert value with @path + 1 symbol@ of existing @path@ in tree.-insert :: (Foldable t, Alternative t, Eq s) => Stack s -> v -> Prefix s t v -> Prefix s t v-insert (s :< _) x prefix@((==) s . flip (^.) symbol -> False) = prefix-insert (s :< Nothing) x prefix@((==) s . flip (^.) symbol -> True) = x :< unwrap prefix-insert (s :< Just ss@(s' :< Just _)) x prefix@((==) s . flip (^.) symbol -> True) =+insert :: (Foldable t, Alternative t, Eq s)+	=> Stack s -> v -> Prefix s t v -> Prefix s t v+insert (s :< _) x prefix@(getPredicate progress . (s,) -> False) = prefix+insert (s :< Nothing) x prefix@(getPredicate progress . (s,) -> True) = x :< unwrap prefix+insert (s :< Just ss@(s' :< Just _)) x prefix@(getPredicate progress . (,) s -> True) = 	prefix & nodes %~ (<$>) (insert ss x)-insert (s :< Just ss@(s' :< Nothing)) x prefix@((==) s . flip (^.) symbol -> True) =+insert (s :< Just ss@(s' :< Nothing)) x prefix@(getPredicate progress . (,) s -> True) = 	prefix & nodes %~ (<|>) (pure $ x :< Hop s' empty)+insert _ _ prefix = prefix++-- | Unlike @insert@, you can specify longest path, but a gap will be filled Monoid's empty values+crumbs :: (Foldable t, Alternative t, Eq s, Monoid v)+	=> Stack s -> v -> Prefix s t v -> Prefix s t v+crumbs (s :< _) x prefix@(getPredicate progress . (s,) -> False) = prefix+crumbs (s :< Just ss) x prefix@(getPredicate exactly . (,) s -> True) =+	(extract prefix) :< Hop s (pure $ crumbs ss x $ mempty :< Hop (extract ss) empty)+crumbs (s :< Nothing) x prefix@(getPredicate exactly . (,) s -> True) = x :< Hop s empty+crumbs (s :< Just ss@(s' :< Just _)) x prefix@(getPredicate progress . (,) s -> True) =+	prefix & nodes %~ (<$>) (crumbs ss x)+crumbs (s :< Just (s' :< Nothing)) x prefix@(getPredicate progress . (,) s -> True) =+	prefix & nodes %~ (<|>) (pure $ x :< Hop s' empty)+crumbs _ _ prefix = prefix

@@ -1,9 +1,12 @@-module Data.Apart.Structures.Tree.Rose (Rose, construct) where+module Data.Apart.Structures.Tree.Rose (Rose, singleton, construct) where  import Control.Applicative (Alternative (..)) import Control.Comonad.Cofree (Cofree (..), coiter)  type Rose t = Cofree t++singleton :: Alternative t => a -> Rose t a+singleton x = x :< empty  construct :: (Functor t, Alternative t) => a -> t a -> Rose t a construct x structure = (:<) x $ (<$>) (coiter $ const empty) structure

@@ -0,0 +1,51 @@+module Data.Apart.Usage.Blockchain+	(Transaction (..), Block, Blockchain, genesis, block, mainchain, verify) where++import Control.Comonad.Cofree (Cofree (..))+import Data.Bitraversable (Bitraversable (..))+import Data.Functor.Compose (Compose (..))++import Data.Apart (Apart (..), Shape (..), Scattered (..))+import Data.Apart.Structures.Stack (Stack)++type Account = Int+type Tokens = Int+data Connection+data Table++-- | Simplified transaction type, no certificates/keys.+data Transaction = Transaction+	{ from :: Account, amount :: Tokens, to :: Account }++-- | Block is just a bunch of transactions, no pointers/keys here.+type Block = Stack Transaction++-- | Our blockchain type is distributed - we really don't want to keep all chain in memory,+-- instead, we'll store balance table of all accounts in some database.+type Blockchain = Scattered Stack Block (Connection, Table)++-- | Let's suppose that genesis is a regular transaction,+-- but proceeded from magic account 0 to real accounts.+--+-- @'Transaction' 0 1000 1 ':<' 'Nothing'@+genesis :: Block+genesis = Transaction 0 1000 1 :< Nothing++-- | First real block, 1 sends 50 tokens to 4.+--+-- @'Transaction' 1 50 4 ':<' 'Nothing'@+block :: Block+block = Transaction 1 50 4 :< Nothing++-- | We're facing with increasing chain in memory, so, let's calculate UTXO+-- for each account and put this information somewhere else.+--+-- @'Apart' $ 'block' ':<' 'Converted' ...@+mainchain :: Blockchain+mainchain = Apart $ block :< Converted (undefined, undefined)++-- | Verifying block is just a calculation UTXO for each account that trying to send money,+-- so, we already have balance table and current block, the task becomes simple -+-- just match transactions and balances.+verify :: Stack Transaction -> Blockchain -> Compose IO Maybe Block+verify txs chain = undefined

@@ -0,0 +1,21 @@+module Data.Apart.Usage.LRU (LRU, cache) where++import Control.Comonad.Cofree (Cofree (..))+import Data.Functor.Alt (Alt (..))+import Data.Functor.Bind (Bind (..))++import Data.Apart (Segment (..))+import Data.Apart.Structures.Tree.Binary (Binary, Branches (..))+import Data.Apart.Structures.Tree.Binary.Splay (insert)++{-|+	In this usage example we'll try to implement LRU cache.+	This policy discards the least recently used items first,+	so we need to add priority for the most recently used elements.+	Very resembles behavoir of Splay trees, actually.+-}+type LRU a = Segment Binary a++-- | Insert sortable value to cache, aftear that, value moved to root+cache :: Ord a => a -> LRU a -> LRU a+cache x lru = (lru >>- insert x) <!> Less (x :< End)

@@ -1,7 +1,7 @@ import Control.Comonad.Cofree (Cofree (..)) import Data.Foldable (toList) -import Data.Apart (Apart (..), Shape (..), Scattered (..), Segment (..), limit, fluent, recover)+import Data.Apart (Apart (..), Shape (..), Scattered (..), Segment (..), limit, throughout, recover) import Data.Apart.Structures.Stack (Stack)  -- part of data structure in some file@@ -12,16 +12,16 @@ read_from_file fp = read @(Segment Stack Int) <$> readFile fp  -- the whole structure in memory-inmemory :: Stack Int-inmemory = 1 :< Just (2 :< Just (3 :< Just (4 :< Just (5 :< Nothing))))+in_memory :: Stack Int+in_memory = 1 :< Just (2 :< Just (3 :< Just (4 :< Just (5 :< Nothing))))  save_to_file :: FilePath -> Segment Stack Int -> IO FilePath save_to_file fp structure = writeFile fp (show structure) *> pure fp  main = do 	print "Splitting data structure based on limit, the rest should be putted in file"-	limit 4 (save_to_file "Example/backup.txt") inmemory >>= print . toList . part+	limit 4 (save_to_file "Example/backup.txt") in_memory >>= print . toList . part 	print "Recovering data structure, the rest of structure should be in file" 	recover read_from_file scattered >>= print . toList 	print "Traverse over structure with action, recover segments on the way"-	fluent print read_from_file scattered+	throughout print read_from_file scattered

@@ -7,6 +7,7 @@ import Test.Apart.Structures.Tree.Binary import Test.Apart.Structures.Tree.Binary.AVL import Test.Apart.Structures.Tree.Binary.Splay+import Test.Apart.Structures.Tree.Prefix  main = do 	hSetBuffering stdout LineBuffering@@ -27,3 +28,7 @@ 	checkParallel $ Group "Splay tree structure" [ 		( "Found element should be lifted to root" 		, found_element_should_be_lifted_to_root )]++	checkParallel $ Group "Prefix tree structure" [+		( "After successful insert length should be incremented"+		, after_successful_insert_length_should_be_incremented )]

@@ -1,7 +1,7 @@ name:                apart-version:             0.1.0+version:             0.1.1 synopsis:            Get all your structure and rip it apart.-homepage:            https://github.com/iokasimov/tree+homepage:            https://github.com/iokasimov/apart license:             BSD3 license-file:        LICENSE author:              Murat Kasimov@@ -28,8 +28,12 @@     Data.Apart.Structures.Tree.Rose,     Data.Apart.Structures.Tree.Prefix,     Data.Apart.Structures.Tree.Binary,+    Data.Apart.Structures.Tree.Binary.Rotation,     Data.Apart.Structures.Tree.Binary.AVL,-    Data.Apart.Structures.Tree.Binary.Splay+    Data.Apart.Structures.Tree.Binary.Splay,+    Data.Apart.Machinery.Moore,+    Data.Apart.Usage.Blockchain,+    Data.Apart.Usage.LRU   other-modules:     Data.Apart.Apart,     Data.Apart.Shape,