1 {-# OPTIONS_GHC -XModalTypes -dcore-lint -ddump-types -XNoMonomorphismRestriction #-}
2 module Stack where
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 ------------------------------------------------------------------------------
13 --
14 -- Basic logic functions
15 --
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})
20 --
21 -- Simulates "conditionally consuming" data from an input port.
22 --
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.
26 --
27 --peek :: <[ (Bool,Bool) ~~> Bool ]>
28 peek input next =
29   <[ \input ->
30      \next ->
31      let
32        prev         = ~~(delay True) next
33        out          = select prev input feedback
34 --     (feedback,_) = switch next out
35        feedback     = switch' next out
36      in out
37    ]>
40 ------------------------------------------------------------------------------
41 --
42 -- Numbers are represented in unary (Peano) notation: the number N is
43 -- N-many False values followed by a single True
44 --
45 type Number = Bool
48 --
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"
52 --
53 --numberToBooleans :: <[ (Number,Bool) ~~> Bool ]>
54 allTrues :: forall g . <[ () ~~> Bool ]>@g
55 allTrues = undefined
56 allFalses :: forall g . <[ () ~~> Bool ]>@g
57 allFalses = undefined
59 numberToBooleans =
60  <[ \numbers ->
61     \includeTrailingTrue ->
62       let sel            = select numbers includeTrailingTrue ~~allTrues
63 --          (out,_)        = switch sel numbers
64           out        = switch' sel numbers
65       in out
66   ]>
69 ------------------------------------------------------------------------------
70 --
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.
74 --
75 --decrement :: <[ Number ~~> Number ]>
76 decrement =
77  <[ \input ->
78       let isFirstBitOfNumber        = ~~(delay True) input
79           isFirstBitOfNonzeroNumber = ~~and' (~~not' input) isFirstBitOfNumber
80 --          (_,out)                   = switch isFirstBitOfNonzeroNumber input
81           out                   = switch' isFirstBitOfNonzeroNumber input
82        in out
83   ]>
85 --increment :: <[ Number ~~> Number ]>
86 increment =
87   <[ \input ->
88        let isFirstBitOfNumber = ~~(delay True) out
89            out                = select isFirstBitOfNumber ~~allFalses input
90         in out
91    ]>
93 --isZero :: <[ Number ~~> Bool ]>
94 isZero =
95   <[ \input ->
96         let prev    = ~~(delay True) input
97 --          (out,_) = switch input (~~and' prev input)
98             out = switch' input (~~and' prev input)
99          in out
100    ]>
103 ------------------------------------------------------------------------------
104 --
105 -- Versions of the "select" and "select" operators that act on Numbers
106 -- (the "select" port is still boolean).
107 --
108 -- numberSelect :: <[ (Bool,Number,Number) ~~> Number ]>
109 {-
110 numberSelect =
111   <[ \sel ->
112      \iftrue ->
113      \iffalse ->
114         let sel'     = ~~peek sel next_sel
115             out      = select sel' iftrue iffalse
116             next_sel = out
117         in  out
118    ]>
119 -}
121 numberSwitch :: <[ (Bool,Number) ~~> (Number,Number) ]>
122 {-
123 numberSwitch =
124   <[ \sel ->
125      \input ->
126         let sel'     = ~~peek sel next_sel
127             out      = switch sel' input
128             next_sel = input
129         in  out
130    ]>
131 -}
133 numberSelect :: <[ (Bool,(Number,(Number,()))) ~~> Number ]>@g
134 numberSelect = undefined
136 ------------------------------------------------------------------------------
137 --
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.
141 --
142 {-
143 maybeNumber :: ([Number] -> [Number]) ->
144               ([Number] -> [Number]) ->
145               [Bool] ->
146               [Number] ->
147               [Number]
149 maybeNumber ftrue ffalse sel input =
150   let (inputTrue,inputFalse) = numberSwitch sel input
151    in numberSelect sel (ftrue inputTrue) (ffalse inputFalse)
152 -}
153 maybeNumber ::
154    <[ Number ~~> Number ]>@g ->
155    <[ Number ~~> Number ]>@g ->
156    <[ (Bool,Number) ~~> Number ]>@g
157 maybeNumber = undefined
160 ------------------------------------------------------------------------------
161 stack =
162   <[ \commandIsPop ->
163      \push ->
164      let
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
175                                pushOrPopEmpty
176                                (~~numberSelect
177                                   commandIsPop
178                                   ~~allTrues
179                                   push)
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)
186                                 popEmptyResult
187                                 stackStorage
189        -- Third stage: copy the result of the "push" operation to its
190        -- second output, optionally diverting the *first* element to the
191        -- first output.
192        (popResult,stackStorage)  = ~~numberSwitch
193                                       (numberToBooleans newCount commandIsPop)
194                                       pushResult
196     in popResult
197   ]>
199 {-
201 ------------------------------------------------------------------------------
202 --
203 --  Boilerplate
204 --
207 int2p 0 = [True]
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
213 p2i _ = []
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
220  where
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)
230 delay x                   = \n -> x:n
232 select sel iftrue iffalse =
233     case sel of
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') ; _ -> [] }
236       []           -> []
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))
240 switch _ _                 = ([],[])
242 allTrues  = delay True  allTrues
243 allFalses = delay False allFalses
244 -}