summaryrefslogtreecommitdiff
path: root/testsuite/tests/programs/barton-mangler-bug/Basic.hs
diff options
context:
space:
mode:
Diffstat (limited to 'testsuite/tests/programs/barton-mangler-bug/Basic.hs')
-rw-r--r--testsuite/tests/programs/barton-mangler-bug/Basic.hs287
1 files changed, 287 insertions, 0 deletions
diff --git a/testsuite/tests/programs/barton-mangler-bug/Basic.hs b/testsuite/tests/programs/barton-mangler-bug/Basic.hs
new file mode 100644
index 0000000000..1597a86d2f
--- /dev/null
+++ b/testsuite/tests/programs/barton-mangler-bug/Basic.hs
@@ -0,0 +1,287 @@
+
+module Basic where
+import TypesettingTricks
+--import Int( Num(fromInt) )
+import Physical
+--import GHC( (->) )
+infixr 7 |>
+class Signal s where
+ mapSignal:: (Physical a, Physical b) => (s a b) -> a -> b
+ mapSigList:: (Physical a, Physical b) => (s a b) -> [a] -> [b]
+ toSig:: (Physical a, Physical b) => (s a b) -> SignalRep a b
+ mapSignal = mapSignal . toSig
+ mapSigList = map . mapSignal
+ toSig = FunctionRep . mapSignal
+instance Signal (->) where
+ mapSignal f = f
+ toSig = FunctionRep
+data {- (Physical a, Physical b) => -} SignalRep a b =
+ FunctionRep (a -> b) |
+ PieceContRep (PieceCont a b)
+
+instance Eq (SignalRep a b) where
+ (==) a b = error "No equality for SignalRep"
+
+instance Show (SignalRep a b) where
+ show sr = error "No show for SignalRep"
+
+instance Signal SignalRep where
+ mapSignal (FunctionRep f) = mapSignal f
+ mapSignal (PieceContRep f) = mapSignal f
+ mapSigList (FunctionRep f) = mapSigList f
+ mapSigList (PieceContRep f) = mapSigList f
+ toSig = id
+instance (Physical a, Physical b) => Eq (a -> b) where
+ a == b = error "Attempt to apply equality to functions"
+binop:: (Physical a, Physical b) => (Float -> Float -> Float) ->
+ (a -> b) -> (a -> b) -> a -> b
+binop op f g t = toPhysical ((fromPhysical (f t)) `op` (fromPhysical (g t)))
+unop:: (Physical a, Physical b ) => (Float -> Float) ->
+ (a -> b) -> a -> b
+unop op f t = toPhysical (op (fromPhysical (f t)))
+instance (Physical a, Physical b) => Num (SignalRep a b) where
+ f + g = FunctionRep (binop (+) (mapSignal f) (mapSignal g))
+ f * g = FunctionRep (binop (*) (mapSignal f) (mapSignal g))
+ negate f = FunctionRep (unop negate (mapSignal f))
+ abs f = FunctionRep (unop abs (mapSignal f))
+ signum f = FunctionRep (unop abs (mapSignal f))
+ fromInteger i = FunctionRep (\t -> toPhysical (fromInteger i))
+ --fromInt i = FunctionRep (\t -> toPhysical (fromInt i))
+instance (Physical a, Physical b) =>
+ Fractional (SignalRep a b) where
+ f / g = FunctionRep (binop (/) (mapSignal f) (mapSignal g))
+ fromRational r = FunctionRep (\t -> (toPhysical (fromRational r)))
+instance (Physical a, Physical b) =>
+ Floating (SignalRep a b) where
+ pi = FunctionRep (\t -> (toPhysical pi))
+ exp f = FunctionRep (unop exp (mapSignal f))
+ log f = FunctionRep (unop log (mapSignal f))
+ sin f = FunctionRep (unop sin (mapSignal f))
+ cos f = FunctionRep (unop cos (mapSignal f))
+ asin f = FunctionRep (unop asin (mapSignal f))
+ acos f = FunctionRep (unop acos (mapSignal f))
+ atan f = FunctionRep (unop atan (mapSignal f))
+ sinh f = FunctionRep (unop sinh (mapSignal f))
+ cosh f = FunctionRep (unop cosh (mapSignal f))
+ asinh f = FunctionRep (unop asinh (mapSignal f))
+ acosh f = FunctionRep (unop acosh (mapSignal f))
+ atanh f = FunctionRep (unop atanh (mapSignal f))
+data Event =
+ TimeEvent Float |
+ FunctionEvent (Float -> Bool) |
+ BurstEvent Int Event
+
+instance Show Event where
+ show (TimeEvent f) = "TimeEvent " ++ show f
+ show (FunctionEvent _) = "FunctionEvent"
+ show (BurstEvent i e) = "BurstEvent " ++ show i ++ " " ++ show e
+
+instance Eq Event where
+ (TimeEvent x) == (TimeEvent y) = x == y
+ (BurstEvent i e) == (BurstEvent i' e') = (i' == i) && (e' == e)
+eventOccurs:: Event -> Float -> Float
+eventOccurs (TimeEvent t) x = if x < t then x else t
+eventOccurs (FunctionEvent f) x = stepEval f x
+eventOccurs (BurstEvent i e) x =
+ if i == 1 then
+ eventOccurs e x
+ else
+ eventOccurs (BurstEvent (i-1) e) ((eventOccurs e x) + eventEps x)
+stepEval:: (Float -> Bool) -> Float -> Float
+stepEval f x = if f x then x else stepEval f (x + eventEps x)
+data ZeroIndicator = LocalZero | GlobalZero deriving (Eq, Show)
+data {- (Physical a, Physical b) => -} FunctionWindow a b =
+ Window ZeroIndicator Event (SignalRep a b)
+ deriving (Eq, Show)
+data PieceCont a b = Windows [FunctionWindow a b]
+ deriving (Eq, Show)
+instance Signal PieceCont where
+ mapSignal (Windows []) t = toPhysical 0.0
+ mapSignal (Windows wl) t = (mapSignal s) (toPhysical t')
+ where (t', (Window z e s), wl') = getWindow 0.0 (fromPhysical t) wl
+ toSig = PieceContRep
+getWindow:: (Physical a, Physical b) =>
+ Float -> Float -> [ FunctionWindow a b ] ->
+ (Float, FunctionWindow a b, [ FunctionWindow a b ])
+getWindow st t [] = (t, Window LocalZero e f, [])
+ where e = TimeEvent (realmul 2 t)
+ f = FunctionRep (\t -> toPhysical 0.0)
+getWindow st t (w:wl) = if t' <= wt then (t',w,w:wl)
+ else getWindow (st+wt) t wl
+ where wt = eventOccurs e t'
+ (Window z e s) = w
+ t' = if z == LocalZero then t-st else t
+(|>) :: (Physical a, Physical b) => FunctionWindow a b ->
+ PieceCont a b -> PieceCont a b
+w |> (Windows wl) = Windows (w:wl)
+nullWindow = Windows []
+cycleWindows:: (Physical a, Physical b) =>
+ PieceCont a b -> PieceCont a b
+cycleWindows (Windows wl) = Windows (cycle wl)
+constant:: (Physical a, Physical b) => b -> SignalRep a b
+constant x = FunctionRep (\t -> x)
+linear:: (Physical a, Physical b) => Float -> b -> SignalRep a b
+linear m b = FunctionRep (\x -> toPhysical (realmul m (fromPhysical x) + (fromPhysical b)))
+sine:: (Physical a, Physical b) =>
+ b -> Frequency -> Float -> SignalRep a b
+sine mag omeg phase = FunctionRep (\x -> toPhysical (realmul (fromPhysical mag) (sin (realmul (realmul (realmul 2 pi) (fromPhysical omeg)) (fromPhysical x) + phase))))
+waveform:: (Physical a, Physical b) => a -> [b] -> SignalRep a b
+waveform samp ampls =
+ let stepSlope y y' = realdiv ((fromPhysical y') - (fromPhysical y)) (fromPhysical samp)
+ makeWin (v,v') = Window LocalZero (TimeEvent (fromPhysical samp))
+ (linear (stepSlope v v') v)
+ points = cycle ampls
+ in PieceContRep (Windows (map makeWin (zip points (tail points))))
+random:: (Physical a, Physical b) =>
+ Integer -> a -> SignalRep a b
+random i s = waveform s (map toPhysical (rand i))
+ramp:: (Physical a, Physical b) => a -> b -> SignalRep a b
+ramp per v =
+ let sig = linear (realdiv (fromPhysical v) (fromPhysical per)) (toPhysical 0.0)
+ in PieceContRep (Windows (cycle ([Window LocalZero (TimeEvent (fromPhysical per)) sig ])))
+triangle:: (Physical a, Physical b) => a -> b -> SignalRep a b
+triangle per v =
+ let sl = realmul 2.0 (realdiv (fromPhysical v) (fromPhysical per))
+ qper = realdiv (fromPhysical v) 4.0
+ wins = (Window LocalZero (TimeEvent qper) (linear sl (toPhysical 0.0))) |>
+ (Window LocalZero (TimeEvent (realmul 2.0 qper)) (linear (- sl) v)) |>
+ (Window LocalZero (TimeEvent qper) (linear sl (toPhysical (- (fromPhysical v))))) |>
+ nullWindow
+ in PieceContRep (cycleWindows wins)
+step:: (Physical a, Physical b) => a -> b -> SignalRep a b
+step tr lvl = FunctionRep (\t -> if (fromPhysical t) < (fromPhysical tr) then (toPhysical 0.0) else lvl)
+square:: (Physical a, Physical b) => a -> b -> SignalRep a b
+square per lvl =
+ let trans = realdiv (fromPhysical per) 2.0
+ nlvl = asTypeOf (toPhysical (- (fromPhysical lvl))) lvl
+ f t = if (fromPhysical t) < trans then lvl else nlvl
+ wins = Windows [Window LocalZero (TimeEvent (fromPhysical per)) (FunctionRep f)]
+ in PieceContRep (cycleWindows wins)
+pulse:: (Physical a, Physical b) => a -> a -> b -> SignalRep a b
+pulse st wid lvl =
+ let tr = (fromPhysical st) + (fromPhysical wid)
+ f t = if (fromPhysical t) < (fromPhysical st) then (toPhysical 0.0)
+ else if (fromPhysical t) < tr then lvl else (toPhysical 0.0)
+ in FunctionRep f
+trap:: (Physical a, Physical b) => a -> a -> a -> a -> b ->
+ SignalRep a b
+trap st r wid f lvl =
+ let stepSlope y y' t = realdiv (y' - y) (fromPhysical t)
+ bigwin = realmul 10000000 ((fromPhysical st) + (fromPhysical wid))
+ wins = Window LocalZero (TimeEvent (fromPhysical st)) (constant (toPhysical 0.0)) |>
+ Window LocalZero (TimeEvent (fromPhysical r)) (linear (stepSlope 0.0 (fromPhysical lvl) r) (toPhysical 0.0)) |>
+ Window LocalZero (TimeEvent (fromPhysical wid)) (constant lvl) |>
+ Window LocalZero (TimeEvent (fromPhysical f)) (linear (stepSlope (fromPhysical lvl) 0.0 f) lvl) |>
+ Window LocalZero (TimeEvent bigwin) (constant (toPhysical 0.0)) |>
+ nullWindow
+ in PieceContRep wins
+expc:: (Physical a, Physical b) => Float -> SignalRep a b
+expc damp = FunctionRep (\t -> toPhysical (exp (- (realmul (fromPhysical t) damp))))
+data {- (Physical indep, Physical dep) => -} BasicSignal indep dep =
+ Overshoot {start_delay::indep,
+ pulse_width::indep,
+ ringing::dep,
+ oscillation::Frequency,
+ damp_fac::Float}
+ | Pulse_dc {start_delay::indep,
+ pulse_width::indep,
+ rise_time::indep,
+ fall_time::indep,
+ period::indep,
+ dc_offset::dep,
+ amplitude::dep,
+ over::BasicSignal indep dep,
+ under::BasicSignal indep dep}
+ | Pulse_ac {start_delay::indep,
+ pulse_width::indep,
+ period::indep,
+ dc_offset::dep,
+ amplitude::dep,
+ frequency::Frequency,
+ phase::Float}
+ deriving (Eq, Show)
+
+data {- (Eq a, Eq b) => -} Foo a b = Foo { x :: a, y :: b}
+
+foo :: (Eq a, Eq b) => Foo a b
+foo = Foo{}
+
+{-
+overshoot:: (Physical a, Physical b) => BasicSignal a b
+overshoot = Overshoot{}
+pulse_dc:: (Physical a, Physical b) => BasicSignal a b
+pulse_dc = Pulse_dc {over = Overshoot{start_delay=toPhysical 0.0,
+ ringing=(toPhysical 0.0),
+ oscillation=toPhysical 1.0,
+ damp_fac=1.0},
+ under = Overshoot{start_delay=toPhysical 0.0,
+ ringing=(toPhysical 0.0),
+ oscillation=toPhysical 1.0,
+ damp_fac=1.0},
+ start_delay = toPhysical 0.0,
+ dc_offset = toPhysical 0.0}
+
+pulse_ac:: (Physical a, Physical b) => BasicSignal a b
+pulse_ac = Pulse_ac {dc_offset = toPhysical 0.0,
+ amplitude = toPhysical 0.0}
+-}
+
+makeWin:: (Physical a, Physical b) => a -> a ->
+ SignalRep a b -> SignalRep a b
+makeWin st wid sig =
+ let wins = Window LocalZero (TimeEvent (fromPhysical st)) (constant (toPhysical 0.0)) |>
+ Window LocalZero (TimeEvent (fromPhysical wid)) sig |>
+ nullWindow
+ in PieceContRep wins
+instance Signal BasicSignal where
+ toSig (Overshoot start_delay pulse_width ringing oscillation damp_fac) =
+ let ring = sine ringing oscillation 0.0
+ cond = asTypeOf (expc damp_fac) ring
+ sig = temp ring cond
+ temp:: (Physical a, Physical b) => SignalRep a b ->
+ SignalRep a b -> SignalRep a b
+ temp f g = FunctionRep (binop (*) (mapSignal f) (mapSignal g))
+-- temp f g = f * g
+-- temp f g = asTypeOf (f * g) ring
+ wins = Window LocalZero (TimeEvent (fromPhysical start_delay)) (constant (toPhysical 0.0)) |>
+ Window LocalZero (TimeEvent (fromPhysical pulse_width)) sig |>
+ nullWindow
+ in PieceContRep wins
+ toSig Pulse_dc{ start_delay = start_delay
+ , rise_time = rise_time
+ , pulse_width = pulse_width
+ , fall_time = fall_time
+ , dc_offset = dc_offset
+ , period = period
+ , amplitude = amplitude
+ , over = over
+ , under = under
+ } =
+ let pul = trap start_delay rise_time pulse_width fall_time amplitude
+ so = toPhysical ((fromPhysical start_delay) + (fromPhysical rise_time))
+ su = toPhysical ((fromPhysical so) + (fromPhysical pulse_width) + (fromPhysical fall_time))
+ oversh = toSig over{start_delay=so}
+ undersh = toSig under{start_delay=su}
+ off = constant dc_offset
+ temp:: (Physical a, Physical b) => SignalRep a b ->
+ SignalRep a b -> SignalRep a b
+ temp f g = FunctionRep (binop (+) (mapSignal f) (mapSignal g))
+ sig = temp (temp (temp pul oversh) undersh) off
+ wins = (Window LocalZero (TimeEvent (fromPhysical period)) sig) |>
+ nullWindow
+ in PieceContRep (cycleWindows wins)
+sumSig:: (Physical a, Physical b, Signal s, Signal s') =>
+ (s a b) -> (s' a b) -> SignalRep a b
+sumSig f f' =
+ let s1 t = fromPhysical (mapSignal f t)
+ s2 t = fromPhysical (mapSignal f' t)
+ in FunctionRep (\t -> toPhysical ((s1 t) + (s2 t)))
+mulSig:: (Physical a, Physical b, Signal s, Signal s') =>
+ (s a b) -> (s' a b) -> SignalRep a b
+mulSig f f' =
+ let f1 t = fromPhysical (mapSignal f t)
+ f2 t = fromPhysical (mapSignal f' t)
+ in FunctionRep (\t -> toPhysical ((f1 t) * (f2 t)))
+
+eventEps:: Float -> Float
+eventEps x = let eps = realdiv x 1000 in if 0.01 < eps then 0.01 else eps
View Lorry Controller Status