{-

How to make Roman Numerals worse than they already are.
http://kenta.blogspot.com/search?q=bvpqwmoh

Copyright 2020 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 #-}
module Main(main, trace_placeholder) where {
import System.Environment(getArgs);
import Control.Exception(assert);
import Debug.Trace(trace);
import Data.Function((&));
import Control.Category((>>>));
import Prelude hiding((.),(>>));
--import qualified Prelude;
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(guard);
import qualified Data.Maybe as Maybe;
--import qualified Data.Map as Map; import Data.Map(Map);
import qualified Data.IntMap.Strict as IntMap; import Data.IntMap.Strict(IntMap);
import qualified Data.IntSet as IntSet; import Data.IntSet(IntSet);
--import qualified Data.Set as Set; import Data.Set(Set);
--import qualified Data.Bifunctor as Bifunctor;
import qualified Data.Tuple as Tuple;
import qualified Data.Char as Char;
import Data.Ord(comparing);
import Control.Applicative(Alternative);
import Data.MemoTrie(memoFix);
-- import Data.Function.Memoize(memoFix);
-- Data.MemoTrie is faster than Data.Function.Memoize
import Control.Monad.Identity(runIdentity);

type Ii = Integer;

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

main :: IO();
main = do {
hSetBuffering stdout LineBuffering;
getArgs >>= \case{
-- value of a Worse Roman Numeral given on the command line
["value",s] -> roman s & print;
-- all length-n Worse Roman Numerals
["dump",n] -> allnletter (read n) & mapM_ (\s -> putStrLn $ show (roman s) ++ " " ++ s);
-- stats about all length-n Worse Roman Numerals
["stats",n] -> allnletter (read n) & stats;
-- Worse Roman Numerals whose value is equal to a number given on the command line
["match",n] -> matchnum (read n) & mapM_ putStrLn;
-- Shortest representation of all integers, starting at 0.
["all"] -> mapM_ dumppair pairsshortest;
["oneshort"] -> mapM_ print pairsone;

["negrange",n] -> enumFromThen 0 (negate 1) & lastofrange (manysizes (read n)) & print;
["posrange",n] -> enumFrom 1 & lastofrange (manysizes (read n)) & print;
-- still has a space leak
["growing",n] -> state0 & List.unfoldr ufunc & take (read n) & mapM_ dump1;
["worstcase"] -> mapM_ (\(a,b) -> [show b,a] & unwords & putStrLn) worstcase;
["worstcase2"] -> worstcase & mapM_ (snd >>> print);
["worstcase2",n] -> worstcase & drop (read n) & mapM_ (snd >>> print);
["worstcase1",n] -> (worstcase !! (read n)) & snd & print;

-- values of all Worse Roman Numerals given on the command line
decodemany -> mapM_ (roman >>> print) decodemany;
};
};

romanvals :: [Ii];
romanvals = 1:5:map ((*)10) romanvals;

romanchars :: [(Char,Ii)];
--romanchars = reverse $ zip "IVXLCDMABEFGHJK"
romanchars = reverse $ zip "IVXLCDM" romanvals ;
-- needs "reverse" because breakm process them in this order

-- placeholders for larger roman characters, not what is actually used.
romancharslong :: [(Char,Ii)];
romancharslong = runIdentity $ do {
ivx <- map fst romanchars & reverse & pure;
abd <- pure $ (List.\\) ['A'..'Z'] ivx;
zip (ivx ++ abd) romanvals & reverse & return;
};

breakm :: (Eq a) => a -> [a] -> ([[a]],[a]);
breakm c l = case break ((==)c) l of {
(before,[]) -> ([],before);
(before,(h:t)) -> assert (h==c) $
case breakm c t of {
-- "reverse before" just to make things more confusing
--(pc,rest) -> (reverse before:pc,rest)
(pc,rest) -> (before:pc,rest)
}};


-- does not consume huge memory when searching for matches
valueunmemoized :: forall a . (Eq a) => ([a] -> String) -> [(a,Ii)] -> [a] -> Ii;
valueunmemoized _ [] [] = 0;
valueunmemoized showerror [] cs = error $ "wrong characters: '"++showerror cs++"'";
valueunmemoized showerror ((h,hval):rest) s = case breakm h s of {
(subtracts :: [[a]], add :: [a]) -> valueunmemoized showerror rest add + 
 (combinesubtractsstraight subtracts & map (valueunmemoized showerror rest) & noncarry hval)
};

-- make non-polymorphic for simplicity of memoizing
valuememoized :: [(Char,Ii)] -> String -> Ii;
valuememoized [] [] = 0;
valuememoized [] cs = error $ "wrong characters: '"++ cs ++"'";
valuememoized hh@((h,_):rest) s = case filter ((==) h) s of {
[] -> valuememoized rest s;
_ -> actualcompute hh s;
};

actualcompute :: [(Char,Ii)] -> String -> Ii;
actualcompute hh instr = memoFix ac (hh,instr) where {
ac :: (([(Char, Ii)], String) -> Ii) -> ([(Char, Ii)], [Char]) -> Ii;
ac recursivecall hhs = case hhs of {
([],[]) -> 0;
([],_) -> error "wrong characters actualcompute";
((h,hval):rest,s) -> case breakm h s of {
(subtracts :: [String], add :: String) -> recursivecall (rest,add) +
 (combinesubtractsstraight subtracts & map (\x -> recursivecall (rest,x)) & noncarry hval);
}}};


combinesubtractsstraight :: [[a]] -> [[a]];
combinesubtractsstraight = scanl (++) [] >>> tail;

-- do subtractions
noncarry :: Ii -> [Ii] -> Ii;
noncarry big = map (\x -> big - x) >>> sum;

roman :: String -> Ii;
roman = map Char.toUpper >>> valueunmemoized id romanchars;

romanmemoized :: String -> Ii;
romanmemoized = map Char.toUpper >>> valuememoized romancharslong;

stats :: [String] -> IO ();
stats l = do {
putStrLn $ "length " ++ show (length l);
List.minimumBy (comparing roman) l & showstat "min";
List.maximumBy (comparing roman) l & showstat "max";
putStrLn $ "sum " ++ (map roman l & sum & show);
putStrLn $ "sumsq " ++ (map roman l & map (\x -> x*x) & sum & show);
};

showstat :: String -> String -> IO ();
showstat title x = putStrLn $ title ++ " " ++ x ++ " = " ++ show (roman x);

allnletter :: Int -> [String];
allnletter n = Monad.replicateM n (map fst romanchars );

allnumbers :: [String];
allnumbers = concatMap allnletter [1..];

matchnum :: Ii -> [String];
matchnum n = filter (\x -> n == roman x) allnumbers;

shortestofnum :: Ii -> [String];
shortestofnum n = map allnletter [1..] & map (filter $ \x -> n == roman x) & filter (null >>> not) & head & List.sortBy compareroman;

oneshortest :: Ii -> String;
oneshortest n = allnumbers & filter (\x -> n == roman x) & head;

zipmap :: (a -> b) -> [a] -> [(a,b)];
zipmap f = map (\x -> (x, f x));

pairsshortest :: [(Ii,[String])];
pairsshortest = zipmap shortestofnum allnums;

pairsone :: [(Ii,String)];
pairsone = zipmap oneshortest allnums;

allnums :: [Ii];
allnums = 0:do{
n <- [1..];
[n, negate n];
};

onesizemap :: Int -> IntMap [String];
onesizemap size = IntMap.fromListWith combinec $ do {
r <- allnletter size;
v <- safeint $ roman r;
-- in hopes of saving memory, but it does not work
guard $ v < 4000;
guard $ (negate 4000) < v;
return (v,[r]);
};

combinec :: [String] -> [String] -> [String];
-- combine [x] y = x:y;
combinec [x] _ = [x];
combinec _new _old = error $ "not singleton new";

safeint :: (Monad m, Alternative m) => Ii -> m Int;
safeint i = do {
guard $ fromIntegral(minBound::Int) <= i;
guard $ i <= fromIntegral(maxBound::Int);
return $ fromInteger i;
};

manysizes :: Int -> IntMap [String];
-- we use / abuse that it is left biased, which keeps the shorter strings
manysizes size = enumFromTo 1 size & map onesizemap & IntMap.unions;

lastofrange :: IntMap a -> [Int] -> Int;
lastofrange m = takeWhile (\x -> IntMap.member x m) >>> last;

-- negrange 9 is -1762 (old process)
-- now (combinesubtractsstraight) -1626

isinteresting :: IntSet -> Integer -> Bool;
isinteresting s v = (v < 4000) && (negate 4000 < v) && IntSet.notMember (fromInteger v) s;

newnums :: IntSet -> [String] -> ([(Integer,String)], IntSet);
newnums s lr = let {
ans = zipmap roman lr & filter (\x -> x & snd & isinteresting s) & map Tuple.swap;
} in (ans,ans & map (fst >>> fromInteger) & IntSet.fromList & IntSet.union s);

ufunc :: (Int, IntSet) -> Maybe ( [(Integer,String)], (Int,IntSet));
ufunc (lastn,s) = Just $ let {
n = lastn + 1;
} in case newnums s (allnletter n) of {
(out,s) -> (out, (n,s))
};

state0 :: (Int,IntSet);
state0 = (0,IntSet.empty);

dump1 :: [(Integer,String)] -> IO ();
dump1 l = do {
-- putStrLn "dump1";
mapM_ (\(x,y) -> [show x, y] & unwords & putStrLn) l;
};

{-
growing 10 good to -2562 (6gb)
growing 9 -1626
growing 8 -625
growing 7 -116 .. 2222
-}

intersperseandterminate :: Char -> String -> String;
intersperseandterminate c l = List.intersperse c l ++ [c];

flist :: a -> [a -> a] -> [a];
flist _ [] = [];
flist x (f:rest) = let {y=f x} in y:flist y rest;

worstcase :: [(String,Integer)];
worstcase = romancharslong & reverse & map fst & map intersperseandterminate & flist "" & zipmap romanmemoized;

getval :: Char -> Integer;
getval c = List.find (\x -> fst x == c) romanchars & Maybe.fromJust & snd;

-- aesthetic comparison
compareroman :: String -> String -> Ordering;
compareroman x y = case compare (length x) (length y) of {
EQ -> scompare;
-- prefer shorter
z -> z;
} where {
scompare :: Ordering;
scompare = let {
vx :: [Ii];
vx=map getval x& List.sort & reverse;
vy :: [Ii];
vy=map getval y& List.sort & reverse;
-- prefer less weight
} in case compare vx vy of {
EQ -> incompare;
z -> z;
};
incompare = let {
vx :: [Ii];
vx=map getval x;
vy :: [Ii];
vy=map getval y;
-- prefer heavy stuff near the front, e.g., -99
} in compare vy vx;

};

dumppair :: (Ii,[String]) -> IO();
dumppair (i,rs) = show i:rs & unwords & putStrLn;

} --end