[#14] Add drawMergePattern

apply-merge.cabal

@@ -44,10 +44,12 @@ library
       src
   ghc-options: -Wall -Wunused-packages
   build-depends:
-      base >=4.16 && <4.17 || >=4.17 && <4.18 || >=4.18 && <4.19 || >=4.19 && <4.20 || >=4.20 && <4.21
+      array ==0.5.*
+    , base >=4.16 && <4.17 || >=4.17 && <4.18 || >=4.18 && <4.19 || >=4.19 && <4.20 || >=4.20 && <4.21
     , containers >=0.6 && <0.7 || >=0.7 && <0.8
     , pqueue >=1.4 && <1.5 || >=1.5 && <1.6
     , reflection ==2.1.*
+    , text >=1.2 && <1.3 || >=2.0 && <2.1 || >=2.1 && <2.2
   default-language: GHC2021
 
 test-suite apply-merge-tests
@@ -75,7 +77,8 @@ test-suite apply-merge-tests
       test
   ghc-options: -Wall -Wunused-packages
   build-depends:
-      base >=4.16 && <4.17 || >=4.17 && <4.18 || >=4.18 && <4.19 || >=4.19 && <4.20 || >=4.20 && <4.21
+      array ==0.5.*
+    , base >=4.16 && <4.17 || >=4.17 && <4.18 || >=4.18 && <4.19 || >=4.19 && <4.20 || >=4.20 && <4.21
     , containers >=0.6 && <0.7 || >=0.7 && <0.8
     , data-ordlist ==0.4.*
     , pqueue >=1.4 && <1.5 || >=1.5 && <1.6
@@ -84,6 +87,7 @@ test-suite apply-merge-tests
     , tasty-expected-failure ==0.12.*
     , tasty-hunit ==0.10.*
     , tasty-quickcheck ==0.10.*
+    , text >=1.2 && <1.3 || >=2.0 && <2.1 || >=2.1 && <2.2
     , transformers >=0.5 && <0.6 || >=0.6 && <0.7
     , vector >=0.12 && <0.13 || >=0.13 && <0.14
   default-language: GHC2021
@@ -109,12 +113,14 @@ benchmark apply-merge-benchmarks
       bench
   ghc-options: -Wall -Wunused-packages
   build-depends:
-      base >=4.16 && <4.17 || >=4.17 && <4.18 || >=4.18 && <4.19 || >=4.19 && <4.20 || >=4.20 && <4.21
+      array ==0.5.*
+    , base >=4.16 && <4.17 || >=4.17 && <4.18 || >=4.18 && <4.19 || >=4.19 && <4.20 || >=4.20 && <4.21
     , containers >=0.6 && <0.7 || >=0.7 && <0.8
     , data-ordlist ==0.4.*
     , pqueue >=1.4 && <1.5 || >=1.5 && <1.6
     , reflection ==2.1.*
     , tasty-bench ==0.3.*
+    , text >=1.2 && <1.3 || >=2.0 && <2.1 || >=2.1 && <2.2
     , transformers >=0.5 && <0.6 || >=0.6 && <0.7
     , vector >=0.12 && <0.13 || >=0.13 && <0.14
   default-language: GHC2021

package.yaml

@@ -44,9 +44,11 @@ library:
   other-modules:
   - ApplyMerge.IntSet
   dependencies:
+  - array ^>= {0.5}
   - containers ^>= {0.6, 0.7}
   - pqueue ^>= {1.4, 1.5}
   - reflection ^>= {2.1}
+  - text ^>= {1.2, 2.0, 2.1}
 
 # The library implements apply-merge in a few different ways, with slightly
 # different performance characteristics, but only exports the current best
@@ -65,6 +67,7 @@ tests:
     - test
     main: Main.hs
     dependencies:
+    - array ^>= {0.5}
     - containers ^>= {0.6, 0.7}
     - data-ordlist ^>= {0.4}
     - pqueue ^>= {1.4, 1.5}
@@ -73,6 +76,7 @@ tests:
     - tasty-expected-failure ^>= {0.12}
     - tasty-hunit ^>= {0.10}
     - tasty-quickcheck ^>= {0.10}
+    - text ^>= {1.2, 2.0, 2.1}
     - transformers ^>= {0.5, 0.6}
     - vector ^>= {0.12, 0.13}
 
@@ -83,10 +87,12 @@ benchmarks:
     - bench
     main: Main.hs
     dependencies:
+    - array ^>= {0.5}
     - containers ^>= {0.6, 0.7}
     - data-ordlist ^>= {0.4}
     - pqueue ^>= {1.4, 1.5}
     - reflection ^>= {2.1}
     - tasty-bench ^>= {0.3}
+    - text ^>= {1.2, 2.0, 2.1}
     - transformers ^>= {0.5, 0.6}
     - vector ^>= {0.12, 0.13}

src/Data/List/ApplyMerge.hs

@@ -7,12 +7,25 @@
 -- License: BSD-3-Clause
 -- Maintainer: Preetham Gujjula <[email protected]>
 -- Stability: experimental
-module Data.List.ApplyMerge (applyMerge, applyMergeBy, applyMergeOn) where
+module Data.List.ApplyMerge
+  ( applyMerge,
+    applyMergeBy,
+    applyMergeOn,
+
+    -- * Ascii drawing
+    drawMergePattern,
+  )
+where
 
 import ApplyMerge.IntSet qualified
+import Data.Array (Array, (!))
+import Data.Array qualified as Array
+import Data.Function ((&))
 import Data.Proxy (Proxy (..))
 import Data.Reflection (Reifies, reflect, reify)
 import Data.Semigroup (Arg (..))
+import Data.Text (Text)
+import Data.Text qualified as Text
 
 -- | If given a binary function @f@ that is non-decreasing in both arguments,
 --   and two (potentially infinite) ordered lists @xs@ and @ys@, then
@@ -80,3 +93,71 @@ applyMergeOn p f as bs =
         let c = f a b
          in Arg (p c) c
    in map (\(Arg _ c) -> c) (applyMerge f' as bs)
+
+type ApplyMerge = forall a b c. (Ord c) => (a -> b -> c) -> [a] -> [b] -> [c]
+
+-- | @drawMergePattern f as bs size n@ takes the parameters for an @applyMerge@
+--   and displays what the smallest @size@ x @size@ elements look like after @n@
+--   elements have been generated.
+--
+-- >>> import Data.Text.IO qualified as Text
+-- >>> Text.putStr (drawMergePattern (+) [1..] [1..] 10 50)
+-- . . . . . . . . . *
+-- . . . . . . . . * *
+-- . . . . . . . * * *
+-- . . . . . . * * * *
+-- . . . . . * * * * *
+-- . . . . . * * * * *
+-- . . . . * * * * * *
+-- . . . * * * * * * *
+-- . . * * * * * * * *
+-- . * * * * * * * * *
+drawMergePattern :: (Ord c) => (a -> b -> c) -> [a] -> [b] -> Int -> Int -> Text
+drawMergePattern = drawMergePatternWith applyMerge
+
+drawMergePatternWith ::
+  forall a b c.
+  (Ord c) =>
+  ApplyMerge ->
+  (a -> b -> c) ->
+  [a] ->
+  [b] ->
+  Int ->
+  Int ->
+  Text
+drawMergePatternWith applyMerge' f as bs size n =
+  let labeledAs :: [(a, Int)]
+      labeledAs = zip as [0 ..]
+
+      labeledBs :: [(b, Int)]
+      labeledBs = zip bs [0 ..]
+
+      f' :: (a, Int) -> (b, Int) -> (c, (Int, Int))
+      f' (a, x) (b, y) = (f a b, (x, y))
+
+      labeledCs :: [(c, (Int, Int))]
+      labeledCs = applyMerge' f' labeledAs labeledBs
+
+      markedIndices :: [(Int, Int)]
+      markedIndices =
+        labeledCs
+          & take n
+          & map snd
+          & filter (\(x, y) -> x < size && y < size)
+
+      markedArray :: Array (Int, Int) Bool
+      markedArray =
+        let r = ((0, 0), (size - 1, size - 1))
+         in Array.array ((0, 0), (size - 1, size - 1)) $
+              map (,False) (Array.range r)
+                ++ map (,True) markedIndices
+
+      mkRow :: Int -> Text
+      mkRow row =
+        Text.intersperse ' ' $
+          Text.pack $
+            flip map [0 .. size - 1] $ \i ->
+              if markedArray ! (row, i)
+                then '.'
+                else '*'
+   in Text.unlines (map mkRow [0 .. size - 1])