-- File : Ursl.hs -- Author : Richard A. O'Keefe -- Version: 1.0 -- SCCS : "@(#)99/03/22 Ursl.hs 1.4" -- Updated: 1999.03.17 -- Defines: UnRolled Strict Lists {- The purpose of this module is to provide a data structure that is (a) as much like a list as possible, but (b) strict, and (c) "unrolled" so that one pattern match typically serves to unpack four elements (not 1) which can be processed together. To get the best out of it, you need a compiler that does cross-module optimisation, specifically inlining. With that, you will get some of the benefits that loop unrolling in compilers for imperative languages provides. I wrote a much smaller version of this module to try and make a Neural Network program run faster. This file was written for use with Hugs and GHC, using only what is common to Haskell 1.4 and Haskell 98 (which is the reason why Ursl is not an instance of Functor, because that changed). There is also a version in Clean, suitable for Clean 1.3. See the comment at the end of the file for a detailed list of the list-related standard functions that have equivalents here and names. -} module Ursl( -- UnRolled Strict List Ursl, lenUrsl, lengthUrsl, toUrsl, fromUrsl, anyUrsl, elemUrsl, allUrsl, notElemUrsl, mapAccumLUrsl, mapAccumRUrsl, mapUrsl, map2Ursl, redUrsl, red2Ursl, appUrsl, nthUrsl, newUrsl, replicateUrsl, zeroUrsl, nullUrsl, isEmptyUrsl, isPrefixUrsl, isSuffixUrsl, lookupUrsl, findUrsl, reverseUrsl, sumUrsl, productUrsl, maximumUrsl, minimumUrsl, elemIndexUrsl, elemIndicesUrsl, findIndexUrsl, findIndicesUrsl, takeUrsl, takeWhileUrsl, dropUrsl, dropWhileUrsl, splitAtUrsl, spanUrsl, breakUrsl, filterUrsl, partitionUrsl, foldlUrsl, foldl1Ursl, foldrUrsl, foldr1Ursl, scanlUrsl, scanl1Ursl, scanrUrsl, scanr1Ursl, zipUrsl, zipUrslUrsl, zipListUrsl, zipWithUrsl, zipWithUrslUrsl, zipWithListUrsl, unzipUrsl, -- The names in the left column are copied from Dijkstra's arrays in -- "A Discipline of Programming". The names in the right column are -- based on the list operations in Haskell's Prelude. loextUrsl, -- (:) loremUrsl, tailUrsl, tlUrsl, botUrsl, headUrsl, hdUrsl, hiextUrsl, hiremUrsl, initUrsl, topUrsl, lastUrsl ) where data Eval a => Ursl a = U0 | U1 !a | U2 !a !a | U3 !a !a !a | U4 !a !a !a !a !(Ursl a) deriving (Eq) {- We want Eq and Ord to satisfy the following laws 1. (toUrsl x == toUrsl y) == (x == y) for x, y:: [a] and Eq a The Eq instance we get by 'deriving' is just right. 2. compare (toUrsl x) (toUrsl y) == compare x y for x, y:: [a] and Ord a The Ord instance we get by 'deriving' is a perfectly good total order, but unfortunately it is _not_ the total order we want. -} instance (Eval a, Ord a) => Ord (Ursl a) where -- compare :: (Eval a, Ord a) => (Ursl a) -> (Ursl a) -> Ordering compare (U4 a b c d xs) (U4 p q r s ys) = case compare a p of EQ -> case compare b q of EQ -> case compare c r of EQ -> case compare d s of EQ -> compare xs ys o -> o o -> o o -> o o -> o compare (U4 a b c _ _) (U3 p q r) = case compare a p of EQ -> case compare b q of EQ -> case compare c r of LT -> LT _ -> GT o -> o o -> o compare (U4 a b _ _ _) (U2 p q) = case compare a p of EQ -> case compare b q of LT -> LT _ -> GT o -> o compare (U4 a _ _ _ _) (U1 p) = case compare a p of LT -> LT _ -> GT compare (U4 _ _ _ _ _ ) (U0) = GT compare (U3 a b c) (U4 p q r _ _) = case compare a p of EQ -> case compare b q of EQ -> case compare c r of GT -> GT _ -> LT o -> o o -> o compare (U3 a b c) (U3 p q r) = case compare a p of EQ -> case compare b q of EQ -> compare c r o -> o o -> o compare (U3 a b _) (U2 p q) = case compare a p of EQ -> case compare b q of LT -> LT _ -> GT o -> o compare (U3 a _ _) (U1 p) = case compare a p of LT -> LT _ -> GT compare (U3 _ _ _) (U0) = GT compare (U2 a b) (U4 p q _ _ _) = case compare a p of EQ -> case compare b q of GT -> GT _ -> LT o -> o compare (U2 a b) (U3 p q _) = case compare a p of EQ -> case compare b q of GT -> GT _ -> LT o -> o compare (U2 a b) (U2 p q) = case compare a p of EQ -> compare b q o -> o compare (U2 a _) (U1 p) = case compare a p of LT -> LT _ -> GT compare (U2 _ _) (U0) = GT compare (U1 a) (U4 p _ _ _ _) = case compare a p of GT -> GT _ -> LT compare (U1 a) (U3 p _ _) = case compare a p of GT -> GT _ -> LT compare (U1 a) (U2 p _) = case compare a p of GT -> GT _ -> LT compare (U1 a) (U1 p) = compare a p compare (U1 _) (U0) = GT compare (U0) (U4 _ _ _ _ _) = LT compare (U0) (U3 _ _ _) = LT compare (U0) (U2 _ _) = LT compare (U0) (U1 _) = LT compare (U0) (U0) = EQ -- zeroUrsl is an empty ursl, like []. zeroUrsl :: (Eval a) => (Ursl a) zeroUrsl = U0 -- nullUrsl is identical to ==zeroUrsl nullUrsl :: (Eval a) => (Ursl a) -> Bool nullUrsl U0 = True nullUrsl _ = False -- isEmptyUrsl is another name for nullUrsl isEmptyUrsl :: (Eval a) => (Ursl a) -> Bool isEmptyUrsl U0 = True isEmptyUrsl _ = False -- lengthUrsl (toUrsl xs) = length xs lengthUrsl :: Eval a => Ursl a -> Int lengthUrsl u = lenUrsl u -- lenUrsl u takes O(#u) time. lenUrsl :: Eval a => Ursl a -> Int lenUrsl u = loop u 0 where loop (U4 _ _ _ _ xs) n = loop xs (n+4) loop (U3 _ _ _) n = n+3 loop (U2 _ _) n = n+2 loop (U1 _) n = n+1 loop (U0) n = n -- toUrsl l takes O(#l) time and allocates O(#l) space toUrsl :: Eval a => [a] -> Ursl a toUrsl (a:b:c:d:xs) = U4 a b c d (toUrsl xs) toUrsl [a,b,c] = U3 a b c toUrsl [a,b] = U2 a b toUrsl [a] = U1 a toUrsl [] = U0 -- fromUrsl u takes O(#u) time and allocates O(#u) space fromUrsl :: Eval a => Ursl a -> [a] fromUrsl (U4 a b c d xs) = a:b:c:d:fromUrsl xs fromUrsl (U3 a b c) = [a,b,c] fromUrsl (U2 a b) = [a,b] fromUrsl (U1 a) = [a] fromUrsl (U0) = [] -- show (an ursl) is modelled on show (an array). -- In fact, "deriving Show" would work perfectly well and the result -- is moderately readable, but I believe this looks better and it -- makes data files easier to convert between list representation and -- Ursl representation. instance (Eval a, Show a) => Show (Ursl a) where showsPrec p u = showParen (p > 9) ( showString "toUrsl " . shows (fromUrsl u) ) -- read (an ursl) is modelled on read (an array), -- which is commented out in hugs/lib/Array.hs. instance (Eval a, Read a) => Read (Ursl a) where readsPrec p = readParen (p > 9) (\r -> [(toUrsl xs, u) | ("toUsrl",s) <- lex r, (xs,u) <- reads s]) -- mapAccumLUrsl f s0 (toUrsl xs) = (s, toUrsl r) -- where (s, r) = mapAccumL f s0 xs mapAccumLUrsl :: (Eval b, Eval c) => (a -> b -> (a,c)) -> a -> (Ursl b) -> (a, Ursl c) mapAccumLUrsl f s0 (U4 a b c d xs) = (sn, U4 fa fb fc fd ys) where (sa,fa) = f s0 a (sb,fb) = f sa b (sc,fc) = f sb c (sd,fd) = f sc d (sn,ys) = mapAccumLUrsl f sd xs mapAccumLUrsl f s0 (U3 a b c) = (sc, U3 fa fb fc) where (sa,fa) = f s0 a (sb,fb) = f sa b (sc,fc) = f sb c mapAccumLUrsl f s0 (U2 a b) = (sb, U2 fa fb) where (sa,fa) = f s0 a (sb,fb) = f sa b mapAccumLUrsl f s0 (U1 a) = (sa, U1 fa) where (sa,fa) = f s0 a mapAccumLUrsl _ s0 (U0) = (s0, U0) -- mapAccumRUrsl f s0 (toUrsl xs) = (s, toUrsl r) -- where (s, r) = mapAccumR f s0 xs mapAccumRUrsl :: (Eval b, Eval c) => (a -> b -> (a,c)) -> a -> (Ursl b) -> (a, Ursl c) mapAccumRUrsl f s0 (U4 a b c d xs) = (sa, U4 fa fb fc fd ys) where (sn,ys) = mapAccumRUrsl f s0 xs (sd,fd) = f sn d (sc,fc) = f sd c (sb,fb) = f sc b (sa,fa) = f sb a mapAccumRUrsl f s0 (U3 a b c) = (sa, U3 fa fb fc) where (sc,fc) = f s0 c (sb,fb) = f sc b (sa,fa) = f sb a mapAccumRUrsl f s0 (U2 a b) = (sa, U2 fa fb) where (sb,fb) = f s0 b (sa,fa) = f sb a mapAccumRUrsl f s0 (U1 a) = (sa, U1 fa) where (sa,fa) = f s0 a mapAccumRUrsl _ s0 (U0) = (s0, U0) -- mapUrsl f (toUrsl xs) = toUrsl (map f xs) mapUrsl :: (Eval a, Eval b) => (a -> b) -> (Ursl a) -> (Ursl b) mapUrsl f (U4 a b c d xs) = U4 (f a) (f b) (f c) (f d) (mapUrsl f xs) mapUrsl f (U3 a b c) = U3 (f a) (f b) (f c) mapUrsl f (U2 a b) = U2 (f a) (f b) mapUrsl f (U1 a) = U1 (f a) mapUrsl _ (U0) = U0 -- map2Ursl f (toUrsl xs) (toUrsl ys) = toUrsl (map (uncurry f) (zip xs ys)) -- but is rather more direct. map2Ursl :: (Eval a, Eval b, Eval c) => (a -> b -> c) -> (Ursl a) -> (Ursl b) -> (Ursl c) map2Ursl g (U4 a b c d xs) (U4 p q r s ys) = U4 (g a p) (g b q) (g c r) (g d s) (map2Ursl g xs ys) map2Ursl g (U3 a b c) (U3 p q r) = U3 (g a p) (g b q) (g c r) map2Ursl g (U2 a b) (U2 p q) = U2 (g a p) (g b q) map2Ursl g (U1 a) (U1 p) = U1 (g a p) map2Ursl _ (U0) (U0) = U0 map2Ursl _ _ _ = error "Ursl.map2Ursl: length mismatch" -- redUrsl f x0 (toUrsl xs) = foldl f x0 xs redUrsl :: Eval b => (a -> b -> a) -> a -> Ursl b -> a redUrsl f v0 (U4 a b c d xs) = redUrsl f (f (f (f (f v0 a) b) c) d) xs redUrsl f v0 (U3 a b c) = f (f (f v0 a) b) c redUrsl f v0 (U2 a b) = f (f v0 a) b redUrsl f v0 (U1 a) = f v0 a redUrsl _ v0 (U0) = v0 red2Ursl :: (Eval b, Eval c) => (a -> b -> c -> a) -> a -> Ursl b -> Ursl c -> a red2Ursl g v0 (U4 a b c d xs) (U4 p q r s ys) = red2Ursl g (g (g (g (g v0 a p) b q) c r) d s) xs ys red2Ursl g v0 (U3 a b c) (U3 p q r) = g (g (g v0 a p) b q) c r red2Ursl g v0 (U2 a b) (U2 p q) = g (g v0 a p) b q red2Ursl g v0 (U1 a) (U1 p) = g v0 a p red2Ursl _ v0 (U0) (U0) = v0 red2Ursl _ _ _ _ = error "Ursl.red2Ursl: length mismatch" -- nthUrsl (toUrsl xs) n = xs !! n -- It's O(n) but the constant factor _should_ be smaller than for lists. nthUrsl :: (Eval a) => Ursl a -> Int -> a nthUrsl u n | n < 0 = error "Ursl.nthUrsl: negative index" | True = loop u n where loop (U4 a b c d xs) n = case n of {0 -> a; 1 -> b; 2 -> c; 3 -> d; _ -> loop xs (n-4)} loop (U3 a b c) n = case n of {0 -> a; 1 -> b; 2 -> c; _ -> error e} loop (U2 a b) n = case n of {0 -> a; 1 -> b; _ -> error e} loop (U1 a) n = case n of {0 -> a; _ -> error e} loop (U0) n = case n+0 of {_ -> error e} e = "Ursl.nthUrsl: index too large" -- replicateUrsl n x = toUrsl (replicate n x) replicateUrsl :: (Eval a) => Int -> a -> (Ursl a) replicateUrsl n a = case n of 0 -> U0 1 -> U1 a 2 -> U2 a a 3 -> U3 a a a n -> U4 a a a a (replicateUrsl (n-4) a) -- newUrsl f n = toUrsl [f i | i <- [0..n-1]] newUrsl :: Eval a => (Int -> a) -> Int -> Ursl a newUrsl f n | n < 0 = error "Ursl.newUrsl: negative size" | True = loop 0 n where loop _ 0 = U0 loop m 1 = U1 (f m) loop m 2 = U2 (f m) (f (m+1)) loop m 3 = U3 (f m) (f (m+1)) (f (m+2)) loop m n = U4 (f m) (f (m+1)) (f (m+2)) (f (m+3)) (loop (m+4) (n-4)) -- appUrsl (toUrsl xs) (toUrsl ys) = toUrsl (xs ++ ys) -- Unlike list concatenation, ursl concatenation has to copy BOTH -- arguments. Building up an ursl incrementally is NOT a good idea. -- If you want to do that, you're better to build up a list and then -- turn it into an ursl. The cost is O(#xs+#ys). appUrsl :: Eval a => Ursl a -> Ursl a -> Ursl a appUrsl (U4 a b c d xs) ys = U4 a b c d (appUrsl xs ys) appUrsl (U3 a b c) ys = cons3 a b c ys appUrsl (U2 a b) ys = cons2 a b ys appUrsl (U1 a) ys = cons1 a ys appUrsl (U0) ys = ys -- cons1 x (toUrsl xs) = toUrsl (x:xs) -- That is, it adds the element x at the front of an Ursl. -- Because the remaining elements have to be realigned, -- this costs O(#xs), *NOT* O(1). cons1 :: Eval a => a -> Ursl a -> Ursl a cons1 a (U4 p q r s ys) = U4 a p q r (cons1 s ys) cons1 a (U3 p q r) = U4 a p q r (U0) cons1 a (U2 p q) = U3 a p q cons1 a (U1 p) = U2 a p cons1 a (U0) = U1 a -- cons2 x y (toUrsl xs) = toUrsl (x:y:xs) -- That is, it adds the elements x,y at the front of an Ursl. -- Because the remaining elements have to be realigned, -- this costs O(#xs), *NOT* O(1). cons2 :: Eval a => a -> a -> Ursl a -> Ursl a cons2 a b (U4 p q r s ys) = U4 a b p q (cons2 r s ys) cons2 a b (U3 p q r) = U4 a b p q (U1 r) cons2 a b (U2 p q) = U4 a b p q (U0) cons2 a b (U1 p) = U3 a b p cons2 a b (U0) = U2 a b -- cons3 x y z (toUrsl xs) = toUrsl (x:y:z:xs) -- That is, it adds the elements x,y,z at the front of an Ursl. -- Because the remaining elements have to be realigned, -- this costs O(#xs), *NOT* O(1). cons3 :: Eval a => a -> a -> a -> Ursl a -> Ursl a cons3 a b c (U4 p q r s ys) = U4 a b c p (cons3 q r s ys) cons3 a b c (U3 p q r) = U4 a b c p (U2 q r) cons3 a b c (U2 p q) = U4 a b c p (U1 q) cons3 a b c (U1 p) = U4 a b c p (U0) cons3 a b c (U0) = U3 a b c -- hdUrsl (toUrsl xs) = hd xs (Clean name) -- This is O(1). hdUrsl :: Eval a => Ursl a -> a hdUrsl u = botUrsl u -- headUrsl (toUrsl xs) = head xs (Haskell name) -- This is O(1). headUrsl :: Eval a => Ursl a -> a headUrsl u = botUrsl u -- botUrsl (toUrsl (x:xs)) = x -- This is O(1) but the constant factor is higher than for lists. botUrsl :: Eval a => Ursl a -> a botUrsl (U4 a _ _ _ _) = a botUrsl (U3 a _ _) = a botUrsl (U2 a _) = a botUrsl (U1 a) = a botUrsl (U0) = error "Ursl.botUrsl: empty argument" -- loextUrsl x (toUrsl xs) = toUrsl (x:xs) -- Because the remaining elements have to be realigned, -- this costs O(#xs), *NOT* O(1). loextUrsl :: Eval a => a -> Ursl a -> Ursl a loextUrsl x (U4 a b c d xs) = U4 x a b c (loextUrsl d xs) loextUrsl x (U3 a b c) = U4 x a b c (U0) loextUrsl x (U2 a b) = U3 x a b loextUrsl x (U1 a) = U2 x a loextUrsl x (U0) = U1 x -- tlUrsl (toUrsl xs) = tl xs (Clean name) -- Because the remaining elements have to be realigned, -- this costs O(#xs), *NOT* O(1). tlUrsl :: Eval a => Ursl a -> Ursl a tlUrsl u = loremUrsl u -- tailUrsl (toUrsl xs) = tail xs (Haskell name) -- Because the remaining elements have to be realigned, -- this costs O(#xs), *NOT* O(1). tailUrsl :: Eval a => Ursl a -> Ursl a tailUrsl u = loremUrsl u -- loremUrsl (toUrsl (x:xs)) = toUrsl xs -- Because the remaining elements have to be realigned, -- this costs O(#xs), *NOT* O(1). loremUrsl :: Eval a => Ursl a -> Ursl a loremUrsl (U4 _ b c d (U0)) = U3 b c d loremUrsl (U4 _ b c d xs) = U4 b c d (botUrsl xs) (loremUrsl xs) loremUrsl (U3 _ b c) = U2 b c loremUrsl (U2 _ b) = U1 b loremUrsl (U1 _) = U0 loremUrsl (U0) = error "Ursl.loremUrsl: empty argument" -- lastUrsl (toUrsl xs) = last xs -- This is O(#xs) just like last, but the constant factor should be smaller. lastUrsl :: Eval a => Ursl a -> a lastUrsl u = topUrsl u -- topUrsl (toUrsl [x1,...,xn]) = xn topUrsl :: Eval a => Ursl a -> a topUrsl (U4 _ _ _ d (U0)) = d topUrsl (U4 _ _ _ _ xs) = topUrsl xs topUrsl (U3 _ _ c) = c topUrsl (U2 _ b) = b topUrsl (U1 a) = a topUrsl (U0) = error "Ursl.topUrsl: empty argument" -- hiextUrsl x (toUrsl xs) = toUrsl (append xs [x]) hiextUrsl :: Eval a => a -> Ursl a -> Ursl a hiextUrsl x (U4 a b c d xs) = U4 a b c d (hiextUrsl x xs) hiextUrsl x (U3 a b c) = U4 a b c x (U0) hiextUrsl x (U2 a b) = U3 a b x hiextUrsl x (U1 a) = U2 a x hiextUrsl x (U0) = U1 x -- initUrsl (toUrsl xs) = toUrsl (init xs) -- This is O(#xs) just like init, but the constant factor should be smaller. initUrsl :: Eval a => Ursl a -> Ursl a initUrsl u = hiremUrsl u -- hiremUrsl (toUrsl xs) = toUrsl (reverse (tl (reverse xs))) hiremUrsl :: Eval a => Ursl a -> Ursl a hiremUrsl (U4 a b c _ (U0)) = U3 a b c hiremUrsl (U4 a b c d xs) = U4 a b c d (hiremUrsl xs) hiremUrsl (U3 a b _) = U2 a b hiremUrsl (U2 a _) = U1 a hiremUrsl (U1 _) = U0 hiremUrsl (U0) = error "Ursl.hiremUrsl: empty argument" -- partitionUrsl p (toUrsl xs) = (toUrsl ps, toUrsl qs) -- where (ps, qs) = partition xs -- This could be done in one pass using 16 auxiliary functions with 0 to 6 -- arguments, the way filterUrsl has 4 auxiliary functions with 0 to 3 -- arguments. I'd much rather not, thank you. partitionUrsl :: (Eval a) => (a -> Bool) -> Ursl a -> (Ursl a, Ursl a) partitionUrsl p u = (filterUrsl p u, filterUrsl (not . p) u) -- filterUrsl p (toUrsl x) = toUrsl (filter p x) -- There is a very short way to write this: -- filterUrsl p = toUrsl . filter p . fromUrsl -- Is there a shorter _efficient_ way? filterUrsl :: (Eval a) => (a -> Bool) -> Ursl a -> Ursl a filterUrsl p u = loop0 u where loop0 (U4 a b c d xs) = case (p a,p b,p c,p d) of (True, True, True, True ) -> U4 a b c d (loop0 xs) (True, True, True, False) -> loop3 a b c xs (True, True, False,True ) -> loop3 a b d xs (True, True, False,False) -> loop2 a b xs (True, False,True, True ) -> loop3 a c d xs (True, False,True, False) -> loop2 a c xs (True, False,False,True ) -> loop2 a d xs (True, False,False,False) -> loop1 a xs (False,True, True, True ) -> loop3 b c d xs (False,True, True, False) -> loop2 b c xs (False,True, False,True ) -> loop2 b d xs (False,True, False,False) -> loop1 b xs (False,False,True, True ) -> loop2 c d xs (False,False,True, False) -> loop1 c xs (False,False,False,True ) -> loop1 d xs (False,False,False,False) -> loop0 xs loop0 (U3 a b c) = case (p a,p b,p c) of (True, True, True ) -> U3 a b c (True, True, False) -> U2 a b (True, False,True ) -> U2 a c (True, False,False) -> U1 a (False,True, True ) -> U2 b c (False,True, False) -> U1 b (False,False,True ) -> U1 c (False,False,False) -> U0 loop0 (U2 a b) = case (p a,p b) of (True, True ) -> U2 a b (True, False) -> U1 a (False,True ) -> U1 b (False,False) -> U0 loop0 (U1 a) = case (p a) of (True ) -> U1 a (False) -> U0 loop0 (U0) = U0 loop1 u (U4 a b c d xs) = case (p a,p b,p c,p d) of (True, True, True, True ) -> U4 u a b c (loop1 d xs) (True, True, True, False) -> U4 u a b c (loop0 xs) (True, True, False,True ) -> U4 u a b d (loop0 xs) (True, True, False,False) -> loop3 u a b xs (True, False,True, True ) -> U4 u a c d (loop0 xs) (True, False,True, False) -> loop3 u a c xs (True, False,False,True ) -> loop3 u a d xs (True, False,False,False) -> loop2 u a xs (False,True, True, True ) -> U4 u b c d (loop0 xs) (False,True, True, False) -> loop3 u b c xs (False,True, False,True ) -> loop3 u b d xs (False,True, False,False) -> loop2 u b xs (False,False,True, True ) -> loop3 u c d xs (False,False,True, False) -> loop2 u c xs (False,False,False,True ) -> loop2 u d xs (False,False,False,False) -> loop1 u xs loop1 u (U3 a b c) = case (p a,p b,p c) of (True, True, True ) -> U4 u a b c (U0) (True, True, False) -> U3 u a b (True, False,True ) -> U3 u a c (True, False,False) -> U2 u a (False,True, True ) -> U3 u b c (False,True, False) -> U2 u b (False,False,True ) -> U2 u c (False,False,False) -> U1 u loop1 u (U2 a b) = case (p a,p b) of (True, True ) -> U3 u a b (True, False) -> U2 u a (False,True ) -> U2 u b (False,False) -> U1 u loop1 u (U1 a) = case (p a) of (True ) -> U2 u a (False) -> U1 u loop1 u (U0) = U1 u loop2 u v (U4 a b c d xs) = case (p a,p b,p c,p d) of (True, True, True, True ) -> U4 u v a b (loop2 c d xs) (True, True, True, False) -> U4 u v a b (loop1 c xs) (True, True, False,True ) -> U4 u v a b (loop1 d xs) (True, True, False,False) -> U4 u v a b (loop0 xs) (True, False,True, True ) -> U4 u v a c (loop1 d xs) (True, False,True, False) -> U4 u v a c (loop0 xs) (True, False,False,True ) -> U4 u v a d (loop0 xs) (True, False,False,False) -> loop3 u v a xs (False,True, True, True ) -> U4 u v b c (loop1 d xs) (False,True, True, False) -> U4 u v b c (loop0 xs) (False,True, False,True ) -> U4 u v b d (loop0 xs) (False,True, False,False) -> loop3 u v b xs (False,False,True, True ) -> U4 u v c d (loop0 xs) (False,False,True, False) -> loop3 u v c xs (False,False,False,True ) -> loop3 u v d xs (False,False,False,False) -> loop2 u v xs loop2 u v (U3 a b c) = case (p a,p b,p c) of (True, True, True ) -> U4 u v a b (U1 c) (True, True, False) -> U4 u v a b (U0) (True, False,True ) -> U4 u v a c (U0) (True, False,False) -> U3 u v a (False,True, True ) -> U4 u v b c (U0) (False,True, False) -> U3 u v b (False,False,True ) -> U3 u v c (False,False,False) -> U2 u v loop2 u v (U2 a b) = case (p a,p b) of (True, True ) -> U4 u v a b (U0) (True, False) -> U3 u v a (False,True ) -> U3 u v b (False,False) -> U2 u v loop2 u v (U1 a) = case (p a) of (True ) -> U3 u v a (False) -> U2 u v loop2 u v (U0) = U2 u v loop3 u v w (U4 a b c d xs) = case (p a,p b,p c,p d) of (True, True, True, True ) -> U4 u v w a (loop3 b c d xs) (True, True, True, False) -> U4 u v w a (loop2 b c xs) (True, True, False,True ) -> U4 u v w a (loop2 b d xs) (True, True, False,False) -> U4 u v w a (loop1 b xs) (True, False,True, True ) -> U4 u v w a (loop2 c d xs) (True, False,True, False) -> U4 u v w a (loop1 c xs) (True, False,False,True ) -> U4 u v w a (loop1 d xs) (True, False,False,False) -> U4 u v w a (loop0 xs) (False,True, True, True ) -> U4 u v w b (loop2 c d xs) (False,True, True, False) -> U4 u v w b (loop1 c xs) (False,True, False,True ) -> U4 u v w b (loop1 d xs) (False,True, False,False) -> U4 u v w b (loop0 xs) (False,False,True, True ) -> U4 u v c d (loop0 xs) (False,False,True, False) -> U4 u v w c (loop0 xs) (False,False,False,True ) -> U4 u v w d (loop0 xs) (False,False,False,False) -> loop3 u v w xs loop3 u v w (U3 a b c) = case (p a,p b,p c) of (True, True, True ) -> U4 u v w a (U2 b c) (True, True, False) -> U4 u v w a (U1 b) (True, False,True ) -> U4 u v w a (U1 c) (True, False,False) -> U4 u v w a (U0) (False,True, True ) -> U4 u v w b (U1 c) (False,True, False) -> U4 u v w b (U0) (False,False,True ) -> U4 u v w c (U0) (False,False,False) -> U3 u v w loop3 u v w (U2 a b) = case (p a,p b) of (True, True ) -> U4 u v w a (U1 b) (True, False) -> U4 u v w a (U0) (False,True ) -> U4 u v w b (U0) (False,False) -> U3 u v w loop3 u v w (U1 a) = case (p a) of (True ) -> U4 u v w a (U0) (False) -> U3 u v w loop3 u v w (U0) = U3 u v w -- allUrsl p (toUrsl xs) = all p xs allUrsl :: Eval a => (a -> Bool) -> Ursl a -> Bool allUrsl p (U4 a b c d xs) = p a && p b && p c && p d && allUrsl p xs allUrsl p (U3 a b c) = p a && p b && p c allUrsl p (U2 a b) = p a && p b allUrsl p (U1 a) = p a allUrsl _ (U0) = True -- notElemUrsl x (toUrsl xs) = notElem x xs notElemUrsl :: (Eval a, Eq a) => a -> Ursl a -> Bool notElemUrsl x = allUrsl (/= x) -- anyUrsl p (toUrsl xs) = any p xs anyUrsl :: Eval a => (a -> Bool) -> Ursl a -> Bool anyUrsl p (U4 a b c d xs) = p a || p b || p c || p d || anyUrsl p xs anyUrsl p (U3 a b c) = p a || p b || p c anyUrsl p (U2 a b) = p a || p b anyUrsl p (U1 a) = p a anyUrsl _ (U0) = False -- elemUrsl x (toUrsl xs) = elem x xs -- This is O(#xs) just like elem. elemUrsl :: (Eval a, Eq a) => a -> Ursl a -> Bool elemUrsl x = anyUrsl (== x) -- isPrefixUrsl (toUrsl xs) (toUrsl ys) = isPrefixOf xs ys isPrefixUrsl :: (Eq a, Eval a) => Ursl a -> Ursl a -> Bool isPrefixUrsl (U4 a b c d xs) (U4 p q r s ys) = a == p && b == q && c == r && d == s && isPrefixUrsl xs ys isPrefixUrsl (U3 a b c) (U4 p q r _ _) = a == p && b == q && c == r isPrefixUrsl (U3 a b c) (U3 p q r) = a == p && b == q && c == r isPrefixUrsl (U2 a b) (U4 p q _ _ _) = a == p && b == q isPrefixUrsl (U2 a b) (U3 p q _) = a == p && b == q isPrefixUrsl (U2 a b) (U2 p q) = a == p && b == q isPrefixUrsl (U1 a) (U4 p _ _ _ _) = a == p isPrefixUrsl (U1 a) (U3 p _ _) = a == p isPrefixUrsl (U1 a) (U2 p _) = a == p isPrefixUrsl (U1 a) (U1 p) = a == p isPrefixUrsl (U0) (U0) = True isPrefixUrsl _ _ = False -- isSuffixUrsl (toUrsl xs) (toUrsl ys) = isSuffixOf xs ys -- If it's good enough for the list version to build reversed lists -- and check them, it's good enough for the ursl version. Note that -- the Quintus library equivalent of isSuffixOf did *NOT* build any -- reversed lists, but doing for ursls what it did would require 25 -- cases, which is a lot for a function of minor importance. isSuffixUrsl :: (Eq a, Eval a) => Ursl a -> Ursl a -> Bool isSuffixUrsl u v = pref (reverseFromUrsl u) (reverseFromUrsl v) where pref (x:xs) (y:ys) = x == y && pref xs ys pref (_:_ ) [] = False pref [] _ = True -- takeUrsl n (toUrsl xs) = toUrsl (take n xs) -- This is O(n), just like take, but the constant factor _should_ be smaller. -- Note that (n > lenUrsl u) => takeUrsl n u == u; -- it is NOT treated as an error. Negative n should be an error but isn't. takeUrsl :: Eval a => Int -> Ursl a -> Ursl a takeUrsl n (U4 a b c d xs) = case n of 0 -> U0 1 -> U1 a 2 -> U2 a b 3 -> U3 a b c n -> U4 a b c d (takeUrsl (n-4) xs) takeUrsl n u@(U3 a b _) = case n of 0 -> U0 1 -> U1 a 2 -> U2 a b _ -> u takeUrsl n u@(U2 a _) = case n of 0 -> U0 1 -> U1 a _ -> u takeUrsl n u@(U1 _) = case n of 0 -> U0 _ -> u takeUrsl n u@(U0) = case n of _ -> u -- takeWhileUrsl p (toUrsl xs) = toUrsl (takeWhile n xs) -- This is order(#result), just like takeWhile. It tests the same -- elements that takeWhile would, in the same order. takeWhileUrsl :: Eval a => (a -> Bool) -> Ursl a -> Ursl a takeWhileUrsl p (U4 a b c d xs) = if not (p a) then U0 else if not (p b) then U1 a else if not (p c) then U2 a b else if not (p d) then U3 a b c else U4 a b c d (takeWhileUrsl p xs) takeWhileUrsl p u@(U3 a b c) = if not (p a) then U0 else if not (p b) then U1 a else if not (p c) then U2 a b else u takeWhileUrsl p u@(U2 a b) = if not (p a) then U0 else if not (p b) then U1 a else u takeWhileUrsl p u@(U1 a) = if not (p a) then U0 else u takeWhileUrsl _ u@(U0) = u -- dropUrsl n (toUrsl xs) = toUrsl (drop n xs) -- Because the resulting elements have to be realigned, -- this costs O(#xs), *NOT* O(n) as drop does, and not O(#result) either. -- Note that (n > lenUrsl u) => dropUrsl n u == U0; -- it is NOT treated as an error. Negative n should be an error but isn't. dropUrsl :: Eval a => Int -> Ursl a -> Ursl a dropUrsl n u@(U4 _ b c d xs) = case n of 0 -> u 1 -> cons3 b c d xs 2 -> cons2 c d xs 3 -> cons1 d xs n -> dropUrsl (n-4) xs dropUrsl n u@(U3 _ b c) = case n of 0 -> u 1 -> U2 b c 2 -> U1 c _ -> U0 dropUrsl n u@(U2 _ b) = case n of 0 -> u 1 -> U1 b _ -> U0 dropUrsl n u@(U1 _) = case n of 0 -> u _ -> U0 dropUrsl n u@(U0) = case n of _ -> u -- dropWhileUrsl p (toUrsl xs) = toUrsl (dropWhile p xs) -- This tests the same elements that dropWhile would, in the same order, -- but because the remaining elements have to be realigned, -- it costs O(#xs), which is in general worse than dropWhile. dropWhileUrsl :: Eval a => (a -> Bool) -> Ursl a -> Ursl a dropWhileUrsl p u@(U4 a b c d xs) = if not (p a) then u else if not (p b) then cons3 b c d xs else if not (p c) then cons2 c d xs else if not (p d) then cons1 d xs else dropWhileUrsl p xs dropWhileUrsl p u@(U3 a b c) = if not (p a) then u else if not (p b) then U2 b c else if not (p c) then U1 c else U0 dropWhileUrsl p u@(U2 a b) = if not (p a) then u else if not (p b) then U1 b else U0 dropWhileUrsl p u@(U1 a) = if not (p a) then u else U0 dropWhileUrsl _ u@(U0) = u -- splitAtUrsl n (toUrsl xs) = (toUrsl as, toUrsl zs) -- where (as, zs) = splitAt n xs -- It is technically possible to do this in a single pass, which is -- the point of the splitAt function, but it's not easy. Maybe some -- day I'll do it; for now this at least gives the right answer. splitAtUrsl :: (Eval a) => Int -> Ursl a -> (Ursl a, Ursl a) splitAtUrsl n u = (takeUrsl n u, dropUrsl n u) -- spanUrsl p (toUrsl xs) = (toUrsl as, toUrsl zs) -- where (as, zs) = span p xs -- Same comment as splitAtUrsl. spanUrsl :: (Eval a) => (a -> Bool) -> Ursl a -> (Ursl a, Ursl a) spanUrsl p u = (takeWhileUrsl p u, dropWhileUrsl p u) -- breakUrsl p (toUrsl xs) = (toUrsl as, toUrsl zs) -- where (as, zs) = break p xs -- Same comment as splitAtUrsl and spanUrsl. -- Code any one of these three functions and the other two are obvious. breakUrsl :: (Eval a) => (a -> Bool) -> Ursl a -> (Ursl a, Ursl a) breakUrsl p u = spanUrsl (not . p) u -- zipListUrsl xs (toUrsl ys) = toUrsl (zip xs ys) -- The list argument may be infinite; the Ursl argument may not. -- It is an error if the ursl is longer than the list. zipListUrsl :: (Eval a, Eval b) => [a] -> Ursl b -> Ursl (a,b) zipListUrsl (a:b:c:d:xs) (U4 p q r s ys) = U4 (a,p) (b,q) (c,r) (d,s) (zipListUrsl xs ys) zipListUrsl (a:b:c:_) (U3 p q r) = U3 (a,p) (b,q) (c,r) zipListUrsl (a:b:_) (U2 p q) = U2 (a,p) (b,q) zipListUrsl (a:_) (U1 p) = U1 (a,p) zipListUrsl (_) (U0) = U0 zipListUrsl _ _ = error "Ursl.zipListUrsl: length mismatch" -- zipUrslUrsl (toUrsl xs) (toUrsl ys) = toUrsl (zip xs ys) -- The two ursls must be the same length; this is different from -- Prelude.list and could be changed if there were a compelling reason. zipUrslUrsl :: (Eval a, Eval b) => Ursl a -> Ursl b -> Ursl (a,b) zipUrslUrsl (U4 a b c d xs) (U4 p q r s ys) = U4 (a,p) (b,q) (c,r) (d,s) (zipUrslUrsl xs ys) zipUrslUrsl (U3 a b c) (U3 p q r) = U3 (a,p) (b,q) (c,r) zipUrslUrsl (U2 a b) (U2 p q) = U2 (a,p) (b,q) zipUrslUrsl (U1 a) (U1 p) = U1 (a,p) zipUrslUrsl (U0) (U0) = U0 zipUrslUrsl _ _ = error "Ursl.zipUrslUrsl: length mismatch" {- Haskell has one function zip :: [a] -> [b] -> [(a,b)]. Clean has two: zip :: ([a],[b]) -> [(a,b)] zip2 :: [a] [b] -> [(a,b)]. Clean is clearly right here; it makes sense to have a function that is an exact inverse of unzip, so in Clean we have zip o unzip :: [(a,b)] -> [(a,b)] is the identity unzip o zip :: ([a],[b]) -> ([a],[b]) is the identity Since I already wanted zipListUrsl, it made sense to have (Clean) zip2 => zipUrslUrsl (both arguments Ursls) => zipListUrsl (one a list, the other an Ursl) (Clean) zip => zipUrsl -} -- zipUrsl (toUrsl xs, toUrsl ys) = toUrsl (zip xs ys) zipUrsl :: (Eval a, Eval b) => (Ursl a, Ursl b) -> Ursl (a,b) zipUrsl (xs,ys) = zipUrslUrsl xs ys -- zipWithUrsl f (toUrsl xs, toUrsl ys) = toUrsl (zipWith f xs ys) zipWithUrsl :: (Eval a, Eval b, Eval c) => (a -> b -> c) -> (Ursl a, Ursl b) -> Ursl c zipWithUrsl f (xs, ys) = zipWithUrslUrsl f xs ys -- zipWithUrslUrsl f (toUrsl xs) (toUrsl ys) = toUrsl (zipWith f xs ys) -- The two ursls must be the same length; this is different from -- Prelude.list and could be changed if there were a compelling reason. zipWithUrslUrsl :: (Eval a, Eval b, Eval c) => (a -> b -> c) -> Ursl a -> Ursl b -> Ursl c zipWithUrslUrsl f (U4 a b c d xs) (U4 p q r s ys) = U4 (f a p) (f b q) (f c r) (f d s) (zipWithUrslUrsl f xs ys) zipWithUrslUrsl f (U3 a b c) (U3 p q r) = U3 (f a p) (f b q) (f c r) zipWithUrslUrsl f (U2 a b) (U2 p q) = U2 (f a p) (f b q) zipWithUrslUrsl f (U1 a) (U1 p) = U1 (f a p) zipWithUrslUrsl _ (U0) (U0) = U0 zipWithUrslUrsl _ _ _ = error "Ursl.zipWithUrslUrsl: length mismatch" -- zipWithListUrsl fxs (toUrsl ys) = toUrsl (zipWith f xs ys) -- The list argument may be infinite; the Ursl argument may not. -- It is an error if the ursl is longer than the list. zipWithListUrsl :: (Eval a, Eval b, Eval c) => (a -> b -> c) -> [a] -> Ursl b -> Ursl c zipWithListUrsl f (a:b:c:d:xs) (U4 p q r s ys) = U4 (f a p) (f b q) (f c r) (f d s) (zipWithListUrsl f xs ys) zipWithListUrsl f (a:b:c:_) (U3 p q r) = U3 (f a p) (f b q) (f c r) zipWithListUrsl f (a:b:_) (U2 p q) = U2 (f a p) (f b q) zipWithListUrsl f (a:_) (U1 p) = U1 (f a p) zipWithListUrsl _ (_) (U0) = U0 zipWithListUrsl _ _ _ = error "Ursl.zipWithListUrsl: length mismatch" -- unzipUrsl (toUrsl xs) = (toUrsl as,toUrsl bs) where (as, bs) = unzip xs unzipUrsl :: (Eval a, Eval b) => Ursl (a,b) -> (Ursl a, Ursl b) unzipUrsl (U4 (a,p) (b,q) (c,r) (d,s) xs) = (U4 a b c d as, U4 p q r s bs) where (as, bs) = unzipUrsl xs unzipUrsl (U3 (a,p) (b,q) (c,r)) = (U3 a b c, U3 p q r) unzipUrsl (U2 (a,p) (b,q)) = (U2 a b, U2 p q) unzipUrsl (U1 (a,p)) = (U1 a, U1 p) unzipUrsl (U0) = (U0, U0) -- foldlUrsl f a (toUrsl xs) = foldl f a xs foldlUrsl :: (Eval b) => (a -> b -> a) -> a -> (Ursl b) -> a foldlUrsl f x0 (U4 a b c d xs) = foldlUrsl f (f (f (f (f x0 a) b) c) d) xs foldlUrsl f x0 (U3 a b c) = f (f (f x0 a) b) c foldlUrsl f x0 (U2 a b) = f (f x0 a) b foldlUrsl f x0 (U1 a) = f x0 a foldlUrsl _ x0 (U0) = x0 -- foldl1Ursl f (toUrsl xs) = foldl1 f xs foldl1Ursl :: (Eval a) => (a -> a -> a) -> (Ursl a) -> a foldl1Ursl f (U4 a b c d xs) = foldlUrsl f (f (f (f a b) c) d) xs foldl1Ursl f (U3 a b c) = f (f a b) c foldl1Ursl f (U2 a b) = f a b foldl1Ursl _ (U1 a) = a foldl1Ursl _ (U0) = error "Ursl.foldl1Ursl: empty argument" -- scanlUrsl f a (toUrsl xs) = toUrsl (scanl f a xs) scanlUrsl :: (Eval a, Eval b) => (a -> b -> a) -> a -> (Ursl b) -> (Ursl a) scanlUrsl f x0 (U4 a b c d xs) = U4 x0 xa xb xc (scanlUrsl f xd xs) where xa = f x0 a xb = f xa b xc = f xb c xd = f xc d scanlUrsl f x0 (U3 a b c) = U4 x0 xa xb xc (U0) where xa = f x0 a xb = f xa b xc = f xb c scanlUrsl f x0 (U2 a b) = U3 x0 xa xb where xa = f x0 a xb = f xa b scanlUrsl f x0 (U1 a) = U2 x0 xa where xa = f x0 a scanlUrsl _ x0 (U0) = U1 x0 -- scanl1Ursl f (toUrsl xs) = scanl1 f xs scanl1Ursl :: (Eval a) => (a -> a -> a) -> (Ursl a) -> (Ursl a) scanl1Ursl f (U4 a b c d xs) = U4 a xb xc xd (loop xd xs) where xb = f a b xc = f xb c xd = f xc d loop fo (U4 p q r s ys) = U4 fp fq fr fs (loop fs ys) where fp = f fo p fq = f fp q fr = f fq r fs = f fr s loop fo (U3 p q r) = U3 fp fq fr where fp = f fo p fq = f fp q fr = f fq r loop fo (U2 p q) = U2 fp fq where fp = f fo p fq = f fp q loop fo (U1 p) = U1 fp where fp = f fo p loop _ (U0) = U0 scanl1Ursl f (U3 a b c) = U3 a xb xc where xb = f a b xc = f xb c scanl1Ursl f (U2 a b) = U2 a xb where xb = f a b scanl1Ursl _ (U1 a) = U1 a scanl1Ursl _ (U0) = U0 -- foldrUrsl f x0 (toUrsl xs) = foldr f x0 xs foldrUrsl :: (Eval a) => (a -> b -> b) -> b -> (Ursl a) -> b foldrUrsl f x0 (U4 a b c d xs) = f a (f b (f c (f d (foldrUrsl f x0 xs)))) foldrUrsl f x0 (U3 a b c) = f a (f b (f c x0)) foldrUrsl f x0 (U2 a b) = f a (f b x0) foldrUrsl f x0 (U1 a) = f a x0 foldrUrsl _ x0 (U0) = x0 -- foldr1Ursl f (toUrsl xs) = foldr1 f xs foldr1Ursl :: (Eval a) => (a -> a -> a) -> (Ursl a) -> a foldr1Ursl f (U4 a b c d xs) = f a (f b (f c (f d (foldr1Ursl f xs)))) foldr1Ursl f (U3 a b c) = f a (f b c) foldr1Ursl f (U2 a b) = f a b foldr1Ursl _ (U1 a) = a foldr1Ursl _ (U0) = error "Ursl.foldr1Ursl: empty argument" -- scanrUrsl f (toUrsl xs) = toUrsl (scanr f xs) -- I don't see any clean way of doing this without an auxiliary -- pair-returning function. The Glasgow extension of unboxed tuple -- results would come in very handy here! scanrUrsl :: (Eval a, Eval b) => (b -> a -> a) -> a -> (Ursl b) -> (Ursl a) scanrUrsl f x0 u = v where (_,v) = loop u loop (U4 a b c d xs) = (fa, U4 fa fb fc fd ys) where (fe,ys) = loop xs fd = f d fe fc = f c fd fb = f b fc fa = f a fb loop (U3 a b c) = (fa, U4 fa fb fc x0 U0) where fc = f c x0 fb = f b fc fa = f a fb loop (U2 a b) = (fa, U3 fa fb x0) where fb = f b x0 fa = f a fb loop (U1 a) = (fa, U2 fa x0) where fa = f a x0 loop (U0) = (x0, U1 x0) -- scanr1Ursl f (toUrsl xs) = toUrsl (scanr1 f xs) scanr1Ursl :: (Eval a) => (a -> a -> a) -> (Ursl a) -> (Ursl a) scanr1Ursl f (U4 a b c d U0) = U4 fa fb fc d U0 where fc = f c d fb = f b fc fa = f a fb scanr1Ursl f (U4 a b c d xs) = U4 fa fb fc fd ys where ys = scanr1Ursl f xs fd = f d (botUrsl ys) fc = f c fd fb = f b fc fa = f a fb scanr1Ursl f (U3 a b c) = U3 fa fb c where fb = f b c fa = f a fb scanr1Ursl f (U2 a b) = U2 fa b where fa = f a b scanr1Ursl _ (U1 a) = U1 a scanr1Ursl _ (U0) = U0 -- reverseUrsl (toUrsl xs) = toUrsl (reverse xs) -- There doesn't seem to be any simple way to do this directly; -- no matter what we do a two pass algorithm seems to be required, -- so I've taken the easy way out and built an intermediate list. reverseUrsl :: Eval a => (Ursl a) -> (Ursl a) reverseUrsl u = toUrsl (reverseFromUrsl u) -- reverseFromUrsl u takes O(#u) time and allocates O(#u) space reverseFromUrsl :: Eval a => Ursl a -> [a] reverseFromUrsl u = loop u [] where loop (U4 a b c d xs) ys = loop xs (d:c:b:a:ys) loop (U3 a b c) ys = c:b:a:ys loop (U2 a b) ys = b:a:ys loop (U1 a) ys = a:ys loop (U0) ys = ys -- sumUrsl (toUrsl xs) = sum xs sumUrsl :: (Eval a, Num a) => (Ursl a) -> a sumUrsl u = foldlUrsl (+) 0 u -- productUrsl (toUrsl xs) = product xs productUrsl :: (Eval a, Num a) => (Ursl a) -> a productUrsl u = foldlUrsl (*) 1 u -- maximumUrsl (toUrsl xs) = maximum xs maximumUrsl :: (Eval a, Ord a) => (Ursl a) -> a maximumUrsl u = foldl1Ursl max u -- minimumUrsl (toUrsl xs) = minimum xs minimumUrsl :: (Eval a, Ord a) => (Ursl a) -> a minimumUrsl u = foldl1Ursl min u -- elemIndicesUrsl x (toUrsl xs) = elemIndices x xs -- Note that the result is a LIST, not an ursl. elemIndicesUrsl :: (Eq a, Eval a) => a -> (Ursl a) -> [Int] elemIndicesUrsl x u = findIndicesUrsl (x ==) u -- findIndicesUrsl p (toUrsl xs) = findIndices p xs -- Note that the result is a LIST, not an ursl. -- I'm not sure which it should be, but since the result is not -- guaranteed to be the same shape as any existing ursl, let alone -- the argument, it does not appear that there's any great advantage -- to making it an ursl. There should be a function (for lists and -- another for ursls) that takes a non-decreasing list of ints and -- indexes into a list (or an ursl) to select the elements that -- findIndices has found the indices of. findIndicesUrsl :: (Eval a) => (a -> Bool) -> (Ursl a) -> [Int] findIndicesUrsl p u = loop 0 u where loop x (U4 a b c d xs) = let ys = loop (x+4) xs in let dr = if p d then (x+3):ys else ys in let cr = if p c then (x+2):dr else dr in let br = if p b then (x+1):cr else cr in if p a then (x+0):br else br loop x (U3 a b c) = let cr = if p c then [x+2] else [] in let br = if p b then (x+1):cr else cr in if p a then (x+0):br else br loop x (U2 a b) = let br = if p b then [x+1] else [] in if p a then (x+0):br else br loop x (U1 a) = if p a then [x+0] else [] loop _ (U0) = [] -- elemIndexUrsl x (toUrsl xs) = elemIndex x xs elemIndexUrsl :: (Eval a, Eq a) => a -> (Ursl a) -> Maybe Int elemIndexUrsl x u = findIndexUrsl (x ==) u -- findIndexUrsl p (toUrsl xs) = findIndex p xs -- This _cannot_ be a specialisation of findIndicesUrsl, although it -- computes the same result that such a specialisation would, because -- we expect the cost to be O(number of leading elements that are not p) -- while findIndicesUrsl is O(#xs). findIndexUrsl :: (Eval a) => (a -> Bool) -> (Ursl a) -> Maybe Int findIndexUrsl p u = loop 0 u where loop x (U4 a b c d xs) | p a = Just (x+0) | p b = Just (x+1) | p c = Just (x+2) | p d = Just (x+3) | True = loop (x+4) xs loop x (U3 a b c) | p a = Just (x+0) | p b = Just (x+1) | p c = Just (x+2) | True = Nothing loop x (U2 a b) | p a = Just (x+0) | p b = Just (x+1) | True = Nothing loop x (U1 a) | p a = Just (x+0) | True = Nothing loop _ (U0) | True = Nothing -- findUrsl p (toUrsl xs) = find p xs findUrsl :: (Eval a) => (a -> Bool) -> (Ursl a) -> Maybe a findUrsl p (U4 a b c d xs) | p a = Just a | p b = Just b | p c = Just c | p d = Just d | True = findUrsl p xs findUrsl p (U3 a b c) | p a = Just a | p b = Just b | p c = Just c | True = Nothing findUrsl p (U2 a b) | p a = Just a | p b = Just b | True = Nothing findUrsl p (U1 a) | p a = Just a | True = Nothing findUrsl _ (U0) | True = Nothing -- lookupUrsl k (toUrsl d) = lookup k d -- This is slightly frivolous, but then, so is Prelude.lookup! lookupUrsl :: (Eq a, Eval a, Eval b) => a -> (Ursl (a,b)) -> Maybe b lookupUrsl k (U4 (ka,va) (kb,vb) (kc,vc) (kd,vd) xs) | k == ka = Just va | k == kb = Just vb | k == kc = Just vc | k == kd = Just vd | True = lookupUrsl k xs lookupUrsl k (U3 (ka,va) (kb,vb) (kc,vc)) | k == ka = Just va | k == kb = Just vb | k == kc = Just vc | True = Nothing lookupUrsl k (U2 (ka,va) (kb,vb)) | k == ka = Just va | k == kb = Just vb | True = Nothing lookupUrsl k (U1 (ka,va)) | k == ka = Just va | True = Nothing lookupUrsl _ (U0) | True = Nothing {- Prelude Ursl ======= ==== Eq == == /= /= Ord < < >= >= > > <= <= max max min min Read readsPrec readsPrec readList -- nothing special Show showsPrec showsPrec showList -- nothing special Functor map (Haskell 1.4) -- This module has to be compatible fmap (Haskell 98) -- with BOTH versions for now, so -- can't do either. Use mapUrsl Monad, MonadPlus, MonadZero >>= -- not provided >> -- not provided return -- not provided MonadZero zero zeroUrsl filter filterUrsl MonadPlus ++ appUrsl concat -- not provided specific [] zeroUrsl : loextUrsl head headUrsl, hdUrsl, botUrsl last lastUrsl, topUrsl tail tailUrsl, tlUrsl, loremUrsl init initUrsl, hiremUrsl null nullUrsl, isEmptyUrsl length lenUrsl !! nthUrsl foldl foldlUrsl foldl' -- not needed, already strict foldl1 foldl1Ursl scanl scanlUrsl scanl1 scanl1Ursl foldr foldrUrsl foldr1 foldr1Ursl scanr scanrUrsl scanr1 scanr1Ursl replicate replicateUrsl take takeUrsl drop dropUrsl splitAt splitAtUrsl (currently 2-pass) takeWhile takeWhileUrsl dropWhile dropWhileUrsl span spanUrsl (currently 2-pass) break breakUrsl (currently 2-pass) reverse reverseUrsl any anyUrsl all allUrsl elem elemUrsl notElem notElemUrsl lookup lookupUrsl sum sumUrsl product productUrsl maximum maximumUrsl minimum minimumUrsl zip zipUrslUrsl, zipListUrsl zipWith zipWithUrslUrsl, zipWithListUrsl unzip unzipUrsl List Ursl ==== ==== elemIndex elemIndexUrsl elemIndices elemIndicesUrsl findIndex findIndexUrsl findIndices findIndicesUrsl partition partitionUrsl isPrefixOf isPrefixUrsl isSuffixOf isSuffixUrsl mapAccumL mapAccumLUrsl mapAccumR mapAccumRUrsl Not provided iterate -- makes an infinite list repeat -- makes an infinite list cycle -- makes an infinite list lines -- String-specific words -- String-specific unlines -- String-specific unwords -- String-specific and -- not pointful as Ursls are strict or -- not pointful as Ursls are strict zip3 and higher -- can do, but wait till need seen zipWith3 and higher -- can do, but wait till need seen unzip3 and higher -- can do, but wait till need seen nub, nubBy -- unordered sequences are wrong for delete, deleteBy -- sets; ordered sequences are fine, \\, deleteFirstBy -- and trees are good. Since ursls union, unionBy -- to improve space and time costs, intersect, intersectBy, -- using them badly would be pointless. intersperse -- can do, but wait till need seen transpose -- doable, useful, but rather tricky. group, groupBy -- doable, tricky, query use inits -- doable, costly, query use tails -- doable, costly, query use maximumBy -- is just foldl1 except for err msg minimumBy -- is just foldl1 except for err msg sort, sortBy, insertBy -- see note on sorting below genericLength -- use lenUrsl and convert result genericTake -- convert length, call takeUrsl genericDrop -- convert length, call dropUrsl genericSplitAt -- convert length, call splitAtUrsl genericIndex -- convert index, call nthUrsl genericReplicate -- convert length, call replicateUrsl The sorting algorithm in the Hugs library (from which I culled this list) is insertion sort, a strange choice when merge sort is so easy and so fast. You are at the mercy of whatever List.sort gives you. Incremental operations on ursls are so inefficient (no criticism; they're not _designed_ to be good at incremental ones but to be better than lists at _bulk_ operations) that it is certain to be faster to do sortUrsl = toUrsl . sort . fromUrsl and I would have done that except that I don't want to import List into this module and I don't want to tie the reputation of this module to someone's decision to use insertion sort in List. -}