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 ( Coordinates )
    9 import           HelVM.HelMA.Automata.Piet.Types.Image
   10 import           HelVM.HelMA.Automata.Piet.Types.Label
   11 import           HelVM.HelMA.Automata.Piet.Types.Labelling
   12 import           HelVM.HelMA.Automata.Piet.Types.Program     ( Program (Program) )
   13 
   14 import           Data.IntMap                                 hiding ( filter )
   15 
   16 import           Lens.Micro
   17 import           Lens.Micro.TH                               ( makeLenses )
   18 
   19 import qualified Relude.Extra                                as Extra
   20 
   21 type EquivalenceMap = IntMap LabelKey
   22 
   23 data LabellingStatus
   24   = LabellingStatus
   25       { _currentCoords :: Coordinates
   26       , _nextKey       :: LabelKey
   27       , _labelling     :: Labelling
   28       , _equivalences  :: EquivalenceMap
   29       }
   30   deriving stock (Show)
   31 
   32 makeLenses ''LabellingStatus
   33 
   34 compile ∷ Image Color → Program
   35 compile image_ = Program image_ (label4 image_)
   36 
   37 label4 ∷ Eq a ⇒ Image a → Labelling
   38 label4 = label4With (==)
   39 
   40 label4With ∷ (a → a → Bool) → Image a → Labelling
   41 label4With neighbours img = Labelling img' inf where
   42   initialLabelling = Labelling (newImage (witdthImage img, heightImage img) []) mempty
   43   status           = label4With' neighbours img (LabellingStatus (0, 0) 0 initialLabelling mempty)
   44   currentLabelling = status ^. labelling
   45 
   46   img' = fmap (applyEquivClass (status ^. equivalences)) (currentLabelling ^. mask)
   47   inf  = foldrWithKey (mergeClass (status ^. equivalences)) mempty (currentLabelling ^. info)
   48 
   49   applyEquivClass eqMap lbl = equivClass lbl eqMap
   50 
   51   mergeClass eqMap label labelInfo = alter (updateMap labelInfo) (equivClass label eqMap)
   52 
   53   updateMap Nothing    Nothing            = Nothing
   54   updateMap (Just new) Nothing            = Just (Just new)
   55   updateMap Nothing    (Just old)         = Just old
   56   updateMap (Just new) (Just (Just oldS)) = Just (Just (new <> oldS))
   57   updateMap _          _                  = Nothing
   58 
   59 label4With' ∷ (a → a → Bool) → Image a → LabellingStatus → LabellingStatus
   60 label4With' neighbours img status = checkNext (nextCoords xy) (updateStatus mergeLabels) where
   61   xy@(x, y) = status ^. currentCoords
   62   pixel     = pixelImage (x, y) img
   63   lblng     = status ^. labelling
   64 
   65   mergeLabels = fmap getMaskLabel $ filter isNeighbour $ addPixelInfo <$> previousNeighbours xy
   66 
   67   addPixelInfo (nx, ny) = (nx, ny, pixelImage (nx, ny) img)
   68   isNeighbour (_, _, e) = neighbours pixel e
   69   getMaskLabel (nx, ny, _) = pixelImage (nx, ny) (lblng ^. mask)
   70 
   71   updateStatus [] = status
   72     & (labelling . mask %~ setPixelImage (x, y) (status ^. nextKey))
   73     & (labelling . info %~ insert (status ^. nextKey) (addPixel (x, y) Nothing))
   74     & (nextKey %~ Extra.next)
   75 
   76   updateStatus [l] = status
   77     & (labelling . mask %~ setPixelImage (x, y) l)
   78     & (labelling . info %~ adjust (addPixel (x, y)) l)
   79 
   80   updateStatus [l1, l2] = status
   81     & (labelling . mask %~ setPixelImage (x, y) (max l1 l2))
   82     & (labelling . info %~ adjust (addPixel (x, y)) (max l1 l2))
   83     & (equivalences %~ equivInsert l1 l2)
   84 
   85   updateStatus _ = error "too many neighbours in HelVM.HelMA.Automata.Piet.Compiler.ImageProcessor.label4With'"
   86 
   87   checkNext (Just xy') s = label4With' neighbours img (s & currentCoords .~ xy')
   88   checkNext Nothing    s = s
   89 
   90   previousNeighbours (cx, cy) = filter validCoord [ (cx-1, cy), (cx, cy-1) ]
   91   validCoord (nx, ny) = nx >= 0 && ny >= 0
   92 
   93   nextCoords (cx, cy) = guardX (cx < witdthImage img - 1) cx cy
   94   guardX True  cx cy = Just (cx + 1, cy)
   95   guardX False _ cy  = guardY (cy < heightImage img - 1) cy
   96   guardY True  cy = Just (0, cy + 1)
   97   guardY False _  = Nothing
   98 
   99 equivClass ∷ LabelKey → EquivalenceMap → LabelKey
  100 equivClass e = findWithDefault e e
  101 
  102 equivInsert ∷ LabelKey → LabelKey → EquivalenceMap → EquivalenceMap
  103 equivInsert x y mp = guardInsert (x /= y) where
  104   guardInsert True  = fmap replaceClass $ insert x newClass $ insert y newClass mp
  105   guardInsert False = mp
  106 
  107   class1   = equivClass x mp
  108   class2   = equivClass y mp
  109   classes  = x :| [y, class1, class2]
  110   newClass = Extra.minimum1 classes
  111 
  112   replaceClass eqClass = checkInClass (eqClass `elem` classes) eqClass
  113   checkInClass True  _   = newClass
  114   checkInClass False eqc = eqc