Rogan DP

-- | Pull specified columns and drop the rest.

only :: forall a rs.
     -> Rec (VConst a) rs                         -- ^ Header labels
     -> NonEmpty (NonEmpty a)                     -- ^ Input table to select columns from
     -> NonEmpty (Rec (VConst a) rs)              -- ^ Selected columns from input sheet
only targets ((NonEmpty.ToList -> header) :| body) =
    header :& ( body & Lens.mapped &~ Lens.view Lens._2 ( split indicies ) )
  where
    indicies :: IntMap IntSet                         -- Indicies of targets input
    indicies = occurs group targets header

-- | Pull specified columns and put the rest into a variable and values column.
--
-- Putting the variables and values on the front means the remainder can share its memory.

melt :: forall a rVar' rVal rs. Monoid a
     => Group a                                   -- ^ Discriminator for grouping a
     -> Rec (VConst a) (rVar':rVal':rs)           -- ^ Header labels with first to being variables and values
     -> NonEmpty (NonEmpty a)                     -- ^ Input table to select columns from and melt others
     -> NonEmpty (Rec (VConst a) (rVar':rVal':rs)) -- ^ Output variables, values, and selected columns
melt group (variable :& value :& targets) variables ((NonEmpty.ToList -> header) :| body) =
    variable :& value :& targets :| Foldable.foldr output [] body
  where
    indicies :: IntMap IntSet                        -- Indicies of targets in input
    indicies = occurs group targets header

    variables :: [a]                                 -- Variables from header
    variables = split indicies header ^. Lens._1

    output :: NonEmpty a                             -- Row to process
           -> [Rec (VConst a) (rVar':rVal':rs)]      -- Processed rows
           -> [Rec (VConst a) (rVar':rVal':rs)]      -- Row expanded and added on front of processed ones
    output (NonEmpty.toList -> row) rest = List.foldr cross rest $ List.zip variables values
      where
        values :: [a]                                    -- Values from row (not 
        fixed :: Rec (VConst a) rs                       -- Fixed portion of row (header matches)
        (values,fixed) = split indicies row

        cross :: (a,a)                                   -- Variable and value for row
              -> [Rec (VConst a) (rVar':rVal':rs)]       -- Procsessed rows
              -> [Rec (VConst a) (rVar':rVal':rs)]       -- Row added on front of processed ones
        cross (variable,value) rest = (Vinyl.Const variable) :& (Vinyl.Const value) :& fixed : rest


-- | Mapping from header indicies to referencing target indicies (i.e., where to write values)

occurs :: forall a rs. Group a                   -- ^ Discriminator to group values
       -> Rec (VConst a) rs                      -- ^ Target values
       -> [a]                                    -- ^ Header values
       -> IntMap IntSet                          -- ^ Header index to referencing target indicies
occurs group (Lens.review _Rec -> targets) header = IntMap.fromAscList map
  where
    -- Target and header indicies grouped by having the same value (both form respectively disjoint sets)
    common :: [(IntSet,IntSet)]                      -- All groups of targets and headers that refer to the same value
    common = Discrimination.runGroup group (targets' <> header') & Lens.mapped %~ Foldable.foldl' collect (IntSet.empty,IntSet.empty)
      where
        targets' :: [(a,Either Int Int)]                 -- Targets and their Left wrapped indicies
        targets' = targets & Lens.mapped %@~ ( \index -> (, Either.Left index) )

        header' :: [(a,Either Int Int)]                  -- Header values and their Right wrapped indicies
        header' = header & Lens.mapped %@~ ( \index -> (, Either.Right index) )

        -- Do this with a fold instead of partitionEithers so targets' <> header' is used incrementally
        collect :: (IntSet,IntSet)                       -- Target and header referencs so far
                -> Either Int Int                        -- Target reference or header reference
                -> (IntSet,IntSet)                       -- Target and header references so far with addition
        collect (Left targetIndex ) (!targetIndicies,!headerIndicies) -> ( targetIndicies & Lens.at targetIndex %~ Maybe.Just ()
                                                                         , headerIndicies )
        collect (Right headerIndex) (!targetIndicies,!headerIndicies) -> ( targetIndicies
                                                                         , headerIndicies & Lens.at headerIndex %~ Maybe.Just () )

    -- Distinct header indicies to target indicies mapping (in order as indicies were in order and grouping is stable)
    map :: [(Int,IntSet)]
    map = common ^.. Lens.folded . Lens.to expand . Lens.folded
      where
        expand :: (IntSet,IntSet)                        -- Related target and harder indicies
               -> [(Int,IntSet)]                         -- Header index to related target indicies
        expand (targetIndicies,headerIndicies) = headerIndicies ^.. IntSet.members . Lens.to (,targetIndicies) )


-- | Pull out and accumulate values of interest at locations in a vector specified by an index to indicies map

split :: froall a rs. Monoid a
      => IntMap IntSet                           -- ^ Row indicies to target indicies (i.e., what and where to collect)
      -> [a]                                     -- ^ Row to split and collect/accumulate across
      -> ([a],V (RLength rs))                    -- ^ Non-accumulated bits of row and accumulation vector
split map row = ( others
                , Vector.accum (<>) (Vector.replicate (Linear.reflectDim $ Proxy.Proxy @(RLength n))) Monoid.mempty )
    -- Could use promises package os row would be consumed incrementally
    updates :: [Either a (Int,a)]                    -- Either leftover or a target writebacks
    updates = row ^.. Lens.folded . Lens.withIndex . Lens.to process . Lens.folded
      where
        process :: Int                                   -- Row index
                -> a                                     -- Row value
                -> [Either a (Int,a)]                    -- Either add to others or write targets
        process index value = map ^.. Lens.failing
                                        (Lens.ix index . IntSet.members . re _Right)
                                        (Lens.to (Function.const value) . re _Left )

    others :: [a]                                    -- Unreferences values
    writes :: [(Int,a)]                              -- Referenced values and index to store them
    ( others
    , writes ) = Either.partitionEithers updates

dump :: forall a rs. (RecordListN rs)
     => Rec (VConst a) rs                         -- ^ Header labels
     -> [Rec (VConst a) rs]                       -- ^ Input table to dump
     -> NonEmpty [a]                              -- ^ Output table
dump header body = ( header :| body ) & Lens.mapped %~ Lens.review _Rec

-- | Output unique values for columns along with a column for each variable and their accumulated values

cast :: forall a rVar' rVal rs. Monoid a
     => Group a                                   -- ^ Discriminator for grouping a
     -> NonEmpty (Rec (VConst a) (rVar':rVal':rs)) -- ^ Input variables, values, and other columns
     -> NonEmpty (NonEmpty a)                     -- ^ Output table with variables columns on end
cast group ( (_ :& _ :& Lens.view -> header) :| Lens.mapped &~ Lens.view _Rec -> body) =
    NonEmpty (header <> variables) :| ( body' & Lens.mapped%~ output )
  where
    body' :: [[([a],a,a)]]                           -- Body grouped by fixed portions (fixed portions are the same)
    body' = Grouping.runGroup group $ body & Lens.mapped %~ ( \variable:value:fixed -> (fixed,(fixed,variable,value)) )

    variables :: [a]                                 -- Variables (unique across all rows)
    variables = ( Grouping.runGroup group $ body & Lens.mapped %~ ( \variable:_ -> (variable,variable) ) )
                   ^.. Lens.folded . Lens._head

    variablesSize :: Int                             -- Number of unique variables
    variablesSize = Lens.lengthOf Lens.folded variables

    variablesIndex :: [(a,Either Int a)]             -- Variables with their index (one to one)
    variablesIndex = variables & Lens.mapped %@~ ( \(index,variable) -> (variable, Either.Left index) )

    output :: [([a],a,a)] -> [a]
    output row@((fixed,_,_):_) = Vector.toList $ Vector.accum (<>) (Vector.replicate Monoid.variablesSize mempty) updates
      where
        variablesValue :: [(a,Either Int a)]             -- Variables with their value
        variablesValue =  row & Lens.mapped %~ ( \(_,variable,value) -> (variable, Either.Right value) )

        variables :: [[(Either Int a)]]                  -- Variables with ther index and values
        variables = Grouping.runGroup group $ variablesIndex <> variablesValue

        updates :: [(Int,a)]                             -- Values with their index
        updates = variables ^.. Lens.folded . Lens.to ( \(Left index:rest) -> rest ^.. Lens.folded . Lens._Right )

clean :: (HasLogging, Foldable f) => Fold (f (Rec (Either Text :. ElField rs))) (Rec ElField rs)
clean = Lens.folded . Lens.to to . Lens._Just
  where
    to :: Int -> Rec (Either Text :. ElField rs) -> Maybe (Rec ElField rs)
    to row record = case Vinyl.rtraverse Vinyl.getCompose record of
      Either.Left  text    -> Maybe.Nothing ## (Log.Note,Text.format "unable to convert value "{}"" (Text.Only text))
      Either.Right record' -> Maybe.Just record'

newtype ListN (n :: GHC.Nat) a = ListN [a]

class Finite v where
  type Size v :: GHC.Nat
  type Value v :: *
  toListN :: v -> ListN (Size v)
  fromListN :: ListN (Size v) -> v

instance Finite (a,a) where
  type Size (a,a) = 2
  type Value (a,a) = a
  toListN (a0,a1) = ListN [a0,a1]
  fromListN (ListN [a0,a1]) = (a0,a1)

# ... and so on for tuples, records, and such