perturbation based calculations
[maximus:emndl.git] / emndl_autotune.hs
1 {-
2     emndl -- exponentially transformed Mandelbrot Set renderer
3     Copyright (C) 2011  Claude Heiland-Allen <claude@mathr.co.uk>
4
5     This program is free software: you can redistribute it and/or modify
6     it under the terms of the GNU General Public License as published by
7     the Free Software Foundation, either version 3 of the License, or
8     (at your option) any later version.
9
10     This program is distributed in the hope that it will be useful,
11     but WITHOUT ANY WARRANTY; without even the implied warranty of
12     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
13     GNU General Public License for more details.
14
15     You should have received a copy of the GNU General Public License
16     along with this program.  If not, see <http://www.gnu.org/licenses/>.
17 -}
18
19 module Main (main) where
20
21 import Control.Monad (guard, when)
22 import Data.Either (lefts)
23 import Data.List (minimumBy)
24 import Data.Maybe (listToMaybe, fromMaybe)
25 import Data.Ord (comparing)
26 import Data.Vec (NearZero(nearZero))
27 import System.Random (RandomGen, randomR, newStdGen) -- StdGen)
28 import System.Environment (getArgs)
29 import System.IO (hPutStrLn, stderr)
30 import Control.Parallel.Strategies (parMap, rseq)
31 import Data.Number.MPFR (toString, RoundMode(Near), set)
32 import Data.Number.MPFR.Instances.Near()
33
34 import Number (I, R, C)
35 import Complex (Complex((:+)), magnitude2)
36 import MuAtom (refineNucleus)
37 import GridScan (gridEdge, gridShow, gridConverge, gridStep, gridScan, gridSpace)
38
39 default (Int)
40
41 straddlesOrigin :: [C] -> Bool
42 straddlesOrigin ps = odd . length . filter id . zipWith positiveReal ps $ (drop 1 ps ++ take 1 ps)
43
44 positiveReal :: C -> C -> Bool
45 positiveReal (u:+v) (x:+y)
46   | v < 0 && y < 0 = False
47   | v > 0 && y > 0 = False
48   | (u * (y - v) - v * (x - u)) * (y - v) > 0 = True
49   | otherwise = False
50
51 maxPeriod :: I -> I
52 maxPeriod p = 12 * p
53
54 locateNucleus :: I -> R -> C -> Maybe I
55 locateNucleus p r c =
56   let cs = [ c + (r:+r), c + (r:+(-r)), c + ((-r):+(-r)), c + ((-r):+r) ]
57       zs = iterate (zipWith (\cc z -> z * z + cc) cs) [0,0,0,0]
58   in  fmap fst . listToMaybe . dropWhile (not . straddlesOrigin . snd) . zip [0 .. maxPeriod p] $ zs
59
60 offsetFromOrigin :: [C] -> R
61 offsetFromOrigin = magnitude2 . sum
62
63 rescan :: I -> R -> C -> Maybe (R, C)
64 rescan p r0 c0
65   = case filter (straddlesOrigin . snd)
66   . parMap rseq (fmap (parMap rseq (\c -> iterate (\z->z * z + c) 0 !! p)))
67   . fmap (\(r, c) -> ((r, c), [c + (r:+r), c + ((-r):+r), c + ((-r):+(-r)), c + (r:+(-r))]))
68   $( [ (r', c0 + d) | i <- [-1,1], j <- [-1,1 ], let d = ((r'*i) :+ (r'*j)) ]
69   ++ [ (r', c0 + d) | i <- [  0 ], j <- [  0 ], let d = ((r'*i) :+ (r'*j)) ]) of
70     [] -> Nothing
71     xs -> Just . fst . minimumBy (comparing $ offsetFromOrigin . snd) $ xs
72   where r' = r0 / 2
73
74 shuffle :: RandomGen g => [a] -> g -> ([a], g)
75 shuffle [] g = ([], g)
76 shuffle xs g =  let (i, g') = randomR (0, length xs - 1) g
77                     (h, x:t) = splitAt i xs
78                     (xs', g'') = shuffle (h ++ t) g'
79                 in  (x : xs', g'')
80
81 autotunes :: RandomGen g => ((C, R, I), g) -> [Either (C, R, I) String]
82 autotunes x@((c0, r0, p0), _) = Left (c0, r0, p0) :
83   case autotune1 x of
84     (Nothing,  _) -> []
85     (Just str, m) -> Right str : case m of
86       Nothing -> []
87       Just y -> autotunes y
88
89 autotune1 :: RandomGen g => ((C, R, I), g) -> (Maybe String, Maybe ((C, R, I), g))
90 autotune1 (x@(c0, r0, _), g0)
91   | nearZero r0 = (Nothing, Nothing)
92   | otherwise =
93       let grid = gridConverge . iterate gridStep . gridScan c0 $ r0
94           edge = gridEdge grid
95           str = gridShow grid
96           (es, g1) = shuffle edge g0
97       in  (Just str, autotune' es (x, g1))
98
99 autotune' :: RandomGen g => [C] -> ((C, R, I), g) -> Maybe ((C, R, I), g)
100 autotune' [] _ = Nothing
101 autotune' (c1:es) x@((_, r0, p0), g0) =
102   fromMaybe (autotune' es x) $ do
103     let r1 = gridSpace r0
104     p1 <- locateNucleus p0 r1 c1
105     guard $ p1 > 2 && (p0 == 1 || p1 `mod` p0 /= 0)
106     (_, c1') <- (!! 64) . iterate (uncurry (rescan p1) =<<) $ Just (r1, c1)
107     let (re, im, r2) = refineNucleus (fromIntegral p1) c1'
108         c2 = re :+ im
109     return $ Just ((c2, r2, p1), g0)
110
111 main :: IO ()
112 main = do
113   args <- getArgs
114   let bits = case args of
115         [b] -> read b
116         _ -> 128 :: Int
117       dec = ceiling . ((logBase 10 2 :: Double) *) . fromIntegral $ bits
118       r = set Near (fromIntegral bits)
119 --      g = read "123456789 987654321" :: StdGen
120   g <- newStdGen
121   let ats = autotunes ((r 0 :+ r 0, r 1, 1), g)
122       (fre :+ fim, fzr, _) = last (lefts ats)
123       pretty (Left (re:+im,zr,p)) = ["P " ++ show p, "R " ++ toString dec re, "I " ++ toString dec im, "@ " ++ toString dec zr]
124       pretty (Right s) = [s]
125   when verbose $ (mapM_ (hPutStrLn stderr) . concatMap pretty . init) ats
126   putStrLn . unwords $ [ toString dec fre, toString dec fim, show (ceiling (0.5 + logBase 2 (256 / fzr) / 8) :: Int) ]
127
128 verbose :: Bool
129 verbose = True