module Currycarbon.CLI.RunCalibrate
(CalibrateOptions (..), runCalibrate) where
import Currycarbon.CalCurves.Intcal20
import Currycarbon.Calibration.Calibration
import Currycarbon.Parsers
import Currycarbon.SumCalibration
import Currycarbon.Types
import Currycarbon.Utils
import Control.Exception (throwIO)
import Control.Monad (unless, when)
import Data.Maybe (fromJust, fromMaybe,
isJust)
import System.IO (hPutStrLn, stderr)
import qualified System.Random as R
data CalibrateOptions = CalibrateOptions {
CalibrateOptions -> [NamedCalExpr]
_calibrateExprs :: [NamedCalExpr]
, CalibrateOptions -> [String]
_calibrateExprFiles :: [FilePath]
, CalibrateOptions -> Maybe String
_calibrateCalCurveFile :: Maybe FilePath
, CalibrateOptions -> CalibrationMethod
_calibrateCalibrationMethod :: CalibrationMethod
, CalibrateOptions -> Bool
_calibrateAllowOutside :: Bool
, CalibrateOptions -> Bool
_calibrateDontInterpolateCalCurve :: Bool
, CalibrateOptions -> Bool
_calibrateQuiet :: Bool
, CalibrateOptions -> String
_calibrateStdOutEncoding :: String
, CalibrateOptions -> Maybe String
_calibrateDensityFile :: Maybe FilePath
, CalibrateOptions -> Maybe String
_calibrateHDRFile :: Maybe FilePath
, CalibrateOptions -> Maybe (Maybe Word, Word, String)
_calibrateAgeSampling :: Maybe (Maybe Word, Word, FilePath)
, CalibrateOptions -> Maybe String
_calibrateCalCurveSegmentFile :: Maybe FilePath
, CalibrateOptions -> Maybe String
_calibrateCalCurveMatrixFile :: Maybe FilePath
}
runCalibrate :: CalibrateOptions -> IO ()
runCalibrate :: CalibrateOptions -> IO ()
runCalibrate (
CalibrateOptions
[NamedCalExpr]
exprs [String]
exprFiles
Maybe String
calCurveFile CalibrationMethod
method Bool
allowOutside Bool
noInterpolate
Bool
quiet String
encoding
Maybe String
densityFile Maybe String
hdrFile
Maybe (Maybe Word, Word, String)
ageSampling
Maybe String
calCurveSegmentFile Maybe String
calCurveMatrixFile
) = do
let ascii :: Bool
ascii = String
encoding forall a. Eq a => a -> a -> Bool
/= String
"UTF-8"
[[NamedCalExpr]]
exprsFromFile <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM String -> IO [NamedCalExpr]
readNamedCalExprsFromFile [String]
exprFiles
let exprsCombined :: [NamedCalExpr]
exprsCombined = [NamedCalExpr]
exprs forall a. [a] -> [a] -> [a]
++ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[NamedCalExpr]]
exprsFromFile
exprsRenamed :: [NamedCalExpr]
exprsRenamed = [NamedCalExpr] -> [NamedCalExpr]
replaceEmptyNames [NamedCalExpr]
exprsCombined
if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [NamedCalExpr]
exprsRenamed
then Handle -> String -> IO ()
hPutStrLn Handle
stderr String
"Nothing to calibrate. See currycarbon -h for help"
else do
Handle -> String -> IO ()
hPutStrLn Handle
stderr forall a b. (a -> b) -> a -> b
$ String
"Method: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show CalibrationMethod
method
Handle -> String -> IO ()
hPutStrLn Handle
stderr forall a b. (a -> b) -> a -> b
$ String
"Curve: " forall a. [a] -> [a] -> [a]
++ forall a. a -> Maybe a -> a
fromMaybe String
"IntCal20" Maybe String
calCurveFile
CalCurveBP
calCurve <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return CalCurveBP
intcal20) String -> IO CalCurveBP
readCalCurveFromFile Maybe String
calCurveFile
let calConf :: CalibrateDatesConf
calConf = CalibrateDatesConf
defaultCalConf {
_calConfMethod :: CalibrationMethod
_calConfMethod = CalibrationMethod
method
, _calConfAllowOutside :: Bool
_calConfAllowOutside = Bool
allowOutside
, _calConfInterpolateCalCurve :: Bool
_calConfInterpolateCalCurve = Bool -> Bool
not Bool
noInterpolate
}
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. Maybe a -> Bool
isJust Maybe String
calCurveSegmentFile Bool -> Bool -> Bool
|| forall a. Maybe a -> Bool
isJust Maybe String
calCurveMatrixFile) forall a b. (a -> b) -> a -> b
$ do
case [NamedCalExpr]
exprsRenamed of
[NamedCalExpr String
_ (UnCalDate UncalC14
uncal)] -> do
let calCurveSegment :: CalCurveBCAD
calCurveSegment = Bool -> CalCurveBP -> CalCurveBCAD
prepareCalCurveSegment (Bool -> Bool
not Bool
noInterpolate) forall a b. (a -> b) -> a -> b
$
UncalC14 -> CalCurveBP -> CalCurveBP
getRelevantCalCurveSegment UncalC14
uncal CalCurveBP
calCurve
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. Maybe a -> Bool
isJust Maybe String
calCurveSegmentFile) forall a b. (a -> b) -> a -> b
$
String -> CalCurveBCAD -> IO ()
writeCalCurve (forall a. HasCallStack => Maybe a -> a
fromJust Maybe String
calCurveSegmentFile) CalCurveBCAD
calCurveSegment
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. Maybe a -> Bool
isJust Maybe String
calCurveMatrixFile) forall a b. (a -> b) -> a -> b
$
String -> CalCurveMatrix -> IO ()
writeCalCurveMatrix (forall a. HasCallStack => Maybe a -> a
fromJust Maybe String
calCurveMatrixFile) forall a b. (a -> b) -> a -> b
$
UncalPDF -> CalCurveBCAD -> CalCurveMatrix
makeCalCurveMatrix (UncalC14 -> UncalPDF
uncalToPDF UncalC14
uncal) CalCurveBCAD
calCurveSegment
[NamedCalExpr]
_ -> do
forall e a. Exception e => e -> IO a
throwIO forall a b. (a -> b) -> a -> b
$ String -> CurrycarbonException
CurrycarbonCLIException
String
"--calCurveSegFile and --calCurveMatFile only work with \
\a single uncalibrated radiocarbon date."
Handle -> String -> IO ()
hPutStrLn Handle
stderr String
"Calibrating..."
let errorOrCalPDFs :: [Either CurrycarbonException CalPDF]
errorOrCalPDFs = forall a b. (a -> b) -> [a] -> [b]
map (CalibrateDatesConf
-> CalCurveBP -> NamedCalExpr -> Either CurrycarbonException CalPDF
evalNamedCalExpr CalibrateDatesConf
calConf CalCurveBP
calCurve) [NamedCalExpr]
exprsRenamed
Maybe StdGen
maybeRNG <- case Maybe (Maybe Word, Word, String)
ageSampling of
Maybe (Maybe Word, Word, String)
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
Just (Maybe Word
maybeSeed, Word
_, String
_) -> case Maybe Word
maybeSeed of
Maybe Word
Nothing -> forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). MonadIO m => m StdGen
R.initStdGen
Just Word
seed -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Int -> StdGen
R.mkStdGen (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
seed)
Bool
-> Bool
-> CalCurveBP
-> Maybe StdGen
-> [(NamedCalExpr, Either CurrycarbonException CalPDF)]
-> IO ()
handleExprs Bool
ascii Bool
True CalCurveBP
calCurve Maybe StdGen
maybeRNG forall a b. (a -> b) -> a -> b
$ forall a b. [a] -> [b] -> [(a, b)]
zip [NamedCalExpr]
exprsRenamed [Either CurrycarbonException CalPDF]
errorOrCalPDFs
where
handleExprs ::
Bool
-> Bool
-> CalCurveBP
-> Maybe R.StdGen
-> [(NamedCalExpr, Either CurrycarbonException CalPDF)]
-> IO ()
handleExprs :: Bool
-> Bool
-> CalCurveBP
-> Maybe StdGen
-> [(NamedCalExpr, Either CurrycarbonException CalPDF)]
-> IO ()
handleExprs Bool
_ Bool
_ CalCurveBP
_ Maybe StdGen
_ [] = Handle -> String -> IO ()
hPutStrLn Handle
stderr String
"Done."
handleExprs Bool
_ascii Bool
True CalCurveBP
calCurve Maybe StdGen
maybeRNG ((NamedCalExpr, Either CurrycarbonException CalPDF)
firstDate:[(NamedCalExpr, Either CurrycarbonException CalPDF)]
otherDates) =
case (NamedCalExpr, Either CurrycarbonException CalPDF)
firstDate of
(NamedCalExpr
_, Left CurrycarbonException
e) -> do
CurrycarbonException -> IO ()
printE CurrycarbonException
e
Bool
-> Bool
-> CalCurveBP
-> Maybe StdGen
-> [(NamedCalExpr, Either CurrycarbonException CalPDF)]
-> IO ()
handleExprs Bool
_ascii Bool
True CalCurveBP
calCurve Maybe StdGen
maybeRNG [(NamedCalExpr, Either CurrycarbonException CalPDF)]
otherDates
(NamedCalExpr
namedCalExpr, Right CalPDF
cPDF) -> do
let (Maybe Int
sampleSeed, Maybe StdGen
newRNG) = Maybe StdGen -> (Maybe Int, Maybe StdGen)
drawSeed Maybe StdGen
maybeRNG
Bool
-> NamedCalExpr
-> CalPDF
-> Maybe Int
-> (String -> CalPDF -> IO ())
-> (String -> CalC14 -> IO ())
-> (String -> RandomAgeSample -> IO ())
-> IO ()
flexOut Bool
_ascii NamedCalExpr
namedCalExpr CalPDF
cPDF Maybe Int
sampleSeed String -> CalPDF -> IO ()
writeCalPDF String -> CalC14 -> IO ()
writeCalC14 String -> RandomAgeSample -> IO ()
writeRandomAgeSample
Bool
-> Bool
-> CalCurveBP
-> Maybe StdGen
-> [(NamedCalExpr, Either CurrycarbonException CalPDF)]
-> IO ()
handleExprs Bool
_ascii Bool
False CalCurveBP
calCurve Maybe StdGen
newRNG [(NamedCalExpr, Either CurrycarbonException CalPDF)]
otherDates
handleExprs Bool
_ascii Bool
False CalCurveBP
calCurve Maybe StdGen
maybeRNG ((NamedCalExpr, Either CurrycarbonException CalPDF)
nextDate:[(NamedCalExpr, Either CurrycarbonException CalPDF)]
otherDates) =
case (NamedCalExpr, Either CurrycarbonException CalPDF)
nextDate of
(NamedCalExpr
_, Left CurrycarbonException
e) -> do
CurrycarbonException -> IO ()
printE CurrycarbonException
e
Bool
-> Bool
-> CalCurveBP
-> Maybe StdGen
-> [(NamedCalExpr, Either CurrycarbonException CalPDF)]
-> IO ()
handleExprs Bool
_ascii Bool
False CalCurveBP
calCurve Maybe StdGen
maybeRNG [(NamedCalExpr, Either CurrycarbonException CalPDF)]
otherDates
(NamedCalExpr
namedCalExpr, Right CalPDF
cPDF) -> do
let (Maybe Int
sampleSeed, Maybe StdGen
newRNG) = Maybe StdGen -> (Maybe Int, Maybe StdGen)
drawSeed Maybe StdGen
maybeRNG
Bool
-> NamedCalExpr
-> CalPDF
-> Maybe Int
-> (String -> CalPDF -> IO ())
-> (String -> CalC14 -> IO ())
-> (String -> RandomAgeSample -> IO ())
-> IO ()
flexOut Bool
_ascii NamedCalExpr
namedCalExpr CalPDF
cPDF Maybe Int
sampleSeed String -> CalPDF -> IO ()
appendCalPDF String -> CalC14 -> IO ()
appendCalC14 String -> RandomAgeSample -> IO ()
appendRandomAgeSample
Bool
-> Bool
-> CalCurveBP
-> Maybe StdGen
-> [(NamedCalExpr, Either CurrycarbonException CalPDF)]
-> IO ()
handleExprs Bool
_ascii Bool
False CalCurveBP
calCurve Maybe StdGen
newRNG [(NamedCalExpr, Either CurrycarbonException CalPDF)]
otherDates
printE :: CurrycarbonException -> IO ()
printE :: CurrycarbonException -> IO ()
printE CurrycarbonException
e = Handle -> String -> IO ()
hPutStrLn Handle
stderr forall a b. (a -> b) -> a -> b
$ CurrycarbonException -> String
renderCurrycarbonException CurrycarbonException
e
drawSeed :: Maybe R.StdGen -> (Maybe Int, Maybe R.StdGen)
drawSeed :: Maybe StdGen -> (Maybe Int, Maybe StdGen)
drawSeed Maybe StdGen
maybeRNG = (\Maybe (Word32, StdGen)
x -> (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Word32, StdGen)
x, forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Word32, StdGen)
x)) (forall g. RandomGen g => g -> (Word32, g)
R.genWord32 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe StdGen
maybeRNG)
flexOut ::
Bool
-> NamedCalExpr
-> CalPDF
-> Maybe Int
-> (FilePath -> CalPDF -> IO ())
-> (FilePath -> CalC14 -> IO ())
-> (FilePath -> RandomAgeSample -> IO ())
-> IO ()
flexOut :: Bool
-> NamedCalExpr
-> CalPDF
-> Maybe Int
-> (String -> CalPDF -> IO ())
-> (String -> CalC14 -> IO ())
-> (String -> RandomAgeSample -> IO ())
-> IO ()
flexOut Bool
_ascii NamedCalExpr
namedCalExpr CalPDF
calPDF Maybe Int
maybeSeed String -> CalPDF -> IO ()
calPDFToFile String -> CalC14 -> IO ()
calC14ToFile String -> RandomAgeSample -> IO ()
randomAgeSampleToFile = do
case CalPDF -> Either CurrycarbonException CalC14
refineCalDate CalPDF
calPDF of
Left CurrycarbonException
e -> do
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
quiet forall a b. (a -> b) -> a -> b
$ do
String -> IO ()
putStrLn (String
"CalEXPR: " forall a. [a] -> [a] -> [a]
++ NamedCalExpr -> String
renderNamedCalExpr NamedCalExpr
namedCalExpr)
CurrycarbonException -> IO ()
printE CurrycarbonException
e
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. Maybe a -> Bool
isJust Maybe String
hdrFile) forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
quiet forall a b. (a -> b) -> a -> b
$
Handle -> String -> IO ()
hPutStrLn Handle
stderr String
"<!> Error: Can not create --hdrFile"
Right CalC14
calC14 -> do
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
quiet forall a b. (a -> b) -> a -> b
$ do
String -> IO ()
putStrLn (Bool -> (NamedCalExpr, CalPDF, CalC14) -> String
renderCalDatePretty Bool
_ascii (NamedCalExpr
namedCalExpr, CalPDF
calPDF, CalC14
calC14))
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. Maybe a -> Bool
isJust Maybe String
hdrFile) forall a b. (a -> b) -> a -> b
$
String -> CalC14 -> IO ()
calC14ToFile (forall a. HasCallStack => Maybe a -> a
fromJust Maybe String
hdrFile) CalC14
calC14
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. Maybe a -> Bool
isJust Maybe (Maybe Word, Word, String)
ageSampling Bool -> Bool -> Bool
&& forall a. Maybe a -> Bool
isJust Maybe Int
maybeSeed) forall a b. (a -> b) -> a -> b
$ do
let (Maybe Word
_, Word
nrOfSamples, String
path) = forall a. HasCallStack => Maybe a -> a
fromJust Maybe (Maybe Word, Word, String)
ageSampling
rng :: StdGen
rng = Int -> StdGen
R.mkStdGen (forall a. HasCallStack => Maybe a -> a
fromJust Maybe Int
maybeSeed)
conf :: AgeSamplingConf
conf = StdGen -> Word -> AgeSamplingConf
AgeSamplingConf StdGen
rng Word
nrOfSamples
case AgeSamplingConf
-> CalPDF -> Either CurrycarbonException RandomAgeSample
sampleAgesFromCalPDF AgeSamplingConf
conf CalPDF
calPDF of
Left CurrycarbonException
e -> do
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
quiet forall a b. (a -> b) -> a -> b
$ do
CurrycarbonException -> IO ()
printE CurrycarbonException
e
Handle -> String -> IO ()
hPutStrLn Handle
stderr String
"<!> Error: Can not create --samplesFile"
Right RandomAgeSample
res -> String -> RandomAgeSample -> IO ()
randomAgeSampleToFile String
path RandomAgeSample
res
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. Maybe a -> Bool
isJust Maybe String
densityFile) forall a b. (a -> b) -> a -> b
$
String -> CalPDF -> IO ()
calPDFToFile (forall a. HasCallStack => Maybe a -> a
fromJust Maybe String
densityFile) CalPDF
calPDF
replaceEmptyNames :: [NamedCalExpr] -> [NamedCalExpr]
replaceEmptyNames :: [NamedCalExpr] -> [NamedCalExpr]
replaceEmptyNames = forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (String -> NamedCalExpr -> NamedCalExpr
modifyNamedExpr forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show) ([Integer
1..] :: [Integer])
where
modifyNamedExpr :: String -> NamedCalExpr -> NamedCalExpr
modifyNamedExpr :: String -> NamedCalExpr -> NamedCalExpr
modifyNamedExpr String
i NamedCalExpr
nexpr =
if NamedCalExpr -> String
_exprID NamedCalExpr
nexpr forall a. Eq a => a -> a -> Bool
== String
""
then NamedCalExpr
nexpr { _exprID :: String
_exprID = String
i, _expr :: CalExpr
_expr = String -> CalExpr -> CalExpr
replaceName String
i (NamedCalExpr -> CalExpr
_expr NamedCalExpr
nexpr) }
else NamedCalExpr
nexpr { _expr :: CalExpr
_expr = String -> CalExpr -> CalExpr
replaceName String
i (NamedCalExpr -> CalExpr
_expr NamedCalExpr
nexpr) }
replaceName :: String -> CalExpr -> CalExpr
replaceName :: String -> CalExpr -> CalExpr
replaceName String
i (UnCalDate (UncalC14 String
name Word
x Word
y)) =
if String
name forall a. Eq a => a -> a -> Bool
== String
""
then UncalC14 -> CalExpr
UnCalDate forall a b. (a -> b) -> a -> b
$ String -> Word -> Word -> UncalC14
UncalC14 String
i Word
x Word
y
else UncalC14 -> CalExpr
UnCalDate forall a b. (a -> b) -> a -> b
$ String -> Word -> Word -> UncalC14
UncalC14 String
name Word
x Word
y
replaceName String
i (WindowBP (TimeWindowBP String
name Word
start Word
stop)) =
if String
name forall a. Eq a => a -> a -> Bool
== String
""
then TimeWindowBP -> CalExpr
WindowBP forall a b. (a -> b) -> a -> b
$ String -> Word -> Word -> TimeWindowBP
TimeWindowBP String
i Word
start Word
stop
else TimeWindowBP -> CalExpr
WindowBP forall a b. (a -> b) -> a -> b
$ String -> Word -> Word -> TimeWindowBP
TimeWindowBP String
name Word
start Word
stop
replaceName String
i (WindowBCAD (TimeWindowBCAD String
name Int
start Int
stop)) =
if String
name forall a. Eq a => a -> a -> Bool
== String
""
then TimeWindowBCAD -> CalExpr
WindowBCAD forall a b. (a -> b) -> a -> b
$ String -> Int -> Int -> TimeWindowBCAD
TimeWindowBCAD String
i Int
start Int
stop
else TimeWindowBCAD -> CalExpr
WindowBCAD forall a b. (a -> b) -> a -> b
$ String -> Int -> Int -> TimeWindowBCAD
TimeWindowBCAD String
name Int
start Int
stop
replaceName String
i (CalDate (CalPDF String
name Vector Int
x Vector Float
y)) =
if String
name forall a. Eq a => a -> a -> Bool
== String
""
then CalPDF -> CalExpr
CalDate forall a b. (a -> b) -> a -> b
$ String -> Vector Int -> Vector Float -> CalPDF
CalPDF String
i Vector Int
x Vector Float
y
else CalPDF -> CalExpr
CalDate forall a b. (a -> b) -> a -> b
$ String -> Vector Int -> Vector Float -> CalPDF
CalPDF String
name Vector Int
x Vector Float
y
replaceName String
i (SumCal CalExpr
a CalExpr
b) = CalExpr -> CalExpr -> CalExpr
SumCal (String -> CalExpr -> CalExpr
replaceName (String
i forall a. [a] -> [a] -> [a]
++ String
"s") CalExpr
a) (String -> CalExpr -> CalExpr
replaceName (String
i forall a. [a] -> [a] -> [a]
++ String
"S") CalExpr
b)
replaceName String
i (ProductCal CalExpr
a CalExpr
b) = CalExpr -> CalExpr -> CalExpr
ProductCal (String -> CalExpr -> CalExpr
replaceName (String
i forall a. [a] -> [a] -> [a]
++ String
"p") CalExpr
a) (String -> CalExpr -> CalExpr
replaceName (String
i forall a. [a] -> [a] -> [a]
++ String
"P") CalExpr
b)