never executed always true always false

    1 module HelVM.HelMA.Automata.Piet.Parser (
    2   parseToRightTextIO,
    3   parseRightIO,
    4 ) where
    5 
    6 import           HelVM.HelMA.Automata.Piet.Color
    7 import           HelVM.HelMA.Automata.Piet.Coordinates
    8 import           HelVM.HelMA.Automata.Piet.Image
    9 import           HelVM.HelMA.Automata.Piet.MonadFailExtra
   10 
   11 import           HelVM.HelIO.Extra
   12 
   13 import           Control.Applicative.Tools
   14 import           Control.Exception
   15 
   16 import           Data.ListLike                            (length)
   17 
   18 import           Graphics.Imlib
   19 
   20 import           Safe                                     (findJust)
   21 
   22 import           Prelude                                  hiding (length)
   23 
   24 parseToRightTextIO :: FilePath -> IO Text
   25 parseToRightTextIO = showP <.> parseRightIO
   26 
   27 parseRightIO :: FilePath -> IO ColorImage
   28 parseRightIO = eitherToMonadFail <=< parseIO
   29 
   30 parseIO :: FilePath -> ColorImageEitherIO
   31 parseIO = imageFromFilePath Nothing
   32 
   33 imageFromFilePath ::  Maybe Int -> FilePath -> ColorImageEitherIO
   34 imageFromFilePath codelInfo = flip (uncurry buildColorImageEitherIO) codelInfo . swap <=< loadImageWithErrorReturn
   35 
   36 buildColorImageEitherIO :: ImlibLoadError -> ImlibImage -> Maybe Int -> ColorImageEitherIO
   37 buildColorImageEitherIO ImlibLoadErrorNone img codelInfo = Right <$> imageFromImlib img codelInfo
   38 buildColorImageEitherIO err                _   _         = pure $ Left err
   39 
   40 imageFromImlib :: ImlibImage -> Maybe Int -> IO ColorImage
   41 imageFromImlib img = setImlibImage img . buildColorImageIO
   42 
   43 setImlibImage :: ImlibImage -> IO a -> IO a
   44 setImlibImage img = bracket_ (contextSetImage img) freeImageAndDecache
   45 
   46 buildColorImageIO :: Maybe Int -> IO ColorImage
   47 buildColorImageIO = imageFromContext <=< imageGuessCodelLength
   48 
   49 imageGuessCodelLength :: Maybe Int -> IO Int
   50 imageGuessCodelLength = maybe imageGuessCodelLengthDefault pure
   51 
   52 imageGuessCodelLengthDefault :: IO Int
   53 imageGuessCodelLengthDefault = do
   54   width  <- imageGetWidth
   55   height <- imageGetHeight
   56   rows   <- mapM (\y -> mapM (`imageQueryPixel` y) [0 .. width -1]) [0 .. height-1]
   57   cols   <- mapM (\x -> mapM ( imageQueryPixel  x) [0 .. height-1]) [0 .. width -1]
   58   pure $ imageGuessCodelLengthDefault' rows cols width height
   59 
   60 imageGuessCodelLengthDefault' :: (Eq a1, Eq a2) => [a1] -> [a2] -> Int -> Int -> Int
   61 imageGuessCodelLengthDefault' rows cols width height = findJust (== 1) $ scanl gcd (gcd width height) list
   62   where list = groupAndLength rows <> groupAndLength cols
   63 
   64 groupAndLength :: Eq a => [a] -> [Int]
   65 groupAndLength = length <.> group
   66 
   67 imageFromContext :: Int -> IO ColorImage
   68 imageFromContext = imageFromContextWithMax . max 1
   69 
   70 imageFromContextWithMax :: Int -> IO ColorImage
   71 imageFromContextWithMax codelLength = do
   72   width  <- (`div` codelLength) <$> imageGetWidth
   73   height <- (`div` codelLength) <$> imageGetHeight
   74   pixels <- mapM (toColors codelLength) [ (x, y) | x <- [ 0 .. width-1 ], y <- [ 0 .. height-1 ] ]
   75   pure $ newImage pixels (width-1 , height-1)
   76 
   77 toColors :: Int -> Coordinates -> IO (Coordinates , Color)
   78 toColors codelLength xy = (xy , ) . toColor <$> toImlibColorIO codelLength xy
   79 
   80 toImlibColorIO :: Int -> (Int, Int) -> IO ImlibColor
   81 toImlibColorIO codelLength (x , y) = imageQueryPixel (x * codelLength) (y * codelLength)
   82 
   83 toColor :: ImlibColor -> Color
   84 toColor (ImlibColor _ r g b) = rgb2Color $ RGBColor r g b
   85 
   86 -- | Types
   87 
   88 type ColorImageEitherIO = IO (Either ImlibLoadError ColorImage)
   89 type ColorImage = Image Color