twentefp-eventloop-graphics 0.1.0.0 → 0.1.0.1

raw patch · 10 files changed

+196/−111 lines, 10 filesdep ~twentefp-numberdep ~twentefp-websocketsPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: twentefp-number, twentefp-websockets

API changes (from Hackage documentation)

Files

• src/EventLoop/CommonTypes.hs +7/−7
• src/EventLoop/EventProcessor.hs +19/−41
• src/EventLoop/Input/Mouse.hs +2/−2
• src/EventLoop/Json.hs +11/−6
• src/EventLoop/Output/Graphical/Graphical.hs +24/−24
• src/EventLoop/Output/Single.hs +41/−25
• src/EventLoop/Output/SystemMessage.hs +1/−1
• src/FPPrac/Graphics/MakePrimitives.hs +59/−0
• src/FPPrac/Graphics/NormalizeNumber.hs +25/−0
• twentefp-eventloop-graphics.cabal +7/−5

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

@@ -1,7 +1,6 @@ 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)
@@ -10,54 +9,33 @@ 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"
+eventloop eh beginState = WS.server ipadres (fromIntegral port) $ doEvents eh beginState 
 
 -- Event Loop
-doEvents :: (a -> IOMessage -> ([IOMessage], a)) -> a -> WS.Connection -> IO ()
-doEvents eh state conn = do
-                    request <- readRequest conn
+doEvents :: (a -> IOMessage -> ([IOMessage], a)) -> a -> WS.Connection -> WS.StdOutMutex -> WS.ConnectionSendMutex -> IO ()
+doEvents eh state conn stdoutM connSendM = do
+                    request <- readRequest conn stdoutM
                     let
                         (resp, state') = eh state request 
-                        sendActions = map (sendResponse conn)  resp
+                        sendActions = map (sendResponse connSendM conn stdoutM)  resp
                     sequence sendActions
-                    doEvents eh state' conn
+                    doEvents eh state' conn stdoutM connSendM
                 
-readRequest :: WS.Connection -> IO IOMessage                
-readRequest conn = do
-                    msg <- WS.receiveData conn
-                    let
-                        string = T.unpack msg
-                        request = stringToJsonObject string
-                    return request
+readRequest :: WS.Connection -> WS.StdOutMutex -> IO IOMessage                
+readRequest conn stdoutM = do
+                            msg <- WS.receiveData conn :: IO T.Text
+                            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                      +sendResponse :: WS.ConnectionSendMutex -> WS.Connection -> WS.StdOutMutex -> IOMessage -> IO ()
+sendResponse mu conn stdoutM response = do
+                                        let
+                                            string = show response
+                                            text = T.pack string
+                                        WS.safeSendText mu conn text                      

@@ -29,8 +29,8 @@                                     | mouseType == mousedownS  = MouseDown button pos element
                                     where
                                         JSONString mouseType = retrieveError mousetypeS ms
-                                        JSONNumber x = retrieveError xS ms
-                                        JSONNumber y = retrieveError yS ms
+                                        JSONFloat x = retrieveError xS ms
+                                        JSONFloat y = retrieveError yS ms
                                         pos = (x, y)
                                         JSONString element = retrieveError elementS ms
                                         jsonButton = retrieveError buttonS ms

@@ -5,7 +5,7 @@ 
 data JSONMember = JSONMember [Char] JSONMessage
 
-data JSONMessage = JSONNumber Number
+data JSONMessage = JSONFloat Float
                 | JSONString [Char]
                 | JSONBool Bool
                 | JSONObject [JSONMember]
@@ -26,9 +26,9 @@     fromJsonMessage :: JSONMessage -> a
     
 instance Show JSONMessage where    
-    show (JSONNumber n)      = show n
-    show (JSONString s)      = "\"" ++ s ++ "\""
-    show (JSONBool bool)     | bool        = "true"
+    show (JSONFloat f)       = show f
+    show (JSONString s)      = "\"" ++ escapeStringJson s ++ "\""
+    show (JSONBool bool)     | bool      = "true"
                              | otherwise = "false"
     show (JSONObject (r:rs)) = "{" ++ rows ++ "}"
                                     where
@@ -44,7 +44,12 @@ instance Show JSONMember where
     show (JSONMember name m) = "\"" ++ name ++ "\": " ++ (show m)
 
-
+escapeStringJson :: [Char] -> [Char]
+escapeStringJson [] = ""
+escapeStringJson (c:cs) | c == '"' || c == '\'' || c == '\\' = '\\':c:rest
+                        | otherwise = c:rest
+                        where
+                            rest = escapeStringJson cs
 
 
 class JSONAble a where
@@ -95,7 +100,7 @@ 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))
+                            | isDigit c1 = (r2, JSONFloat (read number))
                             | otherwise = error (errorMsg "\"" [c1])
                             where
                                 (r1, word)   = parseWord (c2:cs)

@@ -17,7 +17,7 @@ -- Options
 type Name = [Char]
 type Groupname = [Char]
-type Color = (Number, Number, Number) -- (r, g, b)
+type Color = (Float, Float, Float) -- (r, g, b)
 type Font = [Char]
 type Relative = Bool -- Move relative to old spot or not
 
@@ -70,31 +70,31 @@                         
 -- Primitive graphical structures                        
 data Primitive = Text    { edgeColor :: Color
-                        , edgeThickness :: Number
+                        , edgeThickness :: Float
                         , color :: Color
                         , position :: Pos
-                        , size :: Number
+                        , size :: Float
                         , font :: Font
                         , text :: [Char]
                         , fromCenter :: Bool
                         }
                 | Line     { edgeColor :: Color
-                        , edgeThickness :: Number
+                        , edgeThickness :: Float
                         , positions :: [Pos]
                         }
                 | Rect    { edgeColor :: Color
-                        , edgeThickness :: Number
+                        , edgeThickness :: Float
                         , color :: Color
                         , position :: Pos -- Topleft corner
                         , dimensions :: Dimension
                         }
                 | Arc     { edgeColor :: Color
-                        , edgeThickness :: Number
+                        , edgeThickness :: Float
                         , color :: Color
                         , position :: Pos
-                        , radius :: Number
-                        , startAng :: Number -- In degrees
-                        , endAng :: Number -- In degrees
+                        , radius :: Float
+                        , startAng :: Float -- In degrees
+                        , endAng :: Float -- In degrees
                         }
                     deriving (Show, Eq)
 
@@ -102,45 +102,45 @@ 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 edgethicknessS  (JSONFloat et)), 
                                                                                       (JSONMember colorS          (colorToJsonMessage color)), 
                                                                                       (JSONMember positionS       (positionToJsonMessage position)), 
-                                                                                      (JSONMember sizeS           (JSONNumber size)), 
+                                                                                      (JSONMember sizeS           (JSONFloat 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 edgethicknessS  (JSONFloat 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 edgethicknessS  (JSONFloat 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 edgethicknessS (JSONFloat et)), 
                                                                                   (JSONMember colorS         (colorToJsonMessage color)), 
                                                                                   (JSONMember positionS      (positionToJsonMessage position)), 
-                                                                                  (JSONMember radiusS        (JSONNumber radius)), 
-                                                                                  (JSONMember startangS      (JSONNumber startAng)), 
-                                                                                  (JSONMember endangS        (JSONNumber endAng))]
+                                                                                  (JSONMember radiusS        (JSONFloat radius)), 
+                                                                                  (JSONMember startangS      (JSONFloat startAng)), 
+                                                                                  (JSONMember endangS        (JSONFloat endAng))]
 
 -- Support Functions                                                                                
 colorToJsonMessage :: Color -> JSONMessage
-colorToJsonMessage (r, g, b) = JSONObject [(JSONMember rS (JSONNumber r)), 
-                                           (JSONMember gS (JSONNumber g)), 
-                                           (JSONMember bS (JSONNumber b))]
+colorToJsonMessage (r, g, b) = JSONObject [(JSONMember rS (JSONFloat r)), 
+                                           (JSONMember gS (JSONFloat g)), 
+                                           (JSONMember bS (JSONFloat b))]
 
 positionToJsonMessage :: Pos -> JSONMessage
-positionToJsonMessage (x, y) = JSONObject [(JSONMember xS (JSONNumber x)), 
-                                           (JSONMember yS (JSONNumber y))] 
+positionToJsonMessage (x, y) = JSONObject [(JSONMember xS (JSONFloat x)), 
+                                           (JSONMember yS (JSONFloat y))] 
 
 dimensionToJsonMessage :: Dimension -> JSONMessage                                           
-dimensionToJsonMessage (h, w) = JSONObject [(JSONMember heightS (JSONNumber h)), 
-                                            (JSONMember widthS  (JSONNumber w))]
+dimensionToJsonMessage (w, h) = JSONObject [(JSONMember heightS (JSONFloat h)), 
+                                            (JSONMember widthS  (JSONFloat w))]

@@ -3,8 +3,9 @@ import qualified Network.Socket     as S
 import qualified Network.WebSockets as WS
 import qualified Data.Text          as T
+import Control.Exception (catch, SomeException, throw)
 
-import EventLoop.EventProcessor (sendResponse, IOMessage)
+import EventLoop.EventProcessor (IOMessage)
 import EventLoop.Output.OutputEvent
 import EventLoop.Output.Graphical
 import EventLoop.Output.SystemMessage
@@ -17,17 +18,26 @@                                     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 ()
+                                    let
+                                        close = catched sock conn
+                                        func  = do
+                                                    sendResponse conn setup
+                                                    sendResponse conn out'
+                                                    sendResponse conn closeMsg
+                                                    WS.sendClose conn (T.pack "")
+                                                    WS.closeSocket sock
+                                    catch func close
                 where
                     setup = toIOMessage (setupMessage out)
                     out' = toIOMessage out 
-                    close = toIOMessage closeMessage
-    
+                    closeMsg = toIOMessage closeMessage
+ 
+catched :: S.Socket -> WS.Connection -> SomeException -> IO ()
+catched sock conn e = do
+                        WS.sendClose conn (T.pack "")
+                        WS.closeSocket sock
+                        throw e
+ 
 setupMessage :: OutputEvent -> OutputEvent
 setupMessage (OutGraphical (Draw g _)) = OutSysMessage [CanvasSetup dim]
                                     where
@@ -40,28 +50,34 @@ toIOMessage :: OutputEvent -> IOMessage
 toIOMessage = toJsonMessage
 
+sendResponse :: WS.Connection -> IOMessage -> IO ()
+sendResponse conn response = do
+                                let
+                                    string = show response
+                                    text = T.pack string
+                                WS.sendTextData conn text 
+
+
 maxDimensions :: GObject -> Dimension
 maxDimensions (GObject _ prim [])     = maxDimensionsPrim prim
-maxDimensions (GObject n prim (c:cs)) = (max h h', max w w')
+maxDimensions (GObject n prim (c:cs)) = (max w w', max h h')
                                         where
-                                            (h, w) = maxDimensions c
-                                            (h', w') = maxDimensions (GObject n prim cs)
+                                            (w, h) = maxDimensions c
+                                            (w', h') = maxDimensions (GObject n prim cs)
 maxDimensions (Container [])          = (0, 0)
-maxDimensions (Container (c:cs))      = (max h h', max w w')
+maxDimensions (Container (c:cs))      = (max w w', max h h')
                                         where
-                                            (h, w) = maxDimensions c
-                                            (h', w') = maxDimensions (Container cs)
+                                            (w, h) = maxDimensions c
+                                            (w', h') = 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 (Text _ _ _ (x, y) size _ str fromCenter) | fromCenter = (x + (fromIntegral $ length str * 10) / 2, y + size / 2)
+                                                            | otherwise  = (x + (fromIntegral $ length str * 10), y + size)
 maxDimensionsPrim (Line _ _ [])                             = (0, 0)                                                                    
-maxDimensionsPrim (Line _ _ [(x, y)])                       = (y, x)
-maxDimensionsPrim (Line ec et ((x, y):xs))                  = (max y y', max x x')
+maxDimensionsPrim (Line _ _ [(x, y)])                       = (x, y)
+maxDimensionsPrim (Line ec et ((x, y):xs))                  = (max x x', max y y')
                                                         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)
-    
-
-
+                                                            (x', y') = maxDimensionsPrim (Line ec et xs) 
+                                                            
+maxDimensionsPrim (Rect _ _ _ (x, y) (w, h))                = (x + w / 2, y + h / 2) 
+maxDimensionsPrim (Arc _ _ _ (x, y) r _ _)                  = (x + r, y + r)

@@ -16,4 +16,4 @@     
 -- Support Function
 dimensionToJsonMessage :: Dimension -> JSONMessage
-dimensionToJsonMessage (h, w) = JSONObject [(JSONMember hS (JSONNumber h)), (JSONMember wS (JSONNumber w))]+dimensionToJsonMessage (w, h) = JSONObject [(JSONMember hS (JSONFloat h)), (JSONMember wS (JSONFloat w))]

@@ -0,0 +1,59 @@+module FPPrac.Graphics.MakePrimitives where
+
+import EventLoop.Output
+import EventLoop.CommonTypes
+import FPPrac.Graphics.NormalizeNumber
+
+type NormalizedNum = Float
+type TextSize = NormalizedNum
+type Radius = NormalizedNum
+type Angle  = NormalizedNum
+
+createDrawCommand :: GObject -> String -> Graphical
+createDrawCommand g groupname = Draw g groupname
+
+createMoveGroupCommand :: String -> Pos -> Relative -> Graphical
+createMoveGroupCommand groupname pos rel = MoveGroup groupname pos rel
+
+createMoveElementCommand :: String -> Pos -> Relative -> Graphical
+createMoveElementCommand name pos rel = MoveElement name pos rel
+
+createRemoveGroupCommand :: String -> Graphical
+createRemoveGroupCommand groupname = RemoveGroup groupname
+
+createRemoveElementCommand :: String -> Graphical
+createRemoveElementCommand name = RemoveElement name
+
+
+createGraphicalObject :: String -> Primitive -> [GObject] -> GObject
+createGraphicalObject name prim children = GObject name prim children
+
+createGraphicalContainer :: [GObject] -> GObject
+createGraphicalContainer contents = Container contents
+
+
+createTextPrimitive :: Color -> Pos -> TextSize -> Font -> String -> Bool -> Primitive
+createTextPrimitive col pos size font str fromCenter = Text (0,0,0) 1 col pos size font str fromCenter
+
+createLinePrimitive :: Color -> [Pos] -> Primitive
+createLinePrimitive col positions = Line col 1 positions
+
+createRectPrimitive :: Color -> Pos -> Dimension -> Primitive
+createRectPrimitive col pos dim = Rect (0,0,0) 0 col pos dim
+
+createArcPrimitive :: Color -> Pos -> Radius -> Angle -> Angle -> Primitive
+createArcPrimitive col pos rad startAngle endAngle = Arc (0,0,0) 0 col pos rad startAngle endAngle
+
+-- (x,y)
+createPosition :: (NormalizeNumber x, NormalizeNumber y) => x -> y -> (NormalizedNum ,NormalizedNum)
+createPosition x y = (normalize x, normalize y)
+
+-- (w,h)
+createDimension :: (NormalizeNumber w, NormalizeNumber h) => w -> h -> (NormalizedNum, NormalizedNum)
+createDimension w h = (normalize w, normalize h)
+
+createColor :: (NormalizeNumber r, NormalizeNumber g, NormalizeNumber b) => r -> g -> b -> (NormalizedNum, NormalizedNum, NormalizedNum)
+createColor r g b = (normalize r, normalize g, normalize b)
+
+createNormalizedNum :: (NormalizeNumber i) => i -> NormalizedNum
+createNormalizedNum i = normalize i

@@ -0,0 +1,25 @@+module FPPrac.Graphics.NormalizeNumber where
+
+
+import GHC.Float
+import FPPrac.Prelude.Number
+
+class (Num a) => NormalizeNumber a where
+    normalize :: a -> Float
+    
+instance NormalizeNumber Float where
+    normalize f = f
+    
+instance NormalizeNumber Int where
+    normalize = fromIntegral
+    
+instance NormalizeNumber Integer where
+    normalize = fromIntegral
+
+
+instance NormalizeNumber Double where    
+    normalize = double2Float
+
+instance NormalizeNumber Number where
+    normalize (I i) = fromIntegral i
+    normalize (F d) = double2Float d   

@@ -1,5 +1,5 @@ name:                twentefp-eventloop-graphics
-version:             0.1.0.0
+version:             0.1.0.1
 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
@@ -18,7 +18,8 @@     EventLoop.Input,
     EventLoop.Output.Graphical,
     EventLoop.Output.Single,
-    EventLoop.CommonTypes
+    EventLoop.CommonTypes,
+    FPPrac.Graphics.MakePrimitives
     
   other-modules:
     EventLoop.Main, 
@@ -31,12 +32,13 @@     EventLoop.Input.SystemMessage, 
     EventLoop.Input.Mouse, 
     EventLoop.Input.Keyboard, 
-    EventLoop.Input.InputEvent
+    EventLoop.Input.InputEvent,
+    FPPrac.Graphics.NormalizeNumber
     
   build-depends:
     base                >= 4.6.0.1   && < 5, 
-    twentefp-websockets >= 0.1.0.0,
-    twentefp-number     >= 0.1.0.0,
+    twentefp-websockets >= 0.1.0.1,
+    twentefp-number     >= 0.1.0.2,
     text                >= 0.11.3.1,
     network             >= 2.3       && < 2.6