Microblob.hs

module Geometry.Tile.Microblob
  ( Microblob(..)
  , indices
  , names
  , quad

  , genSets
  ) where

import RIO

import Data.Bits
import Geometry.Quad (Quad(..))
import Geometry.Tile.Neighbors (Neighbors(..))
import Resource.Collection (Generic1, Generically1(..), enumerate)
import RIO.Map qualified as Map
import RIO.Set qualified as Set

data Microblob a = Microblob
  { brCornerInner    :: a
  , blCornerInner    :: a
  , trCornerInner    :: a
  , tlCornerInner    :: a
  , tlCornerOuter    :: a
  , ttEdgeHorizontal :: a
  , trCornerOuter    :: a
  , llEdgeVertical   :: a
  , full             :: a
  , rrEdgeVertical   :: a
  , blCornerOuter    :: a
  , bbEdgeHorizontal :: a
  , brCornerOuter    :: a
  }
  deriving stock (Eq, Ord, Show, Functor, Foldable, Traversable, Generic1)
  deriving Applicative via Generically1 Microblob

indices :: Microblob Int
indices = fmap fst . enumerate $ pure ()

names :: Microblob Text
names = Microblob
  { brCornerInner    = "brCornerInner"
  , blCornerInner    = "blCornerInner"
  , trCornerInner    = "trCornerInner"
  , tlCornerInner    = "tlCornerInner"
  , tlCornerOuter    = "tlCornerOuter"
  , ttEdgeHorizontal = "ttEdgeHorizontal"
  , trCornerOuter    = "trCornerOuter"
  , llEdgeVertical   = "llEdgeVertical"
  , full             = "full"
  , rrEdgeVertical   = "rrEdgeVertical"
  , blCornerOuter    = "blCornerOuter"
  , bbEdgeHorizontal = "bbEdgeHorizontal"
  , brCornerOuter    = "brCornerOuter"
  }

quad :: Neighbors Int -> Microblob a -> Int -> Quad a
quad Neighbors{..} Microblob{..} index = Quad
  { quadLT =
      if iNorth && iWest then
        if testBit index northWest then
          full
        else
          tlCornerInner
      else
        if iNorth then
          llEdgeVertical
        else
          if iWest then
            ttEdgeHorizontal
          else
            tlCornerOuter

  , quadRT =
      if iNorth && iEast then
        if testBit index northEast then
          full
        else
          trCornerInner
      else
        if iNorth then
          rrEdgeVertical
        else
          if iEast then
            ttEdgeHorizontal
          else
            trCornerOuter

  , quadLB =
      if iSouth && iWest then
        if testBit index southWest then
          full
        else
          blCornerInner
      else
        if iSouth then
          llEdgeVertical
        else
          if iWest then
            bbEdgeHorizontal
          else
            blCornerOuter

  , quadRB =
      if iSouth && iEast then
        if testBit index southEast then
          full
        else
          brCornerInner
      else
        if iSouth then
          rrEdgeVertical
        else
          if iEast then
            bbEdgeHorizontal
          else
            brCornerOuter
  }
  where
    iNorth = testBit index north
    iWest  = testBit index west
    iEast  = testBit index east
    iSouth = testBit index south

genSets :: Neighbors Int -> (Set Int, Map Int Int)
genSets bits = foldl' @[] f (Set.empty, Map.empty) [0..255]
  where
    Neighbors{..} = bits

    f (uniq, dups) i =
      ( Set.insert index uniq
      , Map.insert i index dups
      )
      where
        index = i
          & bool (clearBit northWest) id (iNorth && iWest)
          & bool (clearBit northEast) id (iNorth && iEast)
          & bool (clearBit southWest) id (iSouth && iWest)
          & bool (clearBit southEast) id (iSouth && iEast)

        iNorth = testBit i north
        iWest  = testBit i west
        iEast  = testBit i east
        iSouth = testBit i south