{- 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 . -} {-# 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