How can I optimize this haskell function - haskell

I need to find the closest color in a palette ps to a given color p. How do I make the function nearestColor as fast as possible, without changing the type of
Pixel8 or PixelRGB8. So far I have tried inlining.
import qualified Data.Vector as V
type Pixel8 = Word8
data PixelRGB8 = PixelRGB8 {-# UNPACK #-} !Pixel8 -- Red
{-# UNPACK #-} !Pixel8 -- Green
{-# UNPACK #-} !Pixel8 -- Blue
deriving (Eq, Ord, Show)
nearestColor :: PixelRGB8 -> Vector PixelRGB8 -> PixelRGB8
nearestColor p ps = snd $ V.minimumBy comp ds
where
ds = V.map (\px -> (dist2Px px p, px)) ps
comp a b = fst a `compare` fst b
dist2Px :: PixelRGB8 -> PixelRGB8 -> Int
dist2Px (PixelRGB8 r1 g1 b1) (PixelRGB8 r2 g2 b2) = dr*dr + dg*dg + db*db
where
(dr, dg, db) =
( fromIntegral r1 - fromIntegral r2
, fromIntegral g1 - fromIntegral g2
, fromIntegral b1 - fromIntegral b2 )

If you want to use a single palette and request different colours, I'd first flip your signature:
type Palette = V.Vector PixelRGB8
nearestColor :: Palette -> PixelRGB8 -> PixelRGB8
That facilitates partial application, and allows the palette configuration to be memoised.
Next, you want to do that: re-store the palette in a data structure suitable for fast lookup. Since you're basically interested in Euclidean distance in ℝ3 (BTW not really ideal for colour comparison), this is a very common problem. A classic structure is the k-d tree, which has long been used for such a nearest-neighbour search. There's sure enough a Haskell library available, which quite a convenient interface for you:
import qualified Data.Trees.KdTree a s KD
instance KD.Point PixelRGB where
dimension _ = 3
coord 0 (PixelRGB r _ _) = fromIntegral r
coord 1 (PixelRGB _ g _) = fromIntegral g
coord 2 (PixelRGB _ _ b) = fromIntegral b
dist2 = fromIntegral . dist2Px
Then we can transform a palette into such a tree:
type FastPalette = KD.KdTree PixelRGB8
accelPalette :: Palette -> FastPalette
accelPalette = KD.fromList . V.toList
And finally just use the library-provided next neighbour search:
nearestColor palette = fromJust . KD.nearestNeighbor fpal
where fpal = accelPalette palette

Related

Generate a random list of custom data type, where values provided to data constructor are somehow bounded within a range

I have defined a Point data type, with a single value constructor like so:
data Point = Point {
x :: Int,
y :: Int,
color :: Color
} deriving (Show, Eq)
data Color = None
| Black
| Red
| Green
| Blue
deriving (Show, Eq, Enum, Bounded)
I have found an example of making a Bounded Enum an instance of the Random class and have made Color an instance of it like so:
instance Random Color where
random g = case randomR (1, 4) g of
(r, g') -> (toEnum r, g')
randomR (a, b) g = case randomR (fromEnum a, fromEnum b) g of
(r, g') -> (toEnum r, g')
I was then able to find out how to make Point an instance of the Random class also:
instance Random Point where
randomR (Point xl yl cl, Point xr yr cr) g =
let (x, g1) = randomR (xl, xr) g
(y, g2) = randomR (yl, yr) g1
(c, g3) = randomR (cl, cr) g2
in (Point x y c, g3)
random g =
let (x, g1) = random g
(y, g2) = random g1
(c, g3) = random g2
in (Point x y c, g3)
So, this let's me make random point values. But, what I'd like to do is be able to create a list of random Point values, where the x and the y properties are bounded within some range whilst leaving the color property to be an unbounded random value. Is this possible with the way I am currently modelling the code, or do I need to rethink how I construct Point values? For instance, instead of making Point an instance of the Random class, should I just create a random list of Int in the IO monad and then have a pure function that creates n Points, using values from the random list to construct each Point value?
Edit, I think I have found out how to do it:
Without changing the above code, in the IO monad I can do the following:
solved :: IO ()
solved = do
randGen <- getStdGen
let x = 2
let randomPoints = take x $ randomRs (Point 0 0 None, Point 200 200 Blue) randGen
putStrLn $ "Random points: " ++ show randomPoints
This seems to work, randomRs appears to let me specify a range...
Presumably because my Point data type derives Eq?
Or
Is it because my x and y properties are Int (guessing here, but may be "bounded" by default) and I have Color derive bounded?
It works because of the properties of the Int and Color types, not because of the properties of Point. If one suppresses the Eq clause of Point, it still works.
Your code is overall quite good, however I would mention a few minor caveats.
In the Random instance for Point, you are chaining the generator states manually; this is a bit error prone, and monadic do notation is supposed to make it unnecessary. The Color instance could be simplified.
You are using IO where it is not really required. IO is just one instance of the MonadRandom class. If g is an instance of RandomGen, any Rand g is an instance of MonadRandom.
The random values you're getting are not reproducible from a program execution to the next one; this is because getStdGen implicitly uses the launch time as a random number generation seed. It may do that because it is IO-hosted. In many situations, this is a problem, as one might want to vary the choice of random sequence and the system parameters independently of each other.
Using monadic style, the basics of your code could be rewritten for example like this:
import System.Random
import System.Random.TF -- Threefish random number generator
import Control.Monad.Random
data Point = Point {
x :: Int,
y :: Int,
color :: Color
} deriving (Show, Eq)
data Color = None
| Black
| Red
| Green
| Blue
deriving (Show, Eq, Enum, Bounded)
instance Random Color where
randomR (a, b) g = let (r,g') = randomR (fromEnum a, fromEnum b) g
in (toEnum r, g')
random g = randomR (minBound::Color, maxBound::Color) g
singleRandomPoint :: -- monadic action for just one random point
MonadRandom mr => Int -> Int -> Color -> Int -> Int -> Color -> mr Point
singleRandomPoint xmin ymin cmin xmax ymax cmax =
do
-- avoid manual chaining of generator states:
x <- getRandomR (xmin, xmax)
y <- getRandomR (ymin, ymax)
c <- getRandomR (cmin, cmax)
return (Point x y c)
And then we can derive an expression returning an unlimited list of random points:
-- monadic action for an unlimited list of random points:
seqRandomPoints :: MonadRandom mr =>
Int -> Int -> Color -> Int -> Int -> Color -> mr [Point]
seqRandomPoints xmin ymin cmin xmax ymax cmax =
sequence (repeat (singleRandomPoint xmin ymin cmin xmax ymax cmax))
-- returns an unlimited list of random points:
randomPoints :: Int -> Int -> Int -> Color -> Int -> Int -> Color -> [Point]
randomPoints seed xmin ymin cmin xmax ymax cmax =
let
-- get random number generator:
-- using Threefish algorithm (TF) for better statistical properties
randGen = mkTFGen seed
action = seqRandomPoints xmin ymin cmin xmax ymax cmax
in
evalRand action randGen
Finally we can print the first few random points on stdout:
-- Small printing utility:
printListAsLines :: Show t => [t] -> IO()
printListAsLines xs = mapM_ (putStrLn . show) xs
solved01 :: IO ()
solved01 = do
let
seed = 42 -- for random number generator setup
-- unlimited list of random points:
allRandomPoints = randomPoints seed 0 0 None 200 200 Blue
count = 5
someRandomPoints = take count allRandomPoints
-- IO not used at all so far
putStrLn $ "Random points: "
printListAsLines someRandomPoints
main = solved01
Program execution (reproducible with constant seed):
$ randomPoints
Random points:
Point {x = 187, y = 56, color = Green}
Point {x = 131, y = 28, color = Black}
Point {x = 89, y = 135, color = Blue}
Point {x = 183, y = 190, color = Red}
Point {x = 27, y = 161, color = Green}
$
Should you prefer to just get a finite number of points and also get back the updated state of your random number generator, you would have to use replicate n instead of repeat, and runRand instead of evalRand.
Bit more details about the monadic approach here.

How to memoize the repeated subtrees of a game tree (a potentially infinite rose tree)?

I am attempting to implement the Negamax algorithm in Haskell.
For this, I am representing the future possibilities a game might take in a rose tree (Data.Tree.Forest (depth, move, position)). However, often there are positions that can be reached with two different sequences of moves. It is a waste (and quickly becomes very slow) to re-evaluate (the subtrees of) repeated positions.
Here is what I tried so far:
Implement a variant of Tying the Knot to share common sub-results. However, I have only been able to find explanations of tying the knot for (potentially infinite) lists, and nothing about re-using subtrees.
Another approach I have considered was to build a tree inside the State monad, where the state to keep would be a Map (depth, position) (Forest (depth, move, position)) to perform explicit memoization but I have so far not been able to set this up properly either.
I think that both approaches might have the problem that a game tree can only be built in a corecursive way: We do not build the tree up to the root from the leaves, but build a (potentially infinite) tree lazily from the root down.
EDIT: To give you an example of the code I am currently using (that is too slow):
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleContexts #-}
module ZeroSumGame where
import qualified Control.Arrow
import Data.Tree
import Numeric.Natural (Natural)
(|>) :: a -> (a -> b) -> b
x |> f = f x
infixl 0 |>
{-# INLINE (|>) #-}
class Ord s => Game s where
data Move s
initial :: s -- | Beginning of the game
applyMove :: Natural -> s -> Move s -> s -- | Moving from one game state to the next
possibleMoves :: Natural -> s -> [Move s] -- | Lists moves the current player is able to do.
isGameOver :: s -> Bool -- | True if the game has ended. TODO: Maybe write default implementation using `possibleMoves state == []`?
scorePosition :: Natural -> Move s -> s -> Int -- | Turns a position in an integer, for the Negamax algorithm to decide which position is the best.
type Trimove state = (Natural, Move state, state) -- | Depth since start of game, move to next position, new position
gameforest :: Game s => Natural -> s -> Forest (Trimove s)
gameforest start_depth start_state = unfoldForest buildNode (nextpositions start_depth start_state)
where
buildNode (depth, move, current_state) =
if
isGameOver current_state
then
((depth, move, current_state), [])
else
((depth, move, current_state), nextpositions depth current_state)
nextpositions depth current_state =
current_state
|> possibleMoves depth
|> fmap (\move -> (succ depth, move, applyMove depth current_state move))
scoreTree :: Game s => Ord (Move s) => Natural -> Tree (Trimove s) -> (Move s, Int)
scoreTree depth node =
case (depth, subForest node) of
(0, _) ->
node |> rootLabel |> uncurry3dropFirst scorePosition
(_, []) ->
node |> rootLabel |> uncurry3dropFirst scorePosition
(_, children) ->
children
|> scoreForest (pred depth)
|> map (Control.Arrow.second negate)
|> maximum
uncurry3dropFirst :: (a -> b -> c -> d) -> (a, b, c) -> (b, d)
uncurry3dropFirst fun (a, b, c) = (b, fun a b c)
scoreForest :: Game s => Ord (Move s) => Natural -> Forest (Trimove s) -> [(Move s, Int)]
scoreForest depth forest =
forest
|> fmap (scoreTree depth)
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleContexts #-}
module TicTacToe where
import qualified Control.Monad.State
import Control.Monad.State (State)
import qualified Data.Map
import Data.Map (Map)
import qualified Control.Arrow
import Data.Tree
import Data.Array (Array)
import qualified Data.Array
import qualified Data.Maybe
import qualified Data.Foldable
import Numeric.Natural (Natural)
import ZeroSumGame
data CurrentPlayer = First | Second
deriving (Eq, Ord, Show)
instance Enum CurrentPlayer where
fromEnum First = 1
fromEnum Second = -1
toEnum 1 = First
toEnum (-1) = Second
toEnum _ = error "Improper player"
newtype TicTacToe = TicTacToe (Array (Int, Int) (Maybe CurrentPlayer))
deriving (Eq, Ord)
instance Game TicTacToe where
data Move TicTacToe = TicTacToeMove (Int, Int)
deriving (Eq, Ord, Show, Bounded)
initial = TicTacToe initialTicTacToeBoard
possibleMoves _depth = possibleTicTacToeMoves
applyMove depth (TicTacToe board) (TicTacToeMove (x, y)) =
TicTacToe newboard
where
newboard = board Data.Array.// [((x, y), Just player)]
player = case depth `mod` 2 of
0 -> First
_ -> Second
isGameOver state = Data.Maybe.isJust (findFilledLines state)
scorePosition _ _ state =
state
|> findFilledLines
|> fmap fromEnum
|> Data.Maybe.fromMaybe 0
|> (* (-10000))
findFilledLines :: TicTacToe -> Maybe CurrentPlayer
findFilledLines (TicTacToe board) =
(rows ++ columns ++ diagonals)
|> map winner
|> Data.Foldable.asum
where
rows = vals rows_indexes
columns = vals columns_indexes
diagonals = vals diagonals_indexes
rows_indexes = [[(i, j) | i <- [0..2]]| j <- [0..2]]
columns_indexes = [[(i, j) | j <- [0..2]]| i <- [0..2]]
diagonals_indexes = [[(i, i) ]| i <- [0..2]] ++ [[(i, 2 - i) ]| i <- [0..2]]
vals = map (map (\index -> board Data.Array.! index))
winner :: Eq a => [Maybe a] -> Maybe a
winner [x,y,z] =
if x == y && x == z then x else Nothing
winner _ = Nothing
initialTicTacToeBoard :: (Array (Int, Int) (Maybe CurrentPlayer))
initialTicTacToeBoard =
Data.Array.array ((0, 0), (2, 2)) [((i, j), Nothing) | i <- [0..2], j <- [0..2]]
possibleTicTacToeMoves :: TicTacToe -> [Move TicTacToe]
possibleTicTacToeMoves (TicTacToe board) = foldr checkSquareForMove [] (Data.Array.assocs board)
where
checkSquareForMove (index, val) acc = case val of
Nothing -> TicTacToeMove index : acc
Just _ -> acc
printBoard :: TicTacToe -> String
printBoard (TicTacToe board) =
unlines [unwords [showTile (board Data.Array.! (y, x)) | x <- [0..2]] | y <- [0..2]]
where
showTile loc =
case loc of
Nothing -> " "
Just Second -> "X"
Just First -> "O"
(TypeFamilies is used to allow each Game implementation to have their own notion of a Move, and FlexibleContexts is then required to enforce Move s to implement Ord.
Problem reformulation
If I understand the question correctly, you have a function that returns the possible next moves in a game, and one to take that move:
start :: Position
moves :: Position -> [Move]
act :: Position -> Move -> Position
and how you want to build the infinite tree of states (please allow me to ignore the Depth field, for simplicity. If you consider the depth counter as part of the Position type, you see that no generality is lost here):
states :: Forest (Position, Move)
states = forest start
forest :: Position -> Forest (Position, Move)
forest p = [ Node (m, p') (states p') | m <- moves p, let p' = act p m ]
but you want to achieve that in a way that identical subtrees of forest are shared.
Towards Memoization
The general technique is here is that we want to memoize forest: This way, for identical Positions, we get shared subtrees. So the recipe is:
forest :: Position -> Forest (Position, Move)
forest = memo forest'
forest' :: Position -> Forest (Position, Move)
forest' p = [ Node (m, p') (states p') | m <- moves p, let p' = act p m ]
And we need a suitable memo-function:
memo :: (Position -> a) -> (Position -> a)
At this point, we need to know more about Position in order to know how to implement that using an equivalent of the “lazy list” trick… But you see that you do not need to memoize functions that involve Rose trees.
I would try to do this by normalizing board positions based on some "canonical" sequence of moves to reach that position. Then each child is assigned the value of traversing its individual normalized sequence through the tree. (no code because I'm on my phone and this is a big task.)
How well this works depends on the ease of calculating normalized move sequences in the game you're playing. But it's a way to introduce sharing by tying the knot, making use of a shared reference to the root of the game tree. Maybe it will serve as inspiration for other ideas that fit your specific case.

How to "extend" a (partial) record selector?

NB: The type I define below is just a convenient example for the purposes of this question; I'm sure there's no any need for me to roll my own definition of complex numbers in Haskell.
I don't know if I'm using the right terminology here, but the selector r below is ane example of what I mean by a "partial" record selector:
data Complex = Polar { r :: Float, y :: Float }
| Rectangular { x :: Float, y :: Float }
deriving Show
r is "partial" because it cannot be applied to all Complex values; e.g.
r $ Polar 3 0
-- 3.0
...but
r $ Rectangular 3 0
-- *** Exception: No match in record selector r
In this case, however, there's a sensible definition for r $ Rectangular x y, namely:
-- assuming {-# LANGUAGE RecordWildCards #-}
r :: Complex -> Float
r Rectangular { .. } = sqrt $ (x * x) + (y * y)
GHCi rejects this definition of r, with a multiple declarations of ‘r’ error.
Is there a way to extend r so that it can be applied to any Complex value?
Of course, I realize that I can define something like
-- assuming {-# LANGUAGE RecordWildCards #-}
modulus :: Complex -> Float
modulus Polar { .. } = r
modulus Rectangular { .. } = sqrt $ (x * x) + (y * y)
...but I want to know if it is possible to extend the already existing selector r.
No, and IMO such record selectors should never be introduced in the first place. I'd write this as
type ℝ = Float -- Note that Double is usually more sensible
newtype S¹ = S¹ {ϑ :: ℝ} -- in [-π, π[
newtype ℝPlus = ℝPlus {posℝ :: ℝ} -- in [0, ∞[
data Complex = Polar ℝPlus S¹
| Rectangular ℝ ℝ
deriving Show
This way, there is no error potential in form of partial record selectors, and also no confusion what to unpack etc.. Even for such a “non-record type”, you can write your own accessors, preferrably in lens form:
import Control.Lens
r :: Lens' Complex ℝPlus
r = lens get set
where get (Polar r _) = r
get (Rectangular x y) = ℝPlus . sqrt $ x^2 + y^2
set (Polar _ θ) r = Polar r θ
set (Rectangular x y) (ℝPlus r) = Rectangular (x * η) (y * η)
where η = r / sqrt (x^2 + y^2)

Why does my Haskell program ends with out of memory error?

I'm trying to write a Haskell program to parse huge text file (about 14Gb), but i can't understand how to make it free unused data from memory or not to make stack overflow during foldr. Here is the program source:
import qualified Data.ByteString.Lazy.Char8 as LBS
import qualified Data.ByteString.Lex.Lazy.Double as BD
import System.Environment
data Vertex =
Vertex{
vertexX :: Double,
vertexY :: Double,
vertexZ :: Double}
deriving (Eq, Show, Read)
data Extent =
Extent{
extentMax :: Vertex,
extentMin :: Vertex}
deriving (Eq, Show, Read)
addToExtent :: Extent -> Vertex -> Extent
addToExtent ext vert = Extent vertMax vertMin where
(vertMin, vertMax) = (makeCmpVert max (extentMax ext) vert, makeCmpVert min (extentMin ext) vert) where
makeCmpVert f v1 v2 = Vertex(f (vertexX v1) (vertexX v2))
(f (vertexY v1) (vertexY v2))
(f (vertexZ v1) (vertexZ v2))
readCoord :: LBS.ByteString -> Double
readCoord l = case BD.readDouble l of
Nothing -> 0
Just (value, _) -> value
readCoords :: LBS.ByteString -> [Double]
readCoords l | LBS.length l == 0 = []
| otherwise = let coordWords = LBS.split ' ' l
in map readCoord coordWords
parseLine :: LBS.ByteString -> Vertex
parseLine line = Vertex (head coords) (coords!!1) (coords!!2) where
coords = readCoords line
processLines :: [LBS.ByteString] -> Extent -> Extent
processLines strs ext = foldr (\x y -> addToExtent y (parseLine x)) ext strs
processFile :: String -> IO()
processFile name = do
putStrLn name
content <- LBS.readFile name
let (countLine:recordsLines) = LBS.lines content
case LBS.readInt countLine of
Nothing -> putStrLn "Can't read records count"
Just (recordsCount, _) -> do
print recordsCount
let vert = parseLine (head recordsLines)
let ext = Extent vert vert
print $ processLines recordsLines ext
main :: IO()
main = do
args <- getArgs
case args of
[] -> do
putStrLn "Missing file path"
xs -> do
processFile (head xs)
return()
Text file contains lines with three floating point numbers delimited with space character. This program always tries to occupy all free memory on a computer and crashes with out of memory error.
You are being too lazy. Vertex and Extent have non-strict fields, and all your functions returning a Vertex return
Vertex thunk1 thunk2
without forcing the components to be evaluated. Also addToExtent directly returns an
Extent thunk1 thunk2
without evaluating the components.
Thus none of the ByteStrings actually is released early to be garbage-collected, since the Doubles are not parsed from them yet.
When that is fixed by making the fields of Vertex and Extent strict - or the functions returning a Vertex resp. Extent forcing all parts of their input, you have the problem that
processLines strs ext = foldr (\x y -> addToExtent y (parseLine x)) ext strs
can't start assembling the result before the end of the list of lines is reached because then
(\x y -> addToExtent y (parseLine x))
is strict in its second argument.
However, barring NaNs and undefined values, if I didn't miss something, the result would be the same if you use a (strict!) left fold, so
processLines strs ext = foldl' (\x y -> addToExtent x (parseLine y)) ext strs
should produce the desired result without holding on to the data if Vertex and Extent get strict fields.
Ah, I did miss something:
addToExtent ext vert = Extent vertMax vertMin
where
(vertMin, vertMax) = (makeCmpVert max (extentMax ext) vert, makeCmpVert min (extentMin ext)
If that isn't a typo (what I expect it is), fixing that would be somewhat difficult.
I think it should be
(vertMax, vertMin) = ...
addToExtent is too lazy. A possible alternative definition is
addToExtent :: Extent -> Vertex -> Extent
addToExtent ext vert = vertMax `seq` vertMin `seq` Extent vertMax vertMin where
(vertMin, vertMax) = (makeCmpVert max (extentMax ext) vert, makeCmpVert min (extentMinext) vert) where
makeCmpVert f v1 v2 = Vertex(f (vertexX v1) (vertexX v2))
(f (vertexY v1) (vertexY v2))
(f (vertexZ v1) (vertexZ v2))
data Vertex =
Vertex{
vertexX :: {-# UNPACK #-} !Double,
vertexY :: {-# UNPACK #-} !Double,
vertexZ :: {-# UNPACK #-} !Double}
deriving (Eq, Show, Read)
The problem is that vertMin and vertMax are never evaluated until the entire file is processed - resulted in two huge thunks in Extent.
I also recommend changing the definition of Extent to
data Extent =
Extent{
extentMax :: !Vertex,
extentMin :: !Vertex}
deriving (Eq, Show, Read)
(though with these changes, the seq calls in addToExtent become redundant).

Derivatives of a multivariative function and corresponding Jacobian with vector-space package

I am having a problem with the vector-space package again. I received a very helpful answer from #mnish in a recent post, but there I only dealt with a function which depends on only 1 variable.
What happens when I have, for instance, a function which maps from polar coordinates to cartesians
f:(0,oo) x [0,2pi] -> R²
(r,phi) -> (r*cos(phi),r*sin(phi))
which depends on 2 variables.
I have tried this out, with quite a naive approach:
polar :: Double -> Double -> ((Double,Double) :~> (Double,Double))
polar r phi = \(r,phi) -> (((idD) r)*cos( idD phi),((idD) r)*sin( idD phi))
I get the following error:
Couldn't match expected type `(Double, Double) :> (Double, Double)'
with actual type `(t0, t1)'
In the expression:
(((idD) r) * cos (idD phi), ((idD) r) * sin (idD phi))
In the expression:
\ (r, phi)
-> (((idD) r) * cos (idD phi), ((idD) r) * sin (idD phi))
In an equation for `polar':
polar r phi
= \ (r, phi)
-> (((idD) r) * cos (idD phi), ((idD) r) * sin (idD phi))
For one component
polarx :: Double -> Double -> ((Double,Double) :~> Double)
polarx r phi = \(r,phi) -> ((idD) r)*cos( idD phi)
I get
Couldn't match expected type `Double'
with actual type `(Double, Double)'
Expected type: (Double, Double) :> Double
Actual type: (Double, Double) :> (Double, Double)
In the return type of a call of `idD'
In the first argument of `(*)', namely `((idD) r)'
Apparently there is some type disorder, but I can't figure out what is wrong.
Another question arises, when I want to calculate the Jacobian of such a mapping. As the name suggests, it has something to do with linear maps, which is, of course, covered by the package, actually it is based on those maps. But again, my Haskell knowledge is insufficient, to derive a solution on my own.
I finally found a solution to my problem, it was not that hard, but still it took me a while to figure it out. In case anyone else is interested I present the details.
First here is my code for the polar case:
polarCoordD :: ((Double,Double) :~> (Double,Double))
polarCoordD = \(r,phi) -> pairD (polarx (r,phi), polary (r,phi))
where polarx :: (Double,Double) :~> Double
polarx = \(r,phi) -> (fst . unpairD $ (idD) (r,phi))*cos( snd . unpairD $ idD (r, phi))
polary :: (Double,Double) :~> Double
polary = \(r,phi) -> (fst . unpairD $ (idD) (r,phi))*sin( snd . unpairD $ idD (r, phi))
The key was to make the "derivation variable" (idD) aware of the tuple (r, phi) which holds the two variables I want to differentiate. Then I have to unpack the tuple via unpairD and chose the first and the second part of the resulting pair (in polarx and polary). Both are packed again into a pair. Maybe there is a more elegant way to do this, but that's how I understood it finally.
From here it is not hard to go further to cylindrical coordinates or, in fact, to any other curved orthogonal coordinate system.
For cylindrical coordinates I obtain:
cylCoordD :: (Vec3 Double :~> Vec3 Double)
cylCoordD = \(r,phi,z) -> tripleD (cylx (r,phi,z), cyly (r,phi,z),cylz (0,0,z))
where cylx :: (Double,Double,Double) :~> Double
cylx = \(r,phi,z) -> (fst' . untripleD $ (idD) (r,phi,z))*cos( snd' . untripleD $ idD (r, phi,z))
cyly :: (Double,Double,Double) :~> Double
cyly = \(r,phi,z) -> (fst' . untripleD $ (idD) (r,phi,z))*sin( snd' . untripleD $ idD (r, phi,z))
cylz :: (Double,Double,Double) :~> Double
cylz = \(_,_,z) -> third . untripleD $ idD (0,0,z)
fst' :: (a,b,c) -> a
fst' (x,_,_) = x
snd' :: (a,b,c) -> b
snd' (_,y,_) = y
third :: (a,b,c) -> c
third (_,_,z) = z
where Vec3 Double belongs to type Vec3 a = (a, a, a).
Now we can even build a transformation matrix:
let transmat = \(r,phi,z) -> powVal $ liftD3 (,,) (normalized $ derivAtBasis (cylCoordD (r,phi,z)) (Left ())) (normalized $ derivAtBasis (cylCoordD (r,phi,z)) (Right (Left ()))) (normalized $ derivAtBasis (cylCoordD (r,phi,z)) (Right (Right ())))
*Main> transmat (2, rad 0, 0)
((1.0,0.0,0.0),(0.0,1.0,0.0),(0.0,0.0,1.0))
*Main> transmat (2, rad 90, 0)
((6.123233995736766e-17,1.0,0.0),(-1.0,6.123233995736766e-17,0.0),(0.0,0.0,1.0))
rad is a convenience function
rad :: Double -> Double
rad = (pi*) . (*recip 180)
Now it would be interesting to convert this "matrix" to the matrix type of Numeric Prelude and/or hmatrix, but I am not sure if this would be even useful. But still, it would be a nice example for the use of the vector-space -package.
I still have to figure out the use and especially the application of linear maps.
Just saw this followup question. I'm not sure what you want:
the Jacobian matrix
a Jacobian-vector product
a Jacobian-transpose-vector product
In such a low-dimensional system, I'll assume the first. (The others come in handy mainly when the system is high-dimensional enough that you don't want to store or compute the Jacobian per-se, but instead treat it as a generalized sparse matrix.) In any case:
Prelude> :m + Numeric.AD
Prelude Numeric.AD> let f [r,phi] = map (r*) [cos phi, sin phi]
Prelude Numeric.AD> jacobian f [2,3::Float]
[[-0.9899925,-0.28224],[0.14112,-1.979985]]

Resources