packages feed

set-cover 0.1 → 0.1.1

raw patch · 6 files changed

+78/−78 lines, 6 filesdep +storable-recorddep ~containersdep ~enummapsetdep ~knead

Dependencies added: storable-record

Dependency ranges changed: containers, enummapset, knead, llvm-extra, llvm-tf, random, transformers

Files

set-cover.cabal view
@@ -1,5 +1,5 @@ Name:             set-cover-Version:          0.1+Version:          0.1.1 License:          BSD3 License-File:     LICENSE Author:           Henning Thielemann, Helmut Podhaisky@@ -45,7 +45,7 @@   Default:     False  Source-Repository this-  Tag:         0.1+  Tag:         0.1.1   Type:        darcs   Location:    http://hub.darcs.net/thielema/set-cover/ @@ -89,11 +89,12 @@    If flag(llvm)     Build-Depends:-      knead >=0.4 && <0.5,-      llvm-extra >=0.8 && <0.9,-      llvm-tf >=3.1.1 && <3.2,+      knead >=0.4 && <0.6,+      llvm-extra >=0.10 && <0.11,+      llvm-tf >=9.2 && <9.3,       tfp >=1.0 && <1.1,       comfort-array >=0.3 && <0.5,+      storable-record >=0.0.5 && <0.1,       storable-endian >=0.2.6 && <0.3,       bool8 >=0.0 && <0.1,       lazyio >=0.1 && <0.2
src/Math/SetCover/Exact.hs view
@@ -320,7 +320,7 @@ If a set is chosen for a partition, then its label is included in the output. E.g. @set0 = Set.fromList [0,1], set1 = Set.fromList [2], set2 = Set.fromList [0,1,2]@,-then 'partitions' returns @["01", "2"]@.+then 'partitions' returns @[\"01\", \"2\"]@.  The order of partitions and the order of labels depends on the implementation
src/Math/SetCover/Exact/Knead.hs view
@@ -139,6 +139,7 @@ keepMinimum :: IO (Phys.Array BlockDim Block -> IO (BlockId,Block)) keepMinimum =    Render.run $ \xs ->+      Render.MarshalExp $       Expr.maybe Expr.zero (Expr.mapSnd keepMinimumBit) $       Symb.findAll (Expr.not . nullBlock . Expr.snd) $       Symb.zip (Symb.id (Symb.shape xs)) xs
src/Math/SetCover/Exact/Knead/Saturated.hs view
@@ -10,13 +10,13 @@ import Math.SetCover.Exact.Knead.Vector (Block) import Math.SetCover.Exact.Knead.Symbolic          (SetId, SetDim, BlockId, BlockDim, blocksFromSets,-          nullSet, disjoint, disjointRows, differenceWithRow,-          findIndices, collectRows)+          nullSet, disjoint, differenceWithRow,+          filterDisjointRows, findIndices)  import qualified Control.Monad.HT as Monad import Control.Monad.HT ((<=<)) import Control.Monad (foldM)-import Control.Applicative (liftA2, liftA3, pure, (<$>), (<*>))+import Control.Applicative (liftA3, pure, (<$>))  import qualified Data.Array.Knead.Parameterized.Render as Render import qualified Data.Array.Knead.Simple.Physical as Phys@@ -30,14 +30,12 @@ import qualified Data.Array.Comfort.Boxed as Array import Data.Array.Comfort.Boxed (Array) -import qualified LLVM.Extra.Extension.X86 as X86-import qualified LLVM.Extra.Extension as Ext import qualified LLVM.Extra.Multi.Vector as MultiVector import qualified LLVM.Extra.Multi.Value.Vector as MultiValueVec import qualified LLVM.Extra.Multi.Value as MultiValue-import LLVM.Extra.Multi.Vector.Memory () import LLVM.Extra.Multi.Value (atom) +import qualified LLVM.Util.Intrinsic as Intr import qualified LLVM.Core as LLVM  import qualified Type.Data.Num.Decimal as TypeNum@@ -53,8 +51,8 @@ import qualified Data.Int as Int import qualified Data.Bool8 as Bool8 import qualified Data.Bits as Bits-import Data.Functor.Compose (Compose(Compose,getCompose)) import Data.Set (Set)+import Data.Maybe (fromMaybe)  import Prelude2010 import Prelude ()@@ -133,21 +131,13 @@    LLVM.Value Counters -> LLVM.Value Counters ->    LLVM.CodeGenFunction r (LLVM.Value Counters) incSatGeneric x y =-   (\(MultiValue.Cons z) -> getCompose z)+   (\(MultiValue.Cons z) -> z)    <$>-   Expr.unliftM2 incSat-      (MultiValue.Cons (Compose x)) (MultiValue.Cons (Compose y))+   Expr.unliftM2 incSat (MultiValue.Cons x) (MultiValue.Cons y)  incSatX86 :: Exp Counters -> Exp Counters -> Exp Counters incSatX86 =-   Expr.liftM2-      (MultiValue.liftM2-         (\xc yc ->-            Compose <$>-            case (getCompose xc, getCompose yc) of-               (x,y) ->-                  Ext.run (incSatGeneric x y)-                     (X86.paddusb128 <*> pure x <*> pure y)))+   Expr.liftTupleM2 (\x y -> fromMaybe incSatGeneric Intr.maybeUAddSat x y)  sumRows ::    Symb.Array (SetDim, blockDim) Counters ->@@ -168,8 +158,7 @@    Expr.fromInteger' numCounters  toCounters :: Exp Block -> Exp Counters-toCounters =-   Expr.liftM (MultiValue.liftM (fmap Compose . LLVM.bitcast))+toCounters = Expr.liftTupleM LLVM.bitcast  _pickBits :: Exp BitId -> Exp Block -> Exp Counters _pickBits k block =@@ -177,15 +166,13 @@   word16 :: Exp BitId -> Exp Word.Word16-word16 = Expr.liftM (MultiValue.liftM LLVM.ext) . bitPos+word16 = Expr.liftTupleM LLVM.ext . bitPos  toBlock16 :: Exp Block -> Exp Block16-toBlock16 =-   Expr.liftM (MultiValue.liftM (fmap Compose . LLVM.bitcast))+toBlock16 = Expr.liftTupleM LLVM.bitcast  fromBlock16 :: Exp Block16 -> Exp Counters-fromBlock16 =-   Expr.liftM (MultiValue.liftM (fmap Compose . LLVM.bitcast . getCompose))+fromBlock16 = Expr.liftTupleM LLVM.bitcast  pickBitsX86 :: Exp BitId -> Exp Block -> Exp Counters pickBitsX86 k block =@@ -200,20 +187,6 @@    Slice.apply (Slice.second extrudeBits)  -filterDisjointRows ::-   IO (SetId ->-       (Array SetDim label, Phys.Array (SetDim,BlockDim) Block) ->-       IO (Array SetDim label, Phys.Array (SetDim,BlockDim) Block))-filterDisjointRows = do-   disjRows <- Render.run $ \k -> findIndices . disjointRows k-   collect <- Render.run collectRows-   return $ \k0 (labels,sets) -> do-      perm <- disjRows k0 sets-      liftA2 (,)-         (Array.fromList (Phys.shape perm) . map (labels Array.!)-            <$> Phys.toList perm)-         (collect perm sets)- updateStateIO :: IO (SetId -> State label -> LazyIO.T (State label)) updateStateIO = do    filt <- filterDisjointRows@@ -239,9 +212,7 @@  extractBlock :: Exp CounterId -> Exp Block -> Exp Subblock extractBlock =-   Expr.liftM2-      (\(MultiValue.Cons k) (MultiValue.Cons v) ->-         MultiValue.Cons <$> (LLVM.extractelement v =<< LLVM.zext k))+   Expr.liftTupleM2 (\k v -> LLVM.extractelement v =<< LLVM.zext k)  flattenCounters ::    Symb.Array (BlockDim, BitDim) Counters ->@@ -252,7 +223,7 @@   bitPos :: Exp BitId -> Exp Subblock-bitPos = Expr.liftM (MultiValue.liftM LLVM.bitcast)+bitPos = Expr.liftTupleM LLVM.bitcast  singleBit :: Exp BitId -> Exp Subblock singleBit = Expr.shl 1 . bitPos@@ -272,7 +243,8 @@    IO (Phys.Array (BlockDim, BitDim) Counters ->        IO ((BlockId,CounterId),Counter)) _keepMinimum =-   Render.run $ Expr.mapSnd singleBit . argMinimum . flattenCounters+   Render.run $+   Render.MarshalExp . Expr.mapSnd singleBit . argMinimum . flattenCounters   argMinMasked ::@@ -311,6 +283,7 @@        IO ((BlockId,CounterId),Counter)) _keepMinimumMasked =    Render.run $ \free ->+      Render.MarshalExp .       Expr.mapSnd singleBit . argMinimumMasked free . flattenCounters  @@ -419,6 +392,7 @@        IO ((BlockId,CounterId),Subblock)) keepMinimumMaskedVec =    Render.run $ \free ->+      Render.MarshalExp .       Expr.mapSnd singleBit . keepMinimumMaskedCascade .       argMinimumMaskedVec free
src/Math/SetCover/Exact/Knead/Symbolic.hs view
@@ -8,11 +8,9 @@    getRow,    nullSet,    disjoint,-   disjointRows,    differenceWithRow,    findIndices,    filterDisjointRows,-   collectRows,    ) where  import qualified Math.SetCover.Exact.Block as Blocks@@ -36,12 +34,15 @@ import Data.Array.Comfort.Boxed (Array)  import qualified LLVM.Extra.Multi.Value as MultiValue+import qualified LLVM.Extra.Storable as Storable import LLVM.Extra.Multi.Value (atom)  import qualified Data.Word as Word import qualified Data.Int as Int import Data.Set (Set) +import Foreign.Storable.Record.Tuple (Tuple(Tuple))+ import Prelude2010 import Prelude () @@ -101,10 +102,10 @@ add2 =    Render.run $ \xs ->    Render.MapAccumLSimple-      (Expr.modify2 atom (atom,atom) $ \carry (a,b) ->+      (Expr.modify2 atom (Tuple (atom,atom)) $ \carry (Tuple (a,b)) ->          (addHigh a b carry, addLow a b carry))       (Symb.fill (Expr.fst (Symb.shape xs)) Expr.zero)-      (halfBags xs)+      (Symb.map Expr.tuple $ halfBags xs)   zbAtom :: Shape.ZeroBased (MultiValue.Atom a)@@ -278,6 +279,14 @@    Render.MapFilter Expr.fst Expr.snd       (Symb.zip (Symb.id $ Symb.shape arr) arr) +findDisjointRows ::+   (BitSet block, Storable.C block) =>+   IO (SetId ->+       Phys.Array (SetDim,BlockDim) block ->+       IO (Phys.Array SetDim SetId))+findDisjointRows =+   Render.run $ \k -> findIndices . disjointRows k+ collectRows ::    (MultiValue.C block) =>    Symb.Array SetDim SetId ->@@ -289,11 +298,12 @@       sets  filterDisjointRows ::+   (BitSet block, Storable.C block) =>    IO (SetId ->-       (Array SetDim label, Phys.Array (SetDim,BlockDim) Block) ->-       IO (Array SetDim label, Phys.Array (SetDim,BlockDim) Block))+       (Array SetDim label, Phys.Array (SetDim,BlockDim) block) ->+       IO (Array SetDim label, Phys.Array (SetDim,BlockDim) block)) filterDisjointRows = do-   disjRows <- Render.run $ \k sets -> findIndices $ disjointRows k sets+   disjRows <- findDisjointRows    collect <- Render.run collectRows    return $ \k (labels,sets) -> do       perm <- disjRows k sets
src/Math/SetCover/Exact/Knead/Vector.hs view
@@ -7,12 +7,14 @@ import qualified Math.SetCover.Exact.Block as Blocks import Math.SetCover.Exact.Knead (BitSet) +import Control.Monad ((<=<)) import Control.Applicative (liftA2)  import qualified Data.Array.Knead.Expression as Expr -import qualified LLVM.Extra.Multi.Value.Memory as MultiValueMem+import qualified LLVM.Extra.Storable as Storable import qualified LLVM.Extra.Multi.Value as MultiValue+import qualified LLVM.Extra.Tuple as Tuple import qualified LLVM.Extra.Arithmetic as A  import qualified LLVM.Core as LLVM@@ -21,7 +23,7 @@ import qualified Foreign.Storable as Store import Foreign.Storable (Storable) import Foreign.Marshal.Array (advancePtr)-import Foreign.Ptr (castPtr)+import Foreign.Ptr (Ptr, castPtr) import Data.Storable.Endian (peekLE, pokeLE)  import qualified Data.NonEmpty.Mixed as NonEmptyM@@ -41,11 +43,11 @@  {-# INLINE getByte #-} getByte :: Int -> Word64 -> Word8-getByte k x = fromIntegral $ shiftR x k+getByte k x = fromIntegral $ shiftR x (k*8)  {-# INLINE _putByte #-} _putByte :: Int -> Word8 -> Word64-_putByte k x = shiftL (fromIntegral x) k+_putByte k x = shiftL (fromIntegral x) (k*8)   instance Storable Block where@@ -59,28 +61,40 @@       let ptr64 = castPtr ptr       in  liftA2 Block (peekLE ptr64) (peekLE (advancePtr ptr64 1)) +instance Tuple.Value Block where+   type ValueOf Block = LLVM.Value ByteVector+   valueOf = LLVM.valueOf . blockVector+ instance MultiValue.C Block where-   type Repr f Block = f ByteVector-   cons (Block x0 x1) =-      MultiValue.consPrimitive $ LLVM.vector $-      fmap (\k -> if k<8 then getByte k x0 else getByte k x1) $-      NonEmptyC.iterate (1+) 0+   cons = MultiValue.consPrimitive . blockVector    undef = MultiValue.undefPrimitive    zero = MultiValue.zeroPrimitive-   phis = MultiValue.phisPrimitive-   addPhis = MultiValue.addPhisPrimitive+   phi = MultiValue.phiPrimitive+   addPhi = MultiValue.addPhiPrimitive +blockVector :: Block -> ByteVector+blockVector (Block x0 x1) =+   LLVM.vector $+   fmap+      (\k ->+         let split = Store.sizeOf x0+         in if k<split then getByte k x0 else getByte (k-split) x1) $+   NonEmptyC.iterate (1+) 0+ instance MultiValue.Logic Block where    and = MultiValue.liftM2 LLVM.and; or = MultiValue.liftM2 LLVM.or    xor = MultiValue.liftM2 LLVM.xor; inv = MultiValue.liftM LLVM.inv -instance MultiValueMem.C Block where-   type Struct Block = ByteVector-   load = MultiValueMem.loadPrimitive-   store = MultiValueMem.storePrimitive-   decompose = MultiValueMem.decomposePrimitive-   compose = MultiValueMem.composePrimitive+instance Storable.C Block where+   load = Storable.load <=< castBlockPtr+   store b = Storable.store b <=< castBlockPtr +castBlockPtr ::+   LLVM.Value (Ptr Block) ->+   LLVM.CodeGenFunction r (LLVM.Value (Ptr ByteVector))+castBlockPtr = LLVM.bitcast++ toWord128 ::    LLVM.Value ByteVector ->    LLVM.CodeGenFunction r (LLVM.Value (LLVM.WordN TypeNum.D128))@@ -93,8 +107,8 @@  instance BitSet Block where    nullBlock =-      Expr.liftM (MultiValue.liftM (\x ->-         A.cmp LLVM.CmpEQ (LLVM.value LLVM.zero) =<< toWord128 x))+      Expr.liftTupleM (\x ->+         A.cmp LLVM.CmpEQ (LLVM.value LLVM.zero) =<< toWord128 x)    blocksFromSets sets =       let (avails, free) = Blocks.blocksFromSets sets           numBlocks = - div (- length free) blockSize@@ -105,5 +119,5 @@             NonEmptyM.sliceVertical . (++ repeat 0)       in  (map sliceRow avails, sliceRow free)    keepMinimumBit =-      Expr.liftM (MultiValue.liftM (\x0 ->-         do x <- toWord128 x0; fromWord128 =<< A.and x =<< A.neg x))+      Expr.liftTupleM (\x0 ->+         do x <- toWord128 x0; fromWord128 =<< A.and x =<< A.neg x)