From 48e3bef3d4220e8ca20ae50dea5bd2993949e5bd Mon Sep 17 00:00:00 2001 From: Preetham Gujjula Date: Wed, 15 May 2024 13:18:54 -0700 Subject: [PATCH] [#14] Add drawMergePattern --- apply-merge.cabal | 12 ++++-- package.yaml | 6 +++ src/Data/List/ApplyMerge.hs | 83 ++++++++++++++++++++++++++++++++++++- 3 files changed, 97 insertions(+), 4 deletions(-) diff --git a/apply-merge.cabal b/apply-merge.cabal index d9fe7dd..cc2429a 100644 --- a/apply-merge.cabal +++ b/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 diff --git a/package.yaml b/package.yaml index dd5e7dc..773ffe2 100644 --- a/package.yaml +++ b/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} diff --git a/src/Data/List/ApplyMerge.hs b/src/Data/List/ApplyMerge.hs index 900b515..da641ba 100644 --- a/src/Data/List/ApplyMerge.hs +++ b/src/Data/List/ApplyMerge.hs @@ -7,12 +7,25 @@ -- License: BSD-3-Clause -- Maintainer: Preetham Gujjula -- 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])