[Lots more changes and things compile except Main jupdike@gmail.com**20080204170214] { hunk ./CPS.lhs 7 -> module CPS ( CPS(..), +> module CPS ( CPS, hunk ./CPS.lhs 13 -> BT(..), +> BT, hunk ./CPS.lhs 16 -> many, many1, sepBy, sepBy1, +> many, many1, sepByCPS, sepBy1CPS, hunk ./CPS.lhs 193 -> sepBy, sepBy1 :: BT st val1 res -> BT st val2 res -> BT st [val1] res -> sepBy m s = sepBy1 m s ? unit [] -> sepBy1 m s = m &= \a -> many (s & m) &= \x -> unit (a:x) +> sepByCPS, sepBy1CPS :: BT st val1 res -> BT st val2 res -> BT st [val1] res +> sepByCPS m s = sepBy1CPS m s ? unit [] +> sepBy1CPS m s = m &= \a -> many (s & m) &= \x -> unit (a:x) addfile ./CPSParser.lhs hunk ./CPSParser.lhs 1 +> module CPSParser + + ( CPS, + > -- get next token etc + > item, unItem, end, + > -- error handling + > Parser, ParseResult, + > runParserCPS, + > parseError, mandatory, probe + > ) + +> where + + + + +> import CPS + + + +Parsing based on the CPS Monad +The state is instantiated to a list of tokens. item returns the first item of the input, and fails if the input is exhausted. + + +> item :: BT [tok] tok res +> item = \c f s -> case s of [] -> f; a:x -> c a f x + + +unItem pushes the given token back. + + +> unItem :: tok -> BT [tok] () res +> unItem a = \c f s -> c () f (a:s) + + +end succeeds only if the input is empty. + + +> end :: BT [tok] () res +> end = \c f s -> case s of [] -> c () f []; _:_ -> f + + + +Error handling + + +> type Parser tok val res = BT [tok] val (ParseResult tok res) +> type ParseResult tok val = Either (val, [tok]) String + + + + +> succCont = \v f x -> Left (v, x) +> failCont s = Right s + + +Running a parser. + + +> runParserCPS :: Parser tok val val -> [tok] -> ParseResult tok val +> runParserCPS p = p succCont (failCont syntaxError) + + +Signal an error. + + +> parseError :: String -> Parser tok val res +> parseError s = hardFail (failCont s) + + +Turn soft into hard failure. + + +> mandatory s p = p ? parseError s + + +Turn hard into soft failure. + + +> probe :: Parser tok val val -> Parser tok val val +> probe p = \c f s -> case runParserCPS p s of +> Left (v, x) -> c v f x +> Right _ -> f + + + + +> syntaxError = "syntax error" + + +Optimizations. + + +> {-# INLINE item #-} +> {-# INLINE unItem #-} + + hunk ./Convert.lhs 13 -> import Prim ( Ident(..), Prim(..) ) -> import Expr ( Expr(..) ) -> import Function ( Function(..), minus, mone ) +> import Ratio + +> import Prim -- ( Ident(..), Prim(..) ) +> import Expr -- ( Expr(..) ) +> import Function -- ( Function, minus, mone ) hunk ./Convert.lhs 23 -> infixr 1 :.: -> infixr 2 +++ -> infixr 3 *** -> infixr 5 :^: + > infixr 1 :.: + > infixr 2 +++ + > infixr 3 *** + > infixr 5 :^: hunk ./Derive.lhs 13 -> import Function ( Prim(..), Ident(..), Function(..), -> constant, -> minus, zero, one, mone, two, mtwo, half, mhalf ) +> import Prim +> import Expr + +> import Function + + ( Prim, Ident, Function, + > constant, + > minus, zero, one, mone, two, mtwo, half, mhalf ) hunk ./Function.lhs 5 -> module Function ( Ident, Function(..), Prim(..), -> constant, -> csplit, summands, factors, esplit, -> (+++), (***), summ, prod, minus, -> nat, zero, half, mhalf, one, mone, two, mtwo, ten -> ) -> where +> module Function where + + ( Ident, Function, Prim, + > constant, + > csplit, summands, factors, esplit, + > (+++), (***), summ, prod, minus, + > nat, zero, half, mhalf, one, mone, two, mtwo, ten + > ) + > where hunk ./Function.lhs 21 -> import Prim ( Ident(..), Prim(..) ) +> import Prim + + ( Ident(..), Prim(..) ) hunk ./Function.lhs 68 -> summ [] = zero -> summ [f] = f -> summ fs = Summ fs +> ssumm [] = zero +> ssumm [f] = f +> ssumm fs = Summ fs hunk ./Function.lhs 76 -> prod [] = one -> prod [f] = f -> prod fs = Prod fs +> pprod [] = one +> pprod [f] = f +> pprod fs = Prod fs hunk ./Integrate.lhs 16 -> import CPS renaming (zero to dontknow) +> import Data.List ( partition ) + +> import CPS --renaming (zero to dontknow) hunk ./Integrate.lhs 20 -> renaming (mergeSort to sort) +> --renaming (mergeSort to sort) hunk ./Integrate.lhs 22 -> import Function ( Function(..), Prim(..), constant, -> factors, prod, -> (+++), (***), half, one, mone, two ) -> import Derive ( derive ) -> import Simplify hiding (prod) -> import Table ( Table(..), retrieve ) +> import Prim +> import Expr +> import Function -- ( Function(..), Prim(..), constant, +> -- factors, prod, +> -- (+++), (***), half, one, mone, two ) +> import Derive -- ( derive ) +> import Simplify -- hiding (prod) +> import Table -- ( Table(..), retrieve ) + +> dontknow = zzero +> sort = mergeSort addfile ./OrdAssList.lhs hunk ./OrdAssList.lhs 1 +Ordered association lists + + +> module OrdAssList ( FM, OrdAssList, +> -- construction +> empty, singleton, union, unionMany, +> add, (///), +> -- construction with combining function +> union_C, unionMany_C, add_C, addMany_C, +> -- modification +> intersect, delete, deleteMany, minus, +> amapFM, +> -- conversion +> toList, fromList, +> -- size +> -- length, genericLength +> -- testing +> --null +> isSingleton, +> -- extraction +> elemsFM, indicesFM, +> -- lookup +> lookup, lookupWithDefault, +> lookupWithContinuation, +> -- *additional functions* +> toSortedList, fromSortedList, +> prefixLookup +> ) +> where + + + + +> import Sort ( mergeSortBy, uniqueBy ) +> import Subsequences ( isPrefixOf ) + + > import Support ( applyWithDefault, applyWithContinuation ) + +> applyWithDefault :: (a -> Maybe b) -> b -> a -> b +> applyWithDefault f def a = case f a of Nothing -> def; Just v -> v + + + + +> applyWithContinuation :: (a -> Maybe b) -> (b -> c) -> c -> a -> c +> applyWithContinuation f succ err a +> = case f a of Nothing -> err; Just v -> succ v + + +Note: many functions are identical to those of OrdList except for the compare function. + +Type definitions + + +> type FM a b = OrdAssList a b + + +Lists ordered by the first component containing no duplicates. + + +> type OrdAssList a b = [(a, b)] + + +Lists are already instances of Eq and Ord. + + +> --instance Eq a => Eq (FM a b) +> --instance Ord a => Ord (FM a b) + + + +Construction + + +> empty :: FM a b +> empty = [] + + + + +> singleton :: (a,b) -> FM a b +> singleton b = [b] + + +union corresponds to merge. + + +> union :: Ord a => FM a b -> FM a b -> FM a b +> union [] y = y +> union x@(_:_) [] = x +> union x@(a:x') y@(b:y') = case comparet a b of +> LT -> a : union x' y +> EQ -> a : union x' y' +> GT -> b : union x y' + + + + +> unionMany :: Ord a => [FM a b] -> FM a b +> unionMany = foldl union empty + + + + +> add :: Ord a => (a,b) -> FM a b -> FM a b +> add a [] = [a] +> add a x@(b:x') = case comparet a b of +> LT -> a : x +> EQ -> a : x' +> GT -> b : add a x' + + +Note: /// instead of //. + + +> (///) :: Ord a => FM a b -> [(a,b)] -> FM a b +> --x /// bs = foldr add x bs -- insertion sort +> x /// bs = x `union` fromList bs -- merge sort + + + +Construction with combining function +The combining function is called as combine old new and combine left right, respectively. + + +> union_C :: Ord a => (b -> b -> b) +> -> FM a b -> FM a b -> FM a b +> union_C combine [] y = y +> union_C combine x@(_:_) [] = x +> union_C combine x@(b1@(a1,v1):x') y@(b2@(a2,v2):y') +> = case compare a1 a2 of +> LT -> b1 : union_C combine x' y +> EQ -> (a1,combine v1 v2) : union_C combine x' y' +> GT -> b2 : union_C combine x y' + + + + +> unionMany_C :: Ord a => (b -> b -> b) -> [FM a b] -> FM a b +> unionMany_C combine = foldl (union_C combine) empty + + + + +> add_C :: Ord a => (b -> b -> b) +> -> (a,b) -> FM a b -> FM a b +> add_C combine b [] = [b] +> add_C combine b1@(a1,v1) x@(b2@(a2,v2):x') +> = case compare a1 a2 of +> LT -> b1 : x +> EQ -> (a1,combine v1 v2) : x' +> GT -> b2 : add_C combine b1 x' + + + + +> addMany_C :: Ord a => (b -> b -> b) +> -> FM a b -> [(a,b)] -> FM a b +> addMany_C combine x bs = union_C combine x (fromList bs) + + + +Modification + + +> intersect :: Ord a => FM a b -> FM a b -> FM a b +> intersect [] y = [] +> intersect x@(_:_) [] = [] +> intersect x@(a:x') y@(b:y') = case comparet a b of +> LT -> intersect x' y +> EQ -> a : intersect x' y' +> GT -> intersect x y' + + + + +> delete :: Ord a => a -> FM a b -> FM a b +> delete a [] = [] +> delete a x@(b:x') = case compare a (fst b) of +> LT -> x +> EQ -> x' +> GT -> b : delete a x' + + + + +> deleteMany :: Ord a => FM a b -> [a] -> FM a b +> deleteMany = foldr delete + + + + +> minus :: Ord a => FM a b -> FM a b -> FM a b +> minus [] y = [] +> minus x@(_:_) [] = x +> minus x@(a:x') y@(b:y') = case comparet a b of +> LT -> a : minus x' y +> EQ -> minus x' y' +> GT -> minus x y' + + + + +> amapFM :: ((a,b) -> c) -> (FM a b -> FM a c) +> amapFM f bs = [ (a,f b) | b@(a,v)<-bs ] + + +Note: partition, filter, foldl, foldr need no redefinition. + +Conversion + + +> toList :: FM a b -> [(a,b)] +> toList = id + + + + +> fromList :: Ord a => [(a,b)] -> FM a b +> fromList = fromSortedList +> . mergeSortBy (\p q -> fst p <= fst q) + + + +Size +Note: length and genericLength need no redefinition. + + +> --length :: FM a b -> Int +> --genericLength :: Integral i => FM a b -> i + + + +Testing +Note: null needs no redefinition. + + +> --null :: FM a b -> Bool + + + + +> isSingleton :: FM a b -> Bool +> isSingleton [a] = True +> isSingleton _ = False + + + + +> intersecting :: Ord a => FM a b -> FM a b -> Bool +> intersecting [] y = False +> intersecting x@(_:_) [] = False +> intersecting x@(a:x') y@(b:y')= case comparet a b of +> LT -> intersecting x' y +> EQ -> True +> GT -> intersecting x y' + + + + +> isSubsetOf :: Ord a => FM a b -> FM a b -> Bool +> isSubsetOf [] y = True +> isSubsetOf x@(_:_) [] = False +> isSubsetOf x@(a:x') y@(b:y') = case comparet a b of +> LT -> False +> EQ -> isSubsetOf x' y' +> GT -> isSubsetOf x y' + + + +Extraction +Note: elemsFM instead of elems. Dito: indicesFM. + + +> elemsFM :: FM a b -> [b] +> elemsFM = map snd + + + + +> indicesFM :: FM a b -> [a] +> indicesFM = map fst + + + +Lookup +Note: ! is predefined. + + +> --(!) :: Ord a => FM a b -> a -> b +> --x ! a = lookupWithDefault x +> -- (error "OrdAssList.!: elem not found") a + + + + +> lookupt :: Ord a => FM a b -> a -> Maybe b +> lookupt [] a = Nothing +> lookupt x@(b:x') a = case compare a (fst b) of +> LT -> Nothing +> EQ -> Just (snd b) +> GT -> lookupt x' a + + + + +> lookupWithDefault :: Ord a => FM a b -> b -> a -> b +> lookupWithDefault = applyWithDefault . lookupt + + + + +> lookupWithContinuation :: Ord a => FM a b -> (b -> c) -> c -> a -> c +> lookupWithContinuation = applyWithContinuation . lookupt + + + +Additional functions + + +> toSortedList :: FM a b -> [(a,b)] +> toSortedList = id + + + + +> fromSortedList :: Eq a => [(a,b)] -> FM a b +> fromSortedList = uniqueBy (\p q -> fst p == fst q) + + +prefixLookup returns the list of all completions of the given list. + + +> prefixLookup :: Ord a => FM [a] b -> [a] -> [([a],b)] +> prefixLookup x s = [ b | b@(a, _)<-x, s `isPrefixOf` a ] + + + +Auxiliary functions + + +> comparet :: Ord a => (a,b) -> (a,b) -> Ordering +> comparet p q = compare (fst p) (fst q) + + + hunk ./Prim.lhs 5 -> module Prim ( Ident, Prim(..) -> ) +> module Prim + + ( Ident, Prim(..) + > ) + hunk ./Simplify.lhs 1 +> {-# OPTIONS_GHC -fglasgow-exts #-} + hunk ./Simplify.lhs 19 -> import Support -> + > import Support + > + +> import Ratio +> import List ( groupBy ) +> import Array + hunk ./Simplify.lhs 27 -> renaming (mergeSortBy to sortBy) hunk ./Simplify.lhs 28 -> import Function ( Function(..), Prim(..), constant, -> summands, factors, esplit, -> nat, zero, one, mone ) +> import Function + + > ( Function(..), Prim(..), constant, + > summands, factors, esplit, + > nat, zero, one, mone ) hunk ./Simplify.lhs 39 -> infixr 5 ^^^, `pow` -> infix 4 -=> +> infixr 5 ^^^ +> infixr 5 # +> infix 5 --> + + >, `pow` + > infix 4 -=> + +> f # g = g . f +> sortBy = mergeSortBy hunk ./Simplify.lhs 123 -> Ratio m ^^^ Ratio (n :% 1) -> | n >= 0 = Ratio (m ^ n) -> | otherwise = Ratio (recip m ^ negate n) +> Ratio m ^^^ Ratio r -- Ratio (n :% 1) +> | denominator r == 1 +> , n <- numerator r +> = case n >= 0 of +> True -> Ratio (m ^ n) +> False -> Ratio (recip m ^ negate n) hunk ./Simplify.lhs 231 +> isWhole r = denominator r == 1 + hunk ./Simplify.lhs 235 -> (Summ (f:fs)) `pow` Ratio (i :% 1) -> | i > 0 && i <= n = binom i f (Summ fs) -> | i < 0 && -i <= n = binom (-i) f (Summ fs) ^^^ mone +> (Summ (f:fs)) `pow` (Ratio r) -- (i :% 1) +> | isWhole r , i <- denominator r +> , i > 0 && i <= n = binom i f (Summ fs) +> | isWhole r , i <- denominator r +> , i < 0 && -i <= n = binom (-i) f (Summ fs) ^^^ mone hunk ./Simplify.lhs 246 +> a --> b = (a,b) + hunk ./Simplify.lhs 252 -> [ (i,0) := 1 | i<-[0..n] ] -> ++ [ (i,i) := 1 | i<-[1..n] ] -> ++ [ (i,j) := c!(i-1,j) + c!(i-1,j-1) | i<-[2..n],j<-[1..i-1] ]) +> [ (i,0) --> 1 | i<-[0..n] ] +> ++ [ (i,i) --> 1 | i<-[1..n] ] +> ++ [ (i,j) --> c!(i-1,j) + c!(i-1,j-1) | i<-[2..n],j<-[1..i-1] ]) addfile ./Sort.lhs hunk ./Sort.lhs 1 + +> module Sort ( qsort, qsortBy, +> mergeSort, mergeSortBy, +> merge, mergeLists, mergeBy, mergeListsBy, +> naturalSort, naturalSortBy, +> uniqueBy, unique +> ) +> where + + + +Quicksort + + +> qsort :: Ord a => [a] -> [a] +> qsort = qsortBy (<=) +> +> qsortBy :: (a -> a -> Bool) -> [a] -> [a] +> qsortBy (<=) x = qsortsBy (<=) x [] + + +The following code is due to Lennart Augustsson. + + +> qsortsBy :: (a -> a -> Bool) -> [a] -> [a] -> [a] +> qsortsBy (<=) [] y = y +> qsortsBy (<=) [a] y = a:y +> qsortsBy (<=) (a:x) y = qpartBy (<=) a x [] [] y + + +qpartBy partitions and sorts the sublists. Note that l and r are in reverse order and must be sorted with an anti-stable sorting. + + +> qpartBy (<=) a [] l r y = rqsortsBy (<=) l (a : rqsortsBy (<=) r y) +> qpartBy (<=) a (b:x) l r y +> | a <= b = qpartBy (<=) a x l (b:r) y +> | otherwise = qpartBy (<=) a x (b:l) r y + + +rqsortsBy is as qsortsBy but anti-stable, ie reverses equal elements. + + +> rqsortsBy :: (a -> a -> Bool) -> [a] -> [a] -> [a] +> rqsortsBy (<=) [] y = y +> rqsortsBy (<=) [a] y = a:y +> rqsortsBy (<=) (a:x) y = rqpartBy (<=) a x [] [] y + + + + +> rqpartBy (<=) a [] l r y = qsortsBy (<=) l (a : qsortsBy (<=) r y) +> rqpartBy (<=) a (b:x) l r y +> | b <= a = rqpartBy (<=) a x (b:l) r y +> | otherwise = rqpartBy (<=) a x l (b:r) y + + + +Mergesort +Bottom-up Variant of mergesort. + + +> mergeSort :: Ord a => [a] -> [a] +> mergeSort = mergeSortBy (<=) + + + + +> mergeSortBy :: (a -> a -> Bool) -> [a] -> [a] +> mergeSortBy (<=) = mergeListsBy (<=) . runPhase +> where + + +Building "runs" of length 2. + + +> runPhase [] = [] +> runPhase [a] = [[a]] +> runPhase (a:b:x) +> | a <= b = [a,b] : runPhase x +> | otherwise = [b,a] : runPhase x + + +Merging two lists. + + +> merge :: Ord a => [a] -> [a] -> [a] +> merge = mergeBy (<=) +> +> mergeBy :: (a -> a -> Bool) -> [a] -> [a] -> [a] +> mergeBy (<=) [] y = y +> mergeBy (<=) (a:x) [] = a : x +> mergeBy (<=) v@(a:x) w@(b:y) +> | a <= b = a : mergeBy (<=) x w +> | otherwise = b : mergeBy (<=) v y + + +Iteratively merging the runs. Good for its own sake. + + +> mergeLists :: Ord a => [[a]] -> [a] +> mergeLists = mergeListsBy (<=) +> +> mergeListsBy :: (a -> a -> Bool) -> [[a]] -> [a] +> mergeListsBy (<=) = mergeLists +> where +> mergeLists [] = [] +> mergeLists [x] = x +> mergeLists (x1:x2:xs) = mergeLists (mergeBy (<=) x1 x2:mergePairs xs) +> +> mergePairs [] = [] +> mergePairs [x] = [x] +> mergePairs (x1:x2:xs) = mergeBy (<=) x1 x2 : mergePairs xs + + + +Natural mergesort +Natural mergesort respect runs of the given list. + + +> naturalSort :: Ord a => [a] -> [a] +> naturalSort = naturalSortBy (<=) + + + + +> naturalSortBy :: (a -> a -> Bool) -> [a] -> [a] +> naturalSortBy (<=) = mergeListsBy (<=) . runPhase +> where + + +Splitting into runs. takeAsc takes an ascending prefix. + + +> runPhase [] = [[]] +> runPhase (a:x) = takeAsc [a] x +> +> takeAsc as [] = [reverse as] +> takeAsc as@(a:_) (e:x) +> | a <= e = takeAsc (e:as) x +> | otherwise = takeAscDes as [e] x +> +> takeAscDes as ds [] = [mergeBy (<=) (reverse as) ds] +> takeAscDes as@(a:_) ds@(d:_) v@(e:x) +> | a <= e = takeAscDes (e:as) ds x +> | d <= e = mergeBy (<=) (reverse as) ds : runPhase v +> | otherwise = takeAscDes as (e:ds) x + + +ToDo: Is naturalSortBy stable? + +Misc + + +> uniqueBy :: (a -> a -> Bool) -> [a] -> [a] +> uniqueBy (==) [] = [] +> uniqueBy (==) [a] = [a] +> uniqueBy (==) (a:x@(b:_)) | a==b = uniqueBy (==) x +> | otherwise = a : uniqueBy (==) x + + + + +> unique :: Eq a => [a] -> [a] +> unique = uniqueBy (==) + + addfile ./Subsequences.lhs hunk ./Subsequences.lhs 1 +COMMENT:----------------------- + +Compile me with + ghc -c -O Subsequences.lhs +------------------------------- + + +> module Subsequences ( isPrefixOf +> ) +> where + + + + +> isPrefixOf :: Eq a => [a] -> [a] -> Bool +> x `isPrefixOf` y = x==take (length x) y + + hunk ./Table.lhs 5 -> module Table ( Table(..), readTable, retrieve +> module Table ( Table, readTable, retrieve hunk ./Table.lhs 13 -> import IOSupport -> -> import CPSParser renaming (zero to dontknow) + > import IOSupport + +> import Text.ParserCombinators.Parsec + +> import CPS +> import CPSParser hunk ./Table.lhs 21 -> import Prim ( Ident(..), Prim(..) ) -> import Expr ( Expr(..) ) -> import Function ( Function(..), constant, -> csplit, summands, factors, summ, prod ) +> import Prim -- ( Ident(..), Prim(..) ) +> import Expr -- ( Expr(..) ) +> import Function -- ( Function(..), constant, + + > csplit, summands, factors, summ, prod ) + hunk ./Table.lhs 31 +> dontknow = zzero + hunk ./Table.lhs 46 -> readTable fid = try (readFile fid) >>= -> either -> (\err -> print err >> -> return []) -> (\str -> case runParser table str of -> Left (t, _) -> --sequence [ print e | e<-t ] >> -> return t -> Right _ -> putLine "syntax error" >> -> return []) +> readTable fid = do +> str <- readFile fid +> case runParser table () fid str of +> Left e -> do putStrLn "syntax error" +> return [] +> Right t -> return t hunk ./Table.lhs 59 -> table = sepBy equ (lit ';') &= \t -> -> opt (lit ';') ';' & unit t +> table = do t <- sepBy equ (lit ';') +> --optional (lit ';') (lit ';') +> return t hunk ./Table.lhs 67 -> equ = lit '|' & var &= \x -> expr &= \e1 -> -> lit '=' & expr &= \e2 -> -> unit (convert x e1, convert x e2) +> equ = lit '|' >> var >>= \x -> expr >>= \e1 -> +> lit '=' >> expr >>= \e2 -> +> return (convert x e1, convert x e2) hunk ./Table.lhs 116 -> | length cs <= 1 = match (summ cs) (summ cs') &= \env1 -> +> | length cs <= 1 = match (ssumm cs) (ssumm cs') &= \env1 -> hunk ./Table.lhs 123 -> | length cs <= 1 = match (prod cs) (prod cs') &= \env1 -> +> | length cs <= 1 = match (pprod cs) (pprod cs') &= \env1 -> addfile ./clean hunk ./clean 1 +#!/bin/sh + +rm *.o +rm *.hi hunk ./g 2 -ghc --make Print.lhs +#ghc --make Function.lhs +#ghc --make Convert.lhs +#ghc --make Table.lhs + +ghc --make Integrate.lhs + }