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

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