rexparse (empty) → 0.1.0.0
raw patch · 6 files changed
+487/−0 lines, 6 filesdep +JuicyPixelsdep +arraydep +base
Dependencies added: JuicyPixels, array, base, binary, bytestring, hspec, rexparse, zlib
Files
- CHANGELOG.md +5/−0
- LICENSE +29/−0
- app/Main.hs +50/−0
- rexparse.cabal +60/−0
- src/Data/Rexparse.hs +284/−0
- test/Main.hs +59/−0
+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Revision history for rexparse++## 0.1.0.0 -- 2026-08-29++* First version. Released on an unsuspecting world.
+ LICENSE view
@@ -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.
+ app/Main.hs view
@@ -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 <> " <input.xp> <output.png>"+ exitFailure
+ rexparse.cabal view
@@ -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+ (<https://www.gridsagegames.com/rexpaint/>).++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
+ src/Data/Rexparse.hs view
@@ -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))
+ test/Main.hs view
@@ -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