roc-cluster-demo (empty) → 0.1.0.0

raw patch · 5 files changed

+175/−0 lines, 5 filesdep +basedep +containersdep +glosssetup-changed

Dependencies added: base, containers, gloss, optparse-applicative, roc-cluster

Files

LICENSE +30/−0
README.md +5/−0
Setup.hs +2/−0
roc-cluster-demo.cabal +29/−0
src/Main.hs +109/−0

+ LICENSE view

@@ -0,0 +1,30 @@+Copyright Anton Gushcha (c) 2017++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 Anton Gushcha 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.

+ README.md view

@@ -0,0 +1,5 @@+# roc-cluster-demo++Controls:+- Left click adds new points+- Right click performs clusterization

+ Setup.hs view

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

+ roc-cluster-demo.cabal view

@@ -0,0 +1,29 @@+name:                roc-cluster-demo+version:             0.1.0.0+synopsis:            Gloss interactive demo for roc-cluster package+description:         Demo for displaying operation of ROC online clustering.+homepage:            https://github.com/ncrashed/roc-cluster-demo#readme+license:             BSD3+license-file:        LICENSE+author:              Anton Gushcha+maintainer:          ncrashed@gmail.com+copyright:           2017 Anton Gushcha+category:            Web+build-type:          Simple+cabal-version:       >=1.10+extra-source-files:  README.md++executable roc-cluster-demo+  hs-source-dirs:      src+  main-is:             Main.hs+  default-language:    Haskell2010+  build-depends:+      base                  >= 4.7      && < 5+    , containers            >= 0.5      && < 0.6+    , gloss                 >= 1.10     && < 1.11+    , optparse-applicative  >= 0.13     && < 0.14+    , roc-cluster           >= 0.1      && < 0.2+  default-extensions:+    OverloadedStrings+    RecordWildCards+    ScopedTypeVariables

+ src/Main.hs view

@@ -0,0 +1,109 @@+module Main where++import Data.Cluster.ROC+import Data.Monoid+import Graphics.Gloss.Interface.Pure.Game+import Options.Applicative++import qualified Data.Foldable as F+import qualified Data.Sequence as S+import Debug.Trace++data Vec2 = Vec2 !Float !Float+  deriving (Eq, Show)++instance ClusterSpace Vec2 where+  pointZero = Vec2 0 0+  pointAdd (Vec2 x1 y1) (Vec2 x2 y2) = Vec2 (x1 + x2) (y1 + y2)+  pointScale v (Vec2 x y) = Vec2 (realToFrac v * x) (realToFrac v * y)+  -- gaus kernell with sigma = 1+  pointKernel (Vec2 x1 y1) (Vec2 x2 y2) = realToFrac $ exp ( negate $ 0.5 * ((x2 - x1) ^ 2 + (y2 - y1) ^ 2) )+  pointDistanceSquared x y = 2 - 2 * pointKernel x y+  {-# INLINE pointZero #-}+  {-# INLINE pointAdd #-}+  {-# INLINE pointScale #-}+  {-# INLINE pointKernel #-}+  {-# INLINE pointDistanceSquared #-}++data World = World {+  worldClusters  :: ROCContext Vec2+, worldWidth     :: Float+, worldHeight    :: Float+, worldNewPoints :: S.Seq Vec2+, worldOldPoints :: S.Seq Vec2+}++runClustering :: ROCConfig -> IO ()+runClustering cfg = play display bg fps world render handleEvent update+  where+    width = 800+    height = 800+    display = InWindow "ROC demo" (width, height) (100, 100)+    bg = greyN 0.9+    fps = 60+    world = World (emptyROCContext cfg) (fromIntegral width) (fromIntegral height) mempty mempty++render :: World -> Picture+render World{..} = scaleWorld $ drawOrigin <> drawNewPoints <> drawOldPoints <> drawClusters+  where+    scaleWorld = scale (worldWidth*0.5) (worldHeight*0.5)+    drawOrigin =+         line [(-0.9, 0), (0.9, 0)]+      <> line [(0, -0.9), (0, 0.9)]+    drawNewPoints = F.foldMap (\(Vec2 x y) -> translate x y $ color red $ circleSolid 0.005) worldNewPoints+    drawOldPoints = F.foldMap (\(Vec2 x y) -> translate x y $ color blue $ circleSolid 0.005) worldOldPoints+    drawClusters = F.foldMap drawCluster $ rocPrototypes worldClusters+    drawCluster p = let+      Vec2 x y = prototypeValue p+      r = realToFrac $ 0.1 / (1 + exp (negate $ prototypeWeight p) )+      in translate x y $ circle r <> line [(-0.005, 0), (0.005, 0)] <> line [(0, -0.005), (0, 0.005)]++handleEvent :: Event -> World -> World+handleEvent (EventResize (w, h)) world = world {+    worldWidth = fromIntegral w+  , worldHeight = fromIntegral h+  }+handleEvent (EventKey (MouseButton LeftButton) Down _ (x, y)) world@World{..} = world {+    worldNewPoints = worldNewPoints S.|> Vec2 (2 * x / worldWidth) (2 * y / worldHeight)+  }+handleEvent (EventKey (MouseButton RightButton) Down _ _) world@World{..} = world {+    worldNewPoints = mempty+  , worldOldPoints = worldOldPoints <> worldNewPoints+  , worldClusters = clusterize worldNewPoints worldClusters+  }+handleEvent _ world = world++update :: Float -> World -> World+update = const id++data Options = Options {+  threshold :: Double+, maxClusters :: Int+}++toROCConfig :: Options -> ROCConfig+toROCConfig Options{..} = defaultROCConfig {+    rocThreshold = threshold+  , rocMaxClusters = maxClusters+  }++configParser :: Parser ROCConfig+configParser = fmap toROCConfig $ Options+  <$> option auto (+       long "threshold"+    <> help "Cluster with lower weight will be deleted at post-process step."+    <> value 0.1+    )+  <*> option auto (+       long "maxclusters"+    <> help "Maximum count of allowed clusters."+    <> value 10+    )++main :: IO ()+main = runClustering =<< execParser opts+  where+    opts = info (configParser <**> helper)+      ( fullDesc+     <> progDesc "Run interactive demo for ROC clustering algorithm"+     <> header "roc-cluster-demo - a demo for roc-cluster-demo" )