packages feed

goal-core (empty) → 0.1

raw patch · 7 files changed

+710/−0 lines, 7 filesdep +Chartdep +Chart-cairodep +Chart-gtksetup-changed

Dependencies added: Chart, Chart-cairo, Chart-gtk, base, cairo, colour, containers, data-default-class, goal-core, gtk, lens

Files

+ Goal/Core.hs view
@@ -0,0 +1,181 @@+module Goal.Core+    ( -- * Module Exports+      module Goal.Core.Plot+    , module Data.Function+    , module Data.Ord+    , module Data.Monoid+    , module Data.List+    , module Data.Maybe+    , module Data.Either+    , module Data.Default.Class+    , module Control.Applicative+    , module Control.Monad+    , module Control.Monad.ST+    , module Control.Arrow+    , module Control.Lens.Type+    , module Control.Lens.Getter+    , module Control.Lens.Setter+    , module Control.Lens.TH+    , module Control.Concurrent+    , module Numeric+    , module Debug.Trace+    -- * Lists+    , takeEvery+    , breakEvery+    -- * Low-Level+    , traceGiven+    -- * Numeric+    , roundSD+    , toPi+    -- ** Functions+    , logistic+    , logit+    -- ** Lists+    , mean+    , range+    , discretizeFunction+    ) where+++--- Imports ---+++-- Re-exports --++import Goal.Core.Plot hiding (empty,over)++import Data.Ord+import Data.Function+import Data.Monoid hiding (Dual)+import Data.List hiding (sum)+import Data.Maybe+import Data.Either++import Control.Applicative+import Control.Arrow hiding ((<+>))+import Control.Monad+import Control.Monad.ST+import Control.Lens.Type+import Control.Lens.Getter+import Control.Lens.Setter hiding (Identity)+import Control.Lens.TH+import Control.Concurrent++import Debug.Trace+import Data.Default.Class+import Numeric+++--- General Functions ---+++takeEvery :: Int -> [x] -> [x]+-- | Takes every nth element, starting with the head of the list.+takeEvery m = map snd . filter (\(x,_) -> mod x m == 0) . zip [0..]++breakEvery :: Int -> [x] -> [[x]]+-- | Break the list up into lists of length n.+breakEvery _ [] = []+breakEvery n xs = take n xs : breakEvery n (drop n xs)++traceGiven :: Show a => a -> a+-- | Runs traceShow on the given element.+traceGiven a = traceShow a a+++--- Numeric ---+++roundSD :: (Floating x, RealFrac x) => Int -> x -> x+-- | Roundest the number to the specified significant digit.+roundSD n x = (/10^n) . fromIntegral . round $ 10^n * x++toPi :: (Floating x, RealFrac x) => x -> x+-- | Modulo pi thingy.+toPi x =+    let xpi = x / pi+        n = floor xpi+        f = xpi - fromIntegral n+    in if even n then pi * f else -(pi * (1 - f))++logistic :: Floating x => x -> x+-- | A standard sigmoid function.+logistic x = 1 / (1 + exp(negate x))++logit :: Floating x => x -> x+-- | The inverse of the logistic.+logit x = log $ x / (1 - x)++-- Lists --++mean :: Fractional x => [x] -> x+-- | Average value of a list of numbers.+mean = uncurry (/) . foldr (\e (s,c) -> (e+s,c+1)) (0,0)++range :: Double -> Double -> Int -> [Double]+-- | Returns n  numbers from mn to mx.+range _ _ 0 = []+range mn mx 1 = [(mn + mx) / 2]+range mn mx n =+    [ x * mx + (1 - x) * mn | x <- (/ (fromIntegral n - 1)) . fromIntegral <$> [0 .. n-1] ]++discretizeFunction :: Double -> Double -> Int -> (Double -> Double) -> [(Double,Double)]+-- | Takes range information in the form of a minimum, maximum, and sample count,+-- a function to sample, and returns a list of pairs (x,f(x)) over the specified+-- range.+discretizeFunction mn mx n f =+    let rng = range mn mx n+    in zip rng $ f <$> rng++-- Graveyard --++{-+parMapWH :: (a -> b) -> [a] -> [b]+-- | ParMap using rseq. WH stands for Weak Head (normal form).+parMapWH = parMap rseq++parMapDS :: NFData b => (a -> b) -> [a] -> [b]+parMapDS = parMap rdeepseq++gridSearch+    :: (a -> Double) -- ^ The error function on the model+    -> (x -> a) -- ^ A constructor from the parameter being tested to the model+    -> [x] -- ^ The list of parameter values to test+    -> (x,[(x,Double)]) -- ^ The best parameter and model, and accompanying statistics++-- | A general implementation of a grid search. Returns a triple where the first+-- element is the best parameter, the second is the best model, and the third is a list+-- of the errors calculated at each parameter value.+gridSearch errorfun constructor xs =+    let as = constructor <$> xs+        errs = parMapDS errorfun as+        x = fst . minimumBy (comparing snd) $ zip xs errs+    in (x,zip xs errs)++iterativeOptimization+    :: (a -> a -> Double) -- ^ Difference measure+    -> Double -- ^ Differential error threshold+    -> Int -- ^ Maximum number of iterations (< 1 is interpreted as infinity)+    -> (a -> a) -- ^ Iterator+    -> a -- ^ Initial Value+    -> (a,[(a,Double)]) -- ^ The final value and associated descent+-- | Iterates a value, stopping when a stopping criterion is satisfied, or the maximum+-- number of iterations is reached. The algorithm returns the resulting value as well as+-- the descent preceding it.+--+-- The error accompanying each element of the descent corresponds to the error between+-- that element and the following element. The last error in the descent will therefore+-- correspond to the measured difference between the last element of the descent, and the+-- returned singleton in the pair.+--+-- If the last error in the returned descent is less then the given threshold, then the+-- threshold was reached. Otherwise, n will have been reached as the terminal condition.+iterativeOptimization difference thrsh n iterator a =+    let itrs = iterate iterator a+        itrs' = if n > 0 then take (n+1) itrs else itrs+        zps = zip itrs' $ tail itrs'+        zps' = case break ((< thrsh) . snd) . zip zps $ uncurry difference <$> zps of+                   (zps0,[]) -> zps0+                   (zps0,rst) -> zps0 ++ [head rst]+    in (snd . fst . last $ zps', first fst <$> zps')+    -}
+ Goal/Core/Plot.hs view
@@ -0,0 +1,264 @@+module Goal.Core.Plot+    ( -- * Module Exports+      module Graphics.Rendering.Chart+    , module Data.Colour+    , module Data.Colour.Names+    , module Data.Colour.SRGB.Linear+    , module Graphics.Rendering.Chart.Backend.Cairo+    , module Graphics.Rendering.Chart.Grid+    , module Graphics.Rendering.Chart.Gtk+    , module Graphics.Rendering.Chart.State+    , module Goal.Core.Plot.Contour+    -- * Plots+    -- ** PixMap+    , pixMapPlot+    -- ** Histograms+    , histogramPlot+    , histogramPlot0+    , logHistogramPlot+    , logHistogramPlot0+    -- * Layouts+    -- ** PixMap+    , pixMapLayout+    -- ** Histogram+    , histogramLayout+    , logHistogramLayout+    , histogramLayoutLR+    -- * Util+    , rgbaGradient+    -- * Rendering+    , renderableToAspectWindow+    ) where+++--- Imports ---++import Data.List hiding (sum)++import Control.Monad+import Control.Lens.Getter+import Control.Lens.Setter hiding (Identity)++import Data.Default.Class+import Numeric+++-- Re-exports --++import Graphics.Rendering.Chart hiding (x0,y0,Point)+import Data.Colour+import Data.Colour.Names+import Data.Colour.SRGB.Linear+import Graphics.Rendering.Chart.Backend.Cairo+import Graphics.Rendering.Chart.State+import Graphics.Rendering.Chart.Grid+import Graphics.Rendering.Chart.Gtk++-- Scientific --++import Goal.Core.Plot.Contour++-- Qualified --++import qualified Graphics.UI.Gtk as G+++-- Unqualified --++import Graphics.Rendering.Cairo (liftIO)+++--- Util ---++rgbaGradient :: (Double, Double, Double, Double) -> (Double, Double, Double, Double) -> Int+    -> [AlphaColour Double]+-- | Returns an ordered list of colours useful for plotting.+rgbaGradient (rmn,gmn,bmn,amn) (rmx,gmx,bmx,amx) n =+    zipWith (flip withOpacity) [amn,amn + astp .. amx]+    $ zipWith3 rgb [rmn,rmn + rstp .. rmx] [gmn,gmn + gstp .. gmx] [bmn,bmn + bstp .. bmx]+    where rstp = (rmx - rmn) / fromIntegral n+          gstp = (gmx - gmn) / fromIntegral n+          bstp = (bmx - bmn) / fromIntegral n+          astp = (amx - amn) / fromIntegral n+++--- Plots ---+++-- PixMap --++pixMapPlot :: (Double,Double) -> [[AlphaColour Double]] -> Plot Double Double+-- | Returns a pixmap representation of a matrix style set of doubles. Based on the+-- defaults, the list of colours are assumed to be in (y,x) coordinates, where the+-- origin is at the lower left of the image. If matrix style coordinates are desired,+-- The containing layout should be given a reversed y axis, so that the origin is at the+-- top left of the image.++--  The pair of doubles indicates where corner of the given image should be located.+pixMapPlot (x0,y0) pss = foldr1 joinPlot+    $ concat [ [ boxPlot r c . solidFillStyle $ p | (c,p) <- zip [x0..] ps ] | (r,ps) <- zip [y0..] pss ]+    where boxPlot y x stl = toPlot+              $ plot_fillbetween_style .~ stl+              $ plot_fillbetween_values .~ [(x-0.5,(y-0.5,y+0.5)),(x+0.5,(y-0.5,y+0.5))]+              $ def++pixMapLayout :: Int -> Int -> Layout Double Double -> Layout Double Double+-- | A nice base layout for a pixMap, with a box around the pixmap with one 'pixel'+-- padding, and a reversed y axis for matrix style coordinates.+pixMapLayout rws0 cls0 lyt =+    layout_top_axis_visibility .~ AxisVisibility True True False+    $ layout_left_axis_visibility .~ AxisVisibility True True False+    $ layout_right_axis_visibility .~ AxisVisibility True True False+    $ layout_bottom_axis_visibility .~ AxisVisibility True True False+    $ layout_y_axis . laxis_reverse .~ True+    $ layout_y_axis . laxis_generate .~+        const (makeAxis (const "") ([-1.5,rws+0.5],[-1.5,rws+0.5],[-1.5,rws+0.5]))+    $ layout_x_axis . laxis_generate .~+        const (makeAxis (const "") ([-1.5,cls+0.5],[-1.5,cls+0.5],[-1.5,cls+0.5]))+    $ lyt+    where cls = fromIntegral cls0+          rws = fromIntegral rws0++-- Histogram --++histogramPlot0 :: (Num a,BarsPlotValue a) =>Int -> [[Double]] -> PlotBars Double a -> PlotBars Double a+-- | Generates a histogram plot where the min and max bin value is taken from the data set.+histogramPlot0 n xss plt =+    let mx = maximum $ maximum <$> xss+        mn = minimum $ minimum <$> xss+    in histogramPlot n mn mx xss plt++logHistogramPlot0 :: Int -> [[Double]] -> PlotBars Double Double -> PlotBars Double Double+-- | Generates a histogram plot where the min and max bin value is taken from the data set.+logHistogramPlot0 n xss =+    let mx = maximum $ maximum <$> xss+        mn = minimum $ minimum <$> xss+    in logHistogramPlot n mn mx xss++histogramPlot+    :: (Num a,BarsPlotValue a)+    => Int -- ^ Number of bins+    -> Double -- ^ Min range+    -> Double -- ^ Max range+    -> [[Double]] -- ^ Data set+    -> PlotBars Double a -- ^ Plot+    -> PlotBars Double a -- ^ New Plot+-- | Creates a histogram out of a data set. The data set is a list of list of values, where+-- each sublist is a collection of data along an axis. Under and overflow is put into the+-- first and last bin, respectively. The bars are centered at the mid point between each+-- pair of bins.+histogramPlot n mn mx xss plt =+    let bns = range mn mx (n+1)+        vls = transpose $ toHistogram (tail $ take n bns) . sort <$> xss+        stp = (head (tail bns) - head bns) / 2+        bns' = (+ stp) <$> take n bns+     in plot_bars_alignment .~ BarsCentered $ plot_bars_values .~ zip bns' vls $ plt+    where toHistogram _ [] = repeat 0+          toHistogram [] xs = [genericLength xs]+          toHistogram (bn:bns') xs =+              let (hds,xs') = span (< bn) xs+              in genericLength hds : toHistogram bns' xs'++range _ _ 0 = []+range mn mx 1 = [(mn + mx) / 2]+range mn mx n =+    [ x * mx + (1 - x) * mn | x <- (/ (fromIntegral n - 1)) . fromIntegral <$> [0 .. n-1] ]++logHistogramPlot+    :: Int -- ^ Number of bins+    -> Double -- ^ Min range+    -> Double -- ^ Max range+    -> [[Double]] -- ^ Data set+    -> PlotBars Double Double -- ^ Plot+    -> PlotBars Double Double -- ^ New Plot+logHistogramPlot n mn mx xss plt =+    let bplt = histogramPlot n mn mx xss plt+        vls = modVals <$> bplt ^. plot_bars_values+        --cl = fromIntegral . ceiling . maximum . concat $ snd <$> vls+    in plot_bars_values .~ vls $ bplt+    where lbs = 10+          modVals (x,ys) = (x, logBase lbs . (+1) <$> ys)++histogramLayout :: BarsPlotValue a => PlotBars Double a -> Layout Double a -> Layout Double a+-- | The base layout for a histogram.+histogramLayout pbrs lyt =+    let bns = fst <$> pbrs ^. plot_bars_values+        stp = (head (tail bns) - head bns) / 2+        bns' = (head bns - stp) : map (+stp) bns+        rng = abs $ maximum bns'+        labelFun x+            | rng >= 1000 = showEFloat (Just 2) x ""+            | rng <= 0.01 = showEFloat (Just 2) x ""+            | otherwise = reverse . dropWhile (== '.') . dropWhile (== '0') . reverse $ showFFloat (Just 2) x ""+    in layout_x_axis . laxis_generate .~ const (makeAxis labelFun (bns',[],bns'))+       $ layout_plots %~ (plotBars pbrs:)+       $ lyt++logHistogramLayout :: PlotBars Double Double -> Layout Double Double -> Layout Double Double+-- | Base layout for a log-histogram.+logHistogramLayout pbrs lyt =+    let vls = pbrs ^. plot_bars_values+        bns = fst <$> vls+        stp = (head (tail bns) - head bns) / 2+        bns' = (head bns - stp) : map (+stp) bns+        cl = fromIntegral . ceiling . maximum . concat $ snd <$> vls+        rng = abs $ maximum bns'+        xLabelFun x+            | rng >= 1000 = showEFloat (Just 2) x ""+            | rng <= 0.01 = showEFloat (Just 2) x ""+            | otherwise = reverse . dropWhile (== '.') . dropWhile (== '0') . reverse $ showFFloat (Just 2) x ""+    in layout_plots %~ (plotBars pbrs:)+        $ layout_y_axis . laxis_generate .~ const (makeAxis yLabelFun ([0..cl],[],[0..cl]))+        $ layout_x_axis . laxis_generate .~ const (makeAxis xLabelFun (bns',[],bns'))+        $ lyt+    where lbs = 10+          yLabelFun 0 = show 0+          yLabelFun x = show (round lbs) ++ "e" ++ show (round x) ++ "-1"++histogramLayoutLR :: (BarsPlotValue a,PlotValue b) => PlotBars Double a -> LayoutLR Double a b -> LayoutLR Double a b+-- | The base layout for a histogramLR.+histogramLayoutLR pbrs lyt =+    let bns = fst <$> pbrs ^. plot_bars_values+        stp = (head (tail bns) - head bns) / 2+        bns' = (head bns - stp) : map (+stp) bns+        rng = abs $ maximum bns'+        labelFun x+            | rng >= 1000 = showEFloat (Just 2) x ""+            | rng <= 0.01 = showEFloat (Just 2) x ""+            | otherwise = reverse . dropWhile (== '.') . dropWhile (== '0') . reverse $ showFFloat (Just 2) x ""+    in layoutlr_x_axis . laxis_generate .~ const (makeAxis labelFun (bns',[],bns'))+       $ layoutlr_plots %~ (Left (plotBars pbrs):)+       $ lyt++--- IO ---+++renderableToAspectWindow+    :: Bool -- ^ Display Full Screen+    -> Int -- ^ Image width+    -> Int -- ^ Image height+    -> Renderable a -- ^ The Renderable+    -> IO () -- ^ Renders the renderable to the screen++-- | Displays a renderable in a GTK aspect window.+renderableToAspectWindow fs wdth hght rnbl = do++    G.initGUI++    win <- G.windowNew+    afrm <- G.aspectFrameNew 0.5 0.5 . Just $ realToFrac (fromIntegral wdth / fromIntegral hght)+    da <- G.drawingAreaNew++    G.set afrm [ G.containerChild G.:= da ]+    G.set win [ G.containerChild G.:= afrm ]+    when fs $ G.windowFullscreen win+    G.onDestroy win G.mainQuit++    (da `G.on` G.exposeEvent) . liftIO $ do++        updateCanvas rnbl da+        return True++    G.widgetShowAll win+    G.mainGUI+
+ Goal/Core/Plot/Contour.hs view
@@ -0,0 +1,163 @@+module Goal.Core.Plot.Contour (contours) where+++--- Imports ---+++-- General --++import Control.Monad+import Data.List++-- Qualified --++import qualified Data.Map as M+++-- Unqualified --++import Data.Tuple (swap)+++--- Contour Plot ---+++contours+    :: (Double,Double,Int) -- ^ The range along the x axis.+    -> (Double,Double,Int) -- ^ The range along the y axis.+    -> Int -- ^ The number of isolevels.+    -> (Double -> Double -> Double) -- ^ The function to contour.+    -> [(Double,[[(Double,Double)]])] -- ^ (isolevel, (x,y))++-- | Given various parameters and a function to analyze, contourPlot returns a+-- list of PlotLines each of which is an isoline.+contours (xmn,xmx,nx) (ymn,ymx,ny) nlvls f =+    let lsts = functionToLists f (xmn,ymn) (xmx,ymx) stps+        stps = ((xmx - xmn) / fromIntegral nx,(ymx - ymn) / fromIntegral ny)+        (mn,mx) = (minimum $ minimum <$> lsts,maximum $ maximum <$> lsts)+        isostp = (mx - mn) / fromIntegral nlvls+        isolvls = take nlvls [mn + (isostp / 2),mn + (isostp * 1.5)..]+     in contour lsts (xmx,ymx) stps <$> isolvls+++--- Internal ---+++contour :: [[Double]] -> (Double,Double) -> (Double,Double) -> Double -> (Double,[[(Double,Double)]])+contour lsts mxs stps isolvl = (isolvl,linksToLines mxs stps <$> listsToLinks lsts isolvl)+++--- Contour Plot Internal ---+++-- Types --++type Link = (Int,Int)+type ContourPair = (Link,Link)+data ContourBox =+    {- Styled like the indicies of a 3x3 Matrix. The lines are drawn from+       left to right, and if need be, top to bottom -}+    Empty+    | Line ContourPair+    | DLine ContourPair ContourPair+    deriving (Show,Eq)++data PairMap = PM (M.Map Link Link) (M.Map Link Link) deriving Show++-- Type Functions --++contourBoxesToPairMap :: [ContourBox] -> PairMap+contourBoxesToPairMap clns =+    let cprs = concatMap toPairs clns+    in PM (M.fromList cprs) (M.fromList $ map swap cprs)+    where toPairs (Line prpr) = [prpr]+          toPairs (DLine lprpr rprpr) = [lprpr,rprpr]++deletePair :: ContourPair -> PairMap -> PairMap+{- Deletes a left oriented line segmented -}+deletePair (lpr,rpr) (PM lmp rmp) =+    let lmp' = if M.lookup lpr lmp == Just rpr then M.delete lpr lmp else lmp+        rmp' = if M.lookup rpr rmp == Just lpr then M.delete rpr rmp else rmp+    in PM lmp' rmp'++popLink :: Link -> PairMap -> (Maybe Link,PairMap)+popLink lnk pmp@(PM lmp rmp) =+    let lft = M.lookup lnk lmp+        rgt = M.lookup lnk rmp+    in case (lft,rgt) of+           (Just rlnk,_) -> (Just rlnk,deletePair (lnk,rlnk) pmp)+           (_,Just llnk) -> (Just llnk,deletePair (llnk,lnk) pmp)+           _ -> (Nothing,pmp)++-- Core Algorithm --++functionToLists :: (Double -> Double -> Double) -> (Double,Double) -> (Double,Double)+    -> (Double,Double) -> [[Double]]+functionToLists f (xmn,ymn) (xmx,ymx) (xstp,ystp) =+    map (uncurry f) <$> [ [ (x,y) | x <- [xmx,(xmx - xstp)..xmn] ] | y <- [ymx,(ymx - ystp)..ymn] ]++situationTable :: Double -> (((Bool,Double),(Bool,Double)),((Bool,Double),(Bool,Double))) -> ContourBox+situationTable _ (((True,_),(True,_)),((True,_),(True,_))) = Empty+situationTable _ (((True,_),(True,_)),((False,_),(True,_))) = Line ((1,0),(2,1))+situationTable _ (((True,_),(True,_)),((True,_),(False,_))) = Line ((2,1),(1,2))+situationTable _ (((True,_),(True,_)),((False,_),(False,_))) = Line ((1,0),(1,2))+situationTable _ (((True,_),(False,_)),((True,_),(True,_))) = Line ((0,1),(1,2))+situationTable isolvl (((True,ul),(False,ur)),((False,ll),(True,lr)))+    | sum [ul,ur,ll,lr] / 4 < isolvl = DLine ((1,0),(0,1)) ((2,1),(1,2))+    | otherwise = DLine ((1,0),(2,1)) ((0,1),(1,2))+situationTable _ (((True,_),(False,_)),((True,_),(False,_))) = Line ((0,1),(2,1))+situationTable _ (((True,_),(False,_)),((False,_),(False,_))) = Line ((1,0),(0,1))+situationTable _ (((False,_),(True,_)),((True,_),(True,_))) = Line ((1,0),(0,1))+situationTable _ (((False,_),(True,_)),((False,_),(True,_))) = Line ((0,1),(2,1))+situationTable isolvl (((False,ul),(True,ur)),((True,ll),(False,lr)))+    | sum [ul,ur,ll,lr] / 4 < isolvl = DLine ((1,0),(2,1)) ((0,1),(1,2))+    | otherwise = DLine ((1,0),(0,1)) ((2,1),(1,2))+situationTable _ (((False,_),(True,_)),((False,_),(False,_))) = Line ((0,1),(1,2))+situationTable _ (((False,_),(False,_)),((True,_),(True,_))) = Line ((1,0),(1,2))+situationTable _ (((False,_),(False,_)),((False,_),(True,_))) = Line ((2,1),(1,2))+situationTable _ (((False,_),(False,_)),((True,_),(False,_))) = Line ((1,0),(2,1))+situationTable _ (((False,_),(False,_)),((False,_),(False,_))) = Empty++listsToContourBoxes :: [[Double]] -> Double -> [ContourBox]+listsToContourBoxes lsts isolvl = do+    (stnrw,r) <- zip stnlsts [0..]+    (stn,c) <- zip stnrw [0..]+    let bx = situationTable isolvl stn+    guard (bx /= Empty)+    return $ repositionBox (r,c) bx+    where stnlsts = rowZipper $ elementPairs . map threshold <$> lsts+          threshold x = (x >= isolvl,x)+          elementPairs lst = zip lst $ tail lst+          rowZipper rws = uncurry zip <$> elementPairs rws+          repositionContourPair (r,c) ((lr,lc),(rr,rc)) =+              ((lr + 2 * r, lc + 2 * c),(rr + 2 * r, rc + 2 * c))+          repositionBox rc (Line pr) =+              Line $ repositionContourPair rc pr+          repositionBox rc (DLine pr1 pr2) =+              DLine (repositionContourPair rc pr1) (repositionContourPair rc pr2)++traceLinks :: ContourPair -> PairMap -> ([Link],PairMap)+traceLinks (llnk,rlnk) pmp =+    let (llnks,pmp') = tracer [] (Just llnk,pmp)+        (rlnks,pmp'') = tracer [] (Just rlnk,pmp')+    in (llnks ++ reverse rlnks,pmp'')+    where tracer lnks (Just lnk,pmp') =+              tracer (lnk:lnks) $ popLink lnk pmp'+          tracer lnks (Nothing,pmp') = (lnks,pmp')++popLinks :: PairMap -> Maybe ([Link],PairMap)+popLinks pmp@(PM lmp _)+    | M.null lmp = Nothing+    | otherwise =+        let cpr = M.findMin lmp+        in Just (traceLinks cpr $ deletePair cpr pmp)++listsToLinks :: [[Double]] -> Double -> [[(Int,Int)]]+listsToLinks lsts isolvl =+    unfoldr popLinks .  contourBoxesToPairMap $ listsToContourBoxes lsts isolvl++linksToLines :: (Double,Double) -> (Double,Double) -> [(Int,Int)] -> [(Double,Double)]+linksToLines (xmx,ymx) (xstp,ystp) lnks =+   (\(r,c) -> (xmx - fromIntegral c * xstp / 2,ymx - fromIntegral r * ystp / 2)) <$> lnks++
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2014, Sacha Sokoloski++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Sacha Sokoloski nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ goal-core.cabal view
@@ -0,0 +1,43 @@+name: goal-core+version: 0.1+synopsis: Core imports for Geometric Optimization Libraries.+description: Core provides a bunch of convenience functions, basic exports, as+    well as plotting functionality, which are independent of the rest of the+    library.+license: BSD3+license-file: LICENSE+author: Sacha Sokoloski+maintainer: sokolo@mis.mpg.de+category: Math+build-type: Simple+cabal-version: >=1.10++library+    exposed-modules:+        Goal.Core,+        Goal.Core.Plot,+        Goal.Core.Plot.Contour+    build-depends:+        base==4.*,+        data-default-class==0.0.*,+        lens==4.*,+        containers==0.5.*,+        colour==2.3.*,+        gtk==0.14.*,+        cairo==0.13.*,+        Chart==1.5.*,+        Chart-cairo==1.5.*,+        Chart-gtk==1.5.*+    default-extensions: TemplateHaskell+    default-language: Haskell2010+    ghc-options: -O2 -Wall -fno-warn-type-defaults -fno-warn-missing-signatures++executable contours+    main-is: contours.hs+    hs-source-dirs: scripts+    ghc-options: -Wall -O2 -threaded -rtsopts -fno-warn-type-defaults+        -fno-warn-missing-signatures -fno-warn-unused-do-bind+    build-depends:+        base==4.*,+        goal-core==0.1+    default-language: Haskell2010
+ scripts/contours.hs view
@@ -0,0 +1,27 @@+import Goal.Core++--- Test ---++main :: IO ()+main = do+    let f x y = 0.2 * x + 0.2 * y + sin x + sin y+        sz = 7.5+        nstp = 1000+        rng = (-sz,sz,nstp)+        niso = 20+        cntrs = contours rng rng niso f+        clrs = rgbaGradient (0,0,1,1) (1,0,0,1) niso+        lyt = toRenderable . execEC $ do++            layout_title .= "Contours of a 2D Sin Curve"++            sequence $ do++                ((_,cntr),clr) <- zip cntrs clrs++                return . plot . liftEC $ do++                    plot_lines_style .= solidLine 3 clr+                    plot_lines_values .= cntr++    renderableToAspectWindow False 800 600 lyt