Skip to content
Browse files

betty

  • Loading branch information...
1 parent 11aaced commit 252d391e05b57344d68221c40b2c7c5754fdb67b @kirel committed
Showing with 122 additions and 119 deletions.
  1. BIN .Classifier.hs.swp
  2. BIN Betty
  3. +85 −0 Betty.hs
  4. +14 −12 Classifier.hs
  5. +15 −0 JSON/Results.hs
  6. +2 −2 Strokes/JSON.hs → JSON/Strokes.hs
  7. +6 −0 Rakefile
  8. +0 −105 Webserver.hs
  9. BIN Websockets
  10. BIN bench
View
BIN .Classifier.hs.swp
Binary file not shown.
View
BIN Betty
Binary file not shown.
View
85 Betty.hs
@@ -0,0 +1,85 @@
+module Main where
+
+import qualified Hack as Hack
+import Hack.Handler.Happstack
+import Bird
+import qualified Bird as Bird
+import Bird.Translator.Hack
+import qualified Control.Monad.State as S
+import qualified Control.Monad.Reader as R
+import Control.Monad.Trans
+
+import Prelude hiding( log )
+
+import Classifier
+import StrokeSample
+import Strokes
+import Text.JSON
+import JSON.Strokes
+import JSON.Results
+
+-- logic
+
+cK = 10
+classifier = newClassifier cK
+
+sanitize :: Strokes -> Strokes
+sanitize = cleanStrokes . removeEmptyStrokes . (limitStrokes 10)
+
+process :: Strokes -> Stroke
+process = concat . (multiredistribute 30) . (refitStrokes (0,0,1,1)) . sanitize
+
+-- in/out
+
+json :: JSON j => j -> Handler
+json = \d -> mime "application/json" >> (body . encode) d
+jsonerror e = do
+ status 422
+ json $ toJSObject [("error", e)]
+jsonmessage m = json $ toJSObject [("message", m)]
+
+serverinfo = json $ toJSObject [("server", "Betty, the smart crow"), ("version", "0.0.1")]
+
+classify c d =
+ either
+ (\e -> jsonerror e)
+ (\strokes -> do
+ res <- liftIO $ classifyWithClassifier c (newStrokeSample (process strokes) Nothing)
+ log $ show $ res
+ json res)
+ (resultToEither $ decode $ d) -- comes out as Either String Strokes
+
+train _ _ Nothing = json "bla"
+train c d id = either
+ (\e -> jsonerror e)
+ (\strokes -> do
+ liftIO $ trainClassifier c (newStrokeSample (process strokes) id)
+ jsonmessage "Sample was successfully trained.")
+ (resultToEither $ decode $ d)
+
+main = do
+ putStrLn "Betty, the smart crow, was just spotted in flight at http://localhost:3000"
+
+ c <- classifier
+
+ run $ bird (router c) where
+ router c = do
+ r <- request
+ case verb r of
+ Bird.GET -> get c $ path r
+ Bird.POST -> post c $ path r
+ Bird.PUT -> put c $ path r
+ Bird.DELETE -> delete c $ path r
+
+ get c [] = serverinfo
+ get _ _ = status 404
+ post _ ["env"] = body.show =<< R.ask
+ post c ["classify"] = do
+ d <- reqBody
+ classify c d
+ post c ["train", id] = do
+ d <- reqBody
+ train c d (Just id)
+ post _ _ = status 404
+ put _ _ = status 404
+ delete _ _ = status 404
View
26 Classifier.hs
@@ -6,6 +6,7 @@ module Classifier
getSampleCounts,
showSamples,
Sample(..),
+ Score(..),
Results,
) where
@@ -26,15 +27,15 @@ class Sample a where
identifier :: a -> Maybe String -- Nothing for unknown class
data Hit s = Hit {
- score :: Double,
+ samplescore :: Double,
sample :: s
} deriving (Show)
instance Eq (Hit s) where
- h == o = (score h) == (score o)
+ h == o = (samplescore h) == (samplescore o)
instance Ord (Hit s) where
- compare h o = compare (score h) (score o)
+ compare h o = compare (samplescore h) (samplescore o)
data Classifier a = Classifier Int (TVar (Map String [a])) -- Classifier holds Training Data
-- TODO use a different Datastructure than []
@@ -42,8 +43,8 @@ data Classifier a = Classifier Int (TVar (Map String [a])) -- Classifier holds T
showSamples (Classifier _ t) = atomically $ readTVar t
-type Score = Double
-type Results = [(String, Score)]
+data Score = Score { id :: String, score :: Double } deriving (Show)
+type Results = [Score]
-- helper
update :: TVar a -> (a -> a) -> STM ()
@@ -57,7 +58,7 @@ findKNearestNeighbors k unknown known = Data.Heap.toList $ foldl' step (Data.Hea
| otherwise = heap where
lb = distancelb unknown next
dist = distance unknown next
- limit = score $ fromJust $ viewHead heap
+ limit = samplescore $ fromJust $ viewHead heap
-- first sort known in lbdist order
-- TODO find out if this should be actually faster...
@@ -67,16 +68,17 @@ fastFindKNearestNeighbors k unknown known = Data.Heap.toList $ foldl' step (Data
step heap (next, lb) | Data.Heap.size heap < k = Data.Heap.insert (Hit dist next) heap
| lb < limit && dist < limit = Data.Heap.insert (Hit dist next) $ fromJust $ viewTail heap
| otherwise = heap where
- limit = score $ fromJust $ viewHead heap
+ limit = samplescore $ fromJust $ viewHead heap
dist = distance unknown next
-alterMin :: Score -> Maybe Score -> Maybe Score
+alterMin :: Double -> Maybe Double -> Maybe Double
alterMin next Nothing = Just next
alterMin next (Just before) = Just $ min before next
-
+
results :: Sample s => [Hit s] -> Results
-results hits = Data.Map.toList $ foldl step Data.Map.empty hits where
- step results hit = alter (alterMin $ score hit) (fromJust $ identifier $ sample hit) results
+results hits = Prelude.map toScore $ Data.Map.toList $ foldl step Data.Map.empty hits where
+ toScore = uncurry Score
+ step results hit = alter (alterMin $ samplescore hit) (fromJust $ identifier $ sample hit) results
-- insert and accumulate samples
insertWithLimit :: Sample s => Int -> s -> Map String [s] -> Map String [s]
@@ -107,4 +109,4 @@ getSampleCounts (Classifier k t) = do
classifyWithClassifier :: Sample s => Classifier s -> s -> IO Results
classifyWithClassifier c@(Classifier k t) sample = do
samples <- getSamples c
- return $ results $ findKNearestNeighbors k sample samples
+ return $ results $ findKNearestNeighbors k sample samples
View
15 JSON/Results.hs
@@ -0,0 +1,15 @@
+module JSON.Results where
+
+import Text.JSON
+import Classifier
+
+instance JSON Score where
+ -- readJSON :: JSValue -> Result Point
+ readJSON (JSObject j) = case (i,s) of
+ (Ok i, Ok s) -> Ok (Score i s)
+ _ -> Error "Unable to read JSScore"
+ where i = valFromObj "id" j
+ s = valFromObj "score" j
+ readJSON _ = Error "Unable to read JSScore"
+ -- showJSON :: Point -> JSValue
+ showJSON (Score i s) = showJSON $ toJSObject [("id",showJSON i),("score", showJSON s)]
View
4 Strokes/JSON.hs → JSON/Strokes.hs
@@ -1,4 +1,4 @@
-module Strokes.JSON where
+module JSON.Strokes where
import Text.JSON
import Strokes
@@ -19,4 +19,4 @@ instance JSON Point where
-- putStrLn $ show rp
-- case rp of
-- Ok p -> putStrLn $ encode $ p
--- Error e -> putStrLn e
+-- Error e -> putStrLn e
View
6 Rakefile
@@ -0,0 +1,6 @@
+task :default => :compile
+
+task :compile do
+ sh "ghc --make -O2 -threaded Betty"
+ rm Dir.glob("**/*.{hi,o}")
+end
View
105 Webserver.hs
@@ -1,105 +0,0 @@
-module Main where
-
-import Network.Loli
-import Network.Loli.Utils
-import Network.Loli.Template.TextTemplate
-import Hack.Handler.SimpleServer
-import Hack.Contrib.Request
-import Hack.Contrib.Response
-import Control.Monad.Reader
-import Control.Monad.Error
-import Data.ByteString.Lazy(ByteString)
-import Data.ByteString.Lazy.UTF8 (toString, fromString)
-
-import Text.JSON
-import Strokes
-import Strokes.JSON
-
-import StrokeSample
-import Classifier
-
-import Data.Map hiding (update)
-import Data.List (sortBy)
-
-cK = 20
-classifier = newClassifier cK
-
-sanitize :: Strokes -> Strokes
-sanitize = cleanStrokes . removeEmptyStrokes . (limitStrokes 10)
-
-preprocess :: Strokes -> Stroke
-preprocess = concat . (multiredistribute 30) . sanitize
-
-process :: ByteString -> Either String Stroke
-process string = do
- strokes <- (resultToEither . decode . toString) string
- return (preprocess strokes)
-
-jsonPair s e = encode $ makeObj [(s, showJSON e)]
-
-jsonError :: String -> String
-jsonError = jsonPair "error"
-
-jsonMessage :: String -> String
-jsonMessage = jsonPair "message"
-
--- necessarily ugly :/
-jsonResults :: [(String, Double)] -> String
-jsonResults = encode . (Prelude.map toJSO) . sortBySnd where -- FIXME sorting could be done on the client...
- toJSO (i, score) = makeObj [("id", showJSON i), ("score", showJSON score)]
- sortBySnd = sortBy cmp where
- cmp a b = compare (snd a) (snd b)
-
--- server
-main = do
- c <- classifier
- print "Server starting at port 3000"
- (run 3000) . loli $ do
-
- get "/env" $ do
- env <- ask
- (text . show) env
-
- -- real thing
-
- -- classify
- post "/classify" $ do
- env <- ask
-
- j <- liftIO $ either
- (\e -> return $ jsonError e)
- (\stroke -> do
- res <- classifyWithClassifier c $ newStrokeSample stroke Nothing
- return $ jsonResults res)
- (process (body env))
- update $ set_content_type "application/json"
- update $ set_body (fromString j)
- -- output $ text_template j
-
- -- train
- post "/train/:identifier" $ do
- env <- ask
- identifier <- liftM (Prelude.lookup "identifier") captures -- this is always Just
-
- j <- liftIO $ either
- (\e -> return $ jsonError e)
- (\stroke -> do
- trainClassifier c $ newStrokeSample stroke identifier -- weg!
- return $ jsonMessage "Sample was successfully trained.")
- (process (body env))
- update $ set_content_type "application/json"
- update $ set_body (fromString j)
- -- output $ text_template j
-
- -- stats and counts TODO
- get "/" $ do
- s <- liftIO $ getSampleCounts c
- let j = encode $ makeObj [("counts", showJSON (toJSObject (toList s)))]
- update $ set_content_type "application/json"
- update $ set_body (fromString j)
-
- get "/samples" $ do
- s <- liftIO $ showSamples c
- text $ show (s :: Map String [StrokeSample])
-
--- TODO der classifier muss in einen state monat 0_o oder so. So baue ich mir immer nur einen neuen...
View
BIN Websockets
Binary file not shown.
View
BIN bench
Binary file not shown.

0 comments on commit 252d391

Please sign in to comment.
Something went wrong with that request. Please try again.