"Fract! The Cylons!" No... wait: Starbuck used a different word

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
{-# LANGUAGE FlexibleContexts #-}

module Algorithmic.Fractal where

import Control.Monad.State
import Random                        -- or System.Random

import Data.Peano                    -- http://lpaste.net/107204

{--

A soluntion to the fracting problem posted at http://lpaste.net/109219

The old demo:

|
|
|
|
+-----------+------------+-------------+-------------+-----------+---------|
|
|
|
|
|__________________________________________________________________________|

Yeah, the flat line. Let's model that.

 --}

type DecibelMilliwatts = Double
type DBm = DecibelMilliwatts
type Hz = Int

data Spectrum = 
   Spect { minMaxDB :: (DBm, DBm), spikes :: [(Hz, DBm)],
           scope :: (Hz, Hz), step :: Hz, spectrum :: [DBm] }
      deriving Show

testSpectrum :: IO Spectrum
testSpectrum = initSpectrum miniMaxDBm inrange stp

miniMaxDBm = (25.0, 350)
inrange = (0, 1000)
stp = 5

initSpectrum :: (DBm, DBm) -> (Hz, Hz) -> Hz -> IO Spectrum
initSpectrum height@(lo, hi) rng@(left, right) stp =
   t >>= \spike1 -> t >>= \spike2 ->
   evalStateT initializeSpectrum 
              (Spect height [spike1, spike2] rng stp (base lo rng stp))
      where t = rnd left right >>= \hz -> rnd lo hi >>= \dB -> return (hz, dB)

rnd :: Random a => a -> a -> IO a
rnd x y = getStdRandom (randomR (x, y))

base :: DBm -> (Hz, Hz) -> Hz -> [DBm]
base flr (lo, hi) stp = take ((hi - lo) `div` stp) (repeat flr)

initializeSpectrum :: StateT Spectrum IO Spectrum
initializeSpectrum = get >>= mapM_ fractedSpike . spikes >> get >>= return

flatline :: (Num t, Monad m) => a -> m t
flatline info = return 1

{--

Our flat-line solution ('Ground Zero,' as it were), where initializeSpectrum
is defined using the flatline function

*Algorithmic.Fractal> testSpectrum 
Spect {minMaxDB = (25.0,350.0), spectrum = [25.0,25.0,25.0,...25.0,25.0,25.0], 
spikes = [(578,73.64258250131797),(367,277.3725723474921)], scope = (0,1000), 
step = 5}

(imagery (as per the bonus question posted at http://lpaste.net/109221)
is posted at 

http://logicaltypes.blogspot.com/p/1haskelladay-problems-with-solutions.html

and eventually archived under August 2014 1HaskellADay problems (link pending))

 --}

smoothSpike :: MonadState Spectrum m => (Hz, DBm) -> m ()
smoothSpike inf@(hz, dBm) = get >>= \(Spect height b rng stp spect) ->
   constructPeak inf rng stp height return >>=
   mergePeak inf rng stp spect return >>=
   put . Spect height b rng stp

mergePeak :: Monad m => (Hz, DBm) -> (Hz, Hz) -> Hz -> [DBm] ->
             ([DBm] -> m [DBm]) -> [DBm] -> m [DBm]
mergePeak spike@(cntr, _) r@(left, _) stp spect f peak =
   let (startHz, endHz) = slopeInfo spike r stp
       startMerg = (startHz - left) `div` stp
       endMerg   = startMerg + length peak
   in  f (take startMerg spect) >>= \front ->
       f (drop endMerg spect) >>= return . ((++) (front ++ peak))

constructPeak :: Monad m => (Hz, DBm) -> (Hz, Hz) -> Hz -> (DBm, DBm) 
                 -> ([DBm] -> m [DBm]) -> m [DBm]
constructPeak spike@(centre, peak) r@(left, right) stp (lo, hi) f =
   let haslope = descend (tenthSteps r stp) peak lo
       -- now we need to trim that peak if it bleeds off the edge:
       (startFreqSlope, endFreqSlope) = slopeInfo spike r stp
-- TODO: make f monadic
   in  f (reverse haslope) >>= \up -> f (tail haslope) >>= \down ->
-- DONE
   let chopl = drop ((left - startFreqSlope) `div` stp) (up ++ down)
   in  return (take ((length chopl) - (endFreqSlope - right) `div` stp) chopl)

slopeInfo :: (Hz, DBm) -> (Hz, Hz) -> Hz -> (Hz, Hz)
slopeInfo (centre, _) (left, right) stp =
   let harngSlope = (right - left) `div` 20
   in  (centre - harngSlope, centre + harngSlope)

tenthSteps :: (Hz, Hz) -> Hz -> Int
tenthSteps (lo, hi) stp = (hi - lo) `div` (stp * 20)

-- we present Data.List.unfoldr, unwound:

descend :: Int -> DBm -> DBm -> [DBm]
descend steps peak lo =
   d' (fromInt steps) peak ((peak - lo) / fromInteger (toInteger steps))
      where d' Z _ _ = []
            d' (S n) h d = h : d' n (h-d) d

mean :: (Fractional a, Num a) => a -> a -> a
mean low hi = (low + hi) / 2.0

{--

Our solution with two spikes, where initializeSpectrum is defined in
terms of smoothSpike (Heh: 'smooth'Spike. Yeah):

*Algorithmic.Fractal> testSpectrum 
Spect {minMaxDB = (25.0,350.0), spectrum = [25.0,25.0,25.0,...
53.30159674853821,81.60319349707643,109.90479024561466,...
54.33445414425439,25.0,25.0,25.0,...25.0], 
spikes = [(575,318.3445414425443),(569,308.01596748538225)], 
scope = (0,1000), step = 5}

(As you can see, the spikes are 'smooshed' together.)

('Smooshed' is a technical term. We use it all the time at work. 'Smooshed.')

 --}

{-- Now, let's get fracting!

Declaratively, what we are doing here, fracting, is to fract the base-line
to represent noise in the silence, and then to fract each side of the
spikes. (I suppose the spikes could come out pre-fracted and save us the
trouble!)

To 'fract' something is to break it so that a dimension-2 line becomes a
dimension 2.something-or-other line. That's the technical-what explanation.

The 'how' of that is that we break each line segment and then displace
the broken point, then we subdivide, taking each segment of the broken line
and breaking those, recursively. Simple, easy, yielding beautiful results.

 --}

-- We wish to fract to a certain depth/dimensionality, then STOP (because
-- you can fract forever down to infinitisimals

data Dir = Up | Down
   deriving (Eq, Show, Ord, Enum)

opposite :: Dir -> Dir
opposite Up = Down
opposite Down = Up

op :: Num a => Dir -> a -> a -> a
op Up = (+)
op Down = (-)

fract :: Peano -> Dir -> DBm -> [DBm] -> IO [DBm]
fract Z dir fractBy part = 
   doDaFract dir fractBy part >>= return . uncurry (++)
fract (S n) dir fractBy part =
   doDaFract dir fractBy part >>= \(left, right) ->
   mapM (fract n (opposite dir) fractBy) [left, right] >>= return . concat

doDaFract :: Dir -> DBm -> [DBm] -> IO ([DBm], [DBm])
doDaFract dir fractBy chord =
   let half = length chord `div` 2
       (left, right) = splitAt half chord
   in  rnd 0.0 fractBy >>= \ht ->
       return (cend dir ht left, cend (opposite dir) ht right)

cend :: Dir -> DBm -> [DBm] -> [DBm]
cend dir fractBy chord =
   let len = length chord
       fracted = fractBy / fromInteger (toInteger len)
   in  zipWith (op dir) chord (map (*fracted) (take len [0,1..]))

fractedSpike :: (Hz, DBm) -> StateT Spectrum IO ()
fractedSpike inf@(hz, dB) = get >>= \(Spect height b rng stp spect) ->
   let fractingfn = fract (fromInt 5) Up 15
   in  lift (constructPeak inf rng stp height fractingfn) >>= \spike ->
       lift (mergePeak inf rng stp spect fractingfn spike) >>=
       put . Spect height b rng stp

{--

And with initializeSpectrum defined with fractedSpike, we have:

*Algorithmic.Fractal> testSpectrum 
Spect {minMaxDB = (25.0,350.0), 
spikes = [(248,174.86199818373706),(517,151.3385962377858)], 
scope = (0,1000), step = 5, spectrum = [25.0,29.957182543918762,
28.944455163296414,...48.53293978963253,57.14822162877735,...
33.07034462964207,33.828727407026825,...140.91198823255533,...
-0.4927804548481274,...10.481323965659634,14.671541264915174,
...16.682456837155662]}

Woot! The long and winding road! But we got there. YAY!

 --}
58:25: Error: Use replicate
Found:
take ((hi - lo) `div` stp) (repeat flr)
Why not:
replicate ((hi - lo) `div` stp) flr
61:22: Error: Monad law, right identity
Found:
get >>= mapM_ fractedSpike . spikes >> get >>= return
Why not:
get >>= mapM_ fractedSpike . spikes >> get
98:8: Warning: Use liftM
Found:
f (drop endMerg spect) >>= return . ((++) (front ++ peak))
Why not:
Control.Monad.liftM ((++) (front ++ peak)) (f (drop endMerg spect))
98:35: Warning: Redundant bracket
Found:
return . ((++) (front ++ peak))
Why not:
return . (++) (front ++ peak)
98:44: Warning: Use section
Found:
((++) (front ++ peak))
Why not:
((front ++ peak) ++)
110:22: Warning: Redundant bracket
Found:
(length chopl) - (endFreqSlope - right) `div` stp
Why not:
length chopl - (endFreqSlope - right) `div` stp
181:4: Warning: Use liftM
Found:
doDaFract dir fractBy part >>= return . uncurry (++)
Why not:
Control.Monad.liftM (uncurry (++)) (doDaFract dir fractBy part)
184:4: Warning: Use liftM
Found:
mapM (fract n (opposite dir) fractBy) [left, right] >>=
return . concat
Why not:
(Control.Monad.liftM concat
(mapM (fract n (opposite dir) fractBy) [left, right]))