GraphHammer (empty) → 0.3
raw patch · 9 files changed
+4832/−0 lines, 9 filesdep +Graph500dep +arraydep +basesetup-changed
Dependencies added: Graph500, array, base, containers, mtl, stm, time
Files
- GraphHammer.cabal +40/−0
- LICENSE +340/−0
- Setup.hs +2/−0
- src/GraphHammer.hs +17/−0
- src/GraphHammer/HList.hs +67/−0
- src/GraphHammer/Info.hs +74/−0
- src/GraphHammer/IntMap.hs +1841/−0
- src/GraphHammer/IntSet.hs +1102/−0
- src/GraphHammer/SimplestParallel.hs +1349/−0
+ GraphHammer.cabal view
@@ -0,0 +1,40 @@+Name: GraphHammer+Version: 0.3+Synopsis: GraphHammer Haskell graph analyses framework inspired by STINGER.+Description:+ GraphHammer is a graph analyses framework. See+ "GraphHammer.SimplestParallel" for library documentation. Examples+ exists in GraphHammer-examples package: see+ "GraphHammer.VertexDegree", "GraphHammer.TriangleCount",+ "GraphHammer.ClusteringCoefficients" for examples.+License: GPL-2+License-file: LICENSE+Author: serguey.zefirov@parsci.com+Maintainer: alexander.vershilov@parsci.com+Copyright: 2013, Parallel Scientific Labs, LLC+Category: Concurrency+Build-type: Simple+-- Extra-source-files:+Cabal-version: >=1.6+++Library+ hs-source-dirs: src+ Exposed-modules: GraphHammer+ GraphHammer.Info+ GraphHammer.HList+ GraphHammer.SimplestParallel+ Other-modules: GraphHammer.IntSet+ GraphHammer.IntMap+ Build-depends: base >= 3.0 && < 5.0,+ containers >= 0.3,+ mtl >= 1.1,+ array >= 0.3,+ stm >= 2.1 && < 3,+ time >= 1.4,+ Graph500 >= 0.3+ ghc-options: -O3 -Wall++source-repository head+ type: git+ location: git://github.com/ps-labs/GraphHammer.git
+ LICENSE view
@@ -0,0 +1,340 @@+ GNU GENERAL PUBLIC LICENSE+ Version 2, June 1991++ Copyright (C) 1989, 1991 Free Software Foundation, Inc.+ 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA+ Everyone is permitted to copy and distribute verbatim copies+ of this license document, but changing it is not allowed.++ Preamble++ The licenses for most software are designed to take away your+freedom to share and change it. By contrast, the GNU General Public+License is intended to guarantee your freedom to share and change free+software--to make sure the software is free for all its users. This+General Public License applies to most of the Free Software+Foundation's software and to any other program whose authors commit to+using it. (Some other Free Software Foundation software is covered by+the GNU Library General Public License instead.) You can apply it to+your programs, too.++ When we speak of free software, we are referring to freedom, not+price. Our General Public Licenses are designed to make sure that you+have the freedom to distribute copies of free software (and charge for+this service if you wish), that you receive source code or can get it+if you want it, that you can change the software or use pieces of it+in new free programs; and that you know you can do these things.++ To protect your rights, we need to make restrictions that forbid+anyone to deny you these rights or to ask you to surrender the rights.+These restrictions translate to certain responsibilities for you if you+distribute copies of the software, or if you modify it.++ For example, if you distribute copies of such a program, whether+gratis or for a fee, you must give the recipients all the rights that+you have. You must make sure that they, too, receive or can get the+source code. And you must show them these terms so they know their+rights.++ We protect your rights with two steps: (1) copyright the software, and+(2) offer you this license which gives you legal permission to copy,+distribute and/or modify the software.++ Also, for each author's protection and ours, we want to make certain+that everyone understands that there is no warranty for this free+software. If the software is modified by someone else and passed on, we+want its recipients to know that what they have is not the original, so+that any problems introduced by others will not reflect on the original+authors' reputations.++ Finally, any free program is threatened constantly by software+patents. We wish to avoid the danger that redistributors of a free+program will individually obtain patent licenses, in effect making the+program proprietary. To prevent this, we have made it clear that any+patent must be licensed for everyone's free use or not licensed at all.++ The precise terms and conditions for copying, distribution and+modification follow.++ GNU GENERAL PUBLIC LICENSE+ TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION++ 0. This License applies to any program or other work which contains+a notice placed by the copyright holder saying it may be distributed+under the terms of this General Public License. The "Program", below,+refers to any such program or work, and a "work based on the Program"+means either the Program or any derivative work under copyright law:+that is to say, a work containing the Program or a portion of it,+either verbatim or with modifications and/or translated into another+language. (Hereinafter, translation is included without limitation in+the term "modification".) Each licensee is addressed as "you".++Activities other than copying, distribution and modification are not+covered by this License; they are outside its scope. The act of+running the Program is not restricted, and the output from the Program+is covered only if its contents constitute a work based on the+Program (independent of having been made by running the Program).+Whether that is true depends on what the Program does.++ 1. You may copy and distribute verbatim copies of the Program's+source code as you receive it, in any medium, provided that you+conspicuously and appropriately publish on each copy an appropriate+copyright notice and disclaimer of warranty; keep intact all the+notices that refer to this License and to the absence of any warranty;+and give any other recipients of the Program a copy of this License+along with the Program.++You may charge a fee for the physical act of transferring a copy, and+you may at your option offer warranty protection in exchange for a fee.++ 2. You may modify your copy or copies of the Program or any portion+of it, thus forming a work based on the Program, and copy and+distribute such modifications or work under the terms of Section 1+above, provided that you also meet all of these conditions:++ a) You must cause the modified files to carry prominent notices+ stating that you changed the files and the date of any change.++ b) You must cause any work that you distribute or publish, that in+ whole or in part contains or is derived from the Program or any+ part thereof, to be licensed as a whole at no charge to all third+ parties under the terms of this License.++ c) If the modified program normally reads commands interactively+ when run, you must cause it, when started running for such+ interactive use in the most ordinary way, to print or display an+ announcement including an appropriate copyright notice and a+ notice that there is no warranty (or else, saying that you provide+ a warranty) and that users may redistribute the program under+ these conditions, and telling the user how to view a copy of this+ License. (Exception: if the Program itself is interactive but+ does not normally print such an announcement, your work based on+ the Program is not required to print an announcement.)++These requirements apply to the modified work as a whole. If+identifiable sections of that work are not derived from the Program,+and can be reasonably considered independent and separate works in+themselves, then this License, and its terms, do not apply to those+sections when you distribute them as separate works. But when you+distribute the same sections as part of a whole which is a work based+on the Program, the distribution of the whole must be on the terms of+this License, whose permissions for other licensees extend to the+entire whole, and thus to each and every part regardless of who wrote it.++Thus, it is not the intent of this section to claim rights or contest+your rights to work written entirely by you; rather, the intent is to+exercise the right to control the distribution of derivative or+collective works based on the Program.++In addition, mere aggregation of another work not based on the Program+with the Program (or with a work based on the Program) on a volume of+a storage or distribution medium does not bring the other work under+the scope of this License.++ 3. You may copy and distribute the Program (or a work based on it,+under Section 2) in object code or executable form under the terms of+Sections 1 and 2 above provided that you also do one of the following:++ a) Accompany it with the complete corresponding machine-readable+ source code, which must be distributed under the terms of Sections+ 1 and 2 above on a medium customarily used for software interchange; or,++ b) Accompany it with a written offer, valid for at least three+ years, to give any third party, for a charge no more than your+ cost of physically performing source distribution, a complete+ machine-readable copy of the corresponding source code, to be+ distributed under the terms of Sections 1 and 2 above on a medium+ customarily used for software interchange; or,++ c) Accompany it with the information you received as to the offer+ to distribute corresponding source code. (This alternative is+ allowed only for noncommercial distribution and only if you+ received the program in object code or executable form with such+ an offer, in accord with Subsection b above.)++The source code for a work means the preferred form of the work for+making modifications to it. For an executable work, complete source+code means all the source code for all modules it contains, plus any+associated interface definition files, plus the scripts used to+control compilation and installation of the executable. However, as a+special exception, the source code distributed need not include+anything that is normally distributed (in either source or binary+form) with the major components (compiler, kernel, and so on) of the+operating system on which the executable runs, unless that component+itself accompanies the executable.++If distribution of executable or object code is made by offering+access to copy from a designated place, then offering equivalent+access to copy the source code from the same place counts as+distribution of the source code, even though third parties are not+compelled to copy the source along with the object code.++ 4. You may not copy, modify, sublicense, or distribute the Program+except as expressly provided under this License. Any attempt+otherwise to copy, modify, sublicense or distribute the Program is+void, and will automatically terminate your rights under this License.+However, parties who have received copies, or rights, from you under+this License will not have their licenses terminated so long as such+parties remain in full compliance.++ 5. You are not required to accept this License, since you have not+signed it. However, nothing else grants you permission to modify or+distribute the Program or its derivative works. These actions are+prohibited by law if you do not accept this License. Therefore, by+modifying or distributing the Program (or any work based on the+Program), you indicate your acceptance of this License to do so, and+all its terms and conditions for copying, distributing or modifying+the Program or works based on it.++ 6. Each time you redistribute the Program (or any work based on the+Program), the recipient automatically receives a license from the+original licensor to copy, distribute or modify the Program subject to+these terms and conditions. You may not impose any further+restrictions on the recipients' exercise of the rights granted herein.+You are not responsible for enforcing compliance by third parties to+this License.++ 7. If, as a consequence of a court judgment or allegation of patent+infringement or for any other reason (not limited to patent issues),+conditions are imposed on you (whether by court order, agreement or+otherwise) that contradict the conditions of this License, they do not+excuse you from the conditions of this License. If you cannot+distribute so as to satisfy simultaneously your obligations under this+License and any other pertinent obligations, then as a consequence you+may not distribute the Program at all. For example, if a patent+license would not permit royalty-free redistribution of the Program by+all those who receive copies directly or indirectly through you, then+the only way you could satisfy both it and this License would be to+refrain entirely from distribution of the Program.++If any portion of this section is held invalid or unenforceable under+any particular circumstance, the balance of the section is intended to+apply and the section as a whole is intended to apply in other+circumstances.++It is not the purpose of this section to induce you to infringe any+patents or other property right claims or to contest validity of any+such claims; this section has the sole purpose of protecting the+integrity of the free software distribution system, which is+implemented by public license practices. Many people have made+generous contributions to the wide range of software distributed+through that system in reliance on consistent application of that+system; it is up to the author/donor to decide if he or she is willing+to distribute software through any other system and a licensee cannot+impose that choice.++This section is intended to make thoroughly clear what is believed to+be a consequence of the rest of this License.++ 8. If the distribution and/or use of the Program is restricted in+certain countries either by patents or by copyrighted interfaces, the+original copyright holder who places the Program under this License+may add an explicit geographical distribution limitation excluding+those countries, so that distribution is permitted only in or among+countries not thus excluded. In such case, this License incorporates+the limitation as if written in the body of this License.++ 9. The Free Software Foundation may publish revised and/or new versions+of the General Public License from time to time. Such new versions will+be similar in spirit to the present version, but may differ in detail to+address new problems or concerns.++Each version is given a distinguishing version number. If the Program+specifies a version number of this License which applies to it and "any+later version", you have the option of following the terms and conditions+either of that version or of any later version published by the Free+Software Foundation. If the Program does not specify a version number of+this License, you may choose any version ever published by the Free Software+Foundation.++ 10. If you wish to incorporate parts of the Program into other free+programs whose distribution conditions are different, write to the author+to ask for permission. For software which is copyrighted by the Free+Software Foundation, write to the Free Software Foundation; we sometimes+make exceptions for this. Our decision will be guided by the two goals+of preserving the free status of all derivatives of our free software and+of promoting the sharing and reuse of software generally.++ NO WARRANTY++ 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY+FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN+OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES+PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED+OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF+MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS+TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE+PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING,+REPAIR OR CORRECTION.++ 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING+WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR+REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES,+INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING+OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED+TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY+YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER+PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE+POSSIBILITY OF SUCH DAMAGES.++ END OF TERMS AND CONDITIONS++ How to Apply These Terms to Your New Programs++ If you develop a new program, and you want it to be of the greatest+possible use to the public, the best way to achieve this is to make it+free software which everyone can redistribute and change under these terms.++ To do so, attach the following notices to the program. It is safest+to attach them to the start of each source file to most effectively+convey the exclusion of warranty; and each file should have at least+the "copyright" line and a pointer to where the full notice is found.++ <one line to give the program's name and a brief idea of what it does.>+ Copyright (C) <year> <name of author>++ This program is free software; you can redistribute it and/or modify+ it under the terms of the GNU General Public License as published by+ the Free Software Foundation; either version 2 of the License, or+ (at your option) any later version.++ This program is distributed in the hope that it will be useful,+ but WITHOUT ANY WARRANTY; without even the implied warranty of+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+ GNU General Public License for more details.++ You should have received a copy of the GNU General Public License+ along with this program; if not, write to the Free Software+ Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA+++Also add information on how to contact you by electronic and paper mail.++If the program is interactive, make it output a short notice like this+when it starts in an interactive mode:++ Gnomovision version 69, Copyright (C) year name of author+ Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'.+ This is free software, and you are welcome to redistribute it+ under certain conditions; type `show c' for details.++The hypothetical commands `show w' and `show c' should show the appropriate+parts of the General Public License. Of course, the commands you use may+be called something other than `show w' and `show c'; they could even be+mouse-clicks or menu items--whatever suits your program.++You should also get your employer (if you work as a programmer) or your+school, if any, to sign a "copyright disclaimer" for the program, if+necessary. Here is a sample; alter the names:++ Yoyodyne, Inc., hereby disclaims all copyright interest in the program+ `Gnomovision' (which makes passes at compilers) written by James Hacker.++ <signature of Ty Coon>, 1 April 1989+ Ty Coon, President of Vice++This General Public License does not permit incorporating your program into+proprietary programs. If your program is a subroutine library, you may+consider it more useful to permit linking proprietary applications with the+library. If this is what you want to do, use the GNU Library General+Public License instead of this License.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ src/GraphHammer.hs view
@@ -0,0 +1,17 @@+-- | +-- Module : GraphHammer.hs+-- Copyright : (C) 2013 Parallel Scientific Labs, LLC.+-- License : GPLv2+--+-- Top level module for GraphHammer library+module GraphHammer(+ module GraphHammer.Info+ -- Selecting implementation to export.+ , module GraphHammer.SimplestParallel+ ) where++-- Information storage and retrieval.+import GraphHammer.Info++-- Prototype implementation.+import GraphHammer.SimplestParallel
+ src/GraphHammer/HList.hs view
@@ -0,0 +1,67 @@+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE IncoherentInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++-- |+-- Module : GraphHammer.HList+-- Copyright : (C) 2013 Parallel Scientific Labs, LLC.+-- License : GPLv2+--+-- Homebrew HList.+module GraphHammer.HList where++data Nil++infixr 5 :.+data a :. b++hHead :: a :. as -> a+hHead = undefined++hTail :: a :. as -> as+hTail = undefined++data FALSE+data TRUE++class FAIL a -- no instances!++class TyCast a b | a -> b, b -> a+instance TyCast a a++class TyOr x y r | x y -> r+instance TyOr TRUE TRUE TRUE+instance TyOr TRUE FALSE TRUE+instance TyOr FALSE TRUE TRUE+instance TyOr FALSE FALSE FALSE++class TyEq b x y | x y -> b+instance TyEq FALSE x y+instance TyCast TRUE b => TyEq b x x++-- type-level arithmetic.+data Z+data S n++class Nat a where+ natural :: a -> Int++instance Nat Z where+ natural = const 0++fromSucc :: S n -> n+fromSucc = undefined++instance Nat n => Nat (S n) where+ natural = (1+) . natural . fromSucc++class HLength a where+ hLength :: a -> Int+instance HLength Nil where hLength = const 0+instance HLength as => HLength (a :. as) where hLength list = 1 + hLength (hTail list)
+ src/GraphHammer/Info.hs view
@@ -0,0 +1,74 @@+-- |+-- Module : GraphHammer.Info+-- Copyright : (C) 2013 Parallel Scientific Labs, LLC.+-- License : GPLv2+--+-- Defines a classes to store and read info for GraphHammer edges and vertices+-- information.+--+-- Also defines instances of those classes for unit (). It is meant as a safe+-- way to say "no useful information". Its use as an info should not incur any+-- cost.++{-# LANGUAGE GADTs #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeSynonymInstances #-}++module GraphHammer.Info(+ Info(..)+ , InfoArray(..)+ ) where++import Data.Array++import G500.Index++-------------------------------------------------------------------------------+-- Classes for information storage.++-- |A class to store information.+class Info a where+ -- |A type we encode our values to.+ type EncodingType a++ -- |A method to encode value.+ encodeInfo :: a -> EncodingType a++ -- |Decoding process.+ decodeInfo :: EncodingType a -> a++-- |A class that defines "array interface" for GraphHammer information.+class (Num i, Ix i, Info a) => InfoArray i a where+ -- |A type for arrays with specified index.+ type EncodedInfoArray i a++ -- |Create an array.+ -- First parameter is a length of array.+ newEncodedInfoArray :: Monad m => a -> i -> m (EncodedInfoArray i a)++ -- |Get a value from array.+ readEncodedInfo :: Monad m => EncodedInfoArray i a -> i -> m a++ -- |Store an encoded value.+ storeEncodedInfo :: Monad m => EncodedInfoArray i a -> i -> a -> m ()++-------------------------------------------------------------------------------+-- Instances for () type.++instance Info () where+ type EncodingType () = ()+ encodeInfo = const ()+ decodeInfo = const ()++instance InfoArray Index () where+ type EncodedInfoArray Index () = ()+ newEncodedInfoArray _ _ = return ()+ readEncodedInfo _ _ = return ()+ storeEncodedInfo _ _ _ = return ()++instance InfoArray Int () where+ type EncodedInfoArray Int () = ()+ newEncodedInfoArray _ _ = return ()+ readEncodedInfo _ _ = return ()+ storeEncodedInfo _ _ _ = return ()
+ src/GraphHammer/IntMap.hs view
@@ -0,0 +1,1841 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE MagicHash #-}+{-# OPTIONS_GHC -cpp -XNoBangPatterns -XScopedTypeVariables #-}+{-# LANGUAGE CPP #-}++-- License: The Glasgow Haskell Compiler License+--+-- Redistribution and use in source and binary forms, with or without+-- modification, are permitted provided that the following conditions are met:+--+-- - Redistributions of source code must retain the above copyright notice,+-- this list of conditions and the following disclaimer.+--+-- - Redistributions in binary form must reproduce the above copyright notice,+-- this list of conditions and the following disclaimer in the documentation+-- and/or other materials provided with the distribution.+--+-- - Neither name of the University nor the names of its contributors may be+-- used to endorse or promote products derived from this software without+-- specific prior written permission.+--+-- THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF+-- GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,+-- INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND+-- FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE+-- UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE+-- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR+-- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER+-- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT+-- LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY+-- OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH+-- DAMAGE.++-----------------------------------------------------------------------------+-- |+-- Module : Data.IntMap+-- Copyright : (c) Daan Leijen 2002+-- (c) Andriy Palamarchuk 2008+-- License : BSD-style+-- Maintainer : libraries@haskell.org+-- Stability : provisional+-- Portability : portable+--+-- An efficient implementation of maps from integer keys to values.+--+-- Since many function names (but not the type name) clash with+-- "Prelude" names, this module is usually imported @qualified@, e.g.+--+-- > import Data.IntMap (IntMap)+-- > import qualified Data.IntMap as IntMap+--+-- The implementation is based on /big-endian patricia trees/. This data+-- structure performs especially well on binary operations like 'union'+-- and 'intersection'. However, my benchmarks show that it is also+-- (much) faster on insertions and deletions when compared to a generic+-- size-balanced map implementation (see "Data.Map").+--+-- * Chris Okasaki and Andy Gill, \"/Fast Mergeable Integer Maps/\",+-- Workshop on ML, September 1998, pages 77-86,+-- <http://citeseer.ist.psu.edu/okasaki98fast.html>+--+-- * D.R. Morrison, \"/PATRICIA -- Practical Algorithm To Retrieve+-- Information Coded In Alphanumeric/\", Journal of the ACM, 15(4),+-- October 1968, pages 514-534.+--+-- Operation comments contain the operation time complexity in+-- the Big-O notation <http://en.wikipedia.org/wiki/Big_O_notation>.+-- Many operations have a worst-case complexity of /O(min(n,W))/.+-- This means that the operation can become linear in the number of+-- elements with a maximum of /W/ -- the number of bits in an 'Int'+-- (32 or 64).+-----------------------------------------------------------------------------++module GraphHammer.IntMap (+ -- * Map type+ IntMap, Key -- instance Eq,Show++ -- * Operators+ , (!), (\\)++ -- * Query+ , null+ , size+ , member+ , notMember+ , lookup+ , findWithDefault++ -- * Construction+ , empty+ , singleton++ -- ** Insertion+ , insert+ , insertWith, insertWithKey, insertLookupWithKey++ -- ** Delete\/Update+ , delete+ , adjust+ , adjustWithKey+ , update+ , updateWithKey+ , updateLookupWithKey+ , alter++ -- * Combine++ -- ** Union+ , union+ , unionWith+ , unionWithKey+ , unions+ , unionsWith++ -- ** Difference+ , difference+ , differenceWith+ , differenceWithKey++ -- ** Intersection+ , intersection+ , intersectionWith+ , intersectionWithKey++ -- * Traversal+ -- ** Map+ , map+ , mapWithKey+ , mapAccum+ , mapAccumWithKey+ , mapAccumRWithKey++ -- ** Fold+ , fold+ , foldWithKey++ -- * Conversion+ , elems+ , keys+ , keysSet+ , assocs++ -- ** Lists+ , toList+ , fromList+ , fromListWith+ , fromListWithKey++ -- ** Ordered lists+ , toAscList+ , fromAscList+ , fromAscListWith+ , fromAscListWithKey+ , fromDistinctAscList++ -- * Filter+ , filter+ , filterWithKey+ , partition+ , partitionWithKey++ , mapMaybe+ , mapMaybeWithKey+ , mapEither+ , mapEitherWithKey++ , split+ , splitLookup++ -- * Submap+ , isSubmapOf, isSubmapOfBy+ , isProperSubmapOf, isProperSubmapOfBy++ -- * Min\/Max++ , maxView+ , minView+ , findMin+ , findMax+ , deleteMin+ , deleteMax+ , deleteFindMin+ , deleteFindMax+ , updateMin+ , updateMax+ , updateMinWithKey+ , updateMaxWithKey+ , minViewWithKey+ , maxViewWithKey++ -- * Debugging+ , showTree+ , showTreeWith++ -- extras for GraphHammer.+ , unionWithSetValue+ , mapFromSetValue+ ) where+++import Prelude hiding (lookup,map,filter,foldr,foldl,null)+import Data.Bits+import qualified GraphHammer.IntSet as IntSet+import Data.Monoid (Monoid(..))+import Data.Maybe (fromMaybe)+import Data.Foldable (Foldable(foldMap))+import Data.Traversable (Traversable(traverse))+import Control.Applicative (Applicative(pure,(<*>)),(<$>))+import Control.Monad ( liftM )+import Data.Int+import Data.Word+{-+-- just for testing+import qualified Prelude+import Test.QuickCheck+import List (nub,sort)+import qualified List+-}++import Text.Read++infixl 9 \\{-This comment teaches CPP correct behaviour -}++-- A "Nat" is a natural machine word (an unsigned Int)+type Nat = Word++natFromInt :: Key -> Nat+natFromInt = fromIntegral++intFromNat :: Nat -> Key+intFromNat = fromIntegral++shiftRL :: Nat -> Int -> Nat+shiftRL x i = shiftR x i++{--------------------------------------------------------------------+ Operators+--------------------------------------------------------------------}++-- | /O(min(n,W))/. Find the value at a key.+-- Calls 'error' when the element can not be found.+--+-- > fromList [(5,'a'), (3,'b')] ! 1 Error: element not in the map+-- > fromList [(5,'a'), (3,'b')] ! 5 == 'a'++(!) :: IntMap a -> Key -> a+m ! k = find' k m++-- | Same as 'difference'.+(\\) :: IntMap a -> IntMap b -> IntMap a+m1 \\ m2 = difference m1 m2++{--------------------------------------------------------------------+ Types+--------------------------------------------------------------------}+-- | A strict map of integers to values @a@.+data IntMap a = Nil+ | Tip {-# UNPACK #-} !Key !a+ | Bin {-# UNPACK #-} !Prefix {-# UNPACK #-} !Mask !(IntMap a) !(IntMap a)++type Prefix = Int32+type Mask = Int32+type Key = Int32++instance Monoid (IntMap a) where+ mempty = empty+ mappend = union+ mconcat = unions++instance Foldable IntMap where+ foldMap _ Nil = mempty+ foldMap f (Tip _k v) = f v+ foldMap f (Bin _ _ l r) = foldMap f l `mappend` foldMap f r++instance Traversable IntMap where+ traverse _ Nil = pure Nil+ traverse f (Tip k v) = Tip k <$> f v+ traverse f (Bin p m l r) = Bin p m <$> traverse f l <*> traverse f r++{--------------------------------------------------------------------+ Query+--------------------------------------------------------------------}+-- | /O(1)/. Is the map empty?+--+-- > Data.IntMap.null (empty) == True+-- > Data.IntMap.null (singleton 1 'a') == False++null :: IntMap a -> Bool+null Nil = True+null _ = False++-- | /O(n)/. Number of elements in the map.+--+-- > size empty == 0+-- > size (singleton 1 'a') == 1+-- > size (fromList([(1,'a'), (2,'c'), (3,'b')])) == 3+size :: IntMap a -> Int+size t+ = case t of+ Bin _ _ l r -> size l + size r+ Tip _ _ -> 1+ Nil -> 0++-- | /O(min(n,W))/. Is the key a member of the map?+--+-- > member 5 (fromList [(5,'a'), (3,'b')]) == True+-- > member 1 (fromList [(5,'a'), (3,'b')]) == False++member :: Key -> IntMap a -> Bool+member k m+ = case lookup k m of+ Nothing -> False+ Just _ -> True++-- | /O(log n)/. Is the key not a member of the map?+--+-- > notMember 5 (fromList [(5,'a'), (3,'b')]) == False+-- > notMember 1 (fromList [(5,'a'), (3,'b')]) == True++notMember :: Key -> IntMap a -> Bool+notMember k m = not $ member k m++-- | /O(min(n,W))/. Lookup the value at a key in the map. See also 'Data.Map.lookup'.+lookup :: Key -> IntMap a -> Maybe a+lookup k t+ = let nk = natFromInt k in seq nk (lookupN nk t)++lookupN :: Nat -> IntMap a -> Maybe a+lookupN k t+ = case t of+ Bin _ m l r+ | zeroN k (natFromInt m) -> lookupN k l+ | otherwise -> lookupN k r+ Tip kx x+ | (k == natFromInt kx) -> Just x+ | otherwise -> Nothing+ Nil -> Nothing+-- ^ inlining lookup doesn't seem to help.++find' :: Key -> IntMap a -> a+find' k m+ = case lookup k m of+ Nothing -> error ("IntMap.find: key " ++ show k ++ " is not an element of the map")+ Just x -> x++-- | /O(min(n,W))/. The expression @('findWithDefault' def k map)@+-- returns the value at key @k@ or returns @def@ when the key is not an+-- element of the map.+--+-- > findWithDefault 'x' 1 (fromList [(5,'a'), (3,'b')]) == 'x'+-- > findWithDefault 'x' 5 (fromList [(5,'a'), (3,'b')]) == 'a'++findWithDefault :: a -> Key -> IntMap a -> a+findWithDefault def k m+ = case lookup k m of+ Nothing -> def+ Just x -> x++{--------------------------------------------------------------------+ Construction+--------------------------------------------------------------------}+-- | /O(1)/. The empty map.+--+-- > empty == fromList []+-- > size empty == 0++empty :: IntMap a+empty+ = Nil++-- | /O(1)/. A map of one element.+--+-- > singleton 1 'a' == fromList [(1, 'a')]+-- > size (singleton 1 'a') == 1++singleton :: Key -> a -> IntMap a+singleton k x+ = Tip k x++{--------------------------------------------------------------------+ Insert+--------------------------------------------------------------------}+-- | /O(min(n,W))/. Insert a new key\/value pair in the map.+-- If the key is already present in the map, the associated value is+-- replaced with the supplied value, i.e. 'insert' is equivalent to+-- @'insertWith' 'const'@.+--+-- > insert 5 'x' (fromList [(5,'a'), (3,'b')]) == fromList [(3, 'b'), (5, 'x')]+-- > insert 7 'x' (fromList [(5,'a'), (3,'b')]) == fromList [(3, 'b'), (5, 'a'), (7, 'x')]+-- > insert 5 'x' empty == singleton 5 'x'++insert :: Key -> a -> IntMap a -> IntMap a+insert k x t+ = case t of+ Bin p m l r+ | nomatch k p m -> join k (Tip k x) p t+ | zero k m -> Bin p m (insert k x l) r+ | otherwise -> Bin p m l (insert k x r)+ Tip ky _+ | k==ky -> Tip k x+ | otherwise -> join k (Tip k x) ky t+ Nil -> Tip k x++-- right-biased insertion, used by 'union'+-- | /O(min(n,W))/. Insert with a combining function.+-- @'insertWith' f key value mp@+-- will insert the pair (key, value) into @mp@ if key does+-- not exist in the map. If the key does exist, the function will+-- insert @f new_value old_value@.+--+-- > insertWith (++) 5 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "xxxa")]+-- > insertWith (++) 7 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a"), (7, "xxx")]+-- > insertWith (++) 5 "xxx" empty == singleton 5 "xxx"++insertWith :: (a -> a -> a) -> Key -> a -> IntMap a -> IntMap a+insertWith f k x t+ = insertWithKey (\_ x' y' -> f x' y') k x t++-- | /O(min(n,W))/. Insert with a combining function.+-- @'insertWithKey' f key value mp@+-- will insert the pair (key, value) into @mp@ if key does+-- not exist in the map. If the key does exist, the function will+-- insert @f key new_value old_value@.+--+-- > let f key new_value old_value = (show key) ++ ":" ++ new_value ++ "|" ++ old_value+-- > insertWithKey f 5 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "5:xxx|a")]+-- > insertWithKey f 7 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a"), (7, "xxx")]+-- > insertWithKey f 5 "xxx" empty == singleton 5 "xxx"++insertWithKey :: (Key -> a -> a -> a) -> Key -> a -> IntMap a -> IntMap a+insertWithKey f k x = k `seq` go+ where+ go t@(Bin p m l r)+ | nomatch k p m = join k (Tip k x) p t+ | zero k m = Bin p m (go l) r+ | otherwise = Bin p m l (go r)++ go t@(Tip ky y)+ | k==ky = Tip k (f k x y)+ | otherwise = join k (Tip k x) ky t++ go Nil = Tip k x+++-- | /O(min(n,W))/. The expression (@'insertLookupWithKey' f k x map@)+-- is a pair where the first element is equal to (@'lookup' k map@)+-- and the second element equal to (@'insertWithKey' f k x map@).+--+-- > let f key new_value old_value = (show key) ++ ":" ++ new_value ++ "|" ++ old_value+-- > insertLookupWithKey f 5 "xxx" (fromList [(5,"a"), (3,"b")]) == (Just "a", fromList [(3, "b"), (5, "5:xxx|a")])+-- > insertLookupWithKey f 7 "xxx" (fromList [(5,"a"), (3,"b")]) == (Nothing, fromList [(3, "b"), (5, "a"), (7, "xxx")])+-- > insertLookupWithKey f 5 "xxx" empty == (Nothing, singleton 5 "xxx")+--+-- This is how to define @insertLookup@ using @insertLookupWithKey@:+--+-- > let insertLookup kx x t = insertLookupWithKey (\_ a _ -> a) kx x t+-- > insertLookup 5 "x" (fromList [(5,"a"), (3,"b")]) == (Just "a", fromList [(3, "b"), (5, "x")])+-- > insertLookup 7 "x" (fromList [(5,"a"), (3,"b")]) == (Nothing, fromList [(3, "b"), (5, "a"), (7, "x")])++insertLookupWithKey :: (Key -> a -> a -> a) -> Key -> a -> IntMap a -> (Maybe a, IntMap a)+insertLookupWithKey f k x = k `seq` go+ where+ go t@(Bin p m l r)+ | nomatch k p m = (Nothing,join k (Tip k x) p t)+ | zero k m = case go l of (found, l') -> (found,Bin p m l' r)+ | otherwise = case go r of (found, r') -> (found,Bin p m l r')++ go t@(Tip ky y)+ | k==ky = (Just y,Tip k (f k x y))+ | otherwise = (Nothing,join k (Tip k x) ky t)++ go Nil = (Nothing,Tip k x)+++{--------------------------------------------------------------------+ Deletion+ [delete] is the inlined version of [deleteWith (\k x -> Nothing)]+--------------------------------------------------------------------}+-- | /O(min(n,W))/. Delete a key and its value from the map. When the key is not+-- a member of the map, the original map is returned.+--+-- > delete 5 (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"+-- > delete 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]+-- > delete 5 empty == empty++delete :: Key -> IntMap a -> IntMap a+delete k = go+ where+ go t@(Bin p m l r)+ | nomatch k p m = t+ | zero k m = bin p m (go l) r+ | otherwise = bin p m l (go r)++ go t@(Tip ky _)+ | k==ky = Nil+ | otherwise = t++ go Nil = Nil++-- | /O(min(n,W))/. Adjust a value at a specific key. When the key is not+-- a member of the map, the original map is returned.+--+-- > adjust ("new " ++) 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "new a")]+-- > adjust ("new " ++) 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]+-- > adjust ("new " ++) 7 empty == empty++adjust :: (a -> a) -> Key -> IntMap a -> IntMap a+adjust f k m+ = adjustWithKey (\_ x -> f x) k m++-- | /O(min(n,W))/. Adjust a value at a specific key. When the key is not+-- a member of the map, the original map is returned.+--+-- > let f key x = (show key) ++ ":new " ++ x+-- > adjustWithKey f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "5:new a")]+-- > adjustWithKey f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]+-- > adjustWithKey f 7 empty == empty++adjustWithKey :: (Key -> a -> a) -> Key -> IntMap a -> IntMap a+adjustWithKey f+ = updateWithKey (\k' x -> Just (f k' x))++-- | /O(min(n,W))/. The expression (@'update' f k map@) updates the value @x@+-- at @k@ (if it is in the map). If (@f x@) is 'Nothing', the element is+-- deleted. If it is (@'Just' y@), the key @k@ is bound to the new value @y@.+--+-- > let f x = if x == "a" then Just "new a" else Nothing+-- > update f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "new a")]+-- > update f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]+-- > update f 3 (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"++update :: (a -> Maybe a) -> Key -> IntMap a -> IntMap a+update f+ = updateWithKey (\_ x -> f x)++-- | /O(min(n,W))/. The expression (@'update' f k map@) updates the value @x@+-- at @k@ (if it is in the map). If (@f k x@) is 'Nothing', the element is+-- deleted. If it is (@'Just' y@), the key @k@ is bound to the new value @y@.+--+-- > let f k x = if x == "a" then Just ((show k) ++ ":new a") else Nothing+-- > updateWithKey f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "5:new a")]+-- > updateWithKey f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]+-- > updateWithKey f 3 (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"++updateWithKey :: (Key -> a -> Maybe a) -> Key -> IntMap a -> IntMap a+updateWithKey f k = go+ where+ go t@(Bin p m l r)+ | nomatch k p m = t+ | zero k m = bin p m (go l) r+ | otherwise = bin p m l (go r)++ go t@(Tip ky y)+ | k==ky = case f k y of+ Just y' -> Tip ky y'+ Nothing -> Nil+ | otherwise = t++ go Nil = Nil++-- | /O(min(n,W))/. Lookup and update.+-- The function returns original value, if it is updated.+-- This is different behavior than 'Data.Map.updateLookupWithKey'.+-- Returns the original key value if the map entry is deleted.+--+-- > let f k x = if x == "a" then Just ((show k) ++ ":new a") else Nothing+-- > updateLookupWithKey f 5 (fromList [(5,"a"), (3,"b")]) == (Just "a", fromList [(3, "b"), (5, "5:new a")])+-- > updateLookupWithKey f 7 (fromList [(5,"a"), (3,"b")]) == (Nothing, fromList [(3, "b"), (5, "a")])+-- > updateLookupWithKey f 3 (fromList [(5,"a"), (3,"b")]) == (Just "b", singleton 5 "a")++updateLookupWithKey :: (Key -> a -> Maybe a) -> Key -> IntMap a -> (Maybe a,IntMap a)+updateLookupWithKey f k = go+ where+ go t@(Bin p m l r)+ | nomatch k p m = (Nothing,t)+ | zero k m = case updateLookupWithKey f k l of (found, l') -> (found,bin p m l' r)+ | otherwise = case updateLookupWithKey f k r of (found, r') -> (found,bin p m l r')++ go t@(Tip ky y)+ | k==ky = case f k y of+ Just y' -> (Just y,Tip ky y')+ Nothing -> (Just y,Nil)+ | otherwise = (Nothing,t)++ go Nil = (Nothing,Nil)++-- | /O(log n)/. The expression (@'alter' f k map@) alters the value @x@ at @k@, or absence thereof.+-- 'alter' can be used to insert, delete, or update a value in an 'IntMap'.+-- In short : @'lookup' k ('alter' f k m) = f ('lookup' k m)@.+alter :: (Maybe a -> Maybe a) -> Key -> IntMap a -> IntMap a+alter f k = k `seq` go+ where+ go t@(Bin p m l r)+ | nomatch k p m = case f Nothing of+ Nothing -> t+ Just x -> join k (Tip k x) p t+ | zero k m = bin p m (go l) r+ | otherwise = bin p m l (go r)++ go t@(Tip ky y)+ | k==ky = case f (Just y) of+ Just x -> Tip ky x+ Nothing -> Nil++ | otherwise = case f Nothing of+ Just x -> join k (Tip k x) ky t+ Nothing -> Tip ky y++ go Nil = case f Nothing of+ Just x -> Tip k x+ Nothing -> Nil+++{--------------------------------------------------------------------+ Union+--------------------------------------------------------------------}+-- | The union of a list of maps.+--+-- > unions [(fromList [(5, "a"), (3, "b")]), (fromList [(5, "A"), (7, "C")]), (fromList [(5, "A3"), (3, "B3")])]+-- > == fromList [(3, "b"), (5, "a"), (7, "C")]+-- > unions [(fromList [(5, "A3"), (3, "B3")]), (fromList [(5, "A"), (7, "C")]), (fromList [(5, "a"), (3, "b")])]+-- > == fromList [(3, "B3"), (5, "A3"), (7, "C")]++unions :: [IntMap a] -> IntMap a+unions xs+ = foldlStrict union empty xs++-- | The union of a list of maps, with a combining operation.+--+-- > unionsWith (++) [(fromList [(5, "a"), (3, "b")]), (fromList [(5, "A"), (7, "C")]), (fromList [(5, "A3"), (3, "B3")])]+-- > == fromList [(3, "bB3"), (5, "aAA3"), (7, "C")]++unionsWith :: (a->a->a) -> [IntMap a] -> IntMap a+unionsWith f ts+ = foldlStrict (unionWith f) empty ts++-- | /O(n+m)/. The (left-biased) union of two maps.+-- It prefers the first map when duplicate keys are encountered,+-- i.e. (@'union' == 'unionWith' 'const'@).+--+-- > union (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "a"), (7, "C")]++union :: IntMap a -> IntMap a -> IntMap a+union t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)+ | shorter m1 m2 = union1+ | shorter m2 m1 = union2+ | p1 == p2 = Bin p1 m1 (union l1 l2) (union r1 r2)+ | otherwise = join p1 t1 p2 t2+ where+ union1 | nomatch p2 p1 m1 = join p1 t1 p2 t2+ | zero p2 m1 = Bin p1 m1 (union l1 t2) r1+ | otherwise = Bin p1 m1 l1 (union r1 t2)++ union2 | nomatch p1 p2 m2 = join p1 t1 p2 t2+ | zero p1 m2 = Bin p2 m2 (union t1 l2) r2+ | otherwise = Bin p2 m2 l2 (union t1 r2)++union (Tip k x) t = insert k x t+union t (Tip k x) = insertWith (\_ y -> y) k x t -- right bias+union Nil t = t+union t Nil = t++-- | /O(n+m)/. The union with a combining function.+--+-- > unionWith (++) (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "aA"), (7, "C")]++unionWith :: (a -> a -> a) -> IntMap a -> IntMap a -> IntMap a+unionWith f m1 m2+ = unionWithKey (\_ x y -> f x y) m1 m2++-- | /O(n+m)/. The union with a combining function.+--+-- > let f key left_value right_value = (show key) ++ ":" ++ left_value ++ "|" ++ right_value+-- > unionWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "5:a|A"), (7, "C")]++unionWithKey :: (Key -> a -> a -> a) -> IntMap a -> IntMap a -> IntMap a+unionWithKey f t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)+ | shorter m1 m2 = union1+ | shorter m2 m1 = union2+ | p1 == p2 = Bin p1 m1 (unionWithKey f l1 l2) (unionWithKey f r1 r2)+ | otherwise = join p1 t1 p2 t2+ where+ union1 | nomatch p2 p1 m1 = join p1 t1 p2 t2+ | zero p2 m1 = Bin p1 m1 (unionWithKey f l1 t2) r1+ | otherwise = Bin p1 m1 l1 (unionWithKey f r1 t2)++ union2 | nomatch p1 p2 m2 = join p1 t1 p2 t2+ | zero p1 m2 = Bin p2 m2 (unionWithKey f t1 l2) r2+ | otherwise = Bin p2 m2 l2 (unionWithKey f t1 r2)++unionWithKey f (Tip k x) t = insertWithKey f k x t+unionWithKey f t (Tip k x) = insertWithKey (\k' x' y' -> f k' y' x') k x t -- right bias+unionWithKey _ Nil t = t+unionWithKey _ t Nil = t++{--------------------------------------------------------------------+ Difference+--------------------------------------------------------------------}+-- | /O(n+m)/. Difference between two maps (based on keys).+--+-- > difference (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 3 "b"++difference :: IntMap a -> IntMap b -> IntMap a+difference t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)+ | shorter m1 m2 = difference1+ | shorter m2 m1 = difference2+ | p1 == p2 = bin p1 m1 (difference l1 l2) (difference r1 r2)+ | otherwise = t1+ where+ difference1 | nomatch p2 p1 m1 = t1+ | zero p2 m1 = bin p1 m1 (difference l1 t2) r1+ | otherwise = bin p1 m1 l1 (difference r1 t2)++ difference2 | nomatch p1 p2 m2 = t1+ | zero p1 m2 = difference t1 l2+ | otherwise = difference t1 r2++difference t1@(Tip k _) t2+ | member k t2 = Nil+ | otherwise = t1++difference Nil _ = Nil+difference t (Tip k _) = delete k t+difference t Nil = t++-- | /O(n+m)/. Difference with a combining function.+--+-- > let f al ar = if al == "b" then Just (al ++ ":" ++ ar) else Nothing+-- > differenceWith f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (3, "B"), (7, "C")])+-- > == singleton 3 "b:B"++differenceWith :: (a -> b -> Maybe a) -> IntMap a -> IntMap b -> IntMap a+differenceWith f m1 m2+ = differenceWithKey (\_ x y -> f x y) m1 m2++-- | /O(n+m)/. Difference with a combining function. When two equal keys are+-- encountered, the combining function is applied to the key and both values.+-- If it returns 'Nothing', the element is discarded (proper set difference).+-- If it returns (@'Just' y@), the element is updated with a new value @y@.+--+-- > let f k al ar = if al == "b" then Just ((show k) ++ ":" ++ al ++ "|" ++ ar) else Nothing+-- > differenceWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (3, "B"), (10, "C")])+-- > == singleton 3 "3:b|B"++differenceWithKey :: (Key -> a -> b -> Maybe a) -> IntMap a -> IntMap b -> IntMap a+differenceWithKey f t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)+ | shorter m1 m2 = difference1+ | shorter m2 m1 = difference2+ | p1 == p2 = bin p1 m1 (differenceWithKey f l1 l2) (differenceWithKey f r1 r2)+ | otherwise = t1+ where+ difference1 | nomatch p2 p1 m1 = t1+ | zero p2 m1 = bin p1 m1 (differenceWithKey f l1 t2) r1+ | otherwise = bin p1 m1 l1 (differenceWithKey f r1 t2)++ difference2 | nomatch p1 p2 m2 = t1+ | zero p1 m2 = differenceWithKey f t1 l2+ | otherwise = differenceWithKey f t1 r2++differenceWithKey f t1@(Tip k x) t2+ = case lookup k t2 of+ Just y -> case f k x y of+ Just y' -> Tip k y'+ Nothing -> Nil+ Nothing -> t1++differenceWithKey _ Nil _ = Nil+differenceWithKey f t (Tip k y) = updateWithKey (\k' x -> f k' x y) k t+differenceWithKey _ t Nil = t+++{--------------------------------------------------------------------+ Intersection+--------------------------------------------------------------------}+-- | /O(n+m)/. The (left-biased) intersection of two maps (based on keys).+--+-- > intersection (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "a"++intersection :: IntMap a -> IntMap b -> IntMap a+intersection t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)+ | shorter m1 m2 = intersection1+ | shorter m2 m1 = intersection2+ | p1 == p2 = bin p1 m1 (intersection l1 l2) (intersection r1 r2)+ | otherwise = Nil+ where+ intersection1 | nomatch p2 p1 m1 = Nil+ | zero p2 m1 = intersection l1 t2+ | otherwise = intersection r1 t2++ intersection2 | nomatch p1 p2 m2 = Nil+ | zero p1 m2 = intersection t1 l2+ | otherwise = intersection t1 r2++intersection t1@(Tip k _) t2+ | member k t2 = t1+ | otherwise = Nil+intersection t (Tip k _)+ = case lookup k t of+ Just y -> Tip k y+ Nothing -> Nil+intersection Nil _ = Nil+intersection _ Nil = Nil++-- | /O(n+m)/. The intersection with a combining function.+--+-- > intersectionWith (++) (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "aA"++intersectionWith :: (a -> b -> c) -> IntMap a -> IntMap b -> IntMap c+intersectionWith f m1 m2+ = intersectionWithKey (\_ x y -> f x y) m1 m2++-- | /O(n+m)/. The intersection with a combining function.+--+-- > let f k al ar = (show k) ++ ":" ++ al ++ "|" ++ ar+-- > intersectionWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "5:a|A"++intersectionWithKey :: (Key -> a -> b -> c) -> IntMap a -> IntMap b -> IntMap c+intersectionWithKey f t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)+ | shorter m1 m2 = intersection1+ | shorter m2 m1 = intersection2+ | p1 == p2 = bin p1 m1 (intersectionWithKey f l1 l2) (intersectionWithKey f r1 r2)+ | otherwise = Nil+ where+ intersection1 | nomatch p2 p1 m1 = Nil+ | zero p2 m1 = intersectionWithKey f l1 t2+ | otherwise = intersectionWithKey f r1 t2++ intersection2 | nomatch p1 p2 m2 = Nil+ | zero p1 m2 = intersectionWithKey f t1 l2+ | otherwise = intersectionWithKey f t1 r2++intersectionWithKey f (Tip k x) t2+ = case lookup k t2 of+ Just y -> Tip k (f k x y)+ Nothing -> Nil+intersectionWithKey f t1 (Tip k y)+ = case lookup k t1 of+ Just x -> Tip k (f k x y)+ Nothing -> Nil+intersectionWithKey _ Nil _ = Nil+intersectionWithKey _ _ Nil = Nil+++{--------------------------------------------------------------------+ Min\/Max+--------------------------------------------------------------------}++-- | /O(log n)/. Update the value at the minimal key.+--+-- > updateMinWithKey (\ k a -> Just ((show k) ++ ":" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3,"3:b"), (5,"a")]+-- > updateMinWithKey (\ _ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"++updateMinWithKey :: (Key -> a -> a) -> IntMap a -> IntMap a+updateMinWithKey f = go+ where+ go (Bin p m l r) | m < 0 = let t' = updateMinWithKeyUnsigned f r in Bin p m l t'+ go (Bin p m l r) = let t' = updateMinWithKeyUnsigned f l in Bin p m t' r+ go (Tip k y) = Tip k (f k y)+ go Nil = error "maxView: empty map has no maximal element"++updateMinWithKeyUnsigned :: (Key -> a -> a) -> IntMap a -> IntMap a+updateMinWithKeyUnsigned f = go+ where+ go (Bin p m l r) = let t' = go l in Bin p m t' r+ go (Tip k y) = Tip k (f k y)+ go Nil = error "updateMinWithKeyUnsigned Nil"++-- | /O(log n)/. Update the value at the maximal key.+--+-- > updateMaxWithKey (\ k a -> Just ((show k) ++ ":" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3,"b"), (5,"5:a")]+-- > updateMaxWithKey (\ _ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"++updateMaxWithKey :: (Key -> a -> a) -> IntMap a -> IntMap a+updateMaxWithKey f = go+ where+ go (Bin p m l r) | m < 0 = let t' = updateMaxWithKeyUnsigned f l in Bin p m t' r+ go (Bin p m l r) = let t' = updateMaxWithKeyUnsigned f r in Bin p m l t'+ go (Tip k y) = Tip k (f k y)+ go Nil = error "maxView: empty map has no maximal element"++updateMaxWithKeyUnsigned :: (Key -> a -> a) -> IntMap a -> IntMap a+updateMaxWithKeyUnsigned f = go+ where+ go (Bin p m l r) = let t' = go r in Bin p m l t'+ go (Tip k y) = Tip k (f k y)+ go Nil = error "updateMaxWithKeyUnsigned Nil"+++-- | /O(log n)/. Retrieves the maximal (key,value) pair of the map, and+-- the map stripped of that element, or 'Nothing' if passed an empty map.+--+-- > maxViewWithKey (fromList [(5,"a"), (3,"b")]) == Just ((5,"a"), singleton 3 "b")+-- > maxViewWithKey empty == Nothing++maxViewWithKey :: IntMap a -> Maybe ((Key, a), IntMap a)+maxViewWithKey t+ = case t of+ Bin p m l r | m < 0 -> let (result, t') = maxViewUnsigned l in Just (result, bin p m t' r)+ Bin p m l r -> let (result, t') = maxViewUnsigned r in Just (result, bin p m l t')+ Tip k y -> Just ((k,y), Nil)+ Nil -> Nothing++maxViewUnsigned :: IntMap a -> ((Key, a), IntMap a)+maxViewUnsigned t+ = case t of+ Bin p m l r -> let (result,t') = maxViewUnsigned r in (result,bin p m l t')+ Tip k y -> ((k,y), Nil)+ Nil -> error "maxViewUnsigned Nil"++-- | /O(log n)/. Retrieves the minimal (key,value) pair of the map, and+-- the map stripped of that element, or 'Nothing' if passed an empty map.+--+-- > minViewWithKey (fromList [(5,"a"), (3,"b")]) == Just ((3,"b"), singleton 5 "a")+-- > minViewWithKey empty == Nothing++minViewWithKey :: IntMap a -> Maybe ((Key, a), IntMap a)+minViewWithKey t+ = case t of+ Bin p m l r | m < 0 -> let (result, t') = minViewUnsigned r in Just (result, bin p m l t')+ Bin p m l r -> let (result, t') = minViewUnsigned l in Just (result, bin p m t' r)+ Tip k y -> Just ((k,y),Nil)+ Nil -> Nothing++minViewUnsigned :: IntMap a -> ((Key, a), IntMap a)+minViewUnsigned t+ = case t of+ Bin p m l r -> let (result,t') = minViewUnsigned l in (result,bin p m t' r)+ Tip k y -> ((k,y),Nil)+ Nil -> error "minViewUnsigned Nil"+++-- | /O(log n)/. Update the value at the maximal key.+--+-- > updateMax (\ a -> Just ("X" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "Xa")]+-- > updateMax (\ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"++updateMax :: (a -> a) -> IntMap a -> IntMap a+updateMax f = updateMaxWithKey (const f)++-- | /O(log n)/. Update the value at the minimal key.+--+-- > updateMin (\ a -> Just ("X" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3, "Xb"), (5, "a")]+-- > updateMin (\ _ -> Nothing) (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"++updateMin :: (a -> a) -> IntMap a -> IntMap a+updateMin f = updateMinWithKey (const f)++-- Similar to the Arrow instance.+first :: (a -> c) -> (a, b) -> (c, b)+first f (x,y) = (f x,y)++-- | /O(log n)/. Retrieves the maximal key of the map, and the map+-- stripped of that element, or 'Nothing' if passed an empty map.+maxView :: IntMap a -> Maybe (a, IntMap a)+maxView t = liftM (first snd) (maxViewWithKey t)++-- | /O(log n)/. Retrieves the minimal key of the map, and the map+-- stripped of that element, or 'Nothing' if passed an empty map.+minView :: IntMap a -> Maybe (a, IntMap a)+minView t = liftM (first snd) (minViewWithKey t)++-- | /O(log n)/. Delete and find the maximal element.+deleteFindMax :: IntMap a -> (a, IntMap a)+deleteFindMax = fromMaybe (error "deleteFindMax: empty map has no maximal element") . maxView++-- | /O(log n)/. Delete and find the minimal element.+deleteFindMin :: IntMap a -> (a, IntMap a)+deleteFindMin = fromMaybe (error "deleteFindMin: empty map has no minimal element") . minView++-- | /O(log n)/. The minimal key of the map.+findMin :: IntMap a -> (Key,a)+findMin Nil = error $ "findMin: empty map has no minimal element"+findMin (Tip k v) = (k,v)+findMin (Bin _ m l r)+ | m < 0 = find r+ | otherwise = find l+ where find (Tip k v) = (k,v)+ find (Bin _ _ l' _) = find l'+ find Nil = error "findMax Nil"++-- | /O(log n)/. The maximal key of the map.+findMax :: IntMap a -> (Key,a)+findMax Nil = error $ "findMax: empty map has no maximal element"+findMax (Tip k v) = (k,v)+findMax (Bin _ m l r)+ | m < 0 = find l+ | otherwise = find r+ where find (Tip k v) = (k,v)+ find (Bin _ _ _ r') = find r'+ find Nil = error "findMax Nil"++-- | /O(log n)/. Delete the minimal key. An error is thrown if the IntMap is already empty.+-- Note, this is not the same behavior Map.+deleteMin :: IntMap a -> IntMap a+deleteMin = maybe (error "deleteMin: empty map has no minimal element") snd . minView++-- | /O(log n)/. Delete the maximal key. An error is thrown if the IntMap is already empty.+-- Note, this is not the same behavior Map.+deleteMax :: IntMap a -> IntMap a+deleteMax = maybe (error "deleteMax: empty map has no maximal element") snd . maxView+++{--------------------------------------------------------------------+ Submap+--------------------------------------------------------------------}+-- | /O(n+m)/. Is this a proper submap? (ie. a submap but not equal).+-- Defined as (@'isProperSubmapOf' = 'isProperSubmapOfBy' (==)@).+isProperSubmapOf :: Eq a => IntMap a -> IntMap a -> Bool+isProperSubmapOf m1 m2+ = isProperSubmapOfBy (==) m1 m2++{- | /O(n+m)/. Is this a proper submap? (ie. a submap but not equal).+ The expression (@'isProperSubmapOfBy' f m1 m2@) returns 'True' when+ @m1@ and @m2@ are not equal,+ all keys in @m1@ are in @m2@, and when @f@ returns 'True' when+ applied to their respective values. For example, the following+ expressions are all 'True':++ > isProperSubmapOfBy (==) (fromList [(1,1)]) (fromList [(1,1),(2,2)])+ > isProperSubmapOfBy (<=) (fromList [(1,1)]) (fromList [(1,1),(2,2)])++ But the following are all 'False':++ > isProperSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1),(2,2)])+ > isProperSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1)])+ > isProperSubmapOfBy (<) (fromList [(1,1)]) (fromList [(1,1),(2,2)])+-}+isProperSubmapOfBy :: (a -> b -> Bool) -> IntMap a -> IntMap b -> Bool+isProperSubmapOfBy predicate t1 t2+ = case submapCmp predicate t1 t2 of+ LT -> True+ _ -> False++submapCmp :: (a -> b -> Bool) -> IntMap a -> IntMap b -> Ordering+submapCmp predicate t1@(Bin p1 m1 l1 r1) (Bin p2 m2 l2 r2)+ | shorter m1 m2 = GT+ | shorter m2 m1 = submapCmpLt+ | p1 == p2 = submapCmpEq+ | otherwise = GT -- disjoint+ where+ submapCmpLt | nomatch p1 p2 m2 = GT+ | zero p1 m2 = submapCmp predicate t1 l2+ | otherwise = submapCmp predicate t1 r2+ submapCmpEq = case (submapCmp predicate l1 l2, submapCmp predicate r1 r2) of+ (GT,_ ) -> GT+ (_ ,GT) -> GT+ (EQ,EQ) -> EQ+ _ -> LT++submapCmp _ (Bin _ _ _ _) _ = GT+submapCmp predicate (Tip kx x) (Tip ky y)+ | (kx == ky) && predicate x y = EQ+ | otherwise = GT -- disjoint+submapCmp predicate (Tip k x) t+ = case lookup k t of+ Just y | predicate x y -> LT+ _ -> GT -- disjoint+submapCmp _ Nil Nil = EQ+submapCmp _ Nil _ = LT++-- | /O(n+m)/. Is this a submap?+-- Defined as (@'isSubmapOf' = 'isSubmapOfBy' (==)@).+isSubmapOf :: Eq a => IntMap a -> IntMap a -> Bool+isSubmapOf m1 m2+ = isSubmapOfBy (==) m1 m2++{- | /O(n+m)/.+ The expression (@'isSubmapOfBy' f m1 m2@) returns 'True' if+ all keys in @m1@ are in @m2@, and when @f@ returns 'True' when+ applied to their respective values. For example, the following+ expressions are all 'True':++ > isSubmapOfBy (==) (fromList [(1,1)]) (fromList [(1,1),(2,2)])+ > isSubmapOfBy (<=) (fromList [(1,1)]) (fromList [(1,1),(2,2)])+ > isSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1),(2,2)])++ But the following are all 'False':++ > isSubmapOfBy (==) (fromList [(1,2)]) (fromList [(1,1),(2,2)])+ > isSubmapOfBy (<) (fromList [(1,1)]) (fromList [(1,1),(2,2)])+ > isSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1)])+-}+isSubmapOfBy :: (a -> b -> Bool) -> IntMap a -> IntMap b -> Bool+isSubmapOfBy predicate t1@(Bin p1 m1 l1 r1) (Bin p2 m2 l2 r2)+ | shorter m1 m2 = False+ | shorter m2 m1 = match p1 p2 m2 && (if zero p1 m2 then isSubmapOfBy predicate t1 l2+ else isSubmapOfBy predicate t1 r2)+ | otherwise = (p1==p2) && isSubmapOfBy predicate l1 l2 && isSubmapOfBy predicate r1 r2+isSubmapOfBy _ (Bin _ _ _ _) _ = False+isSubmapOfBy predicate (Tip k x) t = case lookup k t of+ Just y -> predicate x y+ Nothing -> False+isSubmapOfBy _ Nil _ = True++{--------------------------------------------------------------------+ Mapping+--------------------------------------------------------------------}+-- | /O(n)/. Map a function over all values in the map.+--+-- > map (++ "x") (fromList [(5,"a"), (3,"b")]) == fromList [(3, "bx"), (5, "ax")]++map :: (a -> b) -> IntMap a -> IntMap b+map f = mapWithKey (\_ x -> f x)++-- | /O(n)/. Map a function over all values in the map.+--+-- > let f key x = (show key) ++ ":" ++ x+-- > mapWithKey f (fromList [(5,"a"), (3,"b")]) == fromList [(3, "3:b"), (5, "5:a")]++mapWithKey :: (Key -> a -> b) -> IntMap a -> IntMap b+mapWithKey f = go+ where+ go (Bin p m l r) = Bin p m (go l) (go r)+ go (Tip k x) = Tip k (f k x)+ go Nil = Nil++-- | /O(n)/. The function @'mapAccum'@ threads an accumulating+-- argument through the map in ascending order of keys.+--+-- > let f a b = (a ++ b, b ++ "X")+-- > mapAccum f "Everything: " (fromList [(5,"a"), (3,"b")]) == ("Everything: ba", fromList [(3, "bX"), (5, "aX")])++mapAccum :: (a -> b -> (a,c)) -> a -> IntMap b -> (a,IntMap c)+mapAccum f = mapAccumWithKey (\a' _ x -> f a' x)++-- | /O(n)/. The function @'mapAccumWithKey'@ threads an accumulating+-- argument through the map in ascending order of keys.+--+-- > let f a k b = (a ++ " " ++ (show k) ++ "-" ++ b, b ++ "X")+-- > mapAccumWithKey f "Everything:" (fromList [(5,"a"), (3,"b")]) == ("Everything: 3-b 5-a", fromList [(3, "bX"), (5, "aX")])++mapAccumWithKey :: (a -> Key -> b -> (a,c)) -> a -> IntMap b -> (a,IntMap c)+mapAccumWithKey f a t+ = mapAccumL f a t++-- | /O(n)/. The function @'mapAccumL'@ threads an accumulating+-- argument through the map in ascending order of keys.+mapAccumL :: (a -> Key -> b -> (a,c)) -> a -> IntMap b -> (a,IntMap c)+mapAccumL f a t+ = case t of+ Bin p m l r -> let (a1,l') = mapAccumL f a l+ (a2,r') = mapAccumL f a1 r+ in (a2,Bin p m l' r')+ Tip k x -> let (a',x') = f a k x in (a',Tip k x')+ Nil -> (a,Nil)++-- | /O(n)/. The function @'mapAccumR'@ threads an accumulating+-- argument through the map in descending order of keys.+mapAccumRWithKey :: (a -> Key -> b -> (a,c)) -> a -> IntMap b -> (a,IntMap c)+mapAccumRWithKey f a t+ = case t of+ Bin p m l r -> let (a1,r') = mapAccumRWithKey f a r+ (a2,l') = mapAccumRWithKey f a1 l+ in (a2,Bin p m l' r')+ Tip k x -> let (a',x') = f a k x in (a',Tip k x')+ Nil -> (a,Nil)++{--------------------------------------------------------------------+ Filter+--------------------------------------------------------------------}+-- | /O(n)/. Filter all values that satisfy some predicate.+--+-- > filter (> "a") (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"+-- > filter (> "x") (fromList [(5,"a"), (3,"b")]) == empty+-- > filter (< "a") (fromList [(5,"a"), (3,"b")]) == empty++filter :: (a -> Bool) -> IntMap a -> IntMap a+filter p m+ = filterWithKey (\_ x -> p x) m++-- | /O(n)/. Filter all keys\/values that satisfy some predicate.+--+-- > filterWithKey (\k _ -> k > 4) (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"++filterWithKey :: (Key -> a -> Bool) -> IntMap a -> IntMap a+filterWithKey p = go+ where+ go (Bin pr m l r) = bin pr m (go l) (go r)+ go t@(Tip k x)+ | p k x = t+ | otherwise = Nil+ go Nil = Nil++-- | /O(n)/. Partition the map according to some predicate. The first+-- map contains all elements that satisfy the predicate, the second all+-- elements that fail the predicate. See also 'split'.+--+-- > partition (> "a") (fromList [(5,"a"), (3,"b")]) == (singleton 3 "b", singleton 5 "a")+-- > partition (< "x") (fromList [(5,"a"), (3,"b")]) == (fromList [(3, "b"), (5, "a")], empty)+-- > partition (> "x") (fromList [(5,"a"), (3,"b")]) == (empty, fromList [(3, "b"), (5, "a")])++partition :: (a -> Bool) -> IntMap a -> (IntMap a,IntMap a)+partition p m+ = partitionWithKey (\_ x -> p x) m++-- | /O(n)/. Partition the map according to some predicate. The first+-- map contains all elements that satisfy the predicate, the second all+-- elements that fail the predicate. See also 'split'.+--+-- > partitionWithKey (\ k _ -> k > 3) (fromList [(5,"a"), (3,"b")]) == (singleton 5 "a", singleton 3 "b")+-- > partitionWithKey (\ k _ -> k < 7) (fromList [(5,"a"), (3,"b")]) == (fromList [(3, "b"), (5, "a")], empty)+-- > partitionWithKey (\ k _ -> k > 7) (fromList [(5,"a"), (3,"b")]) == (empty, fromList [(3, "b"), (5, "a")])++partitionWithKey :: (Key -> a -> Bool) -> IntMap a -> (IntMap a,IntMap a)+partitionWithKey predicate t+ = case t of+ Bin p m l r+ -> let (l1,l2) = partitionWithKey predicate l+ (r1,r2) = partitionWithKey predicate r+ in (bin p m l1 r1, bin p m l2 r2)+ Tip k x+ | predicate k x -> (t,Nil)+ | otherwise -> (Nil,t)+ Nil -> (Nil,Nil)++-- | /O(n)/. Map values and collect the 'Just' results.+--+-- > let f x = if x == "a" then Just "new a" else Nothing+-- > mapMaybe f (fromList [(5,"a"), (3,"b")]) == singleton 5 "new a"++mapMaybe :: (a -> Maybe b) -> IntMap a -> IntMap b+mapMaybe f = mapMaybeWithKey (\_ x -> f x)++-- | /O(n)/. Map keys\/values and collect the 'Just' results.+--+-- > let f k _ = if k < 5 then Just ("key : " ++ (show k)) else Nothing+-- > mapMaybeWithKey f (fromList [(5,"a"), (3,"b")]) == singleton 3 "key : 3"++mapMaybeWithKey :: (Key -> a -> Maybe b) -> IntMap a -> IntMap b+mapMaybeWithKey f = go+ where+ go (Bin p m l r) = bin p m (go l) (go r)+ go (Tip k x) = case f k x of+ Just y -> Tip k y+ Nothing -> Nil+ go Nil = Nil++-- | /O(n)/. Map values and separate the 'Left' and 'Right' results.+--+-- > let f a = if a < "c" then Left a else Right a+-- > mapEither f (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])+-- > == (fromList [(3,"b"), (5,"a")], fromList [(1,"x"), (7,"z")])+-- >+-- > mapEither (\ a -> Right a) (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])+-- > == (empty, fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])++mapEither :: (a -> Either b c) -> IntMap a -> (IntMap b, IntMap c)+mapEither f m+ = mapEitherWithKey (\_ x -> f x) m++-- | /O(n)/. Map keys\/values and separate the 'Left' and 'Right' results.+--+-- > let f k a = if k < 5 then Left (k * 2) else Right (a ++ a)+-- > mapEitherWithKey f (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])+-- > == (fromList [(1,2), (3,6)], fromList [(5,"aa"), (7,"zz")])+-- >+-- > mapEitherWithKey (\_ a -> Right a) (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])+-- > == (empty, fromList [(1,"x"), (3,"b"), (5,"a"), (7,"z")])++mapEitherWithKey :: (Key -> a -> Either b c) -> IntMap a -> (IntMap b, IntMap c)+mapEitherWithKey f (Bin p m l r)+ = (bin p m l1 r1, bin p m l2 r2)+ where+ (l1,l2) = mapEitherWithKey f l+ (r1,r2) = mapEitherWithKey f r+mapEitherWithKey f (Tip k x) = case f k x of+ Left y -> (Tip k y, Nil)+ Right z -> (Nil, Tip k z)+mapEitherWithKey _ Nil = (Nil, Nil)++-- | /O(log n)/. The expression (@'split' k map@) is a pair @(map1,map2)@+-- where all keys in @map1@ are lower than @k@ and all keys in+-- @map2@ larger than @k@. Any key equal to @k@ is found in neither @map1@ nor @map2@.+--+-- > split 2 (fromList [(5,"a"), (3,"b")]) == (empty, fromList [(3,"b"), (5,"a")])+-- > split 3 (fromList [(5,"a"), (3,"b")]) == (empty, singleton 5 "a")+-- > split 4 (fromList [(5,"a"), (3,"b")]) == (singleton 3 "b", singleton 5 "a")+-- > split 5 (fromList [(5,"a"), (3,"b")]) == (singleton 3 "b", empty)+-- > split 6 (fromList [(5,"a"), (3,"b")]) == (fromList [(3,"b"), (5,"a")], empty)++split :: Key -> IntMap a -> (IntMap a,IntMap a)+split k t+ = case t of+ Bin _ m l r+ | m < 0 -> (if k >= 0 -- handle negative numbers.+ then let (lt,gt) = split' k l in (union r lt, gt)+ else let (lt,gt) = split' k r in (lt, union gt l))+ | otherwise -> split' k t+ Tip ky _+ | k>ky -> (t,Nil)+ | k<ky -> (Nil,t)+ | otherwise -> (Nil,Nil)+ Nil -> (Nil,Nil)++split' :: Key -> IntMap a -> (IntMap a,IntMap a)+split' k t+ = case t of+ Bin p m l r+ | nomatch k p m -> if k>p then (t,Nil) else (Nil,t)+ | zero k m -> let (lt,gt) = split k l in (lt,union gt r)+ | otherwise -> let (lt,gt) = split k r in (union l lt,gt)+ Tip ky _+ | k>ky -> (t,Nil)+ | k<ky -> (Nil,t)+ | otherwise -> (Nil,Nil)+ Nil -> (Nil,Nil)++-- | /O(log n)/. Performs a 'split' but also returns whether the pivot+-- key was found in the original map.+--+-- > splitLookup 2 (fromList [(5,"a"), (3,"b")]) == (empty, Nothing, fromList [(3,"b"), (5,"a")])+-- > splitLookup 3 (fromList [(5,"a"), (3,"b")]) == (empty, Just "b", singleton 5 "a")+-- > splitLookup 4 (fromList [(5,"a"), (3,"b")]) == (singleton 3 "b", Nothing, singleton 5 "a")+-- > splitLookup 5 (fromList [(5,"a"), (3,"b")]) == (singleton 3 "b", Just "a", empty)+-- > splitLookup 6 (fromList [(5,"a"), (3,"b")]) == (fromList [(3,"b"), (5,"a")], Nothing, empty)++splitLookup :: Key -> IntMap a -> (IntMap a,Maybe a,IntMap a)+splitLookup k t+ = case t of+ Bin _ m l r+ | m < 0 -> (if k >= 0 -- handle negative numbers.+ then let (lt,found,gt) = splitLookup' k l in (union r lt,found, gt)+ else let (lt,found,gt) = splitLookup' k r in (lt,found, union gt l))+ | otherwise -> splitLookup' k t+ Tip ky y+ | k>ky -> (t,Nothing,Nil)+ | k<ky -> (Nil,Nothing,t)+ | otherwise -> (Nil,Just y,Nil)+ Nil -> (Nil,Nothing,Nil)++splitLookup' :: Key -> IntMap a -> (IntMap a,Maybe a,IntMap a)+splitLookup' k t+ = case t of+ Bin p m l r+ | nomatch k p m -> if k>p then (t,Nothing,Nil) else (Nil,Nothing,t)+ | zero k m -> let (lt,found,gt) = splitLookup k l in (lt,found,union gt r)+ | otherwise -> let (lt,found,gt) = splitLookup k r in (union l lt,found,gt)+ Tip ky y+ | k>ky -> (t,Nothing,Nil)+ | k<ky -> (Nil,Nothing,t)+ | otherwise -> (Nil,Just y,Nil)+ Nil -> (Nil,Nothing,Nil)++{--------------------------------------------------------------------+ Fold+--------------------------------------------------------------------}+-- | /O(n)/. Fold the values in the map, such that+-- @'fold' f z == 'Prelude.foldr' f z . 'elems'@.+-- For example,+--+-- > elems map = fold (:) [] map+--+-- > let f a len = len + (length a)+-- > fold f 0 (fromList [(5,"a"), (3,"bbb")]) == 4++fold :: (a -> b -> b) -> b -> IntMap a -> b+fold f = foldWithKey (\_ x y -> f x y)++-- | /O(n)/. Fold the keys and values in the map, such that+-- @'foldWithKey' f z == 'Prelude.foldr' ('uncurry' f) z . 'toAscList'@.+-- For example,+--+-- > keys map = foldWithKey (\k x ks -> k:ks) [] map+--+-- > let f k a result = result ++ "(" ++ (show k) ++ ":" ++ a ++ ")"+-- > foldWithKey f "Map: " (fromList [(5,"a"), (3,"b")]) == "Map: (5:a)(3:b)"++foldWithKey :: (Key -> a -> b -> b) -> b -> IntMap a -> b+foldWithKey+ = foldr++foldr :: (Key -> a -> b -> b) -> b -> IntMap a -> b+foldr f z t+ = case t of+ Bin 0 m l r | m < 0 -> foldr' f (foldr' f z l) r -- put negative numbers before.+ Bin _ _ _ _ -> foldr' f z t+ Tip k x -> f k x z+ Nil -> z++foldr' :: (Key -> a -> b -> b) -> b -> IntMap a -> b+foldr' f = go+ where+ go z (Bin _ _ l r) = go (go z r) l+ go z (Tip k x) = f k x z+ go z Nil = z++{--------------------------------------------------------------------+ List variations+--------------------------------------------------------------------}+-- | /O(n)/.+-- Return all elements of the map in the ascending order of their keys.+--+-- > elems (fromList [(5,"a"), (3,"b")]) == ["b","a"]+-- > elems empty == []++elems :: IntMap a -> [a]+elems+ = foldWithKey (\_ x xs -> x:xs) []++-- | /O(n)/. Return all keys of the map in ascending order.+--+-- > keys (fromList [(5,"a"), (3,"b")]) == [3,5]+-- > keys empty == []++keys :: IntMap a -> [Key]+keys+ = foldWithKey (\k _ ks -> k:ks) []++-- | /O(n*min(n,W))/. The set of all keys of the map.+--+-- > keysSet (fromList [(5,"a"), (3,"b")]) == Data.IntSet.fromList [3,5]+-- > keysSet empty == Data.IntSet.empty++keysSet :: IntMap a -> IntSet.IntSet+keysSet m = IntSet.fromDistinctAscList (keys m)+++-- | /O(n)/. Return all key\/value pairs in the map in ascending key order.+--+-- > assocs (fromList [(5,"a"), (3,"b")]) == [(3,"b"), (5,"a")]+-- > assocs empty == []++assocs :: IntMap a -> [(Key,a)]+assocs m+ = toList m+++{--------------------------------------------------------------------+ Lists+--------------------------------------------------------------------}+-- | /O(n)/. Convert the map to a list of key\/value pairs.+--+-- > toList (fromList [(5,"a"), (3,"b")]) == [(3,"b"), (5,"a")]+-- > toList empty == []++toList :: IntMap a -> [(Key,a)]+toList+ = foldWithKey (\k x xs -> (k,x):xs) []++-- | /O(n)/. Convert the map to a list of key\/value pairs where the+-- keys are in ascending order.+--+-- > toAscList (fromList [(5,"a"), (3,"b")]) == [(3,"b"), (5,"a")]++toAscList :: IntMap a -> [(Key,a)]+toAscList t+ = -- NOTE: the following algorithm only works for big-endian trees+ let (pos,neg) = span (\(k,_) -> k >=0) (foldr (\k x xs -> (k,x):xs) [] t) in neg ++ pos++-- | /O(n*min(n,W))/. Create a map from a list of key\/value pairs.+--+-- > fromList [] == empty+-- > fromList [(5,"a"), (3,"b"), (5, "c")] == fromList [(5,"c"), (3,"b")]+-- > fromList [(5,"c"), (3,"b"), (5, "a")] == fromList [(5,"a"), (3,"b")]++fromList :: [(Key,a)] -> IntMap a+fromList xs+ = foldlStrict ins empty xs+ where+ ins t (k,x) = insert k x t++-- | /O(n*min(n,W))/. Create a map from a list of key\/value pairs with a combining function. See also 'fromAscListWith'.+--+-- > fromListWith (++) [(5,"a"), (5,"b"), (3,"b"), (3,"a"), (5,"a")] == fromList [(3, "ab"), (5, "aba")]+-- > fromListWith (++) [] == empty++fromListWith :: (a -> a -> a) -> [(Key,a)] -> IntMap a+fromListWith f xs+ = fromListWithKey (\_ x y -> f x y) xs++-- | /O(n*min(n,W))/. Build a map from a list of key\/value pairs with a combining function. See also fromAscListWithKey'.+--+-- > fromListWith (++) [(5,"a"), (5,"b"), (3,"b"), (3,"a"), (5,"a")] == fromList [(3, "ab"), (5, "aba")]+-- > fromListWith (++) [] == empty++fromListWithKey :: (Key -> a -> a -> a) -> [(Key,a)] -> IntMap a+fromListWithKey f xs+ = foldlStrict ins empty xs+ where+ ins t (k,x) = insertWithKey f k x t++-- | /O(n)/. Build a map from a list of key\/value pairs where+-- the keys are in ascending order.+--+-- > fromAscList [(3,"b"), (5,"a")] == fromList [(3, "b"), (5, "a")]+-- > fromAscList [(3,"b"), (5,"a"), (5,"b")] == fromList [(3, "b"), (5, "b")]++fromAscList :: [(Key,a)] -> IntMap a+fromAscList xs+ = fromAscListWithKey (\_ x _ -> x) xs++-- | /O(n)/. Build a map from a list of key\/value pairs where+-- the keys are in ascending order, with a combining function on equal keys.+-- /The precondition (input list is ascending) is not checked./+--+-- > fromAscListWith (++) [(3,"b"), (5,"a"), (5,"b")] == fromList [(3, "b"), (5, "ba")]++fromAscListWith :: (a -> a -> a) -> [(Key,a)] -> IntMap a+fromAscListWith f xs+ = fromAscListWithKey (\_ x y -> f x y) xs++-- | /O(n)/. Build a map from a list of key\/value pairs where+-- the keys are in ascending order, with a combining function on equal keys.+-- /The precondition (input list is ascending) is not checked./+--+-- > fromAscListWith (++) [(3,"b"), (5,"a"), (5,"b")] == fromList [(3, "b"), (5, "ba")]++fromAscListWithKey :: (Key -> a -> a -> a) -> [(Key,a)] -> IntMap a+fromAscListWithKey _ [] = Nil+fromAscListWithKey f (x0 : xs0) = fromDistinctAscList (combineEq x0 xs0)+ where+ -- [combineEq f xs] combines equal elements with function [f] in an ordered list [xs]+ combineEq z [] = [z]+ combineEq z@(kz,zz) (x@(kx,xx):xs)+ | kx==kz = let yy = f kx xx zz in combineEq (kx,yy) xs+ | otherwise = z:combineEq x xs++-- | /O(n)/. Build a map from a list of key\/value pairs where+-- the keys are in ascending order and all distinct.+-- /The precondition (input list is strictly ascending) is not checked./+--+-- > fromDistinctAscList [(3,"b"), (5,"a")] == fromList [(3, "b"), (5, "a")]++#ifdef __GLASGOW_HASKELL__+fromDistinctAscList :: forall a. [(Key,a)] -> IntMap a+#else+fromDistinctAscList :: [(Key,a)] -> IntMap a+#endif+fromDistinctAscList [] = Nil+fromDistinctAscList (z0 : zs0) = work z0 zs0 Nada+ where+ work (kx,vx) [] stk = finish kx (Tip kx vx) stk+ work (kx,vx) (z@(kz,_):zs) stk = reduce z zs (branchMask kx kz) kx (Tip kx vx) stk++#ifdef __GLASGOW_HASKELL__+ reduce :: (Key,a) -> [(Key,a)] -> Mask -> Prefix -> IntMap a -> Stack a -> IntMap a+#endif+ reduce z zs _ px tx Nada = work z zs (Push px tx Nada)+ reduce z zs m px tx stk@(Push py ty stk') =+ let mxy = branchMask px py+ pxy = mask px mxy+ in if shorter m mxy+ then reduce z zs m pxy (Bin pxy mxy ty tx) stk'+ else work z zs (Push px tx stk)++ finish _ t Nada = t+ finish px tx (Push py ty stk) = finish p (join py ty px tx) stk+ where m = branchMask px py+ p = mask px m++data Stack a = Push {-# UNPACK #-} !Prefix !(IntMap a) !(Stack a) | Nada+++{--------------------------------------------------------------------+ Eq+--------------------------------------------------------------------}+instance Eq a => Eq (IntMap a) where+ t1 == t2 = equal t1 t2+ t1 /= t2 = nequal t1 t2++equal :: Eq a => IntMap a -> IntMap a -> Bool+equal (Bin p1 m1 l1 r1) (Bin p2 m2 l2 r2)+ = (m1 == m2) && (p1 == p2) && (equal l1 l2) && (equal r1 r2)+equal (Tip kx x) (Tip ky y)+ = (kx == ky) && (x==y)+equal Nil Nil = True+equal _ _ = False++nequal :: Eq a => IntMap a -> IntMap a -> Bool+nequal (Bin p1 m1 l1 r1) (Bin p2 m2 l2 r2)+ = (m1 /= m2) || (p1 /= p2) || (nequal l1 l2) || (nequal r1 r2)+nequal (Tip kx x) (Tip ky y)+ = (kx /= ky) || (x/=y)+nequal Nil Nil = False+nequal _ _ = True++{--------------------------------------------------------------------+ Ord+--------------------------------------------------------------------}++instance Ord a => Ord (IntMap a) where+ compare m1 m2 = compare (toList m1) (toList m2)++{--------------------------------------------------------------------+ Functor+--------------------------------------------------------------------}++instance Functor IntMap where+ fmap = map++{--------------------------------------------------------------------+ Show+--------------------------------------------------------------------}++instance Show a => Show (IntMap a) where+ showsPrec d m = showParen (d > 10) $+ showString "fromList " . shows (toList m)++{-+XXX unused code++showMap :: (Show a) => [(Key,a)] -> ShowS+showMap []+ = showString "{}"+showMap (x:xs)+ = showChar '{' . showElem x . showTail xs+ where+ showTail [] = showChar '}'+ showTail (x':xs') = showChar ',' . showElem x' . showTail xs'++ showElem (k,v) = shows k . showString ":=" . shows v+-}++{--------------------------------------------------------------------+ Read+--------------------------------------------------------------------}+instance (Read e) => Read (IntMap e) where+#ifdef __GLASGOW_HASKELL__+ readPrec = parens $ prec 10 $ do+ Ident "fromList" <- lexP+ xs <- readPrec+ return (fromList xs)++ readListPrec = readListPrecDefault+#else+ readsPrec p = readParen (p > 10) $ \ r -> do+ ("fromList",s) <- lex r+ (xs,t) <- reads s+ return (fromList xs,t)+#endif++{--------------------------------------------------------------------+ Debugging+--------------------------------------------------------------------}+-- | /O(n)/. Show the tree that implements the map. The tree is shown+-- in a compressed, hanging format.+showTree :: Show a => IntMap a -> String+showTree s+ = showTreeWith True False s+++{- | /O(n)/. The expression (@'showTreeWith' hang wide map@) shows+ the tree that implements the map. If @hang@ is+ 'True', a /hanging/ tree is shown otherwise a rotated tree is shown. If+ @wide@ is 'True', an extra wide version is shown.+-}+showTreeWith :: Show a => Bool -> Bool -> IntMap a -> String+showTreeWith hang wide t+ | hang = (showsTreeHang wide [] t) ""+ | otherwise = (showsTree wide [] [] t) ""++showsTree :: Show a => Bool -> [String] -> [String] -> IntMap a -> ShowS+showsTree wide lbars rbars t+ = case t of+ Bin p m l r+ -> showsTree wide (withBar rbars) (withEmpty rbars) r .+ showWide wide rbars .+ showsBars lbars . showString (showBin p m) . showString "\n" .+ showWide wide lbars .+ showsTree wide (withEmpty lbars) (withBar lbars) l+ Tip k x+ -> showsBars lbars . showString " " . shows k . showString ":=" . shows x . showString "\n"+ Nil -> showsBars lbars . showString "|\n"++showsTreeHang :: Show a => Bool -> [String] -> IntMap a -> ShowS+showsTreeHang wide bars t+ = case t of+ Bin p m l r+ -> showsBars bars . showString (showBin p m) . showString "\n" .+ showWide wide bars .+ showsTreeHang wide (withBar bars) l .+ showWide wide bars .+ showsTreeHang wide (withEmpty bars) r+ Tip k x+ -> showsBars bars . showString " " . shows k . showString ":=" . shows x . showString "\n"+ Nil -> showsBars bars . showString "|\n"++showBin :: Prefix -> Mask -> String+showBin _ _+ = "*" -- ++ show (p,m)++showWide :: Bool -> [String] -> String -> String+showWide wide bars+ | wide = showString (concat (reverse bars)) . showString "|\n"+ | otherwise = id++showsBars :: [String] -> ShowS+showsBars bars+ = case bars of+ [] -> id+ _ -> showString (concat (reverse (tail bars))) . showString node++node :: String+node = "+--"++withBar, withEmpty :: [String] -> [String]+withBar bars = "| ":bars+withEmpty bars = " ":bars+++{--------------------------------------------------------------------+ Helpers+--------------------------------------------------------------------}+{--------------------------------------------------------------------+ Join+--------------------------------------------------------------------}+join :: Prefix -> IntMap a -> Prefix -> IntMap a -> IntMap a+join p1 t1 p2 t2+ | zero p1 m = Bin p m t1 t2+ | otherwise = Bin p m t2 t1+ where+ m = branchMask p1 p2+ p = mask p1 m++{--------------------------------------------------------------------+ @bin@ assures that we never have empty trees within a tree.+--------------------------------------------------------------------}+bin :: Prefix -> Mask -> IntMap a -> IntMap a -> IntMap a+bin _ _ l Nil = l+bin _ _ Nil r = r+bin p m l r = Bin p m l r+++{--------------------------------------------------------------------+ Endian independent bit twiddling+--------------------------------------------------------------------}+zero :: Key -> Mask -> Bool+zero i m+ = (natFromInt i) .&. (natFromInt m) == 0++nomatch,match :: Key -> Prefix -> Mask -> Bool+nomatch i p m+ = (mask i m) /= p++match i p m+ = (mask i m) == p++mask :: Key -> Mask -> Prefix+mask i m+ = maskW (natFromInt i) (natFromInt m)+++zeroN :: Nat -> Nat -> Bool+zeroN i m = (i .&. m) == 0++{--------------------------------------------------------------------+ Big endian operations+--------------------------------------------------------------------}+maskW :: Nat -> Nat -> Prefix+maskW i m+ = intFromNat (i .&. (complement (m-1) `xor` m))++shorter :: Mask -> Mask -> Bool+shorter m1 m2+ = (natFromInt m1) > (natFromInt m2)++branchMask :: Prefix -> Prefix -> Mask+branchMask p1 p2+ = intFromNat (highestBitMask (natFromInt p1 `xor` natFromInt p2))++{----------------------------------------------------------------------+ Finding the highest bit (mask) in a word [x] can be done efficiently in+ three ways:+ * convert to a floating point value and the mantissa tells us the+ [log2(x)] that corresponds with the highest bit position. The mantissa+ is retrieved either via the standard C function [frexp] or by some bit+ twiddling on IEEE compatible numbers (float). Note that one needs to+ use at least [double] precision for an accurate mantissa of 32 bit+ numbers.+ * use bit twiddling, a logarithmic sequence of bitwise or's and shifts (bit).+ * use processor specific assembler instruction (asm).++ The most portable way would be [bit], but is it efficient enough?+ I have measured the cycle counts of the different methods on an AMD+ Athlon-XP 1800 (~ Pentium III 1.8Ghz) using the RDTSC instruction:++ highestBitMask: method cycles+ --------------+ frexp 200+ float 33+ bit 11+ asm 12++ highestBit: method cycles+ --------------+ frexp 195+ float 33+ bit 11+ asm 11++ Wow, the bit twiddling is on today's RISC like machines even faster+ than a single CISC instruction (BSR)!+----------------------------------------------------------------------}++{----------------------------------------------------------------------+ [highestBitMask] returns a word where only the highest bit is set.+ It is found by first setting all bits in lower positions than the+ highest bit and than taking an exclusive or with the original value.+ Allthough the function may look expensive, GHC compiles this into+ excellent C code that subsequently compiled into highly efficient+ machine code. The algorithm is derived from Jorg Arndt's FXT library.+----------------------------------------------------------------------}+highestBitMask :: Nat -> Nat+highestBitMask x0+ = case (x0 .|. shiftRL x0 1) of+ x1 -> case (x1 .|. shiftRL x1 2) of+ x2 -> case (x2 .|. shiftRL x2 4) of+ x3 -> case (x3 .|. shiftRL x3 8) of+ x4 -> case (x4 .|. shiftRL x4 16) of+ x5 -> case (x5 .|. shiftRL x5 32) of -- for 64 bit platforms+ x6 -> (x6 `xor` (shiftRL x6 1))+++{--------------------------------------------------------------------+ Utilities+--------------------------------------------------------------------}++foldlStrict :: (a -> b -> a) -> a -> [b] -> a+foldlStrict f = go+ where+ go z [] = z+ go z (x:xs) = z `seq` go (f z x) xs++-------------------------------------------------------------------------------+-- Very special operations.+++-- |Create an IntMap from IntSet. This is simpler and probably faster than+-- conversion to ascending lists and then to IntMap through zip.+{-# INLINE mapFromSetValue #-}+mapFromSetValue :: IntSet.IntSet -> a -> IntMap a+mapFromSetValue IntSet.Nil _ = Nil+mapFromSetValue (IntSet.Tip k) a = Tip k a+mapFromSetValue (IntSet.Bin pfx mask' l r) a = Bin pfx mask' (mapFromSetValue l a) (mapFromSetValue r a)++-- |This is unionWith where right operand represented as a IntSet of keys+-- and single value.+{-# INLINE unionWithSetValue #-}+unionWithSetValue :: (a -> a -> a) -> IntMap a -> IntSet.IntSet -> a -> IntMap a+unionWithSetValue f map' set def = unionWith f map' (mapFromSetValue set def)
+ src/GraphHammer/IntSet.hs view
@@ -0,0 +1,1102 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE MagicHash #-}++-- License: The Glasgow Haskell Compiler License+--+-- Copyright 2004, The University Court of the University of Glasgow.+-- All rights reserved.+--+-- Redistribution and use in source and binary forms, with or without+-- modification, are permitted provided that the following conditions are met:+--+-- - Redistributions of source code must retain the above copyright notice,+-- this list of conditions and the following disclaimer.+--+-- - Redistributions in binary form must reproduce the above copyright notice,+-- this list of conditions and the following disclaimer in the documentation+-- and/or other materials provided with the distribution.+--+-- - Neither name of the University nor the names of its contributors may be+-- used to endorse or promote products derived from this software without+-- specific prior written permission.+--+-- THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF+-- GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,+-- INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND+-- FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE+-- UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE+-- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR+-- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER+-- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT+-- LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY+-- OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH+-- DAMAGE.++-----------------------------------------------------------------------------+-- |+-- Module : Data.IntSet+-- Copyright : (c) Daan Leijen 2002+-- License : BSD-style+-- Maintainer : libraries@haskell.org+-- Stability : provisional+-- Portability : portable+--+-- An efficient implementation of integer sets.+--+-- Since many function names (but not the type name) clash with+-- "Prelude" names, this module is usually imported @qualified@, e.g.+--+-- > import Data.IntSet (IntSet)+-- > import qualified Data.IntSet as IntSet+--+-- The implementation is based on /big-endian patricia trees/. This data+-- structure performs especially well on binary operations like 'union'+-- and 'intersection'. However, my benchmarks show that it is also+-- (much) faster on insertions and deletions when compared to a generic+-- size-balanced set implementation (see "Data.Set").+--+-- * Chris Okasaki and Andy Gill, \"/Fast Mergeable Integer Maps/\",+-- Workshop on ML, September 1998, pages 77-86,+-- <http://citeseer.ist.psu.edu/okasaki98fast.html>+--+-- * D.R. Morrison, \"/PATRICIA -- Practical Algorithm To Retrieve+-- Information Coded In Alphanumeric/\", Journal of the ACM, 15(4),+-- October 1968, pages 514-534.+--+-- Many operations have a worst-case complexity of /O(min(n,W))/.+-- This means that the operation can become linear in the number of+-- elements with a maximum of /W/ -- the number of bits in an 'Int'+-- (32 or 64).+-----------------------------------------------------------------------------++module GraphHammer.IntSet (+ -- * Set type+ -- Exported with details for some faster operations in IntMap nearby (sergueyz).+ IntSet(..) -- instance Eq,Show++ -- * Operators+ , (\\)++ -- * Query+ , null+ , size+ , member+ , notMember+ , isSubsetOf+ , isProperSubsetOf++ -- * Construction+ , empty+ , singleton+ , insert+ , delete++ -- * Combine+ , union, unions+ , difference+ , intersection++ -- * Filter+ , filter+ , partition+ , split+ , splitMember++ -- * Min\/Max+ , findMin+ , findMax+ , deleteMin+ , deleteMax+ , deleteFindMin+ , deleteFindMax+ , maxView+ , minView++ -- * Map+ , map++ -- * Fold+ , fold++ -- * Conversion+ -- ** List+ , elems+ , toList+ , fromList++ -- ** Ordered list+ , toAscList+ , fromAscList+ , fromDistinctAscList++ -- * Debugging+ , showTree+ , showTreeWith+ ) where+++import Prelude hiding (lookup,filter,foldr,foldl,null,map)+import Data.Bits++import qualified Data.List as List+import Data.Monoid (Monoid(..))+import Data.Maybe (fromMaybe)+import Data.Int+import Data.Word++import Text.Read++infixl 9 \\{-This comment teaches CPP correct behaviour -}++-- A "Nat" is a natural machine word (an unsigned Int)+type Nat = Word32++natFromInt :: Int32 -> Nat+natFromInt i = fromIntegral i++intFromNat :: Nat -> Int32+intFromNat w = fromIntegral w++shiftRL :: Nat -> Int -> Nat+shiftRL x i = shiftR x i++{--------------------------------------------------------------------+ Operators+--------------------------------------------------------------------}+-- | /O(n+m)/. See 'difference'.+(\\) :: IntSet -> IntSet -> IntSet+m1 \\ m2 = difference m1 m2++{--------------------------------------------------------------------+ Types+--------------------------------------------------------------------}+-- | A set of integers.+data IntSet = Nil+ | Tip {-# UNPACK #-} !Key+ | Bin {-# UNPACK #-} !Prefix {-# UNPACK #-} !Mask !IntSet !IntSet+-- Invariant: Nil is never found as a child of Bin.+-- Invariant: The Mask is a power of 2. It is the largest bit position at which+-- two elements of the set differ.+-- Invariant: Prefix is the common high-order bits that all elements share to+-- the left of the Mask bit.+-- Invariant: In Bin prefix mask left right, left consists of the elements that+-- don't have the mask bit set; right is all the elements that do.+++type Key = Int32+type Prefix = Int32+type Mask = Int32++instance Monoid IntSet where+ mempty = empty+ mappend = union+ mconcat = unions++{--------------------------------------------------------------------+ Query+--------------------------------------------------------------------}+-- | /O(1)/. Is the set empty?+null :: IntSet -> Bool+null Nil = True+null _ = False++-- | /O(n)/. Cardinality of the set.+size :: IntSet -> Int+size t+ = case t of+ Bin _ _ l r -> size l + size r+ Tip _ -> 1+ Nil -> 0++-- | /O(min(n,W))/. Is the value a member of the set?+member :: Key -> IntSet -> Bool+member x t+ = case t of+ Bin p m l r+ | nomatch x p m -> False+ | zero x m -> member x l+ | otherwise -> member x r+ Tip y -> (x==y)+ Nil -> False++-- | /O(min(n,W))/. Is the element not in the set?+notMember :: Key -> IntSet -> Bool+notMember k = not . member k++-- 'lookup' is used by 'intersection' for left-biasing+lookup :: Key -> IntSet -> Maybe Key+lookup k t+ = let nk = natFromInt k in seq nk (lookupN nk t)++lookupN :: Nat -> IntSet -> Maybe Key+lookupN k t+ = case t of+ Bin _ m l r+ | zeroN k (natFromInt m) -> lookupN k l+ | otherwise -> lookupN k r+ Tip kx+ | (k == natFromInt kx) -> Just kx+ | otherwise -> Nothing+ Nil -> Nothing++{--------------------------------------------------------------------+ Construction+--------------------------------------------------------------------}+-- | /O(1)/. The empty set.+empty :: IntSet+empty+ = Nil++-- | /O(1)/. A set of one element.+singleton :: Key -> IntSet+singleton x+ = Tip x++{--------------------------------------------------------------------+ Insert+--------------------------------------------------------------------}+-- | /O(min(n,W))/. Add a value to the set. When the value is already+-- an element of the set, it is replaced by the new one, ie. 'insert'+-- is left-biased.+insert :: Key -> IntSet -> IntSet+insert x t+ = case t of+ Bin p m l r+ | nomatch x p m -> join x (Tip x) p t+ | zero x m -> Bin p m (insert x l) r+ | otherwise -> Bin p m l (insert x r)+ Tip y+ | x==y -> Tip x+ | otherwise -> join x (Tip x) y t+ Nil -> Tip x++-- right-biased insertion, used by 'union'+insertR :: Key -> IntSet -> IntSet+insertR x t+ = case t of+ Bin p m l r+ | nomatch x p m -> join x (Tip x) p t+ | zero x m -> Bin p m (insert x l) r+ | otherwise -> Bin p m l (insert x r)+ Tip y+ | x==y -> t+ | otherwise -> join x (Tip x) y t+ Nil -> Tip x++-- | /O(min(n,W))/. Delete a value in the set. Returns the+-- original set when the value was not present.+delete :: Key -> IntSet -> IntSet+delete x t+ = case t of+ Bin p m l r+ | nomatch x p m -> t+ | zero x m -> bin p m (delete x l) r+ | otherwise -> bin p m l (delete x r)+ Tip y+ | x==y -> Nil+ | otherwise -> t+ Nil -> Nil+++{--------------------------------------------------------------------+ Union+--------------------------------------------------------------------}+-- | The union of a list of sets.+unions :: [IntSet] -> IntSet+unions xs+ = foldlStrict union empty xs+++-- | /O(n+m)/. The union of two sets.+union :: IntSet -> IntSet -> IntSet+union t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)+ | shorter m1 m2 = union1+ | shorter m2 m1 = union2+ | p1 == p2 = Bin p1 m1 (union l1 l2) (union r1 r2)+ | otherwise = join p1 t1 p2 t2+ where+ union1 | nomatch p2 p1 m1 = join p1 t1 p2 t2+ | zero p2 m1 = Bin p1 m1 (union l1 t2) r1+ | otherwise = Bin p1 m1 l1 (union r1 t2)++ union2 | nomatch p1 p2 m2 = join p1 t1 p2 t2+ | zero p1 m2 = Bin p2 m2 (union t1 l2) r2+ | otherwise = Bin p2 m2 l2 (union t1 r2)++union (Tip x) t = insert x t+union t (Tip x) = insertR x t -- right bias+union Nil t = t+union t Nil = t+++{--------------------------------------------------------------------+ Difference+--------------------------------------------------------------------}+-- | /O(n+m)/. Difference between two sets.+difference :: IntSet -> IntSet -> IntSet+difference t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)+ | shorter m1 m2 = difference1+ | shorter m2 m1 = difference2+ | p1 == p2 = bin p1 m1 (difference l1 l2) (difference r1 r2)+ | otherwise = t1+ where+ difference1 | nomatch p2 p1 m1 = t1+ | zero p2 m1 = bin p1 m1 (difference l1 t2) r1+ | otherwise = bin p1 m1 l1 (difference r1 t2)++ difference2 | nomatch p1 p2 m2 = t1+ | zero p1 m2 = difference t1 l2+ | otherwise = difference t1 r2++difference t1@(Tip x) t2+ | member x t2 = Nil+ | otherwise = t1++difference Nil _ = Nil+difference t (Tip x) = delete x t+difference t Nil = t++++{--------------------------------------------------------------------+ Intersection+--------------------------------------------------------------------}+-- | /O(n+m)/. The intersection of two sets.+intersection :: IntSet -> IntSet -> IntSet+intersection t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)+ | shorter m1 m2 = intersection1+ | shorter m2 m1 = intersection2+ | p1 == p2 = bin p1 m1 (intersection l1 l2) (intersection r1 r2)+ | otherwise = Nil+ where+ intersection1 | nomatch p2 p1 m1 = Nil+ | zero p2 m1 = intersection l1 t2+ | otherwise = intersection r1 t2++ intersection2 | nomatch p1 p2 m2 = Nil+ | zero p1 m2 = intersection t1 l2+ | otherwise = intersection t1 r2++intersection t1@(Tip x) t2+ | member x t2 = t1+ | otherwise = Nil+intersection t (Tip x)+ = case lookup x t of+ Just y -> Tip y+ Nothing -> Nil+intersection Nil _ = Nil+intersection _ Nil = Nil++++{--------------------------------------------------------------------+ Subset+--------------------------------------------------------------------}+-- | /O(n+m)/. Is this a proper subset? (ie. a subset but not equal).+isProperSubsetOf :: IntSet -> IntSet -> Bool+isProperSubsetOf t1 t2+ = case subsetCmp t1 t2 of+ LT -> True+ _ -> False++subsetCmp :: IntSet -> IntSet -> Ordering+subsetCmp t1@(Bin p1 m1 l1 r1) (Bin p2 m2 l2 r2)+ | shorter m1 m2 = GT+ | shorter m2 m1 = case subsetCmpLt of+ GT -> GT+ _ -> LT+ | p1 == p2 = subsetCmpEq+ | otherwise = GT -- disjoint+ where+ subsetCmpLt | nomatch p1 p2 m2 = GT+ | zero p1 m2 = subsetCmp t1 l2+ | otherwise = subsetCmp t1 r2+ subsetCmpEq = case (subsetCmp l1 l2, subsetCmp r1 r2) of+ (GT,_ ) -> GT+ (_ ,GT) -> GT+ (EQ,EQ) -> EQ+ _ -> LT++subsetCmp (Bin _ _ _ _) _ = GT+subsetCmp (Tip x) (Tip y)+ | x==y = EQ+ | otherwise = GT -- disjoint+subsetCmp (Tip x) t+ | member x t = LT+ | otherwise = GT -- disjoint+subsetCmp Nil Nil = EQ+subsetCmp Nil _ = LT++-- | /O(n+m)/. Is this a subset?+-- @(s1 `isSubsetOf` s2)@ tells whether @s1@ is a subset of @s2@.++isSubsetOf :: IntSet -> IntSet -> Bool+isSubsetOf t1@(Bin p1 m1 l1 r1) (Bin p2 m2 l2 r2)+ | shorter m1 m2 = False+ | shorter m2 m1 = match p1 p2 m2 && (if zero p1 m2 then isSubsetOf t1 l2+ else isSubsetOf t1 r2)+ | otherwise = (p1==p2) && isSubsetOf l1 l2 && isSubsetOf r1 r2+isSubsetOf (Bin _ _ _ _) _ = False+isSubsetOf (Tip x) t = member x t+isSubsetOf Nil _ = True+++{--------------------------------------------------------------------+ Filter+--------------------------------------------------------------------}+-- | /O(n)/. Filter all elements that satisfy some predicate.+filter :: (Key -> Bool) -> IntSet -> IntSet+filter predicate t+ = case t of+ Bin p m l r+ -> bin p m (filter predicate l) (filter predicate r)+ Tip x+ | predicate x -> t+ | otherwise -> Nil+ Nil -> Nil++-- | /O(n)/. partition the set according to some predicate.+partition :: (Key -> Bool) -> IntSet -> (IntSet,IntSet)+partition predicate t+ = case t of+ Bin p m l r+ -> let (l1,l2) = partition predicate l+ (r1,r2) = partition predicate r+ in (bin p m l1 r1, bin p m l2 r2)+ Tip x+ | predicate x -> (t,Nil)+ | otherwise -> (Nil,t)+ Nil -> (Nil,Nil)+++-- | /O(min(n,W))/. The expression (@'split' x set@) is a pair @(set1,set2)@+-- where @set1@ comprises the elements of @set@ less than @x@ and @set2@+-- comprises the elements of @set@ greater than @x@.+--+-- > split 3 (fromList [1..5]) == (fromList [1,2], fromList [4,5])+split :: Key -> IntSet -> (IntSet,IntSet)+split x t+ = case t of+ Bin _ m l r+ | m < 0 -> if x >= 0 then let (lt,gt) = split' x l in (union r lt, gt)+ else let (lt,gt) = split' x r in (lt, union gt l)+ -- handle negative numbers.+ | otherwise -> split' x t+ Tip y+ | x>y -> (t,Nil)+ | x<y -> (Nil,t)+ | otherwise -> (Nil,Nil)+ Nil -> (Nil, Nil)++split' :: Key -> IntSet -> (IntSet,IntSet)+split' x t+ = case t of+ Bin p m l r+ | match x p m -> if zero x m then let (lt,gt) = split' x l in (lt,union gt r)+ else let (lt,gt) = split' x r in (union l lt,gt)+ | otherwise -> if x < p then (Nil, t)+ else (t, Nil)+ Tip y+ | x>y -> (t,Nil)+ | x<y -> (Nil,t)+ | otherwise -> (Nil,Nil)+ Nil -> (Nil,Nil)++-- | /O(min(n,W))/. Performs a 'split' but also returns whether the pivot+-- element was found in the original set.+splitMember :: Key -> IntSet -> (IntSet,Bool,IntSet)+splitMember x t+ = case t of+ Bin _ m l r+ | m < 0 -> if x >= 0 then let (lt,found,gt) = splitMember' x l in (union r lt, found, gt)+ else let (lt,found,gt) = splitMember' x r in (lt, found, union gt l)+ -- handle negative numbers.+ | otherwise -> splitMember' x t+ Tip y+ | x>y -> (t,False,Nil)+ | x<y -> (Nil,False,t)+ | otherwise -> (Nil,True,Nil)+ Nil -> (Nil,False,Nil)++splitMember' :: Key -> IntSet -> (IntSet,Bool,IntSet)+splitMember' x t+ = case t of+ Bin p m l r+ | match x p m -> if zero x m then let (lt,found,gt) = splitMember x l in (lt,found,union gt r)+ else let (lt,found,gt) = splitMember x r in (union l lt,found,gt)+ | otherwise -> if x < p then (Nil, False, t)+ else (t, False, Nil)+ Tip y+ | x>y -> (t,False,Nil)+ | x<y -> (Nil,False,t)+ | otherwise -> (Nil,True,Nil)+ Nil -> (Nil,False,Nil)++{----------------------------------------------------------------------+ Min/Max+----------------------------------------------------------------------}++-- | /O(min(n,W))/. Retrieves the maximal key of the set, and the set+-- stripped of that element, or 'Nothing' if passed an empty set.+maxView :: IntSet -> Maybe (Key, IntSet)+maxView t+ = case t of+ Bin p m l r | m < 0 -> let (result,t') = maxViewUnsigned l in Just (result, bin p m t' r)+ Bin p m l r -> let (result,t') = maxViewUnsigned r in Just (result, bin p m l t')+ Tip y -> Just (y,Nil)+ Nil -> Nothing++maxViewUnsigned :: IntSet -> (Key, IntSet)+maxViewUnsigned t+ = case t of+ Bin p m l r -> let (result,t') = maxViewUnsigned r in (result, bin p m l t')+ Tip y -> (y, Nil)+ Nil -> error "maxViewUnsigned Nil"++-- | /O(min(n,W))/. Retrieves the minimal key of the set, and the set+-- stripped of that element, or 'Nothing' if passed an empty set.+minView :: IntSet -> Maybe (Key, IntSet)+minView t+ = case t of+ Bin p m l r | m < 0 -> let (result,t') = minViewUnsigned r in Just (result, bin p m l t')+ Bin p m l r -> let (result,t') = minViewUnsigned l in Just (result, bin p m t' r)+ Tip y -> Just (y, Nil)+ Nil -> Nothing++minViewUnsigned :: IntSet -> (Key, IntSet)+minViewUnsigned t+ = case t of+ Bin p m l r -> let (result,t') = minViewUnsigned l in (result, bin p m t' r)+ Tip y -> (y, Nil)+ Nil -> error "minViewUnsigned Nil"++-- | /O(min(n,W))/. Delete and find the minimal element.+--+-- > deleteFindMin set = (findMin set, deleteMin set)+deleteFindMin :: IntSet -> (Key, IntSet)+deleteFindMin = fromMaybe (error "deleteFindMin: empty set has no minimal element") . minView++-- | /O(min(n,W))/. Delete and find the maximal element.+--+-- > deleteFindMax set = (findMax set, deleteMax set)+deleteFindMax :: IntSet -> (Key, IntSet)+deleteFindMax = fromMaybe (error "deleteFindMax: empty set has no maximal element") . maxView+++-- | /O(min(n,W))/. The minimal element of the set.+findMin :: IntSet -> Key+findMin Nil = error "findMin: empty set has no minimal element"+findMin (Tip x) = x+findMin (Bin _ m l r)+ | m < 0 = find r+ | otherwise = find l+ where find (Tip x) = x+ find (Bin _ _ l' _) = find l'+ find Nil = error "findMin Nil"++-- | /O(min(n,W))/. The maximal element of a set.+findMax :: IntSet -> Key+findMax Nil = error "findMax: empty set has no maximal element"+findMax (Tip x) = x+findMax (Bin _ m l r)+ | m < 0 = find l+ | otherwise = find r+ where find (Tip x) = x+ find (Bin _ _ _ r') = find r'+ find Nil = error "findMax Nil"+++-- | /O(min(n,W))/. Delete the minimal element.+deleteMin :: IntSet -> IntSet+deleteMin = maybe (error "deleteMin: empty set has no minimal element") snd . minView++-- | /O(min(n,W))/. Delete the maximal element.+deleteMax :: IntSet -> IntSet+deleteMax = maybe (error "deleteMax: empty set has no maximal element") snd . maxView++{----------------------------------------------------------------------+ Map+----------------------------------------------------------------------}++-- | /O(n*min(n,W))/.+-- @'map' f s@ is the set obtained by applying @f@ to each element of @s@.+--+-- It's worth noting that the size of the result may be smaller if,+-- for some @(x,y)@, @x \/= y && f x == f y@++map :: (Key->Key) -> IntSet -> IntSet+map f = fromList . List.map f . toList++{--------------------------------------------------------------------+ Fold+--------------------------------------------------------------------}+-- | /O(n)/. Fold over the elements of a set in an unspecified order.+--+-- > sum set == fold (+) 0 set+-- > elems set == fold (:) [] set+fold :: (Key -> b -> b) -> b -> IntSet -> b+fold f z t+ = case t of+ Bin 0 m l r | m < 0 -> foldr f (foldr f z l) r+ -- put negative numbers before.+ Bin _ _ _ _ -> foldr f z t+ Tip x -> f x z+ Nil -> z++foldr :: (Key -> b -> b) -> b -> IntSet -> b+foldr f z t+ = case t of+ Bin _ _ l r -> foldr f (foldr f z r) l+ Tip x -> f x z+ Nil -> z++{--------------------------------------------------------------------+ List variations+--------------------------------------------------------------------}+-- | /O(n)/. The elements of a set. (For sets, this is equivalent to toList)+elems :: IntSet -> [Key]+elems s+ = toList s++{--------------------------------------------------------------------+ Lists+--------------------------------------------------------------------}+-- | /O(n)/. Convert the set to a list of elements.+toList :: IntSet -> [Key]+toList t+ = fold (:) [] t++-- | /O(n)/. Convert the set to an ascending list of elements.+toAscList :: IntSet -> [Key]+toAscList t = toList t++-- | /O(n*min(n,W))/. Create a set from a list of integers.+fromList :: [Key] -> IntSet+fromList xs+ = foldlStrict ins empty xs+ where+ ins t x = insert x t++-- | /O(n)/. Build a set from an ascending list of elements.+-- /The precondition (input list is ascending) is not checked./+fromAscList :: [Key] -> IntSet+fromAscList [] = Nil+fromAscList (x0 : xs0) = fromDistinctAscList (combineEq x0 xs0)+ where+ combineEq x' [] = [x']+ combineEq x' (x:xs)+ | x==x' = combineEq x' xs+ | otherwise = x' : combineEq x xs++-- | /O(n)/. Build a set from an ascending list of distinct elements.+-- /The precondition (input list is strictly ascending) is not checked./+fromDistinctAscList :: [Key] -> IntSet+fromDistinctAscList [] = Nil+fromDistinctAscList (z0 : zs0) = work z0 zs0 Nada+ where+ work x [] stk = finish x (Tip x) stk+ work x (z:zs) stk = reduce z zs (branchMask z x) x (Tip x) stk++ reduce z zs _ px tx Nada = work z zs (Push px tx Nada)+ reduce z zs m px tx stk@(Push py ty stk') =+ let mxy = branchMask px py+ pxy = mask px mxy+ in if shorter m mxy+ then reduce z zs m pxy (Bin pxy mxy ty tx) stk'+ else work z zs (Push px tx stk)++ finish _ t Nada = t+ finish px tx (Push py ty stk) = finish p (join py ty px tx) stk+ where m = branchMask px py+ p = mask px m++data Stack = Push {-# UNPACK #-} !Prefix !IntSet !Stack | Nada+++{--------------------------------------------------------------------+ Eq+--------------------------------------------------------------------}+instance Eq IntSet where+ t1 == t2 = equal t1 t2+ t1 /= t2 = nequal t1 t2++equal :: IntSet -> IntSet -> Bool+equal (Bin p1 m1 l1 r1) (Bin p2 m2 l2 r2)+ = (m1 == m2) && (p1 == p2) && (equal l1 l2) && (equal r1 r2)+equal (Tip x) (Tip y)+ = (x==y)+equal Nil Nil = True+equal _ _ = False++nequal :: IntSet -> IntSet -> Bool+nequal (Bin p1 m1 l1 r1) (Bin p2 m2 l2 r2)+ = (m1 /= m2) || (p1 /= p2) || (nequal l1 l2) || (nequal r1 r2)+nequal (Tip x) (Tip y)+ = (x/=y)+nequal Nil Nil = False+nequal _ _ = True++{--------------------------------------------------------------------+ Ord+--------------------------------------------------------------------}++instance Ord IntSet where+ compare s1 s2 = compare (toAscList s1) (toAscList s2)+ -- tentative implementation. See if more efficient exists.++{--------------------------------------------------------------------+ Show+--------------------------------------------------------------------}+instance Show IntSet where+ showsPrec p xs = showParen (p > 10) $+ showString "fromList " . shows (toList xs)++{-+XXX unused code+showSet :: [Int] -> ShowS+showSet []+ = showString "{}"+showSet (x:xs)+ = showChar '{' . shows x . showTail xs+ where+ showTail [] = showChar '}'+ showTail (x':xs') = showChar ',' . shows x' . showTail xs'+-}++{--------------------------------------------------------------------+ Read+--------------------------------------------------------------------}+instance Read IntSet where+#ifdef __GLASGOW_HASKELL__+ readPrec = parens $ prec 10 $ do+ Ident "fromList" <- lexP+ xs <- readPrec+ return (fromList xs)++ readListPrec = readListPrecDefault+#else+ readsPrec p = readParen (p > 10) $ \ r -> do+ ("fromList",s) <- lex r+ (xs,t) <- reads s+ return (fromList xs,t)+#endif++{--------------------------------------------------------------------+ Typeable+--------------------------------------------------------------------}++{--------------------------------------------------------------------+ Debugging+--------------------------------------------------------------------}+-- | /O(n)/. Show the tree that implements the set. The tree is shown+-- in a compressed, hanging format.+showTree :: IntSet -> String+showTree s+ = showTreeWith True False s+++{- | /O(n)/. The expression (@'showTreeWith' hang wide map@) shows+ the tree that implements the set. If @hang@ is+ 'True', a /hanging/ tree is shown otherwise a rotated tree is shown. If+ @wide@ is 'True', an extra wide version is shown.+-}+showTreeWith :: Bool -> Bool -> IntSet -> String+showTreeWith hang wide t+ | hang = (showsTreeHang wide [] t) ""+ | otherwise = (showsTree wide [] [] t) ""++showsTree :: Bool -> [String] -> [String] -> IntSet -> ShowS+showsTree wide lbars rbars t+ = case t of+ Bin p m l r+ -> showsTree wide (withBar rbars) (withEmpty rbars) r .+ showWide wide rbars .+ showsBars lbars . showString (showBin p m) . showString "\n" .+ showWide wide lbars .+ showsTree wide (withEmpty lbars) (withBar lbars) l+ Tip x+ -> showsBars lbars . showString " " . shows x . showString "\n"+ Nil -> showsBars lbars . showString "|\n"++showsTreeHang :: Bool -> [String] -> IntSet -> ShowS+showsTreeHang wide bars t+ = case t of+ Bin p m l r+ -> showsBars bars . showString (showBin p m) . showString "\n" .+ showWide wide bars .+ showsTreeHang wide (withBar bars) l .+ showWide wide bars .+ showsTreeHang wide (withEmpty bars) r+ Tip x+ -> showsBars bars . showString " " . shows x . showString "\n"+ Nil -> showsBars bars . showString "|\n"++showBin :: Prefix -> Mask -> String+showBin _ _+ = "*" -- ++ show (p,m)++showWide :: Bool -> [String] -> String -> String+showWide wide bars+ | wide = showString (concat (reverse bars)) . showString "|\n"+ | otherwise = id++showsBars :: [String] -> ShowS+showsBars bars+ = case bars of+ [] -> id+ _ -> showString (concat (reverse (tail bars))) . showString node++node :: String+node = "+--"++withBar, withEmpty :: [String] -> [String]+withBar bars = "| ":bars+withEmpty bars = " ":bars+++{--------------------------------------------------------------------+ Helpers+--------------------------------------------------------------------}+{--------------------------------------------------------------------+ Join+--------------------------------------------------------------------}+join :: Prefix -> IntSet -> Prefix -> IntSet -> IntSet+join p1 t1 p2 t2+ | zero p1 m = Bin p m t1 t2+ | otherwise = Bin p m t2 t1+ where+ m = branchMask p1 p2+ p = mask p1 m++{--------------------------------------------------------------------+ @bin@ assures that we never have empty trees within a tree.+--------------------------------------------------------------------}+bin :: Prefix -> Mask -> IntSet -> IntSet -> IntSet+bin _ _ l Nil = l+bin _ _ Nil r = r+bin p m l r = Bin p m l r+++{--------------------------------------------------------------------+ Endian independent bit twiddling+--------------------------------------------------------------------}+zero :: Key -> Mask -> Bool+zero i m+ = (natFromInt i) .&. (natFromInt m) == 0++nomatch,match :: Key -> Prefix -> Mask -> Bool+nomatch i p m+ = (mask i m) /= p++match i p m+ = (mask i m) == p++-- Suppose a is largest such that 2^a divides 2*m.+-- Then mask i m is i with the low a bits zeroed out.+mask :: Key -> Mask -> Prefix+mask i m+ = maskW (natFromInt i) (natFromInt m)++zeroN :: Nat -> Nat -> Bool+zeroN i m = (i .&. m) == 0++{--------------------------------------------------------------------+ Big endian operations+--------------------------------------------------------------------}+maskW :: Nat -> Nat -> Prefix+maskW i m+ = intFromNat (i .&. (complement (m-1) `xor` m))++shorter :: Mask -> Mask -> Bool+shorter m1 m2+ = (natFromInt m1) > (natFromInt m2)++branchMask :: Prefix -> Prefix -> Mask+branchMask p1 p2+ = intFromNat (highestBitMask (natFromInt p1 `xor` natFromInt p2))++{----------------------------------------------------------------------+ Finding the highest bit (mask) in a word [x] can be done efficiently in+ three ways:+ * convert to a floating point value and the mantissa tells us the+ [log2(x)] that corresponds with the highest bit position. The mantissa+ is retrieved either via the standard C function [frexp] or by some bit+ twiddling on IEEE compatible numbers (float). Note that one needs to+ use at least [double] precision for an accurate mantissa of 32 bit+ numbers.+ * use bit twiddling, a logarithmic sequence of bitwise or's and shifts (bit).+ * use processor specific assembler instruction (asm).++ The most portable way would be [bit], but is it efficient enough?+ I have measured the cycle counts of the different methods on an AMD+ Athlon-XP 1800 (~ Pentium III 1.8Ghz) using the RDTSC instruction:++ highestBitMask: method cycles+ --------------+ frexp 200+ float 33+ bit 11+ asm 12++ highestBit: method cycles+ --------------+ frexp 195+ float 33+ bit 11+ asm 11++ Wow, the bit twiddling is on today's RISC like machines even faster+ than a single CISC instruction (BSR)!+----------------------------------------------------------------------}++{----------------------------------------------------------------------+ [highestBitMask] returns a word where only the highest bit is set.+ It is found by first setting all bits in lower positions than the+ highest bit and than taking an exclusive or with the original value.+ Allthough the function may look expensive, GHC compiles this into+ excellent C code that subsequently compiled into highly efficient+ machine code. The algorithm is derived from Jorg Arndt's FXT library.+----------------------------------------------------------------------}+highestBitMask :: Nat -> Nat+highestBitMask x0+ = case (x0 .|. shiftRL x0 1) of+ x1 -> case (x1 .|. shiftRL x1 2) of+ x2 -> case (x2 .|. shiftRL x2 4) of+ x3 -> case (x3 .|. shiftRL x3 8) of+ x4 -> case (x4 .|. shiftRL x4 16) of+ x5 -> case (x5 .|. shiftRL x5 32) of -- for 64 bit platforms+ x6 -> (x6 `xor` (shiftRL x6 1))+++{--------------------------------------------------------------------+ Utilities+--------------------------------------------------------------------}+foldlStrict :: (a -> b -> a) -> a -> [b] -> a+foldlStrict f z xs+ = case xs of+ [] -> z+ (x:xx) -> let z' = f z x in seq z' (foldlStrict f z' xx)+++{-+{--------------------------------------------------------------------+ Testing+--------------------------------------------------------------------}+testTree :: [Int] -> IntSet+testTree xs = fromList xs+test1 = testTree [1..20]+test2 = testTree [30,29..10]+test3 = testTree [1,4,6,89,2323,53,43,234,5,79,12,9,24,9,8,423,8,42,4,8,9,3]++{--------------------------------------------------------------------+ QuickCheck+--------------------------------------------------------------------}+qcheck prop+ = check config prop+ where+ config = Config+ { configMaxTest = 500+ , configMaxFail = 5000+ , configSize = \n -> (div n 2 + 3)+ , configEvery = \n args -> let s = show n in s ++ [ '\b' | _ <- s ]+ }+++{--------------------------------------------------------------------+ Arbitrary, reasonably balanced trees+--------------------------------------------------------------------}+instance Arbitrary IntSet where+ arbitrary = do{ xs <- arbitrary+ ; return (fromList xs)+ }+++{--------------------------------------------------------------------+ Single, Insert, Delete+--------------------------------------------------------------------}+prop_Single :: Int -> Bool+prop_Single x+ = (insert x empty == singleton x)++prop_InsertDelete :: Int -> IntSet -> Property+prop_InsertDelete k t+ = not (member k t) ==> delete k (insert k t) == t+++{--------------------------------------------------------------------+ Union+--------------------------------------------------------------------}+prop_UnionInsert :: Int -> IntSet -> Bool+prop_UnionInsert x t+ = union t (singleton x) == insert x t++prop_UnionAssoc :: IntSet -> IntSet -> IntSet -> Bool+prop_UnionAssoc t1 t2 t3+ = union t1 (union t2 t3) == union (union t1 t2) t3++prop_UnionComm :: IntSet -> IntSet -> Bool+prop_UnionComm t1 t2+ = (union t1 t2 == union t2 t1)++prop_Diff :: [Int] -> [Int] -> Bool+prop_Diff xs ys+ = toAscList (difference (fromList xs) (fromList ys))+ == List.sort ((List.\\) (nub xs) (nub ys))++prop_Int :: [Int] -> [Int] -> Bool+prop_Int xs ys+ = toAscList (intersection (fromList xs) (fromList ys))+ == List.sort (nub ((List.intersect) (xs) (ys)))++{--------------------------------------------------------------------+ Lists+--------------------------------------------------------------------}+prop_Ordered+ = forAll (choose (5,100)) $ \n ->+ let xs = concat [[i-n,i-n]|i<-[0..2*n :: Int]]+ in fromAscList xs == fromList xs++prop_List :: [Int] -> Bool+prop_List xs+ = (sort (nub xs) == toAscList (fromList xs))++{--------------------------------------------------------------------+ Bin invariants+--------------------------------------------------------------------}+powersOf2 :: IntSet+powersOf2 = fromList [2^i | i <- [0..63]]++-- Check the invariant that the mask is a power of 2.+prop_MaskPow2 :: IntSet -> Bool+prop_MaskPow2 (Bin _ msk left right) = member msk powersOf2 && prop_MaskPow2 left && prop_MaskPow2 right+prop_MaskPow2 _ = True++-- Check that the prefix satisfies its invariant.+prop_Prefix :: IntSet -> Bool+prop_Prefix s@(Bin prefix msk left right) = all (\elem -> match elem prefix msk) (toList s) && prop_Prefix left && prop_Prefix right+prop_Prefix _ = True++-- Check that the left elements don't have the mask bit set, and the right+-- ones do.+prop_LeftRight :: IntSet -> Bool+prop_LeftRight (Bin _ msk left right) = and [x .&. msk == 0 | x <- toList left] && and [x .&. msk == msk | x <- toList right]+prop_LeftRight _ = True++{--------------------------------------------------------------------+ IntSet operations are like Set operations+--------------------------------------------------------------------}+toSet :: IntSet -> Set.Set Int+toSet = Set.fromList . toList++-- Check that IntSet.isProperSubsetOf is the same as Set.isProperSubsetOf.+prop_isProperSubsetOf :: IntSet -> IntSet -> Bool+prop_isProperSubsetOf a b = isProperSubsetOf a b == Set.isProperSubsetOf (toSet a) (toSet b)++-- In the above test, isProperSubsetOf almost always returns False (since a+-- random set is almost never a subset of another random set). So this second+-- test checks the True case.+prop_isProperSubsetOf2 :: IntSet -> IntSet -> Bool+prop_isProperSubsetOf2 a b = isProperSubsetOf a c == (a /= c) where+ c = union a b+-}
+ src/GraphHammer/SimplestParallel.hs view
@@ -0,0 +1,1349 @@+-- |+-- Module : GraphHammer.SimplestParallel+-- Copyright : (C) 2013 Parallel Scientific Labs, LLC.+-- License : GPLv2+--+-- Simplest and slowest implementation for GraphHammer data structure and+-- analyses combination. It is used for API prototyping. This version is+-- extended with parallel execution of analyses.++{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE IncoherentInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++module GraphHammer.SimplestParallel(+ Index -- from G500.+ -- * HList+ , Nil+ , (:.)++ -- * Representation exported abstractly+ , GraphHammer+ -- ** How to create a new GraphHammer.+ , graphHammerNew++ -- ** An analysis monad to create operations with GraphHammer.+ , GraphHammerM+ , runAnalysesStack++ -- ** Local values processing.+ , Value+ , Composed+ , localValue+ , cst+ , ($=)+ , (+.), (-.), (*.), divV+ , (===), (=/=)++ -- * Analysis type. Abstract.+ , Analysis+ , AnM+ , onEdges+ , anIf+ , getAnalysisResult+ , putAnalysisResult+ , incrementAnalysisResult+ , RequiredAnalyses+ -- ** How to create basic analysis, one which does not depend on the other.+ , basicAnalysis+ -- ** Derived analysis, dependent on some other.+ , derivedAnalysis+ , EnabledAnalysis, EnabledAnalyses+ ) where++import Control.Concurrent+import Control.Monad+import Control.Monad.State+import Data.Array+import Data.Array.IO+import qualified Data.Array.Unboxed as UA+import Data.Bits+import Data.Int+import Data.List (sort)+import Data.Time.Clock ( getCurrentTime, diffUTCTime )+import System.IO+import System.Mem (performGC)++import G500.Index+import GraphHammer.HList++import qualified GraphHammer.IntSet as ISet+import qualified GraphHammer.IntMap as IMap++-------------------------------------------------------------------------------+-- A (already not) very simple representation.+-- Allows one to work on graphs in parallel.++analysisSliceSizeShift :: Int+analysisSliceSizeShift = 8++analysisSliceSize :: Int+analysisSliceSize = 2^analysisSliceSizeShift++analysisSliceSizeMask :: Int+analysisSliceSizeMask = analysisSliceSize - 1++type IntMap a = IMap.IntMap a+type IntSet = ISet.IntSet++-- type IndexSet = Set.Set Index++type VertexAnalyses = IntMap Int64+type AnalysesMap = IntMap VertexAnalyses+type OtherAnalyses = IntMap AnalysesMap++-- First is analysis index, then vertex' local index shifted right by analysisSliceSizeShift+-- and the lat one is vertex' local index modulo analysisSliceSize.+-- This should be relatively small map. Constant number of analyses multiplied by+-- 2^30 (max number of vertices per thread) divided by analysisSliceSize.+-- Expect it to be about 2^12 or less.+type AnalysesArrays = Array Int32 (Array Int32 (IOUArray Int32 Int64))++type EdgeSet = IntMap VertexSet++-- |A representation parametrized by analyses required.+data GraphHammer as = GraphHammer {+ graphHammerMaxNodes :: !Int+ , graphHammerNodeIndex :: !Int+ , _graphHammerBatchCounter :: !Int+ , graphHammerEdges :: !EdgeSet+ -- Results of analyses.+ , graphHammerAnalyses :: !AnalysesArrays+ -- Nodes affected in current batch.+ , graphHammerNodesAffected :: !IntSet+ -- what analyses were changed in affected nodes.+ , _graphHammerAnalysesAffected :: !(IntMap Int)+ , graphHammerChannels :: !(Array Int32 (Chan (Msg as)))+ , graphHammerSendReceiveChannel :: !(Chan SendReceive)+ -- added per portion.+ , graphHammerPortionEdges :: (Array Int EdgeSet)+ -- increments for other nodes.+ -- a map from node index to analysis increments.+ , graphHammerOthersAnalyses :: !OtherAnalyses+ -- a map from node index to continuations.+ , graphHammerContinuationGroups :: !(IntMap [IntSt as])+ }++-- |Monad to operate with GraphHammer.+type GraphHammerM as a = StateT (GraphHammer as) IO a+++-------------------------------------------------------------------------------+-- Working with vertex sets.++data Vertex = Vertex { vertexNode, vertexIndex :: !Int32 }+ deriving (Eq, Ord, Show)++-- vertex set is a map from node to a set of local indices.+type VertexSet = IntMap IntSet++vertexSetEmpty :: forall a. IMap.IntMap a+vertexSetEmpty = IMap.empty++vertexSetIntersection :: IMap.IntMap ISet.IntSet+ -> IMap.IntMap ISet.IntSet -> IMap.IntMap ISet.IntSet+vertexSetIntersection a b = IMap.filter (not . ISet.null) $+ IMap.intersectionWith (ISet.intersection) a b++vertexSetUnion :: IMap.IntMap ISet.IntSet+ -> IMap.IntMap ISet.IntSet -> IMap.IntMap ISet.IntSet+vertexSetUnion a b = IMap.unionWith (ISet.union) a b++vertexSetToList :: VertexSet -> [Vertex]+vertexSetToList set = concatMap (\(n,iset) -> map (Vertex n) $ ISet.toList iset) $+ IMap.toList set++vertexToIndex :: (Integral b, Num a) => b -> Vertex -> a+vertexToIndex maxNodes vertex = fromIntegral (vertexNode vertex) ++ fromIntegral maxNodes * fromIntegral (vertexIndex vertex)++indexToVertex :: (Integral b, Integral a) => a -> b -> Vertex+indexToVertex maxNodes idx = Vertex (fromIntegral nodeIndex) (fromIntegral localIndex)+ where+ (localIndex,nodeIndex) = divMod idx (fromIntegral maxNodes)++vertexSetMember :: Vertex -> VertexSet -> Bool+vertexSetMember vertex set' = case IMap.lookup (vertexNode vertex) set' of+ Just set'' -> ISet.member (vertexIndex vertex) set''+ Nothing -> False++{-+vertexSetInsert :: Vertex -> VertexSet -> VertexSet+vertexSetInsert (Vertex node idx) vset = IMap.insertWith ISet.union node (ISet.singleton idx) vset+-}++vertexSetSingleton :: Vertex -> VertexSet+vertexSetSingleton (Vertex node idx) = IMap.singleton node (ISet.singleton idx)++vertexSetSize :: VertexSet -> Int+vertexSetSize set' = IMap.fold (+) 0 $ IMap.map ISet.size set'++-------------------------------------------------------------------------------+-- Main GraphHammer API.++-- | Create a GraphHammer structure for parallel GraphHammer processing.+graphHammerNew :: HLength as+ => Int -- ^ Max job nodes+ -> Int -- ^ Node index+ -> Chan SendReceive+ -> Array Int32 (Chan (Msg as))+ -> IO (GraphHammer as)+graphHammerNew maxNodes nodeIndex countingChan chans = do+ dummyAnalysisArrays <- liftM (array (0,0)) $ forM [0..0] $ \ai -> do+ aArr <- graphHammerNewAnalysisSliceArray+ return (ai,array (0,0) [(0,aArr)])+ let forwardResult = GraphHammer maxNodes nodeIndex 0 IMap.empty dummyAnalysisArrays+ ISet.empty IMap.empty chans countingChan (error "no portion edges!") IMap.empty IMap.empty+ let analysisProjection :: HLength as' => GraphHammer as' -> as'+ analysisProjection = error "analysisProjection result should be trated abstractly!"+ let analysisCount = hLength (analysisProjection forwardResult)+ let analysisHighIndex = analysisCount-1+ analysisArrays <- liftM (array (0,fromIntegral analysisHighIndex)) $ forM [0..fromIntegral analysisHighIndex] $ \ai -> do+ aArr <- graphHammerNewAnalysisSliceArray+ return (ai,array (0,0) [(0,aArr)])+ let result = forwardResult { graphHammerAnalyses = analysisArrays }+ return result++graphHammerCountReceived :: GraphHammerM as ()+graphHammerCountReceived = do+ countChan <- liftM graphHammerSendReceiveChannel get+ liftIO $ writeChan countChan $ Received 1++graphHammerCountSent :: Int -> GraphHammerM as ()+graphHammerCountSent count = do+ nodeIndex <- liftM graphHammerNodeIndex get+ countChan <- liftM graphHammerSendReceiveChannel get+ liftIO $ writeChan countChan $ Sent nodeIndex count++graphHammerNewAnalysisSliceArray :: IO (IOUArray Int32 Int64)+graphHammerNewAnalysisSliceArray = newArray (0,fromIntegral analysisSliceSize-1) 0++graphHammerFillPortionEdges :: [(Index,Index)] -> GraphHammerM as ()+graphHammerFillPortionEdges edges = do+ nodeIndex <- liftM (fromIntegral . graphHammerNodeIndex) get+ maxNodes <- liftM (fromIntegral . graphHammerMaxNodes) get+ let len = length edges+ let sets = scanl (update maxNodes nodeIndex) IMap.empty edges+ let arr = listArray (0,len) sets+ modify $! \st -> last sets `seq` st {+ graphHammerPortionEdges = arr+ , graphHammerOthersAnalyses = IMap.empty+ }+ where+ update :: Int32 -> Int32 -> EdgeSet -> (Index,Index) -> EdgeSet+ update maxNodes nodeIndex oldSet (fromI, toI)+ | vertexNode fromV == nodeIndex && vertexNode toV == nodeIndex =+ IMap.insertWith vertexSetUnion (vertexIndex fromV) (vertexSetSingleton toV) $!+ IMap.insertWith vertexSetUnion (vertexIndex toV) (vertexSetSingleton fromV) $!+ oldSet+ | vertexNode fromV == nodeIndex =+ IMap.insertWith vertexSetUnion (vertexIndex fromV) (vertexSetSingleton toV) $! oldSet+ | vertexNode toV == nodeIndex =+ IMap.insertWith vertexSetUnion (vertexIndex toV) (vertexSetSingleton fromV) $! oldSet+ | otherwise = oldSet+ where+ fromV = indexToVertex maxNodes fromI+ toV = indexToVertex maxNodes toI++graphHammerCommitNewPortion :: GraphHammerM as ()+graphHammerCommitNewPortion = do+ st <- get+ let portionEdges = graphHammerPortionEdges st+ (_,highest) = bounds portionEdges+ latestUpdates = portionEdges ! highest++ put $! st {+ graphHammerPortionEdges = error "graphHammerPortionEdges accessed outside of transaction."+ , graphHammerEdges = IMap.unionWith vertexSetUnion latestUpdates $ graphHammerEdges st+ , graphHammerContinuationGroups = IMap.empty+ }++graphHammerSplitIndex :: Index -> GraphHammerM as Vertex+graphHammerSplitIndex idx = do+ maxNodes <- liftM graphHammerMaxNodes get+ return $ indexToVertex maxNodes idx++graphHammerVertexSetIntersection :: VertexSet -> VertexSet -> GraphHammerM as VertexSet+graphHammerVertexSetIntersection s1 s2 = return $ vertexSetIntersection s1 s2++graphHammerVertexSetIntersectionAsIndices :: VertexSet -> VertexSet -> GraphHammerM as [Index]+graphHammerVertexSetIntersectionAsIndices s1 s2 = do+ maxNodes <- liftM graphHammerMaxNodes get+ let isection = vertexSetIntersection s1 s2+ return $ map (vertexToIndex maxNodes) $ vertexSetToList isection++graphHammerEdgeExists :: Int -> Vertex -> Vertex -> GraphHammerM as Bool+graphHammerEdgeExists edgeIndex start end+ | start == end = return True+ | otherwise = do+ startIsLocal <- graphHammerLocalVertex start+ r <- if startIsLocal+ then do+ es <- graphHammerGetEdgeSet edgeIndex start+ return $ vertexSetMember end es+ else do+ es <- graphHammerGetEdgeSet edgeIndex end+ return $ vertexSetMember start es+ return r++graphHammerGetEdgeSet :: Int -> Vertex -> GraphHammerM as VertexSet+graphHammerGetEdgeSet edgeInPortion vertex = do+ let localIndex = vertexIndex vertex+ st <- get+ let startEdges = IMap.findWithDefault IMap.empty localIndex $ graphHammerEdges st+ let portionEdges = graphHammerPortionEdges st+ let prevEdges = portionEdges ! edgeInPortion+ let resultEdges = IMap.findWithDefault vertexSetEmpty localIndex prevEdges+ return $ IMap.unionWith ISet.union startEdges resultEdges++graphHammerGrowAnalysisArrays :: Int32 -> GraphHammerM as ()+graphHammerGrowAnalysisArrays newMaxIndex = do+ analyses <- liftM graphHammerAnalyses get+ let (lowA, highA) = bounds analyses+ analyses' <- forM [lowA..highA] $ \ai -> do+ let analysisArrays = analyses ! ai+ let (lowAA,highAA) = bounds analysisArrays+ let incr = newMaxIndex - highAA+ addedArrays <- forM [0..incr-1] $ \ii -> do+ slice <- liftIO graphHammerNewAnalysisSliceArray+ return (highAA+1+ii, slice)+ return (ai,array (lowAA, newMaxIndex) (assocs analysisArrays ++ addedArrays))+ modify $! \st -> st { graphHammerAnalyses = array (lowA, highA) analyses' }++graphHammerGetAnalysisArrayIndex :: Int32 -> Int32 -> GraphHammerM as (Int32,IOUArray Int32 Int64)+graphHammerGetAnalysisArrayIndex analysisIndex' localIndex = do+ let indexOfSlice = shiftR localIndex analysisSliceSizeShift+ analysisArrays <- liftM ((! analysisIndex') . graphHammerAnalyses) get+ let (_,highestIndex) = bounds analysisArrays+ if highestIndex < indexOfSlice+ then do+ graphHammerGrowAnalysisArrays (fromIntegral indexOfSlice)+ graphHammerGetAnalysisArrayIndex analysisIndex' localIndex+ else do+ let sliceArray = analysisArrays ! indexOfSlice+ return (localIndex .&. fromIntegral analysisSliceSizeMask, sliceArray)++graphHammerGetAnalysis :: Int -> Index -> GraphHammerM as Int64+graphHammerGetAnalysis analysisIndex' index' = do+ void $ error "graphHammerGetAnalysis does not distinguish between local and not-local indices!!!"+ localIndex <- graphHammerIndexToLocal index'+ (sliceIndex,sliceArray) <- graphHammerGetAnalysisArrayIndex (fromIntegral analysisIndex') localIndex+ liftIO $ readArray sliceArray sliceIndex++_graphHammerSetAnalysis :: Int -> Index -> Int64 -> GraphHammerM as ()+_graphHammerSetAnalysis analysisIndex' index' value = do+ void $ error "graphHammerSetAnalysis does not distinguish between local and not-local indices!!!"+ localIndex <- graphHammerIndexToLocal index'+ (sliceIndex,sliceArray) <- graphHammerGetAnalysisArrayIndex (fromIntegral analysisIndex') localIndex+ liftIO $ writeArray sliceArray sliceIndex value++graphHammerIncrementAnalysis :: Int -> Index -> Int64 -> GraphHammerM as ()+graphHammerIncrementAnalysis _analysisIndex _index 0 = return () -- cheap no-op.+graphHammerIncrementAnalysis analysisIndex' index' incr = do+ local <- graphHammerIndexToLocal index'+ isLocal <- graphHammerLocalIndex index'+ if isLocal+ then do+ (sliceIndex,sliceArray) <- graphHammerGetAnalysisArrayIndex (fromIntegral analysisIndex') local+ liftIO $ do+ x <- readArray sliceArray sliceIndex+ writeArray sliceArray sliceIndex (x + incr)+ modify $! \st -> st {+ graphHammerNodesAffected = ISet.insert local $ graphHammerNodesAffected st+ }+ else do+ nodeIndex <- graphHammerIndexToNodeIndex index'+ let joinAnalyses old new = IMap.unionWith (IMap.unionWith (+)) old new+ modify $! \st -> st {+ graphHammerOthersAnalyses = IMap.insertWith joinAnalyses nodeIndex+ (IMap.singleton local (IMap.singleton (fromIntegral analysisIndex') incr)) $+ graphHammerOthersAnalyses st+ }++graphHammerBulkIncrementAnalysis :: Int -> VertexSet -> Int64 -> GraphHammerM as ()+graphHammerBulkIncrementAnalysis _analysisIndex _vertices 0 = return ()+graphHammerBulkIncrementAnalysis analysisIndex' vertices incr = do+ thisNode <- liftM (fromIntegral . graphHammerNodeIndex) get+ let (left,ours,right) = IMap.splitLookup thisNode vertices+ case ours of+ -- perform increments for local analyses.+ Just vertices' -> do+ forM_ (ISet.toList vertices') $ \localIndex -> do+ (sliceIndex,sliceArray) <- graphHammerGetAnalysisArrayIndex (fromIntegral analysisIndex') (fromIntegral localIndex)+ liftIO $ do+ x <- readArray sliceArray sliceIndex+ writeArray sliceArray sliceIndex (x + incr)+ modify $! \st -> st {+ graphHammerNodesAffected = ISet.union vertices' $ graphHammerNodesAffected st+ }+ Nothing -> return ()+ let joinAnalyses :: VertexSet -> OtherAnalyses -> OtherAnalyses+ joinAnalyses new old = IMap.unionWith+ (IMap.unionWith (IMap.unionWith (+)))+ (IMap.map (flip IMap.mapFromSetValue $ IMap.singleton (fromIntegral analysisIndex') incr) new)+ old+ modify $! \st -> st {+ graphHammerOthersAnalyses = joinAnalyses left $ joinAnalyses right $+ graphHammerOthersAnalyses st+ }+ return ()++graphHammerGetOtherAnalyses :: GraphHammerM as [(Int32,AnalysesMap)]+graphHammerGetOtherAnalyses = do+ liftM (IMap.toList . graphHammerOthersAnalyses) get++graphHammerIndexToLocal :: Index -> GraphHammerM as Int32+graphHammerIndexToLocal index' = do+ maxNodes <- liftM graphHammerMaxNodes get+ return $ fromIntegral $ index' `div` fromIntegral maxNodes++graphHammerIndexToNodeIndex :: Index -> GraphHammerM as Int32+graphHammerIndexToNodeIndex index' = do+ maxNodes <- liftM graphHammerMaxNodes get+ return $ fromIntegral $ index' `mod` fromIntegral maxNodes++graphHammerCurrentNodeIndex :: GraphHammerM as Int32+graphHammerCurrentNodeIndex = liftM (fromIntegral . graphHammerNodeIndex) get++graphHammerLocalIndex :: Index -> GraphHammerM as Bool+graphHammerLocalIndex index' = do+ nodeIndex <- graphHammerIndexToNodeIndex index'+ liftM (nodeIndex ==) graphHammerCurrentNodeIndex++graphHammerLocalVertex :: Vertex -> GraphHammerM as Bool+graphHammerLocalVertex vertex = do+ liftM ((vertexNode vertex ==) . fromIntegral) graphHammerCurrentNodeIndex++-- |Compute "local job" flag from two vertices.+-- Properties:+-- 1. local job for (v1,v2) at n1 == not (local job for (v1,v2) at n2)+-- n1 and n2 are node indices for v1 and v2.+-- an exception is for n1 is not our node and n2 is not our node too.+-- 2. local job for (v1,v2) == local job for (v2,v1)+-- It is possible for those properties to do not hold for completely+-- local or completely external pair.+graphHammerLocalJob :: Vertex -> Vertex -> GraphHammerM as Bool+graphHammerLocalJob v1' v2' = do+ let randomDir = ((vertexIndex v1 `xor` vertexIndex v2) .&. 1) == 0+ v1Local <- graphHammerLocalVertex v1+ return $ (randomDir && not v1Local) || (not randomDir && v1Local)+ where+ -- order indices to support property 2.+ v1 = min v1' v2'+ v2 = max v1' v2'++graphHammerMergeIncrements :: AnalysesMap -> GraphHammerM as ()+graphHammerMergeIncrements increments = do+{-+ st <- get+ let maxNodes = graphHammerMaxNodes st+ let node = graphHammerNodeIndex st+ let header = "Merging increments at node "++show node++":"+ let prettyAIncr index (ai,incr) = concat [" analysis [",show ai,"][",show index,"] += ",show incr]+ let prettyIndexIncrs (localI,incrs) = map (prettyAIncr (localI*maxNodes+node)) $ IMap.toList incrs+ let incrementsLines = concatMap prettyIndexIncrs $ IMap.toList increments+ let text = unlines $ header : incrementsLines+ liftIO $ putStrLn text+---}+ let flatIncrs = concatMap (\(i,as) -> map (\(ai,incr) -> (i,ai,incr)) $ IMap.toList as) $ IMap.toList increments+ forM_ flatIncrs $ \(localIndex,analysisIndex',incr) -> do+ (sliceIndex,sliceArray) <- graphHammerGetAnalysisArrayIndex (fromIntegral analysisIndex') (fromIntegral localIndex)+ liftIO $ do+ x <- readArray sliceArray sliceIndex+ writeArray sliceArray sliceIndex (x+incr)+ let _mergeIncs old new = IMap.unionWith (+) old new+ modify $! \st -> st {+ graphHammerNodesAffected = ISet.union (IMap.keysSet increments) $ graphHammerNodesAffected st+ }++graphHammerSendToNode :: Int32 -> Msg as -> GraphHammerM as ()+graphHammerSendToNode nodeIndex msg = do+ nodeChan <- liftM ((!nodeIndex) . graphHammerChannels) get+ liftIO $ writeChan nodeChan msg++_graphHammerSendToNodeOfVertex :: Vertex -> Msg as -> GraphHammerM as ()+_graphHammerSendToNodeOfVertex vertex msg = do+ graphHammerSendToNode (vertexNode vertex) msg++graphHammerGroupContinuations :: Vertex -> IntSt as -> GraphHammerM as ()+graphHammerGroupContinuations vertex contState = do+ let _upd v = Just $ case v of+ Just xs -> contState : xs+ Nothing -> [contState]+ modify $! \st -> st {+ graphHammerContinuationGroups = IMap.alter+ (\v -> fmap (contState:) v `mplus` return [contState])+ (vertexNode vertex) $ graphHammerContinuationGroups st+ }++graphHammerDistributeContinuations :: GraphHammerM as ()+graphHammerDistributeContinuations = do+ nodesGroups <- liftM (IMap.toList . graphHammerContinuationGroups) get+ forM_ nodesGroups $ \(n,g) -> graphHammerSendToNode n (ContinueIntersection g)++-- |Get analyses for no more than 100 affected vertices.+graphHammerGetAffectedAnalyses :: GraphHammerM as [(Index,VertexAnalyses)]+graphHammerGetAffectedAnalyses = do+ st <- get+ let affected = take 100 $ ISet.toList $ graphHammerNodesAffected st+ let nodeIndex = fromIntegral $ graphHammerNodeIndex st+ let maxNodes = fromIntegral $ graphHammerMaxNodes st+ let toGlobal i = fromIntegral i * maxNodes + nodeIndex+ forM affected $ \localIndex -> do+ analyses <- liftM IMap.unions $ forM (assocs (graphHammerAnalyses st)) $ \(ai,_analysisSlices) -> do+ (sliceIndex, slice) <- graphHammerGetAnalysisArrayIndex ai (fromIntegral localIndex)+ x <- liftIO $ readArray slice sliceIndex+ return (IMap.singleton (fromIntegral ai) x)+ return (toGlobal localIndex, analyses)++graphHammerClearAffected :: GraphHammerM as ()+graphHammerClearAffected = modify $! \st -> st { graphHammerNodesAffected = ISet.empty }++-------------------------------------------------------------------------------+-- Code that runs the analytics.++-- |Run the analyses stack.+-- at this momemt it's possible to run only parallelizable analyses.+runAnalysesStack :: (HLength as, EnabledAnalyses as as)+ => Integer+ -> Int -- ^ Max number of nodes+ -> IO (Maybe (UA.UArray Int Index)) -- ^ Function to obtain edges to insert+ -> Analysis as as -- ^ A stack of analyses to perform+ -> IO ()+runAnalysesStack threshold maxNodes receiveChanges analysesStack+ | analysesParallelizable analysesStack = do+ putStrLn $ "Max nodes "++show maxNodes+ chans <- liftM (listArray (0,fromIntegral maxNodes-1)) $ mapM (const newChan) [0..maxNodes - 1]+ sendReceiveCountChan <- newChan+ forM_ [0..maxNodes-1] $ \n -> do+ forkIO $ workerThread analysesStack maxNodes n sendReceiveCountChan chans+ startTime <- getCurrentTime+ (computationSeconds,lastCompSeconds,lastCompCount, n) <-+ runLoop 0 0 sendReceiveCountChan chans 0 0+ endTime <- getCurrentTime+ let timeDiff = diffUTCTime endTime startTime+ let edgesPerSecond = fromIntegral n / timeDiff+ putStrLn $ "Edges: "++show n+ putStrLn $ "Edges per second for total time: "++show edgesPerSecond+ putStrLn $ "Total time in seconds: "++show timeDiff+ putStrLn $ "Edges per second for computation time: "++show (fromIntegral n / computationSeconds)+ putStrLn $ "Edges per second for computation time of last "++show lastCompCount++" edges: "++show (fromIntegral lastCompCount / lastCompSeconds)+ putStrLn $ "Computation time in seconds: "++show computationSeconds+ return ()+ where+ gcThreshold = threshold - 8000+ runLoop time lastEdgesTime sendReceiveCountChan chans pn n = do+ edges <- liftIO receiveChanges+ case edges of+ Nothing -> do+ liftIO $ do+ answer <- newChan+ forM_ (elems chans) $ \ch -> do+ writeChan ch (Stop answer)+ forM_ (elems chans) $ \_ -> do+ readChan answer+ return (time,lastEdgesTime,n-threshold,n)+ Just edges' -> do+ start <- getCurrentTime+ let (low,up) = UA.bounds edges'+ let count = div (up-low+1) 2+ if n >= gcThreshold && n < gcThreshold + fromIntegral count+ then performGC >> putStrLn "Garbage collection."+ else return ()+ answer <- newChan+ -- seed the work.+ forM_ (elems chans) $ \ch -> writeChan ch (Portion pn edges' answer)+ -- wait for answers.+ hFlush stdout+ forM_ [0..maxNodes-1] $ \_ ->+ readChan answer+ detectSilenceAndDumpState sendReceiveCountChan maxNodes (elems chans)+ end <- getCurrentTime+ let delta = diffUTCTime end start+ let compTime = time + delta+ let lastEdgesTime'+ | n >= threshold = lastEdgesTime + delta+ | otherwise = lastEdgesTime+ runLoop compTime lastEdgesTime' sendReceiveCountChan chans (pn+1) (n+fromIntegral count)+ detectSilence countChan nodesNotSent sentReceivedBalance+ | nodesNotSent < 0 = error $ "nodesNotSent "++show nodesNotSent++"!!!"+ | nodesNotSent > 0 = continue+ | sentReceivedBalance < 0 = error $ "sentReceivedBalance "++show sentReceivedBalance++"!!!"+ | sentReceivedBalance > 0 = continue+ | otherwise = return ()+ where+ continue = do+ msg <- readChan countChan+ case msg of+ Sent _ i -> detectSilence countChan+ (nodesNotSent-1)+ (sentReceivedBalance + i)+ Received n -> detectSilence countChan+ nodesNotSent+ (sentReceivedBalance - n)+ _gatherDumpAffected chans = do+ putStrLn $ "Analyses of affected indices:"+ answer <- newChan+ forM_ chans $ \ch -> writeChan ch $ GetAffected answer+ allAffected <- flip (flip foldM []) chans $ \totalAffected _ -> do+ someAffected <- readChan answer+ return $ totalAffected ++someAffected+ let firstSome = take 10 $ sort allAffected+ forM_ firstSome $ \(ix,analyses) -> do+ putStrLn $ " Index "++show ix+ forM_ (IMap.toList analyses) $ \(ai,a) -> do+ putStrLn $ " Analysis["++show ai++"]: "++show a+ detectSilenceAndDumpState countChan nNodes _chans = do+ detectSilence countChan nNodes 0+ _performInsertionAndAnalyses edgeList = do+ insertAndAnalyzeSimpleSequential analysesStack edgeList+runAnalysesStack _threshold _maxNodes _receiveChanges _analysesStack = do+ error "Non-parallelizable analyses aren't supported."++-- |Messages the worker thread can receive.+data Msg as =+ -- edge changes.+ -- portion number and edges array+ Portion !Int !(UA.UArray Int Index) (Chan ())+ | AtomicIncrement !Int !AnalysesMap+ | ContinueIntersection ![IntSt as]+ | GetAffected (Chan [(Index,IntMap Int64)])+ | Stop (Chan Int)++-- |Counting messages sent and received.+data SendReceive =+ Sent Int Int+ | Received Int++type MsgChan as = Chan (Msg as)++_createMessageChannel :: IO (MsgChan as)+_createMessageChannel = newChan++type ChanArr as = Array Int32 (MsgChan as)+type MsgChanArr as = ChanArr as++workerThread :: (HLength as, EnabledAnalyses as as) => Analysis as as ->+ Int -> Int -> Chan SendReceive -> MsgChanArr as -> IO ()+workerThread analysis maxNodes nodeIndex countingChan chans = do+ let ourChan = chans ! fromIntegral nodeIndex+ graphHammer <- graphHammerNew maxNodes nodeIndex countingChan chans+ let --receiveLoop :: EnabledAnalysis as as => Int -> GraphHammerM (Msg as) as ()+ receiveLoop n+ | n <= 0 = return ()+ | otherwise = do+ msg <- liftIO $ readChan ourChan+ case msg of+ AtomicIncrement _pn changes -> do+ graphHammerMergeIncrements changes+ graphHammerCountReceived+ receiveLoop n+ ContinueIntersection envs -> do+ forM_ envs interpret+ receiveLoop (n-length envs)+ msg' -> do+ liftIO $ writeChan ourChan msg'+ receiveLoop n+ let --mainLoop :: EnabledAnalysis as as => GraphHammerM (Msg as) as ()+ mainLoop = do+ msg <- liftIO $ readChan ourChan+ case msg of+ Portion pn edges answer -> do+ let es = pairs $ UA.elems edges+ graphHammerFillPortionEdges es+ graphHammerClearAffected+ let work n (i,(f,t)) = do+ incr <- workOnEdge analysis i f t+ return $! n + incr+ count <- foldM work 0 $ zip [0..] es+ graphHammerDistributeContinuations+ receiveLoop count+ sendOtherIncrements pn+ graphHammerCommitNewPortion+ liftIO $ writeChan answer ()+ mainLoop+ AtomicIncrement _pn changes' -> do+ graphHammerMergeIncrements changes'+ graphHammerCountReceived+ mainLoop+ Stop answer -> do+ liftIO $ putStrLn $ "stopped "++show nodeIndex+ liftIO $ writeChan answer nodeIndex+ return ()+ GetAffected answer -> do+ affectedAnalysis <- graphHammerGetAffectedAnalyses+ liftIO $ writeChan answer affectedAnalysis+ mainLoop+ msg' -> do+ liftIO $ writeChan ourChan msg'+ mainLoop+ void $ flip runStateT graphHammer $ mainLoop+ return ()+ where+ pairs (a:b:abs') = (a,b) : pairs abs'+ pairs _ = []++sendOtherIncrements :: Int -> GraphHammerM as ()+sendOtherIncrements pn = do+ increments <- graphHammerGetOtherAnalyses+-- liftIO $ putStrLn $ "Others increments: "++show increments+ forM_ increments $ \(node,incrs) ->+ graphHammerSendToNode (fromIntegral node) (AtomicIncrement pn incrs)+ graphHammerCountSent $ length increments++workOnEdge :: Analysis as as -> Int -> Index -> Index -> GraphHammerM as Int+workOnEdge analysis edgeIndex fromIndex toIndex = do+ fromVertex <- graphHammerSplitIndex fromIndex+ toVertex <- graphHammerSplitIndex toIndex+ exists <- graphHammerEdgeExists edgeIndex fromVertex toVertex+ isFromLocal <- graphHammerLocalVertex fromVertex+ isToLocal <- graphHammerLocalVertex toVertex+ localStart <- graphHammerLocalJob fromVertex toVertex+{-+ thisNode <- graphHammerCurrentNodeIndex+ liftIO $ do+ putStrLn $ unlines [+ "thisNode "++show thisNode+ , "edgeIndex "++show edgeIndex+ , "fromVertex "++show fromVertex+ , "toVertex "++show toVertex+ , "isFromLocal "++show isFromLocal+ , "isToLocal "++show isToLocal+ , "localStart "++show localStart+ , "exists "++show exists]+-- hFlush stdout+---}+ n <- case (isFromLocal, isToLocal, localStart, exists) of+ -- totally external, shouldn't wait.+ (False, False, _, _) -> return 0+ -- totally internal, wouldn't send or receive.+ (True,True, _, False) -> do+ runStack analysis edgeIndex fromIndex toIndex+ return 0+ -- partially internal and started at our node.+ -- it sends a message and shouldn't wait.+ (_,_,True, False) -> do+ runStack analysis edgeIndex fromIndex toIndex+ return 0+ -- partially internal and started outside.+ -- should wait.+ (_,_,False, False) -> return 1+ (_,_,_, True) -> return 0+ return n++insertAndAnalyzeSimpleSequential :: Analysis as' as -> [(Index, Index)] -> GraphHammerM as ()+insertAndAnalyzeSimpleSequential _stack _edges =+ error "insertAndAnalyzeSimpleSequential!!!"++runStack :: Analysis as as -> Int -> Index -> Index -> GraphHammerM as ()+runStack (Analysis startV endV _ action) i start end = do+-- liftIO $ putStrLn $ "statements to interpret:"+-- liftIO $ putStrLn $ show actionStatements+ interpret (interpretInitialEnv i actionStatements)+ where+ actionStatements = ASAssign startV (cst start) : ASAssign endV (cst end) : action++-- |Is analyses stack parallelizable with our method?..+analysesParallelizable :: Analysis as' as -> Bool+analysesParallelizable (Analysis _ _ _ _actions) = True++-------------------------------------------------------------------------------+-- Analysis construction monad.++class AnalysisValue v where+ toInt64 :: v -> Int64+ fromInt64 :: Int64 -> v++instance AnalysisValue Bool where+ toInt64 = fromIntegral . fromEnum+ fromInt64 = toEnum . fromIntegral++instance AnalysisValue Int where+ toInt64 = fromIntegral+ fromInt64 = fromIntegral++instance AnalysisValue Int64 where+ toInt64 = id+ fromInt64 = id++data BulkOp as where+ BulkIncr :: Int -> Value _a Index -> Value _b Index -> Value _c Int64 -> BulkOp as+ CountIncr :: (Show a, Num a, AnalysisValue a) => Value Asgn a -> Value _c a -> BulkOp as+++data AnStatement as where+ -- destination and value+ ASAssign :: (Show a, AnalysisValue a) => Value Asgn a -> Value _a a -> AnStatement as+ -- start vertex for edges, end vertex for edges (will be assigned in run-time),+ -- statements to perform.+ ASOnEdges :: Value _a Index -> Value Asgn Index -> AnStatList as -> AnStatement as+ ASOnEdgesIntersection :: Value _a Index -> Value _b Index -> Value Asgn Index -> Value Asgn Index -> AnStatList as -> AnStatement as+ ASAtomicIncr :: Int -> Value _a Index -> Value _b Int64 -> AnStatement as+ ASIf :: Value _a Bool -> AnStatList as -> AnStatList as -> AnStatement as+ ASSetAnalysisResult :: Int -> Value _a Index -> Value _b Int64 -> AnStatement as+ ASFlagVertex :: Value _a Index -> AnStatement as+ ASOnFlaggedVertices :: Value Asgn Index -> AnStatList as -> AnStatement as+ ASIntersectionBulkOps :: Value _a Index -> Value _b Index -> [BulkOp as] -> AnStatement as+ ASContinueEdgeIsect :: !VertexSet -> Value Asgn Index -> Value Asgn Index -> Vertex -> AnStatList as -> AnStatement as+ ASContinueEdgeIsectBulk :: !VertexSet -> !Vertex -> [BulkOp as] -> AnStatement as++indentShow :: Show a => a -> String +indentShow = indent . show+indent :: String -> String+indent = (" "++)+indentShowStats :: Show a => [a] -> [String]+indentShowStats stats = map indent $ filter (not . null) $ concatMap (lines . show) stats+instance Show (AnStatement as) where+ show (ASAssign dest what) = show dest ++ " := "++show what+ show (ASOnEdges vertex var stats) = unlines $+ ("onEdges "++show vertex++"\\"++show var) : indentShowStats stats+ show (ASOnEdgesIntersection a b aN bN stats) = unlines $+ ("onEdgesIntersection "++show (a,b)++"\\"++show (aN,bN)) : indentShowStats stats+ show (ASAtomicIncr ai idx incr) = "analysisResult["++show ai++"]["++show idx++"] += "++show incr+ show (ASIf cond thens elses) = unlines $+ ("if "++show cond) : "then" : indentShowStats thens ++ ("else" : map indentShow elses)+ show (ASSetAnalysisResult ai idx val) = "analysisResult["++show ai++"]["++show idx++"] := "++show val+ show (ASFlagVertex idx) = "flagVertex "++show idx+ show (ASOnFlaggedVertices x ss) = unlines $ ("onFlaggedVertices \\"++show x ++" ->") : indentShowStats ss+ show (ASIntersectionBulkOps _ _ _) = "ASIntersectionBulkOps"+ show (ASContinueEdgeIsect _ _ _ _ _) = "ASContinueEdgeIsect"+ show (ASContinueEdgeIsectBulk _ _ _) = "ASContinueEdgeIsectBulk"+ showList xs = \s -> s ++ unlines (map show xs)++type AnStatList as = [AnStatement as]++data AnSt as = AnSt {+ asValueIndex :: !Int32+ , asStatements :: !(AnStatList as)+ }++-- this is how we construct analyses.+type AnM as a = State (AnSt as) a++addStatement :: AnStatement as -> AnM as ()+addStatement stat = modify $! \as -> as {+ asStatements = asStatements as ++ [stat]+ }++cutStatements :: AnM as r -> AnM as (AnStatList as, r)+cutStatements act = do+ stats <- liftM asStatements get+ modify $! \as -> as { asStatements = []}+ r <- act+ eStats <- liftM asStatements get+ modify $! \as -> as { asStatements = stats }+ return (eStats, r)++-------------------------------------------------------------------------------+-- Analysis API - enumerating edges.++onEdges :: Value Composed Index -> (Value Composed Index -> AnM as r) -> AnM as r+onEdges vertex act = do+ neighbor <- defineLocal+ (eStats, r) <- cutStatements $ act $ ValueComposed neighbor+ addStatement $ ASOnEdges vertex neighbor eStats+ return r++-------------------------------------------------------------------------------+-- Analysis API - flagging vertices and iterating over them.++{-+flagVertex :: Value any Index -> AnM as ()+flagVertex vertex = do+ addStatement $ ASFlagVertex vertex+-}+{-+onFlaggedVertices :: (Value Composed Index -> AnM as r) -> AnM as r+onFlaggedVertices action = do+ vertex <- defineLocal+ (eStats, r) <- cutStatements $ action $ ValueComposed vertex+ addStatement $ ASOnFlaggedVertices vertex eStats+ return r+-}++-------------------------------------------------------------------------------+-- Analysis API - conditional operator.++anIf :: Value Composed Bool -> AnM as r -> AnM as r -> AnM as r+anIf cond th el = do+ (thStats, r) <- cutStatements th+ (elStats, _) <- cutStatements el+ addStatement $ ASIf cond thStats elStats+ return r++-------------------------------------------------------------------------------+-- Analysis API - keeping analyses' results.++getEnabledAnalyses :: AnM as as+getEnabledAnalyses = return (error "value of getEnabledAnalyses should not be requested.")++getAnalysisIndex :: AnalysisIndex a as => a -> AnM as Int+getAnalysisIndex a = do+ analyses <- getEnabledAnalyses+ return $ analysisIndex a analyses++-- |Fetch analysis result.+getAnalysisResult :: (AnalysisIndex a as) => a -> Value _a Index -> AnM as (Value Composed Int64)+getAnalysisResult analysis vertex = do+ idx <- getAnalysisIndex analysis+ return $ ValueComposed $ ValueAnalysisResult idx vertex++-- |Store analysis result.+putAnalysisResult :: (AnalysisIndex a as) => a -> Value _a Index -> Value _b Int64 -> AnM as ()+putAnalysisResult analysis vertex value = do+ idx <- getAnalysisIndex analysis+ addStatement $ ASSetAnalysisResult idx vertex value++-- |Update atomically result with increment.+incrementAnalysisResult :: (AnalysisIndex a as) => a -> Value _a Index -> Value _b Int64 -> AnM as ()+incrementAnalysisResult analysis vertex incr = do+ idx <- getAnalysisIndex analysis+ addStatement $ ASAtomicIncr idx vertex incr++-------------------------------------------------------------------------------+-- GraphHammer API - values and expressions.++-- value is assignable.+data Asgn+-- value is composite, thus not assignable.+data Composed++-- |A (modifable) value.+data Value asgn v where+ -- argument's index.+ ValueArgument :: Int -> Value Composed v+ -- some local variable.+ ValueLocal :: AnalysisValue v => Int32 -> Value Asgn v+ -- constant. we cannot live wothout them.+ ValueConst :: v -> Value Composed v+ -- binary operation.+ ValueBin :: (Show l, Show r) => BinOp l r v -> Value _a l -> Value _b r -> Value Composed v+ -- and unary operations.+ ValueUn :: UnOp a v -> Value _a a -> Value Composed v+ -- cast as composed.+ ValueComposed :: Value _a v -> Value Composed v+ -- address of the analysis result of the value.+ -- index of the analysis in stack, vertex index.+ ValueAnalysisResult :: Int -> Value _b Index -> Value Asgn Int64++data BinOp x y z where+ Plus :: Num x => BinOp x x x+ Minus :: Num x => BinOp x x x+ Mul :: Num x => BinOp x x x+ Div :: Integral x => BinOp x x x+ Equal :: Eq x => BinOp x x Bool++instance Show v => Show (Value asgn v) where+ show v = case v of+ ValueArgument i -> "arg_"++show i+ ValueLocal i -> "var_"++show i+ ValueConst w -> show w+ ValueBin op a b -> unwords ["(",show a,")", show op, "(",show b,")"]+ ValueUn _op _a -> "unary"+ ValueComposed w -> unwords ["as_composed(",show w,")"]+ ValueAnalysisResult i ix -> "analysis "++show i++" result at "++show ix++instance Show (BinOp x y z) where+ show op = case op of+ Plus -> "+"+ Minus -> "-"+ Mul -> "*"+ Div -> "/"+ Equal -> "=="++data UnOp a r where+ Not :: UnOp Bool Bool+ Negate :: Num v => UnOp v v++-- |Define a (mutable) value local to a computation.+defineLocal :: AnalysisValue v => AnM as (Value Asgn v)+defineLocal = do+ modify $! \as -> as { asValueIndex = asValueIndex as + 1 }+ liftM (ValueLocal . asValueIndex) get++-- |Define a local value and assign to it.+localValue :: (Show v, AnalysisValue v) => v -> AnM as (Value Asgn v)+localValue def = do+ v <- defineLocal+ v $= cst def+ return v++infixl 6 +., -.+(+.), (-.), (*.) :: (Show v, Num v) => Value _a v -> Value _b v -> Value Composed v+a +. b = ValueBin Plus a b+a -. b = ValueBin Minus a b+a *. b = ValueBin Mul a b+divV :: (Integral v, Show v) => Value _a v -> Value _b v -> Value Composed v+divV a b = ValueBin Div a b++(===), (=/=) :: (Show v, Eq v) => Value _a v -> Value _b v -> Value Composed Bool+a === b = ValueBin Equal a b+a =/= b = notV $ a === b++notV :: forall _a. Value _a Bool -> Value Composed Bool+notV = ValueUn Not+-- negV = ValueUn Negate++-- | Constant value+cst :: v -> Value Composed v+cst = ValueConst++-- |Assigning a value.+infixr 1 $=+($=) :: (Show v, AnalysisValue v) => Value Asgn v -> Value _a v -> AnM as ()+dest $= expr = addStatement $ ASAssign dest expr++-------------------------------------------------------------------------------+-- Interpreting analysis in GraphHammer monad.++data IntSt as = IntSt {+ istLocals :: !(IntMap Int64)+ , isEdgeIndex :: !Int+ , isConts :: ![AnStatList as]+ }++type AIM as a = StateT (IntSt as) (StateT (GraphHammer as) IO) a++interpretInitialEnv :: Int -> AnStatList as -> IntSt as+interpretInitialEnv edgeIndex actions =+ IntSt (IMap.empty) edgeIndex [actions]++interpret :: EnabledAnalyses as as => IntSt as -> GraphHammerM as ()+interpret env = flip evalStateT env $ do+ interpretStatements++interpretStatements :: EnabledAnalyses as as => AIM as ()+interpretStatements = do+ conts <- liftM isConts get+ case conts of+ [] -> return ()+ ([]:cs) -> do+ modify $! \st -> st { isConts = cs }+ interpretStatements+ ((s:ss):cs) -> do+ modify $! \st -> st { isConts = ss:cs }+ interpretStatement s+ interpretStatements++interpretStatement :: EnabledAnalyses as as => AnStatement as -> AIM as ()+interpretStatement stat = case stat of+ ASAssign dest what -> --liftIO (putStrLn $ show dest ++ " := "++show what) >>+ assignValue dest what+ ASOnEdges startVertex vertexToAssign stats -> do+ interpretOnEdges startVertex vertexToAssign stats+ ASAtomicIncr aIndex vIndex incr -> do+ incr' <- interpretValue incr+ vIndex' <- interpretValue vIndex+ lift $ graphHammerIncrementAnalysis aIndex vIndex' incr'+ ASIf cond thenStats elseStats -> do+ c <- interpretValue cond+ let stats = if c then thenStats else elseStats+ modify $! \st -> st { isConts = stats : isConts st }+ ASContinueEdgeIsect edgeSet a b thisNodeVertex onEdgeStats -> do+ ei <- liftM isEdgeIndex get+ thisEdgeSet <- lift $ graphHammerGetEdgeSet ei thisNodeVertex+ isection <- lift $ graphHammerVertexSetIntersectionAsIndices edgeSet thisEdgeSet+ let cont c = ASAssign a (cst c) : ASAssign b (cst c) : onEdgeStats + modify $! \st -> st { isConts = map cont isection ++ isConts st }+ ASContinueEdgeIsectBulk edgeSet thisNodeVertex bulkOps -> do+ ei <- liftM isEdgeIndex get+ thisEdgeSet <- lift $ graphHammerGetEdgeSet ei thisNodeVertex+ isection <- lift $ graphHammerVertexSetIntersection edgeSet thisEdgeSet+ interpretBulkOps isection bulkOps+ ASOnEdgesIntersection av bv aN bN stats -> do+ interpretEdgesIntersection av bv aN bN stats+ ASIntersectionBulkOps av bv bulkStats ->+ interpretIntersectionBulkOps av bv bulkStats+ ASSetAnalysisResult _ _ _ -> error "interpretStatement for ASSetAnalysisResult is not implemented yet"+ ASFlagVertex _ -> error "interpretStatement for ASFlagVertex is not implemented yet" + ASOnFlaggedVertices _ _ -> error "interpretStatement for ASOnFlaggedVertices is not implemented yet"+++assignValue :: Show v => Value Asgn v -> Value _b v -> AIM as ()+assignValue (ValueLocal idx) what = do+ x <- interpretValue what+ modify $! \ist -> ist { istLocals = IMap.insert idx (toInt64 x) $ istLocals ist }+assignValue (ValueAnalysisResult _ _) _ = error "it's not possible to assign to result"++interpretIntersectionBulkOps :: Value _a Index -> Value _b Index -> [BulkOp as] -> AIM as ()+interpretIntersectionBulkOps a b ops = do+ ei <- liftM isEdgeIndex get+ s1 <- interpretVertexValue a+ s2 <- interpretVertexValue b+ l1 <- lift $ graphHammerLocalVertex s1+ l2 <- lift $ graphHammerLocalVertex s2+ case (l1,l2) of+ -- this is filtered out in previous steps.+ (False, False) -> error "completely non-local computation!"+ -- completely local computation.+ (True, True) -> do+ e1 <- lift $ graphHammerGetEdgeSet ei s1+ e2 <- lift $ graphHammerGetEdgeSet ei s2+ isection <- lift $ graphHammerVertexSetIntersection e1 e2+ interpretBulkOps isection ops+ -- partially local computations that started in our node.+ (True, False) -> do+ ourEdges <- lift $ graphHammerGetEdgeSet ei s1+ sendAndStop s2 ourEdges+ (False, True) -> do+ ourEdges <- lift $ graphHammerGetEdgeSet ei s2+ sendAndStop s1 ourEdges+ where+ sendAndStop destIndex ourEdges = do+ st <- get+ let continueStat = ASContinueEdgeIsectBulk ourEdges destIndex ops+ let sendSt = continueStat `seq` st { isConts = [continueStat] : isConts st }+ lift $ graphHammerGroupContinuations destIndex $! sendSt+ -- stop interpreting here. It will be continued on another node.+ modify $! \st1 -> st1 { isConts = [] }++interpretBulkOps :: VertexSet -> [BulkOp as] -> AIM as ()+interpretBulkOps _isection [] = return ()+interpretBulkOps isection (op:ops) = do+ case op of+ BulkIncr aindex _ _ incr -> do+ v <- interpretValue incr+ lift $ graphHammerBulkIncrementAnalysis aindex isection v+ CountIncr v incr -> do+ assignValue v (incr *. cst (fromIntegral $ vertexSetSize isection))+ interpretBulkOps isection ops++interpretEdgesIntersection :: Value _a Index -> Value _b Index -> Value Asgn Index -> Value Asgn Index -> AnStatList as -> AIM as ()+interpretEdgesIntersection a b aN bN stats = do+ ei <- liftM isEdgeIndex get+ s1 <- interpretVertexValue a+ s2 <- interpretVertexValue b+ l1 <- lift $ graphHammerLocalVertex s1+ l2 <- lift $ graphHammerLocalVertex s2+ case (l1,l2) of+ (False, False) -> error "completely non-local computation!"+ (True,True) -> do+ e1 <- lift $ graphHammerGetEdgeSet ei s1+ e2 <- lift $ graphHammerGetEdgeSet ei s2+ let cont c = ASAssign aN (cst c) :+ ASAssign bN (cst c) :+ stats+ isection <- lift $ graphHammerVertexSetIntersectionAsIndices e1 e2+ let conts = map cont isection+ modify $! \st -> st { isConts = conts ++ isConts st }+ -- one is local to us, another is out of our reach.+ (True,False) -> do+ ourEdges <- lift $ graphHammerGetEdgeSet ei s1+ sendAndStop s2 s1 ourEdges+ (False,True) -> do+ ourEdges <- lift $ graphHammerGetEdgeSet ei s2+ sendAndStop s1 s2 ourEdges+ where+ sendAndStop destIndex _ourIndex ourEdges = do+ st <- get+ let continueStat = ASContinueEdgeIsect ourEdges aN bN destIndex stats+ let sendSt = st { isConts = [continueStat] : isConts st }+ lift $ graphHammerGroupContinuations destIndex sendSt+ -- stop interpreting here. It will be continued on another node.+ modify $! \st1 -> st1 { isConts = [] }++interpretOnEdges :: EnabledAnalyses as as => Value _a Index -> Value Asgn Index -> AnStatList as -> AIM as ()++-- special case for edge sets intersection.+interpretOnEdges startVertex1 vertexToAssign1@(ValueLocal i1)+ [ASOnEdges startVertex2 vertexToAssign2@(ValueLocal i2) [ASIf (ValueBin Equal a b) thenStats []]]+ | Just i3 <- uncompose a+ , Just i4 <- uncompose b+ , (i1 == i3 && i2 == i4) || (i1 == i4 && i2 == i3) =+ interpretEdgesIntersection startVertex1 startVertex2 vertexToAssign1 vertexToAssign2 thenStats++interpretOnEdges _startVertex _vertexToAssign _stats = do+ error "standalone onEdges is not supported right now!"++interpretValue :: Value _a v -> AIM as v+interpretValue value = case value of+ ValueLocal index1 -> do+ locals <- liftM istLocals get+ case IMap.lookup index1 locals of+ Just v -> return (fromInt64 v)+ Nothing -> error $ "local variable #"++show index1++" not found in "++show locals++"."+ ValueArgument _index -> error "interpreting ValueArgument!!!"+ ValueConst v -> return v+ ValueBin Plus l r -> interpretBin (+) l r+ ValueBin Minus l r -> interpretBin (-) l r+ ValueBin Mul l r -> interpretBin (*) l r+ ValueBin Div l r -> interpretBin (div) l r+ ValueBin Equal l r -> interpretBin (==) l r+ ValueUn Not val -> liftM not $ interpretValue val+ ValueUn Negate val -> liftM negate $ interpretValue val+ ValueComposed v -> interpretValue v+ ValueAnalysisResult analysisIndex1 vertex -> do+ v <- interpretValue vertex+ lift $ graphHammerGetAnalysis analysisIndex1 v+ where+ interpretBin :: (a -> b -> r) -> Value _a a -> Value _b b -> AIM as r+ interpretBin f a b = liftM2 f (interpretValue a) (interpretValue b)++interpretVertexValue :: Value _a Index -> AIM as Vertex+interpretVertexValue value = do+ i <- interpretValue value+ lift $ graphHammerSplitIndex i++-------------------------------------------------------------------------------+-- Optimizing statements operations.++optimizeStatements :: AnStatList as -> AnStatList as+-- trivial case.+optimizeStatements [] = []+-- important case of edge intesection.+optimizeStatements (stat : stats)+ | Just stats' <- recognizeOptimizeIntersection stat+ = stats' ++ optimizeStatements stats+-- all other cases aren't optimizable.+optimizeStatements (stat : stats) = stat : optimizeStatements stats++recognizeOptimizeIntersection :: AnStatement as ->+ Maybe (AnStatList as)+recognizeOptimizeIntersection stat = do+ isection <- recognizeIntersection stat+ let isections = optimizeIntersection isection+ return isections++optimizeIntersection :: AnStatement as -> [AnStatement as]+optimizeIntersection stat@(ASOnEdgesIntersection a b aN bN stats) = case stats of+ [ASAtomicIncr anIx ix incr, ASAssign v (ValueBin Plus l r)]+ | incrIsConst incr+ , Just iix <- uncompose ix+ , Just iaN <- uncompose aN+ , Just ibN <- uncompose bN+ , iix == iaN || iix == ibN+ , Just iv <- uncompose v+ , Just assignIncr <- uncomposeOne iv l r ->+ [ ASIntersectionBulkOps a b [BulkIncr anIx a b incr, CountIncr v assignIncr]]+ _ -> [stat]+ where+ uncomposeOne :: Int32 -> Value _a x -> Value _b x -> Maybe (Value Composed x)+ uncomposeOne rq a1 b1 = do+ i <- uncompose a1+ if i == rq then return (castComposed b1) else mzero+ `mplus` do+ i <- uncompose b1+ if i == rq then return (castComposed a1) else mzero+ castComposed :: Value _a a -> Value Composed a+ castComposed (ValueComposed v) = ValueComposed v+ castComposed (ValueConst c) = ValueConst c+ castComposed v = ValueComposed v+ incrIsConst :: Value _a c -> Bool+ incrIsConst (ValueConst _c) = True+ incrIsConst _ = False+optimizeIntersection _ = error "Not an intersection interation operator."++uncompose :: Value _a x -> Maybe Int32+uncompose (ValueComposed a) = uncompose a+uncompose (ValueLocal i) = Just i+uncompose _ = Nothing++recognizeIntersection :: AnStatement as -> Maybe (AnStatement as)+recognizeIntersection (ASOnEdges a aN [ASOnEdges b bN [ASIf cond stats []]]) = do+ _ <- case cond of+ ValueBin Equal x y -> do+ ix <- uncompose x+ iy <- uncompose y+ iaN <- uncompose aN+ ibN <- uncompose bN+ if (ix == iaN && iy == ibN) || (ix == ibN && iy == iaN)+ then return undefined+ else mzero+ _ -> mzero+ return $ ASOnEdgesIntersection a b aN bN stats+recognizeIntersection _ = mzero++-------------------------------------------------------------------------------+-- GraphHammer analysis combination.++type family RequiredAnalyses a++-- Removed for feature use+-- data AnalysisNotEnabled a++class EnabledAnalysis a as++instance EnabledAnalysis a (a :. as)+instance EnabledAnalysis a as => EnabledAnalysis a (a' :. as)++class EnabledAnalyses as eas++instance EnabledAnalyses Nil eas+instance (EnabledAnalyses as eas, EnabledAnalysis a eas) => EnabledAnalyses (a :. as) eas++data Analysis as wholeset where+ Analysis :: (EnabledAnalyses (RequiredAnalyses a) as, EnabledAnalyses as wholeset, EnabledAnalyses (a :. as) wholeset) =>+ Value Asgn Index -> Value Asgn Index -> Int32 ->+ AnStatList (a :. as) -> Analysis (a :. as) wholeset++basicAnalysis :: ((RequiredAnalyses a) ~ Nil, EnabledAnalysis a wholeset) =>+ a -> (a -> Value Composed Index -> Value Composed Index -> AnM (a :. Nil) ()) -> Analysis (a :. Nil) wholeset+basicAnalysis analysis edgeInsert =+ Analysis sv ev i stats+ where+ i = asValueIndex env+ stats = optimizeStatements $ asStatements env+ ((sv,ev),env) = flip runState (AnSt 0 []) $ do+ sv1 <- defineLocal+ ev1 <- defineLocal+ edgeInsert analysis (ValueComposed sv1) (ValueComposed ev1)+ return (sv1,ev1)++derivedAnalysis :: (EnabledAnalyses (RequiredAnalyses a) as, EnabledAnalyses as wholeset, EnabledAnalyses (a :. as) wholeset) =>+ Analysis as wholeset -> a -> (a -> Value Composed Index -> Value Composed Index -> AnM (a :. as) ()) -> Analysis (a :. as) wholeset+derivedAnalysis (Analysis startV endV startI requiredActions) analysis edgeInsert =+ Analysis startV endV i (map liftStatement requiredActions ++ currentActions)+ where+ initialState = AnSt startI []+ liftStatement :: AnStatement as -> AnStatement (a :. as)+ liftStatement stat = case stat of+ ASAssign v e -> ASAssign v e+ ASOnEdges i1 arg as -> ASOnEdges i1 arg (map liftStatement as)+ ASAtomicIncr ai vi incr -> ASAtomicIncr ai vi incr+ ASIf cond thens elses -> ASIf cond (map liftStatement thens) (map liftStatement elses)+ ASSetAnalysisResult ai vi val -> ASSetAnalysisResult ai vi val+ ASFlagVertex v -> ASFlagVertex v+ ASOnFlaggedVertices arg stats -> ASOnFlaggedVertices arg $ map liftStatement stats+ -- new ones+ ASOnEdgesIntersection va vb ai bi stats -> ASOnEdgesIntersection va vb ai bi $ map liftStatement stats+ ASIntersectionBulkOps _va _vb _ops -> error "derivedAnalysis over ASIntersectionBulkOps is not yet implemented"+ ASContinueEdgeIsect vs ai bi v stats -> ASContinueEdgeIsect vs ai bi v $ map liftStatement stats+ ASContinueEdgeIsectBulk _ _ _ -> error "derivedAnalysis over ASContinueEdgeIsectBulk is not yet implemented"+ currentActions = optimizeStatements $ asStatements env+ i = asValueIndex env+ env = flip execState initialState $ do+ edgeInsert analysis (ValueComposed startV) (ValueComposed endV)++class EnabledAnalysis a as => AnalysisIndex a as where+ analysisIndex :: a -> as -> Int++instance AnalysisIndex a as => AnalysisIndex a (a' :. as) where+ analysisIndex a list = analysisIndex a (hTail list)+instance HLength as => AnalysisIndex a (a :. as) where+ analysisIndex _ list = hLength (hTail list)++{-+class AnalysisIndexBool b a as | a as -> b where+ analysisAtHead :: a -> as -> b+ analysisIndexBool :: b -> a -> as -> Int+instance (HLength as, TyCast TRUE b) => AnalysisIndexBool b a (a :. as) where+ analysisAtHead _ _ = undefined+ analysisIndexBool _ _ list = hLength $ hTail list+instance (AnalysisIndex a as) => AnalysisIndexBool FALSE a (a' :. as) where+ analysisAtHead _ _ = undefined+ analysisIndexBool _ a list = analysisIndex a $ hTail list++instance (EnabledBool b a (a' :. as), AnalysisIndexBool b a (a' :. as), TyEq b a a') => AnalysisIndex a (a' :. as) where+ analysisIndex a as = analysisIndexBool (analysisAtHead a as) a as+-}