// File : Ursl.icl // Author : Richard A. O'Keefe // Version: 1.0 // SCCS : @(#)99/03/22 Ursl.icl 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 Clean 1.3. There is also a version for Hugs and GHC, Ursl.hs. 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. */ implementation module Ursl import StdEnv, Maybe :: Ursl a = U0 | U1 !a | U2 !a !a | U3 !a !a !a | U4 !a !a !a !a !(Ursl a) instance == (Ursl a) | == a where (==) :: !(Ursl a) !(Ursl a) -> Bool | Eq a (==) (U4 a b c d xs) (U4 p q r s ys) = a == p && b == q && c == r && d == s && xs == ys (==) (U3 a b c) (U3 p q r) = a == p && b == q && c == r (==) (U2 a b) (U2 p q) = a == p && b == q (==) (U1 a) (U1 p) = a == p (==) (U0) (U0) = True (==) _ _ = False instance < (Ursl a) | < a where (<) :: !(Ursl a) !(Ursl a) -> Bool | < a (<) (U4 a b c d xs) (U4 p q r s ys) | a < p = True | p < a = False | b < q = True | q < b = False | c < r = True | r < c = False | d < s = True | s < d = False | True = (<) xs ys (<) (U4 a b c _ _ ) (U3 p q r) | a < p = True | p < a = False | b < q = True | q < b = False | c < r = True | True = False (<) (U4 a b _ _ _ ) (U2 p q) | a < p = True | p < a = False | b < q = True | True = False (<) (U4 a _ _ _ _ ) (U1 p) | a < p = True | True = False (<) (U4 _ _ _ _ _ ) (U0) | True = False (<) (U3 a b c) (U4 p q r _ _) | a < p = True | p < a = False | b < q = True | q < b = False | r < c = False | True = True (<) (U3 a b c) (U3 p q r) | a < p = True | p < a = False | b < q = True | q < b = False | c < r = True | True = False (<) (U3 a b _) (U2 p q) | a < p = True | p < a = False | b < q = True | True = False (<) (U3 a _ _) (U1 p) | a < p = True | True = False (<) (U3 _ _ _) (U0) | True = False (<) (U2 a b) (U4 p q _ _ _) | a < p = True | p < a = False | b < q = True | q < b = False | True = True (<) (U2 a b) (U3 p q _) | a < p = True | p < a = False | b < q = True | q < b = False | True = True (<) (U2 a b) (U2 p q) | a < p = True | p < a = False | b < q = True | True = False (<) (U2 a _) (U1 p) | a < p = True | True = False (<) (U2 _ _) (U0) | True = False (<) (U1 a) (U4 p _ _ _ _) | a < p = True | p < a = False | True = True (<) (U1 a) (U3 p _ _) | a < p = True | p < a = False | True = True (<) (U1 a) (U2 p _) | a < p = True | p < a = False | True = True (<) (U1 a) (U1 p) | a < p = True | True = False (<) (U1 _) (U0) | True = False (<) (U0) (U4 _ _ _ _ _) = True (<) (U0) (U3 _ _ _) = True (<) (U0) (U2 _ _) = True (<) (U0) (U1 _) = True (<) (U0) (U0) = False // zeroUrsl is an empty ursl, like []. zeroUrsl :: (Ursl a) zeroUrsl = U0 // nullUrsl is identical to ==zeroUrsl nullUrsl :: !(Ursl a) -> Bool nullUrsl U0 = True nullUrsl _ = False // isEmptyUrsl is another name for nullUrsl isEmptyUrsl :: !(Ursl a) -> Bool isEmptyUrsl U0 = True isEmptyUrsl _ = False // lengthUrsl (toUrsl xs) = length xs lengthUrsl :: !(Ursl a) -> Int lengthUrsl u = lenUrsl u // lenUrsl u takes O(#u) time. lenUrsl :: !(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 instance length Ursl where length :: !(Ursl a) -> Int length u = lenUrsl u // toUrsl l takes O(#l) time and allocates O(#l) space toUrsl :: ![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 :: !(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) = [] // mapAccumLUrsl f s0 (toUrsl xs) = (s, toUrsl r) // where (s, r) = mapAccumL f s0 xs mapAccumLUrsl :: !(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 :: !(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 :: !(!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 :: !(!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 _ _ _ = abort "Ursl.map2Ursl: length mismatch" // redUrsl f x0 (toUrsl xs) = foldl f x0 xs redUrsl :: !(!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 :: !(!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 _ _ _ _ = abort "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 :: !(Ursl a) !Int -> a nthUrsl u n | n < 0 = abort "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; _ -> abort e} loop (U2 a b) n = case n of {0 -> a; 1 -> b; _ -> abort e} loop (U1 a) n = case n of {0 -> a; _ -> abort e} loop (U0) n = case n+0 of {_ -> abort e} e = "Ursl.nthUrsl: index too large" // replicateUrsl n x = toUrsl (replicate n x) replicateUrsl :: !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 :: !(!Int -> a) !Int -> *(Ursl a) newUrsl f n | n < 0 = abort "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)) instance fromString (Ursl a) | fromChar a where fromString :: !{#Char} -> (Ursl a) | fromChar a fromString s = newUrsl (\i -> fromChar (s.[i])) (size s) // 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 :: !(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 // Result would be *(Ursl a) but for this! // 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 :: !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 :: !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 :: !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 :: !(Ursl a) -> a hdUrsl u = botUrsl u // headUrsl (toUrsl xs) = head xs (Haskell name) // This is O(1). headUrsl :: !(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 :: !(Ursl a) -> a botUrsl (U4 a _ _ _ _) = a botUrsl (U3 a _ _) = a botUrsl (U2 a _) = a botUrsl (U1 a) = a botUrsl (U0) = abort "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 :: !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 :: !(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 :: !(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 :: !(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) = abort "Ursl.loremUrsl: empty argument" // lastUrsl (toUrsl xs) = last xs // This is O(#xs) just like last, but the constant factor should be smaller. lastUrsl :: !(Ursl a) -> a lastUrsl u = topUrsl u topUrsl :: !(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) = abort "Ursl.topUrsl: empty argument" // hiextUrsl x (toUrsl xs) = toUrsl (append xs [x]) hiextUrsl :: !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 :: !(Ursl a) -> *(Ursl a) initUrsl u = hiremUrsl u // hiremUrsl (toUrsl xs) = toUrsl (reverse (tl (reverse xs))) hiremUrsl :: !(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) = abort "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 :: !(!a -> Bool) !(Ursl a) -> *(*Ursl a, *Ursl a) partitionUrsl p u = (filterUrsl p u, filterUrsl (not o 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 :: !(!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 :: !(!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 p (U0) = True // notElemUrsl x (toUrsl xs) = notElem x xs notElemUrsl :: !a !(Ursl a) -> Bool | == a notElemUrsl x xs = allUrsl (\y -> not (y == x)) xs // anyUrsl p (toUrsl xs) = any p xs anyUrsl :: !(!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 p (U0) = False // elemUrsl x (toUrsl xs) = elem x xs // This is O(#xs) just like elem. elemUrsl :: !a !(Ursl a) -> Bool | == a elemUrsl x xs = anyUrsl (\y -> y == x) xs // isPrefixUrsl (toUrsl xs) (toUrsl ys) = isPrefixOf xs ys isPrefixUrsl :: !(Ursl a) !(Ursl a) -> Bool | == a 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 :: !(Ursl a) !(Ursl a) -> Bool | == a 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. // Several clauses construct fresh copies of their input when it would // seem that an as-pattern could have been used; that's so that a tiny // bit at the end doesn't spoil compile-time detection that the bulk of // the result is new. takeUrsl :: !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 (U3 a b c) = case n of 0 -> U0 1 -> U1 a 2 -> U2 a b _ -> U3 a b c takeUrsl n (U2 a b) = case n of 0 -> U0 1 -> U1 a _ -> U2 a b takeUrsl n (U1 a) = case n of 0 -> U0 _ -> U1 a takeUrsl n u=:(U0) = case n of _ -> U0 // 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. // Several clauses construct fresh copies of their input when it would // seem that an as-pattern could have been used; that's so that a tiny // bit at the end doesn't spoil compile-time detection that the bulk of // the result is new. takeWhileUrsl :: !(!a -> Bool) !(Ursl a) -> *(Ursl a) takeWhileUrsl p (U4 a b c d xs) = if (not (p a)) U0 (if (not (p b)) (U1 a) (if (not (p c)) (U2 a b) (if (not (p d)) (U3 a b c) (U4 a b c d (takeWhileUrsl p xs))))) takeWhileUrsl p (U3 a b c) = if (not (p a)) U0 (if (not (p b)) (U1 a) (if (not (p c)) (U2 a b) (U3 a b c))) takeWhileUrsl p (U2 a b) = if (not (p a)) U0 (if (not (p b)) (U1 a) (U2 a b)) takeWhileUrsl p (U1 a) = if (not (p a)) U0 (U1 a) takeWhileUrsl p (U0) = (U0) // 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. // The result *might* share with the input, or it might not. dropUrsl :: !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. // The result *might* share with the input, or it might not. dropWhileUrsl :: !(!a -> Bool) !(Ursl a) -> (Ursl a) dropWhileUrsl p u=:(U4 a b c d xs) = if (not (p a)) u (if (not (p b)) (cons3 b c d xs) (if (not (p c)) (cons2 c d xs) (if (not (p d)) (cons1 d xs) (dropWhileUrsl p xs)))) dropWhileUrsl p u=:(U3 a b c) = if (not (p a)) u (if (not (p b)) (U2 b c) (if (not (p c)) (U1 c) U0)) dropWhileUrsl p u=:(U2 a b) = if (not (p a)) u (if (not (p b)) (U1 b) U0) dropWhileUrsl p u=:(U1 a) = if (not (p a)) u U0 dropWhileUrsl p u=:(U0) = u instance % (Ursl a) where (%) :: !(Ursl a) !(!Int,!Int) -> (Ursl a) (%) u (f,t) = takeUrsl (t-f+1) (dropUrsl f 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. // Note that the result is NOT *(*Ursl a, *Ursl a) because the // second element of the pair MIGHT NOT be new. splitAtUrsl :: !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 :: !(!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 :: !(!a -> Bool) !(Ursl a) -> *(*Ursl a, Ursl a) breakUrsl p u = spanUrsl (not o 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 :: ![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 _ _ = abort "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 :: !(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 _ _ = abort "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 :: !(!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 :: !(!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 :: !(!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 _ _ _ = abort "Ursl.zipWithUrslUrsl: length mismatch" // zipWithListUrsl fxs (toUrsl ys) = toUrsl (zipWith f xs ys) // The list argument may be infinite; the Ursl argument may not. zipWithListUrsl :: !(!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 // unzipUrsl (toUrsl xs) = (toUrsl as,toUrsl bs) where (as, bs) = unzip xs unzipUrsl :: !(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 :: !(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 :: (!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) = abort "Ursl.foldl1Ursl: empty argument" // scanlUrsl f a (toUrsl xs) = toUrsl (scanl f a xs) scanlUrsl :: !(!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 :: !(!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 :: !(!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 :: !(!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) = abort "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 :: !(!b a -> a) a !(Ursl b) -> *(Ursl a) scanrUrsl f x0 u = v where (_,v) = loop u // loop :: !(Ursl a) -> *(b, *Ursl b) 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 :: !(!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) = let! ys = scanr1Ursl f xs fd = f d (botUrsl ys) fc = f c fd fb = f b fc fa = f a fb in U4 fa fb fc fd ys 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 :: !(Ursl a) -> *(Ursl a) reverseUrsl u = toUrsl (reverseFromUrsl u) // reverseFromUrsl u takes O(#u) time and allocates O(#u) space reverseFromUrsl :: !(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 :: !(Ursl a) -> a | +, zero a sumUrsl u = foldlUrsl (+) zero u // productUrsl (toUrsl xs) = product xs productUrsl :: !(Ursl a) -> a | *, one a productUrsl u = foldlUrsl (*) one u // maximumUrsl (toUrsl xs) = maximum xs maximumUrsl :: !(Ursl a) -> a | Ord a maximumUrsl u = foldl1Ursl max u // minimumUrsl (toUrsl xs) = minimum xs minimumUrsl :: !(Ursl a) -> a | Ord a minimumUrsl u = foldl1Ursl min u // elemIndicesUrsl x (toUrsl xs) = elemIndices x xs // Note that the result is a LIST, not an ursl. elemIndicesUrsl :: !a !(Ursl a) -> *[!Int] | == a 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 :: !(!a -> Bool) !(Ursl a) -> *[!Int] findIndicesUrsl p u = loop 0 u where check :: !Bool !Int *[!Int] -> *[!Int] check True x xs = [x:xs] check False _ xs = xs loop x (U4 a b c d xs) = check (p a) (x+0) ( check (p b) (x+1) ( check (p c) (x+2) ( check (p d) (x+3) ( loop (x+4) xs)))) loop x (U3 a b c) = check (p a) (x+0) ( check (p b) (x+1) ( check (p c) (x+2) ( []))) loop x (U2 a b) = check (p a) (x+0) ( check (p b) (x+1) ( [])) loop x (U1 a) = check (p a) x [] loop _ (U0) = [] // elemIndexUrsl x (toUrsl xs) = elemIndex x xs elemIndexUrsl :: !a !(Ursl a) -> *Maybe !Int | == a 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 :: !(!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 :: !(!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 :: !a !(Ursl (a,b)) -> *Maybe b | == a 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. */