{-
    Guilloche (spirograph) patterns.

    Copyright 2016 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 #-}
{-# LANGUAGE FlexibleContexts #-}
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 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 Codec.Picture.Types(createMutableImage,MutableImage,freezeImage,writePixel);
import Codec.Picture(encodePng,Pixel8,PngSavable,PixelBaseComponent);
import Control.Monad.Primitive(PrimState,PrimMonad);
import qualified Data.ByteString.Lazy as ByteString;
import Foreign.Storable(Storable);
import Data.Ratio((%),denominator);

--future: consider Codec.Image.PBM in the bitwise package

-- to avoid the redundancy warning
trace_placeholder :: ();
trace_placeholder = (trace,assert) & (id >>> error) "trace_placeholder";

main :: IO();
main = getArgs >>= \case{
["go"] -> go sample_params sample_epicycles;
_ -> undefined;
};

-- Storable context needs FlexibleContexts
-- PixelBaseComponent and PrimState is a "type family" feature
outpic :: (Storable (PixelBaseComponent px), PngSavable px) => MutableImage (PrimState IO) px -> IO();
outpic pic = freezeImage pic >>= (encodePng >>> ByteString.putStr);

go :: Params -> [Epicycle] -> IO();
go params epicycles = do {
 pic :: MutableImage (PrimState IO) Pixel8 <- createMutableImage (params & width_height & fromIntegral) (params & width_height & fromIntegral) black_pixel;
 draw pic params epicycles;
 outpic pic;
};

draw :: MutableImage (PrimState IO) Pixel8 -> Params -> [Epicycle]-> IO();
draw image params epicycles = let {
end :: Integer;
end = calc_period epicycles;
step1 :: Double;
step1 = calc_step params epicycles;
r_range :: Double;
r_range = calc_range epicycles;
scale_factor :: Double;
scale_factor = (params & width_height & subtract margin & fromInteger) / r_range;
offset :: Int;
offset = (div (params & width_height & fromIntegral) 2);
} in trace ("end " ++ show end)
$ trace ("speed " ++ (calc_speed epicycles & show))
$ trace ("step1 " ++ show step1)
$ trace ("r_range " ++ show r_range)
$ trace ("scale_factor " ++ show scale_factor)
$ trace ("offset " ++ show offset)
$ trace ("work " ++ ((fromInteger end) / step1 & show))
$ enumFloat step1 (fromIntegral end) & map (guilloche epicycles) & mapM_ (transform_point scale_factor offset >>> draw_point image);

data Epicycle = Epicycle
{ radius :: Double
, rational_velocity :: Rational -- using Rational allows calculating lcm, but causes a 3x slowdown.
, phase :: Double
};

-- opportunities for parallelization
-- and optimization using recurrence relations of sine and cosine
guilloche :: [Epicycle] -> Double -> (Double,Double);
guilloche epicycles t = (f cos, f sin) where {
f :: (Double -> Double) -> Double;
f fn = map (\e -> radius e * fn (2*pi * velocity e * (t + phase e))) epicycles & sum;
};

data Params = Params
{ width_height :: Integer
};

-- beware roundoff error happens, e.g., step 0.1 behaves differently from 0.125
enumFloat :: Double -> Double -> [Double];
enumFloat tstep t_end = enumFloatFrom 0 where
{ enumFloatFrom start = if start < t_end then
start : enumFloatFrom (start + tstep)
else []
};

white_pixel :: Pixel8;
white_pixel = 255;
black_pixel :: Pixel8;
black_pixel = 0;

transform_point :: Double -> Int -> (Double, Double) -> (Int, Int);
transform_point scale_factor offset (x,y) = (scale scale_factor offset (negate y), scale scale_factor offset x);

draw_point :: PrimMonad m => MutableImage (PrimState m) Pixel8 -> (Int, Int) -> m ();
draw_point image (x,y) = writePixel image x y white_pixel;

scale :: Double -> Int -> Double -> Int;
scale factor offset x = (x * factor & floor) + offset;

sample_params :: Params;
sample_params = Params
{ width_height=2000
};

sample_epicycles :: [Epicycle];
sample_epicycles = sample_epicycles_8way;

sample_epicycles3_5 :: [Epicycle];
sample_epicycles3_5 =[Epicycle 1 1 0
,Epicycle 0.7 (1%5) 0
,Epicycle 0.3 (1%3) 0
,Epicycle 1 (1%77) 0
];


sample_epicycles_8way :: [Epicycle];
sample_epicycles_8way =
[Epicycle 1 1 0
,Epicycle 1 (1%37) 0
,Epicycle 0.7 (1%5) 0
];
sample_epicycles74 :: [Epicycle];
sample_epicycles74 =
[Epicycle 1 1 0
,Epicycle (3/5) (5%1) 0
,Epicycle (3/7) (41%2) 0
,Epicycle (1/2) (1000%37) 0
];

sample_epicycles1 :: [Epicycle];
sample_epicycles1 =
[Epicycle 1 1 0
,Epicycle 1 (1%2) 0
,Epicycle 1 (1%3) 0
,Epicycle 1 (1%5) 0
,Epicycle 1 (1%7) 0
];


lcm_many :: Integral a => [a] -> a;
lcm_many = foldl' lcm 1;

velocity :: Epicycle -> Double;
velocity = rational_velocity >>> fromRational;

calc_period :: [Epicycle] -> Integer;
calc_period = map rational_velocity >>> map denominator >>> lcm_many;

-- sum of the derivatives
calc_speed :: [Epicycle] -> Double;
calc_speed epicycles = zipWith (*) (map radius epicycles) (map (velocity >>> (*(2*pi))) epicycles) & map abs & sum;

calc_range :: [Epicycle] -> Double;
calc_range = map radius >>> map abs >>> sum >>> (*2);

-- decrease the step size by this factor just in case
fine_step :: Double;
fine_step = 0.25;

calc_step :: Params -> [Epicycle] -> Double;
calc_step params epicycles = let {
pix_width :: Double;
pix_width = calc_range epicycles / (params & width_height & fromIntegral);
} in fine_step * pix_width / calc_speed epicycles;

-- avoid the image going all the way to the edge
margin :: Integer;
margin = 20;

} --end