examples/Stack.hs

   1 {-# OPTIONS_GHC -XModalTypes -dcore-lint -ddump-types -XNoMonomorphismRestriction #-}
   2 module Stack where
   3 import Prelude hiding (const)
   4
   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) ]>
  11
  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})
  19
  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    ]>
  38
  39
  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
  46
  47
  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
  58
  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   ]>
  67
  68
  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   ]>
  84
  85 --increment :: <[ Number ~~> Number ]>
  86 increment =
  87   <[ \input ->
  88        let isFirstBitOfNumber = ~~(delay True) out
  89            out                = select isFirstBitOfNumber ~~allFalses input
  90         in out
  91    ]>
  92
  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    ]>
 101
 102
 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 -}
 120
 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 -}
 132
 133 numberSelect :: <[ (Bool,(Number,(Number,()))) ~~> Number ]>@g
 134 numberSelect = undefined
 135
 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]
 148
 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
 158
 159
 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
 170
 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)
 180
 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
 188
 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
 195
 196     in popResult
 197   ]>
 198
 199 {-
 200
 201 ------------------------------------------------------------------------------
 202 --
 203 --  Boilerplate
 204 --
 205
 206
 207 int2p 0 = [True]
 208 int2p n = False:(int2p (n-1))
 209
 210
 211 p2i (True:xs)  = 0:(p2i xs)
 212 p2i (False:xs) = case p2i xs of n:ns -> (n+1):ns
 213 p2i _ = []
 214
 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]
 224
 225 main = do sequence $ map putStrLn $ map show x
 226
 227 logic1 f in1     = map f in1
 228 logic2 f in1 in2 = map f (zip in1 in2)
 229
 230 delay x                   = \n -> x:n
 231
 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       []           -> []
 237
 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 _ _                 = ([],[])
 241
 242 allTrues  = delay True  allTrues
 243 allFalses = delay False allFalses
 244 -}