hat-2.7.0.0: tools/HatDelta.hs
module Main where
-- System Imports
import System.IO (stdin,stdout,stderr,hPutStrLn)
import Data.List (isSuffixOf, intersperse, nubBy, delete, minimumBy
,isPrefixOf, sortBy)
import Data.Char (toLower)
import System.Cmd (system)
import System.Environment (getArgs,getProgName)
import System.Exit (exitWith,ExitCode(..))
import Foreign.C.String (withCString)
import Numeric (showHex)
import System.IO.Unsafe (unsafePerformIO)
import Data.Maybe (fromJust)
-- Hat Imports
import CommonUI (Options(..))
import Detect (doAnim,doDelta,doDetect,doExplore,doObserve,doTrail
,doView,findMain,DetectCommand(..),toCommand,identifyBug
,identifyCycle,findMain,DeltaOption(..),HeuristicMode(..)
,HeuristicBool(..),DetectCommand(..),toCommand
,showHeuristic)
-- import Delta (questions)
import HighlightStyle (Highlight(..),Colour(..),highlight,getTerminalSize)
import LowLevel (NodeType(..),openHatFile,FileNode(..),nil,peekTrace
,getResult,getParentNode,getErrorLoc,getErrorMessage
,getSrcRef,getDefnRef,getSubExprs,nodeType)
import SExp (QName(..),showQN,prettySExp)
import NodeExp (NodeExp(..),nodeExpForNode,fullEval,flatEval
,removeResultCycles,removeNonResultCycles,getNode
,nodeExp2SExp,isIn,limitDepth,children,(===)
,flatEvalText,fullEvalText,finalResult)
import ADT (ADT(..),displayTree,displayTrees,trustIO
,trustModule,trustApps,trustConstant,leaves,subADTs
,detectCycles,foldHiddens,trustUnevaluated,(/==)
,trustMatchingFunction)
import EDT (buildEDT)
import FDT (buildFDT)
import Explore (Location(..),getLocation, getDefLocation,redexParent
,Coord(..))
import Pretty (PrettyOption(..), makeGraph)
import Slice (Slice,makeSlice)
helpMessage :: String
helpMessage = "\
\hat-delta\n\
\=========\n\
\\n\
\hat-delta is an interactive tool for finding bugs in the trace of a \n\
\program supplied as its argument. The user must answer a sequence of\n\
\yes/no questions. Each question asked by hat-delta concerns the reduction \n\
\of a function application to a value. You answer yes if the reduction is\n\
\correct with respect to your intentions, and no otherwise. After a number \n\
\of questions hat-delta reports an example equation which is the cause of\n\
\the observed faulty behaviour - that is, which function definition is\n\
\incorrect.\n\
\\n\
\Options:\n\
\-------------------------------------------------------------------------\n\
\-c Disable compression of the ADT based on reporting the same\n\
\ answer for several questions.\n\
\-d depth Set the maximum depth hat-delta will consider making a jump\n\
\ into the ADT.\n\
\-f function Set the heuristic function that hat-delta should use.\n\
\ Heuristic functions are input in the form of a Haskell data\n\
\ structure:\n\
\ ValueHeuristic n A floating point value - n\n\
\ Correct The number of correct evaluations of the\n\
\ slice.\n\
\ Incorrect The number of incorrect evaluations of the\n\
\ slice.\n\
\ Add f1 f2 Add the values of f1 and f2.\n\
\ Negate f Negate the value of f.\n\
\ Multiply f1 f2 Multiply the values of f1 and f2.\n\
\ Invert f Invert the value of f.\n\
\-h Display this help message and exit.\n\
\-n Set the default value of the heuristic when no slice data\n\
\ is available.\n\
\-q Read QuickCheck tests to grab data.\n\
\-s sliceDepth Set the number of child connections hat-delta will follow\n\
\ when generating a program slice.\n\
\-v Print hat-delta's version number, and exit.\n\
\-------------------------------------------------------------------------\n\
\\n\
\Interactive Commands:\n\
\-------------------------------------------------------------------------\n\
\The hat-delta browser asks you questions, so the basic mode of interaction\n\
\is to type answers:\n\
\yes Yes, the equation looks correct by my understanding of the\n\
\ meaning of the function.\n\
\no No, the equation looks incorrect. Given the displayed arguments,\n\
\ the function is returning the wrong result.\n\
\\n\
\:show Show the ADTs that hat-delta is currently investigating.\n\
\\n\
\:quit Exit the interactive tool.\n\
\:help Shows this help text.\n\
\\n\
\:anim Start the hat-anim browser in a new window, beginning with the\n\
\ currently queried reduction.\n\
\:delta or Start the hat-delta browser in a new window, beginning with the\n\
\:split currently queried reduction.\n\
\:detect Start the hat-detect browser in a new window, beginning with\n\
\ the currently queried reduction.\n\
\:explore Start the hat-explore browser in a new window, beginning with\n\
\ the currently queried reduction.\n\
\:trail Start the hat-trail browser in a new window, beginning with the\n\
\ currently queried reduction.\n\
\\n\
\:set Set an option in the form `:set option value`. Options are:\n\
\ depthLimit Set the maximum depth hat-delta will consider\n\
\ making a jump into the ADT. Must be greater\n\
\ than 0.\n\
\ sliceDepth Set the number of child connections hat-delta will\n\
\ follow when generating a program slice. Must be\n\
\ positive. A depth of 0 indicates that the whole\n\
\ function definition should be used as a slice.\n\
\ heuristic Set the heuristic function that hat-delta should\n\
\ use. As described in the command line options\n\
\ section.\n\
\-------------------------------------------------------------------------\n"
main = do args <- System.Environment.getArgs
prog <- System.Environment.getProgName
let (modName,options) = getOptions args
options <- if Version `elem` options
then do hPutStrLn stdout versionString
exitWith ExitSuccess
else if ShowHelp `elem` options
then do hPutStrLn stdout helpMessage
exitWith ExitSuccess
else if modName == ""
then do hPutStrLn stderr (usage "no root module")
exitWith (ExitFailure 1)
else if "--detect" `elem` args
then do hPutStrLn stdout hatDetectWarning
return $ defaultOptions options
else
return $ defaultOptions options
withCString prog (\p -> withCString (hatFile modName) (openHatFile p))
main <- findMain
detect (modName,options) $ (removeNonResultCycles . removeResultCycles . nodeExpForNode) main
progName :: String
progName = "hat-delta"
hatDetectWarning :: String
hatDetectWarning =
highlight [Background Blue] "Warning: hat-detect is now obsolete. Most users should use hat-delta instead. hat-delta will now be run in a mode that immitates the behaviour of hat-detect."
version :: Float
version = 2.72
versionString :: String
versionString = progName ++ " version: " ++ (show version) ++ "\n" ++
"(c) 2005 Thomas Davie\n"
usage :: String -> String
usage err = progName ++ ": " ++ err ++ "\n" ++
"usage: " ++ progName ++ "[-chqv] [-d depth] [-f heuristicFunction] [-n defaultHeuristicValue] [-s sliceDepth] prog[.hat]"
getOptions :: [String] -> (FilePath, [DeltaOption])
getOptions [] = ("",[])
getOptions (arg:args)
| arg == "-c"
= let (f,opts) = getOptions args in (f,DisableADTCompression:opts)
| arg == "-d"
= let
getDepthLimit [] = ("",[])
getDepthLimit (x:xs) = let (f,opts) = getOptions xs
in (f,(DepthLimit $ read x):opts)
in getDepthLimit args
| arg == "-f"
= let
getHeuristicFunction (x:xs) =
(f,(Heuristic $ read x):opts)
where
(f,opts) = getOptions xs
in getHeuristicFunction args
| arg == "-h"
= let (f,opts) = getOptions args in (f,ShowHelp:opts)
| arg == "-n"
= let
getSliceDepth [] = ("",[])
getSliceDepth (x:xs) = let (f,opts) = getOptions xs
in (f,(NoSliceValue $ read x):opts)
in getSliceDepth args
| arg == "-q"
= let (f,opts) = getOptions args in (f,QuickCheckMode:opts)
| arg == "-s"
= let
getSliceDepth [] = ("",[])
getSliceDepth (x:xs) = let (f,opts) = getOptions xs
in (f,(SliceDepth $ read x):opts)
in getSliceDepth args
| arg == "-t"
= let
getTreeType [] = ("",[])
getTreeType (x:xs) = let (f,opts) = getOptions xs
in (f,(TreeType $ map toLower x):opts)
in getTreeType args
| arg == "-v"
= let (f,opts) = getOptions args in (f,Version:opts)
| arg == "--detect"
= let (f,_) = getOptions args
in (f, [ DisableADTCompression
, DepthLimit 1
, SliceDepth 1
, Heuristic (ValueHeuristic 0.0)])
| otherwise
= let (_,opts) = getOptions args in (arg,opts)
defaultOptions :: [DeltaOption] -> [DeltaOption]
defaultOptions =
defaultTreeType . defaultHeuristic . defaultSliceDepth . defaultDepthLimit
where
defaultSliceDepth :: [DeltaOption] -> [DeltaOption]
defaultSliceDepth options =
if length (filter isSliceDepth options) == 0
then (SliceDepth 1:options)
else options
defaultDepthLimit :: [DeltaOption] -> [DeltaOption]
defaultDepthLimit options =
if length (filter isDepthLimit options) == 0
then (DepthLimit 3:options)
else options
defaultHeuristic :: [DeltaOption] -> [DeltaOption]
defaultHeuristic options =
if length (filter isHeuristic options) == 0
then (Heuristic (Negate
(If (Eq (Add Correct Incorrect)
(ValueHeuristic 0.0))
(
Multiply (ValueHeuristic 1.0)
(Invert (ValueHeuristic 2.0))
)
(
Multiply Correct
(Invert (Add Correct Incorrect))
)
)
)
:options)
else options
defaultTreeType :: [DeltaOption] -> [DeltaOption]
defaultTreeType options =
if length (filter isTreeType options) == 0
then TreeType "edt" : options
else options
detect :: (FilePath, [DeltaOption]) -> NodeExp -> IO()
detect opts = interact . questions opts
hatFile :: FilePath -> FilePath
hatFile = (flip rectify) ".hat"
rectify :: FilePath -> String -> FilePath
rectify f ext | ext `isSuffixOf` f = f
| otherwise = f ++ ext
--- To be removed
data SliceKnowledge = Kn Slice Int Int
trustedModules = ["Prelude", "IO", "Data.Set", "Data.List", "Data.Map"]
instance Show SliceKnowledge where
show (Kn sl wr cr) =
show sl
++ ": "
++ show wr
++ " - "
++ show cr
data DeltaKnowledge = Slices [SliceKnowledge]
isSliceDepth :: DeltaOption -> Bool
isSliceDepth (SliceDepth _) = True
isSliceDepth _ = False
isDepthLimit :: DeltaOption -> Bool
isDepthLimit (DepthLimit _) = True
isDepthLimit _ = False
isHeuristic :: DeltaOption -> Bool
isHeuristic (Heuristic _) = True
isHeuristic _ = False
isTreeType :: DeltaOption -> Bool
isTreeType (TreeType _) = True
isTreeType _ = False
isNothing :: Maybe a -> Bool
isNothing Nothing = True
isNothing _ = False
-- Questions are generated by making a list of booleans of answers
-- and then generating a list of questions based on that. We start
-- with the empty set of knowledge... This may change when we start
-- reading in a corrert program.
questions :: (FilePath, [DeltaOption]) -> NodeExp -> String -> String
questions opts exp =
unlines
. map ("\n" ++)
. (makeQuestions opts exp (Slices []))
. (map toCommand)
. lines
-- Make questions makes a list of questions to ask in order
-- to find a bug in the expression given as the first argument.
-- The second argument is a list of answers to the questions.
-- This function must be able to produce at least one question
-- without needing anything from the answer list.
--
-- This implementation simply calls mkQuestions
-- with the continuation (what to do if the user answers no to
-- the first question) being a function that displays "no
-- bugs found".
makeQuestions :: (FilePath, [DeltaOption])
-> NodeExp
-> DeltaKnowledge
-> [DetectCommand]
-> [String]
makeQuestions (f,opts) n k@(Slices sl) as =
mkQuestions (f,opts) [(compressTree tree)] newMessage [newKnowledge] as
where
newKnowledge =
if QuickCheckMode `elem` opts
then Slices
(compressSlices
( sl
++ (map makeCorrect $ slices opts lvs)
++ (map makeIncorrect
(slices opts
(map (\(Branch _ x _ _) -> x) $ snd tests)))))
else k
lvs = take 100 $ concat $ map leaves $ fst tests
tests = collectTests wholeTree
collectTests :: [ADT] -> ([ADT],[ADT])
collectTests = splitOnPass
. concat
. map findTests
compressTree =
if DisableADTCompression `elem` opts
then id
else map (removeIrrelevantQuestions opts)
findTests b@(Branch _ (NExpApp _ f _ _) _ ch) =
case finalResult f of
NExpIdentifier _ (Plain name) _
-> if "prop_" `isPrefixOf` name
then [b]
else (concat $ map findTests ch)
NExpIdentifier _ (Qualified _ name) _
-> if "prop_" `isPrefixOf` name
then [b]
else (concat $ map findTests ch)
otherwise
-> (concat $ map findTests ch)
findTests x = []
splitOnPass xs = splitOnPassAux xs ([],[])
splitOnPassAux [] (ps,fs) = (ps,fs)
splitOnPassAux (b@(Branch _ test _ _):xs) (ps,fs) =
case finalResult test of
NExpIdentifier _ name _
-> if name == Plain "True"
then splitOnPassAux xs (b:ps,fs)
else splitOnPassAux xs (ps,b:fs)
otherwise
-> splitOnPassAux xs (ps,fs)
tree =
if quickCheckMode
then sortTree workingQCTree
else wholeTree
where
sortTree (Branch _ _ _ ch) = ch
sortTree (Cycle _ _) = []
treeDepth :: Int -> ADT -> Int
treeDepth = treeDepth' 0
where
treeDepth' :: Int -> Int -> ADT -> Int
treeDepth' c m (Branch _ n _ ch)
| c == m = m
| otherwise = case ds of
[] -> c
(x:xs) -> maximum ds
where
ds = (map (treeDepth' (c+1) m) ch)
treeDepth' c _ (Cycle _ _) = c
newMessage = if quickCheckMode
then [identifyTree opts workingQCTree]
else ["No bugs found"]
workingQCTree = head (snd tests)
quickCheckMode :: Bool
quickCheckMode = QuickCheckMode `elem` opts
(TreeType tt) = head $ filter isTreeType opts
wholeTree = ( trustConstant (Plain "otherwise")
. (flip (foldr trustModule) trustedModules)
. detectCycles
. trustUnevaluated
-- . trustIO
. foldHiddens
. (if tt == "fdt"
then buildFDT
else buildEDT)) n
identifyTree :: [DeltaOption] -> ADT -> String
identifyTree opts (Branch _ n _ _) = identifyBug opts n
identifyTree opts (Cycle _ e) = identifyCycle opts e
mkQuestions :: (FilePath, [DeltaOption])
-> [[ADT]]
-> [String]
-> [DeltaKnowledge]
-> [DetectCommand]
-> [String]
mkQuestions _ ([]:_) (report:_) _ _ = [report]
mkQuestions (f,opts)
(edts@(hd@(Branch _ exp disp chldr):others):prevADTs)
(report:prevReports)
(kn@(Slices sl):prevKns)
ans
= f' width
: case ans of
[] -> ["End of input, exiting"]
(Yes:xs) ->
let lvs = take 100 $ leaves edt'
compareQuestions (Branch _ n _ _) (Branch _ n' _ _) =
(flatEval fullEval n) === (flatEval fullEval n')
compareQuestions (Cycle _ xs) (Cycle _ xs') =
and (zipWith compareQuestions xs xs')
compareQuestions _ _ = False
in mkQuestions (f,opts)
( (trustMatchingFunction True
(compareQuestions edt')
edts)
:edts:prevADTs)
(report:report:prevReports)
((Slices
$ compressSlices (sl ++ (map makeCorrect
$ slices opts lvs)))
:kn:prevKns)
xs
(No:xs) ->
mkQuestions (f,opts)
(ch:edts:prevADTs)
((identifyBug opts exp'):report:prevReports)
((Slices
$ compressSlices (sl ++ (map makeIncorrect
$ slices opts [exp'])))
:kn:prevKns)
xs
(Undo:xs) ->
mkQuestions (f,opts)
prevADTs
prevReports
prevKns
xs
(Quit:_) -> ["User Quit. No Bugs Found"]
(Help:_) -> helpMessage : repeatQuestion
(Anim:_) -> seq (unsafePerformIO $ doAnim exp f)
repeatQuestion
(Delta:_) -> seq (unsafePerformIO $ doDelta exp f)
repeatQuestion
(Split:_) -> seq (unsafePerformIO $ doDelta exp f)
repeatQuestion
(Detect:_) -> seq (unsafePerformIO $ doDetect exp f)
repeatQuestion
(Explore:_) -> seq (unsafePerformIO $ doExplore exp f)
repeatQuestion
-- (Observe:_) -> seq (unsafePerformIO $ doObserve exp f)
-- repeatQuestion
(Trail:_) -> seq (unsafePerformIO $ doTrail exp f)
repeatQuestion
(View:_) -> seq (unsafePerformIO $ doView exp)
repeatQuestion
(ShowADT:_) -> displayTrees width (\_ x -> x) edts
: repeatQuestion
(ShowADTHs:_) -> displayTrees width
(showHeuristic (heuristicValue opts kn))
edts
: repeatQuestion
(Children:_) -> let
childQ :: ADT -> String
childQ (Branch _ _ f _) = f width
childQ (Cycle _ _) = "CYCLE!"
in
case head edts of
(Branch _ _ _ chldr)
-> if chldr == []
then "No Children"
else unlines $ map childQ chldr
(Cycle _ chldr)
-> unlines $ map childQ chldr
: repeatQuestion
(Set var val:_) ->
case var of
"depthlimit" ->
newOpts ( (DepthLimit $ read val)
: (filter (not . isDepthLimit) opts))
"slicedepth" ->
newOpts ( (SliceDepth $ read val)
: (filter (not . isSliceDepth) opts))
"heuristic" ->
newOpts ( (Heuristic $ read val)
: (filter (not . isHeuristic) opts))
_ -> "Unknown variable" : repeatQuestion
(Get var:_) ->
case var of
"depthlimit" -> ("Depth Limit: " ++ show depthLimit)
: repeatQuestion
"slicedepth" -> ("Slice Depth: " ++ show sliceDepth)
: repeatQuestion
"heuristic" -> ("Heuristic: " ++ show heuristic)
: repeatQuestion
_ -> "Unknown variable" : repeatQuestion
_ -> "Unknown command, type ':help' for help."
: repeatQuestion
where
edt'@(Branch _ exp' f' ch)
= minADT opts kn $ subADTs (Just depthLimit) edts
(DepthLimit depthLimit) = head $ filter isDepthLimit opts
(SliceDepth sliceDepth) = head $ filter isSliceDepth opts
(Heuristic heuristic) = head $ filter isHeuristic opts
repeatQuestion = newOpts opts
newOpts newOptions = mkQuestions (f,newOptions)
(edts:prevADTs)
(report:prevReports)
(kn:prevKns)
(tail ans)
(width,_) = unsafePerformIO $ getTerminalSize
arg :: Int -> NodeExp -> NodeExp
arg x (NExpApp _ _ as _) = as !! x
mkQuestions (f,opts)
(edts@(hd@(Cycle _ [Branch _ e _ _]):others):prevADTs)
(report:prevReports)
(kn:prevKns)
ans
= mkQuestions (f,opts)
(others:edts:prevADTs)
((identifyBug opts
e ++ "\nBug in looping function.\n")
:report:prevReports)
(kn:kn:prevKns)
ans
mkQuestions (f,opts)
(edts@(hd@(Cycle _ l:others)):prevADTs)
(report:prevReports)
(kn:prevKns)
ans
= mkQuestions (f,opts)
(others:edts:prevADTs)
((identifyCycle opts l):report:prevReports)
(kn:kn:prevKns)
ans
mkQuestions _ _ _ _ _ = error "ADT's corrupt"
minADT :: [DeltaOption] -> DeltaKnowledge -> [ADT] -> ADT
minADT opts kn =
minimumBy (\(Branch _ x _ _) (Branch _ y _ _)
-> compare (heuristicValue opts kn x) (heuristicValue opts kn y))
heuristicValue :: [DeltaOption] -> DeltaKnowledge -> NodeExp -> Float
heuristicValue opts kn exp =
if isNothing sl
then noSliceHeuristic opts
else let know = runs kn $ fromJust sl
in if isNothing know
then -(evalHeuristic mode $ (Kn (fromJust sl) 0 0))
else -(evalHeuristic mode $ fromJust know)
where
sl = makeSlice sliceDepth exp
(Heuristic mode) = head $ filter isHeuristic opts
(SliceDepth sliceDepth) = head $ filter isSliceDepth opts
noSliceHeuristic :: [DeltaOption] -> Float
noSliceHeuristic [] = 0.0
noSliceHeuristic ((NoSliceValue x):xs) = x
noSliceHeuristic (_:xs) = noSliceHeuristic xs
evalHeuristic :: HeuristicMode -> SliceKnowledge -> Float
evalHeuristic (ValueHeuristic n) _ = n
evalHeuristic Correct know =
(\(Kn _ _ c) -> fromIntegral c) know
evalHeuristic Incorrect know =
(\(Kn _ w _) -> fromIntegral w) know
evalHeuristic (Add x y) know =
evalHeuristic x know + evalHeuristic y know
evalHeuristic (Negate x) know =
-(evalHeuristic x know)
evalHeuristic (Multiply x y) know =
evalHeuristic x know * evalHeuristic y know
evalHeuristic (Invert x) know =
1.0 / (evalHeuristic x know)
evalHeuristic (If c t f) know =
if evalBool c know
then evalHeuristic t know
else evalHeuristic f know
evalBool :: HeuristicBool -> SliceKnowledge -> Bool
evalBool TrueBool _ = True
evalBool FalseBool _ = False
evalBool (Not x) kn = not (evalBool x kn)
evalBool (And x y) kn = (evalBool x kn) && (evalBool y kn)
evalBool (Or x y) kn = (evalBool x kn) || (evalBool y kn)
evalBool (Eq x y) kn = (evalHeuristic x kn) == (evalHeuristic y kn)
evalBool (Gt x y) kn = (evalHeuristic x kn) > (evalHeuristic y kn)
evalBool (Lt x y) kn = (evalHeuristic x kn) < (evalHeuristic y kn)
runs :: DeltaKnowledge -> Slice -> Maybe SliceKnowledge
runs kn@(Slices sls) =
getRuns sls
where
getRuns :: [SliceKnowledge] -> Slice -> Maybe SliceKnowledge
getRuns [] _ = Nothing
getRuns (kn@(Kn sl _ _):others) sl'
| sl == sl' = Just kn
| otherwise = getRuns others sl'
removeIrrelevantQuestions :: [DeltaOption] -> ADT -> ADT
removeIrrelevantQuestions opts (Branch t n disp ch) =
Branch t n disp newChildren
where
newChildren = map (removeIrrelevantQuestions opts) movedChildren
movedChildren =
if isNothing topLevelSlice then ch
else foldr (++)
[]
(map (findDifferentSlices (fromJust topLevelSlice)) ch)
topLevelSlice = makeSlice sliceDepth n
findDifferentSlices :: Slice -> ADT -> [ADT]
findDifferentSlices sl (Branch t' n' disp' ch') =
if not (isNothing newSlice) && fromJust newSlice == sl
then foldr (++) [] (map (findDifferentSlices sl) ch')
else [Branch t' n' disp' ch']
where
newSlice = makeSlice sliceDepth n'
findDifferentSlices _ cycle = [cycle]
(SliceDepth sliceDepth) = head $ filter isSliceDepth opts
removeIrrelevantQuestions opts cycle = cycle
elemBy :: a -> [a] -> (a -> a -> Bool) -> Bool
elemBy e l f = any (f e) l
deltaEval :: NodeExp -> NodeExp
deltaEval = flatEval fullEval
slices :: [DeltaOption] -> [NodeExp] -> [Slice]
slices opts = map fromJust
. filter (/= Nothing)
. map (makeSlice sliceDepth)
where
(SliceDepth sliceDepth) = head $ filter isSliceDepth opts
makeIncorrect :: Slice -> SliceKnowledge
makeIncorrect sl = Kn sl 1 0
makeCorrect :: Slice -> SliceKnowledge
makeCorrect sl = Kn sl 0 1
compressSlices :: [SliceKnowledge] -> [SliceKnowledge]
compressSlices =
doCompress . groupBy (\(Kn sl _ _) (Kn sl' _ _) -> sl == sl')
where
doCompress [] = []
doCompress [x] = [x]
doCompress (x@(Kn sl w c):x1@(Kn sl1 w1 c1):xs)
| sl == sl1 = doCompress ((Kn sl (w+w1) (c+c1)):xs)
| otherwise = x : doCompress (x1:xs)
group :: Eq a => [a] -> [a]
group = groupBy (==)
groupBy :: (a -> a -> Bool) -> [a] -> [a]
groupBy f xs
= groupByAux f xs []
where
groupByAux :: (a -> a -> Bool) -> [a] -> [a] -> [a]
groupByAux f [] res = res
groupByAux f (x:xs) res = groupByAux f xs $ insertInto f x res
insertInto :: (a -> a -> Bool) -> a -> [a] -> [a]
insertInto f i [] = [i]
insertInto f i (x:xs)
| f i x = i:x:xs
| otherwise = x:(insertInto f i xs)
addSlice :: SliceKnowledge -> [SliceKnowledge] -> [SliceKnowledge]
addSlice s [] = [s]
addSlice s@(Kn sl a b) (s'@(Kn sl' a' b'):others)
| sl == sl' = (Kn sl (a+a') (b+b')):others
| otherwise = s':(addSlice s others)
format :: DeltaKnowledge -> String
format (Slices slices)
= "Slices:\n"
++ unlines (map show slices)