redo row and diagonal rendering functions

posts/number-number/2/Diagonal.hs

@@ -1,7 +1,9 @@
 {-# LANGUAGE TupleSections #-}
+-- Module for displaying diagonals over Colonnades
 module Diagonal where
 
 import Colonnade
+import Data.List (lookup)
 import Data.Profunctor
 import Data.Bifunctor
 
@@ -35,25 +37,28 @@ newColumn header f = columns f (\_ -> Headed $ RC Nothing (Left header)) [()]
 
 -- Numbered rows of data, as opposed to data for rendering
 data DiagRow a = DR {
-    rowNumber :: RowNumber,
-    rowData :: [a]
+    rowNumber :: RowNumber,           -- Row number
+    rowLabels :: [(String, String)],  -- Extra labelling lookup for this row, which should not be manipulated
+    rowData :: [a]                    -- Actual row data
   } deriving Functor
 
 -- Same as `newColumn`, but reads into a DiagRow's row numberRows
 -- The display function `f` is used to convert the value to a String
 newColumnR header f = newColumn header (\_ c -> RC (Just $ rowNumber c) (Left $ f $ rowNumber c))
 
+-- Additional column from a label on the row
+labelColumn header = newColumn header (\_ (DR rn rl rd) -> RC (Just rn) $ Left $ maybe "" id $ lookup header rl)
+
 -- Number rows with the title "Sequence"
 numberColumn = newColumnR "Sequence" show
 -- Column of ellipses
 ellipsisColumn = newColumnR "..." (const "...")
 
 -- Create a Colonnade over DiagRows by mapping them into lists
--- The ellipsis row is mapped to a cells which always display as ellipses
--- The remaining rows are `Right` if they lie on the main diagonal, or `Left` otherwise
+-- The ellipsis row is mapped to cells which always display as ellipses
 diagBox' n = columns cell headCell [0..n]
-  where cell _ (DR Ellipsis  _) = RC (Just Ellipsis) (Left "...")
-        cell i (DR rn       rd) = RC (Just rn) $ Right $ (if RN i == rn then Right else Left) (rd !! i)
+  where cell _ (DR Ellipsis _ _) = RC (Just Ellipsis) (Left "...")
+        cell i (DR rn       _ rd) = RC (Just rn) $ Right $ (Just i, rd !! i)
         headCell i = Headed $ RC Nothing (Left $ show i)
 
 diagBox n = numberColumn <> diagBox' n <> ellipsisColumn
@@ -63,22 +68,51 @@ displayRows f = (displayTable .) . tagRows'
         tagRows' [] r@(RC rn _) = Left r  -- Tag missing things as left
         tagRows' ((p, f):ps) r@(RC rn _) = if p == rn then Right (f, r) else tagRows' ps r -- Match found, tag right
         displayTable row = case bimap liftRC (fmap liftRC) row of
-          (Left (Left r)) -> Left r
+          (Left (Left r))  -> Left r
           (Left (Right r)) -> Right $ f r
-          (Right (g, r)) -> Right $ g $ either id id r
+          (Right (g, r))   -> Right $ g $ either id id r
 
+-- Build a list of `DiagRow`s from xs, terminated by an ellipsis and an Omega row (y)
 rowsOmega :: [[a]] -> [a] -> [DiagRow a]
-rowsOmega xs y = zipWith (\x n -> DR (RN n) x) xs [0..] ++ [DR Ellipsis [], DR Omega y]
+rowsOmega xs y = zipWith (\x n -> DR (RN n) [] x) xs [0..] ++ [DR Ellipsis [] [], DR Omega [] y]
 
-diagData = rowsOmega [
-    [1, 2, 3, 4, 5, 6],
-    [9, 2, 4, 8, 3, 7],
-    [2, 2, 8, 2, 2, 2],
-    [2, 3, 9, 3, 9, 9],
-    [9, 4, 9, 4, 9, 4],
-    [8, 1, 2, 5, 7, 9]
-  ]
-  [2, 3, 9, 4, 0, 0]
+-- Build a labelled list of `DiagRow`s from labelled sequences xs, terminated by an ellipsis and an Omega row (y)
+-- l is the label name to use in the DiagRow
+rowsOmegaLabelled :: String -> [(String, [a])] -> [a] -> [DiagRow a]
+rowsOmegaLabelled l xs y = zipWith (\(x, y) n -> DR (RN n) [(l, x)] y) xs [0..] ++ [DR Ellipsis [] [], DR Omega [] y]
 
-displayDiagTable ps = rmap style . diagBox
-  where style    = either show id . displayRows (("Red " ++) . show) (map (, ("Green " ++). show) ps)
+-- rmap over a Colonnade using the first function in `ps` which does not return Nothing
+-- If no functions match, `f` is used instead.
+renderCells f ps = rmap $ tryOne ps where
+  tryOne []     c = f c
+  tryOne (p:ps) c = case p c of
+    Just new -> new
+    Nothing  -> tryOne ps c
+
+-- Mark a diagonal using the function f
+-- Cells are expected to be of the format (Maybe {columnNumber}, data)
+-- Diagonal n is the one where the difference between the row number and column number is n
+-- Nonmatches go to Nothing
+markDiagonal n f (RC (Just (RN r)) x) = case x of
+  Left _ -> Nothing
+  Right (Nothing, y) -> Nothing
+  Right (Just x, y) -> if r - x == n then Just $ f y else Nothing
+markDiagonal n f (RC _ x) = Nothing
+
+-- Mark certain row numbers using the function f
+-- Nonmatches go to Nothing
+markRows rns f x@(RC (Just rn) _)
+  | rn `elem` rns = Just $ f x
+  | otherwise     = Nothing
+markRows _ _ (RC _ _) = Nothing
+
+-- Show the pure cell data without the column index
+showCell (RC _ (Left s)) = s
+showCell (RC _ (Right (_, x))) = show x
+
+-- Demo some data with emphasized rows and a diagonal
+displayDiagData :: Show a => [RowNumber] -> Int -> Colonnade Headed (DiagRow a) String
+displayDiagData rows = renderCells showCell [
+    markDiagonal 0 (("Red " ++) . show),
+    markRows rows (("Green " ++) . showCell)
+  ] . diagBox