summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--kiki.cabal7
-rw-r--r--lib/CommandLine.hs559
-rw-r--r--lib/Numeric/Interval.hs754
-rw-r--r--lib/Numeric/Interval/Bounded.hs9
-rw-r--r--lib/SuperOrd.hs23
5 files changed, 1351 insertions, 1 deletions
diff --git a/kiki.cabal b/kiki.cabal
index 191519c..a96eee9 100644
--- a/kiki.cabal
+++ b/kiki.cabal
@@ -57,6 +57,7 @@ Executable hosts
57Executable cokiki 57Executable cokiki
58 Main-is: cokiki.hs 58 Main-is: cokiki.hs
59 Build-Depends: base >=4.6.0.0, 59 Build-Depends: base >=4.6.0.0,
60 bytestring,
60 unix, 61 unix,
61 kiki 62 kiki
62 63
@@ -70,7 +71,11 @@ library
70 Base58, 71 Base58,
71 CryptoCoins, 72 CryptoCoins,
72 ProcessUtils, 73 ProcessUtils,
73 Hosts 74 Hosts,
75 CommandLine,
76 Numeric.Interval,
77 Numeric.Interval.Bounded,
78 SuperOrd
74 other-modules: TimeUtil, 79 other-modules: TimeUtil,
75 Compat, 80 Compat,
76 FunctorToMaybe 81 FunctorToMaybe
diff --git a/lib/CommandLine.hs b/lib/CommandLine.hs
new file mode 100644
index 0000000..dfc16f9
--- /dev/null
+++ b/lib/CommandLine.hs
@@ -0,0 +1,559 @@
1{-# LANGUAGE DeriveFunctor #-}
2{-# LANGUAGE CPP #-}
3-- {-# LANGUAGE RankNTypes #-}
4{-# LANGUAGE BangPatterns #-}
5{-# LANGUAGE GADTs #-}
6{-# LANGUAGE StandaloneDeriving #-}
7{-# LANGUAGE PatternGuards #-}
8module CommandLine
9 ( Args
10 , UsageError(..)
11 , usageErrorMessage
12 , parseInvocation
13 , runArgs
14 , arg
15 , param
16 , params
17 , label
18 ) where
19
20import Control.Applicative
21import Control.Arrow
22import Control.Monad
23import Data.Bits
24import Data.Either
25import Data.Function
26import Data.List
27import Data.Maybe
28import Data.Ord
29import Data.Map.Strict (Map)
30import qualified Data.Map.Strict as Map
31import Data.IntMap.Strict (IntMap)
32import qualified Data.IntMap.Strict as IntMap
33import Debug.Trace
34import Numeric.Interval (Interval(..), singleton, (...), inf, sup, hull)
35import qualified Numeric.Interval as I
36import Numeric.Interval.Bounded
37import SuperOrd
38
39-- trace :: String -> a -> a
40-- trace _ x = x
41
42-- type CompF a = [String] -> [String] -> a
43
44type MergeData = [(Int,Ordering)]
45
46-- | Expr a
47--
48data Expr a where
49 -- | Prim
50 --
51 -- Takes a function from the option arguments and unamed arguments repsectively to
52 -- a value of type a, usually IO (), and gives you an expression tree. As one
53 -- traverses down the tree only the 'interesting' option arguments are passed
54 -- to this function, but all of the unnamed arguments are passed regardless of
55 -- where we are in the tree.
56 --
57 Prim :: ([[String]] -> [String] -> a) -> Interval (SuperOrd Int) -> Expr a
58 -- | Star
59 -- Applicative '<*>'
60 Star :: MergeData -> Expr (b -> a) -> (Expr b) -> Expr a
61 -- | Or
62 -- Alternative '<|>'
63 Or :: MergeData -> Expr a -> Expr a -> Expr a
64 -- | Empty
65 -- Alternative empty
66 Empty :: Expr a
67
68deriving instance Functor Expr
69
70-- | Args
71--
72-- Applicative Functor for interpretting command line arguments.
73data Args a = Args
74 { expr :: Expr a
75 -- ^ Expression tree
76 , accepts :: [String]
77 -- ^ sorted list of acceptable short and long option names (non positional arguments)
78 -- The names include hyphens.
79 }
80 deriving Functor
81
82instance Applicative Args where
83 pure x = Args { expr = Prim (\_ _ -> x) (singleton $ exactly 0), accepts = [] }
84 f <*> b = Args
85 { expr = Star d (expr f) (expr b)
86 , accepts = m
87 }
88 where d = mergeData compare (accepts f) (accepts b)
89 m = mergeLists d const (accepts f) (accepts b)
90
91instance Alternative Args where
92 empty = Args Empty []
93 f <|> g = Args
94 { expr = Or d (expr f) (expr g)
95 , accepts = m
96 }
97 where d = mergeData compare (accepts f) (accepts g)
98 m = mergeLists d const (accepts f) (accepts g)
99
100
101{- dead code?
102unpackBits :: Integer -> [Bool]
103unpackBits 0 = [False]
104unpackBits 1 = [True]
105unpackBits n = ( r /= 0 ) : unpackBits q
106 where
107 (q,r) = divMod n 2
108
109-- requires finite list
110packBits :: [Bool] -> Integer
111packBits bs = sum $ zipWith (\b n -> if b then n else 0) bs $ iterate (*2) 1
112 -}
113
114
115-- | mergeData
116--
117-- > mergeData compare [1,3,5] [2,2,4,6] ==> [(1,LT),(2,GT),(1,LT),(1,GT),(1,LT),(1,GT)]
118--
119-- Given a comparison function and two sorted lists, 'mergeData' will return
120-- a RLE compressed (run-length encoded) list of the comparison results
121-- encountered while merging the lists.
122--
123-- This data is enough information to perform the merge without doing the
124-- comparisons or to reverse a merged list back to two sorted lists.
125--
126-- When one list is exausted, the length of the remaining list is returned as
127-- a run-length for LT or GT depending on whether the left list or the right
128-- list has elements.
129mergeData :: (a -> a -> Ordering) -> [a] -> [a] -> [(Int,Ordering)]
130mergeData comp (x:xs) (y:ys)
131 | comp x y == LT = case mergeData comp xs (y:ys) of
132 (n,LT):ys -> let n'=n+1 in n' `seq` (n',LT):ys
133 ys -> (1,LT):ys
134 | comp x y == EQ = case mergeData comp xs ys of
135 (n,EQ):ys -> let n'=n+1 in n' `seq` (n',EQ):ys
136 ys -> (1,EQ):ys
137 | comp x y == GT = case mergeData comp (x:xs) ys of
138 (n,GT):ys -> let n'=n+1 in n' `seq` (n',GT):ys
139 ys -> (1,GT):ys
140mergeData comp [] [] = []
141mergeData comp [] ys = (length ys, GT) : []
142mergeData comp xs [] = (length xs, LT) : []
143
144mergeLists :: [(Int,Ordering)] -> (a -> a -> a) -> [a] -> [a] -> [a]
145mergeLists ((n,LT):os) f xs ys = ls ++ mergeLists os f xs' ys
146 where
147 (ls,xs') = splitAt n xs
148mergeLists ((n,EQ):os) f xs ys = es ++ mergeLists os f xs' ys'
149 where
150 (les,xs') = splitAt n xs
151 (res,ys') = splitAt n ys
152 es = zipWith f les res
153mergeLists ((n,GT):os) f xs ys = gs ++ mergeLists os f xs ys'
154 where
155 (gs,ys') = splitAt n ys
156mergeLists [] f [] ys = ys
157mergeLists [] f xs [] = xs
158mergeLists [] f xs ys = error "xs ++ ys"
159
160{-
161computeMask :: Int -> Ordering -> Ordering -> [(Int,Ordering)] -> Integer
162computeMask k w t [] = 0
163computeMask k w t ((n,v):os)
164 = if w==v then r .|. shiftL (bit n - 1) k
165 else r
166 where r = computeMask (k+n') w t os
167 n' | v==t = n
168 | otherwise = 0
169
170-- WRONG, one-blocks are not spaced the same in input and output, need shifts
171mergeIntegers :: [(Int,Ordering)] -> (Integer -> Integer -> Integer) -> Integer -> Integer -> Integer
172mergeIntegers os f x y = (leftmask .&. x) .|. (rightmask .&. y) .|. (f (leqmask .&. x) (reqmask .&. y))
173 where
174 leftmask = computeMask 0 LT EQ os
175 leqmask = computeMask 0 EQ LT os
176 reqmask = computeMask 0 EQ GT os
177 rightmask = computeMask 0 GT EQ os
178-}
179{- kinda dead code
180mergeIntegers ((n,LT):os) f !x !y = v `seq` m `seq` m .|. v
181 where
182 m = x .&. (bit n - 1)
183 r = mergeIntegers os f (shiftR x n) y
184 v = r `seq` shiftL r n
185mergeIntegers ((n,EQ):os) f !x !y = mm `seq` v `seq` mm .|. v
186 where
187 mm = f mx my
188 mx = x .&. (bit n - 1)
189 my = y .&. (bit n - 1)
190 r = mergeIntegers os f (shiftR x n) (shiftR y n)
191 v = r `seq` shiftL r n
192mergeIntegers ((n,GT):os) f !x !y = v `seq` m `seq` m .|. v
193 where
194 m = y .&. (bit n - 1)
195 r = mergeIntegers os f x (shiftR y n)
196 v = r `seq` shiftL r n
197mergeIntegers [] f !0 !y = y
198mergeIntegers [] f !x !0 = x
199mergeIntegers [] f !x !y = error "x .|. y"
200-}
201
202splitLists :: [(Int,Ordering)] -> [a] -> ([a],[a])
203splitLists ((n,LT):os) xs = (ls ++ lls, rrs)
204 where
205 (ls,xs') = splitAt n xs
206 (lls,rrs) = splitLists os xs'
207splitLists ((n,EQ):os) xs = (es ++ lls, es ++ rrs)
208 where
209 (es,xs') = splitAt n xs
210 (lls,rrs) = splitLists os xs'
211splitLists ((n,GT):os) xs = (lls, rs ++ rrs)
212 where
213 (rs,xs') = splitAt n xs
214 (lls,rrs) = splitLists os xs'
215splitLists [] xs = (xs,xs)
216
217{-
218mergeBy :: Show a => (a -> a -> Ordering) -> [a] -> [a]
219 -> ( (Integer -> Integer -> Integer) -> Integer -> Integer -> Integer
220 , (b -> b -> b) -> [b] -> [b] -> [b]
221 , [b] -> ([b], [b]))
222mergeBy comp xs ys = trace (unlines ["xs="++show xs,"ys="++show ys,"mergeData="++show d]) (mergeIntegers d, mergeLists d, splitLists d)
223 where
224 d = mergeData comp xs ys
225-}
226
227
228param :: Int -> Args String
229param n = Args (Prim (\_ us -> us!!n) (singleton $ exactly (n+1))) []
230
231arg :: String -> Args String
232arg optname = Args (Prim (\opts _ -> head $ concat $ take 1 opts)
233 (singleton $ exactly 0))
234 [optname]
235
236params :: Args [String]
237params = Args (Prim (\_ args -> args) (exactly 0 ... PositiveInfinity)) []
238
239
240label :: String -> Args a -> Args a
241label _ = id
242
243data ArgsStyle = ArgsStyle
244 { parseInvocation :: String -> [String] -> ([(String,[String])], [String])
245 }
246
247-- | Phase 1. This function accepts a list of command line arguments in its
248-- second argument that will be parsed to obtain a pair of lists: named
249-- argument-value pairs and unnamed arguments values.
250--
251-- The first argument indicates which short options will be treated as on/off
252-- flags and given a dummy value of \"\". Hyphen-prefixed options not in this
253-- list are given their imeediately following string as a value.
254--
255-- The \"--\" convention is implemented to indicate all remaining arguments are
256-- unnamed argument values.
257--
258-- The results of this function are intended to be used as input to 'runArgs'.
259vanilla :: ArgsStyle
260vanilla = ArgsStyle { parseInvocation = parse }
261 where
262 parse flags cli = (opts, concat nons ++ nondashed ++ drop 1 trailing)
263 where
264 (as, trailing) = span (/= "--") cli
265 (nons,bs) = span ((==[True]) . map (not . isPrefixOf "-") . take 1) $ groupBy (const $ not . isPrefixOf "-") as
266 (ds, nondashed) = second concat $ unzip $ map splitParams bs
267 opts = map ((first concat) . splitAt 1) (ds :: [[String]])
268
269 splitParams (('-':[x]):xs) | x `elem` flags = (['-':[x]],xs)
270 splitParams xs = splitAt 2 xs
271
272-- | Information about how the user failed to satisfy a specified usage.
273data UsageError
274 = TooManyParameters Int
275 -- ^ The given number of excessive unnamed arguments occured.
276 | InsufficientParameters Int
277 -- ^ Not enough unnamed arguments. The number indicates how many are
278 -- total are expected.
279 | TooManyOf String [String]
280 -- ^ An option was supplied too many times. The list is a set of values
281 -- associated with the repeated instances.
282 | Missing [String]
283 -- ^ A list of required options that the user failed to specify.
284 | ChooseOne [[String]]
285 -- ^ The user failed to choose one of the given set of option combinations.
286 | Misunderstood [String]
287 -- ^ A list of unrecognized options.
288 | Incompatible [[String]]
289 -- ^ A list of supplied options that may not be used together.
290
291 | NamedFailure String UsageError
292 -- ^ Extra context provided via the 'label' primitive.
293
294 deriving (Eq,Show)
295
296-- | Obtain a description of a usage error that can be reported to the user.
297usageErrorMessage :: UsageError -> String
298usageErrorMessage (NamedFailure _ e) = usageErrorMessage e
299usageErrorMessage (TooManyParameters _) = "too many arguments"
300usageErrorMessage (InsufficientParameters c) = "insufficient arguments (need "++show c++")"
301usageErrorMessage (TooManyOf n xs) = n ++" can be specified only once"
302usageErrorMessage (Missing ns) = "missing: "++intercalate ", " ns
303usageErrorMessage (ChooseOne nss) = "choose one of: "++intercalate ", " (map (intercalate " ") nss)
304usageErrorMessage (Misunderstood ns) = "unrecognized: "++intercalate ", " ns
305usageErrorMessage (Incompatible nss) = intercalate " and " (map (intercalate " ") nss) ++ " cannot be used together"
306
307{-
308rankError :: UsageError -> Int
309rankError (NamedFailure _ e) = rankError e
310rankError (TooManyParameters _) = 0
311rankError (InsufficientParameters _) = 1
312rankError (TooManyOf _ xs) = 1
313rankError (Missing _) = 2
314rankError (ChooseOne _) = 2
315rankError (Misunderstood xs) = 2 + length xs
316rankError (Incompatible ys) = 2 + length ys
317
318tagError :: UsageError -> Int
319tagError (NamedFailure _ _) = 0
320tagError (TooManyParameters _) = 1
321tagError (InsufficientParameters _) = 2
322tagError (TooManyOf _ _) = 3
323tagError (Missing _) = 4
324tagError (ChooseOne _) = 5
325tagError (Misunderstood _) = 6
326tagError (Incompatible _) = 7
327
328missingWhat :: UsageError -> [[String]]
329missingWhat (Missing xs) = [xs]
330missingWhat (ChooseOne ys) = ys
331missingWhat (NamedFailure _ e) = missingWhat e
332missingWhat _ = []
333
334misunderstoodWhat :: UsageError -> [String]
335misunderstoodWhat (Misunderstood xs) = xs
336misunderstoodWhat (Incompatible yss) = concatMap (take 1) yss
337misunderstoodWhat (NamedFailure _ e) = misunderstoodWhat e
338misunderstoodWhat _ = []
339-}
340
341{- dead code
342tryCompute :: [(String,String)] -> [String] -> Computation a -> Either UsageError a
343tryCompute os us c@(Computation { compLabel = lbl })
344 | null lbl = tryCompute' os us c
345 | otherwise = either (Left . NamedFailure lbl) Right $ tryCompute' os us c
346 where
347 tryCompute' os us c
348 | not (null unused_os) = Left $ Misunderstood $ map fst unused_os
349 | not (null missing) = Left $ Missing missing
350 | not (null repss) = Left $ TooManyOf (fst $ head $ head repss) (map snd $ head repss)
351 | ulen < clen = Left $ InsufficientParameters clen
352 | ulen > clen = Left $ TooManyParameters (ulen - clen)
353 | otherwise = Right $ compute c os us
354 where
355 (found, missing) = partition (\k -> k `elem` map fst os) $ consumedOptions c
356 (used_os, unused_os) = partition (\(k,v) -> k `elem` consumedOptions c) os
357 ulen = length us
358 repss = filter (not . null . tail) $ groupBy ((==) `on` fst) $ sortBy (comparing fst) used_os
359 clen = case consumedParameters c of
360 -1 -> ulen
361 num -> num
362-}
363
364#if defined(VERSION_base)
365#if !MIN_VERSION_base(4,8,0)
366sortOn :: Ord b => (a -> b) -> [a] -> [a]
367sortOn f =
368 map snd . sortBy (comparing fst) . map (\x -> let y = f x in y `seq` (y, x))
369#endif
370#endif
371
372removeIntersection (x:xs) (y:ys)
373 | x == y = removeIntersection xs ys
374 | x < y = first (x :) $ removeIntersection xs (y:ys)
375 | x > y = second (y :) $ removeIntersection (x:xs) ys
376removeIntersection [] ys = ([],ys)
377removeIntersection xs [] = (xs,[])
378
379
380-- ordinary sorted list merge.
381mergeL :: Ord a => [a] -> [a] -> [a]
382mergeL as bs = mergeLists (mergeData compare as bs) const as bs
383
384-- | runArgs
385--
386-- (os,us) - named arguments(options, name-value pairs), and unnamed arguments
387-- c - expression tree (applicative functor)
388--
389-- returns either a UsageError or a computed result (perhaps IO ())
390--
391-- Evaluate the given set of named and unnamed values and return
392-- the computed result or else indicate bad usage.
393--
394-- 'parseInvocation' may be used on the results of 'System.Environment.getArgs'
395-- to obtain suitable input for this function.
396runArgs :: ([(String,[String])], [String]) -> Args a -> Either UsageError a
397runArgs (os,us) c
398 | not (null bads) = Left $ Misunderstood $ map fst bads
399 | not (null dups) = Left $ TooManyOf (fst $ head dups) (concat $ take 1 $ snd $ head dups) -- only reports first dup.
400 | otherwise = makeError $ compute (expr c) (zipWith const [0..] (accepts c)) us
401 where
402 os' = sortOn fst os
403 dups = mapMaybe notSingle $ groupBy ((==) `on` fst) (os' :: [(String,[String])])
404 where notSingle [x] = Nothing
405 notSingle ((k,v):xs) = Just (k,v : map snd xs)
406 getbit = let r = Map.fromList $ zip (accepts c) [0..] in trace ("getbit = "++show r) r
407 goods :: [(Int,[String])]
408 (bads,goods) = let r = partitionEithers $ map f os' in trace ("(bads,goods)="++show r) r
409 where f (k,v) = case Map.lookup k getbit of
410 Just b -> Right (b,v)
411 Nothing -> Left (k,v)
412
413 valmap = IntMap.fromList goods
414 namemap = IntMap.fromList $ zip [0..] (accepts c)
415
416 vals = map snd goods
417 ulen = length us
418
419 makeError (_,Left e) = Left $ makeError' e
420 where
421 makeError' (Left xss) = Incompatible $ map (map (namemap IntMap.!)) xss
422 makeError' (Right [xs]) = Missing $ map (namemap IntMap.!) xs
423 makeError' (Right xss) = ChooseOne $ map (map (namemap IntMap.!)) xss
424 makeError (i,Right v)
425 | exactly ulen > sup i = Left $ TooManyParameters (ulen - superApprox (sup i))
426 | exactly ulen < inf i = Left $ InsufficientParameters (superApprox (inf i))
427 | otherwise = Right v
428
429
430 -- On success, returns Right, otherwise:
431 --
432 -- * @ Left (Right xss) @ - xss indicates unspecified required named-options.
433 --
434 -- * @ Left (Left xss) @ - xss is a list of mutually-exclusive sets of specified options.
435 --
436 compute :: Expr a -> [Int] -> [String] -> (Interval (SuperOrd Int), Either (Either [[Int]] [[Int]]) a)
437 compute (Prim f i) opts us
438 | null es = (i, Right $ f vals us )
439 | otherwise = (i, Left $ Right [es])
440 where
441 (es,vals) = partitionEithers
442 $ map (\k -> maybe (Left k) Right (k `IntMap.lookup` valmap)) opts
443 compute (Star d f b) opts us = (max (inf fi) (inf bi) ... max (sup fi) (sup bi), r)
444 where
445 r = case (fres,bres) of
446 (Right ff , Right bb) -> Right $ ff bb
447 (Left e , Right _) -> Left e
448 (Right _ , Left e) -> Left e
449 (Left (Right ls) , Left (Right rs)) -> Left $ Right [ mergeL l r | l <- ls, r <- rs ]
450 (Left (Left ls) , Left (Left rs)) -> Left $ Left (ls ++ rs)
451 (Left e , Left (Right _)) -> Left e
452 (Left (Right _) , Left e ) -> Left e
453 (fopts,bopts) = splitLists d opts
454 (fi,fres) = compute f fopts us
455 (bi,bres) = compute b bopts us
456 compute (Or d f g) opts us
457 = case () of
458 () | null fonly
459 , null gonly
460 , Left (Right fms) <- fr
461 , Left (Right gms) <- gr -> (hi, Left $ Right $ fms ++ gms)
462
463 () | Left (Left fss) <- fr
464 , Left (Left gss) <- gr -> (hi, Left (Left (fss ++ gss)))
465
466 () | null gonly, Left _ <- gr -> (fi,fr)
467 () | null fonly, Left _ <- fr -> (gi,gr)
468
469 () | null gonly, Right _ <- fr -> (fi,fr)
470 () | null fonly, Right _ <- gr -> (gi,gr)
471
472 () | Left (Left fss) <- fr -> (hi, Left (Left ( filter (not . null) (gonly : map (filter (not . (`elem` gopts))) fss))))
473 () | Left (Left gss) <- gr -> (hi, Left (Left ( filter (not . null) (fonly : map (filter (not . (`elem` fopts))) gss))))
474 () -> (hi, Left (Left [fonly,gonly]))
475
476 where
477 (fopts,gopts) = splitLists d opts
478 (fonly,gonly) = (filterPresent *** filterPresent) $ removeIntersection fopts gopts
479 filterPresent = filter (`IntMap.member` valmap)
480 (fi,fr) = compute f fopts us
481 (gi,gr) = compute g gopts us
482 hi = hull fi gi
483 compute Empty _ _ = error "CommandLine: empty evaluation"
484
485{-
486-- | Phase 2. Evaluate the given set of named and unnamed values and return
487-- the computed result or else indicate bad usage.
488--
489-- 'parseInvocation' may be used on the results of 'System.Environment.getArgs'
490-- to obtain suitable input for this function.
491runArgsOlder :: ([(String,String)], [String]) -> ArgsOlder a -> Either UsageError a
492runArgsOlder (os,us) (ArgsOlder alts)
493 | not (null rs) = Right $ head rs
494 | not (null ls) = Left $ chooseError ls
495 | otherwise = Right $ error $ show (length alts,ls)
496 where
497 recs = map (tryCompute os us) alts
498 rs = rights recs
499 ls = lefts recs
500-}
501
502{-
503chooseError :: [UsageError] -> UsageError
504chooseError ls = case span ((==2) . rankError) $ sortOn rankError ls of
505 ([e],_) -> e
506 (e:es,_)
507 | overlap -> em
508 | otherwise -> -- trace ("ms="++show ms) $
509 case findPartition ms of
510 Just (xs@(_:_:_)) -> ChooseOne $ map return xs
511 _ -> em
512 where
513 em:ems = sortBy (comparing (maximum . map length . missingWhat)) (e:es)
514 ms = concatMap missingWhat (em:ems)
515 mi = foldr1 intersect ms
516 overlap = any null $ map (\\ mi) ms
517 (_,e:es) -> case takeWhile ((>2) . rankError) (e:es) of
518 [f] -> f
519 f:fs -> -- trace ("ws="++show (w:ws))
520 case u of
521 [_] -> f
522 _ -> Incompatible u
523 where u = foldr1 union $ w : takeWhile ((==wlen) . length) ws
524 w:ws = map misunderstoodWhat (f:fs)
525 wlen = length w
526 [] -> e
527-}
528
529
530{-
531-- Given a collection of sets, return a list of unique reprasentative members.
532findPartition :: Eq x => [[x]] -> Maybe [x]
533findPartition yss =
534 case sortBy (comparing length) yss of
535 []:_ -> Nothing
536 zss | not (null ds) -> Nothing
537 | otherwise -> _findPartition ps es xss3
538 where
539 (pss,xss0) = span isSingle zss
540 isSingle [x] = True
541 isSingle _ = False
542 ps = foldr union [] pss
543 xss1 = map (partition (`elem` ps)) xss0
544 (xss2,bs) = partition (null . fst) xss1
545 (cs,ds) = partition (null . drop 1 . fst) bs
546 es = foldr union [] $ map snd cs
547 xss3 = map snd xss2
548
549
550_findPartition :: Eq x => [x] -> [x] -> [[x]] -> Maybe [x]
551_findPartition ps qs [] = Just ps
552_findPartition ps qs (xs:xss)
553 | null cs = Nothing
554 | otherwise = listToMaybe ss
555 where
556 cs = filter (not . flip elem qs) xs
557 ts = init $ zipWith (\as (b:bs) -> (b,as++bs)) (inits cs) (tails cs)
558 ss = mapMaybe (\(t,tqs) -> _findPartition (t:ps) (tqs++qs) (filter (not . elem t) xss)) ts
559-}
diff --git a/lib/Numeric/Interval.hs b/lib/Numeric/Interval.hs
new file mode 100644
index 0000000..df4bc33
--- /dev/null
+++ b/lib/Numeric/Interval.hs
@@ -0,0 +1,754 @@
1{-# LANGUAGE CPP #-}
2{-# LANGUAGE Rank2Types #-}
3{-# LANGUAGE DeriveDataTypeable #-}
4#if defined(__GLASGOW_HASKELL) && __GLASGOW_HASKELL__ >= 704
5{-# LANGUAGE DeriveGeneric #-}
6#endif
7-----------------------------------------------------------------------------
8-- |
9-- Module : Numeric.Interval
10-- Copyright : (c) Edward Kmett 2010-2013
11-- License : BSD3
12-- Maintainer : ekmett@gmail.com
13-- Stability : experimental
14-- Portability : DeriveDataTypeable
15-- Version : intervals-0.4.2 (minus distributive instance)
16--
17-- Interval arithmetic
18--
19-----------------------------------------------------------------------------
20
21module Numeric.Interval
22 ( Interval(..)
23 , (...)
24 , whole
25 , empty
26 , null
27 , singleton
28 , elem
29 , notElem
30 , inf
31 , sup
32 , singular
33 , width
34 , midpoint
35 , intersection
36 , hull
37 , bisection
38 , magnitude
39 , mignitude
40 , contains
41 , isSubsetOf
42 , certainly, (<!), (<=!), (==!), (>=!), (>!)
43 , possibly, (<?), (<=?), (==?), (>=?), (>?)
44 , clamp
45 , idouble
46 , ifloat
47 ) where
48
49import Control.Applicative hiding (empty)
50import Data.Data
51#ifdef VERSION_distributive
52import Data.Distributive
53#endif
54import Data.Foldable hiding (minimum, maximum, elem, notElem, null)
55import Data.Function (on)
56import Data.Monoid
57import Data.Traversable
58#if defined(__GLASGOW_HASKELL) && __GLASGOW_HASKELL__ >= 704
59import GHC.Generics
60#endif
61import Prelude hiding (null, elem, notElem)
62
63-- $setup
64
65data Interval a = I !a !a deriving
66 ( Data
67 , Typeable
68#if defined(__GLASGOW_HASKELL) && __GLASGOW_HASKELL__ >= 704
69 , Generic
70#if __GLASGOW_HASKELL__ >= 706
71 , Generic1
72#endif
73#endif
74 )
75
76instance Functor Interval where
77 fmap f (I a b) = I (f a) (f b)
78 {-# INLINE fmap #-}
79
80instance Foldable Interval where
81 foldMap f (I a b) = f a `mappend` f b
82 {-# INLINE foldMap #-}
83
84instance Traversable Interval where
85 traverse f (I a b) = I <$> f a <*> f b
86 {-# INLINE traverse #-}
87
88instance Applicative Interval where
89 pure a = I a a
90 {-# INLINE pure #-}
91 I f g <*> I a b = I (f a) (g b)
92 {-# INLINE (<*>) #-}
93
94instance Monad Interval where
95 return a = I a a
96 {-# INLINE return #-}
97 I a b >>= f = I a' b' where
98 I a' _ = f a
99 I _ b' = f b
100 {-# INLINE (>>=) #-}
101
102#ifdef VERSION_distributive
103instance Distributive Interval where
104 distribute f = fmap inf f ... fmap sup f
105 {-# INLINE distribute #-}
106#endif
107
108infix 3 ...
109
110negInfinity :: Fractional a => a
111negInfinity = (-1)/0
112{-# INLINE negInfinity #-}
113
114posInfinity :: Fractional a => a
115posInfinity = 1/0
116{-# INLINE posInfinity #-}
117
118nan :: Fractional a => a
119nan = 0/0
120
121fmod :: RealFrac a => a -> a -> a
122fmod a b = a - q*b where
123 q = realToFrac (truncate $ a / b :: Integer)
124{-# INLINE fmod #-}
125
126-- | The rule of thumb is you should only use this to construct using values
127-- that you took out of the interval. Otherwise, use I, to force rounding
128(...) :: a -> a -> Interval a
129(...) = I
130{-# INLINE (...) #-}
131
132-- | The whole real number line
133--
134-- >>> whole
135-- -Infinity ... Infinity
136whole :: Fractional a => Interval a
137whole = negInfinity ... posInfinity
138{-# INLINE whole #-}
139
140-- | An empty interval
141--
142-- >>> empty
143-- NaN ... NaN
144empty :: Fractional a => Interval a
145empty = nan ... nan
146{-# INLINE empty #-}
147
148-- | negation handles NaN properly
149--
150-- >>> null (1 ... 5)
151-- False
152--
153-- >>> null (1 ... 1)
154-- False
155--
156-- >>> null empty
157-- True
158null :: Ord a => Interval a -> Bool
159null x = not (inf x <= sup x)
160{-# INLINE null #-}
161
162-- | A singleton point
163--
164-- >>> singleton 1
165-- 1 ... 1
166singleton :: a -> Interval a
167singleton a = a ... a
168{-# INLINE singleton #-}
169
170-- | The infinumum (lower bound) of an interval
171--
172-- >>> inf (1 ... 20)
173-- 1
174inf :: Interval a -> a
175inf (I a _) = a
176{-# INLINE inf #-}
177
178-- | The supremum (upper bound) of an interval
179--
180-- >>> sup (1 ... 20)
181-- 20
182sup :: Interval a -> a
183sup (I _ b) = b
184{-# INLINE sup #-}
185
186-- | Is the interval a singleton point?
187-- N.B. This is fairly fragile and likely will not hold after
188-- even a few operations that only involve singletons
189--
190-- >>> singular (singleton 1)
191-- True
192--
193-- >>> singular (1.0 ... 20.0)
194-- False
195singular :: Ord a => Interval a -> Bool
196singular x = not (null x) && inf x == sup x
197{-# INLINE singular #-}
198
199instance Eq a => Eq (Interval a) where
200 (==) = (==!)
201 {-# INLINE (==) #-}
202
203instance Show a => Show (Interval a) where
204 showsPrec n (I a b) =
205 showParen (n > 3) $
206 showsPrec 3 a .
207 showString " ... " .
208 showsPrec 3 b
209
210-- | Calculate the width of an interval.
211--
212-- >>> width (1 ... 20)
213-- 19
214--
215-- >>> width (singleton 1)
216-- 0
217--
218-- >>> width empty
219-- NaN
220width :: Num a => Interval a -> a
221width (I a b) = b - a
222{-# INLINE width #-}
223
224-- | Magnitude
225--
226-- >>> magnitude (1 ... 20)
227-- 20
228--
229-- >>> magnitude (-20 ... 10)
230-- 20
231--
232-- >>> magnitude (singleton 5)
233-- 5
234magnitude :: (Num a, Ord a) => Interval a -> a
235magnitude x = (max `on` abs) (inf x) (sup x)
236{-# INLINE magnitude #-}
237
238-- | \"mignitude\"
239--
240-- >>> mignitude (1 ... 20)
241-- 1
242--
243-- >>> mignitude (-20 ... 10)
244-- 10
245--
246-- >>> mignitude (singleton 5)
247-- 5
248mignitude :: (Num a, Ord a) => Interval a -> a
249mignitude x = (min `on` abs) (inf x) (sup x)
250{-# INLINE mignitude #-}
251
252instance (Num a, Ord a) => Num (Interval a) where
253 I a b + I a' b' = (a + a') ... (b + b')
254 {-# INLINE (+) #-}
255 I a b - I a' b' = (a - b') ... (b - a')
256 {-# INLINE (-) #-}
257 I a b * I a' b' =
258 minimum [a * a', a * b', b * a', b * b']
259 ...
260 maximum [a * a', a * b', b * a', b * b']
261 {-# INLINE (*) #-}
262 abs x@(I a b)
263 | a >= 0 = x
264 | b <= 0 = negate x
265 | otherwise = 0 ... max (- a) b
266 {-# INLINE abs #-}
267
268 signum = increasing signum
269 {-# INLINE signum #-}
270
271 fromInteger i = singleton (fromInteger i)
272 {-# INLINE fromInteger #-}
273
274-- | Bisect an interval at its midpoint.
275--
276-- >>> bisection (10.0 ... 20.0)
277-- (10.0 ... 15.0,15.0 ... 20.0)
278--
279-- >>> bisection (singleton 5.0)
280-- (5.0 ... 5.0,5.0 ... 5.0)
281--
282-- >>> bisection empty
283-- (NaN ... NaN,NaN ... NaN)
284bisection :: Fractional a => Interval a -> (Interval a, Interval a)
285bisection x = (inf x ... m, m ... sup x)
286 where m = midpoint x
287{-# INLINE bisection #-}
288
289-- | Nearest point to the midpoint of the interval.
290--
291-- >>> midpoint (10.0 ... 20.0)
292-- 15.0
293--
294-- >>> midpoint (singleton 5.0)
295-- 5.0
296--
297-- >>> midpoint empty
298-- NaN
299midpoint :: Fractional a => Interval a -> a
300midpoint x = inf x + (sup x - inf x) / 2
301{-# INLINE midpoint #-}
302
303-- | Determine if a point is in the interval.
304--
305-- >>> elem 3.2 (1.0 ... 5.0)
306-- True
307--
308-- >>> elem 5 (1.0 ... 5.0)
309-- True
310--
311-- >>> elem 1 (1.0 ... 5.0)
312-- True
313--
314-- >>> elem 8 (1.0 ... 5.0)
315-- False
316--
317-- >>> elem 5 empty
318-- False
319--
320elem :: Ord a => a -> Interval a -> Bool
321elem x xs = x >= inf xs && x <= sup xs
322{-# INLINE elem #-}
323
324-- | Determine if a point is not included in the interval
325--
326-- >>> notElem 8 (1.0 ... 5.0)
327-- True
328--
329-- >>> notElem 1.4 (1.0 ... 5.0)
330-- False
331--
332-- And of course, nothing is a member of the empty interval.
333--
334-- >>> notElem 5 empty
335-- True
336notElem :: Ord a => a -> Interval a -> Bool
337notElem x xs = not (elem x xs)
338{-# INLINE notElem #-}
339
340-- | 'realToFrac' will use the midpoint
341instance Real a => Real (Interval a) where
342 toRational x
343 | null x = nan
344 | otherwise = a + (b - a) / 2
345 where
346 a = toRational (inf x)
347 b = toRational (sup x)
348 {-# INLINE toRational #-}
349
350instance Ord a => Ord (Interval a) where
351 compare x y
352 | sup x < inf y = LT
353 | inf x > sup y = GT
354 | sup x == inf y && inf x == sup y = EQ
355 | otherwise = error "Numeric.Interval.compare: ambiguous comparison"
356 {-# INLINE compare #-}
357
358 max (I a b) (I a' b') = max a a' ... max b b'
359 {-# INLINE max #-}
360
361 min (I a b) (I a' b') = min a a' ... min b b'
362 {-# INLINE min #-}
363
364-- @'divNonZero' X Y@ assumes @0 `'notElem'` Y@
365divNonZero :: (Fractional a, Ord a) => Interval a -> Interval a -> Interval a
366divNonZero (I a b) (I a' b') =
367 minimum [a / a', a / b', b / a', b / b']
368 ...
369 maximum [a / a', a / b', b / a', b / b']
370
371-- @'divPositive' X y@ assumes y > 0, and divides @X@ by [0 ... y]
372divPositive :: (Fractional a, Ord a) => Interval a -> a -> Interval a
373divPositive x@(I a b) y
374 | a == 0 && b == 0 = x
375 -- b < 0 || isNegativeZero b = negInfinity ... ( b / y)
376 | b < 0 = negInfinity ... ( b / y)
377 | a < 0 = whole
378 | otherwise = (a / y) ... posInfinity
379{-# INLINE divPositive #-}
380
381-- divNegative assumes y < 0 and divides the interval @X@ by [y ... 0]
382divNegative :: (Fractional a, Ord a) => Interval a -> a -> Interval a
383divNegative x@(I a b) y
384 | a == 0 && b == 0 = - x -- flip negative zeros
385 -- b < 0 || isNegativeZero b = (b / y) ... posInfinity
386 | b < 0 = (b / y) ... posInfinity
387 | a < 0 = whole
388 | otherwise = negInfinity ... (a / y)
389{-# INLINE divNegative #-}
390
391divZero :: (Fractional a, Ord a) => Interval a -> Interval a
392divZero x
393 | inf x == 0 && sup x == 0 = x
394 | otherwise = whole
395{-# INLINE divZero #-}
396
397instance (Fractional a, Ord a) => Fractional (Interval a) where
398 -- TODO: check isNegativeZero properly
399 x / y
400 | 0 `notElem` y = divNonZero x y
401 | iz && sz = empty -- division by 0
402 | iz = divPositive x (inf y)
403 | sz = divNegative x (sup y)
404 | otherwise = divZero x
405 where
406 iz = inf y == 0
407 sz = sup y == 0
408 recip (I a b) = on min recip a b ... on max recip a b
409 {-# INLINE recip #-}
410 fromRational r = let r' = fromRational r in r' ... r'
411 {-# INLINE fromRational #-}
412
413instance RealFrac a => RealFrac (Interval a) where
414 properFraction x = (b, x - fromIntegral b)
415 where
416 b = truncate (midpoint x)
417 {-# INLINE properFraction #-}
418 ceiling x = ceiling (sup x)
419 {-# INLINE ceiling #-}
420 floor x = floor (inf x)
421 {-# INLINE floor #-}
422 round x = round (midpoint x)
423 {-# INLINE round #-}
424 truncate x = truncate (midpoint x)
425 {-# INLINE truncate #-}
426
427instance (RealFloat a, Ord a) => Floating (Interval a) where
428 pi = singleton pi
429 {-# INLINE pi #-}
430 exp = increasing exp
431 {-# INLINE exp #-}
432 log (I a b) = (if a > 0 then log a else negInfinity) ... log b
433 {-# INLINE log #-}
434 cos x
435 | null x = empty
436 | width t >= pi = (-1) ... 1
437 | inf t >= pi = - cos (t - pi)
438 | sup t <= pi = decreasing cos t
439 | sup t <= 2 * pi = (-1) ... cos ((pi * 2 - sup t) `min` inf t)
440 | otherwise = (-1) ... 1
441 where
442 t = fmod x (pi * 2)
443 {-# INLINE cos #-}
444 sin x
445 | null x = empty
446 | otherwise = cos (x - pi / 2)
447 {-# INLINE sin #-}
448 tan x
449 | null x = empty
450 | inf t' <= - pi / 2 || sup t' >= pi / 2 = whole
451 | otherwise = increasing tan x
452 where
453 t = x `fmod` pi
454 t' | t >= pi / 2 = t - pi
455 | otherwise = t
456 {-# INLINE tan #-}
457 asin x@(I a b)
458 | null x || b < -1 || a > 1 = empty
459 | otherwise =
460 (if a <= -1 then -halfPi else asin a)
461 ...
462 (if b >= 1 then halfPi else asin b)
463 where
464 halfPi = pi / 2
465 {-# INLINE asin #-}
466 acos x@(I a b)
467 | null x || b < -1 || a > 1 = empty
468 | otherwise =
469 (if b >= 1 then 0 else acos b)
470 ...
471 (if a < -1 then pi else acos a)
472 {-# INLINE acos #-}
473 atan = increasing atan
474 {-# INLINE atan #-}
475 sinh = increasing sinh
476 {-# INLINE sinh #-}
477 cosh x@(I a b)
478 | null x = empty
479 | b < 0 = decreasing cosh x
480 | a >= 0 = increasing cosh x
481 | otherwise = I 0 $ cosh $ if - a > b
482 then a
483 else b
484 {-# INLINE cosh #-}
485 tanh = increasing tanh
486 {-# INLINE tanh #-}
487 asinh = increasing asinh
488 {-# INLINE asinh #-}
489 acosh x@(I a b)
490 | null x || b < 1 = empty
491 | otherwise = I lo $ acosh b
492 where lo | a <= 1 = 0
493 | otherwise = acosh a
494 {-# INLINE acosh #-}
495 atanh x@(I a b)
496 | null x || b < -1 || a > 1 = empty
497 | otherwise =
498 (if a <= - 1 then negInfinity else atanh a)
499 ...
500 (if b >= 1 then posInfinity else atanh b)
501 {-# INLINE atanh #-}
502
503-- | lift a monotone increasing function over a given interval
504increasing :: (a -> b) -> Interval a -> Interval b
505increasing f (I a b) = f a ... f b
506
507-- | lift a monotone decreasing function over a given interval
508decreasing :: (a -> b) -> Interval a -> Interval b
509decreasing f (I a b) = f b ... f a
510
511-- | We have to play some semantic games to make these methods make sense.
512-- Most compute with the midpoint of the interval.
513instance RealFloat a => RealFloat (Interval a) where
514 floatRadix = floatRadix . midpoint
515
516 floatDigits = floatDigits . midpoint
517 floatRange = floatRange . midpoint
518 decodeFloat = decodeFloat . midpoint
519 encodeFloat m e = singleton (encodeFloat m e)
520 exponent = exponent . midpoint
521 significand x = min a b ... max a b
522 where
523 (_ ,em) = decodeFloat (midpoint x)
524 (mi,ei) = decodeFloat (inf x)
525 (ms,es) = decodeFloat (sup x)
526 a = encodeFloat mi (ei - em - floatDigits x)
527 b = encodeFloat ms (es - em - floatDigits x)
528 scaleFloat n x = scaleFloat n (inf x) ... scaleFloat n (sup x)
529 isNaN x = isNaN (inf x) || isNaN (sup x)
530 isInfinite x = isInfinite (inf x) || isInfinite (sup x)
531 isDenormalized x = isDenormalized (inf x) || isDenormalized (sup x)
532 -- contains negative zero
533 isNegativeZero x = not (inf x > 0)
534 && not (sup x < 0)
535 && ( (sup x == 0 && (inf x < 0 || isNegativeZero (inf x)))
536 || (inf x == 0 && isNegativeZero (inf x))
537 || (inf x < 0 && sup x >= 0))
538 isIEEE x = isIEEE (inf x) && isIEEE (sup x)
539 atan2 = error "unimplemented"
540
541-- TODO: (^), (^^) to give tighter bounds
542
543-- | Calculate the intersection of two intervals.
544--
545-- >>> intersection (1 ... 10 :: Interval Double) (5 ... 15 :: Interval Double)
546-- 5.0 ... 10.0
547intersection :: (Fractional a, Ord a) => Interval a -> Interval a -> Interval a
548intersection x@(I a b) y@(I a' b')
549 | x /=! y = empty
550 | otherwise = max a a' ... min b b'
551{-# INLINE intersection #-}
552
553-- | Calculate the convex hull of two intervals
554--
555-- >>> hull (0 ... 10 :: Interval Double) (5 ... 15 :: Interval Double)
556-- 0.0 ... 15.0
557--
558-- >>> hull (15 ... 85 :: Interval Double) (0 ... 10 :: Interval Double)
559-- 0.0 ... 85.0
560hull :: Ord a => Interval a -> Interval a -> Interval a
561hull x@(I a b) y@(I a' b')
562 | null x = y
563 | null y = x
564 | otherwise = min a a' ... max b b'
565{-# INLINE hull #-}
566
567-- | For all @x@ in @X@, @y@ in @Y@. @x '<' y@
568--
569-- >>> (5 ... 10 :: Interval Double) <! (20 ... 30 :: Interval Double)
570-- True
571--
572-- >>> (5 ... 10 :: Interval Double) <! (10 ... 30 :: Interval Double)
573-- False
574--
575-- >>> (20 ... 30 :: Interval Double) <! (5 ... 10 :: Interval Double)
576-- False
577(<!) :: Ord a => Interval a -> Interval a -> Bool
578x <! y = sup x < inf y
579{-# INLINE (<!) #-}
580
581-- | For all @x@ in @X@, @y@ in @Y@. @x '<=' y@
582--
583-- >>> (5 ... 10 :: Interval Double) <=! (20 ... 30 :: Interval Double)
584-- True
585--
586-- >>> (5 ... 10 :: Interval Double) <=! (10 ... 30 :: Interval Double)
587-- True
588--
589-- >>> (20 ... 30 :: Interval Double) <=! (5 ... 10 :: Interval Double)
590-- False
591(<=!) :: Ord a => Interval a -> Interval a -> Bool
592x <=! y = sup x <= inf y
593{-# INLINE (<=!) #-}
594
595-- | For all @x@ in @X@, @y@ in @Y@. @x '==' y@
596--
597-- Only singleton intervals return true
598--
599-- >>> (singleton 5 :: Interval Double) ==! (singleton 5 :: Interval Double)
600-- True
601--
602-- >>> (5 ... 10 :: Interval Double) ==! (5 ... 10 :: Interval Double)
603-- False
604(==!) :: Eq a => Interval a -> Interval a -> Bool
605x ==! y = sup x == inf y && inf x == sup y
606{-# INLINE (==!) #-}
607
608-- | For all @x@ in @X@, @y@ in @Y@. @x '/=' y@
609--
610-- >>> (5 ... 15 :: Interval Double) /=! (20 ... 40 :: Interval Double)
611-- True
612--
613-- >>> (5 ... 15 :: Interval Double) /=! (15 ... 40 :: Interval Double)
614-- False
615(/=!) :: Ord a => Interval a -> Interval a -> Bool
616x /=! y = sup x < inf y || inf x > sup y
617{-# INLINE (/=!) #-}
618
619-- | For all @x@ in @X@, @y@ in @Y@. @x '>' y@
620--
621-- >>> (20 ... 40 :: Interval Double) >! (10 ... 19 :: Interval Double)
622-- True
623--
624-- >>> (5 ... 20 :: Interval Double) >! (15 ... 40 :: Interval Double)
625-- False
626(>!) :: Ord a => Interval a -> Interval a -> Bool
627x >! y = inf x > sup y
628{-# INLINE (>!) #-}
629
630-- | For all @x@ in @X@, @y@ in @Y@. @x '>=' y@
631--
632-- >>> (20 ... 40 :: Interval Double) >=! (10 ... 20 :: Interval Double)
633-- True
634--
635-- >>> (5 ... 20 :: Interval Double) >=! (15 ... 40 :: Interval Double)
636-- False
637(>=!) :: Ord a => Interval a -> Interval a -> Bool
638x >=! y = inf x >= sup y
639{-# INLINE (>=!) #-}
640
641-- | For all @x@ in @X@, @y@ in @Y@. @x `op` y@
642--
643--
644certainly :: Ord a => (forall b. Ord b => b -> b -> Bool) -> Interval a -> Interval a -> Bool
645certainly cmp l r
646 | lt && eq && gt = True
647 | lt && eq = l <=! r
648 | lt && gt = l /=! r
649 | lt = l <! r
650 | eq && gt = l >=! r
651 | eq = l ==! r
652 | gt = l >! r
653 | otherwise = False
654 where
655 lt = cmp LT EQ
656 eq = cmp EQ EQ
657 gt = cmp GT EQ
658{-# INLINE certainly #-}
659
660-- | Check if interval @X@ totally contains interval @Y@
661--
662-- >>> (20 ... 40 :: Interval Double) `contains` (25 ... 35 :: Interval Double)
663-- True
664--
665-- >>> (20 ... 40 :: Interval Double) `contains` (15 ... 35 :: Interval Double)
666-- False
667contains :: Ord a => Interval a -> Interval a -> Bool
668contains x y = null y
669 || (not (null x) && inf x <= inf y && sup y <= sup x)
670{-# INLINE contains #-}
671
672-- | Flipped version of `contains`. Check if interval @X@ a subset of interval @Y@
673--
674-- >>> (25 ... 35 :: Interval Double) `isSubsetOf` (20 ... 40 :: Interval Double)
675-- True
676--
677-- >>> (20 ... 40 :: Interval Double) `isSubsetOf` (15 ... 35 :: Interval Double)
678-- False
679isSubsetOf :: Ord a => Interval a -> Interval a -> Bool
680isSubsetOf = flip contains
681{-# INLINE isSubsetOf #-}
682
683-- | Does there exist an @x@ in @X@, @y@ in @Y@ such that @x '<' y@?
684(<?) :: Ord a => Interval a -> Interval a -> Bool
685x <? y = inf x < sup y
686{-# INLINE (<?) #-}
687
688-- | Does there exist an @x@ in @X@, @y@ in @Y@ such that @x '<=' y@?
689(<=?) :: Ord a => Interval a -> Interval a -> Bool
690x <=? y = inf x <= sup y
691{-# INLINE (<=?) #-}
692
693-- | Does there exist an @x@ in @X@, @y@ in @Y@ such that @x '==' y@?
694(==?) :: Ord a => Interval a -> Interval a -> Bool
695x ==? y = inf x <= sup y && sup x >= inf y
696{-# INLINE (==?) #-}
697
698-- | Does there exist an @x@ in @X@, @y@ in @Y@ such that @x '/=' y@?
699(/=?) :: Eq a => Interval a -> Interval a -> Bool
700x /=? y = inf x /= sup y || sup x /= inf y
701{-# INLINE (/=?) #-}
702
703-- | Does there exist an @x@ in @X@, @y@ in @Y@ such that @x '>' y@?
704(>?) :: Ord a => Interval a -> Interval a -> Bool
705x >? y = sup x > inf y
706{-# INLINE (>?) #-}
707
708-- | Does there exist an @x@ in @X@, @y@ in @Y@ such that @x '>=' y@?
709(>=?) :: Ord a => Interval a -> Interval a -> Bool
710x >=? y = sup x >= inf y
711{-# INLINE (>=?) #-}
712
713-- | Does there exist an @x@ in @X@, @y@ in @Y@ such that @x `op` y@?
714possibly :: Ord a => (forall b. Ord b => b -> b -> Bool) -> Interval a -> Interval a -> Bool
715possibly cmp l r
716 | lt && eq && gt = True
717 | lt && eq = l <=? r
718 | lt && gt = l /=? r
719 | lt = l <? r
720 | eq && gt = l >=? r
721 | eq = l ==? r
722 | gt = l >? r
723 | otherwise = False
724 where
725 lt = cmp LT EQ
726 eq = cmp EQ EQ
727 gt = cmp GT EQ
728{-# INLINE possibly #-}
729
730-- | The nearest value to that supplied which is contained in the interval.
731clamp :: Ord a => Interval a -> a -> a
732clamp (I a b) x | x < a = a
733 | x > b = b
734 | otherwise = x
735
736-- | id function. Useful for type specification
737--
738-- >>> :t idouble (1 ... 3)
739-- idouble (1 ... 3) :: Interval Double
740idouble :: Interval Double -> Interval Double
741idouble = id
742
743-- | id function. Useful for type specification
744--
745-- >>> :t ifloat (1 ... 3)
746-- ifloat (1 ... 3) :: Interval Float
747ifloat :: Interval Float -> Interval Float
748ifloat = id
749
750-- Bugs:
751-- sin 1 :: Interval Double
752
753
754default (Integer,Double)
diff --git a/lib/Numeric/Interval/Bounded.hs b/lib/Numeric/Interval/Bounded.hs
new file mode 100644
index 0000000..2dd4d7b
--- /dev/null
+++ b/lib/Numeric/Interval/Bounded.hs
@@ -0,0 +1,9 @@
1module Numeric.Interval.Bounded where
2
3import Numeric.Interval
4
5whole' :: Bounded a => Interval a
6whole' = ( minBound ... maxBound )
7
8empty' :: Bounded a => Interval a
9empty' = ( maxBound ... minBound )
diff --git a/lib/SuperOrd.hs b/lib/SuperOrd.hs
new file mode 100644
index 0000000..258a823
--- /dev/null
+++ b/lib/SuperOrd.hs
@@ -0,0 +1,23 @@
1module SuperOrd where
2
3data SuperOrd a
4 = NegativeInfinity
5 | SuperOrd { superApprox :: !a
6 , superCompareApprox :: !Ordering
7 }
8 | PositiveInfinity
9 deriving (Eq, Ord, Show)
10
11instance Bounded (SuperOrd a) where
12 minBound = NegativeInfinity
13 maxBound = PositiveInfinity
14
15exactly :: a -> SuperOrd a
16exactly a = SuperOrd a EQ
17
18lessThan :: a -> SuperOrd a
19lessThan a = SuperOrd a LT
20
21greaterThan :: a -> SuperOrd a
22greaterThan a = SuperOrd a GT
23