{-
Generate and count sentences of a given length.

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 #-}
{-# LANGUAGE TemplateHaskell #-}
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 qualified Data.Bifunctor as Bifunctor;
--import qualified Data.Tuple as Tuple;
import Control.Monad.GenericReplicate(genericReplicateM); -- igenericReplicateM
--import Data.Functor((<&>)); --foreach = flip map
import qualified "poly" Data.Poly as Poly;
import qualified Control.Monad.State.Lazy as State;
import qualified "fclabels" Data.Label as Fclabel;
import qualified Control.Applicative as Applicative;
import qualified "vector" Data.Vector as Vector;

type Ii = Integer;

-- 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,Vector.fromList"") & (id >>> error) "trace_placeholder";

usage :: IO();
usage = error "see 'main' function source code for arguments to pass";

alphabet :: String;
alphabet = "a";

space :: Char;
space = '.';

type Mypoly = Poly.VPoly Ii;

evalpoly :: Mypoly -> Ii;
evalpoly = evalpolyat (List.genericLength alphabet);

evalpolyat :: Ii -> Mypoly -> Ii;
evalpolyat x p = Poly.eval p x;

memoize1 :: Ii -> (compositestate -> Map.Map Ii Mypoly) -> (State.State compositestate Mypoly) -> (Ii -> Mypoly -> compositestate -> compositestate) -> State.State compositestate Mypoly;
memoize1 n getter calcanswer setter = do {
 oldmap :: Map Ii Mypoly <- State.gets getter;
 case Map.lookup n oldmap of {
  Just y -> return y;
  Nothing -> do {
   answer :: Poly.VPoly Ii <- calcanswer;
   -- Poly (version 0.3.1) does not yet support DeepSeq ; it was added 0.3.2
   seq (answer==answer) $
    State.modify (setter n answer);
   return answer;
}}};

-- if this function is moved further down, past some mkLabels commands, then the program will no longer compile
mapupdate :: ((Fclabel.:->) compositestate (Map Ii Mypoly)) -> Ii -> Mypoly -> compositestate -> compositestate;
mapupdate f n answer = Fclabel.modify f (Map.insert n answer);

memoizelens :: Ii -> ((Fclabel.:->) compositestate (Map Ii Mypoly)) -> (State.State compositestate Mypoly) -> State.State compositestate Mypoly;
memoizelens n f calcanswer = memoize1 n (Fclabel.get f) calcanswer (mapupdate f);

sumM :: (Monad m, Num y) => [a] -> (a -> m y) -> m y;
sumM xs f = mapM f xs >>= (sum >>> return);

-- nothing before a splice can refer to anything after a splice
type Bar = Int;
bar :: Int;
bar = 1;
foo :: Bar;
foo = bar;

-- in the "1" family, parenthesized sentences can stand for words

type Monad1family a = State.State State1family a;


data State1family = Mk1family
{ _lenssentence1family :: Map Ii Mypoly
, _lensword1family :: Map Ii Mypoly
};

Fclabel.mkLabels [''State1family];

empty1family :: State1family;
empty1family = Mk1family Map.empty Map.empty;

eval1family :: Monad1family a -> a;
eval1family m = State.evalState m empty1family;

gensentence1family :: Ii -> [String];
gensentence1family n | n<0 = Monad.mzero
| n==0 = return ""
| True = do {
 i <- [1..n];
 Applicative.liftA2 (++)
  (genword1family i)
  (genrestsentence1family $ n-i);
};

countsentence1family :: Ii -> Monad1family Mypoly;
countsentence1family n | n<0 = return 0
| n==0 = return 1
| True = memoizelens n lenssentence1family $ sumM [1..n] (\i -> Applicative.liftA2 (*)
  (countword1family i)
  (countrestsentence1family $ n-i));

-- space followed by rest of the sentence
genrestsentence1family :: Ii -> [String];
genrestsentence1family n | n < 0 = Monad.mzero;
genrestsentence1family 0 = return "";
genrestsentence1family 1 = Monad.mzero;
genrestsentence1family n = do {
r <- gensentence1family $ n-1;
return $ space:r;
};

countrestsentence1family :: Ii -> Monad1family Mypoly;
countrestsentence1family n | n < 0 = return 0;  -- Num instance of Poly
countrestsentence1family 0 = return 1;
countrestsentence1family 1 = return 0;
countrestsentence1family n = countsentence1family $ n-1;

-- word or parenthesized sentence
genword1family :: Ii -> [String];
genword1family n = Monad.mplus
 (genericReplicateM n alphabet)
 (do {
  y <- gensentence1family $ n-2;
  return $ ('(':y)++")";
 });

countword1family :: Ii -> Monad1family Mypoly;
countword1family n = memoizelens n lensword1family (do {
 y <- countsentence1family $ n-2;
 return $ y + Poly.X^n});

----------------------------------------------------
-- in the "2" family, parenthesized sentences can stand for words, but spaces are not permitted before and after them

type Monad2family a = State.State State2family a;

data State2family = Mk2family
{ _lenssentence2family :: Map Ii Mypoly
, _lensplainwordsentence2family :: Map Ii Mypoly
, _lensafterplainword2family :: Map Ii Mypoly
};

Fclabel.mkLabels [''State2family];

empty2family :: State2family;
empty2family = Mk2family Map.empty Map.empty Map.empty;

eval2family :: Monad2family a -> a;
eval2family m = State.evalState m empty2family;

gensentence2family :: Ii -> [String];
gensentence2family n | n<0 = Monad.mzero
| n==0 = return ""
| True = Monad.mplus
 (genplainwordsentence2family n)
 (do{
  i <- [1..n];
  Applicative.liftA2 (++)
   (genparenthesized2family i)
   (gensentence2family $ n-i)
});

countsentence2family :: Ii -> Monad2family Mypoly;
countsentence2family n | n < 0 = return 0
| n == 0 = return 1
| True = memoizelens n lenssentence2family (Applicative.liftA2 (+)
 (countplainwordsentence2family n)
 (sumM [1..n] (\i -> Applicative.liftA2 (*)
  (countparenthesized2family i)
  (countsentence2family $ n -i))));

-- sentence in which first word is a plain word
genplainwordsentence2family :: Ii -> [String];
genplainwordsentence2family n = do {
i <- [1..n];
Applicative.liftA2 (++)
 (genplainword2family i)
 (genafterplainword2family $ n-i)
};

countplainwordsentence2family :: Ii -> Monad2family Mypoly;
countplainwordsentence2family n = memoizelens n lensplainwordsentence2family (sumM [1..n] (\i -> Applicative.liftA2 (*)
 (countplainword2family i)
 (countafterplainword2family $ n-i)));

-- rest of sentence after a plain word
genafterplainword2family :: Ii -> [String];
genafterplainword2family n | n < 0 = Monad.mzero;
genafterplainword2family 0 = return "";
genafterplainword2family 1 = Monad.mzero;
genafterplainword2family n = Monad.mplus
 (genparenthesized2family n)
 (do {
  r <- genplainwordsentence2family $ n-1;
  return $ space:r;
});

countafterplainword2family :: Ii -> Monad2family Mypoly;
countafterplainword2family n | n < 0 = return 0
| n==0 = return 1
| n==1 = return 0
| True = memoizelens n lensafterplainword2family $ Applicative.liftA2 (+)
 (countparenthesized2family n)
 (countplainwordsentence2family $ n-1);

genplainword2family :: Ii -> [String];
genplainword2family n | n < 1 = error "genplainword2family"
| True = genericReplicateM n alphabet;

countplainword2family :: Ii -> Monad2family (Poly.VPoly Ii);
countplainword2family n = return $ Poly.X^n;

genparenthesized2family :: Ii -> [String];
genparenthesized2family n = do {
y <- gensentence2family $ n-2;
return $ ('(':y)++")";
};

countparenthesized2family :: Ii -> Monad2family Mypoly;
countparenthesized2family n = countsentence2family $ n-2;

-------------------------------------------
-- in the "3" family, parenthesized sentences can stand for portions of words.  it is the least restrictive.

type Monad3family a = State.State State3family a;

data State3family = Mk3family
{ _lenssentence3family :: Map Ii Mypoly
, _lensword3family :: Map Ii Mypoly
};

Fclabel.mkLabels [''State3family];

empty3family :: State3family;
empty3family = Mk3family Map.empty Map.empty;

eval3family :: Monad3family a -> a;
eval3family m = State.evalState m empty3family;

gensentence3family :: Ii -> [String];
gensentence3family n | n<0 = Monad.mzero
| n==0 = return ""
| True = do {
 i <- [1..n];
 Applicative.liftA2 (++)
  (genword3family i)
  (genrestsentence3family $ n-i)
};

countsentence3family :: Ii -> Monad3family Mypoly;
countsentence3family n | n<0 = return 0
| n==0 = return 1
| True = memoizelens n lenssentence3family $ sumM [1..n] (\i -> Applicative.liftA2 (*)
 (countword3family i)
 (countrestsentence3family $ n-i));

-- space plus rest of sentence
genrestsentence3family :: Ii -> [String];
genrestsentence3family n | n < 0 = Monad.mzero;
genrestsentence3family 0 = return "";
genrestsentence3family 1 = Monad.mzero;
genrestsentence3family n = do {
r <- gensentence3family $ n-1;
return $ space:r;
};
countrestsentence3family :: Ii -> Monad3family Mypoly;
countrestsentence3family n | n<0 = return 0
| n==0 = return 1
| n==1 = return 0
| True = countsentence3family $ n-1;

-- a word, which could include a balanced parenthesis substring
genword3family :: Ii -> [String];
genword3family n | n < 0 = Monad.mzero
| n == 0 = return ""
| True = Monad.mplus
 (do {
  a <- alphabet;
  z <- genword3family $ n-1;
  return $ a:z})
 (do {
  i <- [2..n];
  y <- gensentence3family $ i-2;
  z <- genword3family $ n-i;
  return $ ('(':y)++")"++z;
});

countword3family :: Ii -> Monad3family Mypoly;
countword3family n | n<0 = return 0
| n==0 = return 1
| True = memoizelens n lensword3family $ Applicative.liftA2 (+)
(do {
  z <- countword3family $ n-1;
  return $ Poly.X * z})
(sumM [2..n] (\i -> Applicative.liftA2 (*)
  (countsentence3family $ i-2)
  (countword3family $ n-i)));

--------------------------------------------------
-- in the 4 family, spaces are forbidden entirely

type Monad4family a = State.State State4family a;

data State4family = Mk4family
{ _lenssentence4family :: Map Ii Mypoly
};

Fclabel.mkLabels [''State4family];


empty4family :: State4family;
empty4family = Mk4family Map.empty;

eval4family :: Monad4family a -> a;
eval4family m = State.evalState m empty4family;

gensentence4family :: Ii -> [String];
gensentence4family n | n < 0 = Monad.mzero
| n == 0 = return ""
| True = Monad.mplus
 (do {
  a <- alphabet;
  z <- gensentence4family $ n-1;
  return $ a:z})
 (do {
  i <- [2..n];
  y <- gensentence4family $ i-2;
  z <- gensentence4family $ n-i;
  return $ ('(':y)++")"++z;
});

countsentence4family :: Ii -> Monad4family Mypoly;
countsentence4family n | n<0 = return 0
| n==0 = return 1
| True = memoizelens n lenssentence4family $ Applicative.liftA2 (+)
(do {
  z <- countsentence4family $ n-1;
  return $ Poly.X * z})
(sumM [2..n] (\i -> Applicative.liftA2 (*)
  (countsentence4family $ i-2)
  (countsentence4family $ n-i)));

-- this needs Control.Monad.State.Lazy
many1family :: Monad1family [Mypoly];
many1family = mapM countsentence1family [0..];

runningsumm :: (Monad m,Num num) => [num] -> m[num];
runningsumm = scanl (+) 0 >>> return;

-- sentences of n characters or less
cumulative1family :: [Mypoly];
cumulative1family = eval1family $ many1family >>= runningsumm;

showlength :: (Ii -> [a]) -> Ii -> String;
showlength f i = f i & length & show;

polyfunctions :: [Ii -> Mypoly];
polyfunctions = [countsentence1family >>> eval1family, countsentence2family >>> eval2family, countsentence3family >>> eval3family, countsentence4family >>> eval4family];
--polyfunctions = [countsentence4family >>> eval4family];




main :: IO();
main = do {
hSetBuffering stdout LineBuffering;
getArgs >>= \case{
[] -> usage;
["count",n] -> polyfunctions & mapM_ (\f -> f (read n) & evalpoly & print); -- count sentences of length n, alphabet as specified in the alphabet function (default size 1).
["alphabetsize",alphabetsize,n] -> polyfunctions & mapM_ (\f -> f (read n) & evalpolyat (read alphabetsize) & (\x -> putStrLn $ show x ++ " = 10^ " ++ show ((fromInteger x & log)/log (10::Double))));
["generate",n] -> [gensentence1family,gensentence2family,gensentence3family,gensentence4family] & mapM_ (\f -> read n & f & List.sort & unwords & putStrLn);
["verifycount",n] -> [gensentence1family,gensentence2family,gensentence3family,gensentence4family] & mapM_ (\f -> read n & showlength f & putStrLn);
["polynomial",n] -> polyfunctions & mapM_ (\f -> f (read n) & print);
["cumulative1family"] -> mapM_ (evalpoly >>> print) cumulative1family;
_ -> undefined;
};
};

--bar :: Int;
--bar = 10;



} --end