never executed always true always false

    1 module HelVM.HelMA.Automata.Piet.Compiler (
    2   compile,
    3   label4,
    4   label4With,
    5 ) where
    6 
    7 import           HelVM.HelMA.Automata.Piet.Types.Color
    8 import           HelVM.HelMA.Automata.Piet.Types.Coordinates
    9 import           HelVM.HelMA.Automata.Piet.Types.Image
   10 import           HelVM.HelMA.Automata.Piet.Types.Label
   11 import           HelVM.HelMA.Automata.Piet.Types.Program
   12 
   13 
   14 import           Data.IntMap                                 hiding (filter)
   15 
   16 import qualified Relude.Extra                                as Extra
   17 
   18 compile :: Image Color -> Program
   19 compile image_ = Program image_ mask__ info_ where
   20   (mask__, info_) = label4 image_
   21 
   22 data LabellingStatus = LabellingStatus
   23   { _currentCoords :: Coordinates
   24   , _nextKey       :: LabelKey
   25   , _mask          :: Image LabelKey
   26   , _infoMap       :: IntMap (Maybe LabelInfo)
   27   , _equivalences  :: EquivalenceMap
   28   } deriving stock (Show)
   29 
   30 label4 :: Eq a => Image a -> (Image LabelKey, IntMap (Maybe LabelInfo))
   31 label4 = label4With (==)
   32 
   33 label4With :: (a -> a -> Bool) -> Image a -> (Image LabelKey, IntMap (Maybe LabelInfo))
   34 label4With neighbours img = (img', inf) where
   35   status = label4With' neighbours img (LabellingStatus (0, 0) 0 (newImage (witdthImage img, heightImage img) []) mempty mempty)
   36   img'   = fmap (applyEquivClass (_equivalences status)) (_mask status)
   37   inf    = foldrWithKey (mergeClass (_equivalences status)) mempty (_infoMap status)
   38 
   39   applyEquivClass eqMap lbl = equivClass lbl eqMap
   40 
   41   mergeClass eqMap label labelInfo = alter (updateMap labelInfo) (equivClass label eqMap)
   42 
   43   updateMap Nothing    Nothing            = Nothing
   44   updateMap (Just new) Nothing            = Just (Just new)
   45   updateMap Nothing    (Just old)         = Just old
   46   updateMap (Just new) (Just (Just oldS)) = Just (Just (new <> oldS))
   47   updateMap _          _                  = Nothing
   48 
   49 label4With' :: (a -> a -> Bool) -> Image a -> LabellingStatus -> LabellingStatus
   50 label4With' neighbours img status = checkNext (nextCoords xy) (updateStatus mergeLabels) where
   51   xy@(x, y) = _currentCoords status
   52   pixel     = pixelImage (x, y) img
   53 
   54   mergeLabels = fmap getMaskLabel $ filter isNeighbour $ addPixelInfo <$> previousNeighbours xy
   55 
   56   addPixelInfo (nx, ny) = (nx, ny, pixelImage (nx, ny) img)
   57   isNeighbour (_, _, e) = neighbours pixel e
   58   getMaskLabel (nx, ny, _) = pixelImage (nx, ny) (_mask status)
   59 
   60   updateStatus []       = status { _nextKey = Extra.next (_nextKey status), _mask = setPixelImage (x, y) (_nextKey status) (_mask status), _infoMap = insert (_nextKey status) (addPixel (x, y) Nothing) (_infoMap status) }
   61   updateStatus [l]      = status { _mask = setPixelImage (x, y) l (_mask status), _infoMap = adjust (addPixel (x, y)) l (_infoMap status) }
   62   updateStatus [l1, l2] = status { _mask = setPixelImage (x, y) (max l1 l2) (_mask status), _infoMap = adjust (addPixel (x, y)) (max l1 l2) (_infoMap status), _equivalences = equivInsert l1 l2 (_equivalences status) }
   63   updateStatus _        = error "too many neighbours in HelVM.HelMA.Automata.Piet.Compiler.ImageProcessor.label4With'"
   64   checkNext (Just xy') s = label4With' neighbours img (s { _currentCoords = xy' })
   65   checkNext Nothing    s = s
   66 
   67   previousNeighbours (cx, cy) = filter validCoord [ (cx-1, cy), (cx, cy-1) ]
   68   validCoord (nx, ny) = nx >= 0 && ny >= 0
   69 
   70   nextCoords (cx, cy) = guardX (cx < witdthImage img - 1) cx cy
   71   guardX True  cx cy = Just (cx + 1, cy)
   72   guardX False _ cy  = guardY (cy < heightImage img - 1) cy
   73   guardY True  cy = Just (0, cy + 1)
   74   guardY False _  = Nothing
   75 
   76 type EquivalenceMap = IntMap LabelKey
   77 
   78 equivClass :: LabelKey -> EquivalenceMap -> LabelKey
   79 equivClass e = findWithDefault e e
   80 
   81 equivInsert :: LabelKey -> LabelKey -> EquivalenceMap -> EquivalenceMap
   82 equivInsert x y mp = guardInsert (x /= y) where
   83   guardInsert True  = fmap replaceClass $ insert x newClass $ insert y newClass mp
   84   guardInsert False = mp
   85 
   86   class1   = equivClass x mp
   87   class2   = equivClass y mp
   88   classes  = x :| [y, class1, class2]
   89   newClass = Extra.minimum1 classes
   90 
   91   replaceClass eqClass = checkInClass (eqClass `elem` classes) eqClass
   92   checkInClass True  _   = newClass
   93   checkInClass False eqc = eqc