diff --git a/GraphHammer.cabal b/GraphHammer.cabal new file mode 100644 --- /dev/null +++ b/GraphHammer.cabal @@ -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 diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. + + + Copyright (C) + + 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. + + , 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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/src/GraphHammer.hs b/src/GraphHammer.hs new file mode 100644 --- /dev/null +++ b/src/GraphHammer.hs @@ -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 diff --git a/src/GraphHammer/HList.hs b/src/GraphHammer/HList.hs new file mode 100644 --- /dev/null +++ b/src/GraphHammer/HList.hs @@ -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) diff --git a/src/GraphHammer/Info.hs b/src/GraphHammer/Info.hs new file mode 100644 --- /dev/null +++ b/src/GraphHammer/Info.hs @@ -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 () diff --git a/src/GraphHammer/IntMap.hs b/src/GraphHammer/IntMap.hs new file mode 100644 --- /dev/null +++ b/src/GraphHammer/IntMap.hs @@ -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, +-- +-- +-- * 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 . +-- 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 (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 (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 (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 (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) diff --git a/src/GraphHammer/IntSet.hs b/src/GraphHammer/IntSet.hs new file mode 100644 --- /dev/null +++ b/src/GraphHammer/IntSet.hs @@ -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, +-- +-- +-- * 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 (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 (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 (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 (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 +-} diff --git a/src/GraphHammer/SimplestParallel.hs b/src/GraphHammer/SimplestParallel.hs new file mode 100644 --- /dev/null +++ b/src/GraphHammer/SimplestParallel.hs @@ -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 +-}