diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for rexparse + +## 0.1.0.0 -- 2026-08-29 + +* First version. Released on an unsuspecting world. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,29 @@ +Copyright (c) 2026, Raveline + + +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 copyright holder 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/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,50 @@ +module Main (main) where + +import Codec.Picture hiding (imageHeight, imageWidth) +import Codec.Picture.Types (createMutableImage, unsafeFreezeImage) +import Control.Monad.ST (runST) +import Data.Rexparse (Cell (..), Layer (..), XpFile (..), parseXPFile, traverseXp_) +import System.Environment (getArgs, getProgName) +import System.Exit (exitFailure) +import System.IO (hPutStrLn, stderr) + +cellScale :: Int +cellScale = 12 + +cellColor :: Cell -> Maybe PixelRGB8 +cellColor c + | bgRed c == 255 && bgGreen c == 0 && bgBlue c == 255 = Nothing + | asciiCode c == 0 || asciiCode c == 32 = Just (PixelRGB8 (bgRed c) (bgGreen c) (bgBlue c)) + | otherwise = Just (PixelRGB8 (fgRed c) (fgGreen c) (fgBlue c)) + +renderXp :: XpFile -> Image PixelRGB8 +renderXp xp = runST $ do + let (w, h) = case layers xp of + (l : _) -> (fromIntegral (imageWidth l), fromIntegral (imageHeight l)) + [] -> (0, 0) + img <- createMutableImage (w * cellScale) (h * cellScale) (PixelRGB8 0 0 0) + traverseXp_ + ( \_ (x, y) c -> case cellColor c of + Nothing -> pure () + Just p -> + sequence_ + [ writePixel img (x * cellScale + dx) (y * cellScale + dy) p + | dx <- [0 .. cellScale - 1] + , dy <- [0 .. cellScale - 1] + ] + ) + xp + unsafeFreezeImage img + +main :: IO () +main = do + args <- getArgs + case args of + [input, output] -> do + xp <- parseXPFile input + writePng output (renderXp xp) + putStrLn $ "Wrote " <> output + _ -> do + prog <- getProgName + hPutStrLn stderr $ "usage: " <> prog <> " " + exitFailure diff --git a/rexparse.cabal b/rexparse.cabal new file mode 100644 --- /dev/null +++ b/rexparse.cabal @@ -0,0 +1,60 @@ +cabal-version: 3.0 +name: rexparse +version: 0.1.0.0 +license: BSD-3-Clause +license-file: LICENSE +maintainer: eraveline@gmail.com +author: Raveline +tested-with: ghc ==9.14.1 ghc ==9.12.2 ghc ==9.10.3 +category: Codec +build-type: Simple +extra-doc-files: CHANGELOG.md +synopsis: A library to handle rexpaint file format +homepage: https://github.com/Raveline/Rexparse +bug-reports: https://github.com/Raveline/Rexparse/issues +description: + A library to read and write RexPaint (.xp) files: the gzip-compressed + binary format used by the RexPaint ASCII-art editor + (). + +source-repository head + type: git + location: https://github.com/Raveline/Rexparse.git + +library + exposed-modules: Data.Rexparse + hs-source-dirs: src + default-language: Haskell2010 + default-extensions: + ImportQualifiedPost DerivingStrategies GeneralizedNewtypeDeriving + DeriveAnyClass DeriveGeneric + + ghc-options: -Wall + build-depends: + array >=0.5.7.0 && <0.6, + base ^>=4.20 || ^>=4.21 || ^>=4.22, + binary >=0.8.9.3 && <0.9, + bytestring >=0.12.1.0 && <0.13, + zlib >=0.7.1.1 && <0.8 + +executable rexparse-xp2png + main-is: Main.hs + hs-source-dirs: app + default-language: Haskell2010 + default-extensions: ImportQualifiedPost + ghc-options: -Wall + build-depends: + base ^>=4.20 || ^>=4.21 || ^>=4.22, + JuicyPixels >=3.3.9 && <3.4, + rexparse + +test-suite rexparse-test + type: exitcode-stdio-1.0 + main-is: Main.hs + hs-source-dirs: test + default-language: Haskell2010 + ghc-options: -Wall + build-depends: + base ^>=4.20 || ^>=4.21 || ^>=4.22, + hspec ^>=2.11, + rexparse diff --git a/src/Data/Rexparse.hs b/src/Data/Rexparse.hs new file mode 100644 --- /dev/null +++ b/src/Data/Rexparse.hs @@ -0,0 +1,284 @@ +{- | Rexparse is a simple library to read the REXPaint @.xp@ format. + +For efficiency, cells are stored in arrays. Read a file with 'parseXPFile'; +from the resulting 'XpFile' you can either: + +- look up individual cells by layer index and @(x, y)@ coordinates, with + 'getRexpaintCell' (or 'unsafeGetRexpaintCell' to skip the 'Maybe' when + you know the indices are valid); +- or walk every cell: 'xpCells' for a plain list, 'traverseXp_' to run an + action per cell, 'traverseXp' / 'mapXp' to rewrite cells. + +Build a file with 'mkLayer' / 'mkXpFile' and write it back with 'writeXPFile'. +-} +module Data.Rexparse ( + RexpaintVersionNumber (..), + NumberOfLayers (..), + LayerIndex (..), + ImageWidth (..), + ImageHeight (..), + Layer (..), + Cell (..), + XpFile (..), + getRexpaintCell, + unsafeGetRexpaintCell, + parseXPFile, + decodeXPFile, + writeXPFile, + encodeXPFile, + mkLayer, + mkXpFile, + xpCells, + layerCells, + cellsAt, + traverseXp, + traverseXp_, + mapXp, +) +where + +import Codec.Compression.GZip (compress, decompress) +import Control.Monad (replicateM) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Data.Array qualified as A +import Data.Binary.Get +import Data.Binary.Put +import Data.ByteString.Lazy qualified as BSL +import Data.Foldable (traverse_) +import Data.Functor.Identity (Identity (..)) +import Data.Int +import Data.Word +import GHC.List ((!?)) + +{- | Version number stored in the beginning of each xp file. +This is only used by Rexpaint. +-} +newtype RexpaintVersionNumber = RexpaintVersionNumber Int32 + deriving newtype (Show, Eq, Ord) + +-- | Amount of layers stored in the picture. +newtype NumberOfLayers = NumberOfLayers Int32 + deriving newtype (Show, Eq, Ord) + +-- | Index of a layer within an 'XpFile', @0@ being the bottom layer. +newtype LayerIndex = LayerIndex Int + deriving newtype (Show, Eq, Ord, Num, Enum, Real, Integral) + +-- | Width in glyphs (not in pixel !). +newtype ImageWidth = ImageWidth Int32 + deriving newtype (Show, Eq, Ord, Num, Enum, Real, Integral) + +-- | Height in glyphs (not in pixels !). +newtype ImageHeight = ImageHeight Int32 + deriving newtype (Show, Eq, Ord, Num, Enum, Real, Integral) + +{- | A single layer. Width and height are repeated on each layer, +as per xp file specifications. Cells are stored in a single array, +as in the xp file itself. +-} +data Layer = Layer + { imageWidth :: ImageWidth + , imageHeight :: ImageHeight + , cells :: A.Array Int Cell + } + deriving stock (Show, Eq, Ord) + +{- | A single cell, containing an asciicode and rgb data for +foreground (fg) and background (bg). +-} +data Cell = Cell + { asciiCode :: Int32 + , fgRed :: Word8 + , fgGreen :: Word8 + , fgBlue :: Word8 + , bgRed :: Word8 + , bgGreen :: Word8 + , bgBlue :: Word8 + } + deriving stock (Show, Eq, Ord) + +{- | A full xp file. +Layers are ordered bottom first, top last. +-} +data XpFile = XpFile + { versionNumber :: RexpaintVersionNumber + , numberOfLayers :: NumberOfLayers + , layers :: [Layer] + } + deriving stock (Show, Eq, Ord) + +{- | Build a 'Layer' from its cells in the on-disk order: column @x = 0@ +top to bottom, then @x = 1@, and so on. The list must hold exactly +@width * height@ cells. +-} +mkLayer :: ImageWidth -> ImageHeight -> [Cell] -> Layer +mkLayer w h cs = Layer w h (A.listArray (0, n - 1) cs) + where + n = fromIntegral w * fromIntegral h + +{- | Assemble an 'XpFile' from its layers, bottom first. 'numberOfLayers' +is derived from the list. +-} +mkXpFile :: RexpaintVersionNumber -> [Layer] -> XpFile +mkXpFile ver ls = XpFile ver (NumberOfLayers (fromIntegral (length ls))) ls + +-- Binary (de)serialisation utilities. We can't use generics here +-- because xp is little endian. + +getCell :: Get Cell +getCell = + Cell + <$> getInt32le + <*> getWord8 + <*> getWord8 + <*> getWord8 + <*> getWord8 + <*> getWord8 + <*> getWord8 + +getLayer :: Get Layer +getLayer = do + w <- getInt32le + h <- getInt32le + let n = fromIntegral w * fromIntegral h + cs <- replicateM n getCell + pure $ Layer (ImageWidth w) (ImageHeight h) (A.listArray (0, n - 1) cs) + +getXpFile :: Get XpFile +getXpFile = do + ver <- getInt32le + nl <- getInt32le + ls <- replicateM (fromIntegral nl) getLayer + pure $ XpFile (RexpaintVersionNumber ver) (NumberOfLayers nl) ls + +putCell :: Cell -> Put +putCell c = do + putInt32le (asciiCode c) + mapM_ putWord8 [fgRed c, fgGreen c, fgBlue c, bgRed c, bgGreen c, bgBlue c] + +putLayer :: Layer -> Put +putLayer l = do + putInt32le (fromIntegral (imageWidth l)) + putInt32le (fromIntegral (imageHeight l)) + mapM_ putCell (A.elems (cells l)) + +putXpFile :: XpFile -> Put +putXpFile xp = do + putInt32le ver + putInt32le (fromIntegral (length (layers xp))) + mapM_ putLayer (layers xp) + where + RexpaintVersionNumber ver = versionNumber xp + +{- | Decode the gzip-compressed on-disk representation of a xp file. +Inverse of 'encodeXPFile'. Partial on malformed input, like 'parseXPFile'. +-} +decodeXPFile :: BSL.ByteString -> XpFile +decodeXPFile = runGet getXpFile . decompress + +{- | Serialise an 'XpFile' to REXPaint's gzip-compressed on-disk format. +The layer count written is derived from the 'layers' list, not from the +'numberOfLayers' field. +-} +encodeXPFile :: XpFile -> BSL.ByteString +encodeXPFile = compress . runPut . putXpFile + +{- | Fetch a given cell in a list of layers, given a +layer number and a set of coords (x, y). +-} +getRexpaintCell :: [Layer] -> LayerIndex -> (Int, Int) -> Maybe Cell +getRexpaintCell layers' (LayerIndex ln) (x, y) = do + layer <- layers' !? ln + let h = fromIntegral (imageHeight layer) + invalidX = x < 0 || x >= fromIntegral (imageWidth layer) + invalidY = y < 0 || y >= h + if invalidX || invalidY + then Nothing + else pure $ cells layer A.! (x * h + y) + +-- | Equivalent of `getRexpaintCell` but without safety. +unsafeGetRexpaintCell :: [Layer] -> LayerIndex -> (Int, Int) -> Cell +unsafeGetRexpaintCell layers' (LayerIndex ln) (x, y) = + let layer = layers' !! ln + h = fromIntegral (imageHeight layer) + in cells layer A.! (x * h + y) + +{- | Parse a xp file. This doesn't include proper error management, +so you might want to call this with some @try@. +-} +parseXPFile :: (MonadIO m) => FilePath -> m XpFile +parseXPFile fp = decodeXPFile <$> liftIO (BSL.readFile fp) + +-- | Write an 'XpFile' to disk in REXPaint's format. +writeXPFile :: (MonadIO m) => FilePath -> XpFile -> m () +writeXPFile fp = liftIO . BSL.writeFile fp . encodeXPFile + +indexToCoords :: Int -> Int -> (Int, Int) +indexToCoords h i = i `divMod` h + +{- | List all the content of a xp file: bottom layer first; per layer, +we then iterate in a column-major fashion, top to bottom then left to right. +-} +xpCells :: XpFile -> [(LayerIndex, (Int, Int), Cell)] +xpCells xp = + [ (LayerIndex li, indexToCoords h i, c) + | (li, layer) <- zip [0 ..] (layers xp) + , let h = fromIntegral (imageHeight layer) + , (i, c) <- A.assocs (cells layer) + ] + +-- | List all the cells in a given layer. +layerCells :: Layer -> [((Int, Int), Cell)] +layerCells layer = + [(indexToCoords h i, c) | (i, c) <- A.assocs (cells layer)] + where + h = fromIntegral (imageHeight layer) + +{- | Fetch the cell at a given set of coords in every layer that has one, +bottom layer first. +-} +cellsAt :: XpFile -> (Int, Int) -> [Cell] +cellsAt xp xy = + [ c + | ln <- [0 .. LayerIndex (length (layers xp) - 1)] + , Just c <- [getRexpaintCell (layers xp) ln xy] + ] + +{- | Traversal of an xp file. Useful if you need to alter the content +of a file and need some applicative to do so. +-} +traverseXp :: + (Applicative f) => + (LayerIndex -> (Int, Int) -> Cell -> f Cell) -> + XpFile -> + f XpFile +traverseXp f xp = + (\ls -> xp{layers = ls}) + <$> traverse (uncurry (traverseLayer f)) (zip [0 ..] (layers xp)) + +traverseLayer :: + (Applicative f) => + (LayerIndex -> (Int, Int) -> Cell -> f Cell) -> + Int -> + Layer -> + f Layer +traverseLayer f li layer = + (\cs -> layer{cells = A.array (A.bounds (cells layer)) cs}) + <$> traverse rebuild (A.assocs (cells layer)) + where + h = fromIntegral (imageHeight layer) + rebuild (i, c) = (,) i <$> f (LayerIndex li) (indexToCoords h i) c + +-- | Traversal of an xp file. Typical use case would be to call a display function for each cell. +traverseXp_ :: + (Applicative f) => + (LayerIndex -> (Int, Int) -> Cell -> f b) -> + XpFile -> + f () +traverseXp_ f xp = traverse_ (\(li, xy, c) -> f li xy c) (xpCells xp) + +{- | Map over an xpfile. Useful if you need to alter an xp file without +needing any kind of applicative in your process. +-} +mapXp :: (LayerIndex -> (Int, Int) -> Cell -> Cell) -> XpFile -> XpFile +mapXp f = runIdentity . traverseXp (\li xy c -> Identity (f li xy c)) diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,59 @@ +module Main (main) where + +import Data.Rexparse +import Test.Hspec + +-- | Ascii code, foreground rgb, background rgb. +fixtureCells :: [Cell] +fixtureCells = + [ Cell 65 255 0 0 0 0 0 -- 'A', red foreground + , Cell 66 0 255 0 0 0 0 -- 'B', green foreground + , Cell 67 0 0 255 0 0 0 -- 'C', blue foreground + , Cell 68 0 0 0 0 0 0 -- 'D', black foreground + ] + +-- | One cell, four 1x1 layers. +fixture :: XpFile +fixture = + mkXpFile + (RexpaintVersionNumber (-1)) + [mkLayer 1 1 [c] | c <- fixtureCells] + +bumpGlyph :: Cell -> Cell +bumpGlyph c = c{asciiCode = asciiCode c + 1} + +main :: IO () +main = hspec $ do + let xp = decodeXPFile (encodeXPFile fixture) + ls = layers xp + + describe "encodeXPFile / decodeXPFile" $ + it "round-trips the fixture" $ + xp `shouldBe` fixture + + describe "parsed structure" $ do + it "keeps the layer count" $ + numberOfLayers xp `shouldBe` NumberOfLayers 4 + it "keeps every layer 1x1" $ + map (\l -> (imageWidth l, imageHeight l)) ls `shouldBe` replicate 4 (1, 1) + + describe "xpCells" $ + it "yields every cell, bottom layer first" $ + xpCells xp `shouldBe` zipWith (\i c -> (i, (0, 0), c)) [0 ..] fixtureCells + + describe "cellsAt" $ + it "returns the stack bottom-to-top" $ + cellsAt xp (0, 0) `shouldBe` fixtureCells + + describe "getRexpaintCell" $ do + it "hits the requested layer" $ + getRexpaintCell ls 2 (0, 0) `shouldBe` Just (fixtureCells !! 2) + it "rejects out-of-range coordinates" $ + getRexpaintCell ls 0 (1, 0) `shouldBe` Nothing + it "rejects an unknown layer" $ + getRexpaintCell ls 4 (0, 0) `shouldBe` Nothing + + describe "mapXp" $ + it "rewrites every cell" $ + map (\(_, _, c) -> c) (xpCells (mapXp (\_ _ -> bumpGlyph) xp)) + `shouldBe` map bumpGlyph fixtureCells