Related
i'm trying to write a function that for n gives matrix n*n with unique rows and columns (latin square).
I got function that gives my list of strings "1" .. "2" .. "n"
numSymbol:: Int -> [String]
I tried to generate all permutations of this, and them all n-length tuples of permutations, and them check if it is unique in row / columns. But complexity (n!)^2 works perfect for 2 and 3, but with n > 3 it takes forever. It is possible to build latin square from permutations directly, for example from
permutation ( numSymbol 3) = [["1","2","3"],["1","3","2"],["2","1","3"],["2","3","1"],["3","1","2"],["3","2","1"]]
get
[[["1","2","3",],["2","1","3"],["3","1","2"]] , ....]
without generating list like [["1",...],["1",...],...], when we know first element disqualify it ?
Note: since we can easily take a Latin square that's been filled with numbers from 1 to n and re-label it with anything we want, we can write code that uses integer symbols without giving anything away, so let's stick with that.
Anyway, the stateful backtracking/nondeterministic monad:
type StateList s = StateT s []
is helpful for this sort of problem.
Here's the idea. We know that every symbol s is going to appear exactly once in each row r, so we can represent this with an urn of all possible ordered pairs (r,s):
my_rs_urn = [(r,s) | r <- [1..n], s <- [1..n]]
Similarly, as every symbol s appears exactly once in each column c, we can use a second urn:
my_cs_urn = [(c,s) | c <- [1..n], s <- [1..n]]
Creating a Latin square is matter of filling in each position (r,c) with a symbol s by removing matching balls (r,s) and (c,s) (i.e., removing two balls, one from each urn) so that every ball is used exactly once. Our state will be the content of the urns.
We need backtracking because we might reach a point where for a particular position (r,c), there is no s such that (r,s) and (c,s) are both still available in their respective urns. Also, a pleasant side-effect of list-based backtracking/nondeterminism is that it'll generate all possible Latin squares, not just the first one it finds.
Given this, our state will look like:
type Urn = [(Int,Int)]
data S = S
{ size :: Int
, rs :: Urn
, cs :: Urn }
I've included the size in the state for convenience. It won't ever be modified, so it actually ought to be in a Reader instead, but this is simpler.
We'll represent a square by a list of cell contents in row-major order (i.e., the symbols in positions [(1,1),(1,2),...,(1,n),(2,1),...,(n,n)]):
data Square = Square
Int -- square size
[Int] -- symbols in row-major order
deriving (Show)
Now, the monadic action to generate latin squares will look like this:
type M = StateT S []
latin :: M Square
latin = do
n <- gets size
-- for each position (r,c), get a valid symbol `s`
cells <- forM (pairs n) (\(r,c) -> getS r c)
return $ Square n cells
pairs :: Int -> [(Int,Int)]
pairs n = -- same as [(x,y) | x <- [1..n], y <- [1..n]]
(,) <$> [1..n] <*> [1..n]
The worker function getS picks an s so that (r,s) and (c,s) are available in the respective urns, removing those pairs from the urns as a side effect. Note that getS is written non-deterministically, so it'll try every possible way of picking an s and associated balls from the urns:
getS :: Int -> Int -> M Int
getS r c = do
-- try each possible `s` in the row
s <- pickSFromRow r
-- can we put `s` in this column?
pickCS c s
-- if so, `s` is good
return s
Most of the work is done by the helpers pickSFromRow and pickCS. The first, pickSFromRow picks an s from the given row:
pickSFromRow :: Int -> M Int
pickSFromRow r = do
balls <- gets rs
-- "lift" here non-determinstically picks balls
((r',s), rest) <- lift $ choices balls
-- only consider balls in matching row
guard $ r == r'
-- remove the ball
modify (\st -> st { rs = rest })
-- return the candidate "s"
return s
It uses a choices helper which generates every possible way of pulling one element out of a list:
choices :: [a] -> [(a,[a])]
choices = init . (zipWith f <$> inits <*> tails)
where f a (x:b) = (x, a++b)
f _ _ = error "choices: internal error"
The second, pickCS checks if (c,s) is available in the cs urn, and removes it if it is:
pickCS :: Int -> Int -> M ()
pickCS c s = do
balls <- gets cs
-- only continue if the required ball is available
guard $ (c,s) `elem` balls
-- remove the ball
modify (\st -> st { cs = delete (c,s) balls })
With an appropriate driver for our monad:
runM :: Int -> M a -> [a]
runM n act = evalStateT act (S n p p)
where p = pairs n
this can generate all 12 Latin square of size 3:
λ> runM 3 latin
[Square 3 [1,2,3,2,3,1,3,1,2],Square 3 [1,2,3,3,1,2,2,3,1],...]
or the 576 Latin squares of size 4:
λ> length $ runM 4 latin
576
Compiled with -O2, it's fast enough to enumerate all 161280 squares of size 5 in a couple seconds:
main :: IO ()
main = print $ length $ runM 5 latin
The list-based urn representation above isn't very efficient. On the other hand, because the lengths of the lists are pretty small, there's not that much to be gained by finding more efficient representations.
Nonetheless, here's complete code that uses efficient Map/Set representations tailored to the way the rs and cs urns are used. Compiled with -O2, it runs in constant space. For n=6, it can process about 100000 Latin squares per second, but that still means it'll need to run for a few hours to enumerate all 800 million of them.
{-# OPTIONS_GHC -Wall #-}
module LatinAll where
import Control.Monad.State
import Data.List
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Map (Map, (!))
import qualified Data.Map as Map
data S = S
{ size :: Int
, rs :: Map Int [Int]
, cs :: Set (Int, Int) }
data Square = Square
Int -- square size
[Int] -- symbols in row-major order
deriving (Show)
type M = StateT S []
-- Get Latin squares
latin :: M Square
latin = do
n <- gets size
cells <- forM (pairs n) (\(r,c) -> getS r c)
return $ Square n cells
-- All locations in row-major order [(1,1),(1,2)..(n,n)]
pairs :: Int -> [(Int,Int)]
pairs n = (,) <$> [1..n] <*> [1..n]
-- Get a valid `s` for position `(r,c)`.
getS :: Int -> Int -> M Int
getS r c = do
s <- pickSFromRow r
pickCS c s
return s
-- Get an available `s` in row `r` from the `rs` urn.
pickSFromRow :: Int -> M Int
pickSFromRow r = do
urn <- gets rs
(s, rest) <- lift $ choices (urn ! r)
modify (\st -> st { rs = Map.insert r rest urn })
return s
-- Remove `(c,s)` from the `cs` urn.
pickCS :: Int -> Int -> M ()
pickCS c s = do
balls <- gets cs
guard $ (c,s) `Set.member` balls
modify (\st -> st { cs = Set.delete (c,s) balls })
-- Return all ways of removing one element from list.
choices :: [a] -> [(a,[a])]
choices = init . (zipWith f <$> inits <*> tails)
where f a (x:b) = (x, a++b)
f _ _ = error "choices: internal error"
-- Run an action in the M monad.
runM :: Int -> M a -> [a]
runM n act = evalStateT act (S n rs0 cs0)
where rs0 = Map.fromAscList $ zip [1..n] (repeat [1..n])
cs0 = Set.fromAscList $ pairs n
main :: IO ()
main = do
print $ runM 3 latin
print $ length (runM 4 latin)
print $ length (runM 5 latin)
Somewhat remarkably, modifying the program to produce only reduced Latin squares (i.e., with symbols [1..n] in order in both the first row and the first column) requires changing only two functions:
-- All locations in row-major order, skipping first row and column
-- i.e., [(2,2),(2,3)..(n,n)]
pairs :: Int -> [(Int,Int)]
pairs n = (,) <$> [2..n] <*> [2..n]
-- Run an action in the M monad.
runM :: Int -> M a -> [a]
runM n act = evalStateT act (S n rs0 cs0)
where -- skip balls [(1,1)..(n,n)] for first row
rs0 = Map.fromAscList $ map (\r -> (r, skip r)) [2..n]
-- skip balls [(1,1)..(n,n)] for first column
cs0 = Set.fromAscList $ [(c,s) | c <- [2..n], s <- skip c]
skip i = [1..(i-1)]++[(i+1)..n]
With these modifications, the resulting Square will include symbols in row-major order but skipping the first row and column. For example:
λ> runM 3 latin
[Square 3 [3,1,1,2]]
means:
1 2 3 fill in question marks 1 2 3
2 ? ? =====================> 2 3 1
3 ? ? in row-major order 3 1 2
This is fast enough to enumerate all 16,942,080 reduced Latin squares of size 7 in a few minutes:
$ stack ghc -- -O2 -main-is LatinReduced LatinReduced.hs && time ./LatinReduced
[1 of 1] Compiling LatinReduced ( LatinReduced.hs, LatinReduced.o )
Linking LatinReduced ...
16942080
real 3m9.342s
user 3m8.494s
sys 0m0.848s
I am writing some code to work with arbitrary radix numbers in haskell. They will be stored as lists of integers representing the digits.
I almost managed to get it working, but I have run into the problem of converting a list of tuples [(a_1,b_1),...,(a_n,b_n)] into a single list which is defined as follows:
for all i, L(a_i) = b_i.
if there is no i such that a_i = k, a(k)=0
In other words, this is a list of (position,value) pairs for values in an array. If a position does not have a corresponding value, it should be set to zero.
I have read this (https://wiki.haskell.org/How_to_work_on_lists) but I don't think any of these methods are suitable for this task.
baseN :: Integer -> Integer -> [Integer]
baseN n b = convert_digits (baseN_digits n b)
chunk :: (Integer, Integer) -> [Integer]
chunk (e,m) = m : (take (fromIntegral e) (repeat 0))
-- This is broken because the exponents don't count for each other's zeroes
convert_digits :: [(Integer,Integer)] -> [Integer]
convert_digits ((e,m):rest) = m : (take (fromIntegral (e)) (repeat 0))
convert_digits [] = []
-- Converts n to base b array form, where a tuple represents (exponent,digit).
-- This works, except it ignores digits which are zero. thus, I converted it to return (exponent, digit) pairs.
baseN_digits :: Integer -> Integer -> [(Integer,Integer)]
baseN_digits n b | n <= 0 = [] -- we're done.
| b <= 0 = [] -- garbage input.
| True = (e,m) : (baseN_digits (n-((b^e)*m)) b)
where e = (greedy n b 0) -- Exponent of highest digit
m = (get_coef n b e 1) -- the highest digit
-- Returns the exponent of the highest digit.
greedy :: Integer -> Integer -> Integer -> Integer
greedy n b e | n-(b^e) < 0 = (e-1) -- We have overshot so decrement.
| n-(b^e) == 0 = e -- We nailed it. No need to decrement.
| n-(b^e) > 0 = (greedy n b (e+1)) -- Not there yet.
-- Finds the multiplicity of the highest digit
get_coef :: Integer -> Integer -> Integer -> Integer -> Integer
get_coef n b e m | n - ((b^e)*m) < 0 = (m-1) -- We overshot so decrement.
| n - ((b^e)*m) == 0 = m -- Nailed it, no need to decrement.
| n - ((b^e)*m) > 0 = get_coef n b e (m+1) -- Not there yet.
You can call "baseN_digits n base" and it will give you the corresponding array of tuples which needs to be converted to the correct output
Here's something I threw together.
f = snd . foldr (\(e,n) (i,l') -> ( e , (n : replicate (e-i-1) 0) ++ l')) (-1,[])
f . map (fromIntegral *** fromIntegral) $ baseN_digits 50301020 10 = [5,0,3,0,1,0,2,0]
I think I understood your requirements (?)
EDIT:
Perhaps more naturally,
f xs = foldr (\(e,n) fl' i -> (replicate (i-e) 0) ++ (n : fl' (e-1))) (\i -> replicate (i+1) 0) xs 0
Often times you want the performance of arrays over linked lists while having not conforming to the requirement of having rectangular arrays.
As an example consider an hexagonal grid, here shown with the 1-distance neighbors of cell (3, 3) in medium gray and the 2-distance neighbors in light gray.
Say we want an array that contains, for each cell, the indices of every 1- and 2-distance neighbor for that cell. One slight issue is that cells have a different amount of X-distance neighbors -- cells on the grid border will have fewer neighbors than cells closer to the grid center.
(We want an array of neighbor indices --- instead of a function from cell coordinates to neighbor indices --- for performance reasons.)
We can work around this problem by keeping track of how many neighbors each cell has. Say you have an array
neighbors2 of size R x C x N x 2, where R is the number of grid rows, C for columns, and N is the maximum number of 2-distance neighbors for any cell in the grid.
Then, by keeping an additional array n_neighbors2 of size R x C, we can keep track of which indices in neighbors2 are populated and which are just zero padding. For example, to retrieve the the 2-distance neighbors of cell (2, 5), we simply index into the array as such:
someNeigh = neighbors2[2, 5, 0..n_neighbors2[2, 5], ..]
someNeigh will be a n_neighbors2[2, 5] x 2 array (or view) of indicies, where someNeigh[0, 0] yields the row of the first neighbor, and someNeigh[0, 1] yields the column of the first neighbor and so forth.
Note that the elements at the positions
neighbors2[2, 5, n_neighbors2[2, 5]+1.., ..]
are irrelevant; this space is just padding to keep the matrix rectangular.
Provided we have a function for finding the d-distance neighbors for any cell:
import Data.Bits (shift)
rows, cols = (7, 7)
type Cell = (Int, Int)
generateNeighs :: Int -> Cell -> [Cell]
generateNeighs d cell1 = [ (row2, col2)
| row2 <- [0..rows-1]
, col2 <- [0..cols-1]
, hexDistance cell1 (row2, col2) == d]
hexDistance :: Cell -> Cell -> Int
hexDistance (r1, c1) (r2, c2) = shift (abs rd + abs (rd + cd) + abs cd) (-1)
where
rd = r1 - r2
cd = c1 - c2
How can we create the aforementioned arrays neighbors2 and n_neighbors2? Assume we know the maximum amount of 2-distance neighbors N beforehand. Then it is possible to modify generateNeighs to always return lists of the same size, as we can fill up remaining entries with (0, 0). That leaves, as I see it, two problems:
We need a function to populate neighbors2 which operates not every individual index but on a slice, in our case it should fill one cell at a time.
n_neighbors2 should be populated simultaneously as neighbors2
A solution is welcome with either repa or accelerate arrays.
Here's you picture skewed 30 degrees to the right:
As you can see your array is actually perfectly rectangular.
The indices of a neighborhood's periphery are easily found as six straight pieces around the chosen center cell, e.g. (imagine n == 2 is the distance of the periphery from the center (i,j) == (3,3) in the picture):
periphery n (i,j) =
-- 2 (3,3)
let
((i1,j1):ps1) = reverse . take (n+1) . iterate (\(i,j)->(i,j+1)) $ (i-n,j)
-- ( 1, 3)
((i2,j2):ps2) = reverse . take (n+1) . iterate (\(i,j)->(i+1,j)) $ (i1,j1)
-- ( 1, 5)
.....
ps6 = ....... $ (i5,j5)
in filter isValid (ps6 ++ ... ++ ps2 ++ ps1)
The whole neighborhood is simply
neighborhood n (i,j) = (i,j) : concat [ periphery k (i,j) | k <- [1..n] ]
For each cell/distance combination, simply generate the neighborhood indices on the fly and access your array in O(1) time for each index pair.
Writing out the answer from #WillNess in full, and incorporating the proposal from #leftroundabout to store indecies in a 1D vector instead, and we get this:
import qualified Data.Array.Accelerate as A
import Data.Array.Accelerate (Acc, Array, DIM1, DIM2, DIM3, Z(..), (:.)(..), (!), fromList, use)
rows = 7
cols = 7
type Cell = (Int, Int)
(neighs, nNeighs) = generateNeighs
-- Return a vector of indices of cells at distance 'd' or less from the given cell
getNeighs :: Int -> Cell -> Acc (Array DIM1 Cell)
getNeighs d (r,c) = A.take n $ A.drop start neighs
where
start = nNeighs ! A.constant (Z :. r :. c :. 0)
n = nNeighs ! A.constant (Z :. r :. c :. d)
generateNeighs :: (Acc (Array DIM1 Cell), Acc (Array DIM3 Int))
generateNeighs = (neighsArr, nNeighsArr)
where
idxs = concat [[(r, c) | c <- [0..cols-1]] | r <- [0..rows-1]]
(neighsLi, nNeighsLi, n) = foldl inner ([], [], 0) idxs
neighsArr = use $ fromList (Z :. n) neighsLi
nNeighsArr = use $ fromList (Z :. rows :. cols :. 5) nNeighsLi
inner (neighs', nNeighs', n') idx = (neighs' ++ cellNeighs, nNeighs'', n'')
where
(cellNeighs, cellNNeighs) = neighborhood idx
n'' = n' + length cellNeighs
nNeighs'' = nNeighs' ++ n' : cellNNeighs
neighborhood :: Cell -> ([Cell], [Int])
neighborhood (r,c) = (neighs, nNeighs)
where
neighsO = [ periphery d (r,c) | d <- [1..4] ]
neighs = (r,c) : concat neighsO
nNeighs = tail $ scanl (+) 1 $ map length neighsO
periphery d (r,c) =
-- The set of d-distance neighbors form a hexagon shape. Traverse each of
-- the sides of this hexagon and gather up the cell indices.
let
ps1 = take d . iterate (\(r,c)->(r,c+1)) $ (r-d,c)
ps2 = take d . iterate (\(r,c)->(r+1,c)) $ (r-d,c+d)
ps3 = take d . iterate (\(r,c)->(r+1,c-1)) $ (r,c+d)
ps4 = take d . iterate (\(r,c)->(r,c-1)) $ (r+d,c)
ps5 = take d . iterate (\(r,c)->(r-1,c)) $ (r+d,c-d)
ps6 = take d . iterate (\(r,c)->(r-1,c+1)) $ (r,c-d)
in filter isValid (ps6 ++ ps5 ++ ps4 ++ ps3 ++ ps2 ++ ps1)
isValid :: Cell -> Bool
isValid (r, c)
| r < 0 || r >= rows = False
| c < 0 || c >= cols = False
| otherwise = True
This can be by using the permute function to fill the neighbors for 1 cell at a time.
import Data.Bits (shift)
import Data.Array.Accelerate as A
import qualified Prelude as P
import Prelude hiding ((++), (==))
rows = 7
cols = 7
channels = 70
type Cell = (Int, Int)
(neighs, nNeighs) = fillNeighs
getNeighs :: Cell -> Acc (Array DIM1 Cell)
getNeighs (r, c) = A.take (nNeighs ! sh1) $ slice neighs sh2
where
sh1 = constant (Z :. r :. c)
sh2 = constant (Z :. r :. c :. All)
fillNeighs :: (Acc (Array DIM3 Cell), Acc (Array DIM2 Int))
fillNeighs = (neighs2, nNeighs2)
where
sh = constant (Z :. rows :. cols :. 18) :: Exp DIM3
neighZeros = fill sh (lift (0 :: Int, 0 :: Int)) :: Acc (Array DIM3 Cell)
-- nNeighZeros = fill (constant (Z :. rows :. cols)) 0 :: Acc (Array DIM2 Int)
(neighs2, nNeighs2li) = foldr inner (neighZeros, []) indices
nNeighs2 = use $ fromList (Z :. rows :. cols) nNeighs2li
-- Generate indices by varying column fastest. This assures that fromList, which fills
-- the array in row-major order, gets nNeighs in the correct order.
indices = foldr (\r acc -> foldr (\c acc2 -> (r, c):acc2 ) acc [0..cols-1]) [] [0..rows-1]
inner :: Cell
-> (Acc (Array DIM3 Cell), [Int])
-> (Acc (Array DIM3 Cell), [Int])
inner cell (neighs, nNeighs) = (newNeighs, n : nNeighs)
where
(newNeighs, n) = fillCell cell neighs
-- Given an cell and a 3D array to contain cell neighbors,
-- fill in the neighbors for the given cell
-- and return the number of neighbors filled in
fillCell :: Cell -> Acc (Array DIM3 Cell) -> (Acc (Array DIM3 Cell), Int)
fillCell (r, c) arr = (permute const arr indcomb neighs2arr, nNeighs)
where
(ra, ca) = (lift r, lift c) :: (Exp Int, Exp Int)
neighs2li = generateNeighs 2 (r, c)
nNeighs = P.length neighs2li
neighs2arr = use $ fromList (Z :. nNeighs) neighs2li
-- Traverse the 3rd dimension of the given cell
indcomb :: Exp DIM1 -> Exp DIM3
indcomb nsh = index3 ra ca (unindex1 nsh)
generateNeighs :: Int -> Cell -> [Cell]
generateNeighs d cell1 = [ (row2, col2)
| row2 <- [0..rows]
, col2 <- [0..cols]
, hexDistance cell1 (row2, col2) P.== d]
-- Manhattan distance between two cells in an hexagonal grid with an axial coordinate system
hexDistance :: Cell -> Cell -> Int
hexDistance (r1, c1) (r2, c2) = shift (abs rd + abs (rd + cd) + abs cd) (-1)
where
rd = r1 - r2
cd = c1 - c2
I have a Data.Map (Int, Int) [String] representing the board of a game (I assume that at a position on the map there can be more than one piece). Let's say that i have the following Map:
fromList [ ( (0,1) , ["piece1", "piece2"] )
, ( (2,2) , ["piece3", "piece4"] ) ]
What I am trying to do is printing the table, in this case a 3 X 3 table, with the elements of the map at the position specified while the rest of the spaces are empty or have an 'x'. I have tried to use foldl and map and combinations of the 2 but I just don't get it how i should do it. I have to mention that i am very new to Haskell. Any help would be great!
Output should be:
x | piece1piece2 | x
x | x | x
x | x | piece3piece4
Here's some code that will get you started. It works by iterating over the (row,column) coords of the board. In the iteration it looks up the string to print for that location, defaulting to "x" on failure. Finally the board is printed one row at a time.
The final format is not exactly what you had in mind but it should get you most of the way there.
import Data.Map as DM
import Data.Maybe
import Data.List.Split
main = do
let pieces = fromList [ ( (0,1) , ["piece1", "piece2"] )
, ( (2,2) , ["piece3", "piece4"] ) ]
-- prepare piece name lists for printing
p2 = fmap concat pieces
height = 3
width = 3
-- iterate over board in row/column order
-- lookup name - use "x" if not found
namesInOrder = [fromMaybe "x" $ DM.lookup (row,col) p2
| row <- [0..height-1]
, col <- [0..width-1]
]
-- split into chunks of one row each
rows = chunksOf width namesInOrder
-- print each row on its own line
mapM print rows
I'm going to start off with the import of Data.Map.Strict. Generally the way to do it is
import qualified Data.Map.Strict as M
import Data.Map.Strict (Map)
You have a Map (Int, Int) String, and you need to print out a square array of strings. It seems that the first thing you need to do is calculate the dimensions of the array. We can do that with an indexed fold. It looks like a good one for the job is
foldlWithKey' :: (a -> k -> b -> a) -> a -> Map k b -> a
Hrmm... Those type variables aren't very informative. Let me relabel them:
foldlWithKey'
:: (acc -> key -> elem -> acc)
-> acc
-> Map key elem
-> acc
This function takes an initial value of an accumulator, and a function indicating how to modify that accumulator for each key and element in the map. Let's make a type representing the dimensions of the board:
data Dim = Dim { rows :: !Int, cols :: !Int }
Now we can write
getDim :: Map (Int, Int) a -> Dim
getDim = M.foldlWithKey' update (Dim 0 0)
where
update (Dim rs cs) (r, c) _
= Dim (max rs (r + 1)) (max cs (c + 1))
For each entry in the Map, we adjust the row and column counts as necessary.
Now that we know the dimensions of the board, let's build a representation of it that will be more suitable for printing. The simplest way to do this is probably to iterate over the row and column numbers, looking up the pairs in the map. Let's start by writing a function to get a single row:
getRow :: Int -> Dim -> Map (Int, Int) a -> [Maybe a]
getRow r (Dim {cols = cs}) m =
[ M.lookup (r, c) | c <- [0 .. cs - 1] ]
Here Nothing means that the key was not in the map, and Just whatever means it was.
Now we can use that to get all the rows:
getRows :: Dim -> Map (Int, Int) a -> [[Maybe a]]
getRows dim#(Dim {rows = rs}) m =
[ getRow r dim m | r <- [0 .. rs - 1] ]
Now we can think about displaying! I'm going to leave this to you, but I suggest you consider using Data.List.intercalate and map to turn each row into a string.
Again I'm requesting comments about how a given design should be implemented in Haskell.
Thanks in advance to everyone providing helpful comments. Also I hope this could be an aid to other Haskell novices like me, having a practical sample code.
This time, we have a polymorphic function doSampling (in module Samples) that takes a generic function f and
a list of reals (indexes) and returns a Samples (indexes, values=f(indexes)). We want implement doSampling only once, as it doesn't matter if is f is a Polynomial or a Sinus. For that,
we have introduced an interface Function, and have Polynomial and Sinus types implement it.
The following is the design being implemented:
Edit 1:
There is a debate on the Function interface (class in Haskell). It has been suggested it is not actually necessary, as doSampling may take a "nude" function (Double -> Double) instead.
But, how to do it, if you need some extra state within the nude function (coeffs for a polynomial, amp+freq+phase for a sinus?
Edit 2:
Very good answers by kosmikus and by Chris Taylor. Thanks.
A key idea in both: have
doSampling :: (Double -> Double) -> [Double] -> Samples
This is: it takes a function (Double -> Double) (instead of Function) and list and returns samples.
My intention was to keep the state of Polynomials and Sinuses. That is not regarded in Chris answer, but it is in kosmikus'. On the other hand, the weak point in kosmikus version could be how to extend its Function definition if you don't have access to the source code.
I would also point out:
Chris' idea of encapsulating a polynomial or a sinus into a function (Double -> Double) by means of a factory function mkPolynomial or mkSinus that generates (using currying?) the desired function taking the apropriate parameters. (Although you can't consult the parameters later).
kosmikous' idea of using value to transform (also using currying?) a Function into a (Double -> Double)
Both answers are worth reading as they have other little Haskell tricks to reduce and simplify code.
In sum
Chris answers does not support keeping the state of a Polynomial or of a Sinus
kosmikus answers is not extensible: adding new type of functions (Cosinus ...)
my answer (being verbose) does overcome the previous downsides, and it would allow (this not necessary for the problem) impose Function types to have more associated-functions apart of value (in the sense of how an java-interfaces work).
My own approach
main (usage)
import Polynomial
import Sinus
import Function
import Samples
-- ...............................................................
p1 = Polynomial [1, 0, 0.5] -- p(x) = 1 + 0.5x^2
s1 = Sinus 2 0.5 3 -- f(x) = 2 sin(0.5x + 3)
-- ...............................................................
-- sample p1 from 0 to 5
m1 = doSampling p1 [0, 0.5 .. 5]
m2 = doSampling s1 [0, 0.5 .. 5]
-- ...............................................................
-- main
-- ...............................................................
main = do
putStrLn "Hello"
print $ value p1 2
print $ value s1 (pi/2)
print $ pairs m1
print $ pairs m2
Function
module Function where
-- ...............................................................
-- "class type" : the types belonging to this family of types
-- must implement the following functions:
-- + value : takes a function and a real and returns a real
-- ...............................................................
class Function f where
value :: f -> Double -> Double
-- f is a type variable, this is:
-- f is a type of the Function "family" not an actual function
Samples
module Samples where
import Function
-- ...............................................................
-- Samples: new data type
-- This is the constructor and says it requieres
-- two list, one for the indexes (xs values) and another
-- for the values ( ys = f (xs) )
-- this constructor should not be used, instead use
-- the "factory" function: new_Samples that performs some checks
-- ...............................................................
data Samples = Samples { indexes :: [Double] , values :: [Double] }
deriving (Show)
-- ...............................................................
-- constructor: it checks lists are equal size, and indexes are sorted
new_Samples :: [Double] -> [Double] -> Samples
new_Samples ind val
| (length ind) /= (length val) = samplesVoid
| not $ isSorted ind = samplesVoid
| otherwise = Samples ind val
-- ...............................................................
-- sample a funcion
-- it takes a funcion f and a list of indexes and returns
-- a Samples calculating the values array as f(indexes)
doSampling :: (Function f) => f -> [Double] -> Samples
doSampling f ind = new_Samples ind vals
where
vals = [ value f x | x <- ind ]
-- ...............................................................
-- used as "error" in the construction
samplesVoid = Samples [] []
-- ...............................................................
size :: Samples -> Int
size samples = length (indexes samples)
-- ...............................................................
-- utility function to get a pair (index,value) out of a Samples
pairs :: Samples -> [(Double, Double)]
pairs samples = pairs' (indexes samples) (values samples)
pairs' :: [Double] -> [Double] -> [(Double, Double)]
pairs' [] [] = []
pairs' [i] [v] = [(i,v)]
pairs' (i:is) (v:vs) = (i,v) : pairs' is vs
-- ...............................................................
-- to check whether a list is sorted (<)
isSorted :: (Ord t) => [t] -> Bool
isSorted [] = True
isSorted [e] = True
isSorted (e1:(e2:tail))
| e1 < e2 = isSorted (e2:tail)
| otherwise = False
Sinus
module Sinus where
-- ...............................................................
import Function
-- ...............................................................
-- Sinus: new data type
-- This is the constructor and says it requieres
-- a three reals
-- ...............................................................
data Sinus = Sinus { amplitude :: Double, frequency :: Double, phase :: Double }
deriving (Show)
-- ...............................................................
-- we say that a Sinus is a Function (member of the class Function)
-- and then, how value is implemented
instance Function Sinus where
value s x = (amplitude s) * sin ( (frequency s)*x + (phase s))
Polynomial
module Polynomial where
-- ...............................................................
import Function
-- ...............................................................
-- Polynomial: new data type
-- This is the constructor and says it requieres
-- a list of coefficients
-- ...............................................................
data Polynomial = Polynomial { coeffs :: [Double] }
deriving (Show)
-- ...............................................................
degree :: Polynomial -> Int
degree p = length (coeffs p) - 1
-- ...............................................................
-- we say that a Polynomial is a Function (member of the class Function)
-- and then, how value is implemented
instance Function Polynomial where
value p x = value' (coeffs p) x 1
-- list of coeffs -> x -> pw (power of x) -> Double
value' :: [Double] -> Double -> Double -> Double
value' (c:[]) _ pw = c * pw
value' (c:cs) x pw = (c * pw) + (value' cs x x*pw)
You certainly don't need the Function class. All this heavyweight class, instance, member variable fluff is one of the things that Haskell is designed to avoid. Pure functions can be much more flexible.
Here's a simple way of doing what you want.
type Sample = ([Double], [Double])
newSample xs vs
| isSorted xs && length xs == length vs = (indices, values)
| otherwise = ([], [])
pairs = uncurry zip
doSampling :: (Double -> Double) -> [Double] -> Sample
doSampling f xs = newSample xs (map f xs)
mkPolynomial :: [Double] -> (Double -> Double)
mkPolynomial coefs x = go coefs
where
go [] = 0
go (c:cs) = c + x * go cs
mkSinus :: Double -> Double -> Double -> (Double -> Double)
mkSinus amp freq phase x = amp * sin (freq * x + phase)
p1 = mkPolynomial [1, 0, 0.5] -- 1 + 0.5x^2
s1 = mkSinus 2 0.5 3 -- 2 sin(0.5x + 3)
m1 = doSampling p1 [0, 0.5 .. 5]
m2 = doSampling s1 [0, 0.5 .. 5]
main :: IO ()
main = do
print $ p1 2
print $ s1 (pi/2)
print $ pairs m1
print $ pairs m2
[Expanded my comment on request.]
I'd probably do this roughly as follows:
import Data.Functor
-- Use a datatype rather than a class. Yes, this makes it harder to
-- add new types of functions later, and in turn easier to define new
-- operations. ("expression problem")
data Function =
Sinus { amplitude :: Double, frequency :: Double, phase :: Double }
| Polynomial { coeffs :: [Double] }
deriving (Show)
-- Interpreting a Function as an actual function.
value :: Function -> (Double -> Double)
value (Sinus amp freq ph) x = amp * sin (freq * x + ph)
value (Polynomial cs) x = value' cs x
-- Rewrite value' to not require non-empty lists. This can also be
-- nicely written as a fold.
value' :: [Double] -> Double -> Double
value' [] _ = 0
value' (c:cs) x = c + x * value' cs x
data Samples = Samples { indexes :: [Double] , values :: [Double] }
deriving (Show)
-- Use Maybe to detect error conditions, instead of strange values
-- such as voidSamples.
newSamples :: [Double] -> [Double] -> Maybe Samples
newSamples ind val
| length ind /= length val = Nothing
| not $ isSorted ind = Nothing
| otherwise = Just (Samples ind val)
doSampling :: (Double -> Double) -> [Double] -> Maybe Samples
doSampling f ind = newSamples ind (map f ind)
isSorted :: (Ord t) => [t] -> Bool
isSorted [] = True
isSorted [e] = True
isSorted (e1:e2:es)
| e1 < e2 = isSorted (e2:es)
| otherwise = False
-- This is just zip.
pairs :: Samples -> [(Double, Double)]
pairs (Samples idxs vals) = zip idxs vals
p1 = Polynomial [1, 0, 0.5] -- p(x) = 1 + 0.5x^2
s1 = Sinus 2 0.5 3 -- f(x) = 2 sin(0.5x + 3)
m1 = doSampling (value p1) [0, 0.5 .. 5]
m2 = doSampling (value s1) [0, 0.5 .. 5]
-- The <$> maps over a Maybe.
main = do
putStrLn "Hello"
print $ value p1 2
print $ value s1 (pi/2)
print $ pairs <$> m1
print $ pairs <$> m2