{-
Calendar Facts grammar in Haskell

This work is licensed under a Creative Commons
Attribution-NonCommercial 2.5 License.

This work is a derivative of "Calendar Facts" from
https://xkcd.com/1930/
-}
{-# LANGUAGE ScopedTypeVariables, LambdaCase, OverloadedStrings #-}
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 Data.List;
--import Control.Monad;
--import Data.Maybe;
--import qualified Data.Map as Map;
--import Data.Map(Map);
--import qualified Data.Set as Set;
--import Data.Set(Set);
import Data.String(IsString(fromString));
-- to avoid the redundancy warning
trace_placeholder :: ();
trace_placeholder = (trace,assert) & (id >>> error) "trace_placeholder";

main :: IO();
main = getArgs >>= \case{
  ["grammar"] -> facts & simplify_grammar & print;
  ["length"] -> mbig & length & print;
  [n] -> mbig !! (read n) & putStrLn;
  _ -> mbig & mapM_ putStrLn;
};

mbig :: [String];
mbig = facts & show_grammar;

data Grammar = Atom String | Choice [Grammar] | Sequence [Grammar] deriving (Show,Eq);

instance IsString Grammar where {
fromString = Atom;
};
-- ":set -XOverloadedStrings" needed in ghci to test

instance Num Grammar where {
-- some hacks because of left associativity of + and *
--(+) (Choice l) y = Choice (l ++ [y]);
(+) x y = Choice [x,y];
--(*) (Sequence l) y = Sequence (l ++ [y]);
(*) x y = Sequence [x,y];
abs = undefined;
signum = undefined;
fromInteger = undefined;
negate = undefined;
};

-- generalize to monad or something less?
show_grammar :: Grammar -> [String];
show_grammar (Atom st) = pure st;
show_grammar (Choice gs) = gs >>= show_grammar;
show_grammar (Sequence gs) =
 mapM show_grammar gs >>= (unwords >>> return);
-- fix question and period in unwords


--facts :: (IsString a, Num a) => a;
facts :: Grammar;
facts =
    "Did you know that"
    *(
      ("the"
       *((("fall"+"spring")*"equinox")
         +(("winter"+"summer")*("solstice"+"Olympics"))
         +(("earliest"+"latest")*("sunrise"+"sunset"))
        ))
      +("Daylight"*("Saving"+"Savings")*"Time")
      +("leap"*("day"+"year"))
      +"Easter"
      +("the"*("Harvest"+"super"+"blood")*"moon")
      +"Toyota Truck Month"
      +"Shark Week"
     )
    *(("happens"*("earlier"+"later"+"at the wrong time")*"every year")
      +("drifts out of sync with the"
        *(("sun"+"moon"+"zodiac"
                    +(("Gregorian"+"Mayan"+"lunar"+"iPhone")
                      *"calendar")
          )
         +"atomic clock in Colorado")
       )
      +("might"*("not happen"+"happen twice")*"this year")
     )
    *"because of"
    *(("time zone legislation in"*("Indiana"+"Arizona"+"Russia"))
      +"a decree by the Pope in the 1500s"
      +(("precession"+"libration"+"nutation"+"libation"+"eccentricity"+"obliquity")
        *"of the"
        *("moon"+"sun"+"earth's axis"+"equator"+"prime meridian"
                    +(("International Date"+"Mason-Dixon")*"line"))
       )
      +"magnetic field reversal"
      +("an arbitrary decision by"*("Benjamin Franklin"+"Isaac Newton"+"FDR"))
     )
    *"? "
    *"Apparently"
    *("it causes a predictable increase in car accidents"
      +"that's why we have leap seconds"
      +"scientists are really worried"
      +("it was even more extreme during the"
        *((("Bronze"+"Ice")*"Age")
          +"Cretaceous"+"1990s"))
      +("there's a proposal to fix it, but it"
        *("will never happen"
          +"actually makes things worse"
          +"is stalled in Congress"
          +"might be unconstitutional"))
      +"it's getting worse and no one knows why")
    *". "
    *alt_text;

alt_text :: Grammar;
alt_text =
    "While it may seem like trivia, it"
    *("causes huge headaches for software developers"
      +"is taken advantage of by high-speed traders"
      +"triggered the 2003 Northeast Blackout"
      +"has to be corrected for by GPS satellites"
      +"is now recognized as a major cause of World War I"
     )
    *".";

simplify_grammar :: Grammar -> Grammar;
simplify_grammar x =
    case x of {
             Atom _ -> x;
             Choice [] -> error "empty choice";
             Choice [y] -> simplify_grammar y;
             Choice xs -> accum_choice xs & map simplify_grammar & Choice;
             Sequence [] -> error "empty sequence";
             Sequence [y] -> simplify_grammar y;
             Sequence xs -> xs & accum_sequence & map simplify_grammar & Sequence;
           };

-- It would be nice if these 2 did not have so much duplicated code
accum_choice :: [Grammar] -> [Grammar];
-- unfoldr does not quite work here because of ++ versus : in the different cases
accum_choice [] = [];
accum_choice ((Choice cs):rest) = accum_choice cs ++ accum_choice rest;
accum_choice (x:rest) = x:accum_choice rest;

accum_sequence :: [Grammar] -> [Grammar];
accum_sequence [] = [];
accum_sequence ((Sequence ss):rest) = accum_sequence ss ++ accum_sequence rest;
accum_sequence (x:rest) = x:accum_sequence rest;
} --end