Personal tools

Haskell Quiz/Maximum Sub-Array/Solution Jkramar

From HaskellWiki

< Haskell Quiz | Maximum Sub-Array(Difference between revisions)
Jump to: navigation, search
m
m
 
(3 intermediate revisions by one user not shown)
Line 1: Line 1:
 
[[Category:Haskell Quiz solutions|Maximum Sub-Array]]
 
[[Category:Haskell Quiz solutions|Maximum Sub-Array]]
+
This includes a solution to the "extra credit" problem of finding the maximum subrectangle.
 
<haskell>
 
<haskell>
maxSubArray xs = drop from$take to xs where
+
import Data.List
  +
  +
maxSubArray' :: (Ord a, Num a) => [a] -> (a, (Int, Int))
  +
maxSubArray' xs = maximum$zipWith diff sumswithpos$scanl1 min sumswithpos where
 
sumswithpos = zip (scanl (+) 0 xs) [0..]
 
sumswithpos = zip (scanl (+) 0 xs) [0..]
diff ((a,ai),(b,bi)) = (a-b,(bi,ai))
+
diff (a,ai) (b,bi) = (a-b,(ai,bi))
(from,to) = snd$maximum$map diff$zip sumswithpos$scanl1 min sumswithpos
+
  +
maxSubArray :: (Ord a, Num a) => [a] -> [a]
  +
maxSubArray xs = drop from$take to xs where (_, (to, from)) = maxSubArray' xs
  +
  +
maxSubRect' :: (Ord a, Num a) => [[a]] -> ((a, (Int, Int)), (Int, Int))
  +
maxSubRect' as = maximum rectsums where
  +
sums ((c,b):rs) = [(maxSubArray'$zipWith (-) b' b, (c',c))|(c',b') <- rs]
  +
rectsums = concatMap sums$init$tails$zip [0..]$transpose$map (scanl (+) 0) as
  +
  +
maxSubRect :: (Ord a, Num a) => [[a]] -> [[a]]
  +
maxSubRect as = map (drop y1.take y2)$drop x1$take x2 as where
  +
((_,(x2,x1)),(y2,y1)) = maxSubRect' as
  +
</haskell>
  +
And now with a gratuitous monad, which actually ends up decreasing the type-safety:
  +
<haskell>
  +
import Data.Monoid
  +
import Data.Function (on)
  +
import Data.List
  +
import Control.Applicative
  +
import Control.Monad
  +
import Data.Ord (comparing)
  +
  +
data TakeNote n a = TakeNote !n !a deriving (Show, Read)
  +
note (TakeNote n _) = n
  +
dropNote (TakeNote _ a) = a
  +
instance (Eq a) => Eq (TakeNote n a) where (==) = (==) `on` dropNote
  +
instance (Ord a) => Ord (TakeNote n a) where compare = comparing dropNote
  +
instance (Monoid n) => Monad (TakeNote n) where
  +
return = TakeNote mempty
  +
TakeNote n a >>= f = TakeNote (mappend n m) b where TakeNote m b = f a
  +
instance Functor (TakeNote n) where fmap f (TakeNote n a) = TakeNote n$f a
  +
instance (Monoid n) => Applicative (TakeNote n) where pure = return; (<*>) = ap
  +
  +
number :: [a] -> [TakeNote [Int] a]
  +
number = zipWith TakeNote (pure<$>[0..])
  +
  +
psum :: (Num a) => [a] -> [a]
  +
psum = scanl (+) 0
  +
  +
maxSubArray' :: (Ord a, Num a) => [a] -> TakeNote [Int] a
  +
maxSubArray' xs = maximum$zipWith (liftA2 (-)) psums$scanl1 min psums where
  +
psums = number$psum xs
  +
  +
maxSubArray' :: (Ord a, Num a) => [a] -> [a]
  +
maxSubArray xs = drop from$take to xs where [to, from] = note$maxSubArray' xs
  +
  +
maxSubRect' :: (Ord a, Num a) => [[a]] -> TakeNote [Int] a
  +
maxSubRect' as = maximum$concatMap sums$tails$number$transpose$psum<$>as where
  +
sums (r:rs) = [maxSubArray'=<<liftA2 (zipWith (-)) r' r|r'<-rs]; sums [] = []
  +
  +
maxSubRect :: (Ord a, Num a) => [[a]] -> [[a]]
  +
maxSubRect as = map (drop y1.take y2)$drop x1$take x2 as where
  +
[y2,y1,x2,x1] = note$maxSubRect' as
 
</haskell>
 
</haskell>

Latest revision as of 18:47, 21 February 2010

This includes a solution to the "extra credit" problem of finding the maximum subrectangle.

import Data.List
 
maxSubArray' :: (Ord a, Num a) => [a] -> (a, (Int, Int))
maxSubArray' xs = maximum$zipWith diff sumswithpos$scanl1 min sumswithpos where
  sumswithpos = zip (scanl (+) 0 xs) [0..]
  diff (a,ai) (b,bi) = (a-b,(ai,bi))
 
maxSubArray :: (Ord a, Num a) => [a] -> [a]
maxSubArray xs = drop from$take to xs where (_, (to, from)) = maxSubArray' xs
 
maxSubRect' :: (Ord a, Num a) => [[a]] -> ((a, (Int, Int)), (Int, Int))
maxSubRect' as = maximum rectsums where 
  sums ((c,b):rs) = [(maxSubArray'$zipWith (-) b' b, (c',c))|(c',b') <- rs]
  rectsums = concatMap sums$init$tails$zip [0..]$transpose$map (scanl (+) 0) as
 
maxSubRect :: (Ord a, Num a) => [[a]] -> [[a]]
maxSubRect as = map (drop y1.take y2)$drop x1$take x2 as where
  ((_,(x2,x1)),(y2,y1)) = maxSubRect' as

And now with a gratuitous monad, which actually ends up decreasing the type-safety:

import Data.Monoid
import Data.Function (on)
import Data.List
import Control.Applicative
import Control.Monad
import Data.Ord (comparing)
 
data TakeNote n a = TakeNote !n !a deriving (Show, Read)
note (TakeNote n _) = n
dropNote (TakeNote _ a) = a
instance (Eq a) => Eq (TakeNote n a) where (==) = (==) `on` dropNote
instance (Ord a) => Ord (TakeNote n a) where compare = comparing dropNote
instance (Monoid n) => Monad (TakeNote n) where
  return = TakeNote mempty
  TakeNote n a >>= f = TakeNote (mappend n m) b where TakeNote m b = f a
instance Functor (TakeNote n) where fmap f (TakeNote n a) = TakeNote n$f a
instance (Monoid n) => Applicative (TakeNote n) where pure = return; (<*>) = ap
 
number :: [a] -> [TakeNote [Int] a]
number = zipWith TakeNote (pure<$>[0..])
 
psum :: (Num a) => [a] -> [a]
psum = scanl (+) 0
 
maxSubArray' :: (Ord a, Num a) => [a] -> TakeNote [Int] a
maxSubArray' xs = maximum$zipWith (liftA2 (-)) psums$scanl1 min psums where
  psums = number$psum xs
 
maxSubArray' :: (Ord a, Num a) => [a] -> [a]
maxSubArray xs = drop from$take to xs where [to, from] = note$maxSubArray' xs
 
maxSubRect' :: (Ord a, Num a) => [[a]] -> TakeNote [Int] a
maxSubRect' as = maximum$concatMap sums$tails$number$transpose$psum<$>as where
  sums (r:rs) = [maxSubArray'=<<liftA2 (zipWith (-)) r' r|r'<-rs]; sums [] = []
 
maxSubRect :: (Ord a, Num a) => [[a]] -> [[a]]
maxSubRect as = map (drop y1.take y2)$drop x1$take x2 as where
  [y2,y1,x2,x1] = note$maxSubRect' as