{-
Puts accents over some letters using Unicode combining diacritics,
and underlines below some using HTML.
Copyright 2018 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 .
-}
{-# LANGUAGE ScopedTypeVariables, LambdaCase #-}
module Main(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 qualified Data.Maybe as Maybe;
--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 System.Random as Random;
import qualified Control.Monad.Random as Random;
import Control.Monad.Random(RandomGen,Rand,getRandomR,evalRand);
-- to avoid the redundancy warning
trace_placeholder :: ();
trace_placeholder = (trace,assert) & (id >>> error) "trace_placeholder";
main :: IO();
main = getArgs >>= \case{
["total"] -> range_try2 & length & print;
["modify"] -> getContents >>= (modify_string >>> evalStdGen) >>= putStr;
["range"] -> range_try2 & List.intersperse "" & concat & putStrLn;
_ -> undefined;
};
evalStdGen :: Rand Random.StdGen a -> IO a;
evalStdGen x = Random.getStdGen >>= (evalRand x >>> return);
ascenders :: String;
ascenders = "bdfhklt";
idotless :: String;
idotless = "ı";
--idotless = "i";
jdotless :: String;
jdotless = "ȷ";
--jdotless = "j";
takes_upper :: String;
takes_upper = (['a'..'z'] List.\\ ascenders) List.\\ "ij";
alphabet_upper_and_lower :: String;
alphabet_upper_and_lower = ['a'..'z'] ++ ['A'..'Z'];
-- in the end, i and j are too narrow to take accents well
tohtml :: Int -> String;
tohtml i = "" ++ show i ++ ";";
mkStdGen2 :: Int -> Random.StdGen;
mkStdGen2 = Random.mkStdGen >>> Random.next >>> snd;
sample :: RandomGen g => [a] -> Rand g a;
sample l = do {
i <- getRandomR (0,length l & pred);
return $ l!!i;
};
-- 300 301 302 30c 308 30a ; 326 327
-- 1dfe 350
all_upper :: [Int];
all_upper = [0x300, 0x301, 0x306, 0x311, 0x303, 0x304, 0x30b, 0x30f, 0x308, 0x307, 0x30a, 0x309 ];
-- circumflex caron = 302 30c, breves = 306 311, doubles = 30b 30f
-- tilde 303 macron 304
modify_char :: RandomGen g => Char -> Rand g String;
modify_char x = do {
dolower :: Bool <- if List.elem x takes_lower then sample_bool else pure False;
if (not $ List.elem x "ij") then do {
upper :: String <- if List.elem x takes_upper then sample_upper else pure "";
return $ (pure x ++ upper & underline_html dolower);
} else sample_bool >>= (remove_dot x >>> underline_html dolower >>> return)
};
remove_dot :: Char -> Bool -> String;
remove_dot c yes = if not yes then [c] else case c of {
'i' -> idotless;
'j' -> jdotless;
_ -> error "not i or j";
};
underline_html :: Bool -> String -> String;
underline_html dolower y = if not dolower then y else
-- ""++y++""
"" ++ y ++ "" -- this supposedly does not work in HTML5
;
sample_bool :: RandomGen g => Rand g Bool;
sample_bool = sample [False,True];
-- how to make this point free?
modify_string :: RandomGen g => String -> Rand g String;
modify_string s = mapM modify_char s >>= (concat >>> return);
descenders :: String;
descenders = "gjpqyQJ"; -- some fonts descend for capital Q and J
takes_lower :: String;
takes_lower = alphabet_upper_and_lower List.\\ (descenders);
sample_upper :: RandomGen g => Rand g String;
sample_upper = all_upper & map tohtml & sample;
range_try2 :: [String];
range_try2 = do {
nucleus :: Char <- alphabet_upper_and_lower;
do_underline <- [False,True];
Monad.guard $ not do_underline || List.elem nucleus takes_lower;
(if List.elem nucleus "ij" then [False,True] >>= (remove_dot nucleus >>> return) else do {
combining_diacritic :: String <- "":map tohtml all_upper;
Monad.guard $ null combining_diacritic || List.elem nucleus takes_upper;
pure nucleus ++ combining_diacritic & return;
}) >>= (underline_html do_underline >>> return);
};
} --end