{-# LANGUAGE NamedFieldPuns #-}
-- | 
-- Module: SwissEphemeris.ChartUtils
-- License: AGPL-3
-- Maintainer: swiss-ephemeris@lfborjas.com
-- Portability: POSIX
--
-- Utility functions for chart drawing functionality. 
-- Uses the C code shared by the swiss ephemeris authors in the official
-- mailing list: <https://groups.io/g/swisseph/message/5568>

module SwissEphemeris.ChartUtils (
  GlyphInfo(..),
  PlanetGlyphInfo,
  glyphPlanet,
  cuspsToSectors,
  gravGroup,
  gravGroupEasy,
  gravGroup2,
  gravGroup2Easy
)
where

import Foreign
import Foreign.C.String
import Foreign.SwissEphemerisExtras
import SwissEphemeris.Internal
import System.IO.Unsafe (unsafePerformIO)
import Data.List ( sort )
import Control.Monad (forM)
import Control.Exception (bracket)

type PlanetGlyph = GravityObject Planet

-- | Information about a @glyph@ (planet or some other object
-- one intends to render within a circular chart) indicating
-- suggested position and scale as decided by 'gravGroup'
-- or 'gravGroup2' to minimize collisions without affecting
-- the sequence of a list of objects, or the sectors
-- within which they may be grouped.
data GlyphInfo a = GlyphInfo
  { GlyphInfo a -> Double
originalPosition :: Double
  -- ^ the original position, before correction
  , GlyphInfo a -> (Double, Double)
glyphSize :: (Double, Double)
  -- ^ lsize,rsize: original size, in degrees, from the center extending
  -- to the left and the right, respectively.
  ,  GlyphInfo a -> Double
placedPosition :: Double
  -- ^ position decided by the algorithm, in degrees
  , GlyphInfo a -> Int
sectorNumber :: Int
  -- ^ sector assigned; should be the same as the original
  , GlyphInfo a -> Int
sequenceNumber :: Int
  -- ^ position in sequence, should also be preserved
  , GlyphInfo a -> Int
levelNumber :: Int
  -- ^ if allowing for multiple concentric levels, which
  -- level is this supposed to be on.
  , GlyphInfo a -> Double
glyphScale :: Double
  -- ^ percentage of actual size it should be resized to
  -- fit, as per the algorithm's recommendation.
  , GlyphInfo a -> a
extraData  :: a
  -- ^ arbitrary data. For @PlanetGlyphInfo@, this is a 'Planet'.
  } deriving (Int -> GlyphInfo a -> ShowS
[GlyphInfo a] -> ShowS
GlyphInfo a -> String
(Int -> GlyphInfo a -> ShowS)
-> (GlyphInfo a -> String)
-> ([GlyphInfo a] -> ShowS)
-> Show (GlyphInfo a)
forall a. Show a => Int -> GlyphInfo a -> ShowS
forall a. Show a => [GlyphInfo a] -> ShowS
forall a. Show a => GlyphInfo a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [GlyphInfo a] -> ShowS
$cshowList :: forall a. Show a => [GlyphInfo a] -> ShowS
show :: GlyphInfo a -> String
$cshow :: forall a. Show a => GlyphInfo a -> String
showsPrec :: Int -> GlyphInfo a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> GlyphInfo a -> ShowS
Show, GlyphInfo a -> GlyphInfo a -> Bool
(GlyphInfo a -> GlyphInfo a -> Bool)
-> (GlyphInfo a -> GlyphInfo a -> Bool) -> Eq (GlyphInfo a)
forall a. Eq a => GlyphInfo a -> GlyphInfo a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: GlyphInfo a -> GlyphInfo a -> Bool
$c/= :: forall a. Eq a => GlyphInfo a -> GlyphInfo a -> Bool
== :: GlyphInfo a -> GlyphInfo a -> Bool
$c== :: forall a. Eq a => GlyphInfo a -> GlyphInfo a -> Bool
Eq)

-- | @GlyphInfo@ specialized to carry 'Planet' names
-- as its @extraData@.
type PlanetGlyphInfo = GlyphInfo Planet

-- | Convenience alias for the 'extraData' accessor, get
-- the 'Planet' conveyed along a glyph info.
glyphPlanet :: PlanetGlyphInfo -> Planet
glyphPlanet :: PlanetGlyphInfo -> Planet
glyphPlanet = PlanetGlyphInfo -> Planet
forall a. GlyphInfo a -> a
extraData

-- | This function does a little bit of insider trading:
-- given N cusps, returns N+1 sectors; where the last
-- sector is an "impossible" position beyond 360, that
-- sets the end of the last sector as the first sector's beginning,
-- beyond one turn. That way, any body occurring in
-- the last sector will exist between @sectors[N-1]@ and
-- @sectors[N]@. I've been using this as the "linearization"
-- approach for the sectors required by 'gravGroup',
-- but one may choose something different.
cuspsToSectors :: [HouseCusp] -> [Double]
cuspsToSectors :: [Double] -> [Double]
cuspsToSectors [] = []
cuspsToSectors [Double]
cusps =
  [Double]
sortedCusps [Double] -> [Double] -> [Double]
forall a. [a] -> [a] -> [a]
++ [[Double] -> Double
forall a. [a] -> a
head [Double]
sortedCusps Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
360.0]
  where
    sortedCusps :: [Double]
sortedCusps = [Double] -> [Double]
forall a. Ord a => [a] -> [a]
sort [Double]
cusps

-- | Given dimensions, planet positions and "sectors" within which
-- the planets are meant to be drawn as glyphs, return a list
-- pairing each position with a 'PlanetGlyphInfo' that not only
-- remembers the position's planet, it's guaranteed to place it
-- in the same sector and sequence it started in, but moved as to
-- avoid colliding with other nearby planets or sector boundaries.
--
-- Note that "sectors" are usually cusps, but one must take that they're
-- sorted or "linearized": no sector should jump over 0/360, and the
-- last sector should mark the "end" of the circle. I use 'cuspsToSectors'
-- on cusps obtained from the main module's cusp calculation functionality
-- and that seems to ensure that sectors are adequately monotonic and not
-- truncated, but one would be wise to take heed to the swiss ephemeris author's
-- notes, too:
-- https://groups.io/g/swisseph/message/5568
gravGroup
  :: HasEclipticLongitude  a
  => (Double, Double)
  -- ^ lwidth, rwidth
  -> [(Planet, a)]
  -- ^ list of pre-calculated positions
  -> [Double]
  -- ^ list of "sectors" (e.g. house cusps + end of last cusp)
  -> Either String [PlanetGlyphInfo]
gravGroup :: (Double, Double)
-> [(Planet, a)] -> [Double] -> Either String [PlanetGlyphInfo]
gravGroup (Double, Double)
sz [(Planet, a)]
positions [Double]
sectors =
  IO (Either String [PlanetGlyphInfo])
-> Either String [PlanetGlyphInfo]
forall a. IO a -> a
unsafePerformIO (IO (Either String [PlanetGlyphInfo])
 -> Either String [PlanetGlyphInfo])
-> IO (Either String [PlanetGlyphInfo])
-> Either String [PlanetGlyphInfo]
forall a b. (a -> b) -> a -> b
$ do
    (Double, Double)
-> [(Planet, a)]
-> (Ptr PlanetGlyph -> IO (Either String [PlanetGlyphInfo]))
-> IO (Either String [PlanetGlyphInfo])
forall a b.
HasEclipticLongitude a =>
(Double, Double)
-> [(Planet, a)] -> (Ptr PlanetGlyph -> IO b) -> IO b
withGrobs (Double, Double)
sz [(Planet, a)]
positions ((Ptr PlanetGlyph -> IO (Either String [PlanetGlyphInfo]))
 -> IO (Either String [PlanetGlyphInfo]))
-> (Ptr PlanetGlyph -> IO (Either String [PlanetGlyphInfo]))
-> IO (Either String [PlanetGlyphInfo])
forall a b. (a -> b) -> a -> b
$ \Ptr PlanetGlyph
grobs ->
      [CDouble]
-> (Ptr CDouble -> IO (Either String [PlanetGlyphInfo]))
-> IO (Either String [PlanetGlyphInfo])
forall a b. Storable a => [a] -> (Ptr a -> IO b) -> IO b
withArray ((Double -> CDouble) -> [Double] -> [CDouble]
forall a b. (a -> b) -> [a] -> [b]
map Double -> CDouble
forall a b. (Real a, Fractional b) => a -> b
realToFrac [Double]
sectors) ((Ptr CDouble -> IO (Either String [PlanetGlyphInfo]))
 -> IO (Either String [PlanetGlyphInfo]))
-> (Ptr CDouble -> IO (Either String [PlanetGlyphInfo]))
-> IO (Either String [PlanetGlyphInfo])
forall a b. (a -> b) -> a -> b
$ \Ptr CDouble
sbdy ->
        (Ptr CChar -> IO (Either String [PlanetGlyphInfo]))
-> IO (Either String [PlanetGlyphInfo])
forall b. (Ptr CChar -> IO b) -> IO b
allocaErrorMessage ((Ptr CChar -> IO (Either String [PlanetGlyphInfo]))
 -> IO (Either String [PlanetGlyphInfo]))
-> (Ptr CChar -> IO (Either String [PlanetGlyphInfo]))
-> IO (Either String [PlanetGlyphInfo])
forall a b. (a -> b) -> a -> b
$ \Ptr CChar
serr -> do
          let nob :: CInt
nob = Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> CInt) -> Int -> CInt
forall a b. (a -> b) -> a -> b
$ [(Planet, a)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Planet, a)]
positions
              nsectors :: CInt
nsectors = CInt -> CInt -> CInt
forall a. Ord a => a -> a -> a
max CInt
0 (CInt -> CInt) -> CInt -> CInt
forall a b. (a -> b) -> a -> b
$ Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> CInt) -> Int -> CInt
forall a b. (a -> b) -> a -> b
$ [Double] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Double]
sectors Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
          CInt
retval <-
            Ptr PlanetGlyph
-> CInt -> Ptr CDouble -> CInt -> Ptr CChar -> IO CInt
forall a.
Ptr (GravityObject a)
-> CInt -> Ptr CDouble -> CInt -> Ptr CChar -> IO CInt
c_grav_group Ptr PlanetGlyph
grobs CInt
nob Ptr CDouble
sbdy CInt
nsectors Ptr CChar
serr

          if CInt
retval CInt -> CInt -> Bool
forall a. Ord a => a -> a -> Bool
< CInt
0 then do
            String
msg <- Ptr CChar -> IO String
peekCAString Ptr CChar
serr
            Either String [PlanetGlyphInfo]
-> IO (Either String [PlanetGlyphInfo])
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String [PlanetGlyphInfo]
 -> IO (Either String [PlanetGlyphInfo]))
-> Either String [PlanetGlyphInfo]
-> IO (Either String [PlanetGlyphInfo])
forall a b. (a -> b) -> a -> b
$ String -> Either String [PlanetGlyphInfo]
forall a b. a -> Either a b
Left String
msg
          else do
            [PlanetGlyph]
repositioned <- Int -> Ptr PlanetGlyph -> IO [PlanetGlyph]
forall a. Storable a => Int -> Ptr a -> IO [a]
peekArray (CInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
nob) Ptr PlanetGlyph
grobs
            [PlanetGlyphInfo]
glyphInfos <- (PlanetGlyph -> IO PlanetGlyphInfo)
-> [PlanetGlyph] -> IO [PlanetGlyphInfo]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM PlanetGlyph -> IO PlanetGlyphInfo
glyphInfo [PlanetGlyph]
repositioned
            Either String [PlanetGlyphInfo]
-> IO (Either String [PlanetGlyphInfo])
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String [PlanetGlyphInfo]
 -> IO (Either String [PlanetGlyphInfo]))
-> ([PlanetGlyphInfo] -> Either String [PlanetGlyphInfo])
-> [PlanetGlyphInfo]
-> IO (Either String [PlanetGlyphInfo])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [PlanetGlyphInfo] -> Either String [PlanetGlyphInfo]
forall a b. b -> Either a b
Right ([PlanetGlyphInfo] -> IO (Either String [PlanetGlyphInfo]))
-> [PlanetGlyphInfo] -> IO (Either String [PlanetGlyphInfo])
forall a b. (a -> b) -> a -> b
$ [PlanetGlyphInfo]
glyphInfos

-- | /Easy/ version of 'gravGroup' that assumes:
--
-- * Glyphs are square/symmetrical, so the left and right widths
-- are just half of the provided width, each.
-- * The provided cusps can be "linearized" by the naïve approach of 'cuspsToSectors'
-- 
gravGroupEasy :: HasEclipticLongitude a
  => Double
  -> [(Planet, a)]
  -> [HouseCusp]
  -> Either String [PlanetGlyphInfo]
gravGroupEasy :: Double
-> [(Planet, a)] -> [Double] -> Either String [PlanetGlyphInfo]
gravGroupEasy Double
w [(Planet, a)]
ps [Double]
s = (Double, Double)
-> [(Planet, a)] -> [Double] -> Either String [PlanetGlyphInfo]
forall a.
HasEclipticLongitude a =>
(Double, Double)
-> [(Planet, a)] -> [Double] -> Either String [PlanetGlyphInfo]
gravGroup (Double
wDouble -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
2,Double
wDouble -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
2) [(Planet, a)]
ps ([Double] -> [Double]
cuspsToSectors [Double]
s)

-- | Same semantics and warnings as 'gravGroup', but allows a couple of things for
-- more advanced (or crowded) applications:
--
-- * Can send an empty list of sectors, to indicate that there's no subdivisions
-- in the circle.
-- * Can specify if planets can be pushed to an "inner" level if they're too
-- crowded in their assigned sector. Useful when drawing several objects in a
-- chart with many/tight sectors.
--
-- With a non-empty list of sectors, and not allowing shifting, this is essentially
-- a slightly slower version of 'gravGroup'.
gravGroup2
  :: HasEclipticLongitude a
  => (Double, Double)
  -- ^ lwidth, rwidth
  -> [(Planet, a)]
  -- ^ list of pre-calculated positions
  -> [Double]
  -- ^ list of "sectors" (e.g. house cusps + end of last cusp)
  -- (can be empty, indicating that we're working in a non-subdivided circle.)
  -> Bool
  -- ^ allow planets to be moved up or down a level?
  -> Either String [PlanetGlyphInfo]
gravGroup2 :: (Double, Double)
-> [(Planet, a)]
-> [Double]
-> Bool
-> Either String [PlanetGlyphInfo]
gravGroup2 (Double, Double)
sz [(Planet, a)]
positions [Double]
sectors Bool
allowShift =
  -- for empty sectors, we need to add an artificial "whole-circle" sector.
  let sectors' :: [Double]
sectors' = if [Double] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Double]
sectors then [Double
0, Double
360.0] else [Double]
sectors
  in IO (Either String [PlanetGlyphInfo])
-> Either String [PlanetGlyphInfo]
forall a. IO a -> a
unsafePerformIO (IO (Either String [PlanetGlyphInfo])
 -> Either String [PlanetGlyphInfo])
-> IO (Either String [PlanetGlyphInfo])
-> Either String [PlanetGlyphInfo]
forall a b. (a -> b) -> a -> b
$ do
    (Double, Double)
-> [(Planet, a)]
-> (Ptr PlanetGlyph -> IO (Either String [PlanetGlyphInfo]))
-> IO (Either String [PlanetGlyphInfo])
forall a b.
HasEclipticLongitude a =>
(Double, Double)
-> [(Planet, a)] -> (Ptr PlanetGlyph -> IO b) -> IO b
withGrobs (Double, Double)
sz [(Planet, a)]
positions ((Ptr PlanetGlyph -> IO (Either String [PlanetGlyphInfo]))
 -> IO (Either String [PlanetGlyphInfo]))
-> (Ptr PlanetGlyph -> IO (Either String [PlanetGlyphInfo]))
-> IO (Either String [PlanetGlyphInfo])
forall a b. (a -> b) -> a -> b
$ \Ptr PlanetGlyph
grobs ->
      [CDouble]
-> (Ptr CDouble -> IO (Either String [PlanetGlyphInfo]))
-> IO (Either String [PlanetGlyphInfo])
forall a b. Storable a => [a] -> (Ptr a -> IO b) -> IO b
withArray ((Double -> CDouble) -> [Double] -> [CDouble]
forall a b. (a -> b) -> [a] -> [b]
map Double -> CDouble
forall a b. (Real a, Fractional b) => a -> b
realToFrac [Double]
sectors') ((Ptr CDouble -> IO (Either String [PlanetGlyphInfo]))
 -> IO (Either String [PlanetGlyphInfo]))
-> (Ptr CDouble -> IO (Either String [PlanetGlyphInfo]))
-> IO (Either String [PlanetGlyphInfo])
forall a b. (a -> b) -> a -> b
$ \Ptr CDouble
sbdy ->
        (Ptr CChar -> IO (Either String [PlanetGlyphInfo]))
-> IO (Either String [PlanetGlyphInfo])
forall b. (Ptr CChar -> IO b) -> IO b
allocaErrorMessage ((Ptr CChar -> IO (Either String [PlanetGlyphInfo]))
 -> IO (Either String [PlanetGlyphInfo]))
-> (Ptr CChar -> IO (Either String [PlanetGlyphInfo]))
-> IO (Either String [PlanetGlyphInfo])
forall a b. (a -> b) -> a -> b
$ \Ptr CChar
serr -> do
          let nob :: CInt
nob = Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> CInt) -> Int -> CInt
forall a b. (a -> b) -> a -> b
$ [(Planet, a)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Planet, a)]
positions
              -- empty sector lists are allowed:
              nsectors :: CInt
nsectors = CInt -> CInt -> CInt
forall a. Ord a => a -> a -> a
max CInt
0 (CInt -> CInt) -> CInt -> CInt
forall a b. (a -> b) -> a -> b
$ Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> CInt) -> Int -> CInt
forall a b. (a -> b) -> a -> b
$ [Double] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Double]
sectors Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
              mayShift :: CBool
mayShift = Bool -> CBool
forall a. Num a => Bool -> a
fromBool Bool
allowShift
          CInt
retval <-
            Ptr PlanetGlyph
-> CInt -> Ptr CDouble -> CInt -> CBool -> Ptr CChar -> IO CInt
forall a.
Ptr (GravityObject a)
-> CInt -> Ptr CDouble -> CInt -> CBool -> Ptr CChar -> IO CInt
c_grav_group2 Ptr PlanetGlyph
grobs CInt
nob Ptr CDouble
sbdy CInt
nsectors CBool
mayShift Ptr CChar
serr

          if CInt
retval CInt -> CInt -> Bool
forall a. Ord a => a -> a -> Bool
< CInt
0 then do
            String
msg <- Ptr CChar -> IO String
peekCAString Ptr CChar
serr
            Either String [PlanetGlyphInfo]
-> IO (Either String [PlanetGlyphInfo])
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String [PlanetGlyphInfo]
 -> IO (Either String [PlanetGlyphInfo]))
-> Either String [PlanetGlyphInfo]
-> IO (Either String [PlanetGlyphInfo])
forall a b. (a -> b) -> a -> b
$ String -> Either String [PlanetGlyphInfo]
forall a b. a -> Either a b
Left String
msg
          else do
            [PlanetGlyph]
repositioned <- Int -> Ptr PlanetGlyph -> IO [PlanetGlyph]
forall a. Storable a => Int -> Ptr a -> IO [a]
peekArray (CInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
nob) Ptr PlanetGlyph
grobs
            [PlanetGlyphInfo]
glyphInfos <- (PlanetGlyph -> IO PlanetGlyphInfo)
-> [PlanetGlyph] -> IO [PlanetGlyphInfo]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM PlanetGlyph -> IO PlanetGlyphInfo
glyphInfo [PlanetGlyph]
repositioned
            Either String [PlanetGlyphInfo]
-> IO (Either String [PlanetGlyphInfo])
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String [PlanetGlyphInfo]
 -> IO (Either String [PlanetGlyphInfo]))
-> ([PlanetGlyphInfo] -> Either String [PlanetGlyphInfo])
-> [PlanetGlyphInfo]
-> IO (Either String [PlanetGlyphInfo])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [PlanetGlyphInfo] -> Either String [PlanetGlyphInfo]
forall a b. b -> Either a b
Right ([PlanetGlyphInfo] -> IO (Either String [PlanetGlyphInfo]))
-> [PlanetGlyphInfo] -> IO (Either String [PlanetGlyphInfo])
forall a b. (a -> b) -> a -> b
$ [PlanetGlyphInfo]
glyphInfos


-- | /Easy/ version of 'gravGroup2', same provisions as 'gravGroupEasy'
gravGroup2Easy :: HasEclipticLongitude a
  => Double
  -> [(Planet, a)]
  -> [HouseCusp]
  -> Bool
  -> Either String [PlanetGlyphInfo]
gravGroup2Easy :: Double
-> [(Planet, a)]
-> [Double]
-> Bool
-> Either String [PlanetGlyphInfo]
gravGroup2Easy Double
w [(Planet, a)]
ps [Double]
s = (Double, Double)
-> [(Planet, a)]
-> [Double]
-> Bool
-> Either String [PlanetGlyphInfo]
forall a.
HasEclipticLongitude a =>
(Double, Double)
-> [(Planet, a)]
-> [Double]
-> Bool
-> Either String [PlanetGlyphInfo]
gravGroup2 (Double
wDouble -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
2, Double
wDouble -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
2) [(Planet, a)]
ps ([Double] -> [Double]
cuspsToSectors [Double]
s)

-- | Given glyph dimensions and a list of ecliptic positions for planets,
-- execute the given computation with an array of @GravityObject@s,
-- ensuring that no pointers escape scope.
withGrobs
  :: HasEclipticLongitude a
  => (Double, Double)
  -> [(Planet, a)]
  -> (Ptr PlanetGlyph -> IO b)
  -> IO b
withGrobs :: (Double, Double)
-> [(Planet, a)] -> (Ptr PlanetGlyph -> IO b) -> IO b
withGrobs (Double
lwidth, Double
rwidth) [(Planet, a)]
positions Ptr PlanetGlyph -> IO b
f = do
  -- we're using the least sophisticated of the strategies
  -- here:
  -- https://ro-che.info/articles/2017-08-06-manage-allocated-memory-haskell
  -- or here: https://wiki.haskell.org/Bracket_pattern
  -- but it seems to do the job
  IO [PlanetGlyph]
-> ([PlanetGlyph] -> IO ()) -> ([PlanetGlyph] -> IO b) -> IO b
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket
    IO [PlanetGlyph]
mkGrobList
    [PlanetGlyph] -> IO ()
forall a. [GravityObject a] -> IO ()
freePlanetPtrs
    ([PlanetGlyph] -> (Ptr PlanetGlyph -> IO b) -> IO b
forall a b. Storable a => [a] -> (Ptr a -> IO b) -> IO b
`withArray` Ptr PlanetGlyph -> IO b
f)
  where
    mkGrobList :: IO [PlanetGlyph]
mkGrobList = [(Planet, a)]
-> ((Planet, a) -> IO PlanetGlyph) -> IO [PlanetGlyph]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(Planet, a)]
positions (((Planet, a) -> IO PlanetGlyph) -> IO [PlanetGlyph])
-> ((Planet, a) -> IO PlanetGlyph) -> IO [PlanetGlyph]
forall a b. (a -> b) -> a -> b
$ \(Planet
planet, a
pos) -> do
      Ptr Planet
planetPtr <- Planet -> IO (Ptr Planet)
forall a. Storable a => a -> IO (Ptr a)
new Planet
planet
      PlanetGlyph -> IO PlanetGlyph
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PlanetGlyph -> IO PlanetGlyph) -> PlanetGlyph -> IO PlanetGlyph
forall a b. (a -> b) -> a -> b
$
       GravityObject :: forall a.
CDouble
-> CDouble
-> CDouble
-> CDouble
-> CInt
-> CInt
-> CInt
-> CDouble
-> Ptr a
-> GravityObject a
GravityObject {
         pos :: CDouble
pos =   Double -> CDouble
forall a b. (Real a, Fractional b) => a -> b
realToFrac (Double -> CDouble) -> (a -> Double) -> a -> CDouble
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Double
forall a. HasEclipticLongitude a => a -> Double
getEclipticLongitude (a -> CDouble) -> a -> CDouble
forall a b. (a -> b) -> a -> b
$ a
pos
       , lsize :: CDouble
lsize = Double -> CDouble
forall a b. (Real a, Fractional b) => a -> b
realToFrac Double
lwidth
       , rsize :: CDouble
rsize = Double -> CDouble
forall a b. (Real a, Fractional b) => a -> b
realToFrac Double
rwidth
       -- fields that will be changed by the functions
       , ppos :: CDouble
ppos = CDouble
0.0
       , sector_no :: CInt
sector_no = CInt
0
       , sequence_no :: CInt
sequence_no = CInt
0
       , level_no :: CInt
level_no = CInt
0
       , scale :: CDouble
scale = CDouble
0.0
       -- store a pointer to the planet enum (stored as an int)
       -- as the "extra data" -- this allows us to remember which
       -- planet this is, without having to schlep around the entire
       -- @EclipticPosition@
       , dp :: Ptr Planet
dp = Ptr Planet
planetPtr
       }
    freePlanetPtrs :: [GravityObject a] -> IO ()
freePlanetPtrs = (GravityObject a -> IO ()) -> [GravityObject a] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Ptr a -> IO ()
forall a. Ptr a -> IO ()
free (Ptr a -> IO ())
-> (GravityObject a -> Ptr a) -> GravityObject a -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GravityObject a -> Ptr a
forall a. GravityObject a -> Ptr a
dp)



glyphInfo :: PlanetGlyph -> IO PlanetGlyphInfo
glyphInfo :: PlanetGlyph -> IO PlanetGlyphInfo
glyphInfo GravityObject{CDouble
pos :: CDouble
pos :: forall a. GravityObject a -> CDouble
pos, CDouble
lsize :: CDouble
lsize :: forall a. GravityObject a -> CDouble
lsize, CDouble
rsize :: CDouble
rsize :: forall a. GravityObject a -> CDouble
rsize, CDouble
ppos :: CDouble
ppos :: forall a. GravityObject a -> CDouble
ppos, CInt
sector_no :: CInt
sector_no :: forall a. GravityObject a -> CInt
sector_no, CInt
sequence_no :: CInt
sequence_no :: forall a. GravityObject a -> CInt
sequence_no, CInt
level_no :: CInt
level_no :: forall a. GravityObject a -> CInt
level_no, CDouble
scale :: CDouble
scale :: forall a. GravityObject a -> CDouble
scale, Ptr Planet
dp :: Ptr Planet
dp :: forall a. GravityObject a -> Ptr a
dp} = do
  Planet
planet' <- Ptr Planet -> IO Planet
forall a. Storable a => Ptr a -> IO a
peek Ptr Planet
dp
  PlanetGlyphInfo -> IO PlanetGlyphInfo
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PlanetGlyphInfo -> IO PlanetGlyphInfo)
-> PlanetGlyphInfo -> IO PlanetGlyphInfo
forall a b. (a -> b) -> a -> b
$
    GlyphInfo :: forall a.
Double
-> (Double, Double)
-> Double
-> Int
-> Int
-> Int
-> Double
-> a
-> GlyphInfo a
GlyphInfo {
      originalPosition :: Double
originalPosition = CDouble -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac  CDouble
pos
    , glyphSize :: (Double, Double)
glyphSize = (CDouble -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac CDouble
lsize, CDouble -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac CDouble
rsize)
    , placedPosition :: Double
placedPosition = CDouble -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac CDouble
ppos
    , sectorNumber :: Int
sectorNumber = CInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral  CInt
sector_no
    , sequenceNumber :: Int
sequenceNumber = CInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
sequence_no
    , levelNumber :: Int
levelNumber = CInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
level_no
    , glyphScale :: Double
glyphScale = CDouble -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac CDouble
scale
    , extraData :: Planet
extraData = Planet
planet'
    }