local-search 0.0.5 → 0.0.6
raw patch · 10 files changed
+548/−604 lines, 10 filesdep +erf
Dependencies added: erf
Files
- Control/Search/Local.hs +239/−197
- Control/Search/Local.hs~ +0/−148
- Control/Search/Local.lhs~ +0/−104
- Control/Search/Local/Distributions.hs +178/−0
- Control/Search/Local/Eager.hs +14/−9
- Control/Search/Local/Example.hs +3/−3
- Control/Search/Local/Queue.hs +0/−20
- Control/Search/Local/Strategies.hs +105/−49
- Demo.hs +0/−67
- local-search.cabal +9/−7
Control/Search/Local.hs view
@@ -16,11 +16,11 @@ > loopP iterativeImprover tspSeed Many search strategies do not always produce improving sequences as the iterative improver does. For these- we provide a simple modification of 'scanl' which can be applied to any stream, called 'saveBest'.+ we provide a simple modification of 'scanl' which can be applied to any stream, called 'bestSoFar'. Finally, these streams are usually descriptions of unlimited processes. To make them practical we limit them using standard Haskell combinators such as 'take' and list index. - > take 20 . saveBest $ loopP searchStrategy seed+ > take 20 . bestSoFar $ loopP searchStrategy seed Search strategies are constructed via the composition of other functions. This often resembles the composition of an arrow pipeline, and this library can be rewritten in terms of arrows, however we have @@ -29,7 +29,7 @@ A simple TABU like search strategy, that has a memory of the recent past (10 elements) of the search process, and filters neighbourhoods accordingly can be created like this; - > searchStrategy xs = map head $ adaptive filter adaptive filter (flip notElem) (window 10 xs) (neighbourhoods xs) + > searchStrategy xs = map head $ zipWith (\ws->filter (flip notElem ws)) (window 10 xs) (neighbourhood xs) A common way to improve meta-heuristics is to introduce stochastic elements, such as random decisions from a constrained set of choices, or neighbourhoods which will not generate exactly the same set of options each time a particular solution @@ -37,7 +37,7 @@ the user of the transformation to a great deal of the process. For example in the above example, to create a random choice from the constrained set at each point you would do this; - > searchStrategy rs xs = zipWith randomChoice rs $ adaptive filter adaptive filter (flip notElem) (window 10 xs) (neighbourhoods xs) + > searchStrategy rs xs = select uniformCDF $ zipWith (\ws->filter (flip notElem ws)) (window 10 xs) (neighbourhood xs) The neighbourhood can be similarly modified. We must still provide the starting points for the extra data used by such transformers, in this case a stream of random values, or in other cases a random number generator, but one provided@@ -47,78 +47,138 @@ merging and dividing streams in sequenced patterns. For example; > applyToBoth tr as bs = (\xs->(map head xs,map last xs)) . chunk 2 $ tr (concat $ transpose [as,bs])- - -} module Control.Search.Local( -- * Types- StreamT,ExpandT,ContraT,- -- * Generic Combinators- lift,bestSoFar,chunk,window,until_,divide,join,nest,nestWithProb,makePop,+ StreamT,Stream,List,+ -- * Optimisable Type Class+ Optimisable,(=:=),(>:),(<:),best,worst,bestOf,sortO,bestSoFar,+ -- * Stream Transformation Combinators+ doMany,chunk,variableChunk,stretch,variableStretch,window,variableDoMany,varyWindow,improvement,+ select,select',until_,restart,restartExtract,nest,preNest,divide,join, -- * Loop Combinators loopP,loopS,- -- * Filters & Choices- improvement,varyWindow,tabuFilter,saChoose,- gaSelect,manySelect,select,streamSelect,- -- * Distributions- logCooling,geoCooling,linCooling, - -- * Complex GA distributions, experimental- limitedDistribution,geometricDistribution,uniformDistribution,- distributionSelectWithRemainder+ -- * Helper functions+ safe, ) where import Data.List-import Control.Search.Local.Queue+import System.Random+import System.IO.Unsafe -{-| The basic stream transformation type. This converts elements of one type into (expected) different elements of the - same type. -}-type StreamT s = [s]->[s]-{-| Many processes in meta-heuristics will create sets of options (e.g. neighbourhood functions) or collect - sets of information about streams (e.g. 'window'). This is the data type for these functions. -}-type ExpandT s = [s]->[[s]]-{-| Choices and selections from larger sets of elements are modelled as these /contractions/, for example - the selection of an element from a neighbourhood, or rather a stream of neighbourhoods. -}-type ContraT s = [[s]]->[s]+{-| In previous versions I have used the standard 'Eq' and 'Ord' classes. However I have then + had to assume that every problem is a minimisation. To get around this, and provide functions that + match more closely to optimisation problems, where the concept we seek is /better than/, rather than + /greater/ or /less/ than, I provide this new class. It is however very very like 'Ord'. + It is proposed that this class is used for value of solution comparisons only, and the standard 'Eq' class+ is retained for situations where the solutions are identical, and do not just share the same value.-}+class Optimisable a where+ {-| Equal to, by solution quality.-}+ (=:=) :: a -> a -> Bool + {-| Better than, assumed to be by solution quality. -}+ (>:) :: a -> a -> Bool + {-| Worse than, assumed to be by solution quality. -}+ (<:) :: a -> a -> Bool ++{-| This returns the best solution in an input list. It can be thought of as similar to 'maximum'.-}+best :: Optimisable s => [s] -> s+best (x : xs) = foldl (\ a b -> if a >: b then a else b) x xs++{-| This returns the worse solution in an input list. It can be thought of as similar to 'minimum'.-}+worst :: Optimisable s => [s] -> s+worst (x : xs) = foldl (\ a b -> if a <: b then a else b) x xs++{-| This returns the best of two input solutions. It can be thought of as similar to 'max'.-}+bestOf :: Optimisable s => s -> s -> s+bestOf a b = if a >: b then a else b++{-| An alternative version of 'sort' (implemented in terms of 'sortBy'), + but using 'Optimisable', so that better solutions are earlier in the output list than worse ones.+-}+sortO :: Optimisable a => [a] -> [a]+sortO = sortBy (\ a b -> if a >: b then LT else GT)++{-| A transformer that is usually used as a final step in a process, to allow the user + to only see the best possible solution at each point, and ignore the intermediate values+ that a strategy may produce. +-}+bestSoFar :: Optimisable s=>StreamT s s+bestSoFar (x:xs) = scanl bestOf x xs++{-| The basic stream transformation type. -}+type StreamT a b = Stream a->Stream b++{-| Internally streams are represented as standard Haskell lists. This type synonym is provided for readability. It is assumed that streams will be infinite.-}+type Stream s = [s]++{-| Lists are also used to represent finite collections or groups of solutions. This synonym is for where+ the list is being used as a finite list. -}+type List s = [s]+ {-| The standard function for /tying the knot/ on a stream described process. This links the outputs of the stream process to the inputs, with an initial set of values, and provides a single stream of values to the user. -}-loopS :: StreamT s->StreamT s+loopS :: StreamT s s->StreamT s s loopS streamT seed = let sols = seed ++ streamT sols in sols {-| A more specific version of 'loopS' and implemented in terms of it. Rather than allowing a number of initial values, this allows only 1.-}-loopP :: StreamT s->s->[s]+loopP :: StreamT s s->s->Stream s loopP f x = loopS f [x] -{-| /lift/ is a lifting function, originally designed to lift filters and partitions to operate over - interrelated streams of data. An example of use is;+{-| This was original created to assist with making multiple selections from a population within a genetic + algorithm. More generally this is a higher order function which will take a stream transformation and apply+ it multiple times to each element of the input stream gathering up the results. - > lift filter (<) as bs --}-lift :: (t -> b -> c) -> (a -> t) -> [a] -> [b] -> [c]-lift f g = zipWith (f.g)+ It can be used to make multiple selections from a population in a GA, or to create a neighbourhood + function from a perturbation operation. For example; + > nF = doMany 5 perturbFunction -{-| A transformer that is usually used as a final step in a process, to allow the user - to only see the best possible solution at each point, and ignore the intermediate values- that a strategy my produce. --}-bestSoFar :: Ord s=>StreamT s-bestSoFar ~(x:xs) = scanl min x xs+ Where /5/ is just an arbitrary example constant and /perturbFunction/ is a placeholder.+ + If the perturb function is defined with a parameter controlling the perturbation, for example a random number, + such as which pair of cities in a TSP to exchange then you can do this for a deterministic operation; + > nF = doMany 5 (zipWith perturbationFunction (cycle [0..4]))++ For a more stochastic effect;+ + > nF = doMany 5 (zipWith perturbationFunction (randoms g)) ++ Where /g/ is assumed to be of the 'System.Random.RandomGen' class.++ -}+doMany :: Int->StreamT s s'->StreamT s (List s')+doMany sz f = chunk sz . f . stretch sz++{-| /variableDoMany/ perfoms the same action as 'doMany', but allows the programmer to vary how many times + the transformation is applied to each underlying solution, through the use of a stream of sizes.-}+variableDoMany :: Stream Int->StreamT s s'->StreamT s (List s')+variableDoMany szs f = variableChunk szs . f . variableStretch szs+ {-| Creates a rolling window over a stream of values up to the size parameter. The windows are then - produced as a stream of lists. -}-window :: Int->ExpandT s-window sz = (map toList) . (scanl fappend initQ)- where- fappend q v | sizeQ q == sz = append (remove q) v- | otherwise = append q v+ produced as a stream of lists. This can also be done using a queue data structure, however this + was found to be slightly faster.-}+window :: Int->StreamT s (List s)+window sz xs = concat [zipWith take [0..sz] (repeat xs) ,map (take sz) . tails .drop (sz-1) $ xs] +{-| A function for transforming a stream of 'window's, taking random numbers of elements from the front + of each window. This can be used in the implementation of variations of the TABU search algorithm. + Usage as follows (with example values) ;++ > varyWindow (3,6) . window 10+-}+varyWindow :: (Int, Int) -> Stream (List s) -> Stream (List s)+varyWindow range = unsafePerformIO k+ where k = do g <- newStdGen+ return $ zipWith take (randomRs range g)+ {-| Breaks down a stream into a series of chunks, frequently finds use in preparing sets of random numbers for various functions, but also in the 'makePop' function that is important for genetic algorithms. -}-chunk :: Int->ExpandT s+chunk :: Int->StreamT s (List s) chunk i xs = let t = (take' i xs) in t `seq` (t : chunk i (drop i xs)) where take' :: Int->[a]->[a]@@ -130,186 +190,168 @@ -- chunk i xs = let (as,bs) = splitAt i xs in as : chunk i bs -- chunk i = unfoldr (Just . splitAt i) -{-| Takes an input stream, breaks it down into 'chunk's, then sorts these chunks and stretches them to - give a stream of populations for processing in a genetic algorithm. -}-makePop :: Ord s => Int -> ExpandT s-makePop sz = concatMap (replicate sz . sort) . chunk sz--{-| A way to link one stream with another at a joining point. The first stream is given as a list only, - the second stream is given as a function which converts from a passed value into a list. - The trigger is provided by a list of booleans paired with the passed values for creating the second list. -- This allows for the creation of cyclical restarting cooling strategies in simulated annealing using a code - snippet like this;+{-| A more flexible version of chunk which can vary the size of each chunk, in accordance with a list providing the + sizes required of each grouping. For example; - > let triggers = map (==0) . zipWith (-) (tail sols) $ sols- > restart basicS cs = until_ basicS cs $ map (restart basicS) (tails cs)- > coolStrat = restart (geoCooling 80000 (*0.5)) triggers- > in ....+ > chunk i = variableChunk (repeat i)+ > variableChunk (cycle [1,2]) [0..] = [[0],[1,2],[3],[4,5]... -}-until_ :: [a]->[Bool]->[[a]]->[a]-until_ (a:_) (True:_) (_:cs:_) = a : cs-until_ (a:as) (False:bs) (_:cs) = a : until_ as bs cs--{-| Splits a stream into two parts. The output of the contraction is not well named here, - it is in fact a collection of streams. The first stream being the part of the original stream - that matched to /False/ in the boolean stream, the second matching to /True/.+variableChunk :: Stream Int->StreamT s (List s)+variableChunk (i:is) xs = let t = take i xs in t : variableChunk is (drop i xs) - Any method can be used to create the boolean stream, e.g.- - > cycle [True,False]- > map (<0.75) (randoms g) --}-divide :: [Bool]->ExpandT s-divide bs xs = [[ x | (b,x)<-zip bs xs,b==i] | i <-[False,True]]+{-| An operation which changes the structure of an underlying stream, but not the data type, by + replicating the elements of the stream in place. Can be thought of as changing the /speed/ of the stream. + This finds use in 'doMany', genetic algorithms and ant colony optimisation.+ For example; -{-| Integrates a collection of streams. The boolean stream indicates the order of integration. - A /True/ in the boolean stream will cause an element to be taken from the second stream, - a /False/ will cause it to take from the first.-}-join :: [Bool]->ContraT s-join bs xss = unfoldr f (bs,xss)- where- f (False:ts,[x:xs,ys]) = Just (x,(ts,[xs,ys]))- f (True:ts,[xs,y:ys]) = Just (y,(ts,[xs,ys]))+ > stretch 2 "abcd" = "aabbccdd" -{-| A nesting procedure. This can nest one transformer into another. The boolean stream - provides the pattern for where the parametrising transformer should be run, with 'True' being the - indicator. It is constructed using divide and join.+-}+stretch :: Int->StreamT s s+stretch sz = concatMap (replicate sz) - A simple example of this in operation is the following; We will have a stream of integers, - incrementing by one each time. Every so often, we will increment by an additional 2.+{-| A more flexible version of stretch which can vary how far each value in the underlying stream is stretched, + in accordance with a list providing the sizes required of each grouping. For example; - > take 20 $ loopP (nest (concat $ repeat [False,False,True,False]) (map (+2)) . map (+1)) 0 + > stretch i = variableStretch (repeat i)+ > variableStretch [3,3,7,2] "abcd" = "aaabbbcccccccdd" +-}+variableStretch :: Stream Int->StreamT s s+variableStretch sz = concat . (zipWith replicate sz) - This is primarily used in the genetic algorithm system for creating mutation transformers.+{-| This function transforms a neighbourhood function to give a transformation that yields /improving/ + neighbourhoods, that is, neighbourhoods that only contain solutions that improve upon the seed solution.+ In the case that there are no improving solutions (local minima), the output is a singleton list + containing the seed solution. This functionality is provided byt the 'safe' helper function.-}+improvement :: Optimisable s => StreamT s (List s) -> StreamT s (List s)+improvement nf sols = safe (map (:[]) sols)+ $ zipWith (\a b -> filter (a >:) b) sols (nf sols) - There is also a current problem with the nesting function. If the -O2 flag is not used during compilation- it causes a memory leak, for reasons currently unknown.- -}-nest :: [Bool]->StreamT s->StreamT s-nest bs tr = join bs . zipWith ($) [id,tr] . divide bs+{-| The generalised selection routine. This takes a stream of lists and selects one element from each list, + to construct the new stream. The selection routine takes a 'DistributionMaker', and selects based upon this.+ This only really makes sense when there is some internal structure in the stream of lists. For example; -{-| A specialisation of the nesting routine, which takes a stream of random values, and a- proportion/probability. This is used to construct the stream of booleans with that - proportion set to True. -}-nestWithProb :: (Ord r,Floating r)=>[r]->r->StreamT s->StreamT s-nestWithProb rs p = nest (map (<p) rs)+ > select (poissonCDF 1) . map sortO -{-| A lifted filter over interrelated streams, currently only used as part of the iterative improvers.-}-improvement :: Ord s=>ExpandT s->ExpandT s-improvement nf sols = lift filter (>) sols (nf sols)+ Each list in the input stream is sorted, so that the best solutions appear first. This is then selected from+ using a Poisson distribution, with the mean at 1. This means that the early (better) solutions are much more + likely to be selected.+-}+select :: (Random r, Ord r) => (Int -> List r) -> StreamT (List a) a+select mkDist = unsafePerformIO k + where k = do g <- newStdGen+ return $ select' (randoms g)+ select' rs xs = let dxs = map (\x -> zip (mkDist $ length x) x) xs+ in zipWith s dxs rs+ s [x] _ = snd x+ s ((p, x) : xs) r = if r > p then s xs r else x -{-| A specialist function that is used as part of a TABU variant called /robust taboo/. It is expected that - the integer stream provided is an appropriately ranged random stream, so that it can limit the TABU list at each - step by a random value. The version in the paper takes a range and random number generator. To avoid the - import of System.Random, this takes the stream of values to vary the window by. To implement the former;- - > varyWindow (randomRs range g) +{-| This function acts like 'select', however the distribution is fixed, not being constructed anew for each + list in the input stream. This is much more efficient, but does assume that the size of each list in the + input is the same (a fixed size neighbourhood is perfect for this). -}-varyWindow :: [Int]->StreamT [s]-varyWindow rs = zipWith take rs+select' :: (Random r,Ord r) => List r->StreamT (List a) a+select' dist = unsafePerformIO k + where k = do g <- newStdGen+ return $ select' (randoms g)+ select' rs xs = let dxs = map (\x -> zip dist x) xs+ in zipWith s dxs rs+ s [x] _ = snd x+ s ((p, x) : xs) r = if r > p then s xs r else x -{-| A filter, similar in some ways to an improvement filter, but more complex, carrying out the common TABU rules.- The first parameter is the stream of TABU lists, the second parameter the stream of source solutions. It operates - over streams of neighbourhoods. -}-tabuFilter :: Ord s=>[[s]]->ExpandT s->ExpandT s-tabuFilter tabu nf sols - = let (imp,notImp) = unzip $ lift partition (>) sols (nf sols)- notTabu = lift filter (flip notElem) tabu notImp- select [] [] c = c- select [] b _ = b- select a _ _ = a- in zipWith3 select imp notTabu notImp +{-| This function is very similar to the /until/ function of FRP. It takes a stream and + returns the elements of that stream until 'True' appears on the trigger stream. At this point + one of the potential futures is chosen and becomes the remainder of the stream. + The potential futures are zipped with the triggers, so the choice is fixed, the /current/ potential + future is the choice. More generally this concept could be elaborated in the future. -{-| The traditional choice function used within simulated annealing. The parameters are; - a function to yield quality of a solution, a value between 0 and 1 (stochastic expected) a temperature, - the old solution and the possible future solution. -}-saChoose :: (Floating v,Ord v)=>(s->v)->v->v->s->s->s-saChoose valueF r t oldSol newSol- | d<=0 || e>r = newSol- | otherwise = oldSol- where- e = exp (- (d/t))- d = (valueF newSol) - (valueF oldSol) + (1) The initial stream of values to place before the trigger+ (2) The stream of triggers+ (3) The stream of potential future streams -{-| A logarithmic cooling strategy intended for use within simulated annealing. Broadly the first value is - the starting temperature and the second a value between 0 and 1. -}-logCooling :: Floating b=>b->b->[b]-logCooling c d = map (\t->c / (log (t + d))) (iterate (+1) 1)+ Could be used to provide a temperature strategy that restarts once in Simulated Annealing like so; -{-| The most common cooling strategy for simulated annealing, geometric. The first value is the starting temperature, - the second a value between 0 and 1, the cooling rate. -}-geoCooling :: Floating b=>b->b->[b]-geoCooling startTemp tempChange = iterate (* tempChange) startTemp+ > let t = iterate (+1) 0 + > in until_ t triggerStream (repeat t) -{-| Included for completeness, this is a cooling strategy for simulated annealing that is usually not very effective,- a linear changing strategy. The first value is the starting temperature the second is the value to increase it by - at each step. In order to have it reduce at each step, pass a negative value. --}-linCooling :: Floating b=>b->b->[b]-linCooling startTemp tempChange= iterate (+ tempChange) startTemp+ This alternative will restart every time 'True' appears on the trigger stream, not just the first time. --- ga selection functions+ > let t = until_ (iterate (+1) 0) triggerStream (repeat t) in t+-}+until_ :: Stream a -- stream of values, to place before trigger+ -> Stream Bool -- stream of triggers for switch over+ -> Stream (Stream a) -- stream of potential futures+ -> Stream a+until_ (a:_) (True:_) (_:(cs:_)) = a : cs+until_ (a : as) (False : bs) (_: cs) = a : until_ as bs cs -{-| The basic selection function, not in stream form. This takes a distribution, - a random number, a collection of elements to select from and gives back - a single value, selected from the collection. -}-select :: Ord r=>[r]->r->[s]->s-select dist r = snd . head . dropWhile ((r>) . fst) . zip dist+{-| A helper function that chooses between elements of the two input streams at each point in the + stream, and returns one which is non-empty. The check looks at values in the second stream first, + if this list is not empty, it is returned.+-}+safe :: Stream (List v) -> Stream (List v) -> Stream (List v)+safe = zipWith (\a b -> if null b then a else b) -{-| The lifting of select to operate over streams of values, rather than making a single selection. - Provides a stream contraction operation. The first parameter is the distribution, the second a - stream of random values.-}-streamSelect :: Ord r=>[r]->[r]->ContraT s-streamSelect dist = zipWith (select dist)+{-| Restart is a little like loop. It will construct a stream of values by applying a stream transformation + to one value, and then the successor and so on. It differs in that it also takes a triggering mechanism+ that can choose to stop the current sequence and continue from a different value (the next value on the + initial stream). For example, the following will start counting initially from 0, then -5, then -10, and + will count until it reaches 11 each time. -{-| This was original created to assist with making multiple selections from a population within a genetic - algorithm. More generally this is a function which operates over streams of collections (lists). - It takes a contraction operation and a size. It will apply the contraction a number of times to - each collection, gather the results and release a new collection. + > restart (map (+1)) (map (>10)) [0,-5,-10]+ -}+restart :: StreamT a a->StreamT a Bool->StreamT a a+restart f r (a : as) = let ms = loopP (nest [(False, id), (True, const as)] (r ms) . f ) a+ in ms+{-| Exactly like 'restart', except that it will only return the result of an iteration of transformation,+ not the intermediate values. For example; - If the contraction stream operation has internal state, such as a stochastic factor, this will be - used correctly, each collection will not have the same elements selected, nor will the same element be- selected repeatedly from each collection. -}-manySelect :: Int->(ContraT s)->StreamT [s]-manySelect sz f = chunk sz . f . concatMap (replicate sz)- -{-| This can be considered the standard genetic algorithm selection process, though it is still - quite parametrisable. It takes a size, the number of elements for each recombination, - a distribution for the selection process to use and a stream of random numbers to control the - selections.+ > restartExtract (map (+1)) (map ((==0) . flip mod 4)) [1,-5,-10,-13] - The most basic version would select 2 parents using a geometric selection curve, like this;- - > gaSelect 2 (iterate (*1.005) 0.005) rs+ gives; - However there is no prescription on the distribution, or number of parents, e.g.+ > [4,-4,-8.. - > gaSelect 3 (uniform 0.1) rs+ -}+restartExtract :: StreamT a a->StreamT a Bool->StreamT a a+restartExtract f r (a : as) = let ms = loopP (nest [(False, id), (True, const as)] rs . f ) a+ rs = r ms+ in [l | (p, l) <- zip (drop 2 $ window 2 rs) ms, p == [True, False]] - Though I do not provide a /uniform/ function at the present time, I intended this example - to suggest three parents selected using a uniform distribution. - -}-gaSelect :: Ord r=>Int->[r]->[r]->StreamT [s]-gaSelect sz dist rs = manySelect sz (streamSelect dist rs)+{-| Is the combination of 'divide' and 'join'. It takes a set of indices and stream transformations, + divides the input stream, using the indices and a stream of indices, transforms each substream + by the related stream transformation, and then puts them all back together again as a new stream. + For example, to apply a transformation (f) to only every third value in a stream, you could do this; + > nest [(True,id),(False,f)] (cycle [True,True,False])+-}+nest :: Eq n => List (n, Stream a -> Stream b) -> Stream n + -> Stream a -> Stream b+nest fs ns = flip join ns . zipWith (\(n, f ) s -> (n, f s)) fs + . divide (map fst fs) ns -distributionSelectWithRemainder :: Ord r=>[r]->r->[s]->(s,[s])-distributionSelectWithRemainder dist r xs - = let (as,bs) = span ((r>) . fst) $ zip dist xs- as' = map snd as- bs' = map snd bs- in if null bs then (last as',init as') else (head bs',as'++(tail bs')) +{-| This function acts like 'nest', but the name stream makes choices (or can do) based upon the initial value+ of solutions on the input stream.-}+preNest :: Eq n => (Stream a -> Stream n) -> List (n, Stream a -> Stream b) + -> Stream a -> Stream b+preNest d fs xs = nest fs (d xs) xs -uniformDistribution :: (Fractional n,Num n)=>n->[n]-uniformDistribution x = scanl (+) x (repeat x)+{-| Join is the inverse of 'divide', it combined substreams into a stream fo values. + It takes a list of substreams, and the indices that indicate them, and then a stream of the indices.+ For each value in the stream of indices, the /next/ value in the appropriate substream is chosen and + produced. +-}+join :: Eq n => List (n, Stream v) -> Stream n -> Stream v+join streams ns = unfoldr f (ns, streams)+ where+ f (k : ks, vs) = let (as, (n, p : ps) : bs) = break ((== k) . fst) vs+ in Just (p, (ks, as ++ (n, ps) : bs)) -geometricDistribution :: Num n=>n->n->[n]-geometricDistribution fact start = map (1-) $ iterate (*fact) start+{-| Divide splits a stream of values into a list of substreams. The division is controlled by + a list of /indices/ and then a stream of these indices. -}+divide :: Eq n => List n -> Stream n -> Stream v -> List (Stream v)+divide indices ns xs = [substream (map (== n) ns) xs | n <- indices]+ where substream bs = map snd . filter fst . zip bs -limitedDistribution :: Fractional n=>Int->[n]->[n]-limitedDistribution numElements xs = let xs' = take numElements xs- i = last xs'- in map (/i) xs'
− Control/Search/Local.hs~
@@ -1,148 +0,0 @@--------------------------------------------------------------------------------- |--- Module : Control.Search.Local--- Copyright : (c) Richard Senington & David Duke 2010--- License : GPL-style--- --- Maintainer : Richard Senington <sc06r2s@leeds.ac.uk>--- Stability : provisional--- Portability : portable--- --- This is the unification, and it is not expected that a user will have to directly import any other files, they are --- all exposed through this one. It then defines some basic search strategies of its own.------------------------------------------------------------------------------ --module Control.Search.Local (- -- Strategies - firstImprov,- minImprov,- maxImprov,- randomImprov,- randomWalk,- simpleTabu,- minFirstTabu,- maxFirstTabu,- stochasticTabu,- saTemp,- simulatedAnnealingA,- simulatedAnnealingB,- - -- Navigators- firstChoice,- manualNavigator,- -- Transformations- improvement,- nShuffle,- nSort,- nReverse,- tabu,- thresholdWorsening,- varyingThresholdWorsening,- multiLevelApply,- sImprovement,- sSort,- sReverse-- -- The internal tree, and accessor functions- LSTree(LSTree,treeNodeName,treeNodeChildren), - mkTree,-- -- Neighbourhoods and problem specific stuff- exchange,- basicExchange,- NumericallyPriced(priceSolution)-)where--import Control.Search.Local.Tree-import Control.Search.Local.Transformation-import Control.Search.Local.Navigator-import Control.Search.Local.Neighbourhood -import System.Random---- | First improvement, relies upon the solutions forming an ordering. --firstImprov :: Ord nme=>LSTree nme->[nme]-firstImprov = firstChoice . improvement--{- | Minimal improvement, will take the worst solution, that still improves upon the current - solution. It is slightly more cautious, and is likely to create longer paths in most problems. -}--minImprov :: Ord nme=>LSTree nme->[nme]-minImprov = firstImprov . nSort---- | Maximal improvement, always takes the best neighbour, and stops when there are no more improvements--maxImprov :: Ord nme=>LSTree nme->[nme]-maxImprov = firstImprov . nReverse . nSort---- | Random improvement, only accepts improvements, but is less predictable as to which it will take.--randomImprov :: (RandomGen g,Ord nme)=>g->LSTree nme->[nme]-randomImprov g = firstImprov . (nShuffle g)--{- | The simplest strategy. The randomisation may not be needed, it depends how - structured the tree is originally. Using the basicExchange function it will - be very ordered, so this is useful. -}--randomWalk :: RandomGen g=>g->LSTree nme->[nme]-randomWalk g = firstChoice . (nShuffle g)--{- | The simplest Tabu search, simply disallows backtracking, should do slightly better than a random walk, - but that is about it. -}--simpleTabu :: Eq nme=>Int->LSTree nme->[nme]-simpleTabu l = firstChoice . (tabu l [])--{- | This will always choose the lowest ordered element of the -neighbourhood, unless it has been seen recently. -The choice of the minFirstTabu or maxFirstTabu, depends upon the -problem, and how it has been encoded, does the user wish for -high ordered, or low ordered solutions. In most cases the -other becomes pointless. -}--minFirstTabu :: Ord nme=>Int->LSTree nme->[nme]-minFirstTabu l = (simpleTabu l) . nSort--maxFirstTabu :: Ord nme=>Int->LSTree nme->[nme]-maxFirstTabu l = (simpleTabu l) . nReverse . nSort--{- | Injection of a random element into TABU, less useful than it -sounds in this case, as this is very similar to simpleTabu.-In practice, real TABU systems use a process of choices. -If improvement is possible (subject to the TABU list) you-accept the first (in whatever order, that is where randomness comes in)-improvement you find. Otherwise you take another element and continue.-This has not yet been represented. -}--stochasticTabu :: (Eq nme,RandomGen g)=>Int->g->LSTree nme->[nme]-stochasticTabu l g =(simpleTabu l) . (nShuffle g ) --{- | A helper function for creating a falling temperature list. Used by -Simulated Annealing. Really just to make it slightly easier to see -what it is doing. -}--saTemp :: Num a=>a->a->[a]-saTemp p iTemp = iterate (*p) iTemp --{- | There are two variants on simulated annealing represented here. The first is simpler,-it assumes that the temperature represents a threshold for a limited worsening filter.-This is applied, and the system is then navigated randomly. -}--simulatedAnnealingA :: (NumericallyPriced nme a,RandomGen g)=>a->a->g->LSTree nme->[nme]-simulatedAnnealingA p iTemp g = firstChoice . (varyingThresholdWorsening (saTemp p iTemp)) . (nShuffle g)--{- |-The second takes the approach that SA tends to be (based upon a level of randomisation) -a random walk at high temperatures, and an iterative improver at low temperatures.-It generates a list of single level transformations based upon this idea, and then-applies them one at a time. -}--simulatedAnnealingB :: (Ord nme,RandomGen g,Num a,Random a,Ord a)=>a->a->g->LSTree nme->[nme]-simulatedAnnealingB p iTemp g = let (g' , g'' ) = split g- xs = zip (saTemp p iTemp) (randoms g') - gFuncs = [if x < y then id else sImprovement | (x, y ) <- xs ]- in firstChoice . (multiLevelApply gFuncs) . (nShuffle g'')----
− Control/Search/Local.lhs~
@@ -1,104 +0,0 @@-> module Control.Search.Local (-> firstImprov,minImprov,maxImprov,randomImprov,randomWalk,simpleTabu,minFirstTabu,maxFirstTabu,stochasticTabu,saTemp,simulatedAnnealingA,simulatedAnnealingB,-> firstChoice,manualNavigator,-> improvement,nShuffle,nSort,nReverse,tabu,thresholdWorsening,varyingThresholdWorsening,multiLevelApply,sImprovement,-> LSTree(LSTree),treeNodeName,treeNodeChildren,mkTree,-> exchange,basicExchange,priceSolution,NumericallyPriced-> )where--> import Control.Search.Local.Tree-> import Control.Search.Local.Transformation-> import Control.Search.Local.Navigator-> import Control.Search.Local.Neighbourhood -> import System.Random--This is the unification, and it is not expected that a user will have to directly import any other files, they are -all exposed through this one. It then defines some basic search strategies of its own.--First improvement, relies upon the solutions forming an ordering. --> firstImprov :: Ord nme=>LSTree nme->[nme]-> firstImprov = firstChoice.improvement--Minimal improvement, will take the worst solution, that still improves upon the current -solution. It is slightly more cautious, and is likely to create longer paths in most problems.--> minImprov :: Ord nme=>LSTree nme->[nme]-> minImprov = firstImprov.nSort--Maximal improvement, always takes the best neighbour, and stops when there are no more improvements--> maxImprov :: Ord nme=>LSTree nme->[nme]-> maxImprov = firstImprov.nReverse.nSort--Random improvement, only accepts improvements, but is less predictable as to which it will take.--> randomImprov :: (RandomGen g,Ord nme)=>g->LSTree nme->[nme]-> randomImprov g = firstImprov. (nShuffle g)--The simplest strategy. The randomisation may not be needed, it depends how -structured the tree is originally. Using the basicExchange function it will -be very ordered, so this is useful.--> randomWalk :: RandomGen g=>g->LSTree nme->[nme]-> randomWalk g = firstChoice.(nShuffle g)--The simplest Tabu search, simply disallows backtracking, should do slightly better than a random walk, -but that is about it.--> simpleTabu :: Eq nme=>Int->LSTree nme->[nme]-> simpleTabu l = firstChoice.(tabu l [])--This will always choose the lowest ordered element of the -neighbourhood, unless it has been seen recently. -The choice of the minFirstTabu or maxFirstTabu, depends upon the -problem, and how it has been encoded, does the user wish for -high ordered, or low ordered solutions. In most cases the -other becomes pointless.--> minFirstTabu :: Ord nme=>Int->LSTree nme->[nme]-> minFirstTabu l = (simpleTabu l).nSort--> maxFirstTabu :: Ord nme=>Int->LSTree nme->[nme]-> maxFirstTabu l = (simpleTabu l).nReverse.nSort--Injection of a random element into TABU, less useful than it -sounds in this case, as this is very similar to simpleTabu.-In practice, real Tabu systems use a process of choices. -If improvement is possible (subject to the TABU list) you-accept the first (in whatever order, that is where randomness comes in)-improvement you find. Otherwise you take another element and continue.--This has not yet been represented.--> stochasticTabu :: (Eq nme,RandomGen g)=>Int->g->LSTree nme->[nme]-> stochasticTabu l g =(simpleTabu l) . (nShuffle g ) --A helper function for creating a falling temperature list. Used by -Simulated Annealing. Really just to make it slightly easier to see -what it is doing.--> saTemp :: Num a=>a->a->[a]-> saTemp p iTemp = iterate (*p) iTemp --There are two variants on simulated annealing represented here. The first is simpler,-it assumes that the temperature represents a threshold for a limited worsening filter.-This is applied, and the system is then navigated randomly.--> simulatedAnnealingA :: (NumericallyPriced nme a,RandomGen g)=>a->a->g->LSTree nme->[nme]-> simulatedAnnealingA p iTemp g = firstChoice.(varyingThresholdWorsening (saTemp p iTemp)).(nShuffle g)--The second takes the approach that SA tends to be (based upon a level of randomisation) -a random walk at high temperatures, and an iterative improver at low temperatures.-It generates a list of single level transformations based upon this idea, and then-applies them one at a time.--> simulatedAnnealingB :: (Ord nme,RandomGen g,Num a,Random a,Ord a)=>a->a->g->LSTree nme->[nme]-> simulatedAnnealingB p iTemp g = let (g' , g'' ) = split g-> xs = zip (saTemp p iTemp) (randoms g') -> gFuncs = [if x < y then id else sImprovement | (x, y ) <- xs ]-> in firstChoice . (multiLevelApply gFuncs) . (nShuffle g'')----
+ Control/Search/Local/Distributions.hs view
@@ -0,0 +1,178 @@+{-| Selection routines have been made generic through the 'select' and 'select'' functions, + which are parametrised by probability distributions. This module provides functions for + constructing and manipulating some example probability distributions. +-}++module Control.Search.Local.Distributions(+ -- * Types+ Distribution,DistributionMaker,+ -- * Distributions+ normalCDF,poissonCDF,uniformCDF,firstChoice,lastChoice, + -- * Distribution Manipulation+ addDistributions,addDistributions',addDistributionMakers,addDistributionMakers',+ -- * Helper code+ poisson,fixEnd,normalCDF',poissonCDF',uniformCDF',+ -- * Debug code + cdf2pdf,distribution2SVG+) where++import Data.Number.Erf+import Data.List+import Control.Search.Local -- not actually used, imported for documentation linking.++{-| The data type for a discrete probability distribution. -}+type Distribution = [Double]++{-| The number of elements being selected between will often vary (such as in improving neighbourhoods), + so it will often be necessary to construct distributions with some constant properties, but varying the + length. -}+type DistributionMaker = Int->Distribution++{-| Parametrised as follows;+ + (1) mean+ + (2) standard deviation + + (3) size++ The function generates the CDF of a Normal distribution, using the mean and standard deviation, over the + range of discrete values [0 .. size]. The result is processed by the 'fixEnd' function, so the final + entry in the distribution is always 1. Over larger enough values of size this should be fine.+ -}+normalCDF :: Double->Double->DistributionMaker+normalCDF mean sd = fixEnd . normalCDF' mean sd ++{-| Parametrised as follows;+ + (1) mean+ + (2) standard deviation + + (3) size++ The function generates the CDF of a Normal distribution, using the mean and standard deviation, over the + range of discrete values [0 .. size]. This function is raw, and does not use 'fixEnd'. +-}+normalCDF' :: Double->Double->DistributionMaker+normalCDF' mean sd n = [ (1+ erf ((fromIntegral x-mean)/sd')) /2 | x<-[0..n]]+ where sd' = sd * sqrt 2++{-| Parametrised as follows;+ + (1) mean+ + (2) size++ This function generates the CDF of a Poisson distribution with the specified mean, over the range of + discrete values [0 .. size]. This function includes a call to 'fixEnd' so that the final value of the + distribution is always 1.+-}+poissonCDF :: Double->DistributionMaker+poissonCDF mean = fixEnd . poissonCDF' mean++{-| Parametrised as follows;+ + (1) mean+ + (2) size++ This function generates the CDF of a Poisson distribution with the specified mean, over the range of + discrete values [0 .. size]. This function gives the raw distribution.+-}+poissonCDF' :: Double->DistributionMaker+poissonCDF' mean k = map (poisson mean) [0..k]++{-| A function to generate a Uniform distribution CDF over the range [0 .. size]. For safety this includes + 'fixEnd', though this should have no effect.-}+uniformCDF :: DistributionMaker+uniformCDF = fixEnd . uniformCDF' ++{-| The raw Uniform distribution without using 'fixEnd'.-}+uniformCDF' :: DistributionMaker+uniformCDF' sz = let sz' = fromIntegral sz in [ fromIntegral x / sz' | x<-[1..sz] ]++{-| It is more likely that when always choosing the first element of list of choices 'head' will be + employed, but this has been included for completeness. This is a CDF. -}+firstChoice :: DistributionMaker+firstChoice n = replicate n 1++{-| Like 'firstChoice' it is more likely that 'last' will be used for this effect. This is also a CDF. -}+lastChoice :: DistributionMaker+lastChoice n = replicate (n-1) 0 ++ [1]++{-| This is parametrised as follows;++ (1) mean ++ (2) k ++ The function generates the probability of element /k/ being chosen from a Poisson distribution with the + specified mean. ++ This is quite a slow function and should probably be memoized in the future.+ -}+poisson :: Double->Int->Double+poisson mean k = exp(-mean) * sum [ (mean **(fromIntegral i)) / fi | (i,fi)<-zip [0..k] factorials] ++{-| Generates the infinite sequence of factorials.-}+factorials = scanl (*) 1 [1..]++{-| The basic CDF functions (e.g. 'poissonCDF'') often do not yield /complete/ CDFs. The distributions that + are produced tend to 1 in the last position of the list, but do not actually get there. For these to be + used practically, the last value of the list should be replaced with 1. This is a bodge, but under most + circumstances should not adversely effect results.-}+fixEnd :: Distribution->Distribution+fixEnd = (++[1]) . init++{-| To enable the construction of more exotic distributions from existing distributions. The basic function + combines them with equal weight on each component. For example;++ > addDistributions [[0,0.5,1],[1,1,1]] = [0.5,0.75,1]++ Compare this with 'addDistributions''. -}+addDistributions :: [Distribution]->Distribution+addDistributions as = map (/l) . map sum . transpose $ as+ where l = fromIntegral . length $ as++{-| A more flexible variation upon 'addDistributions' which allows the programmer to specify the weights to + merge the distributions with. For example;++ > addDistributions [0.3,0.7] [[0,0.5,1],[1,1,1]] = [0.7,0.85,1] +-}+addDistributions' :: [Double]->[Distribution]->Distribution+addDistributions' ps = map sum . transpose . zipWith (\p d->map (*p) d) ps ++{-| Combines 'DistributionMaker's. This combines them with equal weighting. -}+addDistributionMakers :: [DistributionMaker]->DistributionMaker+addDistributionMakers fs n = addDistributions $ map (\f->f n) fs++{-| Combines 'DistributionMaker's but weights each one.-}+addDistributionMakers' :: [Double]->[DistributionMaker]->DistributionMaker+addDistributionMakers' ps fs n = addDistributions' ps $ map (\f->f n) fs++{-| A function included for debug purposes. I expect that many users will be more comfortable using CDFs, but + happier thinking in terms of PDFs. Use in conjunction with 'distribution2SVG' to see what a distribution + looks like.-}+cdf2pdf :: Distribution->Distribution+cdf2pdf xs = head xs : zipWith (\a b->b-a) xs (tail xs) ++{-| A function included for debug purposes, to allow a user to visualise a distribution. + It generates a string, which can be stored in a file as SVG. -}+distribution2SVG :: Distribution->String+distribution2SVG d = concat [svg,+ "<rect x=\"0\" y=\"0\" width=\"400\" height=\"300\" style=\"stroke:black;stroke-width:1;fill:white\"/>",+ mkPath d,+ "<text x=\"20\" y=\"350\" style=\"dominant-baseline:central\">Max Prob:",+ show $ last d,"</text>",+ "</svg>"+ ]+ where+ svg = "<svg xmlns=\"http://www.w3.org/2000/svg\" width=\"400\" height=\"400\">"+ mkPath xs = let (h:hs) = [(x,y,l) | let l = fromIntegral $ length xs-1,(x,y)<-zip xs [0..] ]+ mkM (y,x,l) = concat ["M ",show ((x/l)*400)," ",show (y*300)," "]+ mkLs (y,x,l) = concat ["L ",show ((x/l)*400)," ",show (y*300)," "]+ in concat ["<path style=\"stroke:black;stroke-width:1;stroke-opacity:1;fill:none\" d=\"", + mkM h,concatMap mkLs hs,"\"/>"]+ +
Control/Search/Local/Eager.hs view
@@ -13,7 +13,7 @@ provide two other semi-eager operations which return both an eager value and a lazy remainder. -} -module Control.Search.Local.Eager((!!!),indexWithRemainder,splitAt') where+module Control.Search.Local.Eager((!!!),indexWithRemainder,splitAt',push) where import Data.List @@ -22,20 +22,25 @@ elements in some way (usually true of the local search systems), this will result in the computation being pushed forwards. -} (!!!) :: [a]->Int->a-(!!!) ~(x:_) 0 = x-(!!!) ~(x:xs) n = x `seq` (xs !!! (n-1))+(!!!) xs i = (push xs) !! i {-| Similar to the eager list index, however it also gives back the remainder of the computation as an unevaluated list. It is expected that this will be used to sample a stream for a human user, allowing the user to see what has happened and make a decision to continue, or stop. If continue, then the lazy remainder can be processed further. -} indexWithRemainder :: [a]->Int->(a,[a])-indexWithRemainder ~(x:xs) 0 = (x,xs)-indexWithRemainder ~(x:xs) n = x `seq` (indexWithRemainder xs (n-1))+indexWithRemainder xs i = (\(a:as)->(a,as)) . drop i . push $ xs {-| Eager /splitAt/. Looks like /splitAt/, but the elements of the first list are evaluated to WHNF. -} splitAt' :: Int->[a]->([a],[a])-splitAt' i xs = g ((iterate f ([],xs)) !!! i)- where- f (as,b:bs) = (b:as,bs)- g (as,bs) = (reverse as,bs)+splitAt' i = splitAt i . push ++{-| This is the helper function used by the others to force the list evaluation, as the list is accessed.+ I think this is equivalent to + + > evalList rseq ++ from the /Control.Parallel.Strategies/ library, but reproduced here to reduce dependencies.+ -}+push :: [a] -> [a]+push (x : xs) = x `seq` x : push xs
Control/Search/Local/Example.hs view
@@ -117,7 +117,7 @@ (1) When the difference in quality between two solutions is below the second parameter, terminate (2) The two solutions that we are comparing are divided by the integer parameter -}-limiter :: (Floating f,Ord f)=>(s->f)->f->Int->StreamT s+limiter :: (Floating f,Ord f)=>(s->f)->f->Int->StreamT s s limiter quality l i xs = map fst . takeWhile f $ zip xs (drop i xs) where f (a,b) = abs (quality a - quality b) > l@@ -179,7 +179,7 @@ with values that will be drawn from a source of random numbers. This version would then require lifting to become a stream transformer, and this introduces more complications in the meta-heuristic code. -}-stochasticNeighbourhood :: RandomGen g=>Int->g->ExpandT TSPProblem+stochasticNeighbourhood :: RandomGen g=>Int->g->StreamT TSPProblem (List TSPProblem) stochasticNeighbourhood nSize g sols = let as = chunk nSize . chunk 2 . randomRs (0,numCities (head sols) -1) $ g f s = map (\[a,b]->swapPositions a b s) in zipWith f sols as@@ -188,7 +188,7 @@ it does assume that each population has already been constrained to elements that will form the parents of the new solution. This process also assumes that there will be exactly 2 parents to each new solution, so it is an example of a recombination method only. -}-stochasticRecombine :: RandomGen g=>g->ContraT TSPProblem+stochasticRecombine :: RandomGen g=>g->StreamT (List TSPProblem) TSPProblem stochasticRecombine g a = unfoldr f (a,randoms g :: [Double]) where f ([p1,p2]:ps,rs) = let (fs,rs') = stoRebuild rs (IM.fromList $ zip [0..] [(head c,last c,c) |c<-commonFragments p1edges p2route ])
− Control/Search/Local/Queue.hs
@@ -1,20 +0,0 @@-module Control.Search.Local.Queue where--data Queue a = Queue [a] [a] Int--initQ :: Queue a-initQ = Queue [] [] 0--sizeQ :: Queue a->Int-sizeQ (Queue _ _ s) = s--append :: Queue a -> a -> Queue a-append (Queue fr bk sz) x = Queue fr (x:bk) (1+sz)--remove :: Queue a->Queue a-remove q@(Queue [] [] _ ) = q-remove (Queue [] bk sz) = remove (Queue (reverse bk) [] sz)-remove (Queue as bk sz) = Queue (tail as) bk (sz-1) --toList :: Queue a->[a]-toList (Queue fr bk _) = fr ++ reverse bk
Control/Search/Local/Strategies.hs view
@@ -1,20 +1,25 @@ {-| A collection of common strategies, built out of the combinators in the other libraries. - For examples of their use, see "Control.Search.Local.Example".+ For examples of their use, see "Control.Search.Local.Example". ACO is the least well thought through. -} module Control.Search.Local.Strategies( -- * Iterative Improvers iterativeImprover,firstFoundii,maximalii,minimalii,stochasticii, -- * TABU Search- tabu,standardTabu,+ tabu,standardTabu,tabuFilter, -- * Simulated Annealing- sa,+ sa,logCooling,linCooling,geoCooling,saChoose, -- * Genetic Algorithms- ga,gaConfig+ ga,+ -- * Ant Colony Optimisation+ aco,pheromoneDegrade )where import Control.Search.Local+import Control.Search.Local.Distributions import Data.List+import System.Random+import System.IO.Unsafe {-| The generic skeleton of iterative improvers. The first parameters is a neighbourhood stream expander, @@ -32,35 +37,38 @@ versions suggested in the paper. When the filter results in an empty list, the seed value is wrapped up as a list and returned in its place. -}-iterativeImprover :: Ord s=>ExpandT s->ContraT s->StreamT s+iterativeImprover :: Optimisable s=>StreamT s (List s)->StreamT (List s) s->StreamT s s iterativeImprover nf cf = cf . mkSafe (improvement nf) where mkSafe f sols = zipWith (\a b->if null a then [b] else a) (f sols) sols {-| First found iterative improvement strategy. Fixes the choice function to @map head@. -}-firstFoundii :: Ord s=>ExpandT s->StreamT s-firstFoundii nf = iterativeImprover nf (map head )+firstFoundii :: Optimisable s=>StreamT s (List s)->StreamT s s+firstFoundii nf = iterativeImprover nf (map head) {-| Maximal iterative improvement strategy. Since we seek the lowest possible value of solutions this - translates to fixing the choice function to @map minimum@. -}-maximalii :: Ord s=>ExpandT s->StreamT s-maximalii nf = iterativeImprover nf (map minimum )-{-| Minimal iterative improvement strategy. Fixes the choice function to @map maximum@.-}-minimalii :: Ord s=>ExpandT s->StreamT s-minimalii nf = iterativeImprover nf (map maximum )+ translates to fixing the choice function to @map worst@. -}+maximalii :: Optimisable s=>StreamT s (List s)->StreamT s s+maximalii nf = iterativeImprover nf (map worst)+{-| Minimal iterative improvement strategy. Fixes the choice function to @map best@.-}+minimalii :: Optimisable s=>StreamT s (List s)->StreamT s s+minimalii nf = iterativeImprover nf (map best) {-| Stochastic iterative improvement strategy. The choice function is required to make a random choice from - the neighbourhood at each step. In order to keep this as general as possible we require a choice function, - and a stream of values, expected to be random numbers. The choice function takes one of these random values, - and a neighbourhood and returns a single value. - - This choice function and stream of random values are then used to create a stochastic decision stream - contractor, and the strategy created. + the neighbourhood at each step. This is implemented in terms of the 'select' function, and + uses a 'uniformCDF'. -}-stochasticii :: Ord s=>([s]->r->s)->[r]->ExpandT s->StreamT s-stochasticii rcf rs nf = iterativeImprover nf (zipWith (flip rcf) rs )+stochasticii :: Optimisable s=>StreamT s (List s)->StreamT s s+stochasticii nf = iterativeImprover nf (select uniformCDF) +{-| -}+tabuFilter :: Eq s => (StreamT s (List s)) -- window+ -> (StreamT s (List s)) -- neighbourhood+ -> (StreamT s (List s))+tabuFilter wF nF xs = safe (map (:[]) xs)+ $ zipWith (\ws->filter (flip notElem ws)) (wF xs) (nF xs)+ {-| A general skeleton for TABU search. The three parameters are (1) a stream transformer to create the stream of TABU lists (typically provided by 'window')@@ -69,16 +77,54 @@ (3) a choice transformer to choose a single element from a pruned neighbourhood. -}-tabu :: Ord s=> ExpandT s->ExpandT s->- ContraT s->StreamT s-tabu wf nf cf sols = cf $ tabuFilter (wf sols) nf sols+tabu :: Ord s=> StreamT s (List s)->StreamT s (List s)->+ StreamT (List s) s->StreamT s s+tabu wf nf cf = cf . tabuFilter wf nf {-| Commonly TABU search does not take a function which makes a TABU list, but rather a size of TABU list. We provide this less flexible form here, where the first parameter changes from - to being the window size. Implemented in terms of 'tabu'. -}-standardTabu :: Ord s=> Int->ExpandT s->ContraT s->StreamT s-standardTabu winSize = tabu (window winSize) + to being the window size. The choice function is set to /map head/. Implemented in terms of 'tabu'. + I am not happy with this. What is really needed is a more flexible version of 'safe', so that + rather than just returning the singleton it can return an alternative transformation of the neighbourhood.+ This is also some scope for using compiler rules here to balance usability with performance. + -}+standardTabu :: Ord s=> Int->StreamT s (List s)->StreamT s s+standardTabu winSize nF = tabu (window winSize) nF (map head)++-- tabu cF wF nF xs = let nF' = const (nF xs)+-- in cF . safe (tabuFilter wF nF' xs) ◦ improvement nF' $ xs+++{-| A logarithmic cooling strategy intended for use within simulated annealing. Broadly the first value is + the starting temperature and the second a value between 0 and 1. -}+logCooling :: Floating b=>b->b->[b]+logCooling c d = map (\t->c / (log (t + d))) (iterate (+1) 1)++{-| The most common cooling strategy for simulated annealing, geometric. The first value is the starting temperature, + the second a value between 0 and 1, the cooling rate. -}+geoCooling :: Floating b=>b->b->[b]+geoCooling startTemp tempChange = iterate (* tempChange) startTemp++{-| Included for completeness, this is a cooling strategy for simulated annealing that is usually not very effective,+ a linear changing strategy. The first value is the starting temperature the second is the value to increase it by + at each step. In order to have it reduce at each step, pass a negative value. +-}+linCooling :: Floating b=>b->b->[b]+linCooling startTemp tempChange= iterate (+ tempChange) startTemp++{-| The traditional choice function used within simulated annealing. The parameters are; + a function to yield quality of a solution, a value between 0 and 1 (stochastic expected) a temperature, + the old solution and the possible future solution. Frustratingly this does not make use of 'Optimisable'+ because it requires the actual floating point quality values of solutions.-}+saChoose :: (Floating v,Ord v)=>(s->v)->v->v->s->s->s+saChoose valueF r t oldSol newSol+ | d<=0 || e>r = newSol+ | otherwise = oldSol+ where+ e = exp (- (d/t))+ d = (valueF newSol) - (valueF oldSol)+ {-| Simulated Annealing skeleton. This requires a significant number of parameters due to the various stochastic components, temperatures and the need for a numerical valuation of solutions qualities. The parameters are;@@ -94,36 +140,46 @@ (5) a stream of (stochastic) values for the creation of perturbations -}-sa :: (Floating v,Ord v)=>(s->v)->StreamT s->[v]->[v]->StreamT s+sa :: (Floating v,Ord v)=>(s->v)->StreamT s s->Stream v->Stream v->StreamT s s sa getVal perturbF rs coolS sols = zipWith4 (saChoose getVal) rs coolS sols (perturbF sols) -{-| Genetic Algorithm skeleton. In it's most general form this has three processes, which make up the parameters;+{-| -}+ga :: Int -- population size+ ->Float -- mutation rate+ ->StreamT (List s) s -- recombine, contraction+ ->StreamT (List s) (List s) -- selection of parents + ->StreamT s s -- mutation+ ->StreamT s s+ga popSize perturbProb recombine selection perturb+ = nest [(True, perturb), (False, id)] mutGo + . concat + . doMany popSize (recombine . selection) + . chunk popSize+ where+ mutGo = unsafePerformIO (newStdGen >>= return . map (<perturbProb) . randoms) - (1) conversion of the stream of solutions into a stream of populations+{-| A simple ACO implementation. It assumes that Ants will be released in groups, which is represented as the + population size. It requires a transformation for generating pheromones, and creating new solutions from + pheromone data. This will be problem specific. -}+aco :: Int -- population size+ -> (StreamT (List s) a) -- Pheromone analysis+ -> (StreamT a s) -- solution generation+ -> StreamT s s+aco popSize aP gN = concat . doMany popSize gN . aP . chunk popSize - (2) recombination of elements of each population to give new solutions+{-| ACO's often use a degrading system, so that the next trail contains some part of the previous trails.+ This function provides this functionality, assuming that pheromone data can be summed like a number, and + an initial state is provided. The stream transformation parameter represents a streamed + degrade, for example; - (3) mutation of elements of the stream to create variation+ > map (*0.1)+ + would give one tenth of the previous previous pheromone data added to the result. This is a stream transformation to allow for flexibility, for example adding a stochastic element. -}+pheromoneDegrade :: Num a=>a->StreamT a a->StreamT a a+pheromoneDegrade p0 degrade as = let newTrails = zipWith (+) (degrade (p0 : newTrails)) as in newTrails - It is expected that each of these processes will be created via the composition of a number of other functions.--}-ga :: ExpandT s->ContraT s->StreamT s->StreamT s-ga mkPop recomb mutat = mutat . recomb . mkPop -{-| The standard genetic algorithm configuration. The parameters are; - (1) the selection distribution - (2) the population size - (3) a stream of random values to parametrise the selection routine- - (4) a stream of boolean values to indicate where to apply mutation - (5) the recombination stream transformer-- (6) the mutation stream transformer--}-gaConfig :: Ord s=>[Float]->Int->[Float]->[Bool]->ContraT s->StreamT s->StreamT s-gaConfig dist popSize rs bs recombine mutate- = ga (makePop popSize) (recombine . gaSelect 2 dist rs) (nest bs mutate)
− Demo.hs
@@ -1,67 +0,0 @@--- This file will need to be moved away from the install folder before it will work.--import Control.Search.Local.Eager-import Control.Search.Local.Strategies-import Control.Search.Local-import Control.Search.Local.Example--import System.Random-import CombinatorialOptimisation.TSP--import Data.List--simpleII = loadExampleFile BURMA14 >>= return . loopP (maximalii (map adjacentExchangeN))--iiExample - = do prob<-loadExampleFile FL417- strat<-newStdGen >>= return . stochasticii rChoice . randoms - return . loopP (strat (map adjacentExchangeN)) $ prob- where- rChoice xs p = xs !! (floor ((p::Float) * fromIntegral (length xs))) --simpleTabu = loadExampleFile BURMA14 >>= return . bestSoFar . loopP (standardTabu 5 (map adjacentExchangeN) (map head)) --tabuExample - = do prob<-loadExampleFile FL417- nF <- newStdGen >>= return . stochasticNeighbourhood 417 - vWin <- newStdGen >>= return . varyWindow . randomRs (5,10)- return . bestSoFar . loopP (tabu (vWin . window 15) nF (map head)) $ prob---saExample - = do prob<-loadExampleFile FL417- (fIs,sIs) <- newStdGen >>= return . (\a->(map head a,map last a)) . chunk 2 . randomRs (0,numCities prob-1) - let perturb = zipWith3 swapPositions fIs sIs- choiceRs <-newStdGen >>= return . randoms - return . bestSoFar . loopP (sa getTSPVal perturb - (geoCooling 80000 (0.99 :: Float))- choiceRs) $ prob --saRestartExample - = do prob<-loadExampleFile FL417- (fIs,sIs) <- newStdGen >>= return . (\a->(map head a,map last a)) . chunk 2 . randomRs (0,numCities prob-1) - let perturb = zipWith3 swapPositions fIs sIs- choiceRs <-newStdGen >>= return . randoms - return (restartingSA perturb choiceRs prob)- where- restartingSA perturbF rs seed- = let cs = map (\w -> if null w then False else head w == last w) $ window 10 sols- restart base trigs = until_ base trigs $ map (restart base) (tails trigs)- ts = restart (geoCooling 80000 (0.99::Float) ) cs- sols = loopP (sa getTSPVal perturbF rs ts) seed- in bestSoFar sols- --gaWithMutate - = do prob<-loadExampleFile FL417- recomb<-newStdGen >>= return . stochasticRecombine- startSols <- newStdGen >>= return . randomStarts 20 prob- pattern <- newStdGen >>= return . map (<(0.05::Float)) . randoms -- boolean pattern- (fIs,sIs) <- newStdGen >>= return . (\a->(map head a,map last a)) . chunk 2 . randomRs (0,numCities prob-1) - let dist = (++[1]) . takeWhile (<1) $ iterate (*1.0884) (0.2::Float)- let mut = nest pattern (zipWith3 swapPositions fIs sIs) - rs <- newStdGen >>= return . randoms - return . bestSoFar . loopS (ga (makePop 20) - (recomb . gaSelect 2 dist rs) - mut) $ startSols -
local-search.cabal view
@@ -1,16 +1,16 @@ Name: local-search -Version: 0.0.5-Synopsis: A first attempt at generalised local search within Haskell, for applications in combinatorial optimisation. +Version: 0.0.6+Synopsis: Generalised local search within Haskell, for applications in combinatorial optimisation. Description: This library operates by representing metaheuristics as generators of solutions, or streams of solutions, which are themselves the result of resolving the interactions of other streams of values. The library contains combinators for constructing and - managing these structures. + managing these structures. Stability: experimental Category: Control, Optimisation, Local Search Author: Richard Senington & David Duke License: GPL license-file: LICENSE-Copyright: Copyright (c) 2012 Richard Senington+Copyright: Copyright (c) 2013 Richard Senington Homepage: http://www.comp.leeds.ac.uk/sc06r2s/Projects/HaskellLocalSearch Maintainer: sc06r2s@leeds.ac.uk Build-Type: Simple@@ -19,14 +19,16 @@ library Exposed-Modules: Control.Search.Local- Control.Search.Local.Example + Control.Search.Local.Distributions Control.Search.Local.Eager - Control.Search.Local.Strategies + Control.Search.Local.Strategies+ Control.Search.Local.Example GHC-Options: -O2 Build-Depends: base >= 2.0 && <=5,+ erf >= 2, random >=1.0.0.3, combinatorial-problems >=0.0.4, containers >= 0.4.0.0- Other-Modules: Paths_local_search,Control.Search.Local.Queue+ Other-Modules: Paths_local_search extensions: MultiParamTypeClasses, FunctionalDependencies