Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP

Comparing changes

Choose two branches to see what's changed or to start a new pull request. If you need to, you can also compare across forks.

Open a pull request

Create a new pull request by comparing changes across two branches. If you need to, you can also compare across forks.
base fork: rocketnia/underreact
base: 1635ecd583
...
head fork: rocketnia/underreact
compare: 865ccdb1a2
Checking mergeability… Don't worry, you can still create the pull request.
  • 8 commits
  • 1 file changed
  • 0 commit comments
  • 1 contributor
Showing with 140 additions and 430 deletions.
  1. +140 −430 underreact-rdpio.js
View
570 underreact-rdpio.js
@@ -676,21 +676,15 @@ var class_SigTime = makeClass( {
var class_Signal = makeClass( {
ins_SigTime: null,
- s_invert: null,
+ s_sample: null,
s_never: null,
+ s_drop: null,
+ s_invert: null,
s_mask: null,
s_zip: null,
s_merge: null,
- s_drop: null,
- su_drop: null,
s_delay: null,
- su_delay: null,
- // PORT TODO: Make sure to implement su_apply curried, with one
- // parameter leading into one other.
- su_apply: null,
- su_time: null,
s_future: null,
- s_sample: null,
s_final: function ( s, t ) {
return false;
}
@@ -718,26 +712,17 @@ SigUpT_SUFuture.prototype.init = function () {
var class_SigFun = makeClass( {
ins_Signal: null,
- s_fmap: null,
- su_fmap: function ( f ) {
- return new SigUpT_SUFuture().init();
- }
+ s_fmap: null
} );
var class_SigSplit = makeClass( {
ins_Signal: null,
- s_split: null,
- su_split: function () {
- return new SigUpT_SUFuture().init();
- }
+ s_split: null
} );
var class_SigPeek = makeClass( {
ins_Signal: null,
- s_peek: null,
- su_peek: function ( dt ) {
- return new SigUpT_SUFuture().init();
- }
+ s_peek: null
} );
var class_SigSelect = makeClass( {
@@ -753,34 +738,26 @@ var class_SigDiscrete = makeClass( {
var class_SigShadow = makeClass( {
ins_Signal_of: null,
ins_Signal_as: null,
- s_shadow: null,
- su_shadow: null
+ s_shadow: null
} );
var class_SigLift = makeClass( {
ins_SigShadow: null,
- s_lift: null,
- su_lift: function () {
- return new SigUpT_SUFuture().init();
- }
+ s_lift: null
} );
function ins_Signal_SigShadow( ins_Signal ) {
return makeInstance( class_SigShadow, {
ins_Signal_of: ins_Signal,
ins_Signal_as: ins_Signal,
- s_shadow: id,
- su_shadow: id
+ s_shadow: id
} );
}
function ins_Signal_SigLift( ins_Signal ) {
return makeInstance( class_SigLift, {
ins_SigShadow: ins_Signal_SigShadow( ins_Signal ),
- s_lift: id,
- su_lift: function () {
- return new SigUpT_SUPure().init( id );
- }
+ s_lift: id
} );
}
@@ -805,8 +782,7 @@ function s_alt( ins_Functor, ins_Signal, a, b ) {
var class_SigAdjeqf = makeClass( {
ins_Signal: null,
- s_adjeqf: null,
- su_adjeqf: null
+ s_adjeqf: null
} );
@@ -885,7 +861,9 @@ var class_HasVar = makeClass( {
+// ===================================================================
// Vat.lhs
+// ===================================================================
var class_Vat = makeClass( {
ins_Monad: null,
@@ -916,36 +894,6 @@ var class_ClockedVat = makeClass( {
getMinCycle: null
} );
-function newChokedEvent(
- ins_TimedVat, ins_HasVar, ins_Ord, cooldown, op ) {
-
- var m = ins_TimedVat.ins_Monad;
- var c = ins_TimedVat.ins_HasClock;
- return m.bind( op, c.getTime(), function ( tCreate ) {
- return m.bind( ins_HasVar.newVar( [ tCreate, false ] ),
- function ( st ) {
-
- var chokedOp = m.bind( ins_HasVar.readVar( st ),
- function ( stVal ) {
-
- var tMin = stVal[ 0 ], bSched = stVal[ 1 ];
- return m.bind( c.getTime(), function ( tNow ) {
- if ( ins_Ord.lt( tNow, tMin ) )
- return unless( m, bSched, m.then(
- ins_HasVar.writeVar( st, [ tMin, true ] ),
- ins_TimedVat.atTime( tMin, chokedOp ) ) );
- var tNext = ins_TimedVat.ins_AffineSpace.plusDiff(
- tNow, cooldown );
- return m.then(
- ins_HasVar.writeVar( st, [ tNext, false ] ),
- op );
- } );
- } );
- return m.ret( chokedOp );
- } );
- } );
-}
-
// ===================================================================
@@ -1082,8 +1030,7 @@ var class_BPeek = makeClass( {
var class_BDyn = makeClass( {
ins_BSig: null,
- ins_BProdBase: null,
- ins_BSumBase: null,
+ ins_BJoin: null,
beval: null,
bexec: null
} );
@@ -1122,6 +1069,18 @@ function pip( ins_Callable, fxy, fyz, xAndZcb ) {
return fxy( [ x, ycb ] );
}
+function fpip( fxy, fyz, xAndZcb ) {
+ var x = xAndZcb[ 0 ], zcb = xAndZcb[ 1 ];
+ return fyz( [ fxy( x ), zcb ] );
+}
+
+function pipf( fxy, fyz, xAndZcb ) {
+ var x = xAndZcb[ 0 ], zcb = xAndZcb[ 1 ];
+ return fxy( [ x, function ( y ) {
+ return zcb( fyz( y ) );
+ } ] );
+}
+
function tee( ins_Callable, fn ) {
return function ( xAndXcb ) {
var x = xAndXcb[ 0 ], xcb = xAndXcb[ 1 ];
@@ -1153,97 +1112,17 @@ var class_ChanCB = makeClass( {
function callAndWait( ins_ChanCB, fn, x ) {
var m = ins_IO_Monad;
return m.bind( newChan(), function ( ch ) {
- return m.bind( ins_ChanCB.mkcbChan( id, ch ), function ( chcb ) {
- return m.then( call( ins_ChanCB.ins_Callable, fn, x, chcb ),
+ return m.bind( ins_ChanCB.mkcbChan( ch ), function ( cbch ) {
+ return m.then( call( ins_ChanCB.ins_Callable, fn, x, cbch ),
readChan( ch ) );
} );
} );
}
-var class_StepCB = makeClass( {
- ins_Callable: null,
- mkcbRedirect: null,
- mkcbProc: function ( cbp0 ) {
- var c = this.ins_Callable;
- return c.ins_Monad.bind( this.mkcbRedirect(),
- function ( curAndUpd ) {
- var cur = curAndUpd[ 0 ], upd = curAndUpd[ 1 ];
- var step0 = cbpStepper( c.ins_Monoid, upd, cbp0 );
- return c.ins_Monad.then(
- c.call0( upd, step0 ), c.ins_Monad.ret( cur ) );
- } );
- }
-} );
-
-function cbpStepper( ins_Monoid, upd, cbp ) {
- return function ( x ) {
- var cbNowAndCbpPrime = cbp.runCBProc( x );
- var cbNow = cbNowAndCbpPrime[ 0 ];
- var cbpPrime = cbNowAndCbpPrime[ 1 ];
- var next = cbpStepper( upd, cbpPrime );
- return ins_Monoid.mappend( upd( next ), cbNow );
- };
-}
-
-function CBProc_CBProc() {}
-CBProc_CBProc.prototype.init = function ( runCBProc ) {
- this.runCBProc = function ( x ) {
- return runCBProc( x );
- };
- return this;
-};
-
-function cbpAlways( fn ) {
- var cbp = new CBProc_CBProc().init( function ( x ) {
- return [ fn( x ), cbp ];
- } );
- return cbp;
-}
-
-function cbpNever( ins_Monoid ) {
- return cbpAlways( kfn( ins_Monoid.mempty() ) );
-}
-
-function cbpCons( fn, getCbp ) {
- return new CBProc_CBProc().init( function ( x ) {
- return [ fn( x ), getCbp() ];
- } );
-}
-
-function cbpFromList( ins_Monoid, list ) {
- if ( list instanceof List_Nil )
- return cbpNever( ins_Monoid );
- var x = list.getCar(), xs = list.getCdr();
- return cbpCons( x, function () { return cbpFromList( xs ); } );
-}
-
-function mkcbOnce0( ins_VatCB, ins_StepCB, op ) {
- return ins_VatCB.ins_Callable.ins_Monad.bind(
- ins_VatCB.mkcb0( op ), function ( fn ) {
- return ins_StepCB.mkcbProc( cbpCons( fn, function () {
- return cbpNever( ins_VatCB.ins_Callable.ins_Monoid );
- } ) );
- } );
-}
-
-function mkcbOnce( ins_VatCB, ins_StepCB, op ) {
- return mkcbOnce0( ins_VatCB, ins_StepCB, function ( aAndBcb ) {
- var a = aAndBcb[ 0 ], bcb = aAndBcb[ 1 ];
- var c = ins_VatCB.ins_Callable;
- return c.ins_Monad.bind( op( a ), function ( b ) {
- return c.call0( bcb( b ) );
- } );
- } );
-}
-
function method( ins_VatCB, op ) {
return mkcb( ins_VatCB, op );
}
-function monce( ins_VatCB, ins_StepCB, op ) {
- return mkcbOnce( ins_VatCB, ins_StepCB, op );
-}
-
// ===================================================================
@@ -1257,16 +1136,16 @@ LinkUp_LinkUp.prototype.init = function ( lu_update, lu_stable ) {
return this;
};
+// PORT TODO: See if we really need to pass this instance. It was used
+// when SigUp existed, but now our SigUp values are pairs instead.
function lu_time( ins_Signal, linkUp ) {
- return ins_Maybe_Functor.fmap( function ( lu_update ) {
- return ins_Signal.su_time( lu_update );
- } )( linkUp.getLu_update() );
+ return ins_Maybe_Functor.fmap( fst )( linkUp.getLu_update() );
}
-function luTerminate( ins_Signal, tmTerm ) {
- var su = ins_Signal.s_future( tmTerm, ins_Signal.s_never() );
+function luTerminate( ins_Signal, tm ) {
return new LinkUp_LinkUp.init(
- new Maybe_Just().init( su ), new Maybe_Nothing().init() );
+ new Maybe_Just().init( [ tm, ins_Signal.s_never() ] ),
+ new Maybe_Nothing().init() );
}
var class_Link = makeClass( {
@@ -1276,6 +1155,12 @@ var class_Link = makeClass( {
mkLinkDrop: null
} );
+
+
+// ===================================================================
+// BLink.lhs
+// ===================================================================
+
var class_BLink = makeClass( {
ins_HasVar: null,
ins_Link: null,
@@ -1290,9 +1175,9 @@ var class_BLink = makeClass( {
} );
// mkBLink_ ::
-// (BLink v b u t, BProd b, SigShadow u s t, SigShadow s u t)
-// => st -> ((BLRec t v st s ()) -> (LinkUp t s d) -> v ())
-// -> v (b (s d) (s ()))
+// (BLink v b u t, BProd b, SigShadow u s' t, SigShadow s' u t)
+// => st -> ((BLRec t v st s' ()) -> (LinkUp t s d) -> v ())
+// -> v (b (s d) (s' ()))
function mkBLinkDrop( ins_BLink, ins_BProd,
ins_SigShadow_out, ins_SigShadow_in, s0, cb ) {
@@ -1332,26 +1217,6 @@ BLMeta_BLMeta.prototype.init = function (
var blMetaDefault =
new BLMeta_BLMeta( !"bl_query", !!"bl_tsen", "BLink" );
-function linkUpdate(
- ins_Monad, ins_Signal, ins_HasClock, dt, luSend ) {
-
- var s = ins_Signal.ins_SigTime;
- var a = s.ins_AffineSpace;
- var dtf = s.ins_Ord.ins_Eq.eq(
- dt, a.ins_AdditiveGroup.zeroV() ) ? id :
- function ( t ) { return a.plusV( t, dt ); };
- return function ( sig ) {
- ins_Monad.bind( ins_HasClock.getTime(), function ( tNow ) {
- var tm = dtf( tNow );
- var su = ins_Signal.s_future( tm, sig );
- var lu = new LinkUp_LinkUp().init(
- new Maybe_Just().init( su ),
- new Maybe_Just().init( tm ) );
- return luSend( lu );
- } );
- };
-}
-
// mkLinkRef :: (BLink v b u t, SigShadow s u t, SigShadow u s t)
// => String -- ^ debug string
// -> Diff t -- ^ extra history to keep
@@ -1363,7 +1228,7 @@ function mkLinkRef(
var ignoreSub = kfn( ins_BLink.ins_HasVar.ins_Monad.ret( [] ) );
return mkLinkRefD( ins_BLink, ins_SigShadow_out, ins_SigShadow_in,
- sDebug, ignoreSub, dtHist );
+ sDebug, dtHist, ignoreSub );
}
// mkLinkRefD :: (BLink v b u t, SigShadow s u t, SigShadow u s t)
@@ -1375,7 +1240,7 @@ function mkLinkRef(
// ,b (s ()) (s x) -- ^ to share the reference
// )
function mkLinkRefD( ins_BLink, ins_SigShadow_out, ins_SigShadow_in,
- sDebug, onSub, dtHist ) {
+ sDebug, dtHist, onSub ) {
var v = ins_BLink.ins_HasVar;
var ins_Vat = ins_BLink.ins_Link.ins_Vat;
@@ -1395,22 +1260,23 @@ function mkLinkRefD( ins_BLink, ins_SigShadow_out, ins_SigShadow_in,
function ( vSig ) {
return m.bind( v.newVar( [ bigint( 1 ), dictEmpty() ] ),
function ( vObs ) {
- var onLU = lrefOnLU( s, ins_Vat, v, fdt, onSub, vSig, vObs );
- var onBL = lrefOnBL( s, ins_Vat, v, onSub, vSig, vObs );
+ var onLinkUp =
+ lrefOnLinkUp( s, ins_Vat, v, fdt, onSub, vSig, vObs );
+ var onBLConn = lrefOnBLConn( s, ins_Vat, v, onSub, vSig, vObs );
var blm =
new BLMeta_BLMeta().init( !!"bl_query", !!"bl_tsen", sDebug );
var st0 = [ 0, [ s.s_never(), new Maybe_Nothing().init() ] ];
return m.bind(
ins_BLink.mkBLink( ins_SigShadow_in, ins_SigShadow_out,
- blm, st0, onBL ),
+ blm, st0, onBLConn ),
function ( bl ) {
- return m.ret( [ onLU, bl ] );
+ return m.ret( [ onLinkUp, bl ] );
} );
} );
} );
}
-function lrefOnBL(
+function lrefOnBLConn(
ins_Signal, ins_Vat, ins_HasVar, onSub, vSig, vObs ) {
return function ( blr, lu ) {
@@ -1420,7 +1286,7 @@ function lrefOnBL(
function ( ixAndS0And_ ) {
var ix = ixAndS0And_[ 0 ], s0 = ixAndS0And_[ 1 ][ 0 ];
return m.bind( h.readVar( vSig ), function ( ls ) {
- var sf = maybe( s0, ins_Signal.su_apply( s0 ) )(
+ var sf = maybe( s0, su_apply( ins_Signal, s0 ) )(
lu.getLu_update() );
var tf = lu.getLu_stable();
if ( ls instanceof Maybe_Nothing )
@@ -1437,25 +1303,23 @@ function lrefOnBL(
var bdone = maybe( true, function ( tx ) {
return s_term( ins_Signal, sfc, tx );
} )( tx );
- var autoSubscribe = bdone ? lrefUnsubscribe : lrefSubscribe;
+ var autoSub = bdone ? lrefUnsubscribe : lrefSubscribe;
var lsm = ins_Signal.s_mask( sl, sf );
- var tu = lu_time( ins_Signal, lu );
var slu = ins_Maybe_Functor.fmap( function ( tu ) {
- return ins_Signal.s_future( tu, slm );
- } )( tu );
+ return su_future( ins_Signal, tu, slm );
+ } )( lu_time( ins_Signal, lu ) );
var lux = new LinkUp_LinkUp().init( slu, tx );
return m.then(
h.writeVar( blr.getBl_state(), [ ix, [ sfc, tf ] ] ),
m.then(
- autoSubscribe(
- ins_Signal, ins_Vat, h, onSub, vObs, blr ),
+ autoSub( ins_Signal, ins_Vat, h, onSub, vObs, blr ),
blr.getBl_link()( lux ) ) );
} );
} );
};
}
-function lrefOnLU(
+function lrefOnLinkUp(
ins_Signal, ins_Vat, ins_HasVar, cutHist, onSub, vSig, vObs ) {
return function ( lu ) {
@@ -1464,7 +1328,7 @@ function lrefOnLU(
return m.bind( h.readVar( vSig ), function ( ls ) {
var tl = lu.getLu_stable();
var sl0 = maybe( ins_Signal.s_never(), fst )( ls );
- var sl = maybe( sl0, ins_Signal.su_apply( sl0 ) )(
+ var sl = maybe( sl0, su_apply( ins_Signal, sl0 ) )(
lu.getLu_update() );
var sfc = maybe( ls, function ( tl ) {
return snd( ins_Signal.s_sample( sl, cutHist( tl ) ) );
@@ -1490,10 +1354,9 @@ function lrefOnLU(
return s_term( ins_Signal, sdc, tx );
} )( tx );
var slm = ins_Signal.s_mask( sl, sd );
- var tu = lu_time( ins_Signal, lu );
var slu = ins_Maybe_Functor.fmap( function ( tu ) {
- return ins_Signal.s_future( tu, slm );
- } )( tu );
+ return su_future( ins_Signal, tu, slm );
+ } )( lu_time( ins_Signal, lu ) );
var lux = new LinkUp_LinkUp().init( slu, tx );
return m.then(
h.writeVar(
@@ -1564,6 +1427,18 @@ function tmin( ins_Ord, x, y ) {
return new Maybe_Just().init( ins_Ord.min( x.just, y.just ) );
}
+function su_apply( ins_Signal, s0 ) {
+ return function ( tuAndSu ) {
+ var tu = tuAndSu[ 0 ], su = tuAndSu[ 1 ];
+ return ins_Signal.s_future( s0, tu, su );
+ };
+}
+
+function su_future( ins_Signal, tm, s0 ) {
+ var su = ins_Signal.s_sample( s0, tm )[ 1 ];
+ return [ tm, su ];
+}
+
// ===================================================================
@@ -1990,15 +1865,15 @@ function delReg( ins_Ord_t, ins_Ord_uid, ix, t, reg ) {
}
function delRegList( ins_Ord_t, ins_Ord_uid, ix, ts, reg ) {
- // PORT TODO: Implement foldl on List.
- return foldl( function ( a, b ) {
+ // PORT TODO: Implement foldlPrime on List.
+ return foldlPrime( function ( a, b ) {
return delReg( ins_Ord_t, ins_Ord_uid, ix, b, a );
}, reg, ts );
}
-function updReg( ins_Ord_t, ins_Ord_uid, ix, tAdd, tsDel, r ) {
+function updReg( ins_Ord_t, ins_Ord_uid, ix, tAdd, tsDel, reg ) {
return addReg( ins_Ord_t, ins_Ord_uid, ix, tAdd,
- delRegList( ins_Ord_t, ins_Ord_uid, ix, tsDel, r ) );
+ delRegList( ins_Ord_t, ins_Ord_uid, ix, tsDel, reg ) );
}
// PORT TODO: See if we really need to pass this instance. (We
@@ -2059,9 +1934,9 @@ function wakeupSleepers( ins_Ord_t, qref, tm ) {
{-# LANGUAGE GADTs, TypeOperators, Rank2Types #-}
-module RDP.Behavior
- ( S (..), OpMeta(..)
- , B (..)
+module RDP.BehADT
+ ( S (..)
+ , B (..), bsum, bprod
, BD (..), bdfst, bdsnd, bdonl, bdonr
, BMapFn, BMapMFn
, BFoldLFn, BFoldMLFn, BFoldMapLFn, BFoldMapMLFn
@@ -2070,67 +1945,12 @@ module RDP.Behavior
, bfoldmapl, bfoldmapml, bfoldl, bfoldml
, bfoldmapr, bfoldmapmr, bfoldr, bfoldmr
, QA(..), QL(..), QR(..), getA, getQ
- , bsimplify
) where
-import Data.AffineSpace
-import Data.AdditiveGroup
+import RDP.Signal
+import RDP.Behavior ((:&:),(:|:))
+import Data.AffineSpace (Diff)
import Control.Monad.Identity
-import RDP.RDSignal
-import RDP.RDBehavior ((:&:),(:|:))
-
--- Function types used in folds over maps.
-type BMapFn a a' x y = a x y -> a' x y
-type BMapMFn a a' m x y = a x y -> m (a' x y)
-type BFoldLFn u t l a x y = BD u t l x -> a x y -> BD u t l y
-type BFoldRFn u t l a x y = a x y -> BD u t l y -> BD u t l x
-type BFoldMLFn u t l a m x y = BD u t l x -> a x y -> m (BD u t l y)
-type BFoldMRFn u t l a m x y = a x y -> BD u t l y -> m (BD u t l x)
-type BFoldMapLFn u t l a a' x y = BD u t l x -> a x y -> (a' x y, BD u t l y)
-type BFoldMapRFn u t l a a' x y = a x y -> BD u t l y -> (BD u t l x, a' x y)
-type BFoldMapMLFn u t l a a' m x y = BD u t l x -> a x y -> m (a' x y, BD u t l y)
-type BFoldMapMRFn u t l a a' m x y = a x y -> BD u t l y -> m (BD u t l x, a' x y)
-
--- | some extra metadata to help with simplification
--- (so far just stuff from BLMeta)
-data OpMeta = OpMeta
- { op_show :: String -- ^ string for debugging
- , op_query :: Bool -- ^ behavior is query, or otherwise safe to drop
- , op_tsen :: Bool -- ^ behavior is time-sensitive, unsafe to time-shift
- }
-
--- | Signal operations.
--- Type `u` is a universal unit signal, and `t` is associated time.
--- Type `a` is for effects, eval, exec, and other extensions.
-data S u t a x y where
- -- Effects, Eval, Exec, Extensions, etc.
- Sop :: OpMeta -> a x y -> S u t a x y
-
- -- Value Manipulations.
- -- Sfmap comes with an extra string for `show`.
- Sfmap :: (SigFun f s t) => String -> f x y -> S u t a (s x) (s y)
- Sdrop :: (SigShadow u s t, SigShadow s u t) => S u t a x (s ())
- Sconv :: (SigShadow s' u t, SigLift s s' t) => S u t a (s x) (s' x)
-
- -- Value Composition (that requires touching signals)
- Sdup :: S u t a x (x :&: x)
- Smerge :: S u t a (x :|: x) x
- Sdisj :: S u t a (x :&: (y :|: z)) ((x :&: y) :|: (x :&: z))
- Sconj :: S u t a ((x :&: y) :|: (x :&: z)) (x :&: (y :|: z))
- Szip :: (Signal s t) => S u t a (s x :&: s y) (s (x,y))
- Ssplit :: (SigSplit s t) => S u t a (s (Either x y)) (s x :|: s y)
-
- -- Temporal Manipulations
- Sdelay :: (SigTime t) => Diff t -> S u t a x x
- Ssynch :: S u t a x x
- Speek :: (SigPeek s t) => Diff t -> S u t a (s x) (s () :|: s x)
- -- merge, zip, disjoin, and conjoin implicitly synch
-
--- NOTE:
--- Eval and Exec are handled as special operations (Sop)
--- to avoid direct dependency of S on B.
--- eval :: b x y -> ((s (b x y) :&: x) ~> y)
--- exec :: (s (b x y) :&: x) ~> s ()
-- | Data-plumbing behaviors
-- 'a' is the data processing and effect type
@@ -2158,12 +1978,19 @@ data B a x y where
Bmirr :: B a (x :|: y) (y :|: x)
Basl :: B a (x :|: (y :|: z)) ((x :|: y) :|: z)
+bsum :: B a x y -> B a x' y' -> B a (x :|: x') (y :|: y')
+bsum l r = Bolft l `Bseq` Bmirr `Bseq` Bolft r `Bseq` Bmirr
+
+bprod :: B a x y -> B a x' y' -> B a (x :&: x') (y :&: y')
+bprod l r = Bofst l `Bseq` Bswap `Bseq` Bofst r `Bseq` Bswap
+
-- | data about boundaries between behaviors (RDP specific)
-- Propagates shadow signals through the model:
-- SigShadow s u t is necessary for `bdrop`
-- SigShadow u s t is necessary for `bdisjoin` mask
data BD u t l x where
- BDSig :: (SigShadow s u t, SigShadow u s t) => l s a -> BD u t l (s a)
+ BDSig :: (SigShadow s u t, SigShadow u s t)
+ => l s a -> BD u t l (s a)
BDProd :: BD u t l x -> BD u t l y -> BD u t l (x :&: y)
BDSum :: BD u t l x -> BD u t l y -> BD u t l (x :|: y)
BDNull :: BD u t l x -- for dead code due to inl, inr, fst, snd
@@ -2197,10 +2024,57 @@ getQ = fst . unQA
getA :: QA q a x y -> a x y
getA = snd . unQA
+-- | Signal operations.
+-- Type `u` is a universal unit signal, and `t` is associated time.
+-- Type `a` is for Sop - effects, eval, exec, and other extensions.
+data S u t a x y where
+ -- Effects, Eval, Exec, Extensions, etc.
+ Sop :: a x y -> S u t a x y
+ -- Eval and Exec are handled via Sop because they refer back to
+ -- the parent kind B (I want to avoid direct dependency there).
+ -- eval :: Diff t -> b (s (b x y) :&: x) (u () :|: y)
+ -- exec :: b (s (b x (u ())) :&: x) (u () :|: u ())
+ -- Many effects would be achieved via mkBLink from RDP.Link, and
+ -- these are also represented via Sop.
+
+ -- Value Manipulations.
+ -- Sfmap comes with an extra string for `show`.
+ Sfmap :: (SigFun f s t) => String -> f x y -> S u t a (s x) (s y)
+ Sunit :: S u t a x (u ())
+ Suconv :: (SigShadow s u t, SigShadow u s t) => S u t a (u ()) (s ())
+ Sconv :: (SigShadow s' u t, SigShadow u s' t, SigLift s s' t)
+ => S u t a (s x) (s' x)
+
+ -- Value Composition (that require touching signals)
+ Sdup :: S u t a x (x :&: x)
+ Smerge :: S u t a (x :|: x) x
+ Sdisj :: S u t a (x :&: (y :|: z)) ((x :&: y) :|: (x :&: z))
+ Sconj :: S u t a ((x :&: y) :|: (x :&: z)) (x :&: (y :|: z))
+ Szip :: (SigShadow s u t) => S u t a (s x :&: s y) (s (x,y))
+ Ssplit :: (SigSplit s t) => S u t a (s (Either x y)) (s x :|: s y)
+
+ -- Temporal Manipulations
+ Sdelay :: (Signal u t) => Diff t -> S u t a x x
+ Ssynch :: S u t a x x
+ Speek :: (SigPeek s t) => Diff t -> S u t a (s x) (s () :|: s x)
+ -- drop, merge, zip, disjoin, and conjoin implicitly synch
+
----------------------------
-- BEHAVIOR FOLD MAP LEFT --
----------------------------
+-- Function types used in folds and maps.
+type BMapFn a a' x y = a x y -> a' x y
+type BMapMFn a a' m x y = a x y -> m (a' x y)
+type BFoldLFn u t l a x y = BD u t l x -> a x y -> BD u t l y
+type BFoldRFn u t l a x y = a x y -> BD u t l y -> BD u t l x
+type BFoldMLFn u t l a m x y = BD u t l x -> a x y -> m (BD u t l y)
+type BFoldMRFn u t l a m x y = a x y -> BD u t l y -> m (BD u t l x)
+type BFoldMapLFn u t l a a' x y = BD u t l x -> a x y -> (a' x y, BD u t l y)
+type BFoldMapRFn u t l a a' x y = a x y -> BD u t l y -> (BD u t l x, a' x y)
+type BFoldMapMLFn u t l a a' m x y = BD u t l x -> a x y -> m (a' x y, BD u t l y)
+type BFoldMapMRFn u t l a a' m x y = a x y -> BD u t l y -> m (BD u t l x, a' x y)
+
-- | Map a function and generate a value, with effects:
-- from left to right, first to second, inputs to outputs.
--
@@ -2349,168 +2223,6 @@ bfoldmr af b y0 = bfoldmapmr (bfoldmrf af) b y0 >>= return . fst
bfoldmrf :: (Monad m) => BFoldMRFn u t l a m d r
-> BFoldMapMRFn u t l a (B a) m d r
bfoldmrf af a y = af a y >>= \ x -> return (x, Bop a)
-
----------------------------
--- Simplifying Behaviors --
----------------------------
-
--- Listify a sequence. E.g. (f >>> (g >>> h)) >>> ((i >>> j) >>> k)
--- reduces to (f >>> (g >>> (h >>> (i >>> (j >>> k))))))
-bseqlist :: B a x y -> B a y z -> B a x z
-bseqlist (Bseq f g) h = bseqlist f (Bseq g h)
-bseqlist f (Bseq g h) = f `Bseq` bseqlist g h
-bseqlist f g = f `Bseq` g
-
--- simple list reductions. Assume `r` is simplified, i.e. simplify
--- starting from right hand side. Shifting of `drop` to left and
--- `delay` sufficient only to optimize across them.
-bsimplseq :: B (S u t a) x y -> B (S u t a) x y
-bsimplseq (Bseq Bfwd r) = r -- NOP in sequence
-bsimplseq (Bseq (Bofst Bfwd) r) = r -- NOP on first element
-bsimplseq (Bseq (Bolft Bfwd) r) = r -- NOP on left element.
- -- combine sequential actions on first element.
-bsimplseq (Bseq (Bofst f) (Bseq (Bofst f') r)) =
- (Bseq (Bofst (Bseq f f')) r)
-bsimplseq (Bseq (Bofst f) (Bseq Bswap
- (Bseq (Bofst g) (Bseq Bswap
- (Bseq (Bofst f') r))))) =
- (Bseq Bswap (Bseq (Bofst g)
- (Bseq Bswap (Bseq (Bofst (Bseq f f')) r))))
- -- combine sequential actions on left element
-bsimplseq (Bseq (Bolft f) (Bseq (Bolft f') r)) =
- (Bolft (Bseq f f') `Bseq` r)
-bsimplseq (Bseq (Bolft f) (Bseq Bmirr
- (Bseq (Bolft g) (Bseq Bmirr
- (Bseq (Bolft f') r))))) =
- (Bseq Bmirr (Bseq (Bolft g)
- (Bseq Bmirr (Bseq (Bolft (Bseq f f')) r))))
- -- basic reversible behaviors
-bsimplseq (Bseq Bswap (Bseq Bswap r)) = r -- swap/swap
-bsimplseq (Bseq Bmirr (Bseq Bmirr r)) = r -- mirror/mirror
-bsimplseq (Bseq (Bop Sconj) (Bseq (Bop Sdisj) r)) = r -- conjoin/disjoin
-bsimplseq (Bseq (Bop Sdisj) (Bseq (Bop Sconj) r)) = r -- disjoin/conjoin
- -- assoc-left and assoc-right, via swap3 or mirror3
-bsimplseq (Bseq (Bofst Bswap) (Bseq Bswap (Bseq Bapl
- (Bseq (Bofst Bswap) (Bseq Bswap (Bseq Bapl r)))))) = r
-bsimplseq (Bseq Bapl (Bseq (Bofst Bswap) (Bseq Bswap
- (Bseq Bapl (Bseq (Bofst Bswap) (Bseq Bswap r)))))) = r
-bsimplseq (Bseq (Bolft Bmirr) (Bseq Bmirr (Bseq Basl
- (Bseq (Bolft Bmirr) (Bseq Bmirr (Bseq Basl r)))))) = r
-bsimplseq (Bseq Basl (Bseq (Bolft Bmirr) (Bseq Bmirr
- (Bseq Basl (Bseq (Bolft Bmirr) (Bseq Bmirr r)))))) = r
- -- time-shifts and time merges
-bsimplseq (Bseq (Bop Ssynch) (Bseq (Bop Ssynch) r)) =
- (Bseq (Bop Ssynch) r)
-bsimplseq (Bseq (Bop (Sdelay d0)) (Bseq (Bop (Sdelay d1)) r)) =
- (Bseq (Bop (Sdelay (d0 ^+^ d1))) r)
-bsimplseq b@(Bseq (Bop (Sdelay dt)) (Bseq f r)) =
- if bshiftable f
- then (Bseq f (bsimplseq (Bseq (Bop (Sdelay dt)) r)))
- else b
- -- distribute drop across a product or sum.
-bsimplseq (Bseq (Bofst f) (Bseq d@(Bop Sdrop) r)) =
- let f' = (Bseq f (dupdrop d)) in
- (Bseq (Bofst f') (Bseq (Bop Sdrop) r))
-bsimplseq (Bseq (Bofst f) (Bseq Bswap
- (Bseq (Bofst g) (Bseq d@(Bop Sdrop) r)))) =
- let f' = (Bseq f (dupdrop d)) in
- (Bseq (Bofst f') (Bseq Bswap
- (Bseq (Bofst g) (Bseq (Bop Sdrop) r))))
-bsimplseq (Bseq (Bolft f) (Bseq d@(Bop Sdrop) r)) =
- let f' = (Bseq f (dupdrop d)) in
- (Bseq (Bolft f') (Bseq (Bop Sdrop) r))
-bsimplseq (Bseq (Bolft f) (Bseq Bmirr
- (Bseq (Bolft g) (Bseq d@(Bop Sdrop) r)))) =
- let f' = (Bseq f (dupdrop d)) in
- (Bseq (Bolft f') (Bseq Bmirr
- (Bseq (Bolft g) (Bseq (Bop Sdrop) r))))
- -- distribute drop across merge
-bsimplseq (Bseq (Bop Smerge) (Bseq d@(Bop Sdrop) r)) =
- (Bseq (Bolft (dupdrop d)) (Bseq Bmirr
- (Bseq (Bolft (dupdrop d)) (Bseq Bmirr
- (Bseq (Bop Smerge) (Bseq (Bop Sdrop) r))))))
- -- eliminate other droppable elements
-bsimplseq b@(Bseq f (Bseq (Bop Sdrop) r)) =
- if bdroppable f
- then (Bseq (Bop Sdrop) r)
- else b
- -- none of the above? call it simplified.
-bsimplseq b = b
-
--- dupdrop eliminates ambiguity in signal output type of the drop.
-dupdrop :: B (S u t a) x (s ()) -> B (S u t a) x' (s ())
-dupdrop (Bop Sdrop) = Bop Sdrop
-dupdrop _ = error "illegal dupdrop"
-
-
--- Shiftable means delay can be shifted to after this action. This
--- is a conservative estimate, supports other simplifications. Does
--- not split, dup, merge, or zip delays.
---
--- Droppable means that the behavior can be dropped if its output is
--- dropped. This is simplistic dead-code elimination.
-bshiftable, bdroppable :: B (S u t a) x y -> Bool
-sshiftable, sdroppable :: S u t a x y -> Bool
-
-bshiftable (Bop s) = sshiftable s
-bshiftable Bfwd = True
-bshiftable Bfst = True
-bshiftable Bswap = True
-bshiftable Bapl = True
-bshiftable Binl = True
-bshiftable Bmirr = True
-bshiftable Basl = True
-bshiftable _ = False
-
-bdroppable (Bop s) = sdroppable s
-bdroppable Bfwd = True
-bdroppable Bswap = True
-bdroppable Bapl = True
-bdroppable Binl = True
-bdroppable Bmirr = True
-bdroppable Basl = True
-bdroppable _ = False
-
-sshiftable (Sop m _) = not $ op_tsen m
-sshiftable (Sfmap _ _) = True
-sshiftable Sconv = True
-sshiftable Sdrop = True
-sshiftable Smerge = True
-sshiftable Sdisj = True
-sshiftable Sconj = True
-sshiftable Szip = True
-sshiftable Ssynch = True
-sshiftable _ = False
-
-sdroppable (Sop m _) = op_query m
-sdroppable (Sfmap _ _) = True
-sdroppable Sconv = True
-sdroppable Sdrop = True
-sdroppable Sdup = True
-sdroppable Sdisj = True
-sdroppable Sconj = True
-sdroppable Szip = True
-sdroppable Ssplit = True
-sdroppable (Speek _) = True
-sdroppable Ssynch = True
-sdroppable _ = False
-
--- simplify sequences from right to left.
-bsimplify' :: B (S u t a) x y -> B (S u t a) x y
-bsimplify' (Bseq f g) = bsimplseq (Bseq f (bsimplify' g))
-bsimplify' f = f
-
--- simplify sub-sequences and remove final `Bfwd`
-bsimplsub :: B (S u t a) x y -> B (S u t a) x y
-bsimplsub (Bseq f Bfwd) = bsimplsub f
-bsimplsub (Bseq f g) = Bseq (bsimplsub f) (bsimplsub g)
-bsimplsub (Bofst f) = Bofst (bsimplify f)
-bsimplsub (Bolft f) = Bolft (bsimplify f)
-bsimplsub f = f
-
--- | bsimplify is peephole simplification of a behavior.
-bsimplify :: B (S u t a) x y -> B (S u t a) x y
-bsimplify = bsimplsub . bsimplify' . flip bseqlist Bfwd
*/
@@ -2537,9 +2249,7 @@ DiscreteTimedSeq.lhs (header says DiscreteTimedSignal)
SigDSeq.lhs
SigD.lhs
SigC.lhs
-Agent.lhs (RDAgent)
-BError.lhs
-BState.lhs (Trans.StateBehavior)
-BWriter.lhs (Trans.BWriter)
-BReader.lhs
+DemandMonitor.lhs
+Trans/Error.lhs
+Trans/Env.lhs
*/

No commit comments for this range

Something went wrong with that request. Please try again.