{-
Copyright 2012 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 #-}
module Main where {
import Control.Monad.State;
import Maybe;
import qualified Data.Map as Map;
import System;
import Primality;
import Data.List;
import Data.Word;
import Data.Char;
import qualified Data.ByteString as ByteString;
mainmagic = do{putStrLn "hello world this is a test of latin 1";ByteString.putStrLn magicChars;};
main = do{
         (args :: [String]) <- getArgs;
         getContents >>= 
         (case args of{
                      ["entries"] -> entries;
                      ["process"] -> process;
                      ["checkio"] -> checkio;
                      ["update"] -> ioupdate;
                      ["showval"] -> showval;
                      ["checkprimes"] -> docheckprimes;
                      ["showtype"] -> showtype;
                    }
                          . readInput . map words . lines );
       };
readInput :: [[String]] -> Dict;
readInput x = execState (mapM_ p1 x) Map.empty;

checkio :: Dict -> IO ();
checkio d = do {
              mapM_ (check d) $ Map.toList d;
            };
process :: Dict -> IO ();
process d = do {
              mapM_ print $ Map.toList d;
            };
ioupdate :: Dict -> IO();
ioupdate d = mapM_ print $ Map.toList$doUpdateKeys d;

showval :: Dict -> IO();
showval = mapM_ singleShow . Map.toList ;

type Key = (Nsuffix,Sign);
type Value = (Algebraic,Factors,Bool);
type Algebraic = [Nsuffix];
data Fnumber = N Integer | C Int | P Int | Composite Integer deriving (Show, Ord, Eq);
type Factors = [Fnumber];
type Dict = Map.Map Key Value;
-- type Dict = [(Key,Value)];
type Nsuffix = (Integer,String);
p1 :: [String] -> State Dict ();
p1 ws = if ((head $ head ws) == '#') then
            return ()
        else
            do {
              (d :: Dict) <- get;
              let {
                nl :: String;
                nl = head ws;
                nsuffix :: Nsuffix;
                nsuffix=parseNumber $ head ws;
                sign :: Sign;
                sign = readSign (ws !! 1);
                algebraic :: Algebraic;
                algebraic = map parseNumber $ read (ws !! 2);
                factors :: Factors;
                factors = map parseF $ drop 3 ws;
                newd :: Dict;
                newd = Map.insert (nsuffix,sign) (algebraic,factors,False) d;
                -- newd = d ++ [((nsuffix,sign),(algebraic,factors))];
              };
              put newd;
              return ();
            };

data Sign = Minus | Plus deriving (Show, Ord, Eq);
readSign :: String -> Sign;
readSign "-" = Minus;
readSign "+" = Plus;
readSign s = error $ "bad format:"++s;

showSign :: Sign -> String;
showSign Minus = "\\nobreakdash--"; -- latex
showSign Plus = "+";

getAllFactors :: Dict -> Key -> Value -> Factors;
getAllFactors dict (nsuffix,sign) (algebraic,factors,_) =
    do {
      (k :: Key) <- map (makeKey sign) algebraic;
                        getFactors $ fromJust $ Map.lookup k dict;
    } ++ factors;

makeKey :: Sign -> Nsuffix -> Key;
makeKey sign (indexsuffix) = (indexsuffix,sign);

check :: Dict -> (Key,Value) -> IO ();
check dict (key,value) = do{
                           print (key,value);
                           let { f :: Factors;
                                 f = getAllFactors dict key value;
                                 ns :: Int;
                                 ns = length $ filter (not.isN) f;
                               };
                           print $ f;
                                 case ns of{
                                           0 -> print "READY";
                                           1 -> print "DIVIDE";
                                           _ -> print "ABORT";
                                         };
                         };
updatekey :: (Key,Value) -> Dict -> (Key,Value);
updatekey (key,value) dict = 
    (key,
        if(isFinished value) then value
    else let { f :: Factors;
                    f = getAllFactors dict key value;
                    ns :: Int;
                    ns = length $ filter (not.isN) f;
             } in case ns of {
                            0 -> error "updatekey";
                            1 -> divideThrough (filter isN f) key value;
                            _ -> value;
                          });

singleUpdateKey :: (Key,Value) -> State Dict ();
singleUpdateKey kv = do {
                    (d :: Dict) <- get;
                    let {newkv = updatekey kv d};
                    put $ Map.insert (fst newkv) (snd newkv) d;
};

doUpdateKeys :: Dict -> Dict;
doUpdateKeys d = execState (mapM_ singleUpdateKey (Map.toList d)) d;

parseNumber :: String -> Nsuffix;
parseNumber s = if (last s == 'L' || last s == 'M') then
                    (read $ init s, [last s])
                else (read s, "");
parseF :: String -> Fnumber;
parseF ('C':rest) = C $read rest;
parseF ('P':rest) = P $read rest;
parseF n = N $ read n;

isN :: Fnumber -> Bool;
isN (N _) = True;
isN _ = False;

getN :: Fnumber -> Integer;
getN (N x) = x;

isFinished :: Value -> Bool;
isFinished v = 0==((length . filter (not.isN) . getFactors) v);

getFactors :: Value -> Factors;
getFactors (_,f,_) = f;

divideThrough :: Factors -> Key -> Value -> Value;
divideThrough allfactors k v@(algebraic,factors,finished) = 
    let 
        {
          partial :: Integer;
          partial = product $ map getN $ allfactors;
          ns :: Factors;
          ns = filter isN $ factors;
          shouldbeprime :: Integer -> Fnumber;
          shouldbeprime = case (filter (not.isN) factors) of 
                       {
                         [C _] -> Composite;
                         [P _] -> N;
                       };
                                                       
        } in case (divMod (formKey k) partial) of 
               {
                 (q,0) -> (algebraic,ns++[shouldbeprime q],True);
                 _ -> error $ show (k,v);
               };
    
formKey :: Key -> Integer;
formKey ((i,""),Minus) = 2^i-1;
formKey ((i,""),Plus) = 2^i+1;

formKey ((n,suffix),Plus) = 
    case (divMod (n+2) 4) of 
      {
        (k,0) -> let 
            {
              h = 2*k - 1;
            } in case suffix of 
                   {
                     "L" -> 2^h - 2^k + 1;
                     "M" -> 2^h + 2^k + 1;
                   }};
singleShow :: (Key,Value) -> IO ();
singleShow (key,_) = do 
  { 
    print key;
    print $ formKey key;
};

checkPrimes :: Value -> Bool;
checkPrimes v = and $ map miller_rabin_isPrime $ map getN $ filter isN $ getFactors $ v;

singlecheckprimes :: (Key,Value) -> IO ();
singlecheckprimes (key,value) = do 
  {
    print key;
          let {
            good = checkPrimes value;
          };
                              print $ good;
if (not good) then error "not good" else return ();

};

docheckprimes :: Dict -> IO ();
docheckprimes d = mapM_ singlecheckprimes $ Map.toList $ doUpdateKeys d;


toBase :: Integer -> Integer -> [Int];
toBase base x = let {
toBase' 0 = [];
toBase' x = case (divMod x base) of {
                                  (q,r) -> (fromInteger r):(toBase' q);
                                };
} in reverse $ toBase' x;

mimeBase64 :: String;
mimeBase64 = ['A'..'Z']
             ++ ['a' ..'k'] ++"#"++ ['m'..'z']
                    ++ "&*@34%6789" ++ "+/";

{- stringBase64 :: Integer -> String;
stringBase64 x = map (mimeBase64 !!) $ toBase 64 x;
-}
stringBase32 :: Integer -> ByteString.ByteString;
stringBase32 x = ByteString.pack 
                 $ myaddspaces
                 $ capitalizeW 
                 $ map (num32 !!) 
                 $ (toBase 32) x;

capitalizeW :: [Word8] -> [Word8];
capitalizeW (x:rest) = (x-32):rest;
capitalizeW [] = [];

myaddspaces :: [Word8] -> [Word8];
myaddspaces = reverse . (addspaces 4 [32]) . reverse;

addspaces :: Int -> [a] -> [a] -> [a];
addspaces wordlength space s = 
  if (wordlength < (length s)) then
    (take wordlength s)++space++(addspaces wordlength space (drop wordlength s))
  else
    s;

num32 :: [Word8];
num32 = [248,229,234,239,249,253]
++ (w8 ['a'..'z']);
-- 216 is capital o
latex32lower :: [String];
latex32lower = ["{\\o}","{\\aa}"] ++
               (map backslash 
                ["^{e}","\"{i}", "`{u}","'{y}"]) 
               ++ (map return ['a'..'z']);
latex32upper :: [String];
latex32upper = ["{\\O}","{\\AA}"] ++
               (map backslash 
                ["^{E}","\"{I}", "`{U}","'{Y}"]) 
               ++ (map return ['A'..'Z']);

backslash :: String -> String;
backslash x = '\\':x;

w8 :: String -> [Word8];
w8 = map (fromIntegral . ord);

bystr :: String -> ByteString.ByteString;
bystr = ByteString.pack . w8;
        
showEntry :: (Key,Value) -> ByteString.ByteString;
showEntry (key,(algebraic, factors, _)) = 
   ByteString.concat $ (ByteString.pack $
    w8 ("2^"
        ++ (showkey key) ++ "1 (" 
        ++ (concat$intersperse ", " $ map showalgebraic algebraic) ++ ") "))
:
  ( 
    (intersperse period $ map showfactor $ sort $ factors)
    ++ [bystr".\n"]);
period :: ByteString.ByteString;
period = (bystr ". ");  
showfactor :: Fnumber -> ByteString.ByteString;
showfactor (N x) = stringBase32 x;
-- showfactor (Composite x) = ByteString.pack $ replicate (length $ toBase 32 x) (fromIntegral $ ord '_');
showfactor (Composite x) = ByteString.pack $ myaddspaces $ replicate (length $ toBase 32 x) (fromIntegral $ ord '_');
showfactor x = bystr $ show x;
preview :: Bool -> [a] -> [a];
preview True l = take 370 l;
preview False l = l;
entries :: Dict -> IO ();
entries d = do {
  putStr latexheader;
  mapM_ latexshowentry $  preview the_preview $ Map.toList $ doUpdateKeys d;
  putStr latextrailer;
  };

bytestringshowentry :: (Key,Value) -> IO ();
bytestringshowentry = ByteString.putStr . showEntry;

{-
sort has problem at 1370M:
42561594665463216927619561
19154988777052184768372641
-}

showalgebraic :: Nsuffix -> String;
showalgebraic (i,s) = (show i)++s;

showkey :: Key -> String;
showkey (ns,sign) = (showalgebraic ns)++
                    case (snd ns) of {
                                    "" -> (showSign sign);
                                    _ -> "";
                                  };

magicChars :: ByteString.ByteString;
magicChars = ByteString.pack num32;


showfactorlatex :: Fnumber -> String;
showfactorlatex (N x) = latexdo32 x;
showfactorlatex (Composite x) = concat $ replicate (div (length $ toBase 32 x) 4) " \\rule{1em}{0.1ex}";
showfactorlatex _ = error "showfactorlatex";

(.>) :: (a -> b) -> (b -> c) -> (a -> c);
(.>) = flip (.);

($>) :: a -> (a -> b) -> b;
($>) = flip ($);

latexdo32 :: Integer -> String;
latexdo32 x = x $> toBase 32 $> capitalizelatex 
              $> reverse $> addspaces 4 [" "] $> reverse
              $> concat;

capitalizelatex :: [Int] -> [String];
capitalizelatex (first:rest) = (latex32upper !! first):(map (latex32lower!!)rest);
capitalizelatex []=[];

latexshowentry :: (Key,Value) -> IO ();
latexshowentry = putStr . showentrylatex;

showentrylatex :: (Key,Value) -> String;
showentrylatex (key,(algebraic, factors, _)) =
  ""
  ++ latexcommand "textbf" (showkey key)
  ++ "~" --nonbreaking space
  ++ do_showalgebraic algebraic
--  ++ "\\textbf{"
  ++ formatfactors factors
--  ++ (concat$ intersperse ".\n" $ map showfactorlatex factors)
--  ++ "."
--  ++"}" 
  ++"\n";

do_showalgebraic :: Algebraic -> String;
do_showalgebraic [] = "";
do_showalgebraic algebraic = "("
--  ++"\\textit{"
  ++ (concat$intersperse ", " $ map showalgebraic algebraic) 
--  ++ "}"
  ++ ") ";

formatfactors :: Factors -> String;
formatfactors factors = maybe_italicize (1 == (length factors)) $ concat $ map (\x -> x ++ ". ") $ map showfactorlatex factors;

maybe_italicize :: Bool -> String -> String;
maybe_italicize False s = s;
maybe_italicize True s = latexcommand "textit" s;

cunningham_date :: String;
-- April 22, 2010
cunningham_date = "December 4, 2011";
psbook_margins :: [String];
psbook_margins =        [
          -- weird margins are to make psbook behave better
         "setlength{\\topmargin}{-0.9in}"
        , "setlength{\\headheight}{0in}"
        , "setlength{\\headsep}{0in}"
        , "setlength{\\textheight}{12.0in}"
        , "setlength{\\oddsidemargin}{0in}"
        , "setlength{\\evensidemargin}{-0.9in}"
        , "setlength{\\textwidth}{7.4in}"
        , "setlength{\\pdfpagewidth}{8.5in}"
       , "setlength{\\pdfpageheight}{13in}"
       ] ;

setlength :: String -> Double -> String;
setlength variable length = "setlength{\\" ++ variable ++ "}{" ++ (show length) ++ "in}";
normal_margins :: [String];
normal_margins = [
         setlength "topmargin" 0
        , setlength "headheight" 0.1
        , setlength "headsep" 0.1
        , setlength "voffset" (-0.5)
        , setlength "textheight" 9.8
        , setlength "oddsidemargin" 0
        , setlength "evensidemargin" (-0.5)
        , setlength "textwidth" 7
        , setlength "pdfpagewidth" 8.5
       , setlength "pdfpageheight" 11
];

alphabet_table1 :: [String];
alphabet_table1 = [latexcommand "begin" "flushleft" ] ++ 
                 (map latexconversion [0..31]) ++
                 [latexcommand "end" "flushleft",""];

alphabet_table :: [String];
alphabet_table=["",latexcommand "begin" "tabular}{rcccl"] ++
 (map tablelatexconvert [0..31]) ++
 [latexcommand "end" "tabular",""];

font_pazo :: [String];
font_pazo = ["usepackage[osf]{mathpazo}" -- old style numbers
,"usepackage{type1cm}"];
font_cm :: [String];
font_cm = [ "usepackage{eco}"]; -- old style numbers do not support fractional sizes
the_preview :: Bool;
the_preview = True;
latexheader :: String;
latexheader= 
    unlines 
    $ (map backslash 
    $ [ "documentclass[10pt,twocolumn,twoside]{article}" -- 12pt for psbook shrunk 2up
    ,"usepackage{amsmath}" -- nobreakdash 
        , "usepackage[us,12hr]{datetime}"
        ,"pagestyle{headings}"
        ] ++ font_pazo ++ normal_margins ++
       [ setlength "parindent" 0
        , setlength "baselineskip" 0
        , "title{The Absolute Word of \\rule{2em}{0.1ex} }"
        , "author{as Revealed to Mankind in the Language of Pure Mathematics \\\\ Computed by the Cunningham Project}"
       , ("date{" ++ cunningham_date ++ "}")         
        , "begin{document}"
       , "maketitle"
       , "thispagestyle{empty}"
       ,"makeatletter"
       ,"@setfontsize\\normalsize{8pt}{8.3pt}"
       -- pazo 8/8 fits 40, 8.01, 8.05, 8.07, 8.08, 8.082, 8.083
       -- 8/8.5 fits 39 (so strange)
       -- 8.2 = 38 pgs, 8.1, 8.09, 8.085, 8.084
         -- also 38: 8.3
         
       -- 8/8 computermodern fits on 40 pages
       -- 8/8.98 cm fits 41 pages, but not useful cuz double-sided printing
       -- 8/9.35 cm fits 42 pages
       -- 9/10.1 fits 50 pages
       -- 9/10.7 fits 52 pages
       ,"makeatother"
        ])
    ++[ "The known prime factors of $2^n \\pm 1$, in base 32 with the following alphabet:" ]
          ++ alphabet_table
                 ++ [""
                     ,"References to algebraic factors are in parentheses.  "
             , "The Aurifeuillian factorization of $2^{4k-2}+1$ is $L\\cdot M$, where $L=2^{2k-1}-2^k+1$ and $M=2^{2k-1}+2^k+1$."
             , ""
             ,"\\vspace{1ex}"
              ,""
             ];

binary :: Int -> String;
binary = fromIntegral
         .> (toBase 2) 
         .> reverse 
         .> (++ (repeat 0)) 
         .> take 5 
         .> reverse 
         .> (map show) 
         .> concat ;

latexcommand :: String -> String -> String;
latexcommand texttt x = "\\"++texttt++"{"++x++"}";

latexconversion :: Int -> String;
latexconversion x = concat
                    [ (show x)
                    , "="
                    , (latex32lower!!x)
                    , "="
                    , x $> binary $> latexcommand "texttt"];

tablelatexconvert :: Int -> String;
tablelatexconvert x = concat
                    [ (show x)
                    , "&=&"
                    , (latex32upper!!x)
                    ," "
                    , (latex32lower!!x)
                    , "&=&"
                    , x $> binary $> latexcommand "texttt"
                    , " \\\\"];
                    
latextrailer :: String;
latextrailer = unlines
               [""
               ,"\\raggedleft"
               ,latexcommand "textit" "---\\today, \\currenttime"
               ,latexcommand "end" "document"];

isPlusMinus :: Sign -> Key -> Bool;
isPlusMinus s ((_,""),ks) = (s == ks);
isPlusMinus _ _ = False;

isLM :: Key -> Bool;
isLM ((_,""),_) = False;
isLM _ = True;

mersenne_like :: Value -> Bool;
mersenne_like (_,[N _],_) = True;
mersenne_like _ = False;

count_length :: [Fnumber] -> Int;
count_length [] = 0;
count_length ((N _):rest) = 1+(count_length rest);
count_length ((Composite _):[]) = 2;  -- will factor into at least 2 primes
                                  
show_num_factors :: (Key,Value) -> IO ();
show_num_factors (k,(_,f,_)) =
    do {
      putStr $ show $ count_length f ; putStr " " ; print k };
showtype :: Dict -> IO ();
showtype d = mapM_ show_num_factors $ Map.toList $ doUpdateKeys d
-- end
        }