Commits

U-darkstar\KE  committed 193d7b9

fixed for demonstration

  • Participants
  • Parent commits 9b7bc71

Comments (0)

Files changed (4)

File GTALib.cabal

 -- The package version. See the Haskell package versioning policy
 -- (http://www.haskell.org/haskellwiki/Package_versioning_policy) for
 -- standards guiding when and how versions should be incremented.
-Version:             0.0.1
+Version:             0.0.2
 
 -- A short (one-line) description of the package.
 Synopsis: A library for GTA programming           
   -- Packages needed in order to build this package.
   Build-depends:    base>=4.3 && < 4.6,template-haskell>=2.5 && <2.8,containers>=0.4 && <0.6,parallel >=3.1 && < 3.3
   HS-source-dirs:   src/
-  --GHC-options:    -Wall   -O
+  -- GHC-options:    -Wall   -O
   
   -- Modules not exported by this package.
   -- Other-modules:       

File examples/Knapsack.hs

 import GTA.Data.JoinList
 import GTA.Core hiding (items)
 
-import System.Environment
 import System.Random
 
+{- Demonstration
+
+:l *Knapsack.hs
+
+subs [(1, 30), (2, 20), (2, 40)] `aggregateBy` result
+
+subs [(1, 30), (2, 20), (2, 40)] `filterBy` weightlimit 3 `aggregateBy` result
+subs [(1, 30), (2, 20), (2, 40)] `filterBy` weightlimit 3 `aggregateBy` maxsumsolutionWith getValue
+
+items <- randomItems 200 200
+take 10 items
+length items
+subs items `filterBy` weightlimit 200 `aggregateBy` maxsumsolutionWith getValue
+
+let (_, Bag [x]) = subs items `filterBy` weightlimit 200 `aggregateBy` maxsumsolutionWith getValue
+
+x
+dejoinize x
+sum $ map fst (dejoinize x)
+sum $ map snd (dejoinize x)
+
+items <- randomItems 200 200
+length items
+subs items `filterBy` weightlimit 200 `aggregateBy` maxsumsolutionWith getValue
+
+subs items `aggregateBy` count
+subs items `filterBy` weightlimit 200 `aggregateBy` count
+
+
+-}
+
+--sequential version
+knapsack capa items = 
+  subs items 
+    `filterBy` weightlimit capa
+    `aggregateBy` maxsumsolutionWith getValue
+
+--parallel version
+knapsackP w items = 
+  subsP items 
+    `filterBy` weightlimit w
+    `aggregateBy` maxsumsolutionWith getValue
+
+--main function to check the parallel computation
+main = do
+  let w = 200
+  let n = 2000
+  items <- randomItems n w
+  putStrLn $ "w=" ++ show w ++ ", #items = " ++ show n
+  putStrLn.show $ knapsackP w items
+
+{-
+
+ghc Knapsack.hs -threaded -rtsopts -O2
+
+time ./Knapsack.exe +RTS -N1 -RTS
+time ./Knapsack.exe +RTS -N2 -RTS
+time ./Knapsack.exe +RTS -N4 -RTS
+time ./Knapsack.exe +RTS -N8 -RTS
+
+-}
+
+{-
+Selecting a generator: 
+
+inits [1,2,3] `aggregateBy` result
+segs [1,2,3] `aggregateBy` result
+tails [1,2,3] `aggregateBy` result
+subs [1,2,3] `aggregateBy` result
+assigns "TF" [1,2,3] `aggregateBy` result
+
+
+subs [(1, 30), (2, 20), (2, 40)] `aggregateBy` result
+-}
+
+{-
+Designing a predicate (tester)
+-}
+-- the base definition of user-defined predicate to check the weight limit
+weightlimit' w = (<=w) . ws
+  where 
+       ws (x1 `Times` x2) = (ws x1 + ws x2)
+       ws (Single i) = getWeight i
+       ws  Nil = 0
 {-
-subsJ :: JList a -> Bag (JList a)
-subsJ x = ss x
-    where ss (x1 `Times` x2) = ss x1 `cross` ss x2
-          ss (Single a) = single a `u` bagOfnil
-          ss Nil = emptyBag
+weightlimit' 3 $ joinize[(1,30), (2,20)]
+weightlimit' 3 $ joinize[(1,30), (2,20), (2,40)]
+-}
 
-weightlimit w = (<=w) . ws
+-- the range of the homomorphism becomes smaller
+weightlimit'' w = (<=w) . ws
   where 
        ws (x1 `Times` x2) = (ws x1 + ws x2) `min` (w+1)
        ws (Single i) = getWeight i `min` (w+1)
        ws  Nil = 0
--}
 {-
-subs' :: [a] -> Semiring a s -> s
-subs' = subsJ.joinize
-subsJ :: JList a -> Semiring a s -> s
-subsJ x (GenericSemiring {..}) = ss x
-    where JListAlgebra {..} = algebra
-          CommutativeMonoid {..} = monoid
-          ss (x1 `Times` x2) = ss x1 `times` ss x2
-          ss (Single a) = single a `oplus` nil
-          ss Nil = identity          
+weightlimit'' 3 $ joinize[(1,30), (2,20)]
+weightlimit'' 3 $ joinize[(1,30), (2,20), (2,40)]
 -}
 
+-- definition by JoinListAlgebra operators to be used in GTA framework
 weightlimit w = (<=w) <.> ws
   where ws = JoinListAlgebra{..} where 
            x1 `times` x2  = (   x1 +    x2) `min` (w+1)
            single i  = getWeight i `min` (w+1)
            nil = 0
 
+{-
+subs [(1, 30), (2, 20), (2, 40)] `filterBy` weightlimit 3 `aggregateBy` result
+-}
+
+{-
+Selecting an aggregator: 
+
+-- knapsack problem
+subs [(1, 30), (2, 20), (2, 40)] `filterBy` weightlimit 3 `aggregateBy` maxsumsolutionWith getValue
+
+-}
+
+{-
+Modified knapsack problem solvers via aggregators
+
+-- counting the number of valid selections
+subs [(1, 30), (2, 20), (2, 40)] `filterBy` weightlimit 3 `aggregateBy` count
+
+-- k-best knapsack
+subs [(1, 30), (2, 20), (2, 40)] `filterBy` weightlimit 3 `aggregateBy` maxsumsolutionKWith 3 getValue
+
+[(AddIdentity 70,Bag [[(1,30),(2,40)]]),(AddIdentity 50,Bag [[(1,30),(2,20)]]),(AddIdentity 40,Bag [[(2,40)]])]
+
+-}
+
+
+
+{-
+Modified knapsack problem solvers via testers
+-}
+
+-- user-defined predicate for divisable-by-3
+multipleOf k = (==0) <.> length' k where
+  length' k = JoinListAlgebra{..} 
+  w1 `times` w2 = (w1 + w2) `mod` k
+  single i = 1 `mod` k
+  nil = 0 `mod` k
+{-
+-- with an additional condition: # of selected items are divisible by 3.
+subs [(1, 30), (2, 20), (2, 40)] `filterBy` weightlimit 3 `filterBy` multipleOf 3 `aggregateBy` maxsumsolutionWith getValue
+
+subs [(1, 30), (1, 10), (1, 10), (2, 20), (2, 40)] `filterBy` weightlimit 3 `filterBy` multipleOf 3 `aggregateBy` maxsumsolutionWith getValue
+
+-}
+
+-- user-defined predicate: at most one value item
+oneValueItem v = (<=1) <.> cnt where
+  cnt = JoinListAlgebra{..} 
+  c1 `times` c2 = (c1 + c2) `min` 2
+  single i = if getValue i >= v then 1 else 0
+  nil = 0 
+
+{-
+subs [(1, 30), (2, 20), (2, 40)] `filterBy` weightlimit 3 `filterBy` oneValueItem 30 `aggregateBy` maxsumsolutionWith getValue
+
+-}
+
+-- user-defined predicate: descending in weights
+
+descending :: (Ord w) => 
+              (Maybe (w, Bool, w) -> Bool,
+               JoinListAlgebra (w, v) (Maybe (w, Bool, w)))
+descending = (\a -> case a of Just (_, t, _) -> t; Nothing -> False) <.> h where
+  h = JoinListAlgebra{..} 
+  Just (l1, t1, r1) `times` Just (l2, t2, r2) = Just (l1, t1 && t2 && (r1 > l2), r2)
+  Nothing `times` x = x
+  x `times` Nothing = x
+  single i = Just (getWeight i, True, getWeight i)
+  nil = Nothing
+
+{-
+subs [(1, 30), (2, 20), (2, 40)] `filterBy` weightlimit 3 `filterBy` descending `aggregateBy` maxsumsolutionWith getValue
+
+subs [(2, 20), (2, 40), (1, 30)] `filterBy` weightlimit 3 `filterBy` descending `aggregateBy` maxsumsolutionWith getValue
+
+-}
+
+
+-- =============== for designing a new generator ===========
+{-
+
+let x = bagOfSingleton 1 `bagUnion` bagOfNil
+x
+let y = x `bagUnion` bagOfSingleton 2
+y
+x `crossConcat` y
+
+
+-}
+
+--straightforward imlementation of subs generator on join lists:
+subsJ :: JoinList a -> Bag (JoinList a)
+subsJ x = ss x where
+    ss Nil = bagOfNil
+    ss (Single a) 
+               = bagOfSingleton a `bagUnion` bagOfNil
+    ss (x1 `Times` x2) = ss x1 `crossConcat` ss x2   
+
+{-
+subsJ (joinize [1,2,3])
+
+-}
+
+--abstracted version of subs:
+subsJ' :: JoinList a -> Semiring a s -> s
+subsJ' x (GenericSemiring {..}) = ss x
+    where JoinListAlgebra {..} = algebra
+          CommutativeMonoid {..} = monoid
+          ss (x1 `Times` x2) = ss x1 `times` ss x2
+          ss (Single a) = single a `oplus` nil
+          ss Nil = identity        
+
+{-
+subsJ (joinize [1,2,3]) freeSemiring
+
+-}
+
+--wrapper for usual lists  
+subs' :: [a] -> Semiring a s -> s
+subs' = subsJ'.joinize
+
+{-
+subs' [1,2,3] `aggregateBy` result
+
+-}
 
-knapsack w items = 
+
+-- computes the best value only
+knapsackValue capa items = 
   subs items 
-    >== weightlimit w
-    >=> maxsumWith getValue
+    `filterBy` weightlimit capa
+    `aggregateBy` maxsumWith getValue
 
-knapsackSolution w items = 
+-- another notation
+knapsackValue' w items = 
   subs items 
     >== weightlimit w
-    >=> maxsumsolutionWith getValue
+    >=> maxsumWith getValue
 
 getWeight (w, v) = w
 getValue (w, v) = v
-items = [(1, 10), (4, 20), (2,30)]
-w = 5
+exampleItems = [(1, 10), (4, 20), (2,30)]
+examplelimit = 5
 
--- another notation
-knapsack' w items = 
-  subs items 
-    `filterBy` weightlimit w
-    `aggregateBy` maxsumWith getValue
+{-
+user-defined aggregator
+-}
+--maxvalue:: Semiring (Int, Int) (Maybe Int)
+maxvalue = GenericSemiring{monoid=CommutativeMonoid {..}, 
+                           algebra=JoinListAlgebra {..}} where
+    a `oplus` b = a `max` b
+    identity    = Nothing
+    a `times` b = case (a, b) of (Just a, Just b) -> Just (a + b)
+                                 _ -> Nothing
+    single i    = Just (getValue i)
+    nil         = Just 0
+
+{-
+
+subs [(1, 30), (2, 20), (2, 40)] `filterBy` weightlimit 3 `aggregateBy` maxvalue
+subs [(1, 30), (2, 20), (2, 40)] `filterBy` weightlimit 3 `aggregateBy` maxsumWith getValue
+
+
+-}
 
 
 {-
 -}
 
 
---parallel version
-knapsackP w items = 
-  subsP items 
-    >== weightlimit w
-    >=> maxsumWith getValue
 
 -- with an additional condition: # of selected items are divisible by 3.
-
 knapsack3 w items =
   subs items 
     `filterBy` weightlimit w 
     `filterBy` multipleOf 3
     `aggregateBy` maxsumsolutionWith getValue
 
-multipleOf k = (==0) <.> length' k
-length' k = JoinListAlgebra{..} where 
-  w1 `times` w2 = (w1 + w2) `mod` k
-  single i = 1 `mod` k
-  nil = 0 `mod` k
 
-main = do
+randomItems :: Int -> Int -> IO ([(Int, Int)])
+randomItems n w = do 
   setStdGen (mkStdGen 0)  -- always the same random sequence
   rand <- getStdGen
-  args <- getArgs
-  let w = if length args > 0 then read (head args) else 100
-  let n = if length args > 1 then read (head (tail args)) else 2000
-  let items = genItems n (randomRs (1, 10) rand)
-  putStrLn $ "w=" ++ show w ++ ", #items = " ++ show n
-  putStrLn.show $ knapsackP w items
+  let genItems (v:w:rs) = (v, w):genItems rs
+  return (take n (genItems (randomRs (1, w) rand)))
 
-genItems :: Int -> [Int] -> [(Int, Int)]
-genItems 0 rs = []
-genItems n (v:w:rs) = (v, w):genItems (n-1) rs
 
-{-
-
-ghc Knapsack.hs -threaded -rtsopts -O2
-
-time ./Knapsack.exe +RTS -N1 -RTS
-time ./Knapsack.exe +RTS -N2 -RTS
-time ./Knapsack.exe +RTS -N4 -RTS
-
--}

File slides/HaskellDay2012.pdf

Binary file added.

File src/GTA/Data/JoinList.hs

 {-# LANGUAGE MultiParamTypeClasses,FlexibleInstances,FlexibleContexts,FunctionalDependencies,UndecidableInstances,RankNTypes,ExplicitForAll,ScopedTypeVariables,NoMonomorphismRestriction,OverlappingInstances,EmptyDataDecls,RecordWildCards,TypeFamilies,TemplateHaskell  #-}
 
-module GTA.Data.JoinList (JoinList(Times, Single, Nil), JoinListAlgebra(JoinListAlgebra), times, single, nil, joinize, dejoinize, segs, inits, tails, subs, assigns, paths, mapJ, count, maxsum, maxsumsolution, maxsumWith, maxsumKWith, maxsumsolutionXKWith, maxsumsolutionXWith, maxsumsolutionWith, maxsumsolutionKWith, maxprodWith, maxprodKWith, maxprodsolutionXKWith, maxprodsolutionXWith, maxprodsolutionWith, maxprodsolutionKWith, segsP, initsP, tailsP, subsP, assignsP) where
+module GTA.Data.JoinList (JoinList(Times, Single, Nil), JoinListAlgebra(JoinListAlgebra), times, single, nil, joinize, dejoinize, segs, inits, tails, subs, assigns, paths, mapJ, count, maxsum, maxsumsolution, maxsumWith, maxsumKWith, maxsumsolutionXKWith, maxsumsolutionXWith, maxsumsolutionWith, maxsumsolutionKWith, maxprodWith, maxprodKWith, maxprodsolutionXKWith, maxprodsolutionXWith, maxprodsolutionWith, maxprodsolutionKWith, segsP, initsP, tailsP, subsP, assignsP, crossConcat, bagOfSingleton, emptyBag, bagOfNil, bagUnion, Semiring) where
+
 
 import GTA.Core
 import GTA.Util.GenericSemiringStructureTemplate
                 | Nil
 --             deriving (Show, Eq, Ord, Read)
 
+-- stupid joinize function
 joinize :: forall a. [a] -> JoinList a
 joinize [] = Nil
 joinize [a] = Single a
                 d = (n `div` 2)
             in Times (joinize x1) (joinize x2)
 
+-- stupid dejoinize function
 dejoinize :: forall a. JoinList a -> [a]
 dejoinize (Times x1 x2) = dejoinize x1 ++ dejoinize x2
 dejoinize (Single a) = [a]
                     p2 = h (n-1) x2
           h _ (Single a) = single a
           h _ Nil = nil
+
+--- useful functions to design generators: constructors of bags of lists
+crossConcat :: Bag (JoinList a) -> Bag (JoinList a) -> Bag (JoinList a)
+crossConcat = times (algebra freeSemiring)
+
+bagOfSingleton :: a -> Bag (JoinList a)
+bagOfSingleton = single (algebra freeSemiring)
+
+bagOfNil :: Bag (JoinList a)
+bagOfNil =  nil (algebra freeSemiring)
+
+emptyBag :: Bag (JoinList a)
+emptyBag = let GenericSemiring{..} = freeSemiring :: GenericSemiring (JoinListAlgebra a) (Bag (JoinList a))
+           in identity monoid 
+
+bagUnion :: Bag (JoinList a) -> Bag (JoinList a) -> Bag (JoinList a)
+bagUnion = let GenericSemiring{..} = freeSemiring :: GenericSemiring (JoinListAlgebra a) (Bag (JoinList a))
+           in oplus monoid
+
+