{-

HTML color swatches.

Copyright 2021 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 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.Set as Set; import Data.Set(Set);
--import Data.Tuple(swap);
--import Control.Monad.GenericReplicate(genericReplicateM); -- igenericReplicateM
--import qualified Data.Bifunctor as Bifunctor;  -- (first, second)


main :: IO();
main = getArgs >>= \case{
_ -> go;
};

type Ii = Integer;

-- Endomorphism. useful for (id :: Endo Integer) to assert a type in a pipeline
type Endo a = a->a;

-- to avoid the redundancy warning
trace_placeholder :: ();
trace_placeholder = (trace,assert,printlines,id :: Endo Integer) & (id >>> error) "trace_placeholder";
-- ghc -O2 -fno-ignore-asserts

printlines :: [String] -> IO();
printlines l = do {
hSetBuffering stdout LineBuffering;
mapM_ putStrLn l;
};

showlines :: (Show a) => [a] -> IO();
showlines = map show >>> printlines;

range2 :: [Ii];
range2 = [0,255];

range3 :: [Ii];
range3 = [0,128,255];

newtype Color = Color [Ii] deriving (Ord, Eq);
graycolor :: Color;
graycolor = Color [128,128,128];

gray :: [Color] -> [Color];
gray x = x ++ [graycolor];

displaycolor :: Color -> String;
displaycolor c = rgbshow c ++ "=<span style=\"background-color:" ++ rgbshow c ++ "\">&nbsp;&nbsp;</span>";

rgbshow :: Color -> String;
rgbshow (Color c) = "rgb(" ++ (map show c & List.intersperse "," & concat) ++ ")";

set8 :: [Color];
set8 = Monad.replicateM 3 range2 & map Color;

set9 :: [Color];
set9 = set8 & gray;  -- abuse of the meaning of &

set12 :: [Color];
set12 = [range2, range3, range2] & sequence & map Color;

set13 :: [Color];
set13 = set12 & gray;

set18 :: [Color];
set18 = [range3, range3, range2] & sequence & map Color;

set19 :: [Color];
set19 = set18 & gray;

set27 :: [Color];
set27 = Monad.replicateM 3 range3 & map Color;

-- basic colors HTML 4.01
set16 :: [Color];
set16 = "fff ccc 888 000 f00 800 ff0 880 0f0 080 0ff 088 00f 008 f0f 808" & words & map gen;

gen :: String -> Color;
gen s = map genc s & Color;

genc :: Char -> Ii;
genc '0' = 0;
genc '8' = 0x80;
genc 'c' = 0xc0;
genc 'f' = 0xff;
genc c = error $ "bad char '"++[c]++"'";

colorset :: [Color] -> String;
colorset c = "<p>" ++ (show $ length c) ++ " colors: " ++ (c & map displaycolor & List.intersperse ", " & concat) ++ "</p>";

go :: IO();
go = [set8, set9, set12, set13, set18, set19, set27, set16, set27 List.\\ set16] & mapM_ (colorset >>> putStrLn);
} --end