HLearn-approximation (empty) → 1.0.0

raw patch · 4 files changed

+281/−0 lines, 4 filesdep +ConstraintKindsdep +HLearn-algebradep +HLearn-datastructuressetup-changed

Dependencies added: ConstraintKinds, HLearn-algebra, HLearn-datastructures, HLearn-distributions, base, containers, heap, list-extras, vector

+ HLearn-approximation.cabal view

@@ -0,0 +1,47 @@+Name:                HLearn-approximation+Version:             1.0.0+Description:         Approximation algorithms for NP-hard problems+Category:            Data Mining, Machine Learning, Data Structures+License:             BSD3+--License-file:        LICENSE+Author:              Mike izbicki+Maintainer:          mike@izbicki.me+Build-Type:          Simple+Cabal-Version:       >=1.8++Library+    Build-Depends:      +        HLearn-algebra          >= 1.0.2,+        HLearn-distributions    >= 1.0.0,+        HLearn-datastructures   >= 1.0.0,+        ConstraintKinds         >= 0.0.2,+        base                    >= 3 && < 5,+        +        vector                  >= 0.10.0,+        containers              >= 0.5.0,+        list-extras             >= 0.4.1,+        heap                    >= 1.0.0+        +    hs-source-dirs:     src+    ghc-options:        -rtsopts -auto-all -caf-all -O2 +    Exposed-modules:+        HLearn.NPHard.Scheduling+        HLearn.NPHard.BinPacking+    Extensions:+        FlexibleInstances+        FlexibleContexts+        MultiParamTypeClasses+        FunctionalDependencies+        UndecidableInstances+        ScopedTypeVariables+        BangPatterns+        TypeOperators+        GeneralizedNewtypeDeriving+--        DataKinds+        TypeFamilies+--        PolyKinds+        StandaloneDeriving+        GADTs+        KindSignatures+        ConstraintKinds+

+ Setup.hs view

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

+ src/HLearn/NPHard/BinPacking.hs view

@@ -0,0 +1,84 @@+{-# LANGUAGE DataKinds #-}++-- | Bin packing is one of the most well studied NP-hard problems.  See wikipedia for a detailed description <https://en.wikipedia.org/wiki/Bin_packing>++module HLearn.NPHard.BinPacking+    ( BinPacking (..)+    )+    where+          +import qualified Data.Foldable as F+import qualified Data.Heap as Heap+import Data.List+import Data.List.Extras+import Debug.Trace+import qualified Data.Map as Map+import qualified Data.Sequence as Seq+import GHC.TypeLits+import qualified Control.ConstraintKinds as CK+import HLearn.Algebra+import HLearn.DataStructures.SortedVector++-------------------------------------------------------------------------------+-- data types    ++data BinPacking (n::Nat) a = BinPacking+    { vector  :: !(SortedVector a)+    , packing :: Map.Map Int [a]+    }+    deriving (Read,Show,Eq,Ord)++bfd :: forall a n. (Norm a, Ord (Ring a), SingI n) => SortedVector a -> BinPacking n a+bfd vector = BinPacking+    { vector = vector+    , packing = vector2packing (fromIntegral $ fromSing (sing :: Sing n)) vector+    }++vector2packing :: (Norm a, Ord (Ring a)) => Ring a -> SortedVector a -> Map.Map Int [a]+vector2packing binsize vector = snd $ F.foldr cata (Map.empty,Map.empty) vector+    where+        cata x (weight2bin,packing) = case Map.lookupLE (binsize - magnitude x) weight2bin of+            Nothing -> (weight2bin',packing')+                where+                    newbin = Map.size packing + 1+                    weight2bin' = Map.insert (magnitude x) newbin weight2bin+                    packing' = Map.insert newbin [x] packing+            Just (weight,bin) -> (weight2bin', packing')+                where+                    weight2bin' = Map.insert (weight+magnitude x) bin $ +                                  Map.delete weight weight2bin+                    packing' = Map.insertWith (++) bin [x] packing++-------------------------------------------------------------------------------+-- Algebra++instance (Ord a, Ord (Ring a), Norm a, SingI n) => Abelian (BinPacking n a) +instance (Ord a, Ord (Ring a), Norm a, SingI n) => Monoid (BinPacking n a) where+    mempty = bfd mempty+    p1 `mappend` p2 = bfd $ (vector p1) <> (vector p2)++instance (Ord a, Ord (Ring a), Norm a, SingI n, Group (SortedVector a)) => Group (BinPacking n a) where+    inverse p = BinPacking +        { vector = inverse $ vector p+        , packing = error "Scheduling.inverse: schedule does not exist for inverses"+        }++instance (HasRing (SortedVector a)) => HasRing (BinPacking n a) where+    type Ring (BinPacking n a) = Ring (SortedVector a)++instance (Ord a, Ord (Ring a), Norm a, SingI n, Module (SortedVector a)) => Module (BinPacking n a) where+    r .* p = p { vector = r .* vector p }++---------------------------------------++instance CK.Functor (BinPacking n) where+    type FunctorConstraint (BinPacking n) x = (Ord x, Norm x, SingI n)+    fmap f sched = bfd $ CK.fmap f $ vector sched++-------------------------------------------------------------------------------+-- Training++instance (Ord a, Ord (Ring a), Norm a, SingI n) => HomTrainer (BinPacking n a) where+    type Datapoint (BinPacking n a) = a+    train1dp dp = bfd $ train1dp dp+

+ src/HLearn/NPHard/Scheduling.hs view

@@ -0,0 +1,148 @@+{-# LANGUAGE DataKinds #-}++-- | See the wikipedia article for details about the Multiprocessor Scheduling problem <https://en.wikipedia.org/wiki/Multiprocessor_scheduling>++module HLearn.NPHard.Scheduling+    (+    +    Scheduling (..)++    -- * Operations+    , getSchedules+    , maxpartition+    , minpartition+    , spread+    ) where+          +import qualified Control.ConstraintKinds as CK+import qualified Data.Foldable as F+import qualified Data.Heap as Heap+import Data.List+import Data.List.Extras+import Debug.Trace+import qualified Data.Map as Map+import qualified Data.Sequence as Seq+import GHC.TypeLits+import HLearn.Algebra+import HLearn.DataStructures.SortedVector++-------------------------------------------------------------------------------+-- data types    ++type Bin = Int++data Scheduling (n::Nat) a = Scheduling+    { vector      :: !(SortedVector a)+    , schedule :: Map.Map Bin [a]+    }+    deriving (Read,Show,Eq,Ord)++lptf :: forall a n. (Norm a, Ord (Ring a), SingI n) => SortedVector a -> Scheduling n a+lptf vector = Scheduling+    { vector = vector+    , schedule = vector2schedule (fromIntegral $ fromSing (sing :: Sing n)) vector+    }++vector2schedule :: (Norm a, Ord (Ring a)) => Bin -> SortedVector a -> Map.Map Bin [a]+vector2schedule p vector = snd $ F.foldr cata (emptyheap p,Map.empty) vector+    where+        -- maintain the invariant that size of our heap is always p+        -- the processor with the smallest workload is at the top+        cata x (heap,map) = +            let Just top = Heap.viewHead heap+                set = snd top+                prio = (fst top)+magnitude x+                heap' = Heap.insert (prio,set) (Heap.drop 1 heap)+                map' = Map.insertWith (++) set [x] map+            in (heap',map')++emptyheap :: (Num ring, Ord ring) => Bin -> Heap.MinPrioHeap ring Bin+emptyheap p = Heap.fromAscList [(0,i) | i<-[1..p]]++---------------------------------------++-- | Returns a list of all schedules.  The schedules are represented by a list of the elements within them.+getSchedules :: Scheduling n a -> [[a]]+getSchedules = Map.elems . schedule++-- | Returns the size of the largest bin+maxpartition :: (Ord (Ring a), Norm a) => Scheduling n a -> Ring a+maxpartition p = maximum $ map (sum . map magnitude) $ Map.elems $ schedule p++-- | Returns the size of the smallest bin+minpartition :: (Ord (Ring a), Norm a) => Scheduling n a -> Ring a+minpartition p = minimum $ map (sum . map magnitude) $ Map.elems $ schedule p++-- | A schedule's spread is a measure of it's \"goodness.\"  The smaller the spread, the better the schedule.  It is equal to `maxpartition` - `minpartition`+spread :: (Ord (Ring a), Norm a) => Scheduling n a -> Ring a+spread p = (maxpartition p)-(minpartition p)++-------------------------------------------------------------------------------+-- Algebra++instance (Ord a, Ord (Ring a), Norm a, SingI n) => Abelian (Scheduling n a) +instance (Ord a, Ord (Ring a), Norm a, SingI n) => Monoid (Scheduling n a) where+    mempty = lptf mempty+    p1 `mappend` p2 = lptf $ (vector p1) <> (vector p2)++instance (Ord a, Ord (Ring a), Norm a, SingI n, Group (SortedVector a)) => Group (Scheduling n a) where+    inverse p = Scheduling+        { vector = inverse $ vector p+        , schedule = error "Scheduling.inverse: schedule does not exist for inverses"+        }++instance (HasRing (SortedVector a)) => HasRing (Scheduling n a) where+    type Ring (Scheduling n a) = Ring (SortedVector a)++instance (Ord a, Ord (Ring a), Norm a, SingI n, Module (SortedVector a)) => Module (Scheduling n a) where+    r .* p = p { vector = r .* vector p }++---------------------------------------++instance CK.Functor (Scheduling n) where+    type FunctorConstraint (Scheduling n) x = (Ord x, Norm x, SingI n)+    fmap f sched = lptf $ CK.fmap f $ vector sched++-------------------------------------------------------------------------------+-- Training++instance (Ord a, Ord (Ring a), Norm a, SingI n) => HomTrainer (Scheduling n a) where+    type Datapoint (Scheduling n a) = a+    train1dp dp = lptf $ train1dp dp+    +-------------------------------------------------------------------------------+-- Visualization++class Labeled a where+    label :: a -> String++rmblankline :: String -> String+rmblankline [] = []+rmblankline ('\n':'\n':xs) = rmblankline ('\n':xs)+rmblankline (x:xs) = x:(rmblankline xs)++visualize :: (Norm a, Labeled a, Show (Ring a), Fractional (Ring a)) => Ring a -> Map.Map Bin [a] -> String+visualize height m = rmblankline $ unlines+    [ "\\begin{tikzpicture}"+    , "\\definecolor{hlearn_bgbox}{RGB}{127,255,127}"+    , unlines $ map mknodes $ Map.assocs m+    , unlines $ map (mkproc height) $ Map.assocs m+    , "\\end{tikzpicture}"+    ]++-- mkproc :: (k,[a]) -> String+mkproc height (k,xs) = +    "\\draw[line width=0.1cm] ("++show x++","++show height++") to ("++show x++",0) to node[below] {$s_{"++show k++"}$} ("++show x++"+2,0) to ("++show x++"+2,"++show height++");"+    where+        x = k*2++-- mknodes :: (k,[a]) -> String+mknodes (k,xs) = unlines $ go 0 (reverse xs)+    where+        go i [] = [""]+        go i (x:xs) = (node (k*2+1) (i+(magnitude x)/2) (magnitude x) (label x)):(go (i+magnitude x) xs)+            +    +-- node :: Double->Double->Double->String->String+node x y height name = +    "\\node[shape=rectangle,draw,fill=hlearn_bgbox,minimum width=2cm,minimum height="++show height++"cm] at ("++show x++","++show y++") { "++name++" };"