{-

Electron configuration of elements, assuming the Madelung rule is true.

Copyright 2019 Ken Takusagawa

This program is free software: you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation, either version 3 of the License, or (at
your option) any later version.

This program is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
General Public License for more details.

You should have received a copy of the GNU General Public License
along with this program.  If not, see
<http://www.gnu.org/licenses/>.

-}
{-# LANGUAGE ScopedTypeVariables, LambdaCase, PackageImports #-}
-- ghc -Wall -package extra -c electronorbitals.hs
module Main where {
import System.Environment(getArgs);
import Control.Exception(assert);
import Debug.Trace(trace);
import Data.Function((&));
import Control.Category((>>>));
import Prelude hiding((.),(>>));
--import System.IO(hSetBuffering,stdout,BufferMode(LineBuffering));
--import System.IO(stderr,hPutStrLn);
import qualified Data.List as List;
import qualified Control.Monad as Monad;
import Control.Monad(MonadPlus(mzero));
import qualified Data.Maybe as Maybe;
-- import Data.Maybe(fromMaybe);
--import qualified Data.Map as Map; import Data.Map(Map);
--import qualified Data.Set as Set; import Data.Set(Set);
--import qualified Data.Bifunctor as Bifunctor;
--import qualified Data.Tuple as Tuple;
import Data.Ratio((%));
import "extra" Data.List.Extra(groupOn);
import "regex-compat-tdfa" Text.Regex as Regex(mkRegex, subRegex, Regex); -- regex-compat also works.
import qualified Data.Char as Char;
type Ii = Integer;

-- to avoid the redundancy warning
trace_placeholder :: ();
trace_placeholder = (trace,assert) & (id >>> error) "trace_placeholder";

main :: IO();
main = getArgs >>= \case{
["one",z] -> element $ Zatomicnumber $ read z;
["subshelloverflow"] -> filter zhas21 allz & head & showz & putStrLn;  -- print element number where we run out of subshell letters
["noble"] -> filter isnoble allz & mapM_ (showz >>> putStrLn);
[] -> mapM_ element allz;
_ -> undefined;
};

newtype Nquantumnumber = Nquantumnumber Ii deriving (Show, Ord, Eq);
newtype Lsubshell = Lsubshell Ii deriving (Show, Ord, Eq);
data Spin = Spin Rational deriving (Show);
newtype Zatomicnumber = Zatomicnumber Ii deriving (Eq);

electronspin :: Rational;
electronspin = 1%2;

allspins :: [Spin];
allspins = enumFromTo (negate electronspin) electronspin & map Spin;

-- currently do not need a data type for the magnetic quantum number m

capacity :: Lsubshell -> Ii;
-- a shortcut for this is 2*(2*l+1), but this is more principled.
capacity (Lsubshell l) = List.genericLength $ do {
s <- allspins;
m <- enumFromTo (negate l) l;
return (s,m);
};


allsubshellsnl :: Ii -> [(Nquantumnumber, Lsubshell)];
allsubshellsnl n_plus_l = do {
-- because we do these in this order, lower n are preferred first.
n <- [1 .. n_plus_l];
let {
l = n_plus_l - n;
};
assert (0 <= l) $ return ();
Monad.guard $ l < n;
return (Nquantumnumber n, Lsubshell l);
};

allsubshells :: [(Nquantumnumber, Lsubshell)];
allsubshells = concatMap allsubshellsnl [0..];

-- fails at l=21, or element 13245
subshellnames :: [String];
subshellnames = map return $ "spd" ++ (enumFrom 'f' & filter (\c -> not $ elem c "jspd" ));

getsubshellname :: Lsubshell -> String;
getsubshellname (Lsubshell x) = List.genericIndex subshellnames x;

orbitalname :: (Nquantumnumber, Lsubshell) -> String;
orbitalname (Nquantumnumber n, l) = show n ++ getsubshellname l;

type Orbital = (Nquantumnumber, Lsubshell);

assignorbital :: (Ii,[Orbital]) -> Maybe ((Orbital,Ii),(Ii,[Orbital]));
assignorbital (z,orbitals) =
let {
l :: Lsubshell;
l = orbitals & head & snd;
numassigned = min z (capacity l) }
in Just $
((head orbitals, numassigned),(z - numassigned, tail orbitals));

usedsubshell :: (a,Ii) -> Bool;
usedsubshell (_,x) = x>0;

-- infinite trailing list of subshells with zero electrons
assignelectrons0 :: Zatomicnumber -> [(Orbital,Ii)];
assignelectrons0 z = List.unfoldr assignorbital (unz z,allsubshells);

assignelectrons :: Zatomicnumber -> [(Orbital,Ii)];
assignelectrons = assignelectrons0 >>> takeWhile usedsubshell;

getn :: (Orbital, Ii) -> Nquantumnumber;
getn = fst >>> fst;

assignelectronsfullshell :: Zatomicnumber -> [(Orbital,Ii)];
assignelectronsfullshell z = let {
assignment :: [(Orbital,Ii)];
assignment = assignelectrons0 z;
maxn :: Nquantumnumber;
maxn = periodshell assignment;
} in takeWhile (\x -> getn x <= maxn) assignment;

periodshell :: [(Orbital,Ii)] -> Nquantumnumber;
periodshell = takeWhile usedsubshell >>> map getn >>> maximum;

traditionalprint :: (Orbital,Ii) ->String;
traditionalprint (o,i) = orbitalname o ++ "^" ++ show i;

showwithbar :: Zatomicnumber -> ((Orbital,Ii) -> String) -> String;
showwithbar z printfunction = let {
(inner,outer) = splitinnerandoutershells z;
} in (map printfunction inner & unwords) ++" | "++ (map printfunction outer & unwords);

showz :: Zatomicnumber -> String;
showz (Zatomicnumber z) = "Z = " ++ show z;

element :: Zatomicnumber -> IO();
element z = do { putStrLn $ showz z
++ " : " ++ elname z
++ " : " ++ symboln z
++ " : " ++ systematicname z
++ " : " ++ systematicsymbol z
++ " : " ++ compacttraditionalwithbar z
++ " : " ++ showwithbar z longprint
++ " : " ++ (valence z & showvalence)
;
};

compacttraditionalwithbar :: Zatomicnumber -> String;
compacttraditionalwithbar z = let {
(inner, outer) = splitinnerandoutershells z;
} in (map traditionalprint inner & unwords) ++ " | " ++ (outer & takeWhile usedsubshell & map traditionalprint & unwords);

nshow :: Nquantumnumber -> String;
nshow (Nquantumnumber n) = "n = " ++ show n;

lshow :: Lsubshell -> String;
lshow (Lsubshell l) = "l = " ++ show l;

longprint :: ((Nquantumnumber, Lsubshell), Ii) -> String;
longprint ((n,l), electrons) = "( " ++ nshow n ++ " , " ++ lshow l ++  " , " ++ show electrons ++ " / " ++ show (capacity l)++ " )";

groupbyshell :: [(Orbital,Ii)] -> [[(Orbital,Ii)]];
groupbyshell oi = let {
-- the current subshell and all the shells within it
y :: [((Orbital,Ii),[(Orbital,Ii)])];
y = zip oi (List.inits oi & tail);
z :: [[((Orbital,Ii),[(Orbital,Ii)])]];
z = groupOn (snd >>> periodshell) y;
} in map (map fst) z;

valencecalc :: [(Orbital,Ii)] -> (Ii,Ii);
valencecalc x = (List.foldl' positivevalence 0 x, List.foldl' negativevalence 0 x);

valence :: Zatomicnumber -> (Ii,Ii);
valence = valenceshell >>> valencecalc;

splitinnerandoutershells :: Zatomicnumber -> ([(Orbital,Ii)],[(Orbital,Ii)]);
splitinnerandoutershells z = let {
grouped = assignelectronsfullshell z & groupbyshell;
} in (init grouped & concat, last grouped);

valenceshell :: Zatomicnumber -> [(Orbital,Ii)];
valenceshell = splitinnerandoutershells >>> snd;

positivevalence :: Ii -> (Orbital,Ii) -> Ii;
positivevalence accum (_,x) = accum + x;

negativevalence :: Ii -> (Orbital,Ii) -> Ii;
negativevalence accum ((_,l),x) = accum + (capacity l) - x;

-- noble gas is a gas one before a alkali metal

isnoble :: Zatomicnumber -> Bool;
isnoble = valence >>> snd >>> (== 0);

showvalence :: (Ii,Ii) -> String;
showvalence (positive, negative) = "noble +"++show positive ++" -"++ show negative;

elementlist :: [(Zatomicnumber,String)];
elementlist = zip allz $ words "hydrogen helium lithium beryllium boron carbon nitrogen oxygen fluorine neon sodium magnesium aluminum silicon phosphorus sulfur chlorine argon potassium calcium scandium titanium vanadium chromium manganese iron cobalt nickel copper zinc gallium germanium arsenic selenium bromine krypton rubidium strontium yttrium zirconium niobium molybdenum technetium ruthenium rhodium palladium silver cadmium indium tin antimony tellurium iodine xenon cesium barium lanthanum cerium praseodymium neodymium promethium samarium europium gadolinium terbium dysprosium holmium erbium thulium ytterbium lutetium hafnium tantalum tungsten rhenium osmium iridium platinum gold mercury thallium lead bismuth polonium astatine radon francium radium actinium thorium protactinium uranium neptunium plutonium americium curium berkelium californium einsteinium fermium mendelevium nobelium lawrencium rutherfordium dubnium seaborgium bohrium hassium meitnerium darmstadtium roentgenium copernicium nihonium flerovium moscovium livermorium tennessine oganesson";

-- https://sciencenotes.org/PDFs/elementlist.csv

-- 119 ununennium
--120 unbinilium

elname :: Zatomicnumber -> String;
elname = lookupm elementlist;

iregex :: Regex;
iregex = mkRegex "ii";

nregex :: Regex;
nregex = mkRegex "nnn";

fixupsystematic :: String -> String;
fixupsystematic s = subRegex nregex (subRegex iregex s "i") "nn";

-- https://en.wikipedia.org/wiki/Systematic_element_name

systematicroots :: [(Ii,String)];
systematicroots = "nil un bi tri quad pent hex sept oct enn" & words & zip [0..];

getsystematicroot :: Char -> String;
getsystematicroot d = List.lookup (read [d]) systematicroots & Maybe.fromJust;

unz :: Zatomicnumber -> Ii;
unz (Zatomicnumber z) = z;

systematicname :: Zatomicnumber -> String;
systematicname = unz >>> show >>> map getsystematicroot >>> concat >>> (\x -> x ++ "ium") >>> fixupsystematic;

systematicsymbol :: Zatomicnumber -> String;
systematicsymbol = unz >>> show >>> map getsystematicroot >>> map head >>> capitalize;

capitalize :: String -> String;
capitalize (h:t) = (Char.toUpper h):t;
capitalize _ = "";

allz :: [Zatomicnumber];
allz = map Zatomicnumber [1..];

symbollist :: [(Zatomicnumber,String)];
symbollist = zip allz $ words "H He Li Be B C N O F Ne Na Mg Al Si P S Cl Ar K Ca Sc Ti V Cr Mn Fe Co Ni Cu Zn Ga Ge As Se Br Kr Rb Sr Y Zr Nb Mo Tc Ru Rh Pd Ag Cd In Sn Sb Te I Xe Cs Ba La Ce Pr Nd Pm Sm Eu Gd Tb Dy Ho Er Tm Yb Lu Hf Ta W Re Os Ir Pt Au Hg Tl Pb Bi Po At Rn Fr Ra Ac Th Pa U Np Pu Am Cm Bk Cf Es Fm Md No Lr Rf Db Sg Bh Hs Mt Ds Rg Cn Nh Fl Mc Lv Ts Og";

lookupm :: (Eq a, Monad m, MonadPlus m) => [(a,m b)] -> a -> m b;
lookupm l x = case List.lookup x l of {
Just y -> y;
Nothing -> mzero;
};

symboln :: Zatomicnumber -> String;
symboln = lookupm symbollist;

-- subshell beyond "z";  l = 21
hasl :: Lsubshell -> (Orbital,Ii) -> Bool;
hasl target ((_,l), count) = l >= target && count >0;

zhas21 :: Zatomicnumber -> Bool;
zhas21 = assignelectrons >>> any (hasl (Lsubshell 21));

} --end