diff --git a/src/EventLoop/CommonTypes.hs b/src/EventLoop/CommonTypes.hs --- a/src/EventLoop/CommonTypes.hs +++ b/src/EventLoop/CommonTypes.hs @@ -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] diff --git a/src/EventLoop/EventProcessor.hs b/src/EventLoop/EventProcessor.hs --- a/src/EventLoop/EventProcessor.hs +++ b/src/EventLoop/EventProcessor.hs @@ -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 diff --git a/src/EventLoop/Input/Mouse.hs b/src/EventLoop/Input/Mouse.hs --- a/src/EventLoop/Input/Mouse.hs +++ b/src/EventLoop/Input/Mouse.hs @@ -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 diff --git a/src/EventLoop/Json.hs b/src/EventLoop/Json.hs --- a/src/EventLoop/Json.hs +++ b/src/EventLoop/Json.hs @@ -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) diff --git a/src/EventLoop/Output/Graphical/Graphical.hs b/src/EventLoop/Output/Graphical/Graphical.hs --- a/src/EventLoop/Output/Graphical/Graphical.hs +++ b/src/EventLoop/Output/Graphical/Graphical.hs @@ -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))] diff --git a/src/EventLoop/Output/Single.hs b/src/EventLoop/Output/Single.hs --- a/src/EventLoop/Output/Single.hs +++ b/src/EventLoop/Output/Single.hs @@ -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) diff --git a/src/EventLoop/Output/SystemMessage.hs b/src/EventLoop/Output/SystemMessage.hs --- a/src/EventLoop/Output/SystemMessage.hs +++ b/src/EventLoop/Output/SystemMessage.hs @@ -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))] diff --git a/src/FPPrac/Graphics/MakePrimitives.hs b/src/FPPrac/Graphics/MakePrimitives.hs new file mode 100644 --- /dev/null +++ b/src/FPPrac/Graphics/MakePrimitives.hs @@ -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 diff --git a/src/FPPrac/Graphics/NormalizeNumber.hs b/src/FPPrac/Graphics/NormalizeNumber.hs new file mode 100644 --- /dev/null +++ b/src/FPPrac/Graphics/NormalizeNumber.hs @@ -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 diff --git a/twentefp-eventloop-graphics.cabal b/twentefp-eventloop-graphics.cabal --- a/twentefp-eventloop-graphics.cabal +++ b/twentefp-eventloop-graphics.cabal @@ -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