port image types to Map and remove unecessary Maybes from types

Exckel.cabal

@@ -4,7 +4,7 @@ cabal-version: 1.12
 --
 -- see: https://github.com/sol/hpack
 --
--- hash: cc6a4e593070e5b2a223056d741843c539ecfdcbc14e3385d6aeb32abbeb03bc
+-- hash: d6ac24e27399ac96323936bb6517922d5416f0349194d1474e63d73a06221c90
 
 name: Exckel
 version: 0.3.0.3
@@ -58,6 +58,7 @@ library
  , base >=4.7 && <5
  , bytestring >=0.10.8.2
  , cmdargs >=0.10.20
+ , containers >=0.6.0.1
  , directory >=1.3.3.0
  , extra >=1.6.14
  , file-embed >=0.0.11
@@ -90,6 +91,7 @@ executable exckel
  , base >=4.7 && <5
  , bytestring >=0.10.8.2
  , cmdargs >=0.10.20
+ , containers >=0.6.0.1
  , directory >=1.3.3.0
  , extra >=1.6.14
  , file-embed >=0.0.11

app/Exckel.hs

@@ -16,7 +16,7 @@ main = do
  -- Initialise all fields with environment and command line argument related stuff
  fileInfoInitial <- initialise arguments
  -- Parse and filter the excited states.
- (excitedStatesSpectrum, excitedStatesSpectrumLabel, excitedStatesAnalysis) <- getExcitedStates fileInfoInitial
+ (excitedStatesSpectrum, excitedStatesSpectrumLabel, excitedStatesAnalysis, resortMap) <- getExcitedStates fileInfoInitial
  -- Plot the spectrum
  plotSpectrum fileInfoInitial (excitedStatesSpectrum, excitedStatesSpectrumLabel)
  -- Calculate orbital cubes

package.yaml

@@ -46,6 +46,7 @@ dependencies:
  - sort >= 1.0.0.0
  - ansi-terminal >= 0.8.2
  - extra >= 1.6.14
+ - containers >= 0.6.0.1
 
 library:
  source-dirs: src

src/Exckel/CLI/CLI.hs

@@ -13,6 +13,8 @@ import Data.Attoparsec.Text
 import qualified Data.ByteString.Char8 as BS
 import qualified Data.ByteString.Lazy.Char8 as BL
 import Data.List
+import Data.Map.Strict (Map)
+import qualified Data.Map.Strict as M
 import Data.Maybe
 import qualified Data.Text as T
 import qualified Data.Text.IO as T
@@ -304,8 +306,10 @@ initialise args = do
 
 -- | Reading the log file, parsing the excited states and filtering of excited states. Returns two
 -- | lists of excited states. The first one for obtaining the spectrum, the second one labeling the
--- | spectrum and the third for analysis in the table.
-getExcitedStates :: FileInfo -> IO ([ExcState], [ExcState], [ExcState])
+-- | spectrum and the third for analysis in the table. The last return is optional and contains a
+-- | list of which old state (as from the QC output (fst)), is which new state after resorting the
+-- | energies (snd).
+getExcitedStates :: FileInfo -> IO ([ExcState], [ExcState], [ExcState], Maybe (Map Int Int))
 getExcitedStates fi = do
  -- Header of section
  logHeader "\n----"
@@ -351,6 +355,12 @@ getExcitedStates fi = do
  excitedStatesByS2Renumber = if (fi ^. stateSelection . ssRenumberAfterFilter)
  then renumberExcitedStates excitedStatesByS2
  else excitedStatesByS2
+ -- A replacement list of which old state became which new state.
+ excitedStateResortMap = if (fi ^. stateSelection . ssRenumberAfterFilter)
+ then Just $
+ M.fromList $
+ zip (map (^. nState) excitedStatesByS2) (map (^. nState) excitedStatesByS2Renumber)
+ else Nothing
  -- Filter remaining states by fitting within an energy window.
  excitedStatesByEnergy = case (fi ^. stateSelection . ssEnergyFilter) of
  Nothing -> excitedStatesByS2Renumber
@@ -387,7 +397,12 @@ getExcitedStates fi = do
  error "No excited states left for analysis."
  else return ()
 
- return (excitedStatesByS2Renumber, excitedStatesByFOsc, excitedStatesFinalFilter)
+ return
+ ( excitedStatesByS2Renumber
+ , excitedStatesByFOsc
+ , excitedStatesFinalFilter
+ , excitedStateResortMap
+ )
 
 
 
@@ -476,14 +491,15 @@ calcCDDCubes fi es = do
 
  -- Update the file info about available cubes
  existingCubes <- sortOrbCubes <$> findAllCubes (fi ^. outputPrefix)
+ -- potentially now resort the orbitals based on
  let fiWithCubes = fi & cubeFiles .~ existingCubes
 
  cubeInfo <- case (fiWithCubes ^. cddGenerator) of
  Just REPA {} -> do
  logMessage "CDD calculator" "REgular Parallel Arrays (neglecting all cross terms!)"
  logMessage "Calculating CDDs for states" (show $ map (^. nState) es)
- logMessage "Orbital cubes available" (show $ map takeFileName <$> (fiWithCubes ^. cubeFiles . orbCubes))
- logMessage "Natural orbital cubes available" (show $ map takeFileName <$> (fiWithCubes ^. cubeFiles . natOrbCubes))
+ logMessage "Orbital cubes available" (show $ map takeFileName (fiWithCubes ^. cubeFiles . orbCubes))
+ logMessage "Natural orbital cubes available" (show $ map takeFileName (fiWithCubes ^. cubeFiles . natOrbCubes))
  logInfo "Calculating CDDs in parallel using REPA. See \"REPA.log\""
  mapM_ (\s -> do
  cddTriple <- CG.Exckel.calculateCDD fiWithCubes s
@@ -536,11 +552,11 @@ doPlots fi = do
  imageInfo <- case (fiWithCubes ^. cubePlotter) of
  Just VMD {} -> do
  -- Informations about the current settings
- logMessage "Orbital cubes to plot" $ show $ map takeFileName $ fiWithCubes ^. cubeFiles . orbCubes . _Just
- logMessage "Natural orbital cubes to plot" $ show $ map takeFileName $ fiWithCubes ^. cubeFiles . natOrbCubes . _Just
- logMessage "Hole density cubes to plot" $ show $ map takeFileName $ fiWithCubes ^. cubeFiles . holeCubes . _Just
- logMessage "Electron density cubes to plot" $ show $ map takeFileName $ fiWithCubes ^. cubeFiles . electronCubes . _Just
- logMessage "CDD cubes to plot" $ show $ map takeFileName $ fiWithCubes ^. cubeFiles . cddCubes . _Just
+ logMessage "Orbital cubes to plot" $ show $ map takeFileName $ fiWithCubes ^. cubeFiles . orbCubes
+ logMessage "Natural orbital cubes to plot" $ show $ map takeFileName $ fiWithCubes ^. cubeFiles . natOrbCubes
+ logMessage "Hole density cubes to plot" $ show $ map takeFileName $ fiWithCubes ^. cubeFiles . holeCubes
+ logMessage "Electron density cubes to plot" $ show $ map takeFileName $ fiWithCubes ^. cubeFiles . electronCubes
+ logMessage "CDD cubes to plot" $ show $ map takeFileName $ fiWithCubes ^. cubeFiles . cddCubes
  logMessage "Cube plotter" $ fiWithCubes ^. cubePlotter . _Just . cpExePath
  logMessage "Cube renderer" $ fiWithCubes ^. cubePlotter . _Just . cpRenderer . rExePath
  logMessage "VMD startup file with general settings" $ fromMaybe
@@ -571,10 +587,10 @@ createSummaryDocument fi es = do
 
  logMessage "Pandoc output format" $ show (fi ^. pandocInfo . pdDocType)
  logMessage "Pandoc formatting reference document" $ show (fi ^. pandocInfo . pdRefDoc) ++ ("if \"panref.tmp\" this is the builtin default")
- logMessage "Orbital images available" $ show $ map (takeFileName . snd) (fi ^. imageFiles . orbImages . _Just)
- logMessage "Hole images available" $ show $ map (takeFileName . snd) (fi ^. imageFiles . holeImages . _Just)
- logMessage "Electron images available" $ show $ map (takeFileName . snd) (fi ^. imageFiles . electronImages . _Just)
- logMessage "CDD images available" $ show $ map (takeFileName . snd) (fi ^. imageFiles . cddImages . _Just)
+ logMessage "Orbital images available" $ show $ map (takeFileName . snd) (M.toList $ fi ^. imageFiles . orbImages)
+ logMessage "Hole images available" $ show $ map (takeFileName . snd) (M.toList $ fi ^. imageFiles . holeImages)
+ logMessage "Electron images available" $ show $ map (takeFileName . snd) (M.toList $ fi ^. imageFiles . electronImages)
+ logMessage "CDD images available" $ show $ map (takeFileName . snd) (M.toList $ fi ^. imageFiles . cddImages)
 
  let summary = excitationSummary fi es
  case (fi ^. pandocInfo . pdDocType) of

src/Exckel/CLI/SharedFunctions.hs

@@ -7,21 +7,24 @@ module Exckel.CLI.SharedFunctions
 , findAllImages
 , findAllMRCCMoldenNO
 , sortOrbCubes
+, popReplace
 ) where
 import Control.Monad
 import Data.Char
 import Data.List
 import Data.List.Extra hiding (splitOn)
 import Data.List.Split
-import Data.Maybe
+import Data.Map.Strict (Map)
+import qualified Data.Map.Strict as M
 import Exckel.Types
-import Lens.Micro.Platform
+import Lens.Micro.Platform hiding (to)
 import System.Console.ANSI
 import System.Directory
 import System.FilePath
 import System.IO
 import Text.Printf
 
+
 -- | Put an information to the screen, which displays a value
 logMessage :: String -> String -> IO ()
 logMessage f s = hPrintf stdout " %-70s : %-30s\n" f s
@@ -60,11 +63,11 @@ findAllCubes searchPath = do
  electronCubesFiles = filter (\x -> (take 8 . takeBaseName $ x) == "electron") allCubesAbs
  holeCubesFiles = filter (\x -> (take 4 . takeBaseName $ x) == "hole") allCubesAbs
  return CubeFiles
- { _orbCubes = Just orbCubesFiles
- , _natOrbCubes = Just natOrbCubeFiles
- , _cddCubes = Just cddCubesFiles
- , _electronCubes = Just electronCubesFiles
- , _holeCubes = Just holeCubesFiles
+ { _orbCubes = orbCubesFiles
+ , _natOrbCubes = natOrbCubeFiles
+ , _cddCubes = cddCubesFiles
+ , _electronCubes = electronCubesFiles
+ , _holeCubes = holeCubesFiles
  }
 
 -- | Look for all image files in the directory
@@ -94,17 +97,17 @@ findAllImages searchPath = do
  electronFileNumbers = map ((read :: String -> Int) . drop 8 . takeBaseName) $ electronImageFiles
  holeFileNumbers = map ((read :: String -> Int) . drop 4 . takeBaseName) $ holeImageFiles
  --
- orbImageFilesIndexed = zip orbFileNumbers orbImageFiles
- natOrbImageFilesIndexed = zipWith (\(sN, oN) im -> (sN, oN, im)) natOrbNumbers natOrbImageFiles
- cddImageFilesIndexed = zip cddFileNumbers cddImageFiles
- electronImageFilesIndexed = zip electronFileNumbers electronImageFiles
- holeImageFilesIndexed = zip holeFileNumbers holeImageFiles
+ orbImageFilesIndexed = M.fromList $ zip orbFileNumbers orbImageFiles
+ natOrbImageFilesIndexed = M.fromList $ zip natOrbNumbers natOrbImageFiles
+ cddImageFilesIndexed = M.fromList $ zip cddFileNumbers cddImageFiles
+ electronImageFilesIndexed = M.fromList $ zip electronFileNumbers electronImageFiles
+ holeImageFilesIndexed = M.fromList $ zip holeFileNumbers holeImageFiles
  return ImageFiles
- { _orbImages = Just orbImageFilesIndexed
- , _natOrbImages = Just natOrbImageFilesIndexed
- , _cddImages = Just cddImageFilesIndexed
- , _electronImages = Just electronImageFilesIndexed
- , _holeImages = Just holeImageFilesIndexed
+ { _orbImages = orbImageFilesIndexed
+ , _natOrbImages = natOrbImageFilesIndexed
+ , _cddImages = cddImageFilesIndexed
+ , _electronImages = electronImageFilesIndexed
+ , _holeImages = holeImageFilesIndexed
  }
 
 -- | In a given directory (outdir) look for all natural orbital files of a MRCC calculation with
@@ -139,14 +142,14 @@ findAllMRCCMoldenNO outdir = do
 -- | more helpful order in the output document.
 sortOrbCubes :: CubeFiles -> CubeFiles
 sortOrbCubes cf = cf
- & orbCubes .~ Just orbitalsSorted
- & natOrbCubes .~ Just naturalOrbitalsSorted
+ & orbCubes .~ orbitalsSorted
+ & natOrbCubes .~ naturalOrbitalsSorted
  where
- orbitals = fromMaybe [] $ cf ^. orbCubes
+ orbitals = cf ^. orbCubes
  orbitalIndices = map ((read :: String -> Int) . drop 3 . takeBaseName) $ orbitals
  orbitalsIndexed = zip orbitalIndices orbitals
  orbitalsSorted = map snd . sortOn fst $ orbitalsIndexed
- naturalOrbitals = fromMaybe [] $ cf ^. natOrbCubes
+ naturalOrbitals = cf ^. natOrbCubes
  naturalOrbitalsIndices =
  map (
  (\[_, state, orb] -> ((read :: String -> Int) state, (read :: String -> Int) orb)) .
@@ -162,3 +165,53 @@ sortOrbCubes cf = cf
  groupOn (^. _1 . _1) .
  sortOn (^. _1 . _1) $
  naturalOrbitalsIndexed
+
+-- | In case the order of excited states has changed because of renumbering of them, this function
+-- | takes care of changing the ImageFiles type, so that the renumbered images are linked with the
+-- | images which are on file system level with the old states. The first argument is a replacement
+-- | list of old state numbers and new state numbers.
+{-
+linkRenameImages :: Map Int Int -> ImageFiles -> ImageFiles
+linkRenameImages rMap images = images
+ & natOrbImages . _1 .~ natOrbsStateNew
+ & holeImages . _1 .~ holeIndsNew
+ & electronImages . _1 .~ electronIndsNew
+ &
+ where
+ -- Get state numbers from all relevant image types.
+ natOrbsStateInds = images ^. natOrbImages . _1
+ holeInds = images ^. holeImages . _1
+ electronInds = images ^. electronImages . _1
+ cddInds = images ^. cddInds . _1
+ -- Assign new state numbers
+ natOrbsStateNew = popReplace rMap natOrbsStateInds
+ holeIndsNew = popReplace rMap holeInds
+ electronIndsNew = popReplace rMap electronInds
+ cddIndsNew = popReplace rMap cddInds
+-}
+
+-- | Replace patterns in a list without duplication issues. This avoids issues with possible
+-- | duplicate keys by accepting only Map as input. Keeps the original order of the input list
+-- | otherwise.
+popReplace :: (Eq a, Ord a) => Map a a -> [a] -> [a]
+popReplace rMap oldList =
+ [ joinReplaceColumn (map (!! i) singlySubstLists)
+ | i <- [0 .. length oldList - 1]
+ ]
+ where
+ -- Convert the lookup map to a list of tuples.
+ rList = M.toList rMap
+ -- Given a single substitution, look for the search pattern in list A. If it is found there, write
+ -- append the result of the substitution to an accumulator list B.
+ popReplaceElementsAug :: Eq a => (a, a) -> [a] -> [(Bool, a)]
+ popReplaceElementsAug (from, to) oL =
+ reverse $ foldl (\acc x -> if x == from then (True, to):acc else (False, x):acc) [] oL
+ -- Multiple original lists, each with a single replacement are calculated. Each element is
+ -- now augmented with a True if it has been replaced or a False if not. It will then join the
+ -- lists again so that all replacements are available in the final result.
+ joinReplaceColumn :: [(Bool, a)] -> a
+ joinReplaceColumn r = if all (\(b, _) -> b == False) r
+ then snd . head $ r
+ else snd . head . filter (\(b, _) -> b == True) $ r
+ -- Versions of the original list, where one replacement each has been performed.
+ singlySubstLists = zipWith (\r l -> popReplaceElementsAug r l) rList (repeat oldList)

src/Exckel/CmdArgs.hs

@@ -149,6 +149,5 @@ exckelArgs = ExckelArgs
  , renumberStates = False
  &= help "Renumber the states (energy order), after high spin multiplicities have been removed by \"--s2filter\"."
  &= typ "BOOL"
-
  } &= summary "The Exckel automatic summary programm"
  &= help "Available command line arguments. At least \"--wf\" and \"--exc\" must be specified."

src/Exckel/CubeGenerator/Exckel.hs

@@ -197,8 +197,8 @@ calculateCDD fi eS
  -- All orbitals constructing the CI wavefunction
  requiredOrbs = sort . getOrbNumbers $ eS
  -- All orbitals FilePaths available on disk as cubes
- availableCanOrbsFiles = (fromMaybe [] $ fi ^. cubeFiles . orbCubes)
- availableNatOrbsFiles = (fromMaybe [] $ fi ^. cubeFiles . natOrbCubes)
+ availableCanOrbsFiles = (fi ^. cubeFiles . orbCubes)
+ availableNatOrbsFiles = (fi ^. cubeFiles . natOrbCubes)
  -- All orbitals by their number as written to a molden file.
  availableCanOrbs =
  sort .

src/Exckel/CubePlotter/VMD.hs

@@ -12,7 +12,6 @@ module Exckel.CubePlotter.VMD
 import Control.Monad.Identity
 import Data.Attoparsec.Text
 import qualified Data.HashMap.Lazy as H
-import Data.Maybe
 import qualified Data.Text as T
 import qualified Data.Text.IO as T
 import Exckel.Parser
@@ -130,11 +129,11 @@ plotCubes fi = do
  vmdOutDir = fi ^. outputPrefix
  tachyonInputs =
  (map ((++ ".dat") . T.unpack) . getBaseNames . concat) $
- [ fromMaybe [] $ fi ^. cubeFiles . orbCubes
- , fromMaybe [] $ fi ^. cubeFiles . natOrbCubes
- , fromMaybe [] $ fi ^. cubeFiles . cddCubes
- , fromMaybe [] $ fi ^. cubeFiles .electronCubes
- , fromMaybe [] $ fi ^. cubeFiles . holeCubes
+ [ fi ^. cubeFiles . orbCubes
+ , fi ^. cubeFiles . natOrbCubes
+ , fi ^. cubeFiles . cddCubes
+ , fi ^. cubeFiles .electronCubes
+ , fi ^. cubeFiles . holeCubes
  ]
  resX = fst $ cubePlotterVMD ^. cpRenderer . rResolution
  resY = snd $ cubePlotterVMD ^. cpRenderer . rResolution
@@ -159,11 +158,11 @@ substitueTemplate fi = do
  viewpoint = ("set viewpoints" `T.append`) <$> stateParsed
 
  -- get basenames of all cubes
- let orbitalBaseNames = toTclList $ getBaseNames <$> (fi ^. cubeFiles . orbCubes)
- natOrbBaseNames = toTclList $ getBaseNames <$> (fi ^. cubeFiles . natOrbCubes)
- cddBaseNames = toTclList $ getBaseNames <$> (fi ^. cubeFiles . cddCubes)
- electronBaseNames = toTclList $ getBaseNames <$> (fi ^. cubeFiles . electronCubes)
- holeBaseNames = toTclList $ getBaseNames <$> (fi ^. cubeFiles . holeCubes)
+ let orbitalBaseNames = toTclList $ getBaseNames (fi ^. cubeFiles . orbCubes)
+ natOrbBaseNames = toTclList $ getBaseNames (fi ^. cubeFiles . natOrbCubes)
+ cddBaseNames = toTclList $ getBaseNames (fi ^. cubeFiles . cddCubes)
+ electronBaseNames = toTclList $ getBaseNames (fi ^. cubeFiles . electronCubes)
+ holeBaseNames = toTclList $ getBaseNames (fi ^. cubeFiles . holeCubes)
 
  -- key value map for substitutions by Ginger as Map
  let context = H.fromList
@@ -196,10 +195,8 @@ getBaseNames :: [FilePath] -> [T.Text]
 getBaseNames = map (T.pack . fst . splitExtension)
 
 -- | Convert a list of basenames to a single string for the "foreach" loop in the tcl script
-toTclList :: Maybe [T.Text] -> T.Text
-toTclList s = case s of
- Just x -> T.concat . map (`T.append` " ") $ x
- Nothing -> ""
+toTclList :: [T.Text] -> T.Text
+toTclList s = T.concat . map (`T.append` " ") $ s
 
 -- | Delete Nth element from a list
 deleteNth :: Int -> [a] -> [a]