diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,28 @@ +Copyright (c) 2014, Eric McCorkle +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +* Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. + +* Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + +* Neither the name of the {organization} nor the names of its + contributors may be used to endorse or promote products derived from + this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/enumeration.cabal b/enumeration.cabal new file mode 100644 --- /dev/null +++ b/enumeration.cabal @@ -0,0 +1,60 @@ +Name: enumeration +Category: Data, Serialization, Test, Testing +Version: 0.1.0 +License: BSD3 +License-File: LICENSE +Author: Eric McCorkle +Maintainer: Eric McCorkle +Stability: Beta +Synopsis: A practical API for building recursive enumeration + procedures and enumerating datatypes. +Homepage: https://github.com/emc2/enumeration +Bug-Reports: https://github.com/emc2/enumeration/issues +Copyright: Copyright (c) 2014 Eric McCorkle. All rights reserved. +Description: + A library providing tools for building enumeration procedures for recursively- + enumerable datatypes. This is built atop the arith-encode library, and makes + use of the natural number isomorphisms it provides to represent individual + decisions in the enumeration procedure. As such, each enumeration result is + denoted by a unique path, consisting of a sequence of natural numbers. An + enumeration procedure is simply a (partial) mapping between sequences + and a given datatype. + . + The library provides functionality for constructing enumeration procedures, + as well as facilities for performing enumeration according to various search + strategies (depth-first, breadth-first, etc). These procedures can also be + "warm-started" using a path or a set of paths. Obvious applications include + exhaustive search, testing, automated proving, and others. + . + Additionally, as a path is simply a sequence of natural numbers, an + enumeration procedure can double as a binary serializer/deserializer. For + well-behaved enumeration procedures (ie. those where the mapping is an + isomorphism), the resulting binary format should be very nearly succinct. + . + This is the first release candidate for 1.0 (initial release) +Build-type: Simple +Cabal-version: >= 1.16 + +Source-Repository head + Type: git + Location: git@github.com:emc2/enumeration.git + +Test-Suite UnitTest + default-language: Haskell2010 + type: exitcode-stdio-1.0 + Main-Is: UnitTest.hs + hs-source-dirs: src test + build-depends: base >= 4.4.0 && < 5, Cabal >= 1.16.0, HUnit-Plus, arith-encode, + containers, binary, arithmoi, heap + ghc-options: -fhpc + +Library + default-language: Haskell2010 + hs-source-dirs: src + build-depends: base >= 4.4.0 && < 5, Cabal >= 1.16.0, containers, arith-encode, + binary, arithmoi, heap + exposed-modules: Data.Enumeration + Data.Enumeration.Binary + Data.Enumeration.Traversal + other-modules: + Data.Enumeration.Traversal.Class diff --git a/src/Data/Enumeration.hs b/src/Data/Enumeration.hs new file mode 100644 --- /dev/null +++ b/src/Data/Enumeration.hs @@ -0,0 +1,321 @@ +-- Copyright (c) 2014 Eric McCorkle. All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions +-- are met: +-- +-- 1. Redistributions of source code must retain the above copyright +-- notice, this list of conditions and the following disclaimer. +-- +-- 2. Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in the +-- documentation and/or other materials provided with the distribution. +-- +-- 3. Neither the name of the author nor the names of any contributors +-- may be used to endorse or promote products derived from this software +-- without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE AUTHORS AND CONTRIBUTORS ``AS IS'' +-- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS +-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +-- SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +-- LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF +-- USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND +-- ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +-- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT +-- OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF +-- SUCH DAMAGE. +{-# OPTIONS_GHC -Wall -Werror -funbox-strict-fields #-} +{-# LANGUAGE DeriveDataTypeable #-} + +-- | Utilities for constructing enumerations over datatypes. +-- +-- An 'Enumeration' is a mapping between a particular datatype and a +-- 'Path', which consists of a list of natural numbers. Conceptually, +-- we can think of all the values of a given datatype as being +-- organized into a tree, with nodes representing decisions that +-- narrow down the choices. In such a scheme, a 'Path' represents a +-- path through the tree to a single value, and an 'Enumeration' is a +-- procedure for converting a 'Path' to and from a value. +-- +-- +-- An 'Enumeration' has two key functions: 'fromPath' and 'toPath', +-- which translate between paths and instances of a datatype. These +-- functions are expected to be inverses; or: +-- +-- * @fromPath (toPath v) == v@ for all values in the domain +-- +-- Beyond this, there are no additional restrictions. Specifically, +-- two paths /may/ map to the same value. +-- +-- +-- The 'numBranches' function indicates the maximum value of the first +-- path element for an 'Enumeration'. The minimum value is always 0, +-- and all values between 0 and 'numBranches' must be valid. If there +-- is no upper bound on the value of the first path element, +-- 'numBranches' returns 'Nothing'. The 'toSizedPath' maps a value to +-- a path, which also contains the result of 'numBranches' at each +-- step in the path. +-- +-- +-- The 'withPrefix' function supplies a partial path to an +-- 'Enumeration', yielding a new 'Enumeration' that maps each value to +-- the same path(s) as the original 'Enumeration', with the prefix +-- added or removed. More formally, if +-- +-- * @subenc = withPrefix enc prepath@ +-- +-- Then +-- +-- * @toPath enc val == prepath ++ toPath subenc val@ +-- +-- * @fromPath enc (prepath ++ subpath) == fromPath subenc subpath@ +-- +-- With multiple uses of 'withPrefix', the following must be true: +-- +-- * @withPrefix (withPrefix enc path1) path2 == withPrefix enc (path1 ++ path2)@ +-- +-- Finally, if a complete path is given to 'withPrefix', then the +-- result is a singleton encoding that gives the value associated with +-- that path. That is: +-- +-- * @fromPath enc fullpath == fromPath (withPrefix enc fullpath) []@ +-- +-- This provides \"warm-start\" functionality for 'Enumeration's. +-- When translating a large number of 'Path's with the same prefix, it +-- will generally be much more efficient to use 'withPrefix' and use +-- the resulting 'Enumeration' than to translate the 'Path's directly. +-- +-- +-- The 'prefix' function gives the current prefix for an +-- 'Enumeration'. The following rule describes the relationship +-- between 'prefix' and 'withPrefix': +-- +-- * @prefix (withPrefix enc prepath) == prepath@ +-- +-- +-- 'Enumeration's are similar to 'Encoding's from the arith-encode +-- library, except 'Enumeration's are generally more flexible, and can +-- more easily accomodate complex datatypes with invariants. However, +-- as 'Path's are constructed from natural numbers, we can create an +-- 'Enumeration' using a series of 'Encoding's for intermediate data. +-- The functions in this module provide the ability to construct +-- 'Enumeration's using 'Encoding's +-- +-- A singleton 'Enumeration' can be constructed using the 'singleton' +-- and 'singletonWithPrefix' functions. +-- +-- An 'Encoding' for a datatype can be converted into an 'Enumeration' +-- (where all paths have a single element) using the 'fromEncoding' +-- and 'fromEncodingWithPrefix' functions. +-- +-- The 'step' and 'stepWithPrefix' functions construct an +-- 'Enumeration' from an 'Encoding' for an intermediate value, and a +-- generator function that produces an 'Enumeration' from the +-- intermediate value. +-- +-- The @withPrefix@ variants for each of these take a prefix path, +-- where the non-@withPrefix@ variants set the prefix to @[]@. +module Data.Enumeration( + -- * Definitions + Enumeration, + Path, + BadPath(..), + IllegalArgument(..), + + -- ** Using Enumerations + fromPath, + toPath, + toSizedPath, + withPrefix, + numBranches, + prefix, + + -- * Constructions + singleton, + singletonWithPrefix, + fromEncoding, + fromEncodingWithPrefix, + step, + stepWithPrefix + ) where + +import Control.Exception +import Data.List +import Data.ArithEncode hiding (singleton) +import Data.Typeable + +-- | A path that uniquely identifies a value in an @Enumeration@. +type Path = [Integer] + +-- | A datatype that represents a mapping between @Path@s and @ty@s. +-- Note that unlike @Encoding@s, not all @Path@s are necessarily +-- valid. +data Enumeration ty = + Enumeration { + -- | Convert a @ty@ to a @Path@ + toPath :: !(ty -> Path), + -- | Convert to a list of pairs, where the @fst@ holds + -- the path entry, and @snd@ holds @numBranches@. This is used + -- primarily for encoding values as binary. + toSizedPath :: !(ty -> [(Integer, Maybe Integer)]), + -- | Generate a @ty@ from a @Path@ + fromPath :: !(Path -> ty), + -- | Given a prefix path, get an enumeration that generates @ty@s + -- from the rest of the path. + withPrefix :: !(Path -> Enumeration ty), + -- | Get the upper bound on values for the first path component, + -- or @Nothing@ if there is no bound. + numBranches :: !(Maybe Integer), + -- | The prefix path. + prefix :: !Path + } + +-- | An exception thrown when a 'Path' is invalid. +data BadPath = BadPath String + deriving Typeable + +instance Show BadPath where + show (BadPath "") = "Bad Path" + show (BadPath msg) = "Bad Path: " ++ msg + +instance Exception BadPath + +showPath :: Path -> String +showPath = intercalate "." . map show + +-- | Create an 'Enumeration' with an empty prefix that maps a single +-- value to and from the empty path. Equivalent to +-- @singletonWithPrefix []@ +singleton :: Eq ty => + ty + -- ^ The value to map to and from the empty path. + -> Enumeration ty +singleton = singletonWithPrefix [] + +-- | Create an 'Enumeration' with a given prefix path that maps a +-- single value to and from the empty path. +singletonWithPrefix :: Eq ty => Path -> ty -> Enumeration ty +singletonWithPrefix prefixPath val = + let + showCompletePath path = showPath (prefixPath ++ path) + + fromPathFunc [] = val + fromPathFunc path = + throw $! BadPath $! "Extra path elements " ++ showCompletePath path + + toPathFunc val' + | val' == val = [] + | otherwise = throw $! IllegalArgument "Bad argument to singleton" + + toSizedPathFunc val' + | val' == val = [] + | otherwise = throw $! IllegalArgument "Bad argument to singleton" + + withPrefixFunc [] = out + withPrefixFunc path = + throw $! BadPath $! "Extra path elements " ++ showCompletePath path + + out = Enumeration { fromPath = fromPathFunc, toPath = toPathFunc, + withPrefix = withPrefixFunc, numBranches = Just 0, + prefix = prefixPath, toSizedPath = toSizedPathFunc } + in + out + +-- | Create an 'Enumeration' with an empty prefix from a single +-- 'Encoding'. The 'Path' will always be of length 1, and contains +-- the encoded value. +fromEncoding :: Eq ty => + Encoding ty + -- ^ The 'Encoding' to use + -> Enumeration ty +fromEncoding = fromEncodingWithPrefix [] + +-- | Create an 'Enumeration' with a given prefix from a single +-- 'Encoding'. The 'Path' will always be of length 1, and contains +-- the encoded value. +fromEncodingWithPrefix :: Eq ty => Path -> Encoding ty -> Enumeration ty +fromEncodingWithPrefix prefixPath enc = + let + fromPathFunc [encoded] = decode enc encoded + fromPathFunc [] = throw $! BadPath "Path too short" + fromPathFunc (_ : path) = + throw $! BadPath $! "Extra path elements " ++ showPath path + + toPathFunc val = [encode enc val] + toSizedPathFunc val = [(encode enc val, size enc)] + + withPrefixFunc newPrefix @ [encoded] = + singletonWithPrefix (prefixPath ++ newPrefix) (decode enc encoded) + withPrefixFunc [] = out + withPrefixFunc (_ : path) = + throw $! BadPath $! "Extra path elements " ++ showPath path + + out = Enumeration { fromPath = fromPathFunc, toPath = toPathFunc, + withPrefix = withPrefixFunc, numBranches = size enc, + prefix = prefixPath, toSizedPath = toSizedPathFunc } + in + out + +-- | Create an 'Enumeration' with an empty prefix that uses an +-- 'Encoding' to convert the first element of the path to an interim +-- value, then uses that value to construct an 'Enumeration' to decode +-- the rest of the path. +step :: Encoding ty1 + -- ^ The encoding for the first type. + -> (Path -> ty1 -> Enumeration ty2) + -- ^ A function that produces an enumeration from the first type. + -> (ty2 -> ty1) + -- ^ A function that extracts the first type from the second. + -> Enumeration ty2 +step = stepWithPrefix [] + +-- | Create an 'Enumeration' with a prefix that uses an 'Encoding' to +-- convert the first element of the path to an interim value, then +-- uses that value to construct an 'Enumeration' to decode the rest of +-- the path. +stepWithPrefix :: Path + -- ^ The prefix path. + -> Encoding ty1 + -- ^ The 'Encoding' for the first type. + -> (Path -> ty1 -> Enumeration ty2) + -- ^ A function that produces an enumeration from the first type. + -> (ty2 -> ty1) + -- ^ A function that extracts the first type from the second. + -> Enumeration ty2 +stepWithPrefix prefixPath enc build extract = + let + fromPathFunc (first : rest) = + fromPath (build prefixPath (decode enc first)) rest + fromPathFunc [] = throw $! BadPath "Path too short" + + toPathFunc val = + let + extracted = extract val + inner = build prefixPath extracted + in + encode enc extracted : toPath inner val + + toSizedPathFunc val = + let + extracted = extract val + inner = build prefixPath extracted + in + (encode enc extracted, size enc) : toSizedPath inner val + + withPrefixFunc (first : rest) = + let + extracted = decode enc first + newPrefix = prefixPath ++ [first] + inner = build newPrefix extracted + in + withPrefix inner rest + withPrefixFunc [] = out + + out = Enumeration { fromPath = fromPathFunc, toPath = toPathFunc, + withPrefix = withPrefixFunc, numBranches = size enc, + prefix = prefixPath, toSizedPath = toSizedPathFunc } + in + out diff --git a/src/Data/Enumeration/Binary.hs b/src/Data/Enumeration/Binary.hs new file mode 100644 --- /dev/null +++ b/src/Data/Enumeration/Binary.hs @@ -0,0 +1,192 @@ +-- Copyright (c) 2014 Eric McCorkle. All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions +-- are met: +-- +-- 1. Redistributions of source code must retain the above copyright +-- notice, this list of conditions and the following disclaimer. +-- +-- 2. Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in the +-- documentation and/or other materials provided with the distribution. +-- +-- 3. Neither the name of the author nor the names of any contributors +-- may be used to endorse or promote products derived from this software +-- without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE AUTHORS AND CONTRIBUTORS ``AS IS'' +-- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS +-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +-- SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +-- LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF +-- USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND +-- ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +-- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT +-- OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF +-- SUCH DAMAGE. +{-# OPTIONS_GHC -Wall -Werror #-} + +-- | Functions for binary serialization/deserialization of datatypes +-- using an 'Enumeration'. These functions write out/read in binary +-- data as a sequence of natural numbers representing a path (using +-- the same coding scheme as "Data.Encoding.Binary"). +module Data.Enumeration.Binary( + putWithEnumeration, + getWithEnumeration + ) where + +import Data.Binary.Get hiding (remaining) +import Data.Binary.Put +import Data.Bits +import Data.Enumeration +import Math.NumberTheory.Logarithms + +-- Emit a natural number as a sequence of some number of bytes +putNatural :: Int -> Integer -> Put +putNatural 0 0 = return () +putNatural 0 _ = error "Data remaining at end of encoding" +putNatural remaining natural + | remaining > 8 = + let + output = fromInteger (natural .&. 0xffffffffffffffff) + rest = natural `shiftR` 64 + in do + putWord64le output + putNatural (remaining - 8) rest + | remaining > 4 = + let + output = fromInteger (natural .&. 0xffffffff) + rest = natural `shiftR` 32 + in do + putWord32le output + putNatural (remaining - 4) rest + | remaining > 2 = + let + output = fromInteger (natural .&. 0xffff) + rest = natural `shiftR` 16 + in do + putWord16le output + putNatural (remaining - 2) rest + | otherwise = + let + output = fromInteger (natural .&. 0xff) + rest = natural `shiftR` 8 + in do + putWord8 output + putNatural (remaining - 1) rest + +-- | Use an 'Enumeration' to write out a @ty@ as binary data +putWithEnumeration :: Enumeration ty -> ty -> Put +putWithEnumeration enum = + let + putWithEnumeration' [] = return () + putWithEnumeration' ((encoded, branches) : rest) = + case branches of + Just 0 -> return () + Just 1 -> putWithEnumeration' rest + Just finitesize -> + let + bytes = (integerLog2 (finitesize - 1) `quot` 3) + 1 + in do + putNatural bytes encoded + putWithEnumeration' rest + Nothing -> + do + if encoded < 64 + then + putWord8 (fromInteger encoded `shiftL` 2) + else + let + bytes = (integerLog2 (encoded - 1) `quot` 3) + 1 + in do + if bytes <= 64 + then putWord8 (fromIntegral (((bytes - 1) `shiftL` 2) .|. + 0x1)) + else if bytes <= 16384 + then + putWord16le (fromIntegral (((bytes - 1) `shiftL` 2) .|. + 0x2)) + else + putWord64le (fromIntegral (((bytes - 1) `shiftL` 2) .|. + 0x3)) + putNatural bytes encoded + putWithEnumeration' rest + in + putWithEnumeration' . toSizedPath enum + +-- Read in a natural number as a sequence of some number of bytes +getNatural :: Int -> Get Integer +getNatural bytes = + let + getNatural' :: Integer -> Int -> Get Integer + getNatural' accum count + | count + 8 < bytes = + do + input <- getWord64le + getNatural' ((toInteger input `shiftL` (count * 8)) .|. accum) + (count + 8) + | count + 4 < bytes = + do + input <- getWord32le + getNatural' ((toInteger input `shiftL` (count * 8)) .|. accum) + (count + 4) + | count + 2 < bytes = + do + input <- getWord16le + getNatural' ((toInteger input `shiftL` (count * 8)) .|. accum) + (count + 2) + | count < bytes = + do + input <- getWord8 + getNatural' ((toInteger input `shiftL` (count * 8)) .|. accum) + (count + 1) + | otherwise = return accum + in + getNatural' 0 0 + +-- | Use an 'Enumeration' to extract a @ty@ from binary data. +getWithEnumeration :: Enumeration ty -> Get ty +getWithEnumeration enum = + case numBranches enum of + Just 0 -> return (fromPath enum []) + Just 1 -> getWithEnumeration (withPrefix enum [0]) + Just finitesize -> + let + bytes = (integerLog2 (finitesize - 1) `quot` 3) + 1 + in do + encoded <- getNatural bytes + getWithEnumeration (withPrefix enum [encoded]) + -- Arbitrary-length naturals are encoded with a more complex + -- scheme. The first two bits are a tag, which tells how to + -- interpret the rest. + Nothing -> + do + firstbyte <- lookAhead getWord8 + encoded <- + case firstbyte .&. 0x03 of + -- Naturals less than 64 get packed into the same byte as + -- the tag + 0x0 -> + do + datafield <- getWord8 + return (toInteger (datafield `shiftR` 2)) + -- One-byte length field, and then up to 64 bytes of data + 0x1 -> + do + lenfield <- getWord8 + getNatural (fromIntegral (lenfield `shiftR` 2) + 1) + -- Two-byte length field, and then up to 16384 bytes of data + 0x2 -> + do + lenfield <- getWord16le + getNatural (fromIntegral (lenfield `shiftR` 2) + 1) + -- Eight-byte length field, and then data + 0x3 -> + do + lenfield <- getWord64le + getNatural (fromIntegral (lenfield `shiftR` 2) + 1) + _ -> error "Impossible case" + getWithEnumeration (withPrefix enum [encoded]) diff --git a/src/Data/Enumeration/Traversal.hs b/src/Data/Enumeration/Traversal.hs new file mode 100644 --- /dev/null +++ b/src/Data/Enumeration/Traversal.hs @@ -0,0 +1,204 @@ +-- Copyright (c) 2014 Eric McCorkle. All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions +-- are met: +-- +-- 1. Redistributions of source code must retain the above copyright +-- notice, this list of conditions and the following disclaimer. +-- +-- 2. Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in the +-- documentation and/or other materials provided with the distribution. +-- +-- 3. Neither the name of the author nor the names of any contributors +-- may be used to endorse or promote products derived from this software +-- without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE AUTHORS AND CONTRIBUTORS ``AS IS'' +-- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS +-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +-- SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +-- LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF +-- USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND +-- ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +-- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT +-- OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF +-- SUCH DAMAGE. +{-# OPTIONS_GHC -Wall -Werror -funbox-strict-fields #-} + +-- | Functionality for traversing an 'Enumeration'. +-- +-- This module provides a typeclass, 'Traversal', which represents a +-- traversal scheme for 'Enumeration's. Traversals should be largely +-- independent of the 'Enumeration', though some variants like +-- 'Prioritized' cannot be wholly independent. +-- +-- Three 'Traversal' instances are provided by this module: +-- 'DepthFirst', 'BreadthFirst', and 'Prioritized'. All traversals +-- work by maintaining a set of positions, which consist of an +-- 'Enumeration' and an index (the next value to give as a first path +-- element). At each step, some position is \"expanded\" by replacing +-- it with two positions: one with the index as an additional prefix +-- element, and one with the index incremented. +-- +-- 'DepthFirst' is a simple depth-first scheme. It is not guaranteed +-- to reach all elements, and in some 'Enumeration's, it may never +-- produce an answer. +-- +-- 'BreadthFirst' is a breadth-first scheme, which tends to be +-- better-behaved than 'DepthFirst'. It explores paths in ascending +-- order of path length. For 'Enumeration's with infinite-sized +-- branches, its behavior is not strictly breadth-first (as this would +-- never yield an answer), but it should still behave well for this +-- case. +-- +-- 'Prioritized' is a scheme that uses a scoring function to rank +-- paths. At each step, it will select the \"best\" (highest-ranked) +-- option and expand it. +module Data.Enumeration.Traversal( + Traversal(..), + DepthFirst, + BreadthFirst, + Prioritized, + scoring, + mkPrioritizedTraversal + ) where + +import Data.Enumeration +import Data.Enumeration.Traversal.Class +import Data.Heap(MaxPrioHeap) +import Data.Sequence(Seq, (<|), (|>), ViewL(..), viewl) + +import qualified Data.Heap as Heap +import qualified Data.Sequence as Sequence + +-- | Depth-first traversal. Note that this style of traversal is not +-- guaranteed to be complete (it may deep-dive and never visit some +-- possibilities). However, this implementation should continue +-- producing results even with infinite-sized branches, so long as the +-- depth of any one path isn't too great. +newtype DepthFirst ty = DepthFirst { dfStack :: [(Enumeration ty, Integer)] } + +instance Traversal DepthFirst where + mkTraversal enum = DepthFirst { dfStack = [(enum, 0)] } + + getNext DepthFirst { dfStack = [] } = Nothing + getNext DepthFirst { dfStack = (enum, curr) : rest } = + case numBranches enum of + -- For a leaf, produce a result + Just 0 -> Just (fromPath enum [], prefix enum, + DepthFirst { dfStack = rest }) + Just high + -- If we are exhausting the current step, proceed directly to + -- the next level + | curr + 1 >= high -> + getNext DepthFirst { dfStack = (withPrefix enum [curr], 0) : rest } + -- Otherwise, keep it on the stack. + | otherwise -> + getNext DepthFirst { dfStack = (withPrefix enum [curr], 0) : + (enum, curr + 1) : rest } + -- When there's a step with infinite branches, go ahead and + -- jettison the rest of the stack; we'll never get to it + -- anyway. + Nothing -> + getNext DepthFirst { dfStack = [(withPrefix enum [curr], 0), + (enum, curr + 1)] } + + +-- | Breadth-first traversal. This style of traversal is guaranteed +-- to be complete- that is, it will visit every possibility +-- eventually. However, it may take a very long time to reach any +-- given possibility. +newtype BreadthFirst ty = + BreadthFirst { bfQueue :: Seq (Enumeration ty, Integer) } + +instance Traversal BreadthFirst where + mkTraversal enum = BreadthFirst { bfQueue = Sequence.singleton (enum, 0) } + + getNext BreadthFirst { bfQueue = queue } = + case viewl queue of + (enum, curr) :< rest -> + case numBranches enum of + -- For a leaf, produce a result + Just 0 -> Just (fromPath enum [], prefix enum, + BreadthFirst { bfQueue = rest }) + Just high + -- If we are exhausting the current head of the queue, remove it + | curr + 1 >= high -> + getNext BreadthFirst { bfQueue = rest |> + (withPrefix enum [curr], 0) } + -- Otherwise, keep it on the queue + | otherwise -> + getNext BreadthFirst { bfQueue = ((enum, curr + 1) <| rest) |> + (withPrefix enum [curr], 0) } + -- If there's a step with infinite branches, cycle it to the + -- back of the queue, so we don't deep-dive into it. + Nothing -> + getNext BreadthFirst { bfQueue = rest |> + (withPrefix enum [curr], 0) |> + (enum, curr + 1) } + EmptyL -> Nothing + +-- | Prioritized traversal. Will always pick the highest-scored +-- option. Completeness depends entirely on the scoring function. +data Prioritized ty = + Prioritized { + -- | The scoring function used in a 'Prioritized' traversal scheme. + scoring :: !((Enumeration ty, Integer) -> Float), + priHeap :: !(MaxPrioHeap Float (Enumeration ty, Integer)) + } + +-- | Create a prioritized traversal with a given scoring function. +mkPrioritizedTraversal :: ((Enumeration ty, Integer) -> Float) + -- ^ The scoring function to use. + -> Enumeration ty + -- ^ The enumeration to use. + -> Prioritized ty +mkPrioritizedTraversal scorefunc enum = + let + initial = (enum, 0) + scored = (scorefunc initial, initial) + in + Prioritized { scoring = scorefunc, priHeap = Heap.singleton scored } + +inverseDepth :: (Enumeration ty, Integer) -> Float +inverseDepth (enum, curr) = + case numBranches enum of + Just finitemax -> -(fromIntegral (length (prefix enum)) - + (fromIntegral curr / fromIntegral finitemax)) + Nothing -> -(fromIntegral (length (prefix enum))) + +instance Traversal Prioritized where + mkTraversal = mkPrioritizedTraversal inverseDepth + + getNext pri @ Prioritized { scoring = scorefunc, priHeap = heap } = + case Heap.view heap of + Just ((_, (enum, curr)), rest) -> + case numBranches enum of + -- For a leaf, produce a result + Just 0 -> Just (fromPath enum [], prefix enum, + pri { priHeap = rest }) + -- If we're exhausting the current step, don't keep it in the heap + Just high | curr + 1 >= high -> + let + newelem = (withPrefix enum [curr], 0) + scored = (scorefunc newelem, newelem) + withNew = Heap.insert scored rest + in + getNext pri { priHeap = withNew } + -- Otherwise, insert the incremented current and the new + -- branch into the heap. + _ -> + let + newelem = (withPrefix enum [curr], 0) + scored = (scorefunc newelem, newelem) + increment = (enum, curr + 1) + incscored = (scorefunc increment, increment) + withNew = Heap.insert scored rest + withInc = Heap.insert incscored withNew + in + getNext pri { priHeap = withInc } + Nothing -> Nothing diff --git a/src/Data/Enumeration/Traversal/Class.hs b/src/Data/Enumeration/Traversal/Class.hs new file mode 100644 --- /dev/null +++ b/src/Data/Enumeration/Traversal/Class.hs @@ -0,0 +1,51 @@ +-- Copyright (c) 2014 Eric McCorkle. All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions +-- are met: +-- +-- 1. Redistributions of source code must retain the above copyright +-- notice, this list of conditions and the following disclaimer. +-- +-- 2. Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in the +-- documentation and/or other materials provided with the distribution. +-- +-- 3. Neither the name of the author nor the names of any contributors +-- may be used to endorse or promote products derived from this software +-- without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE AUTHORS AND CONTRIBUTORS ``AS IS'' +-- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS +-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +-- SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +-- LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF +-- USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND +-- ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +-- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT +-- OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF +-- SUCH DAMAGE. +{-# OPTIONS_GHC -Wall -Werror #-} + +-- | Definition of a class for traversals. +module Data.Enumeration.Traversal.Class( + Traversal(..) + ) where + +import Data.Enumeration + +-- | A typeclass representing a traversal scheme over an enumeration. +class Traversal trav where + -- | Create a @Traversal@ from an @Enumeration@. + mkTraversal :: Enumeration ty -> trav ty + -- | Get the next item in the traversal. + getNext :: trav ty -> Maybe (ty, Path, trav ty) + + -- | Get all items in the traversal as a list. + getAll :: trav ty -> [(ty, Path)] + getAll trav = + case getNext trav of + Just (item, path, next) -> (item, path) : getAll next + Nothing -> [] diff --git a/test/UnitTest.hs b/test/UnitTest.hs new file mode 100644 --- /dev/null +++ b/test/UnitTest.hs @@ -0,0 +1,43 @@ +-- Copyright (c) 2014 Eric McCorkle. All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions +-- are met: +-- +-- 1. Redistributions of source code must retain the above copyright +-- notice, this list of conditions and the following disclaimer. +-- +-- 2. Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in the +-- documentation and/or other materials provided with the distribution. +-- +-- 3. Neither the name of the author nor the names of any contributors +-- may be used to endorse or promote products derived from this software +-- without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE AUTHORS AND CONTRIBUTORS ``AS IS'' +-- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS +-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +-- SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +-- LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF +-- USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND +-- ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +-- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT +-- OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF +-- SUCH DAMAGE. + +module Main(main) where + +import Test.HUnitPlus + +import qualified Tests.Data as Data + +tests = [ Data.tests ] + +testsuite = TestSuite { suiteName = "UnitTests", suiteConcurrently = True, + suiteTests = tests, suiteOptions = [] } + +main :: IO () +main = createMain [testsuite]