| PLEAC-Haskell | ||
|---|---|---|
| Prev | ||
module Pleac where import Prelude hiding (($),(^),(.),(!!),map,take,lookup,drop,splitAt,reverse,filter,takeWhile,dropWhile,null,foldl) import Common -------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------- module Common ( module Common , module Regexp , module System , module Complex , module Char , module Numeric -- Monad , foldM -- List , elemIndex, elemIndices, find, findIndex, findIndices, nub, nubBy, delete, deleteBy, (\\), deleteFirstsBy, union, unionBy, intersect, intersectBy, intersperse, transpose, partition, group, groupBy, inits, tails, isPrefixOf, isSuffixOf, mapAccumL, mapAccumR, sort, sortBy, insert, insertBy, maximumBy, minimumBy, genericLength, genericTake, genericDrop, genericSplitAt, genericIndex, genericReplicate, zip4, zip5, zip6, zip7, zipWith4, zipWith5, zipWith6, zipWith7, unzip4, unzip5, unzip6, unzip7, unfoldr -- ,module Prelude ) where ---------------------------------------------------------------------------------------------------- import Prelude hiding (($),(^),(.),(!!),map,take,lookup,drop,splitAt,reverse,filter,takeWhile,dropWhile,null,foldl) import List hiding ((!!),map,take,lookup,drop,splitAt,reverse,filter,takeWhile,dropWhile,null,insert,union,intersect,delete,partition,foldl,length) import Random hiding (split) import Monad hiding (join,when,unless) import Regexp import System import Complex -- seems ghc need it for chr,ord, readHex, readOct import Char import Numeric --ghc import Time --ghc import Locale --import Trace ---------------------------------------------------------------------------------------------------- substr start len insert s = if start >= 0 then s!![0..start-1] ++ insert ++ s!![start+len..] -- [0.. -1] -> [] else s!![0..(length s + start -1)] ++ insert ++ s!![start+len.. -1] --substr s start len insert = take s start ++ insert ++ s!![start+len..] substr2 start insert s = substr start (if start >= 0 then (length s - start) else -start) insert s data Unpack_option = Grab Int | Forward Int | Backward Int | GrabAll deriving Show unpack :: [Unpack_option] -> [a] -> [[a]] unpack opt s = opt.foldl aux (0,[]).snd.reverse --(snd $ reverse) (foldl aux (0,[]) opt) where aux (n,l) (Grab i) = (n+i, s!![n..n+i-1] : l) aux (n,l) (Forward i) = (n+i, l) aux (n,l) (Backward i) = (n-i, l) aux (n,l) GrabAll = (length s + 1, s!![n..] : l) -- could do a foldr so that no need reverse but need reverse opt -- could to a str2Unpack_option so that str2Unpack_option "A5 A*" => [Grab 5,GrabAll] ---------------------------------------------------------------------------------------------------- -- use http://www.dcs.gla.ac.uk/~meurig/regexp/ for substS, ... -- TODO, a subst that take group subst re f s = let matchresult = searchS re [] s in if matchedAny matchresult then beforeMatch matchresult ++ f (wholeMatch matchresult) ++ afterMatch matchresult else s gsubst re f s = let matchresult = searchS re [] s in if matchedAny matchresult then beforeMatch matchresult ++ f (wholeMatch matchresult) ++ (gsubst re f (afterMatch matchresult)) else s -- in perl, =~ do 2 things, first it returns a bool and bind $i -- in haskell we are forced to do it in 2 steps (=~) s re = let matchresult = searchS re [] s in matchedAny matchresult (==~) s re = s =~ ("^"++s++"$") -- the Regexp lib require regexp of the form " var@(...) var2@(...)" i dont -- like put name on this, prefer anonymous as in perl, that is "(...) (...)" -- TODO, handle |, for example when match .(..)|.(..) i would like to return a list of one element -- TODO, handle ?: of perl match re s = let (max,re2) = re.foldl (\(i,acc) c -> if c == '(' then (i+1,acc++" "++show i++"@(") else (i,acc++[c]) ) (1,[]) matchresult = s.searchS re2 [] -- there is a pb cos in match "(\\w+)=(.*)" "MAIL=", we dont get ["MAIL",""] -- but only ["MAIL"], the lib does not handle well empty match subs = allSubexps matchresult subs2 = if (subs.length > 0 && subs.last.fst /= show (max-1)) ||(subs.length == 0 && max > 1) then subs++[(show (max-1),"")] else subs subs3 = subs2.foldl (\(i,acc) (j,str)-> if show i == j then (i+1, acc++[str]) else ((read j)+1, acc++replicate ((read j)-i) ""++[str]) ) (1,[]) in subs3.snd -- cant make match and gmatch the same type, cos one give [] and gmatch give [[]] gmatch re s = let (max,re2) = re.foldl (\(i,acc) c -> if c == '(' then (i+1,acc++" "++show i++"@(") else (i,acc++[c]) ) (1,[]) matchresult = s.searchS re2 [] in if matchedAny matchresult then (match re s):(gmatch re (afterMatch matchresult)) else [] --myl = "cava et toi".match "(a..) et (t)oi" --myl = match "(\\w+)" "pad tty etrre" --myl = match "(\\w+)=" "PAD=/home/pad" --myl = match "(\\w+)=(.*)" "PAD_MAIL=" pattern_matches ((re, v):xs) s = if s =~ re then v else pattern_matches xs s ---------------------------------------------------------------------------------------------------- -- an imitation of the '?' C operator, could even define (:-) = (:) and then have bool ? v1 :- v2 (?) True (a,b) = a (?) False (a,b) = b (==>) a b = (a,b) -- TODO, would like to overload . to behave as >>> when monad, but hard to do (a -> (a->b) -> b) does -- not unify with m a -> (a -> b) -> m b, and want that ? -- it is cool that record get autogenerated func, => we could do object.record_selector -- consistency (.) o f = f o -- object notation for object fan, use it if function have more than one parameter or -- if you want make an "oo-line" (ex o.words.reverse.unwords) (.>) m f = m >>= (\o -> return (f o)) -- <=> >>> (°) f g x = f (g x) (f $ g) x = (g ° f) x next_char c = chr (ord c + 1) show_float i f = showFFloat (Just i) f "" fixpoint f d | f d == d = d | otherwise = fixpoint f (f d) times = replicate join e [] = [] join e xs = foldr1 (\a x -> a ++ e ++ x) xs -- join e [] = [] -- join e [x] = x -- join e (x:xs) = x ++ e ++ join e xs -- ex: join " " ["bi","te","di","ck"] == "bi te di ck" -- string only split --split e xs = splitaux e [] xs --splitaux e a xs | xs.length < e.length = [a ++ xs] -- | take (e.length) xs == e = a:(splitaux e [] (drop (e.length) xs)) -- | otherwise = splitaux e (a++[head xs]) (tail xs) -- better split, handle regexp split re xs = let matchresult = searchS re [] xs in if matchedAny matchresult then (beforeMatch matchresult):(split re (afterMatch matchresult)) else [xs] --test=split "\\s+" "toto titi tia to" break_char c f s = let (a,b) = break (== c) s in if b == [] then a else f a (tail b) upcase xs = map toUpper xs downcase xs = map toLower xs capitalize (x:xs) = toUpper x : xs tonum x = fromInteger x hex ('0':('x':s)) = fst (head (readHex s)) -- TODO do some check oct ('0':('o':s)) = fst (head (readOct s)) -- TODO do some check tohex i = "0x"++aux i where aux i = if i == 0 then "" else aux (i `div` 16)++((['0'..'9']++['A'..'F'])!![i `mod` 16]) tooct i = "0o"++aux i where aux i = if i == 0 then "" else aux (i `div` 8)++(['0'..'7']!![i `mod` 8]) unique :: (Eq a) => [a] -> [a] -- dont know why but forced to put the type unique = nub insert_at :: Int -> [a] -> [a] -> [a] insert_at i toadd xs = let (a,b) = splitAt i xs in a++toadd++b replace :: [(Int, a)] -> [a] -> [a] replace assoc xs = assoc.foldl (\a (i,e) -> let (x,y) = splitAt i a in x++[e]++y ) xs shift (x:xs) = (x,xs) pop xs = (init xs, last xs) -- more efficient let (a,[b]) = splitAt (xs.length - 1) xs in (a,b) foldl_index f acc xs = foldl f acc (zip [1..] xs) complex_i = 0 :+ 1 (<=>) a b = compare a b --debug expr = trace ("Debug:"++show expr++"\n") expr ---------------------------------------------------------------------------------------------------- infixl 1 >>> (>>>) monad f = monad >>= (return ° f) eval x = x >>= (putStrLn ° show) action `when` bool = if bool then action else return () action `unless` bool = action `when` (not bool) cat file = readFile file >>> lines contents = getContents >>> lines (<>) = do l <- argv if (l == []) then contents else foldM (\a e -> cat e >>> (a++)) [] l -- i know it is just poor code, but haskell force me -- TODO, dont work, seems monad are lazy too, dont understand io in haskell anymore :( -- if do {l <- exec "ps ux"; l2 <- exec "who"; l.mapM putStrLn} print the contents of l2 !! exec s = do _ <- system (s++" > /tmp/file") cat "/tmp/file" rand :: (Int, Int) -> IO Int -- force to do that to resolve overloading :( rand = getStdRandom ° randomR stdrand :: IO Double stdrand = getStdRandom (randomR (0,1)) srand val = setStdGen (mkStdGen val) -- in haskell we have getEnv::String -> String, but not getEnvs :( env :: IO (Assoc String String) env = exec "env" >>> (map (\s -> let [a,b] = s.match "(\\w+)=(.*)" in (a,b)) $ fromList) -- env = getEnvironment -- for ghc argv = getArgs just (Just x) = x just _ = error "Common:just" exit i = primExitWith i usage s = putStrLn ("usage:"++s) >> exit 1 -- printf a la danvy -- type fmt a = ---------------------------------------------------------------------------------------------------- --ghc now = do cl <- getClockTime --ghc return (toUTCTime cl) --ghc localtime = toCalendarTime . toClockTime --ghc strftime fmt time = formatCalendarTime defaultTimeLocale fmt time --ghc nulltime = TimeDiff {tdYear=0, tdMonth=0, tdDay=0, tdHour=0, tdMin=0, tdSec=0, tdPicosec = 0} ---------------------------------------------------------------------------------------------------- -- Collects e [e] where ... -- Collects e (e -> Bool) where ... -- Collects Char BitSet where ... -- (Hashable e, Collects a ce) Collects e (Array Int ce) -- type Assoc a b = [(a,b)] -- -- -- this class support only collection of kind/1 => :( cos assoc dont match this criteria -- -- note that some new type variable are introduced (something impossible with ocaml oo, can not -- -- define a list object and then a fold, cos the type of the accumulator is new -- -- can do it in caml/C++ by making fold an external function of the class -- class Collection1 c where -- member1 :: Eq e => e -> c e -> Bool -- need Eq e, otherwise at instance declaration, when member = elem, pb (WHY?) -- cmap1 :: (a -> b) -> c a -> c b -- insert1 :: e -> c e -> c e -- instance Collection1 [] where -- member1 = elem -- cmap1 = map -- insert1 = (:) -- -- instance Collection1 Assoc ..., is not possible -- -- -- class Collection2 e c where, useless constructor class do the same job -- edison is cool, but they dont use depedencies => cant make a superclass Collection of Assoc and Sequence -- morover, there are too many classes, i prefer one class Collection, and then instance OrdSet,Bag,OrdBag,... -- edison use constructor class => if a type is not of the form c a, then it does not work -- as for the Functor class, this is a pb cos you cant make an instance Functor Assoc, cos Assoc is of kind/2 -- TODO, to allow default null, need Eq ce =>, mais apres foldl need des Eq [b] => -- must cut Collection in section CollectionEq, Collection class Collection e ce | ce -> e where -- constructors empty :: ce single :: e -> ce insert :: e -> ce -> ce fromList :: [e] -> ce fromList xs = xs.foldl (flip insert) empty copy :: Int -> e -> ce -- union, intersect, difference :: ce -> ce -> ce -- tabulate ? -- destructors -- simple delete :: e -> ce -> ce delete_all:: e -> ce -> ce -- not relevant for Set -- predicate based filter :: (e -> Bool) -> ce -> ce partition:: (e -> Bool) -> ce -> (ce,ce) -- observers toList :: ce -> [e] size :: ce -> Int -- member :: e -> ce -> Bool -- null :: ce -> Bool -- null ce = ce == empty -- iterators -- concatMap, cfoldr + 1, reducer* ? foldl:: (a -> e -> a) -> a -> ce -> a each :: (e -> IO ()) -> ce -> IO () -- find each -- zip unzip zippWith -- map:: (e -> b) -> ce -> cb -- cant define as is, would like a depedency constraint -- such as ce+b->cb -- can be put outside and use insert/observers -- TODO make AssocOrd class, OrdColl, ... -- goal: Set,Bag -- implementation: list,ordlist, (if odererd => can use bintree), okasaki optimised null es = es == empty member e es = e `elem` (es.toList) -- TODO, could make union more cool, to allow each time different collection -- could allow to do in place of a.insert e, [e]+a union :: (Collection a c) => c -> c -> c -- to force the same collection type union a b = b.foldl (flip insert) a intersect :: (Collection a c, Eq a) => c -> c -> c -- to force the same collection type intersect a b = a.foldl (\a e -> if e `member` b then a.insert e else a) empty difference :: (Collection a c, Eq a) => c -> c -> c -- to force the same collection type difference a b = a.foldl (\a e -> if e `member` b then a else a.insert e) empty class Collection e ce => Sequence e ce where -- constructors cons,snoc :: e -> ce -> ce append :: ce -> ce -> ce append = union -- destructors --simple lview,rview :: ce -> (e,ce) lhead,rhead :: ce -> e ltail,rtail :: ce -> ce -- int based take,drop :: Int -> ce -> ce splitAt :: Int -> ce -> (ce,ce) subseq :: Int -> Int -> ce -> ce takeWhile,dropWhile:: (e -> Bool) -> ce -> ce splitWhile :: (e -> Bool) -> ce -> (ce,ce) -- misc reverse :: ce -> ce -- concat :: [ce] -> ce; not [ce] but ce ce => how ? -- update, inbounds, adjust, [map|foldl|foldr]WithIndex -- instance [a], Queue [a], okasaki optimised -- TODO, make too strong condition, Eq b for example, could make keyss outside the class class (Eq a, Eq b, Collection (a,b) cab) => Association a b cab | cab -> a, cab -> b where keys :: cab -> [a] values:: cab -> [b] has_key:: a -> cab -> Bool has_key k xs = k `elem` (xs.keys) delete_key :: a -> cab -> cab each_key :: (a -> IO ()) -> cab -> IO () keyss :: b -> cab -> [a] keyss v cab = cab.toList.filter (snd $ (==v)).map fst has_value:: b -> cab -> Bool has_value v xs = v `elem` (xs.values) -- instance Assoc, okasaki optimised (bintree, ...) -- AssocMulti, key -> list map f [] = [] map f (x:xs) = f x: map f xs cmap f = toList ° map f ° fromList -- cant make in the type that this must be the same collection class Indexable i ca a | ca -> a where (!~) :: ca -> i -> Maybe a -- lookupM (!) :: ca -> i -> a -- lookup, to be more esthetic do s!(0) rather than s!0 (!) xs i = (xs!~i).just -- lookupWithDefaul (!!) :: ca -> [i] -> [a] (!!) xs is = map (\i -> xs ! i) is -- seems you can not define with infix notation default class value ------------------------------- instance (Num b,Ord b) => Indexable b [a] a where -- to allow s![1..] -- note: a 'try (...) with' would be more efficient that constantly check for array bound -- note: we stop as soon as we have a big index => xs ! [1000, 2,3] if length xs < 1000 will give [] -- (to handle infinite list) -- TODO allow s!![-4..] (!!) xs [] = [] (!!) xs (i:is) | i >= (fromInt (length xs)) = [] -- handle infinite list | i < 0 = xs!((fromInt (length xs)) + i) : xs!!is | otherwise = xs!(i) : xs!!is -- (x:_) !~ 0 = Just x (x:_) !~ n | n < 1 && n >= 0 = Just x -- allow s!3.2 (_:xs) !~ n | n>0 = xs !~ (n-1) _ !~ _ = Nothing instance Collection a [a] where insert = (:) foldl f z [] = z foldl f z (x:xs) = foldl f (f z x) xs filter p xs = [ x | x <- xs, p x ] each = mapM_ toList = id fromList = id -- default fromList dont respect the order empty = [] instance Sequence a [a] where reverse = foldl (flip (:)) [] -- this can be dangerous, cos insert for an Association is replace/add (key,val) whereas -- for a list with simply add, and so use Assoc if you want to choose -- same for each, each will print all the pair, even the obsolete instance (Eq a,Eq b) => Association a b [(a,b)] where keys xs = xs.map fst delete_key k xs = xs.filter (\(a,b) -> a /= k) each_key f = keys $ each f ------------------------------- data SetList a = SetList [a] deriving Show instance Eq a => Collection a (SetList a) where insert e (SetList xs) = SetList (e:(xs.filter (/= e))) toList (SetList xs) = xs instance Eq (SetList a) => Default_val (SetList a) where null_val = SetList [] instance Eq a => Eq (SetList a) where (SetList xs) == (SetList ys) = (xs.all (`elem` ys)) && (xs.length == ys.length) ------------------------------- data Assoc a b = Assoc [(a,b)] deriving Eq instance (Show a, Show b) => Show (Assoc a b) where show (Assoc xs) = xs.map (\(a,b) -> a^" => "^b).unlines instance Eq a => Collection (a,b) (Assoc a b) where empty = Assoc [] insert (k,v) (Assoc xs) = Assoc ((k,v):xs.filter ((/= k) ° fst)) -- [ (k',v') | (k',v') <- xs, k /= k']) toList (Assoc xs) = xs each f (Assoc xs) = xs.each f foldl f z (Assoc xs) = xs.foldl f z instance (Eq a,Eq b) => Association a b (Assoc a b) where keys (Assoc xs) = xs.map fst values (Assoc xs) = xs.map snd instance Eq a => Indexable a (Assoc a b) b where (!~) (Assoc []) k = Nothing (!~) (Assoc ((x,y):xys)) k | k==x = Just y | otherwise = (Assoc xys)!~k -- to do assoc with default value to allow -- from.update (name,+1), better than -- from.insert(name,1+((from!~name ||| (Just 0)).just)) data AssocDefault a b = AssocDefault (b,[(a,b)]) deriving Eq instance (Show a, Show b) => Show (AssocDefault a b) where show (AssocDefault (b,xs)) = xs.map (\(a,b) -> a^" => "^b).unlines instance (Eq a,Default_val b) => Collection (a,b) (AssocDefault a b) where empty = AssocDefault (null_val,[]) insert (k,v) (AssocDefault (b,xs)) = AssocDefault (b,((k,v):xs.filter ((/= k) ° fst))) -- [ (k',v') | (k',v') <- xs, k /= k']) toList (AssocDefault (b,xs)) = xs each f (AssocDefault (b,xs)) = xs.each f foldl f z (AssocDefault (b,xs)) = xs.foldl f z instance (Eq a,Default_val b) => Association a b (AssocDefault a b) where keys (AssocDefault (b,xs)) = xs.map fst instance Eq a => Indexable a (AssocDefault a b) b where (!~) (AssocDefault (b,xs)) k = (Assoc xs)!~ k -- TODO, could put update in classe Association ? update k f h@(AssocDefault (b,xs)) = h.insert(k, (h!~k ||| Just b).just.f) ---------------------------------------------------------------------------------------------------- -- make tuple indexable, oveload ! to work with all, but does not work -- instance Indexable Int (a,b) a where -- (!~) (a,b) 0 = Just a -- instance Indexable Int (a,b) b where -- (!~) (a,b) 1 = Just b ---------------------------------------------------------------------------------------------------- -- matrix, there exist some implementation on the web, TODO dont do list but fixed size vector => -- could make compile-time check, ex *, we must have row_size a = column_size b -- TODO, could be made a class of FinitMap, and that we could have a generic accessor newtype Matrix a = Matrix [[a]] -- prefer a newtype, cos dont want to allow + on every list of list deriving (Eq,Show) -- newtype force you to redefine the deriving stuff row_size (Matrix m) = m.length column_size (Matrix m) = m.head.length (%%) (Matrix m) (i,j) = m!i!j -- could so straessen, this is very inefficient cos we dont have 0(1) access to element -- TODO, use list comprehension, cf hugs demo instance Num a => Num (Matrix a) where ma * mb | ma.column_size == mb.row_size = Matrix aux where aux = [0..ma.row_size -1] .foldl (\acc i -> acc++[ [0..mb.column_size -1] .foldl (\acc j -> acc++[ [0..ma.column_size-1] .foldl (\acc k -> acc+ (ma%%(i,k) * (mb %%(k,j)))) 0] ) [] ] ) [] ---------------------------------------------------------------------------------------------------- class Eq a => Default_val a where null_val :: a is_null :: a -> Bool is_null = (== null_val) -- not really logical, cos we dont really need to force Default_val a, we dont care about a --instance Default_val a => Default_val [a] where null_val = [] -- and need provide extra instance --instance Default_val Char where null_val = 'a' -- need -98 option, still dont know why we need to put the constraint Eq [a] for working instance Eq [a] => Default_val [a] where null_val = [] instance Eq (Maybe a) => Default_val (Maybe a) where null_val = Nothing -- instance Num b => Default_val b where null_val = 0; cant do that :( hugs say it overlaps -- but it is not cos [a] is not member of the Num class instance Default_val Int where null_val = 0 instance Default_val Float where null_val = 0.0 -- would like to do that, but not possible cos Num is a class, not a type --instance Default_val (Num a) where null_val = 0 -- v1 = (2::Int) &&& "ee" -- "ee" -- need the type annotation :( -- v2 = 0.0 &&& "ee" -- "" -- overloading on return value (&&&):: (Default_val a, Default_val b) => b -> a -> a a &&& b = if a.is_null then null_val else b (|||):: Default_val a => a -> a -> a a ||| b = if a.is_null then b else a ---------------------------------------------------------------------------------------------------- -- class Show a => Showbis a where -- showbis :: a -> String -- showbis x = show x -- cant do instance Showbis [Char] where showbis x = x -- cos we cant specialise so far in haskell, we specialise "chacun son tour" => -- first [] then Char => to handle that, do as in the class Show, make 2 func -- (as you may have note, show "123" => "123" and show '1' => '1', strange, might expect -- ['1','2','3'] cos String = [Char] -- in fact, show [a] is not a map show !! cf Prelude to understand the trick -- they introduce another func in the class definition to allow specialisation for [a] -- showbisList :: [a] -> String -- showbisList [] = "[]" -- showbisList (x:xs) = "[" ++ join "," (map show (x:xs)) ++ "]" --instance Showbis a => Showbis [a] where showbis = showbisList --instance Num a => Showbis a where showbis = show -- the beautfile one, but hugs/ghc do special case with show; when -- do 1 ~~ 2 then he wants (1::Int) ~~ (2::Int) :(( -- (~~) a b = showbis a ++ showbis b -- the ugly one, if you have a type that when show put a " at begin and end, then pb !! -- but as it is rarely the case, no matter, same for \ update_anti_slash [] = [] update_anti_slash [x] = [x] update_anti_slash ('\\':x:xs) = (case x of 'n' -> '\n' 't' -> '\t' x -> x ) : update_anti_slash xs update_anti_slash (x:xs) = x : update_anti_slash xs del_enclose :: String -> String del_enclose xs | length xs <= 1 = xs | head xs == '"' && last xs == '"' = xs.tail.init | otherwise = xs (^) a b = (update_anti_slash ° del_enclose ° show) a ++ (update_anti_slash ° del_enclose ° show) b -- (^) a b = let op = update_anti_slash ° del_enclose ° show in op a ++ op b -- dont WORK !! AMAZING infixl 1 ^ |