re-organize into Numeric and Symbolic
[ruff:ruff.git] / Fractal / Mandelbrot / Symbolic / AngledInternalAddress.hs
1 {-# LANGUAGE DeriveDataTypeable #-}
2 {- |
3 Module      :  Fractal.Mandelbrot.Symbolic.AngledInternalAddress
4 Copyright   :  (c) Claude Heiland-Allen 2010-2012
5 License     :  BSD3
6
7 Maintainer  :  claudiusmaximus@goto10.org
8 Stability   :  unstable
9 Portability :  DeriveDataTypeable
10
11 Implementation of ideas from Dierk Schleicher's paper
12 /Internal Addresses Of The Mandelbrot Set And Galois Groups Of Polynomials (version of February 5, 2008)/
13 <http://arxiv.org/abs/math/9411238v2>.
14
15 -}
16 module Fractal.Mandelbrot.Symbolic.AngledInternalAddress
17   ( AngledInternalAddress(Unangled, Angled)
18   , angledInternalAddress
19   , angledFromList
20   , angledToList
21   , externalAngles
22   , stripAngles
23   , splitAddress
24   , joinAddress
25   , addressPeriod
26   , visibleComponents
27   , ConciseAddress(ConciseAddress)
28   , ConciseItem(ConcisePeriod, ConciseAngle)
29   , toConciseAddress
30   , fromConciseAddress
31   , conciseItem
32   ) where
33
34 import Data.Data (Data())
35 import Data.Typeable (Typeable())
36
37 import Data.List (genericDrop, genericIndex, genericLength, genericReplicate)
38 import Data.Ratio ((%))
39
40 import Fractal.Mandelbrot.Symbolic.ExternalAngle (anglePeriod, doubleAngle, ExternalAngle(ExternalAngle), ExternalAnglePair(ExternalAnglePair), BinaryAnglePair(), toBinaryAnglePair, fromBinaryAnglePair, Period(Period), tuneBinaryPair, wrapAngle)
41 import Fractal.Mandelbrot.Symbolic.InternalAngle (InternalAngle(InternalAngle), (*/), FareyAngle(FareyAngle), fareyAngle)
42 import Fractal.Mandelbrot.Symbolic.KneadingSequence (Kneading, kneading, kneadingPeriod, unwrapKneading)
43 import Fractal.Mandelbrot.Symbolic.InternalAddress (InternalAddress(InternalAddress), internalAddress, internalToList)
44 import Fractal.Mandelbrot.Utils (chunkWith2, mod_, strictlyWithin)
45
46
47 rho :: Kneading -> Integer -> Integer
48 rho v r | r >= 1 && fmap (Period r`mod`) (kneadingPeriod v) /= Just 0 = ((1 + r) +) . genericLength . takeWhile id . zipWith (==) vs . genericDrop r $ vs
49         | otherwise = rho v (r + 1)
50   where
51     vs = unwrapKneading v
52
53 orbit :: (a -> a) -> a -> [a]
54 orbit = iterate
55
56 -- | Angled internal addresses have angles between each integer in an
57 --   internal address.
58 data AngledInternalAddress
59   = Unangled Period
60   | Angled Period InternalAngle AngledInternalAddress
61   deriving (Read, Show, Eq, Ord, Data, Typeable)
62
63 -- | Builds a valid 'AngledInternalAddress' from a list, checking the
64 --   precondition that only the last 'Maybe Angle' should be 'Nothing',
65 --   and the 'Integer' must be strictly increasing.
66 angledFromList :: [(Period, Maybe InternalAngle)] -> Maybe AngledInternalAddress
67 angledFromList = fromList' 0
68   where
69     fromList' x [(n, Nothing)] | n > x = Just (Unangled n)
70     fromList' x ((n, Just r) : xs) | n > x && 0 < r && r < 1 = Angled n r `fmap` fromList' n xs
71     fromList' _ _ = Nothing
72
73 unsafeAngledFromList :: [(Period, Maybe InternalAngle)] -> AngledInternalAddress
74 unsafeAngledFromList = fromList' 0
75   where
76     fromList' x [(n, Nothing)] | n > x = Unangled n
77     fromList' x ((n, Just r) : xs) | n > x && 0 < r && r < 1 = Angled n r (fromList' n xs)
78     fromList' _ _ = error "Fractal.Mandelbrot.Address.unsafeAngledFromList"
79
80 -- | Convert an 'AngledInternalAddress' to a list.
81 angledToList :: AngledInternalAddress -> [(Period, Maybe InternalAngle)]
82 angledToList (Unangled n) = [(n, Nothing)]
83 angledToList (Angled n r a) = (n, Just r) : angledToList a
84
85 denominators :: InternalAddress -> Kneading -> [Integer]
86 denominators a v = denominators' (internalToList a)
87   where
88     denominators' (Period s0:ss@(Period s1:_)) =
89       let rr = s1 `mod_` s0
90       in  (((s1 - rr) `div` s0) + if s0 `elem` takeWhile (<= s0) (orbit p rr) then 1 else 2) : denominators' ss
91     denominators' _ = []
92     p = rho v
93
94 numerators :: ExternalAngle -> InternalAddress -> [Integer] -> [Integer]
95 numerators r a qs = zipWith num (internalToList a) qs
96   where
97     num s q = genericLength . filter (<= r) . map (genericIndex rs) $ [0 .. q - 2]
98       where
99         rs = iterate (foldr (.) id . genericReplicate s $ doubleAngle) r
100
101 -- | The angled internal address corresponding to an external angle.
102 angledInternalAddress :: ExternalAngle -> Maybe AngledInternalAddress
103 angledInternalAddress r0 = do
104   let r = wrapAngle r0
105       k = kneading r
106   i <- internalAddress k
107   let d = denominators i k
108       n = numerators r i d
109   return . unsafeAngledFromList . zip (internalToList i) . (++ [Nothing]) . map (Just . InternalAngle) . zipWith (%) n $ d
110
111 -- | Split an angled internal address at the last island.
112 splitAddress :: AngledInternalAddress -> (AngledInternalAddress, [InternalAngle])
113 splitAddress a =
114   let (ps0, rs0) = unzip $ angledToList a
115       ps1 = reverse ps0
116       rs1 = reverse (Nothing : init rs0)
117       prs1 = zip ps1 rs1
118       f ((p, Just r):qrs@((q, _):_)) acc
119         | p == q */ r = f qrs (r : acc)
120       f prs acc = g prs acc
121       g prs acc =
122         let (ps2, rs2) = unzip prs
123             ps3 = reverse ps2
124             rs3 = reverse (Nothing : init rs2)
125             prs3 = zip ps3 rs3
126             aa = unsafeAngledFromList prs3
127         in  (aa, acc)
128   in  f prs1 []
129
130 -- | The inverse of 'splitAddress'.
131 joinAddress :: AngledInternalAddress -> [InternalAngle] -> AngledInternalAddress
132 joinAddress (Unangled p) [] = Unangled p
133 joinAddress (Unangled p) (r:rs) = Angled p r (joinAddress (Unangled $ p */ r) rs)
134 joinAddress (Angled p r a) rs = Angled p r (joinAddress a rs)
135
136 -- | The period of an angled internal address.
137 addressPeriod :: AngledInternalAddress -> Period
138 addressPeriod (Unangled p) = p
139 addressPeriod (Angled _ _ a) = addressPeriod a
140
141 -- | Discard angle information from an internal address.
142 stripAngles :: AngledInternalAddress -> InternalAddress
143 stripAngles = InternalAddress . map fst . angledToList
144
145 -- | The pair of external angles whose rays land at the root of the
146 --   hyperbolic component described by the angled internal address.
147 externalAngles :: AngledInternalAddress -> Maybe ExternalAnglePair
148 externalAngles = externalAngles' 1 (toBinaryAnglePair (ExternalAnglePair 0 1))
149
150 externalAngles' :: Period -> BinaryAnglePair -> AngledInternalAddress -> Maybe ExternalAnglePair
151 externalAngles' p0 lohi (Unangled p)
152   | p0 /= p = case visibleComponents (fromBinaryAnglePair lohi) p of
153       [lh] -> Just lh
154       _ -> Nothing
155   | otherwise = Just (fromBinaryAnglePair lohi)
156 externalAngles' p0 lohi a0@(Angled p r a)
157   | p0 /= p = case visibleComponents (fromBinaryAnglePair lohi) p of
158       [lh] -> externalAngles' p (toBinaryAnglePair lh) a0
159       _ -> Nothing
160   | otherwise = do
161       let FareyAngle _ lh = fareyAngle r
162       externalAngles' (p */ r) (if p > 1 then tuneBinaryPair lh lohi else lh) a
163
164 -- | The visible components in the wake.
165 visibleComponents :: ExternalAnglePair -> Period -> [ExternalAnglePair]
166 visibleComponents (ExternalAnglePair lo hi) q =
167   let gaps (l, h) n
168         | n == 0 = [(l, h)]
169         | n > 0 = let gs = gaps (l, h) (n - 1)
170                       cs = candidates n gs
171                   in  accumulate cs gs
172         -- deliberately unhandled case
173       candidates n gs =
174         let den = 2 ^ n - 1
175         in  [ r
176             | (l, h) <- gs
177             , num <- [ ceiling (l * fromInteger den)
178                       .. floor (h * fromInteger den) ]
179             , let r = ExternalAngle $ num % den
180             , l < r, r < h
181             , anglePeriod r == Just n
182             ]
183       accumulate [] ws = ws
184       accumulate (l : h : lhs) ws =
185         let (ls, ms@((ml, _):_)) = break (l `strictlyWithin`) ws
186             (_s, (_, rh):rs) = break (h `strictlyWithin`) ms
187         in  ls ++ [(ml, l)] ++ accumulate lhs ((h, rh) : rs)
188       -- deliberately unhandled case
189   in  chunkWith2 ExternalAnglePair . candidates q . gaps (lo, hi) $ (q - 1)
190
191 -- | Concise angled internal address type.
192 newtype ConciseAddress = ConciseAddress [ConciseItem]
193   deriving (Read, Show, Eq, Ord, Data, Typeable)
194
195 -- | Concise addresses are mixed sequences of periods and internal angles.
196 data ConciseItem = ConcisePeriod !Period | ConciseAngle !InternalAngle
197   deriving (Read, Show, Eq, Ord, Data, Typeable)
198
199 -- | Deconstructor for items in the vein of 'either'.
200 conciseItem :: (Period -> a) -> (InternalAngle -> a) -> ConciseItem -> a
201 conciseItem f _ (ConcisePeriod p) = f p
202 conciseItem _ g (ConciseAngle r) = g r
203
204 -- | Reduce an angled internal address to concise form.
205 toConciseAddress :: AngledInternalAddress -> ConciseAddress
206 toConciseAddress = ConciseAddress . rule2 1 . rule1 . toItems
207   where
208     toItems (Unangled q) = ConcisePeriod q : []
209     toItems (Angled q r a) = ConcisePeriod q : ConciseAngle r : toItems a
210     rule1 = filter (/= ConciseAngle 0.5)
211     rule2 _ [] = []
212     rule2 p (ConcisePeriod q : rest)
213       | p == q = rule2 q rest
214       | otherwise = ConcisePeriod q : rule2 q rest
215     rule2 p (ConciseAngle r : rest) = ConciseAngle r : rule2 (p */ r) rest
216
217 -- | Recreate an angled internal address from concise form.
218 fromConciseAddress :: ConciseAddress -> AngledInternalAddress
219 fromConciseAddress (ConciseAddress is0) = fromItems . rule1 . rule2 1 $ is0
220   where
221     fromItems [ConcisePeriod p] = Unangled p
222     fromItems (ConcisePeriod p : ConciseAngle r : is) = Angled p r (fromItems is)
223     rule2 p [] = [ConcisePeriod p]
224     rule2 p (ConcisePeriod q : is)
225       | p < q = ConcisePeriod p : rule2 q is
226       | otherwise = rule2 q is
227     rule2 p (ConciseAngle r : is) = ConcisePeriod p : ConciseAngle r : rule2 (p */ r) is
228     rule1 (ConcisePeriod p : ConcisePeriod q : is) = ConcisePeriod p : ConciseAngle 0.5 : rule1 (ConcisePeriod q : is)
229     rule1 (i : is) = i : rule1 is
230     rule1 [] = []
231
232 {-
233 quickCheck (\k -> let r = flip approxRational 1e-3 . abs . snd . properFraction $ k
234                   in 0 < r && r < 1 && odd (denominator r) ==>
235                   (let ma = angledInternalAddress (ExternalAngle r)
236                   in isJust ma ==>
237                   ma == (fromConciseAddress . toConciseAddress) `fmap` ma))
238 -}