root/src/Pugs/Prim/List.hs

Revision 17871, 17.3 kB (checked in by ryporter, 13 months ago)

replace improper use of length() in my previous check-in, because it prevents laziness
  • Property svn:mime-type set to text/plain; charset=UTF-8
  • Property svn:eol-style set to native
Line 
1{-# OPTIONS_GHC -fglasgow-exts -fallow-overlapping-instances #-}
2
3module Pugs.Prim.List (
4    op0Zip, op0Cross, op0Cat, op0Each, op0RoundRobin, op1Pick, op1Sum,
5    op1Min, op1Max, op1Uniq,
6    op2Pick,
7    op2ReduceL, op2Reduce, op2Grep, op2First, op2Map, op2Join,
8    sortByM,
9    op1HyperPrefix, op1HyperPostfix, op2Hyper,
10) where
11import Pugs.Internals
12import Pugs.AST
13import Pugs.Types
14import Pugs.Monads
15import qualified Data.Set as Set
16
17import Pugs.Prim.Numeric
18import Pugs.Prim.Lifts
19
20op0Cat :: [Val] -> Eval Val
21op0Cat = fmap (VList . concat) . mapM fromVal
22
23op0Zip :: [Val] -> Eval Val
24op0Zip = fmap (VList . fmap VList . op0Zip') . mapM fromVal
25
26op0Each :: [Val] -> Eval Val
27op0Each = fmap (VList . concat . op0Zip') . mapM fromVal
28
29op0RoundRobin :: [Val] -> Eval Val
30op0RoundRobin = fmap (VList . fst . partition defined . concat . op0Zip') . mapM fromVal
31
32op0Zip' :: [[Val]] -> [[Val]]
33op0Zip' lists | any null lists = []
34op0Zip' []    = []
35op0Zip' lists = (map zipFirst lists):(op0Zip' (map zipRest lists))
36    where
37    zipFirst []     = undef
38    zipFirst (x:_)  = x
39    zipRest  []     = []
40    zipRest  (_:xs) = xs
41
42op0Cross :: [Val] -> Eval Val
43op0Cross = fmap (VList . fmap VList . op0Cross') . mapM fromVal
44
45op0Cross' :: [[Val]] -> [[Val]]
46op0Cross' [] = [[]]
47op0Cross' (xs:yss) = do
48    x <- xs
49    ys <- op0Cross' yss
50    return (x:ys)
51
52op1Pick :: Val -> Eval Val
53op1Pick (VRef r) = op1Pick =<< readRef r
54op1Pick (VList []) = return undef
55op1Pick (VList vs) = do
56    rand <- io $ randomRIO (0, length vs - 1)
57    return $ vs !! rand
58op1Pick (VJunc (MkJunc _ _ set)) | Set.null set = return undef
59op1Pick (VJunc (MkJunc JAny _ set)) = do -- pick mainly works on 'any'
60    rand <- io $ randomRIO (0 :: Int, (Set.size set) - 1)
61    return $ (Set.elems set) !! rand
62op1Pick (VJunc (MkJunc JNone _ _)) = return undef
63op1Pick (VJunc (MkJunc JAll _ set)) =
64    if (Set.size $ set) == 1 then return $ head $ Set.elems set
65    else return undef
66op1Pick (VJunc (MkJunc JOne dups set)) =
67    if (Set.size $ set) == 1 && (Set.size $ dups) == 0
68    then return $ head $ Set.elems set
69    else return undef
70op1Pick v = die "pick not defined" v
71
72shuffleN :: Int -> [a] -> Eval [a]
73shuffleN _ [] = return []
74shuffleN 0 _  = return []
75shuffleN n xs = do
76    -- pick the first element
77    first <- io $ randomRIO (0 :: Int, length xs - 1)
78    rest <- shuffleN (n-1) $ take first xs ++ drop (first+1) xs
79    return $ head (drop first xs) : rest
80
81op2Pick :: Val -> Val -> Eval Val
82op2Pick (VRef r) num = do
83    ref <- readRef r
84    op2Pick ref num
85op2Pick l@(VList xs) (VNum n)
86    | n == 1/0  = op2Pick l (VInt . toInteger $ length xs)
87    | otherwise = op2Pick l (VInt $ floor n)
88op2Pick (VList xs) (VInt num) = do
89    shuffled <- shuffleN (fromInteger num) xs
90    return $ VList shuffled
91op2Pick r _ = die "pick not defined" r
92
93op1Sum :: Val -> Eval Val
94op1Sum list = do
95    vals <- fromVal list
96    foldM (op2Numeric (+)) undef vals
97
98op1Min :: Val -> Eval Val
99op1Min v = op1MinMax not v
100
101op1Max :: Val -> Eval Val
102op1Max v = op1MinMax id v
103
104-- min_or_max is a function which negates truth/falsehood.
105-- This is necessary as op1MinMax should cope with min() as well as max().
106op1MinMax :: (Bool -> Bool) -> Val -> Eval Val
107op1MinMax min_or_max v = do
108    -- We want to have a real Haskell list
109    args    <- fromVal v
110    -- Extract our comparator sub, or Nothing if none was specified
111    (valList, cmp) <- case args of
112        (v:vs) -> do
113            ifValTypeIsa v "Code"
114                (return (vs, Just v))
115                (ifValTypeIsa (last args) "Code"
116                    (return (init args, Just $ last args))
117                    (return (args, Nothing)))
118        _  -> return (args, Nothing)
119    -- Now let our helper function do the rest
120    op1MinMax' min_or_max cmp valList
121    where
122    op1MinMax' :: (Bool -> Bool) -> (Maybe Val) -> [Val] -> Eval Val
123    -- The min or max of an empty list is undef.
124    op1MinMax' _ _ [] = return undef
125    -- We have to supply our own comparator...
126    op1MinMax' _ Nothing valList = foldM default_compare (head valList) (tail valList)
127    -- or use the one of the user
128    op1MinMax' min_or_max (Just subVal) valList = do
129          sub <- fromVal subVal
130          evl <- asks envEval
131          -- Here we execute the user's sub
132          foldM (\a b -> do
133              rv  <- local (\e -> e{ envContext = cxtItem "Int" }) $ do
134                  evl (App (Val sub) Nothing [Val a, Val b])
135              int <- fromVal rv
136              -- If the return value from the sub was
137              --   -1 ==> a < b
138              --    0 ==> a == b
139              --   +1 ==> a > b
140              -- We call min_or_max so we can work for both min() and max().
141              return $ if min_or_max (int > (0::VInt)) then a else b) (head valList) (tail valList)
142    -- This is the default comparision function, which will be used if the user
143    -- hasn't specified a own comparision function.
144    default_compare a b = do
145        a' <- vCastRat a
146        b' <- vCastRat b
147        let cmp = if a' < b' then (-1) else if a' == b' then 0 else 1
148        return $ if min_or_max (cmp > (0::VInt)) then a else b
149
150op1Uniq :: Val -> Eval Val
151op1Uniq v = do
152    -- We want to have a real Haskell list
153    args    <- fromVal v
154    -- Extract our comparator sub, or Nothing if none was specified
155    (valList, cmp) <- case args of
156        (v:vs) -> do
157            ifValTypeIsa v "Code"
158                (return (vs, Just v))
159                (ifValTypeIsa (last args) "Code"
160                    (return (init args, Just $ last args))
161                    (return (args, Nothing)))
162        _  -> return (args, Nothing)
163    -- After this parameter unpacking, we begin doing the real work.
164    op1Uniq' cmp valList
165    where
166    op1Uniq' :: (Maybe Val) -> [Val] -> Eval Val
167    -- If the user didn't specify an own comparasion sub, we can simply use
168    -- Haskell's nub.
169    op1Uniq' Nothing valList = return . VList $ nub valList
170    -- Else, we have to write our own nubByM and use that.
171    op1Uniq' (Just subVal) valList = do
172        sub <- fromVal subVal
173        evl <- asks envEval
174        -- Here we execute the user's sub
175        result <- nubByM (\a b -> do
176            rv  <- local (\e -> e{ envContext = cxtItem "Bool" }) $ do
177                evl (App (Val sub) Nothing [Val a, Val b])
178            -- The sub returns either true or false.
179            bool <- fromVal rv
180            return . VBool $ bool) valList
181        return . VList $ result
182    -- This is the same as nubBy, only lifted into the Eval monad
183    nubByM :: (Val -> Val -> Eval Val) -> [Val] -> Eval [Val]
184    nubByM eq l = nubByM' l []
185      where
186        nubByM' [] _      = return []
187        nubByM' (y:ys) xs = do
188            -- elemByM returns a Val, but we need a VBool, so we have to use fromVal.
189            cond <- fromVal =<< elemByM eq y xs
190            if cond then nubByM' ys xs else do
191                result <- nubByM' ys (y:xs)
192                return (y:result)
193        elemByM :: (Val -> Val -> Eval Val) -> Val -> [Val] -> Eval Val
194        elemByM _  _ []     = return . VBool $ False
195        elemByM eq y (x:xs) = do
196            cond <- fromVal =<< eq x y
197            -- Same here (we need a VBool, not a Var).
198            if cond then return . VBool $ cond else elemByM eq y xs
199
200op2ReduceL :: Bool -> Val -> Val -> Eval Val
201op2ReduceL keep sub@(VCode _) list = op2ReduceL keep list sub
202op2ReduceL keep list sub = do
203    code <- fromVal sub
204    op2Reduce keep list $ VCode code{ subAssoc = A_left }
205
206op2Reduce :: Bool -> Val -> Val -> Eval Val
207op2Reduce keep sub@VCode{} list = op2Reduce keep list sub
208op2Reduce keep list sub = do
209    code <- fromVal sub
210    args <- fromVal list
211    if null args then identityVal (subName code) else do
212    -- cxt  <- asks envContext
213    let arity = length $ subParams code
214        (reduceM, reduceMn) = if keep then (scanM, scanMn) else (foldM, foldMn)
215    if subAssoc code == A_list
216        then asks envEval >>= \evl -> evl $ App (Val $ VCode code{ subParams = length args `replicate` head (subParams code)}) Nothing (map Val args)
217        else do
218            when (arity < 2) $ fail "Cannot reduce() using a unary or nullary function."
219            -- n is the number of *additional* arguments to be passed to the sub.
220            -- Ex.: reduce { $^a + $^b       }, ...   # n = 1
221            -- Ex.: reduce { $^a + $^b + $^c }, ...   # n = 2
222            let n = arity - 1
223            -- Break on empty list.
224            let doFold xs = do
225                evl <- asks envEval
226                local (\e -> e{ envContext = cxtItemAny }) $ do
227                    evl (App (Val sub) Nothing (map Val xs))
228            case subAssoc code of
229                A_right -> do
230                    let args' = reverse args
231                    reduceMn args' n (doFold . reverse)
232                A_chain -> if arity /= 2            -- FIXME: incorrect for scans
233                    then fail
234                        "When reducing using a chain-associative sub,\nthe sub must take exactly two arguments."
235                    else catchT $ \esc -> do
236                        let doFold' x y = do
237                            val <- doFold [x, y]
238                            case val of
239                                VBool False -> esc val
240                                _           -> return y
241                        reduceM doFold' (head args) (tail args)
242                        return $ VBool True
243                A_non   -> fail $ "Cannot reduce over non-associativity"
244                _       -> reduceMn args n doFold -- "left", "pre"
245    where
246    -- This is a generalized foldM.
247    -- It takes an input list (from which the first elem will be used as start
248    -- value), the number of additional arguments, and a reducing function.
249    foldMn :: [Val] -> Int -> ([Val] -> Eval Val) -> Eval Val
250    foldMn list n f = foldM (\a b -> f (a:b)) (head list) $ list2LoL n $ drop 1 list
251    -- Scan version of foldMn.
252    scanMn :: [Val] -> Int -> ([Val] -> Eval Val) -> Eval Val
253    scanMn list n f = scanM (\a b -> f (a:b)) (head list) $ list2LoL n $ drop 1 list
254    -- The Prelude defines foldM but not scanM.
255    scanM :: (Val -> b -> Eval Val) -> Val -> [b] -> Eval Val
256    scanM f q ls = case ls of
257        []   -> return $ VList [q]
258        x:xs -> do
259            fqx  <- f q x
260            rest <- fromVal =<< scanM f fqx xs
261            return $ VList (q:rest)
262    identityVal name = case nameStr of
263        "**"    -> _1
264        "*"     -> _1
265        "/"     -> _fail
266        "%"     -> _fail
267        "x"     -> _fail
268        "xx"    -> _fail
269        "+&"    -> _neg1
270        "+<"    -> _fail
271        "+>"    -> _fail
272        "~&"    -> _fail
273        "~<"    -> _fail
274        "~>"    -> _fail
275        "+"     -> _0
276        "-"     -> _0
277        "~"     -> _''
278        "+|"    -> _0
279        "+^"    -> _0
280        "~|"    -> _''
281        "~^"    -> _''
282        "&"     -> _junc JAll
283        "|"     -> _junc JAny
284        "^"     -> _junc JOne
285        "!="    -> _false
286        "=="    -> _true
287        "<"     -> _true
288        "<="    -> _true
289        ">"     -> _true
290        ">="    -> _true
291        "~~"    -> _true
292        "eq"    -> _true
293        "ne"    -> _false
294        "lt"    -> _true
295        "le"    -> _true
296        "gt"    -> _true
297        "ge"    -> _true
298        "=:="   -> _true
299        "==="   -> _true
300        "eqv"   -> _true
301        "&&"    -> _true
302        "||"    -> _false
303        "^^"    -> _false
304        ","     -> _list
305        "Z"     -> _list
306        "X"     -> _list
307        ('!':_) -> _false
308        _           -> _undef
309        where
310        nameStr = cast name
311        _0      = return (VInt 0)
312        _1      = return (VInt 1)
313        _undef  = return undef
314        _false  = return (VBool False)
315        _true   = return (VBool True)
316        _list   = return (VList [])
317        _neg1   = return (VInt $ -1)
318        _junc   = \jtyp -> return . VJunc $ MkJunc jtyp Set.empty Set.empty
319        _''     = return (VStr "")
320        _fail   = fail $ "reduce is nonsensical for " ++ cast name
321
322op2Grep :: Val -> Val -> Eval Val
323op2Grep sub@(VCode _) list = op2Grep list sub
324op2Grep list sub = do
325    args <- fromVal list
326    vals <- (`filterM` args) $ \x -> do
327        evl <- asks envEval
328        rv  <- local (\e -> e{ envContext = cxtItem "Bool" }) $ do
329            evl (App (Val sub) Nothing [Val x])
330        fromVal rv
331    return $ VList vals
332
333op2First :: Val -> Val -> Eval Val
334op2First sub@(VCode _) list = op2First list sub
335op2First list sub = do
336  (VList vals) <- (op2Grep list sub)
337  if not (null vals)
338    then return $ (vals !! 0)
339    else return $ undef
340
341op2Map :: Val -> Val -> Eval Val
342op2Map sub@(VCode _) list = op2Map list sub
343op2Map list sub = do
344    args  <- fromVal list
345    arity <- fmap (length . subParams) (fromVal sub)
346    evl   <- asks envEval
347    vals  <- mapMn args arity $ \x -> do
348        rv  <- local (\e -> e{ envContext = cxtSlurpyAny }) $ do
349            evl (App (Val sub) Nothing (map Val x))
350        fromVal rv
351    return $ VList vals
352    where
353    -- Takes a list, an arity, and a function.
354    mapMn           :: [Val] -> Int -> ([Val] -> Eval [Val]) -> Eval [Val]
355    mapMn list 0 f   = fmap concat (mapM (const $ f []) list)
356    mapMn list n f   = mapMn' (list2LoL n list) f
357    -- Takes a LoL and a function and applies the function to the inputlist.
358    mapMn'          :: [[Val]] -> ([Val] -> Eval [Val]) -> Eval [Val]
359    mapMn' (x:xs) f  = liftM2 (++) (f x) (mapMn' xs f)
360    mapMn' []     _  = return []
361
362{-|
363Takes an int and a list and returns a LoL.
364Ex.:
365
366> list2LoL 3 [1,2,3,4,5] = [[1,2,3],[4,5,undef]]
367-}
368list2LoL :: Int -> [Val] -> [[Val]]
369list2LoL n list
370    | n == 0           = fail "Cannot map() using a nullary function."
371    -- If the list has exactly n elements, we've finished our work.
372    | length list == n = [list]
373    -- If the list is empty, we're done, too.
374    | length list == 0 = []
375    -- But if the list contains more elems than we need, we process the
376    -- first n ones and the rest separately.
377    | length list  > n = (list2LoL n $ take n list) ++ (list2LoL n $ drop n list)
378    -- And if the list contains less elems than we need, we pad with undefs.
379    | length list  < n = list2LoL n $ list ++ [undef :: Val]
380    | otherwise        = fail "Invalid arguments to internal function list2LoL passed."
381
382op2Join :: Val -> Val -> Eval Val
383-- op2Join (VList [x@(VRef _)]) y = op2Join x y
384op2Join x y = do
385    (strVal, valList) <- ifValTypeIsa x "Scalar"
386        (return (x, (VRef (arrayRef (listVal y)))))
387        (return (y, x))
388    str     <- fromVal strVal
389    ref     <- fromVal valList
390    list    <- readRef ref
391    strList <- fromVals list
392    return . VStr . concat . intersperse str $ strList
393
394sortByM :: (Val -> Val -> Eval Bool) -> [Val] -> Eval [Val]
395sortByM _ []  = return []
396sortByM _ [x] = return [x]
397sortByM f xs  = do
398    let (as, bs) = splitAt (length xs `quot` 2) xs
399    aSorted <- sortByM f as
400    bSorted <- sortByM f bs
401    doMerge f aSorted bSorted
402    where
403    doMerge :: (Val -> Val -> Eval Bool) -> [Val] -> [Val] -> Eval [Val]
404    doMerge _ [] ys = return ys
405    doMerge _ xs [] = return xs
406    doMerge f (x:xs) (y:ys) = do
407        isLessOrEqual <- f x y
408        if isLessOrEqual
409            then do
410                rest <- doMerge f xs (y:ys)
411                return (x:rest)
412            else do
413                rest <- doMerge f (x:xs) ys
414                return (y:rest)
415
416op1HyperPrefix :: VCode -> Val -> Eval Val
417op1HyperPrefix sub (VRef ref) = do
418    x <- readRef ref
419    op1HyperPrefix sub x
420op1HyperPrefix sub x
421    | VList x' <- x
422    = fmap VList $ hyperList x'
423    | otherwise
424    = fail "Hyper OP only works on lists"
425    where
426    doHyper x
427        | VRef x' <- x
428        = doHyper =<< readRef x'
429        | VList{} <- x
430        = op1HyperPrefix sub x
431        | otherwise
432        = enterEvalContext cxtItemAny $ App (Val $ VCode sub) Nothing [Val x]
433    hyperList xs = do
434        env <- ask
435        io $ do
436            mvs <- forM xs $ \x -> do
437                mv  <- newEmptyMVar
438                forkIO $ do
439                    val <- runEvalIO env (doHyper x)
440                    putMVar mv val
441                return mv
442            mapM takeMVar mvs
443
444op1HyperPostfix :: VCode -> Val -> Eval Val
445op1HyperPostfix = op1HyperPrefix
446
447op2Hyper :: VCode -> Val -> Val -> Eval Val
448op2Hyper sub (VRef ref) y = do
449    x <- readRef ref
450    op2Hyper sub x y
451op2Hyper sub x (VRef ref) = do
452    y <- readRef ref
453    op2Hyper sub x y
454op2Hyper sub x y
455    | VList x' <- x, VList y' <- y
456    = fmap VList $ hyperLists x' y'
457    | VList x' <- x
458    = fmap VList $ mapM ((flip doHyper) y) x'
459    | VList y' <- y
460    = fmap VList $ mapM (doHyper x) y'
461    | otherwise
462    = fail "Hyper OP only works on lists"
463    where
464    doHyper x y
465        | VRef x' <- x, VRef y' <- y
466        = join $ liftM2 doHyper (readRef x') (readRef y')
467        | VRef x' <- x
468        = (flip doHyper $ y) =<< readRef x'
469        | VRef y' <- y
470        = doHyper x =<< readRef y'
471        | VList{} <- x
472        = op2Hyper sub x y
473        | VList{} <- y
474        = op2Hyper sub x y
475        | otherwise
476        = enterEvalContext cxtItemAny $ App (Val $ VCode sub) Nothing [Val x, Val y]
477    hyperLists xs ys = do
478        env <- ask
479        io $ do
480            mvs <- doHyperLists env xs ys
481            mapM takeMVar mvs
482    doHyperLists _ [] [] = return []
483    doHyperLists _ xs [] = mapM newMVar xs
484    doHyperLists _ [] ys = mapM newMVar ys
485    doHyperLists env (x:xs) (y:ys) = do
486        mv  <- newEmptyMVar
487        forkIO $ do
488            val <- runEvalIO env $ doHyper x y
489            putMVar mv val
490        mvs <- doHyperLists env xs ys
491        return (mv:mvs)
Note: See TracBrowser for help on using the browser.