added source for haskell sample scheduler

haskell/sampleScheduler/README

@@ -0,0 +1,18 @@
+todos:
+
+read real Haskell source code to determine conventions for:
+	code
+	names
+	usage
+	documentation
+	type annotations
+	design/library design
+	combinators
+	architecture
+	??other patterns or idioms??
+
+error handling/bad state handling
+
+specifications (of functions)
+
+testing TESTING !!TESTING!!!

haskell/sampleScheduler/changeMe.txt

@@ -0,0 +1,13 @@
+
+getting set up:
+
+download and install the Haskell Platform
+
+if it installed correctly, you should be able to type 'ghci' from a command terminal
+
+this starts a haskell interpreter
+
+if you started it in the same directory as a source file,
+	you can do ':load <filename>' to bring it into the interpreter
+	then you can play with the functions it defines
+	but everything has to compile -- if there are compile errors, it won't work

haskell/sampleScheduler/dependencies.txt

@@ -0,0 +1,8 @@
+
+Control.Applicative
+
+Data.Map
+Data.Set
+Data.List
+
+Text.JSON  (cabal install JSON) (how does Text.JSON map to JSON?)

haskell/sampleScheduler/src/ExampleSelectors.hs

@@ -0,0 +1,49 @@
+module ExampleSelectors (
+	randomPoints,
+	bestByGridPoint,
+	randomPointsAllQuadUnits,
+	bestByGridPointAllQuadUnits,
+	probByGridPoint,
+	nothingBiggerThan,
+	distanceGreaterThan
+) where
+
+import Model
+import Grouper
+import Selector
+import qualified Random as R
+
+
+
+
+-- randomly select n points
+--	are the Int's in the type signature bad?                current answer: leave them for now, refactor to Integral/Integer if necessary later
+randomPoints :: Int -> Int -> Schedule -> Schedule
+randomPoints n s = genericSelect combTransSepQuad (\_ -> ()) (\_ -> selectNRandomly n s)
+
+
+-- select n points, using a weighting function
+--	what if the schedule has fewer than n points?
+--	the weighting function returns an Integer; would a floating-point number be better?
+bestByGridPoint :: Int -> (GridPoint -> Integer) -> Schedule -> Schedule
+bestByGridPoint n f = genericSelect combTransSepQuad f (selectNBest n)
+
+
+-- should I have to specify 'Int'?  No!!!!
+probByGridPoint :: (Fractional t, R.Random t, Ord t) => Int -> Int -> (GridPoint -> t) -> Schedule -> Schedule
+probByGridPoint n s f = genericSelect combTransSepQuad f (selectNProb n s)
+
+
+bestByGridPointAllQuadUnits :: Int -> (GridPoint -> Integer) -> Schedule -> Schedule
+bestByGridPointAllQuadUnits n f = genericSelect combTransCombQuad f (selectNBest n)
+
+
+randomPointsAllQuadUnits :: Int -> Int -> Schedule -> Schedule
+randomPointsAllQuadUnits n s = genericSelect combTransCombQuad (\_ -> ()) (\_ -> selectNRandomly n s)
+
+
+nothingBiggerThan :: Integer -> Schedule -> Schedule
+nothingBiggerThan n = genericSelect combTransCombQuad (all (<= n)) filter
+
+distanceGreaterThan :: (Floating a, Ord a) => a -> Schedule -> Schedule
+distanceGreaterThan d = genericSelect combTransCombQuad (\gp -> d < sqrt (sum $ map ((** 2) . fromInteger) gp)) filter

haskell/sampleScheduler/src/Formatter.hs

@@ -0,0 +1,113 @@
+{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-}
+
+module Formatter (
+	varian,
+	bruker,
+	custom,
+	json,
+	toolkit,
+	separateTransients
+) where
+
+
+import Model
+import Grouper
+import qualified Data.Map as M
+import qualified Data.List as L
+import qualified Data.Set as S
+import qualified Text.RJson as R
+import qualified GHC.Exts as E
+--import qualified Data.Ord as O
+
+
+-- ignore the number of transients; one coordinates/quadunit per line
+-- 0-indexed
+varian :: Schedule -> String
+varian sched = concat $ L.intersperse "\n" formattedPts
+  where
+    formattedPts = map (sprint . decrementCoordinates) $ removeDuplicates $ getPoints sched
+    decrementCoordinates pt = makePoint (map (flip (-) 1) $ gridPoint pt) $ quadUnit pt
+
+
+-- ignore quadrature, transients; print out unique coordinates; one number per line
+-- 1-indexed
+bruker :: Schedule -> String
+bruker sched = concat $ L.intersperse "\n" $ map show coordinates
+  where
+    coordinates = concat $ removeDuplicates gridPoints                       -- put all integers in a single list (each integer corresponds to a line)
+    gridPoints = map gridPoint $ getPoints sched                                -- unwrap grid points from Schedule, Map, tuple, Point contexts
+
+
+removeDuplicates :: (Ord a) => [a] -> [a]
+removeDuplicates = S.toList  .  S.fromList
+
+
+-- ignore transients; all quadunits of a coordinates in one line
+-- 1-indexed
+toolkit :: Schedule -> String
+toolkit sched = concat $ L.intersperse "\n" $ map lineForm ptlines
+  where
+    lineForm (gp, qus) = concat $ L.intersperse " " (sprint gp : (map sprint qus))    -- put a space between each coordinate, QuadUnit, all together on one line
+    ptlines = map (fmap (map fst)) pointTransients                                    -- get rid of the transients, keeping just the GridPoint and the QuadratureUnits
+    pointTransients = (getGrouper combTransCombQuad) $ getPoints sched                -- group the points into [(GridPoint, [(QuadratureUnit, Transients)])]
+
+
+-- one coordinates/quadunit per line
+-- 1-indexed
+custom :: Schedule -> String
+custom = sprint
+
+
+-- one transient per line; like varian format except that points may be repeated (to indicate multiple transients)
+-- 1-indexed
+separateTransients :: Schedule -> String
+separateTransients sched = concat $ L.intersperse "\n" tLines -- transLine
+  where
+    tLines = do
+      pt <- L.sort $ getPoints sched                                                            -- unwrap points from Schedule, Map context
+      return $ formatPoint pt                                                     
+    formatPoint pt = concat $ L.intersperse " " [sprint $ gridPoint pt, sprint $ quadUnit pt]     -- put a space between each coordinate, quadunit
+
+
+-- 1-indexed
+json :: Schedule -> String
+json = show . toJson
+
+-------------------------------------------------
+
+toJson :: Schedule -> R.JsonData
+toJson sched = R.JDObject $ M.fromList [("points", pointsToJson $ getPoints sched)]
+  where
+    pointsToJson = R.JDArray . map ptToJson
+
+ptToJson :: Point -> R.JsonData
+ptToJson pt = R.JDObject $ M.fromList [("gridPoint", gridPointToJson $ gridPoint pt),
+                                       ("quadratureUnit", quadUnitToJson $ quadUnit pt)]
+  where
+    gridPointToJson = R.JDArray . map (R.JDNumber . fromInteger)
+    quadUnitToJson = R.JDArray . map (R.JDString . show)
+
+--------------------------------------------------
+
+class SchedulePrint a where
+  sprint :: a -> String
+
+instance SchedulePrint Quadrature where
+  sprint = show
+
+instance SchedulePrint GridPoint where
+  sprint = concat  .  L.intersperse " "  .  fmap show
+
+instance SchedulePrint QuadUnit where
+  sprint = concat . fmap sprint
+
+instance SchedulePrint Point where
+  sprint pt = concat [sprint $ gridPoint pt, " ", sprint $ quadUnit pt]
+
+instance SchedulePrint Schedule where
+  sprint sched = foldr comb "" groupedPts
+    where
+      groupedPts = (getGrouper combTransSepQuad) $ getPoints sched
+      comb (pt, t) base = concat [sprint pt, " ", show t, "\n", base]
+
+

haskell/sampleScheduler/src/GridPoints.hs

@@ -0,0 +1,79 @@
+module GridPoints (
+	uniformGrid,
+	allLowerBounds,
+	firstPoint,
+	lastPoint,
+	halton
+) where
+
+import Model
+import qualified Data.List as L
+import qualified Control.Applicative as A
+import qualified Data.Set as S
+
+
+-- randomGrid2d :: (Integer, Integer) -> (Integer, Integer) -> Integer -> [GridPoint]
+-- randomGrid2d (xl, xh) (yl, yh) totalpoints = random number generator ...
+
+uniformGrid :: (Enum t) => [(t, t)] -> [[t]]
+uniformGrid bounds = sequence ranges
+  where
+    ranges = map (\(l, h) -> [l .. h]) bounds
+
+allLowerBounds :: (Integral t) => [(t, t)] -> [[t]]
+allLowerBounds bounds = filter onLowerEdge gridpoints
+  where
+    gridpoints = uniformGrid bounds
+    onLowerEdge pt = any (\((l, _), c) -> l == c) (zip bounds pt)    -- can this be refactored (to use zipWith or as a ZipList?)
+                                                                     --           or maybe use the 'Any' monoid (LYAH Ch 11)
+
+firstPoint :: (Integral t) => [(t, t)] -> [[t]]
+firstPoint bounds = [map fst bounds]
+
+lastPoint :: (Integral t) => [(t, t)] -> [[t]]
+lastPoint bounds = [map snd bounds]
+
+
+-- Int in type signature
+-- if there are more than n dimensions in the bounds (n is currently 10 -- the number of primes) -- bad things will happen
+-- does it hit no more than the maximum, no less than the minimum?  it looks like it, but there should be unit tests
+-- if you tell it to take lots of points, and there aren't that many available .... infinite loop (say, 500 from [(1,5)])
+halton :: (Integral t) => [(t, t)] -> Int -> [[t]]
+halton bounds num = S.toList $ foldWhile (\s -> S.size s < num) S.insert S.empty scaledPoints
+  where
+    scaledPoints = map scalePoint points                                                 -- scale the numbers so they fall between the bounds (inclusive!)
+    scalePoint cs = A.getZipList $ (\sf l c -> (floor $ c * sf) + l) A.<$> A.ZipList scalingFactors A.<*> (A.ZipList $ map fst bounds) A.<*> A.ZipList cs
+    scalingFactors = map (\(l, h) -> fromIntegral (h - l + 1)) bounds                    -- is the (+1) correct?  it seems that 'floor' always knocks it down a notch, so ... yes?
+    haltonNums = map (\p -> map (haltonNumber p) [0..]) $ take (length bounds) primes    -- associate a prime with each dimension;  generate halton numbers as infinite lists
+    points = L.transpose haltonNums                                                      -- combine the numbers from the dimension lists to form points
+    primes = [2, 3, 5, 7, 11, 13, 17, 19, 23, 29]
+
+haltonNumber :: Integer -> Integer -> Double
+haltonNumber b i = go 0 (1 / db) i                   -- b is usually a prime; i is the index into the series
+  where
+    go :: Double -> Double -> Integer -> Double
+    go r _ 0 = r                                     -- can it be less than 0?
+    go r f i = go newr (f / db) newi
+      where
+        newr = r + f * (fromInteger $ mod i b)
+        newi = floor $ fromInteger i / db
+    db = fromInteger b
+
+foldWhile :: (b -> Bool) -> (a -> b -> b) -> b -> [a] -> b
+foldWhile pred comb base things = go base things
+  where
+    go b [] = b
+    go b (t:ts) 
+      | pred b = go (comb t b) ts
+      | otherwise = b
+
+
+--concentricShell :: (Integral t, Floating t1) => [(t,t)] -> t1 -> t1 -> [[t]]
+concentricShell bounds spacing maxdev = filter close $ uniformGrid bounds
+  where
+    close point = mydist point <= maxdev                  -- if the point is close to one of the shells (maxdev is a distance)
+    mydist pt = abs (ratio - (fromInteger $ round ratio)) * spacing     -- measuring closeness:  difference between 1) distance from the origin divided by spacing and 2) the nearest integer, multiplied by spacing
+      where
+        ratio = distance / spacing
+        distance = sqrt $ sum $ map ((**2) . fromIntegral) pt
+

haskell/sampleScheduler/src/Grouper.hs

@@ -0,0 +1,59 @@
+module Grouper (
+	Grouper,
+	getGrouper,
+	getGridPoint,
+	getUngrouper,
+	sepTransSepQuad,
+	combTransSepQuad,
+	combTransCombQuad
+) where
+
+import Model
+import GHC.Exts (groupWith)
+import Data.List (genericLength, genericReplicate)
+
+data Grouper a = Grouper { getGrouper :: ([Point] -> [a]),
+			getGridPoint :: a -> GridPoint,
+			getUngrouper :: ([a] -> [Point]) }
+
+sepTransSepQuad :: Grouper Point
+sepTransSepQuad = Grouper g ggp ug
+  where
+    g = id
+    ggp = gridPoint
+    ug = id
+
+
+combTransCombQuad :: Grouper (GridPoint, [(QuadUnit, Integer)])
+combTransCombQuad = Grouper g ggp ug
+  where
+    g pts = map morpher $ groupWith (gridPoint . fst) ptsByPoint
+      where
+        morpher mpts@((pt,t):ps) = (gridPoint pt, map (\(pt1, t1) -> (quadUnit pt1, t1)) mpts)           -- can this be cleaned up?
+        ptsByPoint = map (\x -> (head x, genericLength x)) $ groupWith id pts
+    ggp = fst
+    ug gpts = do
+	(gp, qu_ts) <- gpts
+	(qu, t) <- qu_ts
+        [1 .. t]
+	return $ makePoint gp qu
+
+combTransSepQuad :: Grouper (Point, Integer)
+combTransSepQuad = Grouper g ggp ug
+  where
+    g = map (\pts -> (head pts, genericLength pts)) . groupWith id
+    ggp = gridPoint . fst
+    ug = concatMap (\(pt, t) -> genericReplicate t pt)
+
+
+-- I think this doesn't make any sense
+--sepTransCombQuad :: Grouper (GridPoint, [QuadUnit]) 
+--sepTransCombQuad = Grouper g gp ug
+--  where
+--    g pts = map morpher $ L.groupBy (F.on (==) (gridPoint . fst)) $ L.sortBy (O.comparing (gridPoint . fst)) pts
+--    morpher mpts = (gridPoint $ fst $ head mpts, map (\(pt, t) -> L.genericReplicate t $ quadUnit pt) mpts)
+--    gp = fst
+--    ug gpts = do
+--	(gp, qus) <- gpts
+--	qu <- qus
+--	return (Point gp qu, 1) -- is this being unnecessarily inefficient