+++ /dev/null
-{-# OPTIONS -H12m -package lang #-}
-
-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
projects / ghc-hetmet.git / blobdiff