twentefp-eventloop-graphics (empty) → 0.1.0.0

raw patch · 20 files changed

+806/−0 lines, 20 filesdep +basedep +networkdep +textsetup-changed

Dependencies added: base, network, text, twentefp-number, twentefp-websockets

Files

LICENSE +30/−0
Setup.hs +2/−0
src/EventLoop.hs +30/−0
src/EventLoop/CommonTypes.hs +11/−0
src/EventLoop/Config.hs +102/−0
src/EventLoop/EventProcessor.hs +63/−0
src/EventLoop/Input.hs +13/−0
src/EventLoop/Input/InputEvent.hs +18/−0
src/EventLoop/Input/Keyboard.hs +20/−0
src/EventLoop/Input/Mouse.hs +43/−0
src/EventLoop/Input/SystemMessage.hs +18/−0
src/EventLoop/Json.hs +118/−0
src/EventLoop/Main.hs +18/−0
src/EventLoop/Output.hs +18/−0
src/EventLoop/Output/Graphical.hs +12/−0
src/EventLoop/Output/Graphical/Graphical.hs +146/−0
src/EventLoop/Output/OutputEvent.hs +14/−0
src/EventLoop/Output/Single.hs +67/−0
src/EventLoop/Output/SystemMessage.hs +19/−0
twentefp-eventloop-graphics.cabal +44/−0

+ LICENSE view

@@ -0,0 +1,30 @@+Copyright (c)2011, Christiaan Baaij
+
+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 Christiaan Baaij 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

+ src/EventLoop.hs view

@@ -0,0 +1,30 @@+module EventLoop(
+    start,
+    Pos,
+    Dimension,
+    Element,
+    
+    InputEvent(..),
+    Keyboard(..),
+    KeyboardButton,
+    Mouse(..),
+    MouseButton(..),
+    SystemMessageIn(..),
+    
+    OutputEvent(..),
+    SystemMessageOut(..),
+    Graphical(..),
+    GObject(..),
+    Primitive(..),
+    Name,
+    Groupname,
+    Color,
+    Font,
+    Relative,
+    outSingle
+) where
+
+import EventLoop.Main
+import EventLoop.CommonTypes
+import EventLoop.Input
+import EventLoop.Output

+ src/EventLoop/CommonTypes.hs view

@@ -0,0 +1,11 @@+module EventLoop.CommonTypes(
+    Pos,
+    Dimension,
+    Element
+) where
+
+import FPPrac
+
+type Pos = (Number, Number) -- (x, y)
+type Dimension = (Number, Number) -- (h, w)
+type Element = [Char]

+ src/EventLoop/Config.hs view

@@ -0,0 +1,102 @@+module EventLoop.Config where
+
+import FPPrac
+
+------------------
+-- Server Settings
+ipadres = "127.0.0.1"
+port = 9161 :: Number
+
+-----------
+-- Response modes
+graphicalS      = "graphical"
+commandS        = "command"
+modeS           = "mode"
+drawS           = "draw"
+movegroupS      = "movegroup"
+moveelementS    = "moveelement"
+removegroupS    = "removegroup"
+removeelementS  = "removeelement"
+
+gobjectS    = "gobject"
+nameS       = "name"
+groupnameS  = "groupname"
+positionS   = "position"
+relativeS   = "relative"
+
+-- GObject options
+containerS  = "containers"
+primS       = "prim"
+childrenS   = "children"
+
+-- JSONObject/Primitive options
+typeS   = "type"
+textS   = "text"
+lineS   = "line"
+rectS   = "rect"
+arcS    = "arc"
+
+edgecolorS      = "edgecolor"
+edgethicknessS  = "edgethickness"
+colorS          = "color"
+positionsS      = "positions"
+
+sizeS = "size"
+fontS = "font"
+fromcenterS = "fromcenter"
+
+widthS = "width"
+heightS = "height"
+radiusS = "radius"
+startangS = "startang"
+endangS = "endang"
+
+-- Color
+rS = "r"
+bS = "b"
+gS = "g"
+
+-- Position
+xS = "x"
+yS = "y"
+
+----------
+-- Request options
+
+buttonS = "button"
+
+-- Mouse
+mouseS = "mouse"
+mousetypeS = "mousetype"
+mouseclickS = "mouseclick"
+mouseupS = "mouseup"
+mousedownS = "mousedown"
+leftS = "left"
+middleS = "middle"
+rightS = "right"
+elementS = "element"
+
+-- Keyboard
+keyboardS = "keyboard"
+
+-- SystemMessage
+systemmessageS = "systemmessage"
+backgroundS = "background"
+setupS = "setup"
+timeS = "time"
+
+-- SystemMessageAnswers
+sysmessageanswersS = "systemmessageanswers"
+sysmessageanswerS = "systemmessageanswer"
+messageS = "message"
+answersS = "answers"
+canvassetupS = "canvassetup"
+dimensionS = "dimension"
+timerS = "timer"
+useS = "use"
+closeS = "close"
+
+
+-- Dimension
+hS = "h"
+wS = "w"

+ src/EventLoop/EventProcessor.hs view

@@ -0,0 +1,63 @@+module EventLoop.EventProcessor(eventloop, IOMessage, readRequest, sendResponse) where
+
+import qualified Network.WebSockets as WS
+import Control.Exception (handle, fromException, AsyncException(..), onException)
+import qualified Data.Text as T
+import Data.String (String)
+import Data.Char (isLower, isDigit)
+import Control.Monad (sequence)
+
+import EventLoop.Json
+import EventLoop.Config
+
+import Debug.Trace
+
+type IOMessage = JSONMessage
+
+-- Start connection
+eventloop :: (a -> IOMessage -> ([IOMessage], a)) -> a -> IO ()
+eventloop eh beginState = WS.runServer ipadres (fromIntegral port) $ application eh beginState
+
+application :: (a -> IOMessage -> ([IOMessage], a)) -> a -> WS.PendingConnection -> IO ()
+application eh beginState pending = do
+                        conn <- WS.acceptRequest pending
+                        onException (doEvents eh beginState conn) (putStrLn "text1")
+                        --handle (catchUserInterrupt conn) $ handle (catchDisconnect conn) $ doEvents eh beginState conn
+                        return ()
+
+-- Connection functions
+catchDisconnect :: WS.Connection -> WS.ConnectionException -> IO ()
+catchDisconnect conn e = case e of
+                          WS.ConnectionClosed         -> putStrLn "Connection closed!"
+                          WS.CloseRequest code reason -> putStrLn "test1"
+
+-- User Interrupt
+catchUserInterrupt :: WS.Connection -> AsyncException -> IO()
+catchUserInterrupt conn e = case e of
+                             UserInterrupt -> putStrLn "test2"
+                             ThreadKilled  -> putStrLn "test3"
+
+-- Event Loop
+doEvents :: (a -> IOMessage -> ([IOMessage], a)) -> a -> WS.Connection -> IO ()
+doEvents eh state conn = do
+                    request <- readRequest conn
+                    let
+                        (resp, state') = eh state request 
+                        sendActions = map (sendResponse conn)  resp
+                    sequence sendActions
+                    doEvents eh state' conn
+                
+readRequest :: WS.Connection -> IO IOMessage                
+readRequest conn = do
+                    msg <- WS.receiveData conn
+                    let
+                        string = T.unpack msg
+                        request = stringToJsonObject string
+                    return request
+                    
+sendResponse :: WS.Connection -> IOMessage -> IO ()
+sendResponse conn response = do
+                        let
+                            string = show response
+                            text = T.pack string
+                        WS.sendTextData conn text

+ src/EventLoop/Input.hs view

@@ -0,0 +1,13 @@+module EventLoop.Input(
+    InputEvent(..),
+    Keyboard(..),
+    KeyboardButton,
+    Mouse(..),
+    MouseButton(..),
+    SystemMessageIn(..)
+) where
+
+import EventLoop.Input.InputEvent
+import EventLoop.Input.Keyboard
+import EventLoop.Input.Mouse
+import EventLoop.Input.SystemMessage

+ src/EventLoop/Input/InputEvent.hs view

@@ -0,0 +1,18 @@+module EventLoop.Input.InputEvent where
+
+import EventLoop.Config
+import EventLoop.Json
+import EventLoop.Input.Keyboard
+import EventLoop.Input.Mouse
+import EventLoop.Input.SystemMessage
+
+data InputEvent = InMouse Mouse       
+                | InKeyboard Keyboard
+                | InSysMessage SystemMessageIn
+             
+instance FromJSON InputEvent where
+    fromJsonMessage obj@(JSONObject ms) | keyboardS == type'      = InKeyboard (fromJsonMessage obj)
+                                        | mouseS == type'         = InMouse (fromJsonMessage obj)
+                                        | systemmessageS == type' = InSysMessage (fromJsonMessage obj) 
+                                          where
+                                              JSONString type' = retrieveError typeS ms

+ src/EventLoop/Input/Keyboard.hs view

@@ -0,0 +1,20 @@+module EventLoop.Input.Keyboard(
+    Keyboard(..),
+    KeyboardButton
+) where
+
+import EventLoop.Json
+import EventLoop.Config
+
+-- Possible messages:
+-- {"type": "keyboard", "button": "<kkey>"}
+-- <kkey> = a | b | c .. | z | shift | caps ..
+
+-- Keyboard Messages In
+data Keyboard = KeyPress KeyboardButton
+type KeyboardButton = [Char]
+
+instance FromJSON Keyboard where
+    fromJsonMessage (JSONObject ms) = KeyPress button
+                                    where
+                                        JSONString button = retrieveError buttonS ms

+ src/EventLoop/Input/Mouse.hs view

@@ -0,0 +1,43 @@+module EventLoop.Input.Mouse(
+    Mouse(..),
+    MouseButton(..)
+) where
+
+import EventLoop.Json
+import EventLoop.Config
+import EventLoop.CommonTypes
+
+
+-- Possible messages:
+-- {"type":"mouse","button":"<mkey>","x":<number>,"y":<number>,"element":"<name>"}
+-- <mkey> = left | right | middle
+-- <name> = (a | b | c | ... | z | A | B | C ...)+
+-- <numbers> = (1 | 2 | 3 | ... | 0)+
+
+-- Mouse Messages In
+data Mouse = MouseClick MouseButton Pos Element
+           | MouseUp MouseButton Pos Element
+           | MouseDown MouseButton Pos Element
+           deriving Show
+           
+data MouseButton = MLeft | MRight | MMiddle
+                    deriving Show
+
+instance FromJSON Mouse where
+    fromJsonMessage (JSONObject ms) | mouseType == mouseclickS = MouseClick button pos element
+                                    | mouseType == mouseupS    = MouseUp button pos element
+                                    | mouseType == mousedownS  = MouseDown button pos element
+                                    where
+                                        JSONString mouseType = retrieveError mousetypeS ms
+                                        JSONNumber x = retrieveError xS ms
+                                        JSONNumber y = retrieveError yS ms
+                                        pos = (x, y)
+                                        JSONString element = retrieveError elementS ms
+                                        jsonButton = retrieveError buttonS ms
+                                        button = fromJsonMessage jsonButton
+       
+instance FromJSON MouseButton where
+    fromJsonMessage (JSONString but) | leftS   == but = MLeft
+                                     | middleS == but = MMiddle
+                                     | rightS  == but = MRight
+                                     | otherwise = error ("Could not create a mouse button from value: " ++ but)

+ src/EventLoop/Input/SystemMessage.hs view

@@ -0,0 +1,18 @@+module EventLoop.Input.SystemMessage(
+    SystemMessageIn(..)
+) where
+
+import EventLoop.Json
+import EventLoop.Config
+
+-- System Messages In
+data SystemMessageIn = Setup
+                     | Background
+                     | Time
+                     
+instance FromJSON SystemMessageIn where
+    fromJsonMessage (JSONObject ms) | message == setupS      = Setup
+                                    | message == backgroundS = Background
+                                    | message == timeS       = Time
+                                      where
+                                          JSONString message = retrieveError messageS ms

+ src/EventLoop/Json.hs view

@@ -0,0 +1,118 @@+module EventLoop.Json(JSONMember(..), JSONMessage(..), retrieve, retrieveError, FromJSON(..), JSONAble(..), stringToJsonObject)  where
+
+import Data.Char (isDigit, isLower, isUpper)
+import FPPrac
+
+data JSONMember = JSONMember [Char] JSONMessage
+
+data JSONMessage = JSONNumber Number
+                | JSONString [Char]
+                | JSONBool Bool
+                | JSONObject [JSONMember]
+                | JSONArray [JSONMessage]
+                
+
+retrieve :: [Char] -> [JSONMember] -> Maybe JSONMessage
+retrieve search [] = Nothing
+retrieve search ((JSONMember name member):list) | search == name = Just member
+                                               | otherwise = retrieve search list                
+                
+retrieveError :: [Char] -> [JSONMember] -> JSONMessage
+retrieveError search members = case (retrieve search members) of
+                                Nothing -> error ("Could not find " ++ search ++ " in JSON members")
+                                Just result -> result
+
+class FromJSON a where
+    fromJsonMessage :: JSONMessage -> a
+    
+instance Show JSONMessage where    
+    show (JSONNumber n)      = show n
+    show (JSONString s)      = "\"" ++ s ++ "\""
+    show (JSONBool bool)     | bool        = "true"
+                             | otherwise = "false"
+    show (JSONObject (r:rs)) = "{" ++ rows ++ "}"
+                                    where
+                                        rows = foldl insertComma (show r) (map show rs)
+    show (JSONArray [])       = "[]"
+    show (JSONArray (x:xs))     = "[" ++ list ++ "]"
+                                    where
+                                        list = foldl insertComma (show x) (map show xs)
+
+insertComma :: [Char] -> [Char] -> [Char]
+insertComma a b = a ++ "," ++ b                
+
+instance Show JSONMember where
+    show (JSONMember name m) = "\"" ++ name ++ "\": " ++ (show m)
+
+
+
+
+class JSONAble a where
+    toJsonMessage :: a -> JSONMessage
+  
+-- JSON Grammar for 1 object
+-- Grammar returns (Rest, JSONObject [JSONRow])
+-- O: '{' R+ '}'
+-- R: '"' W '"' ':' V
+-- V: '"' (JSONInt N | JSONString W) '"'
+-- N: ('1' | '2' | '3' | ... | '0')+
+-- W: ('a' | 'b' | 'c' | ... | 'z') (N | W | -)
+
+data Grammer = O | R
+type Rest = [Char]
+
+stringToJsonObject :: [Char] -> JSONMessage
+stringToJsonObject string = snd $ parse O string (JSONObject [])
+
+errorMsg :: [Char] -> [Char] -> [Char]
+errorMsg exp act = "Fault at parsing, expected '" ++ exp ++ "' but found '" ++ act ++ "'"
+
+parse :: Grammer -> Rest -> JSONMessage -> (Rest, JSONMessage)
+parse O [] _ = error (errorMsg "something" "premature end (start of message)")
+parse O (c1:cs) (JSONObject rows)     | c1 == '{' = result
+                                    | otherwise = error (errorMsg "{" [c1])
+                                    where
+                                        ((c1':cs'), object) = parse R cs (JSONObject rows)
+                                        result     | c1' == '}' = (cs', object)
+                                                | otherwise = error (errorMsg "}" [c1'])
+
+parse R [] _ = error (errorMsg "something" "premature end (reading a row)")                                        
+parse R (t:ts) (JSONObject rows) = object
+                                    where
+                                        ((r:rs), rowName) | t == '"' = parseWord ts                 -- Read row name
+                                                          | otherwise = error (errorMsg "\"" [t])  
+                                        rs'    | r == ':' = rs                                         -- Read row delimiter
+                                            | otherwise = error (errorMsg ":" [r])
+                                        ((r'':rs''), var2) = parseVariable rs'                      -- Read variable for row
+                                        rows' = rows ++ [(JSONMember rowName var2)]                 -- Add found result to other rows
+                                        object     | r'' == '}' = ((r'':rs''), JSONObject rows')       -- End, return result
+                                                | r'' == ',' = parse R rs'' (JSONObject rows')      -- Read next row
+                                                | otherwise = error (errorMsg "',' or '}'" [r''])                                    
+
+-- Possibilities:
+-- "\"string123value\"" -> JSONString "string123value" or "12345" -> JSONInt 12345                                    
+parseVariable :: Rest -> (Rest, JSONMessage)                                        
+parseVariable [] = error (errorMsg "something" "premature end")
+parseVariable [c1] = error (errorMsg "longer variable" (c1:" and premature end"))                
+parseVariable (c1:c2:cs)    | c1 == '"' && ((isLower c2) || (isUpper c2)) = (r1, JSONString word)
+                            | isDigit c1 = (r2, JSONNumber (read number))
+                            | otherwise = error (errorMsg "\"" [c1])
+                            where
+                                (r1, word)   = parseWord (c2:cs)
+                                (r2, number) = parseNumber (c1:c2:cs)
+
+parseWord :: Rest -> (Rest, [Char])
+parseWord [] = error (errorMsg "something" "premature end")
+parseWord (c1:cs)     | (isLower c1) || (isDigit c1) || (isUpper c1) = (r1, c1:result')
+                    | c1 == '"' = (cs, [])
+                    | otherwise = error (errorMsg "letter or number" [c1])
+                    where
+                        (r1, result') = parseWord cs
+
+parseNumber :: Rest -> (Rest, [Char])                         
+parseNumber [] = error (errorMsg "something" "premature end")                         
+parseNumber (c1:cs) | isDigit c1 || c1 == '.' = (r1, c1:result')
+                    | c1 == ',' || c1 == '}' = (c1:cs, [])
+                    | otherwise = error (errorMsg "number" [c1])
+                            where
+                                (r1, result') = parseNumber cs

+ src/EventLoop/Main.hs view

@@ -0,0 +1,18 @@+module EventLoop.Main(start) where
+
+import EventLoop.EventProcessor
+import EventLoop.Input.InputEvent
+import EventLoop.Output.OutputEvent
+import EventLoop.Json
+         
+start :: (a -> InputEvent -> ([OutputEvent], a)) -> a -> IO()
+start handler beginstate = eventloop handler' beginstate
+                        where
+                            handler' = changeTypes handler
+
+
+changeTypes :: (a -> InputEvent -> ([OutputEvent], a)) -> a -> IOMessage -> ([IOMessage], a)
+changeTypes f state message = (map toJsonMessage oEvents, state')
+                    where
+                        iEvent = fromJsonMessage message
+                        (oEvents, state') = f state iEvent

+ src/EventLoop/Output.hs view

@@ -0,0 +1,18 @@+module EventLoop.Output(
+    OutputEvent(..),
+    SystemMessageOut(..),
+    Graphical(..),
+    GObject(..),
+    Primitive(..),
+    Name,
+    Groupname,
+    Color,
+    Font,
+    Relative,
+    outSingle
+) where
+
+import EventLoop.Output.OutputEvent
+import EventLoop.Output.SystemMessage
+import EventLoop.Output.Graphical
+import EventLoop.Output.Single

+ src/EventLoop/Output/Graphical.hs view

@@ -0,0 +1,12 @@+module EventLoop.Output.Graphical(
+    Graphical(..),
+    GObject(..),
+    Primitive(..),
+    Name,
+    Groupname,
+    Color,
+    Font,
+    Relative
+) where
+
+import EventLoop.Output.Graphical.Graphical

+ src/EventLoop/Output/Graphical/Graphical.hs view

@@ -0,0 +1,146 @@+module EventLoop.Output.Graphical.Graphical(
+        Graphical(..),
+        GObject(..),
+        Primitive(..),
+        Name,
+        Groupname,
+        Color,
+        Font,
+        Relative
+) where
+
+import EventLoop.Json
+import EventLoop.Config
+import EventLoop.CommonTypes
+import FPPrac
+
+-- Options
+type Name = [Char]
+type Groupname = [Char]
+type Color = (Number, Number, Number) -- (r, g, b)
+type Font = [Char]
+type Relative = Bool -- Move relative to old spot or not
+
+-- Graphical Responses Out
+data Graphical = Draw GObject Groupname
+                | MoveGroup Groupname Pos Relative
+                | MoveElement Name Pos Relative
+                | RemoveGroup Groupname
+                | RemoveElement Name        
+                
+instance JSONAble Graphical where
+    toJsonMessage (Draw gObject gName)              = JSONObject [(JSONMember modeS      (JSONString drawS)),
+                                                               (JSONMember gobjectS   (toJsonMessage gObject)),     
+                                                               (JSONMember groupnameS (JSONString gName))]
+                                                               
+    toJsonMessage (MoveGroup gName pos rel)      = JSONObject [(JSONMember modeS      (JSONString movegroupS)),
+                                                               (JSONMember groupnameS (JSONString gName)), 
+                                                               (JSONMember positionS  (positionToJsonMessage pos)), 
+                                                               (JSONMember relativeS  (JSONBool rel))]
+                                                                                      
+    toJsonMessage (MoveElement name pos rel)     = JSONObject [(JSONMember modeS      (JSONString moveelementS)),
+                                                               (JSONMember nameS      (JSONString name)),       
+                                                               (JSONMember positionS  (positionToJsonMessage pos)), 
+                                                               (JSONMember relativeS  (JSONBool rel))]
+                                                               
+    toJsonMessage (RemoveGroup gName)              = JSONObject [(JSONMember modeS       (JSONString removegroupS)),
+                                                               (JSONMember groupnameS  (JSONString gName))]
+    
+    toJsonMessage (RemoveElement name)              = JSONObject [(JSONMember modeS (JSONString removeelementS)),
+                                                               (JSONMember nameS (JSONString name))]
+                
+
+
+-- Graphical Object Wrapper
+data GObject = GObject    { name :: Name
+                        , prim :: Primitive
+                        , children :: [GObject]
+                        }
+             | Container { children :: [GObject]
+                         }
+                        deriving (Show)
+
+instance JSONAble GObject where
+    toJsonMessage (GObject name prim children) = JSONObject [(JSONMember typeS     (JSONString gobjectS)), 
+                                                             (JSONMember primS     (toJsonMessage prim)), 
+                                                             (JSONMember nameS     (JSONString name)), 
+                                                             (JSONMember childrenS (JSONArray (map toJsonMessage children)))]
+                                                             
+    toJsonMessage (Container children)         = JSONObject [(JSONMember childrenS (JSONArray (map toJsonMessage children)))]
+                        
+-- Primitive graphical structures                        
+data Primitive = Text    { edgeColor :: Color
+                        , edgeThickness :: Number
+                        , color :: Color
+                        , position :: Pos
+                        , size :: Number
+                        , font :: Font
+                        , text :: [Char]
+                        , fromCenter :: Bool
+                        }
+                | Line     { edgeColor :: Color
+                        , edgeThickness :: Number
+                        , positions :: [Pos]
+                        }
+                | Rect    { edgeColor :: Color
+                        , edgeThickness :: Number
+                        , color :: Color
+                        , position :: Pos -- Topleft corner
+                        , dimensions :: Dimension
+                        }
+                | Arc     { edgeColor :: Color
+                        , edgeThickness :: Number
+                        , color :: Color
+                        , position :: Pos
+                        , radius :: Number
+                        , startAng :: Number -- In degrees
+                        , endAng :: Number -- In degrees
+                        }
+                    deriving (Show, Eq)
+
+
+instance JSONAble Primitive where
+    toJsonMessage (Text ec et color position size font text fromcenter) = JSONObject [(JSONMember typeS           (JSONString textS)), 
+                                                                                      (JSONMember edgecolorS      (colorToJsonMessage ec)), 
+                                                                                      (JSONMember edgethicknessS  (JSONNumber et)), 
+                                                                                      (JSONMember colorS          (colorToJsonMessage color)), 
+                                                                                      (JSONMember positionS       (positionToJsonMessage position)), 
+                                                                                      (JSONMember sizeS           (JSONNumber size)), 
+                                                                                      (JSONMember fontS           (JSONString font)), 
+                                                                                      (JSONMember textS           (JSONString text)), 
+                                                                                      (JSONMember fromcenterS     (JSONBool fromcenter))]
+                                                                            
+    toJsonMessage (Line ec et positions) = JSONObject [(JSONMember typeS           (JSONString lineS)), 
+                                                       (JSONMember edgecolorS      (colorToJsonMessage ec)), 
+                                                       (JSONMember edgethicknessS  (JSONNumber et)), 
+                                                       (JSONMember positionsS      (JSONArray (map positionToJsonMessage positions)))]
+                                                                                     
+    toJsonMessage (Rect ec et color position dim) = JSONObject [(JSONMember typeS           (JSONString rectS)), 
+                                                                         (JSONMember edgecolorS      (colorToJsonMessage ec)), 
+                                                                         (JSONMember edgethicknessS  (JSONNumber et)), 
+                                                                         (JSONMember colorS          (colorToJsonMessage color)), 
+                                                                         (JSONMember positionS       (positionToJsonMessage position)),
+                                                                         (JSONMember dimensionS      (dimensionToJsonMessage dim))]
+                                                                
+    toJsonMessage (Arc ec et color position radius startAng endAng) = JSONObject [(JSONMember typeS          (JSONString arcS)),  
+                                                                                  (JSONMember edgecolorS     (colorToJsonMessage ec)), 
+                                                                                  (JSONMember edgethicknessS (JSONNumber et)), 
+                                                                                  (JSONMember colorS         (colorToJsonMessage color)), 
+                                                                                  (JSONMember positionS      (positionToJsonMessage position)), 
+                                                                                  (JSONMember radiusS        (JSONNumber radius)), 
+                                                                                  (JSONMember startangS      (JSONNumber startAng)), 
+                                                                                  (JSONMember endangS        (JSONNumber endAng))]
+
+-- Support Functions                                                                                
+colorToJsonMessage :: Color -> JSONMessage
+colorToJsonMessage (r, g, b) = JSONObject [(JSONMember rS (JSONNumber r)), 
+                                           (JSONMember gS (JSONNumber g)), 
+                                           (JSONMember bS (JSONNumber b))]
+
+positionToJsonMessage :: Pos -> JSONMessage
+positionToJsonMessage (x, y) = JSONObject [(JSONMember xS (JSONNumber x)), 
+                                           (JSONMember yS (JSONNumber y))] 
+
+dimensionToJsonMessage :: Dimension -> JSONMessage                                           
+dimensionToJsonMessage (h, w) = JSONObject [(JSONMember heightS (JSONNumber h)), 
+                                            (JSONMember widthS  (JSONNumber w))]

+ src/EventLoop/Output/OutputEvent.hs view

@@ -0,0 +1,14 @@+module EventLoop.Output.OutputEvent where
+
+import EventLoop.Output.Graphical.Graphical
+import EventLoop.Output.SystemMessage
+import EventLoop.Config
+import EventLoop.Json
+
+data OutputEvent = OutGraphical Graphical
+                 | OutSysMessage [SystemMessageOut]
+                
+                
+instance JSONAble OutputEvent where
+    toJsonMessage (OutGraphical graph)   = JSONObject [(JSONMember modeS (JSONString graphicalS)), (JSONMember commandS (toJsonMessage graph))]
+    toJsonMessage (OutSysMessage ms)  = JSONObject [(JSONMember modeS (JSONString sysmessageanswersS)), (JSONMember answersS (JSONArray (map toJsonMessage ms)))]

+ src/EventLoop/Output/Single.hs view

@@ -0,0 +1,67 @@+module EventLoop.Output.Single (outSingle) where
+
+import qualified Network.Socket     as S
+import qualified Network.WebSockets as WS
+import qualified Data.Text          as T
+
+import EventLoop.EventProcessor (sendResponse, IOMessage)
+import EventLoop.Output.OutputEvent
+import EventLoop.Output.Graphical
+import EventLoop.Output.SystemMessage
+import EventLoop.Config
+import EventLoop.Json
+import EventLoop.CommonTypes
+
+outSingle :: OutputEvent -> IO ()
+outSingle out = S.withSocketsDo $ do
+                                    sock <- WS.makeSocket ipadres (fromIntegral port)
+                                    pendingConn <- WS.makePendingConnection sock
+                                    conn <- WS.acceptRequest pendingConn
+                                    sendResponse conn setup
+                                    sendResponse conn out'
+                                    sendResponse conn close
+                                    WS.sendClose conn (T.pack "")
+                                    WS.closeSocket sock
+                                    return ()
+                where
+                    setup = toIOMessage (setupMessage out)
+                    out' = toIOMessage out 
+                    close = toIOMessage closeMessage
+    
+setupMessage :: OutputEvent -> OutputEvent
+setupMessage (OutGraphical (Draw g _)) = OutSysMessage [CanvasSetup dim]
+                                    where
+                                        dim = maxDimensions g
+setupMessage _ = OutSysMessage [CanvasSetup (512, 512)]                                        
+
+closeMessage :: OutputEvent
+closeMessage = OutSysMessage [Close]
+    
+toIOMessage :: OutputEvent -> IOMessage
+toIOMessage = toJsonMessage
+
+maxDimensions :: GObject -> Dimension
+maxDimensions (GObject _ prim [])     = maxDimensionsPrim prim
+maxDimensions (GObject n prim (c:cs)) = (max h h', max w w')
+                                        where
+                                            (h, w) = maxDimensions c
+                                            (h', w') = maxDimensions (GObject n prim cs)
+maxDimensions (Container [])          = (0, 0)
+maxDimensions (Container (c:cs))      = (max h h', max w w')
+                                        where
+                                            (h, w) = maxDimensions c
+                                            (h', w') = maxDimensions (Container cs)
+
+maxDimensionsPrim :: Primitive -> Dimension
+maxDimensionsPrim (Text _ _ _ (x, y) size _ str fromCenter) | fromCenter = (y + size / 2, x + (fromIntegral $ length str * 10) / 2)
+                                                            | otherwise  = (y + size, x + (fromIntegral $ length str * 10))
+maxDimensionsPrim (Line _ _ [])                             = (0, 0)                                                                    
+maxDimensionsPrim (Line _ _ [(x, y)])                       = (y, x)
+maxDimensionsPrim (Line ec et ((x, y):xs))                  = (max y y', max x x')
+                                                        where
+                                                            (y', x') = maxDimensionsPrim (Line ec et xs) 
+maxDimensionsPrim (Rect _ _ _ (x, y) (h, w))                = (y + h / 2, x + w / 2) 
+maxDimensionsPrim (Arc _ _ _ (x, y) r _ _)                  = (y + r, x + r)
+    
+
+

+ src/EventLoop/Output/SystemMessage.hs view

@@ -0,0 +1,19 @@+module EventLoop.Output.SystemMessage(SystemMessageOut(..)) where
+
+import EventLoop.Json
+import EventLoop.Config
+import EventLoop.CommonTypes
+
+-- System Messages Out
+data SystemMessageOut = CanvasSetup Dimension
+                      | Timer Bool
+                      | Close
+                               
+instance JSONAble SystemMessageOut where
+    toJsonMessage (CanvasSetup dim) = JSONObject [(JSONMember sysmessageanswerS (JSONString canvassetupS)), (JSONMember dimensionS (dimensionToJsonMessage dim))]
+    toJsonMessage (Timer bool)      = JSONObject [(JSONMember sysmessageanswerS (JSONString timerS)), (JSONMember useS (JSONBool bool))]
+    toJsonMessage (Close)           = JSONObject [(JSONMember sysmessageanswerS (JSONString closeS))]
+    
+-- Support Function
+dimensionToJsonMessage :: Dimension -> JSONMessage
+dimensionToJsonMessage (h, w) = JSONObject [(JSONMember hS (JSONNumber h)), (JSONMember wS (JSONNumber w))]

+ twentefp-eventloop-graphics.cabal view

@@ -0,0 +1,44 @@+name:                twentefp-eventloop-graphics
+version:             0.1.0.0
+synopsis:            An eventloop based graphical IO system. Used as Lab Assignments Environment at Univeriteit Twente
+description:         An eventloop based graphical IO system. It uses websockets as a way to communicate with IO devices; a browser in this case. This system is used in the Graphical submodule to be able to express graphical output using the eventloop system for a browser. 
+license:             BSD3
+license-file:        LICENSE
+author:              Sebastiaan la Fleur
+maintainer:          sebastiaan.la.fleur@gmail.com
+-- copyright:           
+category:            Graphics, Education
+build-type:          Simple
+cabal-version:       >=1.8
+
+library
+  exposed-modules:
+    EventLoop, 
+    EventLoop.Output, 
+    EventLoop.Input,
+    EventLoop.Output.Graphical,
+    EventLoop.Output.Single,
+    EventLoop.CommonTypes
+    
+  other-modules:
+    EventLoop.Main, 
+    EventLoop.Json, 
+    EventLoop.EventProcessor, 
+    EventLoop.Config, 
+    EventLoop.Output.SystemMessage, 
+    EventLoop.Output.OutputEvent, 
+    EventLoop.Output.Graphical.Graphical, 
+    EventLoop.Input.SystemMessage, 
+    EventLoop.Input.Mouse, 
+    EventLoop.Input.Keyboard, 
+    EventLoop.Input.InputEvent
+    
+  build-depends:
+    base                >= 4.6.0.1   && < 5, 
+    twentefp-websockets >= 0.1.0.0,
+    twentefp-number     >= 0.1.0.0,
+    text                >= 0.11.3.1,
+    network             >= 2.3       && < 2.6
+    
+  hs-source-dirs:
+    src