Daily Haskell Exercise @dailyhaskellexercise - Tumblr Blog

Ordered Statistics Tree Part 1: product of finger trees

One thing about finger trees is that we often want to argument a few different data. For example, I might want to know the number of elements in a finger tree, while still able to do something else.

Certainly this is not hard easy, since we can just create a pair of two measurable types, add a sum type of integers. Just let the finger tree to measure both of them.

In order to do that, we should write a function that takes the product of measures.

productMeasure:: (Measured v a, Measured u b) => (a -> v)->(b -> u)->((a,b)->(v,u)).

Try to do this by Control.Arrow. It should be a really short answer.

#category

The $m$th element of the union of $k$ non decreasing sequence.

Problem

Let $f_i:\mathbb{N}\to X$ for all $1\leq i\leq k$, where $X$ is totally ordered, and if $a\leq b$ then $f_i(a)\leq f_i(b)$.

Write a function mthElementNonDecreasingSequences :: Ord a=>[(Integer->a)]->Integer->a that returns the $m$th element of the list that is created from combining all these sequence and sort them.

Solution

mthElementNonDecreasingSequences :: Ord a=>[Integer->a]->Integer->a mthElementNonDecreasingSequences xs m = solve (zip xs (repeat (0,m))) (m+1) where solve :: Ord a=> [(Integer->a,(Integer,Integer))]->Integer->a solve [x] m = func x (left x+m-1) solve xs m = solve bounds t where (t,op,op2) | s<=m = (m - diff v,minimum,removeDown) | otherwise = (m, maximum, removeUp) s = sum $ map diff xs z = zip (map takeMid xs) [0..] index = snd $ op z bounds = filter (\x-> left x <= right x) $ take index xs ++ [ op2 v ] ++ drop (index+1) xs v = xs!!index mid (_,(a,b)) = (a+b) `div` 2 left (_,(a,_)) = a right (_,(_,b)) = b func (f,_) = f takeMid a = func a (mid a) removeDown a = (func a, (mid a + 1,right a)) removeUp a = (func a, (left a, mid a - 1)) diff a = mid a - left a + 1

This solution takes $O(k^2 \log m)$ time.

#selection

Alias method

School is going to start, I don't have as much time in updating these...

Problem

Implements the alias method.

Solution

import Data.Ratio import Data.Array import Data.List (partition) import System.Random type DiscreteDistribution a = Array Int (Rational, a, a) discreteDistribution :: [(a,Integer)] -> DiscreteDistribution a discreteDistribution xs = listArray (0,length xs-1) (uncurry buildTable $ partition ((<h).snd) xs') where xs' = map (\(x,y)->(x,y%1)) xs s = foldl (\y (_,x)-> x + y) (0%1) xs' n = fromIntegral (length xs)%1 h = s / n buildTable [] ys = map (\(b,y)->(1%1,b,b)) ys buildTable ((a,x):xs) ((b,y):ys) = (x / h, a, b):sol where v = y-(h-x) sol | v >= h = buildTable xs ((b,v):ys) | v < h = buildTable ((b,v):xs) ys randomElement :: (RandomGen g) => DiscreteDistribution a -> g -> (a, g) randomElement a g = (if u <= numerator v then x else y,g'') where (r,g') = randomR (bounds a) g (v,x,y) = a!r (u,g'') = randomR (1, denominator v) g'

#probability

Periodic Sequence

A sequence is periodic if there exist a $p$, such that $a_i=a_{i+p}$ for all $i\geq 0$.

Problem

Implement the data PeriodicSequence a using Data.Sequence. Such that it is an Applicative, and it models function composition. eval f n :: PeriodicSequence a ->Int->a that evaluate the sequence at position n.

Solution

module PeriodicSequence(PeriodicSequence, eval, periodicSequence) where import Prelude hiding (zipWith, foldr) import qualified Prelude as P import Data.Sequence hiding (take, length) import Data.Foldable import Data.Monoid import Control.Applicative data PeriodicSequence a = PS Int (Seq a) deriving (Eq, Show, Ord) instance Functor PeriodicSequence where fmap f (PS n t) = PS n (fmap f t) instance (Monoid a) => Monoid (PeriodicSequence a) where mempty = PS 1 (singleton mempty) mappend x y = fmap (<>) x <*> y instance Applicative PeriodicSequence where pure f = PS 1 (singleton f) (<*>) (PS n xs) (PS m ys) = PS l (zipWith ($) xs' ys') where xs' = fromList $ take l $ cycle (toList xs) ys' = fromList $ take l $ cycle (toList ys) l = lcm n m eval :: PeriodicSequence a -> Int -> a eval (PS n xs) m = index xs (m `rem` n) periodicSequence :: [a]->PeriodicSequence a periodicSequence xs = PS (length xs) (fromList xs)

#sequence

Lattice Points on a Plane

A point $(x,y)$ on the plane is a lattice point if both $x$ and $y$ are integers.

Problem

Implement latticePoints2D :: [(Integer,Integer)], a infinite list of lattice points, such that every lattice point is in the list.

Solution

import Control.Arrow import Control.Monad import Data.List import Data.Tuple latticePoints :: [(Integer,Integer)] -- 90 180 270 latticePoints = (0,0):concat (transpose $ map (`map` v) [id, swap . first negate, join (***) negate, swap . second negate]) where v = takeLine 0 quadrant takeLine n xss = concat before ++ takeLine (n+1) (after ++ rest) where (prefix,rest) = splitAt n xss (before, after) = unzip $ map (splitAt 1) prefix quadrant = [[(x,y)|x<-[1..]]|y<-[0..]]

#lattice points

First true in a monotonic predicate over the naturals

Let False < True. A predicate $p$ is monotonic if for all $x\leq y$, $p(x)\leq p(y)$.

Problem

Write a function firstTrueMonotonicPredicate :: Integral a =>(a->Bool)->a that output the first position where a monotonic predicate over the natural numbers become true. The algorithm should evaluate the function $O(\log n)$ time, where $n$ is the output. The function does not terminate if all the values are False.

Solution

monotonicPredicate :: Integral a => (a -> Bool) -> a monotonicPredicate f = binSearch 0 ub where ub = 1 + expSearch 1 expSearch i | f i = i | otherwise = expSearch (2*i) -- search from [i,j) binSearch i j | j - i < 3 = if f i then i else i+1 | f mid = binSearch i (mid+1) | otherwise = binSearch (mid+1) j where mid = (i+j) `div` 2

#predicate

The minimum weight path of length $k$ in a DAG with Monge property

Problem

Consider we have a complete directed acyclic graph of $n$ vertices, such that the topological sort order is $v_1,\ldots,v_n$. There is a weight function $w(v_i,v_j)$, such that it has the Monge property, i.e. $w(v_i,v_j) + w(v_{i+1},v_{j + 1}) \leq w(v_i,v_{j+1}) + w(v_{i+1},v_{j})$ holds for all $1 < i + 1 < j \leq n$.

The weight of a path is the sum of the weight of all edges in the path. We want to find a path of length $k$ from $v_1$ to $v_n$, such that the weight is minimized.

The function would have the signature minWeightKLinkedPath :: (Integral a, Num b)=>a->a->(a->a->b)->[a]. The input is $n$, $k$, $w$ and the output is a minimum weight path of length $k$.

Solve the problem in $O(kn)$ time.

Hint

There is an algorithm to solve it in $O(k(n+m))$ time on stackoverflow, which can be modified to run in $O(kn^2)$ time.

Apply the technique in the talk Revisiting The Monge Property. The exercise on totally monotone matrices already implemented the subroutine!

Extensions

We can actually implement the most general form of the problem in Revisiting The Monge Property, and also reduce the memory usage from $O(kn)$ to $O(n)$. Looks like no one has done it with Haskell yet.

Applications

Consider the linear partition problem that got featured on hacker news. It can be reduced to this problem and produce a $O(kn)$ time solution. In the application $k$ is just $cn$ for some constant $c$, thus in theory there is a even better (in theory) solution that takes $n2^{O(\sqrt{\log k \log \log n})}$ time discovered by Schieber.

Solution

minWeightkEdgePath :: (Ord a, Num a) => Int -> Int -> (Int -> Int -> a) -> [Int] minWeightkEdgePath k n w = backtrack (k-1) n where backtrack (-1) _ = [] backtrack x y = y':backtrack (x-1) y' where y' = snd (d!(x,y)) d = array ((0,0),(k-1,n)) [ ((i,j), f i j) | i<-[0..k-1],j<-[0..n]] f 0 i = (w 0 i,0) -- uncomment the following line to use the slower algorithm -- f k i = minimum [(m k j i, j)|j<-[0..n]] f k i = (m k j i,j) where j = p!(k,i) p = array ((1,0),(k,n)) [((z,i),t) |z<-[1..k],(i,t)<-zip [0..n] (columnMinima (m z) (n+1) (n+1))] m k j i = fst (d!(k-1,j)) + w j i

#monge property #dynamic programming

Test if a integer is a perfect power

Problem

A integer $n$ is a perfect power if $n=m^k$ for some integer $m$ and $k>1$.

Write a program to check if a number is a perfect power.

Solution

import Math.NumberTheory.Primes.Heap -- Check if n = m^k. We do a normal search on k. lg :: Integral a => a->a lg n = monotonicPredicate (\k-> 2^k>n) isPerfectPower :: Integral a => a -> Bool isPerfectPower n = any (isExponent n) $ take (fromIntegral $ lg n) primes isExponent :: Integral a => a -> a -> Bool isExponent n m = cand ^ m == n where cand = monotonicPredicate (\k -> k^m >= n) monotonicPredicate :: Integral a => (a -> Bool) -> a monotonicPredicate f = binSearch 0 ub where ub = 1 + expSearch 1 expSearch i | f i = i | otherwise = expSearch (2*i) -- search from [i,j) binSearch i j | j - i < 3 = if f i then i else i+1 | f mid = binSearch i (mid+1) | otherwise = binSearch (mid+1) j where mid = (i+j) `div` 2

#number theory

Sum over a consecutive subsequence

Problem

Solve the Interval Product problem by create a set of functions that solve the following more abstract problem using Data.FingerTree.

Let's consider a sequence of elements in a monoid of $n$ elements, we are interested in the ability to modify an element in position i, insert/delete at position i, and calculate the sum of all elements between position i and j. All these operations should take $O(\log n)$ amortized time under the assumption that all monoid operation takes $O(1)$ time.

Motivation: This exercise shows that finger trees can replace binary indexed (Fenwick) trees. The abstract problem can be used to solve problems like Potentiometers and Frequent Values.

Solution

MonoidSequence.hs

{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleContexts #-} module MonoidSequence(MonoidSequence, splitPosition, update, insert, delete, infixSum, fromList) where import Data.FingerTree hiding (fromList) import qualified Data.FingerTree as F import Data.Monoid type MonoidSequence a = FingerTree (Sum Int, a) (S a) newtype S a = S a instance Monoid a => Measured (Sum Int, a) (S a) where measure (S x) = (Sum 1, x) splitPosition :: Measured (Sum Int, a) (S a) => Int -> MonoidSequence a -> (MonoidSequence a, MonoidSequence a) splitPosition i = split (\(Sum x,_)-> x > i) update :: Measured (Sum Int, a) (S a) => Int -> a -> MonoidSequence a -> MonoidSequence a update i entry tree = insert i entry (delete i tree) insert :: Measured (Sum Int, a) (S a) => Int -> a -> MonoidSequence a -> MonoidSequence a insert i entry tree = x >< singleton (S entry) >< y where (x,y) = splitPosition i tree delete :: Measured (Sum Int, a) (S a) => Int -> MonoidSequence a -> MonoidSequence a delete i tree = x >< y where (x,z) = splitPosition i tree (_,y) = splitPosition 1 z -- sum from position i to position j not inclusive infixSum :: Measured (Sum Int, a) (S a) => Int -> Int -> MonoidSequence a -> a infixSum i j tree = snd $ measure y where (_,z) = splitPosition i tree (y,_) = splitPosition (j-i) z fromList :: Monoid a => [a]-> MonoidSequence a fromList xs = F.fromList $ map S xs

IntervalProduct.hs

-- Interval Product -- ICPC Latin American Regional 2012 Problem I -- ACM-ICPC Live Archive Problem 6139 import MonoidSequence import Data.Monoid import Data.List.Split data Sign = N | Z | P deriving (Eq) instance Show Sign where show N = "-" show P = "+" show Z = "0" instance Monoid Sign where mempty = P mappend Z _ = Z mappend _ Z = Z mappend P x = x mappend x P = x mappend N N = P toSign :: Int -> Sign toSign x | x == 0 = Z | x > 0 = P | x < 0 = N main :: IO () main = interact process process :: String -> String process input = sol l where l = words input sol (n':k':xs) = solve (fromList values) operations ++ sol (drop (n+3*k) xs) where (n,k) = (read n', read k') values = map (toSign.read) (take n xs) operations = map (\[a,b,c]-> (a, read b, read c)) $ chunksOf 3 $ take (3*k) (drop n xs) sol _ = "" solve :: MonoidSequence Sign -> [(String, Int, Int)] -> String solve values ((a,b,c):operations) | a == "P" = show (infixSum (b-1) c values) ++ solve values operations | a == "C" = solve (update (b-1) (toSign c) values) operations solve _ [] = "\n"

#finger tree #data structure

Column Minima in a totally monotone matrix

Let type Matrix a = Int->Int->a to denote a matrix. $A=\{a_{i,j}\}$ for $1\leq i\leq n, 1\leq j\leq m$ is a totally monotone matrix is if for all $i < i'$ and $j < j'$, we have $a_{i,j} > a_{i',j} \Rightarrow a_{i,j'} > a_{i',j'}$. We want an algorithm that uses $O(n+m)$ evaluation of the entries of the matrix to find out the row position of each column's minima.

The SMAWK algorithm solves this problem. Here is an video which features the algorithm around 37 minutes into the video. David Eppstein have a python implementation of the algorithm.

Implement columnMinima :: Ord a => Matrix a->Int->Int->[Int], which takes a totally monotone matrix with it's width and height, it find the list of column minima's row position.

Example

SMAWK.hs

module SMAWK (columnMinima) where -- matrix is totally monotone. matrix i j = (a!!i)!!j where a = [[8,5,5,13,53,68], [m,5,1,5,37,50], [m,m,5,1,17,26], [m,m,m,13,13,18], [m,m,m,m,53,50], [m,m,m,m,m,68]] m = 10000 ghci> columnMinima matrix 6 6 [0,0,1,2,3,3]

Solution

My solution is just a Haskell translation of Eppstein's code. It requires evenOddSplit and horizontalPath.

module SMAWK (columnMinima) where import qualified Data.IntMap as M import Data.Array

type Coord = M.IntMap Int type Matrix a = Int->Int->a columnMinima :: Ord a => Matrix a->Int->Int->[Int] columnMinima m w h = [(M.!) pos x|x<-[0..w-1]] where pos = smawk [0..h-1] [0..w-1] m -- Rows, Cols, Matrix, Maximum smawk :: Ord a => [Int]->[Int]->Matrix a ->Coord smawk rows cols m | null cols = M.empty | otherwise = interpolate row2 where row2 = reverse $ reduce rows [] minima = smawk row2 (snd $ evenOddSplit cols) m cols' = listArray (0,n-1) cols n = length cols -- the reduce part reduce :: [Int]->[Int]->[Int] reduce xs ys -- ys is stack | null xs = ys | null ys = cont | m y ci > m x ci = reduce xs (tail ys) | t /= n = cont | otherwise = reduce (tail xs) ys where x = head xs y = head ys ci = cols'!(t-1) cont = reduce (tail xs) (x:ys) t = length ys interpolate :: [Int]->Coord interpolate rows = M.fromList (map f broken) `M.union` minima where broken = zip (fst $ evenOddSplit cols) (horizontalPath rows ([head rows]++[M.findWithDefault (last rows) (cols'!(c+1)) minima | c<-[0,2..n-2]]++[last rows])) f (a,b) = (a, snd $ minimum $ map g b) where g i = (m i a, i)

#smawk #matrix

Split a increasing list by break points

Problem

Let $A=a_1,\ldots,a_n$ and $B=b_1,\ldots,b_m$ be two lists, such that $\{b_1,\ldots,b_m\} \subset \{a_1,\ldots,a_n\}$ and $a_1 < a_2 < \ldots < a_n$, $a_1 = b_1\leq \ldots \leq b_m = a_n$. Write a horizontalPath :: Ord a => [a]->[a]->[[a]] that outputs a sequence of lists in $A$ that lies in between consecutive values of $B$ (inclusive) in $O(n+m)$ time.

Example:

ghci> horizontalPath [0..4] [0,0,1,4] [[0],[0,1],[1,2,3,4]]

Motivation: This function together with evenOddSplit are the building block of the SMAWK algorithm for finding all the row minimum in a totally monotone matrix.

Solution

horizontalPath :: Ord a => [a]->[a]->[[a]] horizontalPath xs bp = part xs (zip (init bp) (tail bp)) where part xs ((start,end):bp) = prefix:part (end:suffix) bp where (prefix,suffix) = break (> end) xs part _ [] = []

#list

Step Function 5: Applicative

This is the last post about StepFunction module.

Not all programs can be written in the best form the first time around. The API design for StepFunction in the third post seems like someone thought of it in 5 minutes(indeed it was...).

Are there better representation of step function? We don't really need a pair of numbers to specify the interval, we just need to know one end point, and the next end point is implicit.

Why is Monoid required to create a StepFunction?

Why do we require Eq b? It allows one to merge intervals together, and make sure the representation is unique. However, there is no way to express StepFunction a as an instance Applicative if we enforce this requirement.

Let's change the representation for StepFunction. Create a toStepFunction :: (Ord a) => ([a],[b]) -> StepFunction a b, and we should build a inverse fromStepFunction. The first list is a strictly increasing list of end points, and second list is a list of values associated with the first list of points. The second list have one more element to account for all the values before the first end point. Consider the following step function

\[ f(x) = \begin{cases} 0 &\text{if } x < 1 \newline 1 & \text{if } x \in [1,2) \newline 2 & \text{if } x \in [2,3) \newline 3 & \text{if } x > 3 \end{cases} \]

It is constructed by

ghci> toStepFunction ([1,2,3],[0,1,2,3]) Step [(Minimum,0),(Value 1,1),(Value 2,2),(Value 3,3)] ghci> fromStepFunction $ toStepFunction ([1,2,3],[0,1,2,3]) ([1,2,3],[0,1,2,3])

Eq b is no longer a requirement, and the following very redundant StepFunction can be created.

ghci> toStepFunction ([1,2,3],[0,0,0,0]) Step [(Minimum,0),(Value 1,0),(Value 2,0),(Value 3,0)]

To solve this problem, introduce compress:: (Eq b, Ord a) => StepFunction a b -> StepFunction a b.

ghci> compress $ toStepFunction ([1,2,3],[0,0,0,0]) Step [(Minimum,0)]

The module will be more useful if we can make it instances of some popular type classes. Note that $f \circ g$ is a step function if $g$ is a step function. Since $f\circ g$ is just a map over the range, this is a hints that StepFunction a can be implemented as a Functor. Indeed it can be.

Can we make StepFunction a an Applicative? The type of <*> would be StepFunction a (b -> c) -> StepFunction a b -> StepFunction a c. How to make sense of this? We can define it naturally as apply a different function at different intervals.

A concrete example: \[ f(x) = \begin{cases} (\lambda b\to b) &\text{if } x < 0 \newline (\lambda b \to b+1) & \text{otherwise} \end{cases} \] and \[ g(x) = \begin{cases} 0 &\text{if } x < 1 \newline 1 & \text{otherwise} \end{cases} \] \[ (f <*> g)(x) = \begin{cases} 0 &\text{if } x < 0 \newline 1 &\text{if } x < 1 \newline 2 & \text{otherwise} \end{cases} \]

mappend defined on StepFunction a b become a special case of <*>, and the code become much more powerful.

Problem

Rewrite the module, implement fromStepFunction, toStepFunction, compress, eval and make StepFunction a a instance of Applicative.

Future possibilities

Algorithmically, the list based implementation uses $O(n)$ time to transverse the list to find the points of interest. We can use finger trees to improve eval and <*> to $O(\log n)$ and $O(n\log \frac{m}{n})$ time respectively, where $n$ and $m$ are the number of steps in each step function and $n\leq m$.

How can we solve this problem other than call compress manually? I don't have an answer yet.

One could polish this up and upload it to hackage.

Solution

From now on the first solution posted here will be written by me(Chao Xu) unless otherwise specified...

module StepFunction ( StepFunction, eval, toStepFunction, fromStepFunction, compress) where import Control.Arrow import Control.Applicative import Data.Monoid data Bound a = Minimum | Value a | Maximum deriving (Eq, Ord, Show) type Point a b = (Bound a, b) data StepFunction a b = Step [Point a b] deriving (Show, Eq, Ord) instance (Ord x, Monoid y) => Monoid (StepFunction x y) where mempty = Step [(Minimum,mempty)] mappend x y = fmap mappend x <*> y instance Functor (StepFunction a) where fmap f (Step xs) = Step (map (second f) xs) instance (Ord a) => Applicative (StepFunction a) where pure f = Step [(Minimum, f)] (Step fs) <*> (Step xs) = Step (applyStepFunction (fs++[(Maximum,f)]) (xs++[(Maximum,x)])) where (_,x) = head xs (_,f) = head fs compress :: (Ord a, Eq b)=>StepFunction a b->StepFunction a b compress (Step xs) = Step (merge xs) where merge ((a,b):(c,d):xs) | b == d = merge ((a,b):xs) | otherwise = (a,b):merge ((c,d):xs) merge x = x toStepFunction :: (Ord a) => ([a],[b]) -> StepFunction a b toStepFunction (as,bs) | isIncreasing Minimum as = Step (zip (Minimum:map Value as) bs) | otherwise = error "Not a increasing sequence of points." fromStepFunction :: (Ord a) => StepFunction a b -> ([a],[b]) fromStepFunction (Step xs) = (map (\(Value a,_)->a) (tail xs), map snd xs) eval :: (Ord a) => StepFunction a b -> a -> b eval (Step xs) x = snd $ fst $ head $ dropWhile (\((a,_),(b,_))-> a > Value x || b < Value x) z where z = zip xs (tail xs ++ end xs) isIncreasing :: (Ord a)=>Bound a->[a]->Bool isIncreasing p (x:xs) | p < Value x = isIncreasing (Value x) xs | otherwise = False isIncreasing _ [] = True end :: [Point a b] -> [Point a b] end xs = [(Maximum, snd (head xs))] -- in the beginning, both are at Minimum, we will maintain invariant that -- the head of both list have the same starting point. applyStepFunction :: Ord a => [Point a (b->c)]->[Point a b]->[Point a c] applyStepFunction ((begin, f):fs) ((_,x):xs) | begin == Maximum = [] | endf < endx = fx:applyStepFunction fs ((endf,x):xs) | endf == endx = fx:applyStepFunction fs xs | endf > endx = fx:applyStepFunction ((endx,f):fs) xs where (endf, _) = head fs (endx, _) = head xs fx = (begin, f x)

#project #step function #applicative

Step Function 4: Application

Problem

We will use the StepFunction module to solve Serial Numbers, a problem form ACM-ICPC Mid-Central Regional in 2008. Note this problem took the contestants a while to solve. Let's do this in Haskell.

Solution

Chao Xu's solution. It requires the StepFunction module from the previous exercise and the split package.

The idea is to create a monoid that replace the value each time, and the remaining is just data parsing and output, the StepFunction module takes care of the main logic.

import Data.Monoid import StepFunction import Data.List.Split main :: IO () main = interact process data Code = Code String | Identity deriving (Eq, Show) -- Notice the mappend is nothing more than always take the right value unless -- it is Identity instance Monoid Code where mempty = Identity mappend a b | a == Identity = b | b == Identity = a | otherwise = b process :: String -> String process input = concatMap solve problem where problem = init $ splitOn ["0"] $ lines input -- solve each individual problem solve x = head x ++ "\n" ++ build where build = concatMap writeCommand $ (\(_,t,_)->t) $ toList $ stepFunction sol sol = map readCommand (tail x) readCommand :: String -> (Int, Int, Code) readCommand s = (read a, read b + 1, Code (unwords [c,d])) where [a,b,c,d] = words s writeCommand :: (Int, Int, Code) -> String writeCommand (a, b, Code c) = show a ++ " " ++ show (b-1) ++ " " ++ c ++ "\n" writeCommand (_, _, Identity) = ""

Compare this with the java solution here. The java solution was written in 1.5 hours, with most of the time spent on debugging.

#application #acm-icpc #project #monoid #step function

Step Function 3: Encapsulation

We have a working solution for a step function problem. If a user can arbitrarily do things to the StepFunction data, they could create invalid step functions that still consistent with the type. See how the requirements for the representation of step function as lists are not enforceable through type alone.

One way to solve it is to use module as a form of encapsulation, and then only provide smart constructors and abstract data type.

Problem

Create a module for StepFunction, so the inner working of the StepFunction is unknown to the outside. Only eval, stepFunction and stepFunctionBase are exposed.

stepFunctionBase :: (Ord a, Monoid b, Eq b) => b -> [(a,a,b)] -> StepFunction a b stepFunction :: (Ord a, Monoid b, Eq b) => [(a,a,b)] -> StepFunction a b stepFunction = StepFunctionBase mempty toList :: (Ord a, Monoid b, Eq b) => StepFunction a b-> (b,[(a,a,b)],b)

stepFunctionBase creates a StepFunction by summing the list of intervals to a base interval with value b. toList create a new kind of representation of the StepFunction, the left most element is the value taken from Minimum to the start position of the first interval in the middle. The right most element is the value taken from the end position of the last interval to Maximum.

Examples

ghci> stepFunctionBase [0] [(0,1,[1]),(1,2,[2])] StepFunction [(Minimum,Value 0,[0]),(Value 0,Value 1,[1,0]),(Value 1,Value 2,[2,0]),(Value 2,Maximum,[0])] -- overlap intervals in the input is possible ghci> stepFunctionBase [0] [(0,2,[1]),(1,2,[2])] StepFunction [(Minimum,Value 0,[0]),(Value 0,Value 1,[1,0]),(Value 1,Value 2,[1,2,0]),(Value 2,Maximum,[0])] -- $(a,b,_)$ is a empty interval if $a\geq b$. ghci> stepFunction [(0,-1,[1])] StepFunction [(Minimum,Maximum,[])] ghci> toList $ stepFunctionBase [0] [(0,2,[1]),(1,2,[2])] ([0],[(0,1,[1,0]),(1,2,[1,2,0])],[0]) ghci> toList $ stepFunctionBase [0] [(0,1,[1]),(1,2,[2])] ([0],[(0,1,[1,0]),(1,2,[2,0])],[0])

Solution

Chao Xu's solution.

module StepFunction ( StepFunction, eval, stepFunction, stepFunctionBase, toList) where import Data.Monoid data Bound a = Minimum | Value a | Maximum deriving (Eq, Ord, Show) type Interval a b = (Bound a, Bound a, b) data StepFunction a b = StepFunction [Interval a b] deriving (Show, Eq, Ord) -- interval constructors interval :: (Ord a) => a->a->b->Interval a b interval a b y = (Value a, max (Value a) (Value b), y) leftRay :: (Ord a) => a->b->Interval a b leftRay a y = (Minimum, Value a, y) rightRay :: (Ord a) => a->b->Interval a b rightRay b y = (Value b, Maximum, y) instance (Ord x, Eq y, Monoid y) => Monoid (StepFunction x y) where mempty = StepFunction [(Minimum, Maximum, mempty)] mappend (StepFunction xs) (StepFunction ys) = StepFunction (merge $ foldl insertInterval ys xs) where insertInterval [] _ = [] insertInterval ((a',b',y'):ls) (a,b,y) | a >= b' = non [(a',b',y')] ++ insertInterval ls (a,b,y) | b >= b' = non [(a',a,y'),(a,b',y <> y')] ++ insertInterval ls (b',b,y) | b < b' = non [(a',a,y'),(a,b, y <> y'),(b,b',y')] ++ ls where non = filter (\(u,v,_)-> u/=v) merge (h@(a,_,y):h'@(_,b',y'):ls) | y == y' = merge ((a,b',y):ls) | otherwise = h:merge (h':ls) merge x = x eval :: (Ord a) => StepFunction a b -> a -> b eval (StepFunction xs) t = y where (_,_,y) = head $ dropWhile sol xs sol (a,b,_) | a<=Value t && Value t<b = False | otherwise = True stepFunction :: (Ord a, Monoid b, Eq b) => [(a,a,b)] -> StepFunction a b stepFunction = stepFunctionBase mempty stepFunctionBase :: (Ord a, Monoid b, Eq b) => b -> [(a,a,b)] -> StepFunction a b stepFunctionBase base xs = mconcat (map basis xs) `mappend` StepFunction [(Minimum, Maximum, base)] where basis (a,b,y) = StepFunction [leftRay (min a b) mempty, interval a b y, rightRay (max a b) mempty] toList :: StepFunction a b -> (b,[(a,a,b)],b) toList (StepFunction xs) = (value $ head xs, map (\(Value a, Value b, y)->(a,b,y)) $ reverse $ drop 1 $ reverse $ drop 1 xs, value $ last xs) where value (_,_,y) = y

#project #math #monoid #abstraction #step function

Step Function 2: Monoid

Following the previous exercise.

Problem

It is not surprising that the step functions form a monoid by adding the values pointwise. Implement the type StepFunction a b, such that instance (Ord x, Monoid y) => Monoid (StepFunction x y). Also implement eval :: StepFunction a b -> a -> b, which evaluates the value of a step function at a point.

Solution

Chao Xu's solution, requires the Interval a b and Bound a type from the previous exercise. Note insertInterval has the arguments switched.

import Data.List import Data.Monoid data StepFunction a b = StepFunction [Interval a b] deriving (Show, Eq, Ord) instance (Ord x, Eq y, Monoid y) => Monoid (StepFunction x y) where mempty = StepFunction [(Minimum, Maximum, mempty)] mappend (StepFunction a) (StepFunction b) = StepFunction (merge $ foldl insertInterval b a) where insertInterval [] _ = [] insertInterval ((a',b',y'):xs) (a,b,y) | a >= b' = non [(a',b',y')] ++ insertInterval xs (a,b,y) | b >= b' = non [(a',a,y'),(a,b',y <> y')] ++ insertInterval xs (b',b,y) | b < b' = non [(a',a,y'),(a,b, y <> y'),(b,b',y')] ++ xs where non = filter (\(a,b,_)-> a/=b) merge (h@(a,_,y):h'@(_,b',y'):xs) | y == y' = merge ((a,b',y):xs) | otherwise = h:merge (h':xs) merge x = x eval :: (Ord a) => StepFunction a b -> a -> b eval (StepFunction xs) t = y where (_,_,y) = head $ dropWhile sol xs sol (a,b,y) | a<=Value t && Value t<b = False | otherwise = True

#project #math #monoid #step function

Step Function 1: Insert Interval

Let type Interval a b = (Bound a, Bound a, b), where Bound a comes from the previous exercise. It will represent a open interval associated with a value.

We define a step function $f:X\to Y$, if $X$ is totally ordered(type class Ord), $(Y,+)$ is a monoid (type class Monoid), and we can express $f(x) = \sum_{i=1}^n y_i \chi_{[a_i,b_i)}(x)$, where $[a_i,b_i)$ are half open interval on $X$, and none of them intersects. To learn more about step functions, see here. (we use a special case of step function, we require the intervals to be half open intervals.)

We can represent a step function as a unique ordered list of disjoint Interval x y, such that:

The end point of a interval is the beginning point of the next one.

The first interval starts with Minimum and the last ends with Maximum.

Consecutive intervals doesn't have the same value.

No empty intervals.

A example, the step function: \[ f(x) = \begin{cases} "birthday" &\text{if } x \in [5,26) \newline "" & \text{otherwise} \end{cases} \]

the representation:

[(Minimum, Value 5, ""), (Value 5, Value 26, "birthday"), (Value 26, Maximum, "")]

Problem

Create the function insertInterval :: (Ord a, Eq b, Monoid b) => Interval a b->[Interval a b]->[Interval a b]. So if s is a representation of $f$, then insert (a,b,y) s = s'. s' would be a representation of $g(x) = y\chi_{[a,b)}(x) + f(x)$.

Example

ghci> insertInterval (Value 5, Value 26, [1]) [(Minimum, Maximum, [0])] [(Minimum,Value 5,[0]),(Value 5,Value 26,[1,0]),(Value 26,Maximum,[0])] ghci> insertInterval (Value 5, Value 26, []) [(Minimum, Maximum, [])] [(Minimum, Maximum, []) ghci> insertInterval (Value 26, Value 27, [1]) [(Minimum, Value 5, []), (Value 5, Value 26, [1]), (Value 26, Maximum, [])] [(Minimum,Value 5,[]),(Value 5,Value 27,[1]),(Value 27,Maximum,[])]

Solution

Chao Xu's solution.

insertInterval :: (Ord a, Eq b, Monoid b) => Interval a b->[Interval a b]->[Interval a b] insertInterval x y = merge (insert x y) where insert _ [] = [] insert (a,b,y) ((a',b',y'):xs) | a >= b' = non [(a',b',y')] ++ insert (a,b,y) xs | b >= b' = non [(a',a,y'),(a,b',y <> y')] ++ insert (b',b,y) xs | b < b' = non [(a',a,y'),(a,b, y <> y'),(b,b',y')] ++ xs where non = filter (\(a,b,_)-> a/=b) merge (h@(a,_,y):h'@(_,b',y'):xs) | y == y' = merge ((a,b',y):xs) | otherwise = h:merge (h':xs) merge x = x

Note

This is somewhat ugly. Why do we use [Interval a b] instead of a type that make sure we have a valid representation for step function? This is just the first of a series of exercise that lead up to a elegant, general and efficient solution.

#project #monoid #math #step function

Extend any order to have a maximum and minimum element

Problem

Sometimes we want to have a smallest element in a Ord type, but certain Ord types doesn't have them, say Integer. This exercise tries to solve this problem.

Create a new data Bound a, such that it is a instance of Ord. The intended use is to embed a to Bound a, such that we still have the original ordering, but added two more elements Maximum and Minimum, such that they are greater than all elements, or smaller than all elements, respectively.

Solution

Note how everything is taken care of by Haskell's own deriving mechanism, thus one doesn't have to write his own implementation of compare.

data Bound a = Minimum | Value a | Maximum deriving (Eq, Ord)

Note

For any ordered set $(S,\leq)$, one can add two more elements $-\infty$ and $\infty$. Let $\overline{S} = S \cup \{-\infty,\infty\}$. We create a new order $(\overline{S},\preceq)$, such that $-\infty$ and $\infty$ are the minimum and maximum element respectively, and $a\leq b \Leftrightarrow a\preceq b$ for all $a,b\in S$.

This allows $\min$ and $\max$ to form a monoid over $\overline{S}$. This basically a semigroups embedding to a monoid.

#order

Trending Blogs

Recently Viewed Blogs

Daily Haskell Exercise