1 {-# OPTIONS_GHC -XModalTypes -dcore-lint -ddump-types -XNoMonomorphismRestriction #-}
3 import Prelude hiding (const)
5 class ProcessNetwork g where
6 logic :: ( Bool -> Bool) -> <[ Bool ~~> Bool ]>
7 logic2 :: (Bool -> Bool -> Bool) -> <[ (Bool,Bool) ~~> Bool ]>
8 delay :: Bool -> <[ Bool ~~> Bool ]>
9 select :: <[ (Bool,Bool,Bool) ~~> Bool ]>
10 switch :: <[ (Bool,Bool) ~~> (Bool,Bool) ]>
12 ------------------------------------------------------------------------------
14 -- Basic logic functions
16 and' = logic2 (\x y -> x && y)
17 or' = logic2 (\x y -> x || y)
18 not' = logic (\x -> case x of {True->False ; False -> True})
21 -- Simulates "conditionally consuming" data from an input port.
23 -- A value is consumed from "next"; if the value is False,
24 -- the previous output is repeated. Otherwise, a value is
25 -- consumed from "input" and emitted as the output.
27 --peek :: <[ (Bool,Bool) ~~> Bool ]>
32 prev = ~~(delay True) next
33 out = select prev input feedback
34 -- (feedback,_) = switch next out
35 feedback = switch' next out
40 ------------------------------------------------------------------------------
42 -- Numbers are represented in unary (Peano) notation: the number N is
43 -- N-many False values followed by a single True
49 -- Convert a Number to a sequence of False's; the second argument
50 -- is a stream of Bools, one per Number, indicating whether or not
51 -- to include the trailing "True"
53 --numberToBooleans :: <[ (Number,Bool) ~~> Bool ]>
54 allTrues :: forall g . <[ () ~~> Bool ]>@g
56 allFalses :: forall g . <[ () ~~> Bool ]>@g
61 \includeTrailingTrue ->
62 let sel = select numbers includeTrailingTrue ~~allTrues
63 -- (out,_) = switch sel numbers
64 out = switch' sel numbers
69 ------------------------------------------------------------------------------
71 -- Increment, decrement, and zero-test for Numbers. Each of these
72 -- follows a similar pattern: keep a copy of the previous input, and
73 -- "pattern match" on a pair of consecutive bits.
75 --decrement :: <[ Number ~~> Number ]>
78 let isFirstBitOfNumber = ~~(delay True) input
79 isFirstBitOfNonzeroNumber = ~~and' (~~not' input) isFirstBitOfNumber
80 -- (_,out) = switch isFirstBitOfNonzeroNumber input
81 out = switch' isFirstBitOfNonzeroNumber input
85 --increment :: <[ Number ~~> Number ]>
88 let isFirstBitOfNumber = ~~(delay True) out
89 out = select isFirstBitOfNumber ~~allFalses input
93 --isZero :: <[ Number ~~> Bool ]>
96 let prev = ~~(delay True) input
97 -- (out,_) = switch input (~~and' prev input)
98 out = switch' input (~~and' prev input)
103 ------------------------------------------------------------------------------
105 -- Versions of the "select" and "select" operators that act on Numbers
106 -- (the "select" port is still boolean).
108 -- numberSelect :: <[ (Bool,Number,Number) ~~> Number ]>
114 let sel' = ~~peek sel next_sel
115 out = select sel' iftrue iffalse
121 numberSwitch :: <[ (Bool,Number) ~~> (Number,Number) ]>
126 let sel' = ~~peek sel next_sel
127 out = switch sel' input
133 numberSelect :: <[ (Bool,(Number,(Number,()))) ~~> Number ]>@g
134 numberSelect = undefined
136 ------------------------------------------------------------------------------
138 -- An example of a functional: given two process networks which each
139 -- take a Number in and produce a Number output, route each incoming
140 -- Number to one side or the other based on a control token.
143 maybeNumber :: ([Number] -> [Number]) ->
144 ([Number] -> [Number]) ->
149 maybeNumber ftrue ffalse sel input =
150 let (inputTrue,inputFalse) = numberSwitch sel input
151 in numberSelect sel (ftrue inputTrue) (ffalse inputFalse)
154 <[ Number ~~> Number ]>@g ->
155 <[ Number ~~> Number ]>@g ->
156 <[ (Bool,Number) ~~> Number ]>@g
157 maybeNumber = undefined
160 ------------------------------------------------------------------------------
165 -- relatively straightforward: the counter, counter update, and emptiness test:
166 count = ~~(delay True) newCount
167 newCount = ~~maybeNumber ~~decrement ~~increment commandIsPop count
168 isEmpty = ~~isZero count
169 pushOrPopEmpty = ~~or' (~~not' commandIsPop) isEmpty
171 -- First stage: popping from an empty stack is implemented by
172 -- synthesizing a zero value, pushing it, and then popping it.
173 -- This first stage synthesizes the zero-value if necessary
174 (popEmptyResult,_) = ~~numberSwitch
181 -- Second stage: this select copies the existing stack storage
182 -- from its first input to its output, optionally *preceding* it
183 -- with a single value drawn from its second input.
184 pushResult = ~~numberSelect
185 (~~numberToBooleans count pushOrPopEmpty)
189 -- Third stage: copy the result of the "push" operation to its
190 -- second output, optionally diverting the *first* element to the
192 (popResult,stackStorage) = ~~numberSwitch
193 (numberToBooleans newCount commandIsPop)
201 ------------------------------------------------------------------------------
208 int2p n = False:(int2p (n-1))
211 p2i (True:xs) = 0:(p2i xs)
212 p2i (False:xs) = case p2i xs of n:ns -> (n+1):ns
215 --x = peek [1,2,3,4,5,6,7,8] [True,True,False,False,True,False]
216 --x = p2i $ numberSelect [False,True,True,False] even odd
217 --x = p2i $ fst (numberSwitch [False,True,True,False,True] all)
218 --x = p2i $ increment even
219 x = p2i $ stack [True,True,False,False,False,True,True,False,True,True,True,True,True] odd
221 even = concatMap int2p [9,0,2,4,6]
222 odd = concatMap int2p [9,1,3,5]
223 all = concatMap int2p [1,2,0,2,3,4,9,9]
225 main = do sequence $ map putStrLn $ map show x
227 logic1 f in1 = map f in1
228 logic2 f in1 in2 = map f (zip in1 in2)
232 select sel iftrue iffalse =
234 (True :sel') -> case iftrue of { (x:iftrue') -> x:(select sel' iftrue' iffalse) ; _ -> [] }
235 (False:sel') -> case iffalse of { (x:iffalse') -> x:(select sel' iftrue iffalse') ; _ -> [] }
238 switch (True:sel) (x:inp) = let (out1,out2) = switch sel inp in ((x:out1),out2)
239 switch (False:sel) (x:inp) = let (out1,out2) = switch sel inp in (out1,(x:out2))
242 allTrues = delay True allTrues
243 allFalses = delay False allFalses