ghc/tests/programs/barton-mangler-bug/Basic.hs

   1 {-# OPTIONS -H12m #-}
   2
   3 module Basic where
   4 import TypesettingTricks
   5 import Physical
   6 --import GHC( (->) )
   7 infixr 7 |>
   8 class Signal s where
   9   mapSignal:: (Physical a, Physical b) => (s a b) -> a -> b
  10   mapSigList:: (Physical a, Physical b) => (s a b) -> [a] -> [b]
  11   toSig:: (Physical a, Physical b) => (s a b) -> SignalRep a b
  12   mapSignal = mapSignal . toSig
  13   mapSigList = map . mapSignal
  14   toSig = FunctionRep . mapSignal
  15 instance Signal (->) where
  16   mapSignal f = f
  17   toSig = FunctionRep
  18 data {- (Physical a, Physical b) => -} SignalRep a b =
  19    FunctionRep (a -> b) |
  20    PieceContRep (PieceCont a b)
  21    deriving (Eq, Show)
  22 instance Signal SignalRep where
  23   mapSignal (FunctionRep f) = mapSignal f
  24   mapSignal (PieceContRep f) = mapSignal f
  25   mapSigList (FunctionRep f) = mapSigList f
  26   mapSigList (PieceContRep f) = mapSigList f
  27   toSig = id
  28 instance (Physical a, Physical b) => Eq (a -> b) where
  29   a == b = error "Attempt to apply equality to functions"
  30 binop:: (Physical a, Physical b) => (Float -> Float -> Float) ->
  31                                     (a -> b) -> (a -> b) -> a -> b
  32 binop op f g t = toPhysical ((fromPhysical (f t)) `op` (fromPhysical (g t)))
  33 unop:: (Physical a, Physical b ) => (Float -> Float) ->
  34                                     (a -> b) -> a -> b
  35 unop op f t = toPhysical (op (fromPhysical (f t)))
  36 instance (Physical a, Physical b) => Num (SignalRep a b) where
  37   f + g = FunctionRep (binop (+) (mapSignal f) (mapSignal g))
  38   f * g = FunctionRep (binop (*) (mapSignal f) (mapSignal g))
  39   negate f = FunctionRep (unop negate (mapSignal f))
  40   abs f = FunctionRep (unop abs (mapSignal f))
  41   signum f = FunctionRep (unop abs (mapSignal f))
  42   fromInteger i = FunctionRep (\t -> toPhysical (fromInteger i))
  43   fromInt i = FunctionRep (\t -> toPhysical (fromInt i))
  44 instance (Physical a, Physical b) =>
  45          Fractional (SignalRep a b) where
  46   f / g = FunctionRep (binop (/) (mapSignal f) (mapSignal g))
  47   fromRational r = FunctionRep (\t -> (toPhysical (fromRational r)))
  48 instance (Physical a, Physical b) =>
  49           Floating (SignalRep a b) where
  50   pi = FunctionRep (\t -> (toPhysical pi))
  51   exp   f = FunctionRep (unop exp (mapSignal f))
  52   log   f = FunctionRep (unop log (mapSignal f))
  53   sin   f = FunctionRep (unop sin (mapSignal f))
  54   cos   f = FunctionRep (unop cos (mapSignal f))
  55   asin  f = FunctionRep (unop asin (mapSignal f))
  56   acos  f = FunctionRep (unop acos (mapSignal f))
  57   atan  f = FunctionRep (unop atan (mapSignal f))
  58   sinh  f = FunctionRep (unop sinh (mapSignal f))
  59   cosh  f = FunctionRep (unop cosh (mapSignal f))
  60   asinh f = FunctionRep (unop asinh (mapSignal f))
  61   acosh f = FunctionRep (unop acosh (mapSignal f))
  62   atanh f = FunctionRep (unop atanh (mapSignal f))
  63 data Event =
  64   TimeEvent Float |
  65   FunctionEvent (Float -> Bool) |
  66   BurstEvent Int Event
  67   deriving (Show)
  68 instance Eq Event where
  69   (TimeEvent x) == (TimeEvent y) = x == y
  70   (BurstEvent i e) == (BurstEvent i' e') = (i' == i) && (e' == e)
  71 eventOccurs:: Event -> Float -> Float
  72 eventOccurs (TimeEvent t) x = if x < t then x else t
  73 eventOccurs (FunctionEvent f) x = stepEval f x
  74 eventOccurs (BurstEvent i e) x =
  75           if i == 1 then
  76             eventOccurs e x
  77           else
  78             eventOccurs (BurstEvent (i-1) e) ((eventOccurs e x) + eventEps x)
  79 stepEval:: (Float -> Bool) -> Float -> Float
  80 stepEval f x = if f x then x else stepEval f (x + eventEps x)
  81 data ZeroIndicator = LocalZero | GlobalZero deriving (Eq, Show)
  82 data {- (Physical a, Physical b) => -} FunctionWindow a b =
  83      Window ZeroIndicator Event (SignalRep a b)
  84      deriving (Eq, Show)
  85 data PieceCont a b = Windows [FunctionWindow a b]
  86      deriving (Eq, Show)
  87 instance Signal PieceCont where
  88   mapSignal (Windows []) t = toPhysical 0.0
  89   mapSignal (Windows wl) t = (mapSignal s) (toPhysical t')
  90       where (t', (Window z e s), wl') = getWindow 0.0 (fromPhysical t) wl
  91   toSig = PieceContRep
  92 getWindow:: (Physical a, Physical b) =>
  93             Float -> Float -> [ FunctionWindow a b ] ->
  94             (Float, FunctionWindow a b, [ FunctionWindow a b ])
  95 getWindow st t [] = (t, Window LocalZero e f, [])
  96                     where e = TimeEvent (realmul 2 t)
  97                           f = FunctionRep (\t -> toPhysical 0.0)
  98 getWindow st t (w:wl) = if t' <= wt then (t',w,w:wl)
  99                         else getWindow (st+wt) t wl
 100     where wt = eventOccurs e t'
 101           (Window z e s) = w
 102           t' = if z == LocalZero then t-st else t
 103 (|>) :: (Physical a, Physical b) => FunctionWindow a b ->
 104         PieceCont a b -> PieceCont a b
 105 w |> (Windows wl) = Windows (w:wl)
 106 nullWindow = Windows []
 107 cycleWindows:: (Physical a, Physical b) =>
 108                 PieceCont a b -> PieceCont a b
 109 cycleWindows (Windows wl) = Windows (cycle wl)
 110 constant:: (Physical a, Physical b) => b -> SignalRep a b
 111 constant x = FunctionRep (\t -> x)
 112 linear:: (Physical a, Physical b) => Float -> b -> SignalRep a b
 113 linear m b  = FunctionRep (\x -> toPhysical (realmul m (fromPhysical x) + (fromPhysical b)))
 114 sine:: (Physical a, Physical b) =>
 115        b -> Frequency -> Float -> SignalRep a b
 116 sine mag omeg phase = FunctionRep (\x -> toPhysical (realmul (fromPhysical mag) (sin (realmul (realmul (realmul 2 pi) (fromPhysical omeg)) (fromPhysical x) + phase))))
 117 waveform:: (Physical a, Physical b) => a -> [b] -> SignalRep a b
 118 waveform samp ampls =
 119   let stepSlope y y' = realdiv ((fromPhysical y') - (fromPhysical y)) (fromPhysical samp)
 120       makeWin (v,v') = Window LocalZero (TimeEvent (fromPhysical samp))
 121                        (linear (stepSlope v v') v)
 122       points = cycle ampls
 123   in PieceContRep (Windows (map makeWin (zip points (tail points))))
 124 random:: (Physical a, Physical b) =>
 125          Integer -> a -> SignalRep a b
 126 random i s = waveform s (map toPhysical (rand i))
 127 ramp:: (Physical a, Physical b) => a -> b -> SignalRep a b
 128 ramp per v =
 129   let sig = linear (realdiv (fromPhysical v) (fromPhysical per)) (toPhysical 0.0)
 130   in PieceContRep (Windows (cycle ([Window LocalZero (TimeEvent (fromPhysical per)) sig ])))
 131 triangle:: (Physical a, Physical b) => a -> b -> SignalRep a b
 132 triangle per v =
 133   let sl = realmul 2.0 (realdiv (fromPhysical v) (fromPhysical per))
 134       qper = realdiv (fromPhysical v) 4.0
 135       wins =  (Window LocalZero (TimeEvent qper) (linear sl (toPhysical 0.0))) |>
 136               (Window LocalZero (TimeEvent (realmul 2.0 qper)) (linear (- sl) v)) |>
 137               (Window LocalZero (TimeEvent qper) (linear sl (toPhysical (- (fromPhysical v))))) |>
 138                nullWindow
 139   in PieceContRep (cycleWindows wins)
 140 step:: (Physical a, Physical b) => a -> b -> SignalRep a b
 141 step tr lvl = FunctionRep (\t -> if (fromPhysical t) < (fromPhysical tr) then (toPhysical 0.0) else lvl)
 142 square:: (Physical a, Physical b) => a -> b -> SignalRep a b
 143 square per lvl =
 144   let trans = realdiv (fromPhysical per) 2.0
 145       nlvl = asTypeOf (toPhysical (- (fromPhysical lvl))) lvl
 146       f t = if (fromPhysical t) < trans then lvl else nlvl
 147       wins = Windows [Window LocalZero (TimeEvent (fromPhysical per)) (FunctionRep f)]
 148   in PieceContRep (cycleWindows wins)
 149 pulse:: (Physical a, Physical b) => a -> a -> b -> SignalRep a b
 150 pulse st wid lvl =
 151   let tr = (fromPhysical st) + (fromPhysical wid)
 152       f t = if (fromPhysical t) < (fromPhysical st) then (toPhysical 0.0)
 153             else if (fromPhysical t) < tr then lvl else (toPhysical 0.0)
 154   in FunctionRep f
 155 trap:: (Physical a, Physical b) => a -> a -> a -> a -> b ->
 156                                    SignalRep a b
 157 trap st r wid f lvl =
 158   let stepSlope y y' t = realdiv (y' -  y) (fromPhysical t)
 159       bigwin = realmul 10000000 ((fromPhysical st) + (fromPhysical wid))
 160       wins = Window LocalZero (TimeEvent (fromPhysical st)) (constant (toPhysical 0.0)) |>
 161              Window LocalZero (TimeEvent (fromPhysical r)) (linear (stepSlope 0.0 (fromPhysical lvl) r) (toPhysical 0.0)) |>
 162              Window LocalZero (TimeEvent (fromPhysical wid)) (constant lvl) |>
 163              Window LocalZero (TimeEvent (fromPhysical f)) (linear (stepSlope (fromPhysical lvl) 0.0 f) lvl) |>
 164              Window LocalZero (TimeEvent bigwin) (constant (toPhysical 0.0)) |>
 165              nullWindow
 166   in PieceContRep wins
 167 expc:: (Physical a, Physical b) => Float -> SignalRep a b
 168 expc damp = FunctionRep (\t -> toPhysical (exp (- (realmul (fromPhysical t) damp))))
 169 data {- (Physical indep, Physical dep) => -} BasicSignal indep dep =
 170     Overshoot {start_delay::indep,
 171                pulse_width::indep,
 172                ringing::dep,
 173                oscillation::Frequency,
 174                damp_fac::Float}
 175   | Pulse_dc {start_delay::indep,
 176               pulse_width::indep,
 177               rise_time::indep,
 178               fall_time::indep,
 179               period::indep,
 180               dc_offset::dep,
 181               amplitude::dep,
 182               over::BasicSignal indep dep,
 183               under::BasicSignal indep dep}
 184   | Pulse_ac {start_delay::indep,
 185               pulse_width::indep,
 186               period::indep,
 187               dc_offset::dep,
 188               amplitude::dep,
 189               frequency::Frequency,
 190               phase::Float}
 191   deriving (Eq, Show)
 192
 193 data {- (Eq a, Eq b) => -} Foo a b = Foo { x :: a, y :: b}
 194
 195 foo :: (Eq a, Eq b) => Foo a b
 196 foo = Foo{}
 197
 198 {-
 199 overshoot:: (Physical a, Physical b) => BasicSignal a b
 200 overshoot = Overshoot{}
 201 pulse_dc:: (Physical a, Physical b) => BasicSignal a b
 202 pulse_dc = Pulse_dc {over = Overshoot{start_delay=toPhysical 0.0,
 203                                             ringing=(toPhysical 0.0),
 204                                             oscillation=toPhysical 1.0,
 205                                             damp_fac=1.0},
 206                      under = Overshoot{start_delay=toPhysical 0.0,
 207                                              ringing=(toPhysical 0.0),
 208                                              oscillation=toPhysical 1.0,
 209                                              damp_fac=1.0},
 210                      start_delay = toPhysical 0.0,
 211                      dc_offset = toPhysical 0.0}
 212
 213 pulse_ac:: (Physical a, Physical b) => BasicSignal a b
 214 pulse_ac = Pulse_ac {dc_offset = toPhysical 0.0,
 215                      amplitude = toPhysical 0.0}
 216 -}
 217
 218 makeWin:: (Physical a, Physical b) => a -> a ->
 219            SignalRep a b -> SignalRep a b
 220 makeWin st wid sig =
 221   let wins = Window LocalZero (TimeEvent (fromPhysical st)) (constant (toPhysical 0.0)) |>
 222              Window LocalZero (TimeEvent (fromPhysical wid)) sig |>
 223              nullWindow
 224   in PieceContRep wins
 225 instance Signal BasicSignal where
 226   toSig Overshoot{start_delay,pulse_width,
 227                   ringing,oscillation,damp_fac} =
 228     let ring = sine ringing oscillation 0.0
 229         cond = asTypeOf (expc damp_fac) ring
 230         sig = temp ring cond
 231         temp:: (Physical a, Physical b) => SignalRep a b ->
 232                 SignalRep a b -> SignalRep a b
 233         temp f g = FunctionRep (binop (*) (mapSignal f) (mapSignal g))
 234 --        temp f g = f * g
 235 --        temp f g = asTypeOf (f * g) ring
 236         wins = Window LocalZero (TimeEvent (fromPhysical start_delay)) (constant (toPhysical 0.0)) |>
 237                Window LocalZero (TimeEvent (fromPhysical pulse_width)) sig |>
 238                nullWindow
 239     in PieceContRep wins
 240   toSig Pulse_dc{start_delay,rise_time,pulse_width,fall_time,
 241                  dc_offset,period,amplitude,over,under} =
 242     let pul = trap start_delay rise_time pulse_width fall_time amplitude
 243         so = toPhysical ((fromPhysical start_delay) + (fromPhysical rise_time))
 244         su = toPhysical ((fromPhysical so) + (fromPhysical pulse_width) + (fromPhysical fall_time))
 245         oversh = toSig over{start_delay=so}
 246         undersh = toSig under{start_delay=su}
 247         off = constant dc_offset
 248         temp:: (Physical a, Physical b) => SignalRep a b ->
 249                 SignalRep a b -> SignalRep a b
 250         temp f g = FunctionRep (binop (+) (mapSignal f) (mapSignal g))
 251         sig = temp (temp (temp pul oversh) undersh) off
 252         wins = (Window LocalZero (TimeEvent (fromPhysical period)) sig) |>
 253                 nullWindow
 254     in PieceContRep (cycleWindows wins)
 255 sumSig:: (Physical a, Physical b, Signal s, Signal s') =>
 256          (s a b) -> (s' a b) -> SignalRep a b
 257 sumSig f f' =
 258    let s1 t = fromPhysical (mapSignal f t)
 259        s2 t = fromPhysical (mapSignal f' t)
 260    in FunctionRep (\t -> toPhysical ((s1 t) + (s2 t)))
 261 mulSig:: (Physical a, Physical b, Signal s, Signal s') =>
 262          (s a b) -> (s' a b) -> SignalRep a b
 263 mulSig f f' =
 264    let f1 t = fromPhysical (mapSignal f t)
 265        f2 t = fromPhysical (mapSignal f' t)
 266    in FunctionRep (\t -> toPhysical ((f1 t) * (f2 t)))
 267
 268 eventEps:: Float -> Float
 269 eventEps x = let eps = realdiv x 1000 in if 0.01 < eps then 0.01 else eps