colors, orbits and valence

chem-formula.cabal

@@ -24,6 +24,7 @@ library
     , Chemistry.Isotope
     , Chemistry.Orbit
     , Chemistry.Parser
+    , Chemistry.Valence
   build-depends:
       base >= 4.7 && < 5
     , blaze-markup >=0.5
@@ -33,7 +34,7 @@ library
     , dimensional >=1.3
     , hashable >=1.2
     , parsec >=3.0
-    , QuickCheck >=2.13 && <2.14
+    , QuickCheck >=2.13 && <2.15
     , template-haskell >=2.2
     , text >=1.1 && <2.1
     , unicode-tricks >=0.6.1.0

src/Chemistry/Element.hs

@@ -264,8 +264,8 @@ symbol :: Element -- ^ The given element for which we want to obtain the symbol.
 symbol = show
 
 withElementColorS :: Element -> ShowS -> ShowS
-withElementColorS el f = (("\x1b[38;2" ++ r ++ g ++ b ++ "m") ++) . f . ("\x1b[0m"++)
-  where ~(RGB r g b) = (';':) . show <$> toSRGB24 (elementCPK el)
+withElementColorS el f = ("\x1b[38;2" ++) . r . g . b . ('m' :) . f . ("\x1b[0m"++)
+  where ~(RGB r g b) = (++) . (';':) . show <$> toSRGB24 (elementCPK el)
 
 
 symbolColoured :: Element -> String

src/Chemistry/Orbit.hs

@@ -1,31 +1,55 @@
+{-# LANGUAGE OverloadedStrings #-}
+
 module Chemistry.Orbit where
 
-import Data.List.NonEmpty(NonEmpty)
+import Control.Monad.Zip(mzipWith)
+import Data.List(sort)
+import Data.List.NonEmpty(NonEmpty((:|)))
+import Data.Char.Small(asSup)
+import Data.Foldable(toList)
+import qualified Data.Text as T
+import Data.Text(Text, pack, toLower)
 
 data Orbit = S | P | D | F | G deriving (Enum, Eq, Ord, Read, Show)
+data OrbitElement = OrbitElement Int Orbit Int deriving (Eq, Ord, Read, Show)
 newtype OrbitalConfig = OrbitalConfig (NonEmpty (NonEmpty Int)) deriving (Eq, Ord, Read, Show)
 
+orbitElementToText :: OrbitElement -> Text
+orbitElementToText (OrbitElement i o n) = pack (show i) <> toLower (pack (show o)) <> asSup n
+
+orbitConfigs :: OrbitalConfig -> NonEmpty (NonEmpty OrbitElement)
+orbitConfigs (OrbitalConfig es) = mzipWith ((`mzipWith` (S :| [P ..])) . OrbitElement) (1 :| [2..]) es
+
+orbitElement :: Foldable f => f OrbitElement -> OrbitalConfig
+orbitElement _ = OrbitalConfig ((0 :| []) :| [])
+
+orbitalConfigToText :: OrbitalConfig -> Text
+orbitalConfigToText = T.unwords . toList . fmap (T.unwords . toList . fmap orbitElementToText) . orbitConfigs
+
 totalElectrons :: OrbitalConfig -> Int
 totalElectrons (OrbitalConfig vs) = sum (fmap sum vs)
 
-toArrowText :: Int -> Int -> String
-toArrowText n k = concat (replicate f "\8645\8414" ++ [ "\8593\8414" | h == 1 ] ++ replicate ((maxElectronsForOrbit' n `div` 2) - f - h) " \8414")
-  where ~(f, h) = k `divMod` 2
+toArrowText :: OrbitElement -> String
+toArrowText (OrbitElement m n k) = "" -- concat (replicate f "\8645\8414" ++ [ "\8593\8414" | h == 1 ] ++ replicate ((maxElectronsForOrbit' n `div` 2) - f - h) " \8414")
+  -- where ~(f, h) = k `divMod` 2
+
+_orbitPlaces :: Int -> Int
+_orbitPlaces = (1+) . (2*)
 
 maxElectronsForOrbit' :: Int -> Int
-maxElectronsForOrbit' = (2+) . (4*)
+maxElectronsForOrbit' = (2*) . _orbitPlaces
 
 maxElectronsForOrbit :: Orbit -> Int
 maxElectronsForOrbit = maxElectronsForOrbit' . fromEnum
 
-electronsToOrbitals :: Int -> [(Int, Orbit, Int)]
-electronsToOrbitals = fill 0 0
+electronsToOrbitals' :: Int -> [OrbitElement]
+electronsToOrbitals' = fill 1 0
   where fill _ _ 0 = []
-        fill m 0 k = (m+1, S, d) : fill (m - (m-1) `div` 2) ((m+1) `div` 2) (k-d)
+        fill m 0 k = OrbitElement m S d : fill (m - dm + 1) dm (k-d)
           where d = min 2 k
-        fill m n k = (m+1, toEnum n, d) : fill (m+1) (n-1) (k-d)
+                dm = m `div` 2
+        fill m n k = OrbitElement m (toEnum n) d : fill (m+1) (n-1) (k-d)
           where d = min (maxElectronsForOrbit' n) k
 
--- electronsPerShell :: Element -> [Int]
--- electronsPerShell = map sum . molecularOrbital
-
+electronsToOrbitals :: Int -> [OrbitElement]
+electronsToOrbitals = sort . electronsToOrbitals'

src/Chemistry/Parser.hs

@@ -51,7 +51,7 @@ import Text.Parsec.Char(digit, char)
 _grouping :: Eq b => (a -> b) -> [a] -> [(b, [a])]
 _grouping f = go
     where go [] = []
-          go ~(x:xs) = (fx, x : ys) : go zs
+          go (x:xs) = (fx, x : ys) : go zs
               where ~(ys, zs) = span ((fx ==) . f) xs
                     fx = f x
 
@@ -164,7 +164,7 @@ formulaParser' :: Stream s m Char
 formulaParser' el = go'
     where go' = go <$> formulaPartParser' el <*> optionMaybe (formulaParser' el)
           go fp Nothing = FormulaPart fp
-          go fp ~(Just t) = fp :- t
+          go fp (Just t) = fp :- t
 
 -- | A function that produces a parser that parses a 'LinearChain' that makes
 -- use of given parsers to parse the bonds and the items in the linear chain.
@@ -175,7 +175,7 @@ linearChainParser'' :: Stream s m t
 linearChainParser'' bo el = go'
     where go' = go <$> el <*> optionMaybe ((,) <$> bo <*> go')
           go fp Nothing = ChainItem fp
-          go fp ~(Just be) = uncurry (Chain fp) be
+          go fp (Just be) = uncurry (Chain fp) be
 
 _parsing :: (a -> Q b) -> ParsecT String () Identity a -> String -> Q b
 _parsing f p s = either (fail . show) f (runP p () s s)

src/Chemistry/Valence.hs

@@ -0,0 +1,17 @@
+module Chemistry.Valence where
+
+import Chemistry.Element(Element(B, C, N, O, P, S, F, Cl, Br, I, At))
+
+smilesValence :: Element -> [Int]
+smilesValence B = [3]
+smilesValence C = [4]
+smilesValence N = [3,5]
+smilesValence O = [2]
+smilesValence P = [3,5]
+smilesValence S = [2,4,6]
+smilesValence F = [1]
+smilesValence Cl = [1]
+smilesValence Br = [1]
+smilesValence I = [1]
+smilesValence At = [1]
+smilesValence _ = []