ca-patterns (empty) → 0.1.0.0

raw patch · 7 files changed

+647/−0 lines, 7 filesdep +basedep +parsecdep +text

Dependencies added: base, parsec, text, vector

Files

CHANGELOG.md +5/−0
LICENSE.md +20/−0
README.md +2/−0
ca-patterns.cabal +40/−0
src/Data/CA/List.hs +44/−0
src/Data/CA/Pattern.hs +325/−0
src/Text/RLE.hs +211/−0

+ CHANGELOG.md view

@@ -0,0 +1,5 @@+# Revision history for ca-patterns++## 0.1.0.0 -- YYYY-mm-dd++* First version. Released on an unsuspecting world.

+ LICENSE.md view

@@ -0,0 +1,20 @@+Copyright (c) Owen Bechtel++Permission is hereby granted, free of charge, to any person obtaining+a copy of this software and associated documentation files (the+"Software"), to deal in the Software without restriction, including+without limitation the rights to use, copy, modify, merge, publish,+distribute, sublicense, and/or sell copies of the Software, and to+permit persons to whom the Software is furnished to do so, subject to+the following conditions:++The above copyright notice and this permission notice shall be+included in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE+LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION+OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION+WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.

+ README.md view

@@ -0,0 +1,2 @@+# ca-patterns+Data types for life-like cellular automata, functions for creating and parsing RLE files

+ ca-patterns.cabal view

@@ -0,0 +1,40 @@+cabal-version: 2.4+name:          ca-patterns+version:       0.1.0.0+author:        Owen Bechtel+maintainer:    ombspring@gmail.com++category: Data, Text, Parsing+synopsis: Manipulate patterns in cellular automata, create and parse RLE files++description:+  This package contains a Pattern type for working with 2-dimensional 2-state+  cellular automata. It also has functions for creating and parsing RLE+  files. RLE is a textual representation of CA patterns used in applications+  such as Golly and LifeViewer.++homepage:           https://github.com/UnaryPlus/ca-patterns+bug-reports:        https://github.com/UnaryPlus/ca-patterns/issues+license:            MIT+license-file:       LICENSE.md+extra-source-files: CHANGELOG.md, README.md++source-repository head+  type:     git+  location: https://github.com/UnaryPlus/ca-patterns.git++library+    exposed-modules:+      Data.CA.Pattern,+      Data.CA.List,+      Text.RLE++    build-depends:+      base >= 4.11 && < 5,+      vector >= 0.7 && < 0.13,+      text >= 0.7 && < 2.1,+      parsec >= 3.1.6 && < 3.2++    default-language: Haskell2010+    ghc-options:      -Wall+    hs-source-dirs:   src

+ src/Data/CA/List.hs view

@@ -0,0 +1,44 @@+module Data.CA.List (withDimensions, combinations) where++import qualified Control.Applicative as Ap++import qualified Data.CA.Pattern as Pat+import Data.CA.Pattern (Pattern, Cell(..))++composeN :: Int -> (a -> a) -> a -> a+composeN n f+  | n <= 0 = id+  | otherwise = f . composeN (n - 1) f++possible1 :: Int -> [[Cell]]+possible1 n = composeN n (Ap.liftA2 (:) [Dead, Alive]) [[]]++possible2 :: Int -> Int -> [[[Cell]]]+possible2 h w = let+  rows = possible1 w+  in composeN h (Ap.liftA2 (:) rows) [[]]++{-|+A list of every possible h by w pattern. This function+is necessarily exponential in both arguments, so it's only+practical if the dimensions are very small.+-}+withDimensions+  :: Int -- ^ h+  -> Int -- ^ w+  -> [Pattern]+withDimensions h w = map Pat.fromRectList (possible2 h w)++{-|+Combine two patterns in multiple ways. Useful for creating+a list of spaceship / still life collisions.++See 'Pat.combine'.+-}+combinations+  :: (Int, Int) -- ^ min and max vertical offset+  -> (Int, Int) -- ^ min and max horizonal offset+  -> Pattern -> Pattern -> [Pattern]+combinations (yMin, yMax) (xMin, xMax) pat1 pat2 = let+  combine y x = Pat.combine y x pat1 pat2+  in Ap.liftA2 combine [yMin .. yMax] [xMin .. xMax]

+ src/Data/CA/Pattern.hs view

@@ -0,0 +1,325 @@+{-|+The functions in this module allow you to create, transform,+and combine CA patterns.+-}++{-# LANGUAGE BlockArguments, LambdaCase, OverloadedStrings #-}++module Data.CA.Pattern+  ( -- * Cells+    Cell(..), isDead, isAlive+    -- * Patterns+  , Pattern, lookup, generate, height, width, dimensions, valid+    -- * Vector conversions+  , fromRectVector, fromVector, toVector+    -- * List conversions+  , fromRectList, fromList, toList+    -- * Text and string conversions+  , toText, toString+    -- * Trimming+  , trimTop, trimBottom, trimLeft, trimRight, trim+    -- * Cropping and padding+  , setHeight, setWidth, setDimensions+    -- * Transformations+  , reflectX, reflectY, rotateL, rotateR+    -- * Combining+  , combine+  ) where++import Prelude hiding (lookup)+import qualified Data.Maybe as Maybe+import Data.String (IsString)++import qualified Data.Vector as Vec+import Data.Vector (Vector, (!?))++import qualified Data.Text as Text+import Data.Text (Text)++padEnd :: Int -> a -> Vector a -> Vector a+padEnd n val row = row <> Vec.replicate (n - length row) val++dropWhileEnd :: (a -> Bool) -> Vector a -> Vector a+dropWhileEnd f row+  | Vec.null row = Vec.empty+  | f (Vec.last row) = dropWhileEnd f (Vec.init row)+  | otherwise = row++dropFirst :: Vector a -> Vector a+dropFirst = Vec.drop 1++dropLast :: Vector a -> Vector a+dropLast row+  | Vec.null row = Vec.empty+  | otherwise = Vec.init row++firstCell :: Vector Cell -> Cell+firstCell row+  | Vec.null row = Dead+  | otherwise = Vec.head row++lastCell :: Vector Cell -> Cell+lastCell row+  | Vec.null row = Dead+  | otherwise = Vec.last row++{-|+The state of a cell.+-}+data Cell = Dead | Alive+  deriving (Eq, Ord, Show)++isDead :: Cell -> Bool+isDead = \case { Dead -> True; Alive -> False }++isAlive :: Cell -> Bool+isAlive = \case { Dead -> False; Alive -> True }++{-|+A pattern in a 2-dimensional 2-state cellular automaton.+-}+newtype Pattern = Pattern (Vector (Vector Cell))++transform :: (Vector (Vector Cell) -> Vector (Vector Cell)) -> Pattern -> Pattern+transform f (Pattern rows) = Pattern (f rows)++{-|+Get the state of one of the cells in a pattern. @lookup 0 0@+returns the cell in the upper-left corner. If the row+or column number is out of range, this function will+return 'Dead'.+-}+lookup+  :: Int -- ^ row+  -> Int -- ^ column+  -> Pattern -> Cell+lookup r c (Pattern rows) = Maybe.fromMaybe Dead (rows !? r >>= (!? c))++{-|+Generate a pattern from a function.+-}+generate+  :: Int -- ^ height+  -> Int -- ^ width+  -> (Int -> Int -> Cell) -- ^ function taking row and column+  -> Pattern+generate h w f = Pattern (Vec.generate h \r -> Vec.generate w \c -> f r c)++height :: Pattern -> Int+height (Pattern rows) = Vec.length rows++width :: Pattern -> Int+width (Pattern rows)+  | Vec.null rows = 0+  | otherwise = Vec.length (Vec.head rows)++{-|+Get the height and width of a pattern.+-}+dimensions :: Pattern -> (Int, Int)+dimensions pat = (height pat, width pat)++{-|+Test if a pattern is valid, i.e. rectangular.+Some of the functions in this module only behave+properly on rectangular patterns.+-}+valid :: Pattern -> Bool+valid pat@(Pattern rows) = let+  w = width pat+  validRow row = Vec.length row == w+  in all validRow rows++{-|+Convert a vector of rows into a pattern, assuming+the rows are all the same length.+-}+fromRectVector :: Vector (Vector Cell) -> Pattern+fromRectVector = Pattern++{-|+Convert a vector of rows into a pattern. If+the rows are not all the same length, they will+padded with dead cells until the pattern is+rectangular.+-}+fromVector :: Vector (Vector Cell) -> Pattern+fromVector rows = let+  maxWidth = foldr (max . Vec.length) 0 rows+  padded = fmap (padEnd maxWidth Dead) rows+  in Pattern padded++{-|+Convert a pattern into a vector of rows.+-}+toVector :: Pattern -> Vector (Vector Cell)+toVector (Pattern rows) = rows++{-|+Convert a list of rows into a pattern, assuming+the rows are all the same length.+-}+fromRectList :: [[Cell]] -> Pattern+fromRectList = fromRectVector . Vec.fromList . map Vec.fromList++{-|+Convert a list of rows into a pattern. If+the rows are not all the same length, they will+padded with dead cells until the pattern is+rectangular.+-}+fromList :: [[Cell]] -> Pattern+fromList = fromVector . Vec.fromList . map Vec.fromList++{-|+Convert a pattern into a list of rows.+-}+toList :: Pattern -> [[Cell]]+toList (Pattern rows) = map Vec.toList (Vec.toList rows)++toSomeString :: (Monoid s, IsString s) => (Vector Char -> s) -> Char -> Char -> Pattern -> s+toSomeString makeStr dead alive (Pattern rows) = let+  toChar = \case { Dead -> dead; Alive -> alive }+  makeLine row = makeStr (fmap toChar row) <> "\n"+  in foldMap makeLine rows++{-|+Convert a pattern into text. For example, @toText \'.' \'Z'@+will replace each dead cell with a @.@ and each live cell+with a @Z@.+-}+toText+  :: Char -- ^ dead cell+  -> Char -- ^ live cell+  -> Pattern -> Text+toText = let+  add c text = Text.singleton c <> text+  in toSomeString (foldr add "")++{-|+Convert a pattern into a string.+-}+toString+  :: Char -- ^ dead cell+  -> Char -- ^ live cell+  -> Pattern -> String+toString = toSomeString Vec.toList++{-|+Remove rows of dead cells from the top of a pattern.+-}+trimTop :: Pattern -> Pattern+trimTop = transform (Vec.dropWhile (all isDead))++{-|+Remove rows of dead cells from the bottom of a pattern.+-}+trimBottom :: Pattern -> Pattern+trimBottom = transform (dropWhileEnd (all isDead))++trimLeftV :: Vector (Vector Cell) -> Vector (Vector Cell)+trimLeftV rows+  | all (isDead . firstCell) rows = trimLeftV (fmap dropFirst rows)+  | otherwise = rows++trimRightV :: Vector (Vector Cell) -> Vector (Vector Cell)+trimRightV rows+  | all (isDead . lastCell) rows = trimRightV (fmap dropLast rows)+  | otherwise = rows++{-|+Remove columns of dead cells from the left side of a pattern.+-}+trimLeft :: Pattern -> Pattern+trimLeft = transform trimLeftV++{-|+You get the idea.+-}+trimRight :: Pattern -> Pattern+trimRight = transform trimRightV++{-|+A composition of 'trimTop', 'trimBottom', 'trimLeft', and 'trimRight'.+Removes as many dead cells from the pattern as possible while+keeping it rectangular.+-}+trim :: Pattern -> Pattern+trim = trimTop . trimBottom . trimLeft . trimRight++{-|+Force a pattern to have the given height by removing rows+from the bottom or by adding rows of dead cells.+-}+setHeight :: Int -> Pattern -> Pattern+setHeight h pat =+  case compare h (height pat) of+    LT -> transform (Vec.take h) pat+    EQ -> pat+    GT -> let+      row = Vec.replicate (width pat) Dead+      in transform (padEnd h row) pat++{-|+Force a pattern to have the given width by remove columns+from the right or by adding columns of dead cells.+-}+setWidth :: Int -> Pattern -> Pattern+setWidth w pat =+  case compare w (width pat) of+    LT -> transform (fmap (Vec.take w)) pat+    EQ -> pat+    GT -> transform (fmap (padEnd w Dead)) pat++{-|+Set the height and width of a pattern.+-}+setDimensions :: Int -> Int -> Pattern -> Pattern+setDimensions h w = setHeight h . setWidth w++{-|+Reflect vertically, switching the top and the bottom.+-}+reflectY :: Pattern -> Pattern+reflectY = transform Vec.reverse++{-|+Reflect horizontally, switching the left and the right.+-}+reflectX :: Pattern -> Pattern+reflectX = transform (fmap Vec.reverse)++{-|+Rotate counterclockwise by a quarter turn.+-}+rotateL :: Pattern -> Pattern+rotateL pat = let+  (h, w) = dimensions pat+  in generate w h \r c -> lookup c (w - r - 1) pat++{-|+Rotate clockwise by a quarter turn.+-}+rotateR :: Pattern -> Pattern+rotateR pat = let+  (h, w) = dimensions pat+  in generate w h \r c -> lookup (h - c - 1) r pat++{-|+Combine two patterns given a vertical and horizontal offset,+which describe the displacement of the second pattern relative+to the first one.+-}+combine+  :: Int -- ^ vertical offset+  -> Int -- ^ horizontal offset+  -> Pattern -> Pattern -> Pattern+combine y x pat1 pat2 = let+  (y1, y2) = if y < 0 then (-y, 0) else (0, y)+  (x1, x2) = if x < 0 then (-x, 0) else (0, x)+  h = max (height pat1 + y1) (height pat2 + y2)+  w = max (width pat1 + x1) (width pat2 + x2)+  in generate h w \r c -> let+    cell1 = lookup (r - y1) (c - x1) pat1+    cell2 = lookup (r - y2) (c - x2) pat2+    in max cell1 cell2

+ src/Text/RLE.hs view

@@ -0,0 +1,211 @@+{-|+The RLE (run length encoded) format is a common way of representing+patterns in life-like cellular automata. RLE files consist of three+sections:++  1. Zero or more comment lines beginning with @#@++  2. A header of the form @x = [width], y = [height], rule = [rule]@.+  @[width]@ and @[height]@ are natural numbers, and @[rule]@ is the+  rule the pattern is meant to be run in, such as @B36/S23@. The "rule" field+  is optional.++  3. The content of the pattern. @b@ represents a dead cell, @o@ represents+  a live cell, and @$@ denotes the end of a row. A run of identical+  characters can be abbreviated with a number, e.g. @4o@ is short for+  @oooo@ (hence the name "run length encoded"). This section must be+  terminated by a @!@ character.++A glider in the Game of Life could be represented like so:++> #N glider+> x = 3, y = 3, rule = B3/S23+> 3o$2bo$bo!++See this [LifeWiki article](https://conwaylife.com/wiki/Run_Length_Encoded)+for more information.+-}++{-# LANGUAGE BlockArguments, LambdaCase, OverloadedStrings, FlexibleContexts #-}++module Text.RLE (Rule, parse, make, printAll) where++import qualified Data.Char as Char+import qualified Data.String as String+import qualified Control.Applicative as Ap+import Data.Functor.Identity (Identity)+import Data.String (IsString)++import Text.Parsec+  ( Parsec, Stream, runParser+  , (<|>), try, many, many1, manyTill, satisfy+  , anyChar, digit, string, spaces+  )++import qualified Data.Text.IO as IO++import qualified Data.CA.Pattern as Pat+import Data.CA.Pattern (Pattern)++{-|+A string representing a cellular automaton, such as @"B36/S23"@ or+@"B3/S2-i34q"@.+-}+type Rule = String++data RunType = Dead | Alive | Newline+  deriving (Eq)+type Run = (Int, RunType)++data Header = Header Int Int (Maybe Rule)+type RLEData = (Header, [Run])++type Parser s = Parsec s ()++natural :: (Stream s Identity Char) => Parser s Int+natural = do+  num <- many1 digit+  spaces+  return (read num)++symbol :: (Stream s Identity Char) => String -> Parser s ()+symbol sym = string sym >> spaces++parseWidth :: (Stream s Identity Char) => Parser s Int+parseWidth = symbol "x" >> symbol "=" >> natural++parseHeight :: (Stream s Identity Char) => Parser s Int+parseHeight = symbol "," >> symbol "y" >> symbol "=" >> natural++parseRule :: (Stream s Identity Char) => Parser s Rule+parseRule = do+  symbol "," >> symbol "rule" >> symbol "="+  rule <- many1 (satisfy (not . Char.isSpace))+  spaces+  return rule++parseHeader :: (Stream s Identity Char) => Parser s Header+parseHeader = Ap.liftA3 Header parseWidth parseHeight maybeRule+  where maybeRule = fmap Just parseRule <|> return Nothing++parseRunType :: (Stream s Identity Char) => Parser s RunType+parseRunType = (symbol "b" >> return Dead)+  <|> (symbol "o" >> return Alive)+  <|> (symbol "$" >> return Newline)++parseRun :: (Stream s Identity Char) => Parser s Run+parseRun = Ap.liftA2 (,) (natural <|> return 1) parseRunType++parseData :: (Stream s Identity Char) => Parser s RLEData+parseData = do+  rle <- Ap.liftA2 (,) parseHeader (many1 parseRun)+  symbol "!"+  return rle++parseComment :: (Stream s Identity Char) => Parser s ()+parseComment = symbol "#" >> manyTill anyChar newline >> return ()+  where newline = try (symbol "\n")++parseRLE :: (Stream s Identity Char) => Parser s RLEData+parseRLE = spaces >> many parseComment >> parseData++updateRows :: [Run] -> [[Pat.Cell]] -> [[Pat.Cell]]+updateRows = curry \case+  ([], rows) -> rows+  ((0, _) : runs, rows) -> updateRows runs rows++  ((n, rt) : runs, rows) -> let+    add cell = \case+      [] -> [[cell]]+      (row : rest) -> (cell : row) : rest++    runs' = (n - 1, rt) : runs++    rows' = case rt of+      Dead -> add Pat.Dead rows+      Alive -> add Pat.Alive rows+      Newline -> [] : rows++    in updateRows runs' rows'++toPattern :: RLEData -> (Maybe Rule, Pattern)+toPattern (Header h w rule, runs) = let+  rows = updateRows (reverse runs) []+  pat = Pat.setDimensions h w (Pat.fromList rows)+  in (rule, pat)++{-|+Parse an RLE file, returning a 'Rule' (if it exists) and a 'Pattern'.+The argument can be 'String', 'Text', or any other type with a 'Stream'+instance.++This parser is fairly liberal. Whitespace is allowed everywhere except+in the middle of a number or rulestring, and there need not be a+newline after the header. Also, text after the final @!@ character is+ignored.+-}+parse :: (Stream s Identity Char) => s -> Maybe (Maybe Rule, Pattern)+parse str =+  case runParser parseRLE () "" str of+    Left _ -> Nothing+    Right rle -> Just (toPattern rle)++updateRuns :: [[Pat.Cell]] -> [Run] -> [Run]+updateRuns = let+  add rt = \case+    (n, rt') : runs | rt == rt' -> (n + 1, rt) : runs+    runs -> (1, rt) : runs++  in curry \case+  ([], runs) -> reverse runs+  ([] : rows, runs) -> updateRuns rows (add Newline runs)+  ((Pat.Dead : row) : rows, runs) -> updateRuns (row : rows) (add Dead runs)+  ((Pat.Alive : row) : rows, runs) -> updateRuns (row : rows) (add Alive runs)++fromShow :: (Show a, IsString s) => a -> s+fromShow = String.fromString . show++showRunType :: (IsString s) => RunType -> s+showRunType = \case+  Dead -> "b"+  Alive -> "o"+  Newline -> "$"++showRun :: (Semigroup s, IsString s) => Run -> s+showRun = \case+  (1, rt) -> showRunType rt+  (n, rt) -> fromShow n <> showRunType rt++showRuns :: (Semigroup s, IsString s) => Int -> [Run] -> s+showRuns = curry \case+  (_, []) -> ""+  (0, runs) -> "\n" <> showRuns 30 runs+  (n, run : runs) -> showRun run <> showRuns (n - 1) runs++{-|+Convert a 'Pattern' into an RLE. If the first argument is 'Nothing',+the generated RLE will have no "rule" field in its header.+-}+make :: (Semigroup s, IsString s) => Maybe Rule -> Pattern -> s+make rule pat = let+  x = "x = " <> fromShow (Pat.width pat)+  y = ", y = " <> fromShow (Pat.height pat)+  r = case rule of+    Nothing -> ""+    Just str -> ", rule = " <> String.fromString str+  runs = updateRuns (Pat.toList pat) []+  in x <> y <> r <> "\n" <> showRuns 30 runs <> "!\n"++{-|+Convert a list of patterns into RLEs and print them. Example:++> import qualified Text.RLE as RLE+> import Data.CA.List (withDimensions)+> main = RLE.printAll (Just "B3/S23") (withDimensions 4 4)++The program above will print the RLE of every possible pattern+contained in a 4 by 4 square. This data can then be piped into another+program such as apgsearch.+-}+printAll :: Maybe Rule -> [Pattern] -> IO ()+printAll rule = mapM_ (IO.putStrLn . make rule)