diff --git a/Blobs.cabal b/Blobs.cabal --- a/Blobs.cabal +++ b/Blobs.cabal @@ -1,5 +1,5 @@ Name: Blobs -Version: 0.1 +Version: 0.2 License: LGPL License-file: LICENCE-LGPL Author: Arjan van IJzendoorn, Martijn Schrage, Malcolm Wallace @@ -31,11 +31,43 @@ Blobs.icns, blobs.png, dazzle.jpg, index.html, patch.icons, simple.blobpalette, wiring.blobs +library + Build-Depends: base >= 4 && < 5, haskell98, wx >= 0.9, wxcore >= 0.9, HaXml >= 1.14 + , polyparse, directory, pretty, containers + Hs-Source-Dirs: src lib/DData + exposed-modules: Graphics.Blobs.Colors + , Graphics.Blobs.Common + , Graphics.Blobs.CommonIO + , Graphics.Blobs.Constants + , Graphics.Blobs.ContextMenu + , Graphics.Blobs.DisplayOptions + , Graphics.Blobs.Document + , Graphics.Blobs.GUIEvents + , Graphics.Blobs.InfoKind + , Graphics.Blobs.Math + , Graphics.Blobs.NetworkControl + , Graphics.Blobs.NetworkFile + , Graphics.Blobs.Network + , Graphics.Blobs.NetworkUI + , Graphics.Blobs.NetworkView + , Graphics.Blobs.Operations + , Graphics.Blobs.Palette + , Graphics.Blobs.PDDefaults + , Graphics.Blobs.PersistentDocument + , Graphics.Blobs.SafetyNet + , Graphics.Blobs.Shape + , Graphics.Blobs.State + , Graphics.Blobs.StateUtil + -- , Graphics.Blobs.XTC + -- other-modules: Graphics.Blobs + ghc-options: -Wall + executable blobs main-is: Main.hs Build-Depends: base >= 4 && < 5, haskell98, wx >= 0.9, wxcore >= 0.9, HaXml >= 1.14 , polyparse, directory, pretty, containers Hs-Source-Dirs: src lib/DData + ghc-options: -Wall source-repository head type: git diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -2,3 +2,9 @@ ===== Blobs from http://www.cs.york.ac.uk/fp/darcs/Blobs/ + +Changes + +0.2 Move the contents into the Graphics.Blobs namespace + +0.1 Initial import of original code, updated for GHC 7.0.4 diff --git a/src/Colors.hs b/src/Colors.hs deleted file mode 100644 --- a/src/Colors.hs +++ /dev/null @@ -1,86 +0,0 @@ -module Colors where - -import Graphics.UI.WX -import Text.Parse - - --- Different spelling of colour/color to distinguish local/wx datatypes. -data Colour = RGB !Int !Int !Int deriving (Eq,Show,Read) - - -instance Parse Colour where - parse = do { isWord "RGB" - ; return RGB `apply` parse `apply` parse `apply` parse - } - --- translate local to wx -wxcolor :: Colour -> Color -wxcolor (RGB r g b) = rgb r g b - -nodeColor, labelBackgroundColor, evidenceColor, evidenceHatchColor, - wrongProbabilitiesColor, paneBackgroundColor, activeSelectionColor, - inactiveSelectionColor :: Colour -nodeColor = lightBlue -evidenceColor = lightYellow -evidenceHatchColor = licorice -labelBackgroundColor = lightYellow -paneBackgroundColor = coconut -activeSelectionColor = licorice -inactiveSelectionColor = lightGrey -wrongProbabilitiesColor = lightRed - -testSelectionTestColor, testSelectionTargetColor :: Colour -testSelectionTestColor = RGB 0 255 0 -testSelectionTargetColor = RGB 255 0 0 - -lightYellow, lightBlue, lightRed, lightGrey, pink :: Colour -lightYellow = RGB 236 236 169 -lightBlue = RGB 200 255 255 -lightGrey = RGB 150 150 150 -lightRed = RGB 255 200 200 -pink = RGB 255 200 200 - -systemGrey :: Color -- wx type -systemGrey = colorSystem Color3DFace - -licorice, coconut :: Colour -- names black and white already taken by wx -licorice = RGB 0 0 0 -coconut = RGB 255 255 255 - -darkGreen, darkBlue, violet, indigo, darkRed, darkMagenta, darkOrange, - orange, lightPink, purple, lightGreen, mediumPurple, darkViolet, gray, - darkGrey, darkGray, lightGray, silver, whiteSmoke, aqua, teal, maroon, - olive, sienna, brown, fuchsia, turquoise, orangeRed, gold,darkSlateGray - :: Colour -darkGreen = RGB 0 100 0 -darkBlue = RGB 0 0 139 -violet = RGB 238 130 238 -indigo = RGB 75 0 130 -darkRed = RGB 139 0 0 -darkMagenta = RGB 139 0 139 -darkOrange = RGB 255 140 0 -orange = RGB 255 165 0 -lightPink = RGB 255 182 193 -purple = RGB 128 0 128 -lightGreen = RGB 144 238 144 -mediumPurple = RGB 147 112 219 -darkViolet = RGB 148 0 211 - -gray = RGB 128 128 128 -darkGrey = RGB 169 169 169 -- lighter than grey? -darkGray = RGB 169 169 169 -lightGray = RGB 211 211 211 -silver = RGB 192 192 192 -whiteSmoke = RGB 245 245 245 - -aqua = RGB 0 255 255 -teal = RGB 0 128 128 -maroon = RGB 128 0 0 -olive = RGB 128 128 0 -sienna = RGB 160 82 45 -brown = RGB 165 42 42 -fuchsia = RGB 255 0 255 -turquoise = RGB 64 224 208 -orangeRed = RGB 255 69 0 -gold = RGB 255 215 0 -darkSlateGray = RGB 47 79 79 diff --git a/src/Common.hs b/src/Common.hs deleted file mode 100644 --- a/src/Common.hs +++ /dev/null @@ -1,159 +0,0 @@ -module Common (module Common {-, module IOExts-}, module Colors) where - -import Colors --- import IOExts(trace) -import Debug.Trace (trace) -import qualified Data.IntMap as IntMap -import Char(isSpace) -import GHC.Float(formatRealFloat, FFFormat(FFFixed)) -import List - --- | return a list of all cartesian products for a list of lists --- e.g. products [[1,2],[3,4]] = [[1,3],[1,4],[2,3],[2,4]] -products :: [[a]] -> [[a]] -products [] = [[]] -products (xs:xss) = [ x:prod | x <- xs, prod <- products xss] - -trees :: Show a => String -> a -> a -trees msg a = trace ("{" ++ msg ++ ":" ++ show a ++ "}") a - -foreach :: Monad m => [a] -> (a -> m b) -> m [b] -foreach = flip mapM - -foreach_ :: Monad m => [a] -> (a -> m b) -> m () -foreach_ list fun = do - mapM fun list - return () - -ifJust :: Monad m => Maybe a -> (a -> m b) -> m () -ifJust ma f = - case ma of - Nothing -> return () - Just a -> do { f a; return () } - -internalError :: String -> String -> String -> a - -internalError moduleName functionName errorString = - error (moduleName ++ "." ++ functionName ++ ": " ++ errorString) - -parseDouble :: String -> Maybe Double -parseDouble string = - case reads (commasToDots . trim $ string) of - ((double, []):_) -> Just double - _ -> Nothing - where - commasToDots = map (\c -> if c == ',' then '.' else c) - -trim :: String -> String -trim = reverse . dropWhile isSpace . reverse . dropWhile isSpace - --- | A NumberMap maps integers to integers -type NumberMap = IntMap.IntMap Int - --- | A NumberMap can be inverted (keys become values and values become keys) -invertMap :: NumberMap -> NumberMap -invertMap theMap = - let list = IntMap.toList theMap - invertedList = map (\(x, y) -> (y, x)) list - in IntMap.fromList invertedList - --- | commasAnd combines a list of strings to one string by placing --- commas in between and the word "and" just before the last element -commasAnd :: [String] -> String -commasAnd [] = "" -commasAnd [x] = x -commasAnd [x, y] = x ++ " and " ++ y -commasAnd (x:xs) = x ++ ", " ++ commasAnd xs - - --- TODO: is niceFloat 2 0.0001 = "0.0" correct? (as opposed to "0.00") --- | niceFloat prints a floating-point value with maximum --- number of decimals -niceFloat :: Int -> Double -> String -niceFloat nrOfDigits f = - let s = formatRealFloat FFFixed (Just nrOfDigits) f - s' = reverse s -- s -- dropWhile (== '0') (reverse s) - s'' = if head s' == '.' then '0':s' else s' - in reverse s'' - --- | niceFloatFix prints a floating-point value with fixed --- number of decimals -niceFloatFix :: Int -> Double -> String -niceFloatFix nrOfDigits f = - let s = formatRealFloat FFFixed (Just nrOfDigits) f - in if head s == '.' then '0':s else s - --- Compute the average of a list of fractionals, with average [] equal to 0. -average :: Fractional a => [a] -> a -average [] = 0 -average xs = (sum xs) / fromIntegral (length xs) - --- | updateList changes the element at the given zero-based index in a list --- Example: updateList 2 "yes" ["no","maybe","often","always"] ==> --- ["no","maybe","yes","always"] -updateList :: Int -> a -> [a] -> [a] -updateList i x l = take i l ++ [x] ++ drop (i+1) l - --- | groups splits a list into groups of given length. The --- last group might be shorter. --- Example: groups 3 [1..10] ==> [[1,2,3],[4,5,6],[7,8,9],[10]] -groups :: Int -> [a] -> [[a]] -groups _ [] = [] -groups n xs = let (col, rest) = splitAt n xs - in col: groups n rest - -swap :: (a, b) -> (b, a) -swap (a, b) = (b, a) - --- remove the extension from a file name (or path). -removeExtension :: String -> String -removeExtension filename = - case break (=='.') $ reverse filename of - (_ , _ {- dot -}:properName) -> reverse properName - (_ , []) -> filename - -tabDelimited :: [[String]] -> String -tabDelimited = unlines . map (concat . intersperse "\t") - -singleton :: a -> [a] -singleton x = [x] - --- | a version of Prelude.lookup that fails when the element is not present in the assoc-list -unsafeLookup :: (Show k, Eq k) => k -> [(k,v)] -> v -unsafeLookup x assocs = - case lookup x assocs of - Just v -> v - Nothing -> internalError "Common" "unsafeLookup" ("element " ++ show x ++ " not in list.") - --- | a version of Prelude.elemIndex that fails when the element is not present in the list -unsafeElemIndex :: (Show a, Eq a) => a -> [a] -> Int -unsafeElemIndex x xs = - case elemIndex x xs of - Just i -> i - Nothing -> internalError "Common" "unsafeElemIndex" ("element " ++ show x ++ " not in list") - --- Approximately equals -(~=) :: Double -> Double -> Bool -(~=) d1 d2 = abs (d1 - d2) < 0.000001 - -fst3 :: (a, b, c) -> a -fst3 (a, _, _) = a - -snd3 :: (a, b, c) -> b -snd3 (_, b, _) = b - -thd3 :: (a, b, c) -> c -thd3 (_, _, c) = c - -safeIndex :: String -> [a] -> Int -> a -safeIndex msg xs i - | i >= 0 && i < length xs = xs !! i - | otherwise = internalError "Common" "safeIndex" msg - --- reorderList [0,2,1] "hoi" ==> "hio" -reorderList :: Show a => [Int] -> [a] -> [a] -reorderList order xs - | sort order /= [0..length xs-1] = - internalError "Common" "reorderList" ("order = " ++ show order ++ ", list = " ++ show xs) - | otherwise = - [ xs !! i | i <- order ] diff --git a/src/CommonIO.hs b/src/CommonIO.hs deleted file mode 100644 --- a/src/CommonIO.hs +++ /dev/null @@ -1,339 +0,0 @@ -module CommonIO where - -import Math -import Common(ifJust, internalError, tabDelimited, safeIndex, systemGrey) -import SafetyNet - -import Graphics.UI.WX -import Graphics.UI.WXCore -import List(elemIndex) -import System.Directory -import System.IO - -ignoreResult :: IO a -> IO () -ignoreResult action = do { action; return () } - --- | Writes file to disk. If writing fails, an error --- dialog is shown and False is returned -safeWriteFile :: Window a -> String -> String -> IO Bool -safeWriteFile parentWindow fileName contents = - do{ let tmpName = fileName ++ ".tmp" - - ; -- try to write to .tmp file - ; writeOkay <- - catch - (do { writeFile tmpName contents - ; return True - }) - (\ioExc -> - do{ errorDialog parentWindow "Save failed" - ( "Saving " ++ fileName ++ " failed.\n\n" - ++ "Technical reason: " ++ show ioExc ++ "\n\n" - ++ "Tip: do you have write permissions and enough disk space?" - ) - ; return False - } - ) - ; if not writeOkay then - return False - else - do{ -- remove old file if it exists and then rename .tmp to the real name - ; catch (do { exists <- doesFileExist fileName - ; when exists $ removeFile fileName - ; renameFile tmpName fileName - ; return True - }) - (\ioExc -> - do{ errorDialog parentWindow "Save failed" - ( "The file has been saved to " ++ show tmpName ++ "\nbut " - ++ "renaming it to " ++ show fileName ++ " failed.\n\n" - ++ "Technical reason: " ++ show ioExc - ) - ; return False - } - ) - }} - -strictReadFile :: String -> IO String -strictReadFile fname = - do{ contents <- readFile fname - ; seq (length contents) $ return contents -- force reading of entire file - } - -data TextCtrlSize = SingleLine | MultiLine - -myTextDialog :: Window a -> TextCtrlSize -> String -> String -> Bool - -> IO (Maybe String) -myTextDialog parentWindow size dialogTitle initial selectAll = - do{ d <- dialog parentWindow [text := dialogTitle] - ; textInput <- (case size of SingleLine -> textEntry; - MultiLine -> textCtrl) - d [ alignment := AlignLeft, text := initial ] - ; ok <- button d [text := "Ok"] - ; can <- button d [text := "Cancel", identity := wxID_CANCEL] - ; buttonSetDefault ok - ; set d [layout := column 5 [ fill $ widget textInput - , floatBottomRight $ row 5 [widget ok, widget can] - ] - -- ,clientSize := case size of SingleLine -> sz 300 40 - -- MultiLine -> sz 500 200 - ,area := case size of SingleLine -> rect (pt 50 50) (sz 300 80) - MultiLine -> rect (pt 50 50) (sz 500 250) - ] - ; when (selectAll) $ do textCtrlSetSelection textInput 0 250 - ; when (not selectAll) $ do textCtrlSetInsertionPointEnd textInput - set d [ visible := True ] - ; showModal d $ \stop -> - do set ok [on command := safetyNet parentWindow $ - do theText <- get textInput text - stop (Just theText)] - set can [on command := safetyNet parentWindow $ stop Nothing] - } - --- Dialog for selecting a multiple Strings (0 or more) --- Returns Nothing if Cancel was pressed, otherwise it returns the selected strings -multiSelectionDialog :: Window a -> String -> [String] -> [String] - -> IO (Maybe [String]) -multiSelectionDialog parentWindow dialogTitle strings initialSelection = - do{ d <- dialog parentWindow - [ text := dialogTitle - , resizeable := True - ] - ; p <- panel d [] - ; theListBox <- multiListBox p - [ items := strings - , selections := - [ case maybeIndex of - Nothing -> internalError "CommonIO" "multiSelectionDialog" - ( "initial selection " ++ show s - ++ " can not be found in " ++ show strings ) - Just i -> i - | s <- initialSelection - , let maybeIndex = elemIndex s strings - ] - ] - ; selectAll <- button p - [ text := "Select all" - , on command := safetyNet parentWindow $ set theListBox [ selections := take (length strings) [0..] ] - ] - ; selectNone <- button p - [ text := "Select none" - , on command := safetyNet parentWindow $ set theListBox [ selections := [] ] - ] - ; ok <- button p [text := "Ok"] - ; can <- button p [text := "Cancel", identity := wxID_CANCEL] - ; buttonSetDefault ok - ; set d [ layout := container p $ - column 10 [ vfill $ widget theListBox - , row 5 [widget selectAll, widget selectNone, widget ok, widget can] - ] - , clientSize := sz 300 400 - ] - ; showModal d $ \stop -> - do set ok [on command := safetyNet parentWindow $ - do indices <- get theListBox selections - stop (Just (map (safeIndex "CommonIO.multiSelectionDialog" strings) indices))] - set can [on command := safetyNet parentWindow $ - stop Nothing] - } - --- Dialog for selecting a single String --- Returns Nothing if Cancel was pressed, otherwise it returns the selected string -singleSelectionDialog :: Window a -> String -> [String] -> (Maybe String) - -> IO (Maybe String) -singleSelectionDialog _ _ [] _ = - internalError "CommonIO" "singleSelectionDialog" "no strings" -singleSelectionDialog parentWindow dialogTitle strings initialSelection = - do{ d <- dialog parentWindow [ text := dialogTitle, resizeable := True ] - ; p <- panel d [] - ; theListBox <- singleListBox p [ items := strings, selection := 0] - ; ifJust initialSelection $ \selString -> - case elemIndex selString strings of - Nothing -> internalError "CommonIO" "singleSelectionDialog" - ( "initial selection " ++ show selString - ++ " can not be found in " ++ show strings ) - Just i -> set theListBox [ selection := i ] - ; ok <- button p [text := "Ok"] - ; can <- button p [text := "Cancel", identity := wxID_CANCEL] - ; buttonSetDefault ok - ; set d [ layout := container p $ - column 10 [ vfill $ widget theListBox - , row 5 [widget ok, widget can] - ] - , clientSize := sz 300 400 - ] - ; showModal d $ \stop -> - do set ok [on command := safetyNet parentWindow $ - do index <- get theListBox selection - stop (Just (safeIndex "CommonIO.singleSelectionDialog" strings index))] - set can [on command := safetyNet parentWindow $ - stop Nothing] - } - --- | Fill a grid from a list of lists of texts. Each list inside the --- big list represents a row. Also set the given number or rows and --- columns to be header: grey background and not editable. --- This function assumes that the normal spreadsheet-like grid header row --- and column have been made invisible. -fillGridFromList :: Grid () -> Int -> Int -> [[String]] -> IO () -fillGridFromList _ _ _ [] = return () -fillGridFromList theGrid nrHeaderRows nrHeaderCols list = - do{ nrOfCols <- gridGetNumberCols theGrid - ; nrOfRows <- gridGetNumberRows theGrid - ; when (length list > nrOfRows || maximum (map length list) > nrOfCols) $ - internalError "Common" "fillGridFromList" "grid is not big enough" - ; sequence_ . concat $ - [ [ do{ gridSetCellValue theGrid rowNr colNr txt - ; let isHeaderCell = rowNr < nrHeaderRows || colNr < nrHeaderCols - ; gridSetCellBackgroundColour theGrid rowNr colNr - (if isHeaderCell then systemGrey else white) - ; gridSetReadOnly theGrid rowNr colNr isHeaderCell - } - | (txt, colNr) <- zip theRow [0..] - ] - | (theRow, rowNr) <- zip list [0..] - ] - } - --- | Export some data (a list of lists of strings) to a tab delimited --- file. The user is asked to choose a location -exportToTabFile :: Window a -> String -> String -> [[String]] -> IO () -exportToTabFile parentWindow description fileName theData = - do { mFilename <- fileSaveDialog - parentWindow - False -- remember current directory - True -- overwrite prompt - ("Export " ++ description) - [("Tab delimited files",["*.txt"])] - "" -- directory - fileName - ; ifJust mFilename $ \filename -> - ignoreResult (safeWriteFile parentWindow filename (tabDelimited theData)) - } - -getScreenPPI :: IO Size -getScreenPPI = - do{ dc <- screenDCCreate - ; s <- dcGetPPI dc - ; screenDCDelete dc - ; return s - } - -screenToLogicalPoint :: Size -> Point -> DoublePoint -screenToLogicalPoint ppi p = - DoublePoint (screenToLogicalX ppi (pointX p)) - (screenToLogicalY ppi (pointY p)) - -logicalToScreenPoint :: Size -> DoublePoint -> Point -logicalToScreenPoint ppi doublePoint = - pt (logicalToScreenX ppi (doublePointX doublePoint)) - (logicalToScreenY ppi (doublePointY doublePoint)) - -screenToLogicalX :: Size -> Int -> Double -screenToLogicalX ppi x = - fromIntegral x / (fromIntegral (sizeW ppi) / 2.54) - -logicalToScreenX :: Size -> Double -> Int -logicalToScreenX ppi x = - truncate (x * fromIntegral (sizeW ppi) / 2.54) - -screenToLogicalY :: Size -> Int -> Double -screenToLogicalY ppi y = - fromIntegral y / (fromIntegral (sizeH ppi) / 2.54) - -logicalToScreenY :: Size -> Double -> Int -logicalToScreenY ppi y = - truncate (y * fromIntegral (sizeH ppi) / 2.54) - --- Create a grid of which the standard labels (A,B,C... for columns --- and 1,2,3... for rows) are invisible -mkNoLabelGrid :: Window a -> Int -> Int -> IO (Grid ()) -mkNoLabelGrid thePanel nrOfRows nrOfCols = - do{ theGrid <- gridCreate thePanel idAny rectNull 0 - ; gridCreateGrid theGrid nrOfRows nrOfCols 0 - ; gridSetColLabelSize theGrid 0 - ; gridSetRowLabelSize theGrid 0 - ; return theGrid - } - -resizeGrid :: Grid () -> Int -> Int -> IO () -resizeGrid theGrid nrOfRows nrOfCols = - do{ oldNrOfRows <- gridGetNumberRows theGrid - ; oldNrOfCols <- gridGetNumberCols theGrid - ; when (nrOfRows > oldNrOfRows) . ignoreResult $ - gridAppendRows theGrid (nrOfRows - oldNrOfRows) False - ; when (nrOfRows < oldNrOfRows) . ignoreResult $ - gridDeleteRows theGrid nrOfRows (oldNrOfRows - nrOfRows) False - ; when (nrOfCols > oldNrOfCols) . ignoreResult $ - gridAppendCols theGrid (nrOfCols - oldNrOfCols) False - ; when (nrOfCols < oldNrOfCols) . ignoreResult $ - gridDeleteCols theGrid nrOfCols (oldNrOfCols - nrOfCols) False - } - --- | Get the position of a frame, if the frame is minimized or maximized --- it is restored to its normal size first. Otherwise, you get --- (-32000, -32000) for a minimized window :-) -safeGetPosition :: Frame a -> IO (Int, Int) -safeGetPosition f = - do{ -- isMax <- frameIsMaximized f - isMax <- frameIsFullScreen f - -- ; isMin <- frameIsIconized f - -- ; when (isMax || isMin) $ frameRestore f - ; when (isMax) $ frameRestore f - ; p <- get f position - ; return (pointX p, pointY p) - } - --- Show a dialog with a grid and a save button -gridDialogWithSave :: Window a -> String -> Maybe String -> [[String]] - -> IO () -> IO () -gridDialogWithSave parentWindow title maybeNote matrixContents saveAction = - do{ - -- Create dialog and panel - ; theDialog <- dialog parentWindow - [ text := title - , resizeable := True - ] - ; p <- panel theDialog [] - - -- Create and fill grid - ; theGrid <- mkNoLabelGrid p height width - ; gridEnableEditing theGrid False - ; fillGridFromList theGrid 0 0 matrixContents - ; gridAutoSizeColumns theGrid False - - -- File menu - ; saveButton <- button p - [ text := "Save as..." - , on command := safetyNet parentWindow $ saveAction - ] - - -- Dialog layout - ; set theDialog - [ layout := minsize (sz 600 400) $ column 5 - ( case maybeNote of - Just note -> [ hfill $ label note ] - Nothing -> [] - ++ [ container p $ - column 5 [ fill $ widget theGrid - , row 0 [ widget saveButton, glue ] - ] - ] - ) - , visible := True - ] - } - where - width = maximum . map length $ matrixContents - height = length matrixContents - - --- | Using bootstrapUI, a record containing all widgets and variables can be created --- at the end of the create function, but still referred to before creation --- NOTE: widgets should not be referred to in a strict way because this will --- cause a loop -bootstrapUI :: (uistate -> IO uistate) -> IO () -bootstrapUI fIO = - do { fixIO fIO - ; return () - } diff --git a/src/Constants.hs b/src/Constants.hs deleted file mode 100644 --- a/src/Constants.hs +++ /dev/null @@ -1,26 +0,0 @@ -module Constants where - -import Graphics.UI.WX -import Colors - -kSELECTED_WIDTH :: Int -kSELECTED_WIDTH = 3 - -kEDGE_CLICK_RANGE, kNODE_RADIUS, kARROW_SIZE:: Double -kEDGE_CLICK_RANGE = 0.2 -kNODE_RADIUS = 0.5 -kARROW_SIZE = 0.3 - -kSELECTED_OPTIONS :: [Prop (DC ())] -kSELECTED_OPTIONS = [ penWidth := kSELECTED_WIDTH ] - -kNodeLabelColour :: Colour -kNodeLabelColour = licorice - -kNodeInfoColour :: Colour -kNodeInfoColour = darkViolet - -kEdgeInfoColour :: Colour -kEdgeInfoColour = orangeRed - - diff --git a/src/ContextMenu.hs b/src/ContextMenu.hs deleted file mode 100644 --- a/src/ContextMenu.hs +++ /dev/null @@ -1,186 +0,0 @@ -module ContextMenu - ( canvas, edge, node, via ) where - -import State -import Network -import Document -import NetworkControl -import SafetyNet -import CommonIO -import Math (DoublePoint) -import qualified PersistentDocument as PD -import Palette -import InfoKind -import Text.Parse - -import Graphics.UI.WX -import Graphics.UI.WXCore(windowGetMousePosition) - --- | Context menu for empty area of canvas -canvas :: (InfoKind n g, Show g, Parse g, Descriptor g) => - Frame () -> State g n e -> IO () -canvas theFrame state = - do{ contextMenu <- menuPane [] - ; menuItem contextMenu - [ text := "Add node (shift-click)" - , on command := safetyNet theFrame $ addNodeItem theFrame state - ] - ; g <- fmap (getGlobalInfo . getNetwork) - (PD.getDocument =<< getDocument state) - ; menuItem contextMenu - [ text := ("Edit "++descriptor g) - , on command := safetyNet theFrame $ changeGlobalInfo theFrame state - ] - - ; pointWithinWindow <- windowGetMousePosition theFrame - ; menuPopup contextMenu pointWithinWindow theFrame - ; objectDelete contextMenu - } - -addNodeItem :: (InfoKind n g) => Frame () -> State g n e -> IO () -addNodeItem theFrame state = - do{ mousePoint <- windowGetMousePosition theFrame - ; ppi <- getScreenPPI - ; let doubleMousePoint = screenToLogicalPoint ppi mousePoint - ; createNode doubleMousePoint state - } - --- | Context menu for an edge -edge :: (InfoKind n g, InfoKind e g) => - EdgeNr -> Frame () -> DoublePoint -> State g n e -> IO () -edge edgeNr theFrame mousepoint state = - do{ contextMenu <- menuPane [] - - ; pDoc <- getDocument state - ; doc <- PD.getDocument pDoc - ; let network = getNetwork doc - theEdge = getEdge edgeNr network - fromPort = getEdgeFromPort theEdge - toPort = getEdgeToPort theEdge - - ; menuItem contextMenu - [ text := "Add control point" - , on command := safetyNet theFrame $ createVia mousepoint state - ] - ; menuItem contextMenu - [ text := "Delete edge (Del)" - , on command := safetyNet theFrame $ deleteSelection state - ] - ; menuItem contextMenu - [ text := "Edit info (i)" - , on command := safetyNet theFrame $ reinfoNodeOrEdge theFrame state - ] - ; menuLine contextMenu - ; menuItem contextMenu - [ text := "from port "++show fromPort - ] - ; menuItem contextMenu - [ text := "to port "++show toPort - ] - ; pointWithinWindow <- windowGetMousePosition theFrame - ; menuPopup contextMenu pointWithinWindow theFrame - ; objectDelete contextMenu - } - --- | Context menu for a 'via' point -via :: Frame () -> State g n e -> IO () -via theFrame state = - do{ contextMenu <- menuPane [] - ; menuItem contextMenu - [ text := "Delete control point (Del)" - , on command := safetyNet theFrame $ deleteSelection state - ] - ; pointWithinWindow <- windowGetMousePosition theFrame - ; menuPopup contextMenu pointWithinWindow theFrame - ; objectDelete contextMenu - } - --- | Context menu for a node -node :: (InfoKind n g, InfoKind e g) => Int -> Frame () -> State g n e -> IO () -node nodeNr theFrame state = - do{ contextMenu <- menuPane [] - - ; pDoc <- getDocument state - ; doc <- PD.getDocument pDoc - ; let network = getNetwork doc - theNode = getNode nodeNr network - labelAbove = getNameAbove theNode - palette = getPalette network - theShape = getShape theNode - theInfo = getInfo theNode - (i,o) = maybe (0,0) id $ getArity theNode - - ; menuItem contextMenu - [ text := "Rename (r)" - , on command := safetyNet theFrame $ renameNode theFrame state - ] - ; menuItem contextMenu - [ text := "Edit info (i)" - , on command := safetyNet theFrame $ reinfoNodeOrEdge theFrame state - ] - ; menuItem contextMenu - [ text := "Change arity (in/"++show i++", out/"++show o++")" - , on command := safetyNet theFrame $ reArityNode theFrame state - ] - ; menuItem contextMenu - [ text := "Delete (Del)" - , on command := safetyNet theFrame $ deleteSelection state - ] - ; menuLine contextMenu - - ; menuItem contextMenu - [ text := "Label position:" ] - ; menuItem contextMenu - [ text := " above (up arrow)" - , checkable := True - , checked := labelAbove - , on command := safetyNet theFrame $ changeNamePosition True state - ] - ; menuItem contextMenu - [ text := " below (down arrow)" - , checkable := True - , checked := not labelAbove - , on command := safetyNet theFrame $ changeNamePosition False state - ] --- ; set (if labelAbove then aboveItem else belowItem) [ checked := True ] - - ; menuLine contextMenu - - -- work out whether to keep the info-field whilst changing shape - -- (change if shape's default; keep if different i.e. user has changed it) - ; let keepInfo = case theShape of - Left n -> case lookup n (shapes palette) of - Nothing -> const theInfo - Just (_,Nothing) -> const theInfo - Just (_,Just i) -> if i==theInfo then id - else const theInfo - Right _ -> const theInfo - ; menuItem contextMenu - [ text := "Shape:" ] - ; mapM_ (shapeItem theShape keepInfo contextMenu) (shapes palette) - ; otherShape theShape contextMenu - - ; pointWithinWindow <- windowGetMousePosition theFrame - ; menuPopup contextMenu pointWithinWindow theFrame - ; objectDelete contextMenu - - } - where - shapeItem curShape keepInfo contextMenu (name,(_shape,info)) = - menuItem contextMenu - [ text := (" "++name) - , checkable := True - , checked := case curShape of { Left n -> n==name; Right _ -> False; } - , on command := safetyNet theFrame $ changeNodeShape name newinfo state - ] - where newinfo = keepInfo (maybe blank id info) - otherShape curShape contextMenu = - case curShape of - Left _ -> return () - Right _ -> do{ menuItem contextMenu - [ text := "Other shape" - , checkable := True - , checked := True - ] - ; return () - } diff --git a/src/DisplayOptions.hs b/src/DisplayOptions.hs deleted file mode 100644 --- a/src/DisplayOptions.hs +++ /dev/null @@ -1,16 +0,0 @@ -module DisplayOptions where - -import List ((\\)) - -type ShowInfo = [What] -data What = GlobalInfo | NodeLabel | NodeInfo | EdgeInfo deriving (Eq) - -data DisplayOptions = DP - { dpShowInfo :: ShowInfo - } - -standard :: DisplayOptions -standard = DP [GlobalInfo, NodeLabel, NodeInfo, EdgeInfo] - -toggle :: What -> DisplayOptions -> DisplayOptions -toggle w (DP opts) = DP (if w `elem` opts then opts\\[w] else w:opts) diff --git a/src/Document.hs b/src/Document.hs deleted file mode 100644 --- a/src/Document.hs +++ /dev/null @@ -1,94 +0,0 @@ -{-| Module : Document - Maintainer : afie@cs.uu.nl - - This module contains functions to create documents - and to get and set components of the Document datatype. --} - -module Document - ( Document - , Selection(..) - , empty - , getNetwork, setNetwork, unsafeSetNetwork - , getSelection, setSelection - - , updateNetwork, updateNetworkEx - ) where - -import qualified Network -import InfoKind -import Math - -{-------------------------------------------------- - -- TYPES - --------------------------------------------------} - -data Document g n e = Document - { docNetwork :: Network.Network g n e - , docSelection :: Selection - } deriving Show - -data Selection - = NoSelection - | NodeSelection Int - | EdgeSelection Int - | ViaSelection Int Int - | MultipleSelection (Maybe (DoublePoint,DoublePoint)) [Int] [(Int,Int)] - -- DoublePoint pair is for displaying dragged selection rectangle - deriving (Show, Read, Eq) - -{-------------------------------------------------- - -- CREATION - --------------------------------------------------} - - --- | An empty document -empty :: (InfoKind e g, InfoKind n g) => g -> n -> e -> Document g n e -empty g n e = - Document - { docNetwork = Network.empty g n e - , docSelection = NoSelection - } - -{-------------------------------------------------- - -- GETTERS - --------------------------------------------------} - -getNetwork :: Document g n e -> Network.Network g n e -getSelection :: Document g n e -> Selection - -getNetwork doc = docNetwork doc -getSelection doc = docSelection doc - -{-------------------------------------------------- - -- SETTERS - --------------------------------------------------} - --- | setNetwork clears the selection because the node may not exist --- in the new network -setNetwork :: Network.Network g n e -> Document g n e -> Document g n e -setNetwork theNetwork doc = - doc { docNetwork = theNetwork - , docSelection = NoSelection - } - -setSelection :: Selection -> Document g n e -> Document g n e -setSelection theSelection doc = doc { docSelection = theSelection } - -updateNetwork :: (Network.Network g n e -> Network.Network g n e) - -> Document g n e -> Document g n e -updateNetwork networkFun doc - = unsafeSetNetwork (networkFun (getNetwork doc)) - $ doc - -updateNetworkEx :: (Network.Network g n e -> (b, Network.Network g n e)) - -> Document g n e -> (b, Document g n e) -updateNetworkEx networkFun doc = - let (result, newNetwork) = networkFun (getNetwork doc) - in ( result - , unsafeSetNetwork newNetwork doc - ) - --- | Doesn't clear the selection -unsafeSetNetwork :: Network.Network g n e -> Document g n e -> Document g n e -unsafeSetNetwork theNetwork doc = doc { docNetwork = theNetwork } diff --git a/src/GUIEvents.hs b/src/GUIEvents.hs deleted file mode 100644 --- a/src/GUIEvents.hs +++ /dev/null @@ -1,192 +0,0 @@ -module GUIEvents where - -import List (nub,(\\)) -import NetworkView(clickedNode, clickedEdge, clickedVia) -import NetworkControl -import State -import Common -import CommonIO -import Document -import qualified ContextMenu -import qualified PersistentDocument as PD -import InfoKind -import Text.Parse - -import Graphics.UI.WX -import Graphics.UI.WXCore - -mouseDown :: (InfoKind n g, InfoKind e g, Show g, Parse g, Descriptor g) => - Bool -> Point -> Frame () -> State g n e -> IO () -mouseDown leftButton mousePoint theFrame state = - do{ pDoc <- getDocument state - ; doc <- PD.getDocument pDoc - ; ppi <- getScreenPPI - ; let network = getNetwork doc - doubleMousePoint = screenToLogicalPoint ppi mousePoint - ; case clickedNode doubleMousePoint doc of - Nothing -> - case clickedVia doubleMousePoint network of - Nothing -> - case clickedEdge doubleMousePoint network of - Nothing -> - if leftButton then - pickupArea doubleMousePoint state - else ContextMenu.canvas theFrame state - Just edgeNr -> - if leftButton then - selectEdge edgeNr state - else - do{ selectEdge edgeNr state - ; ContextMenu.edge edgeNr theFrame doubleMousePoint state - } - Just (edgeNr,viaNr) -> - if leftButton then - case getSelection doc of - MultipleSelection _ ns vs - | (edgeNr,viaNr) `elem` vs-> - pickupMultiple ns vs doubleMousePoint state - _ -> pickupVia edgeNr viaNr doubleMousePoint state - else - do{ selectVia edgeNr viaNr state - ; ContextMenu.via theFrame state - } - Just nodeNr -> - if leftButton then - case getSelection doc of - MultipleSelection _ ns vs | nodeNr `elem` ns -> - pickupMultiple ns vs doubleMousePoint state - _ -> pickupNode nodeNr doubleMousePoint state - else - do{ selectNode nodeNr state - ; ContextMenu.node nodeNr theFrame state - } - } - -leftMouseDownWithShift :: (InfoKind n g, InfoKind e g) => - Point -> State g n e -> IO () -leftMouseDownWithShift mousePoint state = - do{ pDoc <- getDocument state - ; doc <- PD.getDocument pDoc - ; ppi <- getScreenPPI - ; let network = getNetwork doc - doubleMousePoint = screenToLogicalPoint ppi mousePoint - ; case clickedNode doubleMousePoint doc of - Nothing -> - case clickedEdge doubleMousePoint network of - Nothing -> - -- shift click in empty area = create new node - createNode doubleMousePoint state - Just i -> - selectEdge i state -- shift click on edge = select - Just j -> do -- shift click on node = create edge (if possible) - case getSelection doc of - NodeSelection i | i /= j -> - createEdge i j state - _ -> selectNode j state - } - -leftMouseDownWithMeta :: (InfoKind n g, InfoKind e g) => - Point -> State g n e -> IO () -leftMouseDownWithMeta mousePoint state = - do{ pDoc <- getDocument state - ; doc <- PD.getDocument pDoc - ; ppi <- getScreenPPI - ; let network = getNetwork doc - doubleMousePoint = screenToLogicalPoint ppi mousePoint - ; case clickedNode doubleMousePoint doc of - Just j -> do -- meta click on node = toggle whether node in selection - case getSelection doc of - NodeSelection i - | i == j -> selectNothing state - | i /= j -> selectMultiple Nothing (nub [i,j]) [] state - ViaSelection e v -> selectMultiple Nothing [j] [(e,v)] state - MultipleSelection _ ns vs - | j `elem` ns -> selectMultiple Nothing (ns\\[j]) vs state - | otherwise -> selectMultiple Nothing (j:ns) vs state - _ -> selectNode j state - Nothing -> - case clickedVia doubleMousePoint network of - Just via@(e,v) -> -- meta click on via point = toggle inclusion - case getSelection doc of - NodeSelection i -> selectMultiple Nothing [i] [(e,v)] state - ViaSelection e' v' - | e==e' && v==v' -> selectNothing state - | otherwise -> selectMultiple Nothing [] [via,(e',v')] - state - MultipleSelection _ ns vs - | via `elem` vs -> selectMultiple Nothing ns (vs\\[via]) - state - | otherwise -> selectMultiple Nothing ns (via:vs) state - _ -> selectVia e v state - Nothing -> return () - } - -leftMouseDrag :: Point -> ScrolledWindow () -> State g n e -> IO () -leftMouseDrag mousePoint canvas state = - do{ dragging <- getDragging state - ; ppi <- getScreenPPI - ; ifJust dragging $ \_ -> - do{ pDoc <- getDocument state - ; doc <- PD.getDocument pDoc - ; let doubleMousePoint = screenToLogicalPoint ppi mousePoint - ; case getSelection doc of - NodeSelection nodeNr -> - dragNode nodeNr doubleMousePoint canvas state - ViaSelection edgeNr viaNr -> - dragVia edgeNr viaNr doubleMousePoint canvas state - MultipleSelection Nothing ns vs -> - dragMultiple ns vs doubleMousePoint canvas state - MultipleSelection _ _ _ -> - dragArea doubleMousePoint state - _ -> return () - } - } - -leftMouseUp :: Point -> State g n e -> IO () -leftMouseUp mousePoint state = - do{ dragging <- getDragging state - ; ppi <- getScreenPPI - ; ifJust dragging $ \(hasMoved, offset) -> - do{ pDoc <- getDocument state - ; doc <- PD.getDocument pDoc - ; let doubleMousePoint = screenToLogicalPoint ppi mousePoint - ; case getSelection doc of - NodeSelection nodeNr -> - dropNode hasMoved nodeNr offset doubleMousePoint state - ViaSelection edgeNr viaNr -> - dropVia hasMoved edgeNr viaNr offset doubleMousePoint state - MultipleSelection Nothing ns vs -> - dropMultiple hasMoved ns vs offset doubleMousePoint state - MultipleSelection _ _ _ -> - dropArea offset doubleMousePoint state - _ -> return () - } - } - -deleteKey :: State g n e -> IO () -deleteKey state = - deleteSelection state - -backspaceKey :: State g n e -> IO () -backspaceKey state = - deleteSelection state - -f2Key :: Frame () -> State g n e -> IO () -- due for demolition -f2Key theFrame state = - renameNode theFrame state - -pressRKey :: Frame () -> State g n e -> IO () -pressRKey theFrame state = - renameNode theFrame state - -pressIKey :: (InfoKind n g, InfoKind e g) => Frame () -> State g n e -> IO () -pressIKey theFrame state = - reinfoNodeOrEdge theFrame state - -upKey :: State g n e -> IO () -upKey state = - changeNamePosition True state - -downKey :: State g n e -> IO () -downKey state = - changeNamePosition False state diff --git a/src/Graphics/Blobs/Colors.hs b/src/Graphics/Blobs/Colors.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Blobs/Colors.hs @@ -0,0 +1,86 @@ +module Graphics.Blobs.Colors where + +import Graphics.UI.WX +import Text.Parse + + +-- Different spelling of colour/color to distinguish local/wx datatypes. +data Colour = RGB !Int !Int !Int deriving (Eq,Show,Read) + + +instance Parse Colour where + parse = do { isWord "RGB" + ; return RGB `apply` parse `apply` parse `apply` parse + } + +-- translate local to wx +wxcolor :: Colour -> Color +wxcolor (RGB r g b) = rgb r g b + +nodeColor, labelBackgroundColor, evidenceColor, evidenceHatchColor, + wrongProbabilitiesColor, paneBackgroundColor, activeSelectionColor, + inactiveSelectionColor :: Colour +nodeColor = lightBlue +evidenceColor = lightYellow +evidenceHatchColor = licorice +labelBackgroundColor = lightYellow +paneBackgroundColor = coconut +activeSelectionColor = licorice +inactiveSelectionColor = lightGrey +wrongProbabilitiesColor = lightRed + +testSelectionTestColor, testSelectionTargetColor :: Colour +testSelectionTestColor = RGB 0 255 0 +testSelectionTargetColor = RGB 255 0 0 + +lightYellow, lightBlue, lightRed, lightGrey, pink :: Colour +lightYellow = RGB 236 236 169 +lightBlue = RGB 200 255 255 +lightGrey = RGB 150 150 150 +lightRed = RGB 255 200 200 +pink = RGB 255 200 200 + +systemGrey :: Color -- wx type +systemGrey = colorSystem Color3DFace + +licorice, coconut :: Colour -- names black and white already taken by wx +licorice = RGB 0 0 0 +coconut = RGB 255 255 255 + +darkGreen, darkBlue, violet, indigo, darkRed, darkMagenta, darkOrange, + orange, lightPink, purple, lightGreen, mediumPurple, darkViolet, gray, + darkGrey, darkGray, lightGray, silver, whiteSmoke, aqua, teal, maroon, + olive, sienna, brown, fuchsia, turquoise, orangeRed, gold,darkSlateGray + :: Colour +darkGreen = RGB 0 100 0 +darkBlue = RGB 0 0 139 +violet = RGB 238 130 238 +indigo = RGB 75 0 130 +darkRed = RGB 139 0 0 +darkMagenta = RGB 139 0 139 +darkOrange = RGB 255 140 0 +orange = RGB 255 165 0 +lightPink = RGB 255 182 193 +purple = RGB 128 0 128 +lightGreen = RGB 144 238 144 +mediumPurple = RGB 147 112 219 +darkViolet = RGB 148 0 211 + +gray = RGB 128 128 128 +darkGrey = RGB 169 169 169 -- lighter than grey? +darkGray = RGB 169 169 169 +lightGray = RGB 211 211 211 +silver = RGB 192 192 192 +whiteSmoke = RGB 245 245 245 + +aqua = RGB 0 255 255 +teal = RGB 0 128 128 +maroon = RGB 128 0 0 +olive = RGB 128 128 0 +sienna = RGB 160 82 45 +brown = RGB 165 42 42 +fuchsia = RGB 255 0 255 +turquoise = RGB 64 224 208 +orangeRed = RGB 255 69 0 +gold = RGB 255 215 0 +darkSlateGray = RGB 47 79 79 diff --git a/src/Graphics/Blobs/Common.hs b/src/Graphics/Blobs/Common.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Blobs/Common.hs @@ -0,0 +1,159 @@ +module Graphics.Blobs.Common (module Graphics.Blobs.Common {-, module IOExts-}, module Graphics.Blobs.Colors) where + +import Graphics.Blobs.Colors +-- import IOExts(trace) +import Debug.Trace (trace) +import qualified Data.IntMap as IntMap +import Char(isSpace) +import GHC.Float(formatRealFloat, FFFormat(FFFixed)) +import List + +-- | return a list of all cartesian products for a list of lists +-- e.g. products [[1,2],[3,4]] = [[1,3],[1,4],[2,3],[2,4]] +products :: [[a]] -> [[a]] +products [] = [[]] +products (xs:xss) = [ x:prod | x <- xs, prod <- products xss] + +trees :: Show a => String -> a -> a +trees msg a = trace ("{" ++ msg ++ ":" ++ show a ++ "}") a + +foreach :: Monad m => [a] -> (a -> m b) -> m [b] +foreach = flip mapM + +foreach_ :: Monad m => [a] -> (a -> m b) -> m () +foreach_ list fun = do + mapM fun list + return () + +ifJust :: Monad m => Maybe a -> (a -> m b) -> m () +ifJust ma f = + case ma of + Nothing -> return () + Just a -> do { f a; return () } + +internalError :: String -> String -> String -> a + +internalError moduleName functionName errorString = + error (moduleName ++ "." ++ functionName ++ ": " ++ errorString) + +parseDouble :: String -> Maybe Double +parseDouble string = + case reads (commasToDots . trim $ string) of + ((double, []):_) -> Just double + _ -> Nothing + where + commasToDots = map (\c -> if c == ',' then '.' else c) + +trim :: String -> String +trim = reverse . dropWhile isSpace . reverse . dropWhile isSpace + +-- | A NumberMap maps integers to integers +type NumberMap = IntMap.IntMap Int + +-- | A NumberMap can be inverted (keys become values and values become keys) +invertMap :: NumberMap -> NumberMap +invertMap theMap = + let list = IntMap.toList theMap + invertedList = map (\(x, y) -> (y, x)) list + in IntMap.fromList invertedList + +-- | commasAnd combines a list of strings to one string by placing +-- commas in between and the word "and" just before the last element +commasAnd :: [String] -> String +commasAnd [] = "" +commasAnd [x] = x +commasAnd [x, y] = x ++ " and " ++ y +commasAnd (x:xs) = x ++ ", " ++ commasAnd xs + + +-- TODO: is niceFloat 2 0.0001 = "0.0" correct? (as opposed to "0.00") +-- | niceFloat prints a floating-point value with maximum +-- number of decimals +niceFloat :: Int -> Double -> String +niceFloat nrOfDigits f = + let s = formatRealFloat FFFixed (Just nrOfDigits) f + s' = reverse s -- s -- dropWhile (== '0') (reverse s) + s'' = if head s' == '.' then '0':s' else s' + in reverse s'' + +-- | niceFloatFix prints a floating-point value with fixed +-- number of decimals +niceFloatFix :: Int -> Double -> String +niceFloatFix nrOfDigits f = + let s = formatRealFloat FFFixed (Just nrOfDigits) f + in if head s == '.' then '0':s else s + +-- Compute the average of a list of fractionals, with average [] equal to 0. +average :: Fractional a => [a] -> a +average [] = 0 +average xs = (sum xs) / fromIntegral (length xs) + +-- | updateList changes the element at the given zero-based index in a list +-- Example: updateList 2 "yes" ["no","maybe","often","always"] ==> +-- ["no","maybe","yes","always"] +updateList :: Int -> a -> [a] -> [a] +updateList i x l = take i l ++ [x] ++ drop (i+1) l + +-- | groups splits a list into groups of given length. The +-- last group might be shorter. +-- Example: groups 3 [1..10] ==> [[1,2,3],[4,5,6],[7,8,9],[10]] +groups :: Int -> [a] -> [[a]] +groups _ [] = [] +groups n xs = let (col, rest) = splitAt n xs + in col: groups n rest + +swap :: (a, b) -> (b, a) +swap (a, b) = (b, a) + +-- remove the extension from a file name (or path). +removeExtension :: String -> String +removeExtension filename = + case break (=='.') $ reverse filename of + (_ , _ {- dot -}:properName) -> reverse properName + (_ , []) -> filename + +tabDelimited :: [[String]] -> String +tabDelimited = unlines . map (concat . intersperse "\t") + +singleton :: a -> [a] +singleton x = [x] + +-- | a version of Prelude.lookup that fails when the element is not present in the assoc-list +unsafeLookup :: (Show k, Eq k) => k -> [(k,v)] -> v +unsafeLookup x assocs = + case lookup x assocs of + Just v -> v + Nothing -> internalError "Common" "unsafeLookup" ("element " ++ show x ++ " not in list.") + +-- | a version of Prelude.elemIndex that fails when the element is not present in the list +unsafeElemIndex :: (Show a, Eq a) => a -> [a] -> Int +unsafeElemIndex x xs = + case elemIndex x xs of + Just i -> i + Nothing -> internalError "Common" "unsafeElemIndex" ("element " ++ show x ++ " not in list") + +-- Approximately equals +(~=) :: Double -> Double -> Bool +(~=) d1 d2 = abs (d1 - d2) < 0.000001 + +fst3 :: (a, b, c) -> a +fst3 (a, _, _) = a + +snd3 :: (a, b, c) -> b +snd3 (_, b, _) = b + +thd3 :: (a, b, c) -> c +thd3 (_, _, c) = c + +safeIndex :: String -> [a] -> Int -> a +safeIndex msg xs i + | i >= 0 && i < length xs = xs !! i + | otherwise = internalError "Common" "safeIndex" msg + +-- reorderList [0,2,1] "hoi" ==> "hio" +reorderList :: Show a => [Int] -> [a] -> [a] +reorderList order xs + | sort order /= [0..length xs-1] = + internalError "Common" "reorderList" ("order = " ++ show order ++ ", list = " ++ show xs) + | otherwise = + [ xs !! i | i <- order ] diff --git a/src/Graphics/Blobs/CommonIO.hs b/src/Graphics/Blobs/CommonIO.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Blobs/CommonIO.hs @@ -0,0 +1,339 @@ +module Graphics.Blobs.CommonIO where + +import Graphics.Blobs.Math +import Graphics.Blobs.Common(ifJust, internalError, tabDelimited, safeIndex, systemGrey) +import Graphics.Blobs.SafetyNet + +import Graphics.UI.WX +import Graphics.UI.WXCore +import List(elemIndex) +import System.Directory +import System.IO + +ignoreResult :: IO a -> IO () +ignoreResult action = do { action; return () } + +-- | Writes file to disk. If writing fails, an error +-- dialog is shown and False is returned +safeWriteFile :: Window a -> String -> String -> IO Bool +safeWriteFile parentWindow fileName contents = + do{ let tmpName = fileName ++ ".tmp" + + ; -- try to write to .tmp file + ; writeOkay <- + catch + (do { writeFile tmpName contents + ; return True + }) + (\ioExc -> + do{ errorDialog parentWindow "Save failed" + ( "Saving " ++ fileName ++ " failed.\n\n" + ++ "Technical reason: " ++ show ioExc ++ "\n\n" + ++ "Tip: do you have write permissions and enough disk space?" + ) + ; return False + } + ) + ; if not writeOkay then + return False + else + do{ -- remove old file if it exists and then rename .tmp to the real name + ; catch (do { exists <- doesFileExist fileName + ; when exists $ removeFile fileName + ; renameFile tmpName fileName + ; return True + }) + (\ioExc -> + do{ errorDialog parentWindow "Save failed" + ( "The file has been saved to " ++ show tmpName ++ "\nbut " + ++ "renaming it to " ++ show fileName ++ " failed.\n\n" + ++ "Technical reason: " ++ show ioExc + ) + ; return False + } + ) + }} + +strictReadFile :: String -> IO String +strictReadFile fname = + do{ contents <- readFile fname + ; seq (length contents) $ return contents -- force reading of entire file + } + +data TextCtrlSize = SingleLine | MultiLine + +myTextDialog :: Window a -> TextCtrlSize -> String -> String -> Bool + -> IO (Maybe String) +myTextDialog parentWindow size dialogTitle initial selectAll = + do{ d <- dialog parentWindow [text := dialogTitle] + ; textInput <- (case size of SingleLine -> textEntry; + MultiLine -> textCtrl) + d [ alignment := AlignLeft, text := initial ] + ; ok <- button d [text := "Ok"] + ; can <- button d [text := "Cancel", identity := wxID_CANCEL] + ; buttonSetDefault ok + ; set d [layout := column 5 [ fill $ widget textInput + , floatBottomRight $ row 5 [widget ok, widget can] + ] + -- ,clientSize := case size of SingleLine -> sz 300 40 + -- MultiLine -> sz 500 200 + ,area := case size of SingleLine -> rect (pt 50 50) (sz 300 80) + MultiLine -> rect (pt 50 50) (sz 500 250) + ] + ; when (selectAll) $ do textCtrlSetSelection textInput 0 250 + ; when (not selectAll) $ do textCtrlSetInsertionPointEnd textInput + set d [ visible := True ] + ; showModal d $ \stop -> + do set ok [on command := safetyNet parentWindow $ + do theText <- get textInput text + stop (Just theText)] + set can [on command := safetyNet parentWindow $ stop Nothing] + } + +-- Dialog for selecting a multiple Strings (0 or more) +-- Returns Nothing if Cancel was pressed, otherwise it returns the selected strings +multiSelectionDialog :: Window a -> String -> [String] -> [String] + -> IO (Maybe [String]) +multiSelectionDialog parentWindow dialogTitle strings initialSelection = + do{ d <- dialog parentWindow + [ text := dialogTitle + , resizeable := True + ] + ; p <- panel d [] + ; theListBox <- multiListBox p + [ items := strings + , selections := + [ case maybeIndex of + Nothing -> internalError "CommonIO" "multiSelectionDialog" + ( "initial selection " ++ show s + ++ " can not be found in " ++ show strings ) + Just i -> i + | s <- initialSelection + , let maybeIndex = elemIndex s strings + ] + ] + ; selectAll <- button p + [ text := "Select all" + , on command := safetyNet parentWindow $ set theListBox [ selections := take (length strings) [0..] ] + ] + ; selectNone <- button p + [ text := "Select none" + , on command := safetyNet parentWindow $ set theListBox [ selections := [] ] + ] + ; ok <- button p [text := "Ok"] + ; can <- button p [text := "Cancel", identity := wxID_CANCEL] + ; buttonSetDefault ok + ; set d [ layout := container p $ + column 10 [ vfill $ widget theListBox + , row 5 [widget selectAll, widget selectNone, widget ok, widget can] + ] + , clientSize := sz 300 400 + ] + ; showModal d $ \stop -> + do set ok [on command := safetyNet parentWindow $ + do indices <- get theListBox selections + stop (Just (map (safeIndex "CommonIO.multiSelectionDialog" strings) indices))] + set can [on command := safetyNet parentWindow $ + stop Nothing] + } + +-- Dialog for selecting a single String +-- Returns Nothing if Cancel was pressed, otherwise it returns the selected string +singleSelectionDialog :: Window a -> String -> [String] -> (Maybe String) + -> IO (Maybe String) +singleSelectionDialog _ _ [] _ = + internalError "CommonIO" "singleSelectionDialog" "no strings" +singleSelectionDialog parentWindow dialogTitle strings initialSelection = + do{ d <- dialog parentWindow [ text := dialogTitle, resizeable := True ] + ; p <- panel d [] + ; theListBox <- singleListBox p [ items := strings, selection := 0] + ; ifJust initialSelection $ \selString -> + case elemIndex selString strings of + Nothing -> internalError "CommonIO" "singleSelectionDialog" + ( "initial selection " ++ show selString + ++ " can not be found in " ++ show strings ) + Just i -> set theListBox [ selection := i ] + ; ok <- button p [text := "Ok"] + ; can <- button p [text := "Cancel", identity := wxID_CANCEL] + ; buttonSetDefault ok + ; set d [ layout := container p $ + column 10 [ vfill $ widget theListBox + , row 5 [widget ok, widget can] + ] + , clientSize := sz 300 400 + ] + ; showModal d $ \stop -> + do set ok [on command := safetyNet parentWindow $ + do index <- get theListBox selection + stop (Just (safeIndex "CommonIO.singleSelectionDialog" strings index))] + set can [on command := safetyNet parentWindow $ + stop Nothing] + } + +-- | Fill a grid from a list of lists of texts. Each list inside the +-- big list represents a row. Also set the given number or rows and +-- columns to be header: grey background and not editable. +-- This function assumes that the normal spreadsheet-like grid header row +-- and column have been made invisible. +fillGridFromList :: Grid () -> Int -> Int -> [[String]] -> IO () +fillGridFromList _ _ _ [] = return () +fillGridFromList theGrid nrHeaderRows nrHeaderCols list = + do{ nrOfCols <- gridGetNumberCols theGrid + ; nrOfRows <- gridGetNumberRows theGrid + ; when (length list > nrOfRows || maximum (map length list) > nrOfCols) $ + internalError "Common" "fillGridFromList" "grid is not big enough" + ; sequence_ . concat $ + [ [ do{ gridSetCellValue theGrid rowNr colNr txt + ; let isHeaderCell = rowNr < nrHeaderRows || colNr < nrHeaderCols + ; gridSetCellBackgroundColour theGrid rowNr colNr + (if isHeaderCell then systemGrey else white) + ; gridSetReadOnly theGrid rowNr colNr isHeaderCell + } + | (txt, colNr) <- zip theRow [0..] + ] + | (theRow, rowNr) <- zip list [0..] + ] + } + +-- | Export some data (a list of lists of strings) to a tab delimited +-- file. The user is asked to choose a location +exportToTabFile :: Window a -> String -> String -> [[String]] -> IO () +exportToTabFile parentWindow description fileName theData = + do { mFilename <- fileSaveDialog + parentWindow + False -- remember current directory + True -- overwrite prompt + ("Export " ++ description) + [("Tab delimited files",["*.txt"])] + "" -- directory + fileName + ; ifJust mFilename $ \filename -> + ignoreResult (safeWriteFile parentWindow filename (tabDelimited theData)) + } + +getScreenPPI :: IO Size +getScreenPPI = + do{ dc <- screenDCCreate + ; s <- dcGetPPI dc + ; screenDCDelete dc + ; return s + } + +screenToLogicalPoint :: Size -> Point -> DoublePoint +screenToLogicalPoint ppi p = + DoublePoint (screenToLogicalX ppi (pointX p)) + (screenToLogicalY ppi (pointY p)) + +logicalToScreenPoint :: Size -> DoublePoint -> Point +logicalToScreenPoint ppi doublePoint = + pt (logicalToScreenX ppi (doublePointX doublePoint)) + (logicalToScreenY ppi (doublePointY doublePoint)) + +screenToLogicalX :: Size -> Int -> Double +screenToLogicalX ppi x = + fromIntegral x / (fromIntegral (sizeW ppi) / 2.54) + +logicalToScreenX :: Size -> Double -> Int +logicalToScreenX ppi x = + truncate (x * fromIntegral (sizeW ppi) / 2.54) + +screenToLogicalY :: Size -> Int -> Double +screenToLogicalY ppi y = + fromIntegral y / (fromIntegral (sizeH ppi) / 2.54) + +logicalToScreenY :: Size -> Double -> Int +logicalToScreenY ppi y = + truncate (y * fromIntegral (sizeH ppi) / 2.54) + +-- Create a grid of which the standard labels (A,B,C... for columns +-- and 1,2,3... for rows) are invisible +mkNoLabelGrid :: Window a -> Int -> Int -> IO (Grid ()) +mkNoLabelGrid thePanel nrOfRows nrOfCols = + do{ theGrid <- gridCreate thePanel idAny rectNull 0 + ; gridCreateGrid theGrid nrOfRows nrOfCols 0 + ; gridSetColLabelSize theGrid 0 + ; gridSetRowLabelSize theGrid 0 + ; return theGrid + } + +resizeGrid :: Grid () -> Int -> Int -> IO () +resizeGrid theGrid nrOfRows nrOfCols = + do{ oldNrOfRows <- gridGetNumberRows theGrid + ; oldNrOfCols <- gridGetNumberCols theGrid + ; when (nrOfRows > oldNrOfRows) . ignoreResult $ + gridAppendRows theGrid (nrOfRows - oldNrOfRows) False + ; when (nrOfRows < oldNrOfRows) . ignoreResult $ + gridDeleteRows theGrid nrOfRows (oldNrOfRows - nrOfRows) False + ; when (nrOfCols > oldNrOfCols) . ignoreResult $ + gridAppendCols theGrid (nrOfCols - oldNrOfCols) False + ; when (nrOfCols < oldNrOfCols) . ignoreResult $ + gridDeleteCols theGrid nrOfCols (oldNrOfCols - nrOfCols) False + } + +-- | Get the position of a frame, if the frame is minimized or maximized +-- it is restored to its normal size first. Otherwise, you get +-- (-32000, -32000) for a minimized window :-) +safeGetPosition :: Frame a -> IO (Int, Int) +safeGetPosition f = + do{ -- isMax <- frameIsMaximized f + isMax <- frameIsFullScreen f + -- ; isMin <- frameIsIconized f + -- ; when (isMax || isMin) $ frameRestore f + ; when (isMax) $ frameRestore f + ; p <- get f position + ; return (pointX p, pointY p) + } + +-- Show a dialog with a grid and a save button +gridDialogWithSave :: Window a -> String -> Maybe String -> [[String]] + -> IO () -> IO () +gridDialogWithSave parentWindow title maybeNote matrixContents saveAction = + do{ + -- Create dialog and panel + ; theDialog <- dialog parentWindow + [ text := title + , resizeable := True + ] + ; p <- panel theDialog [] + + -- Create and fill grid + ; theGrid <- mkNoLabelGrid p height width + ; gridEnableEditing theGrid False + ; fillGridFromList theGrid 0 0 matrixContents + ; gridAutoSizeColumns theGrid False + + -- File menu + ; saveButton <- button p + [ text := "Save as..." + , on command := safetyNet parentWindow $ saveAction + ] + + -- Dialog layout + ; set theDialog + [ layout := minsize (sz 600 400) $ column 5 + ( case maybeNote of + Just note -> [ hfill $ label note ] + Nothing -> [] + ++ [ container p $ + column 5 [ fill $ widget theGrid + , row 0 [ widget saveButton, glue ] + ] + ] + ) + , visible := True + ] + } + where + width = maximum . map length $ matrixContents + height = length matrixContents + + +-- | Using bootstrapUI, a record containing all widgets and variables can be created +-- at the end of the create function, but still referred to before creation +-- NOTE: widgets should not be referred to in a strict way because this will +-- cause a loop +bootstrapUI :: (uistate -> IO uistate) -> IO () +bootstrapUI fIO = + do { fixIO fIO + ; return () + } diff --git a/src/Graphics/Blobs/Constants.hs b/src/Graphics/Blobs/Constants.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Blobs/Constants.hs @@ -0,0 +1,26 @@ +module Graphics.Blobs.Constants where + +import Graphics.UI.WX +import Graphics.Blobs.Colors + +kSELECTED_WIDTH :: Int +kSELECTED_WIDTH = 3 + +kEDGE_CLICK_RANGE, kNODE_RADIUS, kARROW_SIZE:: Double +kEDGE_CLICK_RANGE = 0.2 +kNODE_RADIUS = 0.5 +kARROW_SIZE = 0.3 + +kSELECTED_OPTIONS :: [Prop (DC ())] +kSELECTED_OPTIONS = [ penWidth := kSELECTED_WIDTH ] + +kNodeLabelColour :: Colour +kNodeLabelColour = licorice + +kNodeInfoColour :: Colour +kNodeInfoColour = darkViolet + +kEdgeInfoColour :: Colour +kEdgeInfoColour = orangeRed + + diff --git a/src/Graphics/Blobs/ContextMenu.hs b/src/Graphics/Blobs/ContextMenu.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Blobs/ContextMenu.hs @@ -0,0 +1,186 @@ +module Graphics.Blobs.ContextMenu + ( canvas, edge, node, via ) where + +import Graphics.Blobs.State +import Graphics.Blobs.Network +import Graphics.Blobs.Document +import Graphics.Blobs.NetworkControl +import Graphics.Blobs.SafetyNet +import Graphics.Blobs.CommonIO +import Graphics.Blobs.Math (DoublePoint) +import qualified Graphics.Blobs.PersistentDocument as PD +import Graphics.Blobs.Palette +import Graphics.Blobs.InfoKind +import Text.Parse + +import Graphics.UI.WX +import Graphics.UI.WXCore(windowGetMousePosition) + +-- | Context menu for empty area of canvas +canvas :: (InfoKind n g, Show g, Parse g, Descriptor g) => + Frame () -> State g n e -> IO () +canvas theFrame state = + do{ contextMenu <- menuPane [] + ; menuItem contextMenu + [ text := "Add node (shift-click)" + , on command := safetyNet theFrame $ addNodeItem theFrame state + ] + ; g <- fmap (getGlobalInfo . getNetwork) + (PD.getDocument =<< getDocument state) + ; menuItem contextMenu + [ text := ("Edit "++descriptor g) + , on command := safetyNet theFrame $ changeGlobalInfo theFrame state + ] + + ; pointWithinWindow <- windowGetMousePosition theFrame + ; menuPopup contextMenu pointWithinWindow theFrame + ; objectDelete contextMenu + } + +addNodeItem :: (InfoKind n g) => Frame () -> State g n e -> IO () +addNodeItem theFrame state = + do{ mousePoint <- windowGetMousePosition theFrame + ; ppi <- getScreenPPI + ; let doubleMousePoint = screenToLogicalPoint ppi mousePoint + ; createNode doubleMousePoint state + } + +-- | Context menu for an edge +edge :: (InfoKind n g, InfoKind e g) => + EdgeNr -> Frame () -> DoublePoint -> State g n e -> IO () +edge edgeNr theFrame mousepoint state = + do{ contextMenu <- menuPane [] + + ; pDoc <- getDocument state + ; doc <- PD.getDocument pDoc + ; let network = getNetwork doc + theEdge = getEdge edgeNr network + fromPort = getEdgeFromPort theEdge + toPort = getEdgeToPort theEdge + + ; menuItem contextMenu + [ text := "Add control point" + , on command := safetyNet theFrame $ createVia mousepoint state + ] + ; menuItem contextMenu + [ text := "Delete edge (Del)" + , on command := safetyNet theFrame $ deleteSelection state + ] + ; menuItem contextMenu + [ text := "Edit info (i)" + , on command := safetyNet theFrame $ reinfoNodeOrEdge theFrame state + ] + ; menuLine contextMenu + ; menuItem contextMenu + [ text := "from port "++show fromPort + ] + ; menuItem contextMenu + [ text := "to port "++show toPort + ] + ; pointWithinWindow <- windowGetMousePosition theFrame + ; menuPopup contextMenu pointWithinWindow theFrame + ; objectDelete contextMenu + } + +-- | Context menu for a 'via' point +via :: Frame () -> State g n e -> IO () +via theFrame state = + do{ contextMenu <- menuPane [] + ; menuItem contextMenu + [ text := "Delete control point (Del)" + , on command := safetyNet theFrame $ deleteSelection state + ] + ; pointWithinWindow <- windowGetMousePosition theFrame + ; menuPopup contextMenu pointWithinWindow theFrame + ; objectDelete contextMenu + } + +-- | Context menu for a node +node :: (InfoKind n g, InfoKind e g) => Int -> Frame () -> State g n e -> IO () +node nodeNr theFrame state = + do{ contextMenu <- menuPane [] + + ; pDoc <- getDocument state + ; doc <- PD.getDocument pDoc + ; let network = getNetwork doc + theNode = getNode nodeNr network + labelAbove = getNameAbove theNode + palette = getPalette network + theShape = getShape theNode + theInfo = getInfo theNode + (i,o) = maybe (0,0) id $ getArity theNode + + ; menuItem contextMenu + [ text := "Rename (r)" + , on command := safetyNet theFrame $ renameNode theFrame state + ] + ; menuItem contextMenu + [ text := "Edit info (i)" + , on command := safetyNet theFrame $ reinfoNodeOrEdge theFrame state + ] + ; menuItem contextMenu + [ text := "Change arity (in/"++show i++", out/"++show o++")" + , on command := safetyNet theFrame $ reArityNode theFrame state + ] + ; menuItem contextMenu + [ text := "Delete (Del)" + , on command := safetyNet theFrame $ deleteSelection state + ] + ; menuLine contextMenu + + ; menuItem contextMenu + [ text := "Label position:" ] + ; menuItem contextMenu + [ text := " above (up arrow)" + , checkable := True + , checked := labelAbove + , on command := safetyNet theFrame $ changeNamePosition True state + ] + ; menuItem contextMenu + [ text := " below (down arrow)" + , checkable := True + , checked := not labelAbove + , on command := safetyNet theFrame $ changeNamePosition False state + ] +-- ; set (if labelAbove then aboveItem else belowItem) [ checked := True ] + + ; menuLine contextMenu + + -- work out whether to keep the info-field whilst changing shape + -- (change if shape's default; keep if different i.e. user has changed it) + ; let keepInfo = case theShape of + Left n -> case lookup n (shapes palette) of + Nothing -> const theInfo + Just (_,Nothing) -> const theInfo + Just (_,Just i) -> if i==theInfo then id + else const theInfo + Right _ -> const theInfo + ; menuItem contextMenu + [ text := "Shape:" ] + ; mapM_ (shapeItem theShape keepInfo contextMenu) (shapes palette) + ; otherShape theShape contextMenu + + ; pointWithinWindow <- windowGetMousePosition theFrame + ; menuPopup contextMenu pointWithinWindow theFrame + ; objectDelete contextMenu + + } + where + shapeItem curShape keepInfo contextMenu (name,(_shape,info)) = + menuItem contextMenu + [ text := (" "++name) + , checkable := True + , checked := case curShape of { Left n -> n==name; Right _ -> False; } + , on command := safetyNet theFrame $ changeNodeShape name newinfo state + ] + where newinfo = keepInfo (maybe blank id info) + otherShape curShape contextMenu = + case curShape of + Left _ -> return () + Right _ -> do{ menuItem contextMenu + [ text := "Other shape" + , checkable := True + , checked := True + ] + ; return () + } diff --git a/src/Graphics/Blobs/DisplayOptions.hs b/src/Graphics/Blobs/DisplayOptions.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Blobs/DisplayOptions.hs @@ -0,0 +1,16 @@ +module Graphics.Blobs.DisplayOptions where + +import List ((\\)) + +type ShowInfo = [What] +data What = GlobalInfo | NodeLabel | NodeInfo | EdgeInfo deriving (Eq) + +data DisplayOptions = DP + { dpShowInfo :: ShowInfo + } + +standard :: DisplayOptions +standard = DP [GlobalInfo, NodeLabel, NodeInfo, EdgeInfo] + +toggle :: What -> DisplayOptions -> DisplayOptions +toggle w (DP opts) = DP (if w `elem` opts then opts\\[w] else w:opts) diff --git a/src/Graphics/Blobs/Document.hs b/src/Graphics/Blobs/Document.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Blobs/Document.hs @@ -0,0 +1,94 @@ +{-| Module : Document + Maintainer : afie@cs.uu.nl + + This module contains functions to create documents + and to get and set components of the Document datatype. +-} + +module Graphics.Blobs.Document + ( Document + , Selection(..) + , empty + , getNetwork, setNetwork, unsafeSetNetwork + , getSelection, setSelection + + , updateNetwork, updateNetworkEx + ) where + +import qualified Graphics.Blobs.Network as Network +import Graphics.Blobs.InfoKind +import Graphics.Blobs.Math + +{-------------------------------------------------- + -- TYPES + --------------------------------------------------} + +data Document g n e = Document + { docNetwork :: Network.Network g n e + , docSelection :: Selection + } deriving Show + +data Selection + = NoSelection + | NodeSelection Int + | EdgeSelection Int + | ViaSelection Int Int + | MultipleSelection (Maybe (DoublePoint,DoublePoint)) [Int] [(Int,Int)] + -- DoublePoint pair is for displaying dragged selection rectangle + deriving (Show, Read, Eq) + +{-------------------------------------------------- + -- CREATION + --------------------------------------------------} + + +-- | An empty document +empty :: (InfoKind e g, InfoKind n g) => g -> n -> e -> Document g n e +empty g n e = + Document + { docNetwork = Network.empty g n e + , docSelection = NoSelection + } + +{-------------------------------------------------- + -- GETTERS + --------------------------------------------------} + +getNetwork :: Document g n e -> Network.Network g n e +getSelection :: Document g n e -> Selection + +getNetwork doc = docNetwork doc +getSelection doc = docSelection doc + +{-------------------------------------------------- + -- SETTERS + --------------------------------------------------} + +-- | setNetwork clears the selection because the node may not exist +-- in the new network +setNetwork :: Network.Network g n e -> Document g n e -> Document g n e +setNetwork theNetwork doc = + doc { docNetwork = theNetwork + , docSelection = NoSelection + } + +setSelection :: Selection -> Document g n e -> Document g n e +setSelection theSelection doc = doc { docSelection = theSelection } + +updateNetwork :: (Network.Network g n e -> Network.Network g n e) + -> Document g n e -> Document g n e +updateNetwork networkFun doc + = unsafeSetNetwork (networkFun (getNetwork doc)) + $ doc + +updateNetworkEx :: (Network.Network g n e -> (b, Network.Network g n e)) + -> Document g n e -> (b, Document g n e) +updateNetworkEx networkFun doc = + let (result, newNetwork) = networkFun (getNetwork doc) + in ( result + , unsafeSetNetwork newNetwork doc + ) + +-- | Doesn't clear the selection +unsafeSetNetwork :: Network.Network g n e -> Document g n e -> Document g n e +unsafeSetNetwork theNetwork doc = doc { docNetwork = theNetwork } diff --git a/src/Graphics/Blobs/GUIEvents.hs b/src/Graphics/Blobs/GUIEvents.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Blobs/GUIEvents.hs @@ -0,0 +1,192 @@ +module Graphics.Blobs.GUIEvents where + +import List (nub,(\\)) +import Graphics.Blobs.NetworkView(clickedNode, clickedEdge, clickedVia) +import Graphics.Blobs.NetworkControl +import Graphics.Blobs.State +import Graphics.Blobs.Common +import Graphics.Blobs.CommonIO +import Graphics.Blobs.Document +import qualified Graphics.Blobs.ContextMenu as ContextMenu +import qualified Graphics.Blobs.PersistentDocument as PD +import Graphics.Blobs.InfoKind +import Text.Parse + +import Graphics.UI.WX +import Graphics.UI.WXCore + +mouseDown :: (InfoKind n g, InfoKind e g, Show g, Parse g, Descriptor g) => + Bool -> Point -> Frame () -> State g n e -> IO () +mouseDown leftButton mousePoint theFrame state = + do{ pDoc <- getDocument state + ; doc <- PD.getDocument pDoc + ; ppi <- getScreenPPI + ; let network = getNetwork doc + doubleMousePoint = screenToLogicalPoint ppi mousePoint + ; case clickedNode doubleMousePoint doc of + Nothing -> + case clickedVia doubleMousePoint network of + Nothing -> + case clickedEdge doubleMousePoint network of + Nothing -> + if leftButton then + pickupArea doubleMousePoint state + else ContextMenu.canvas theFrame state + Just edgeNr -> + if leftButton then + selectEdge edgeNr state + else + do{ selectEdge edgeNr state + ; ContextMenu.edge edgeNr theFrame doubleMousePoint state + } + Just (edgeNr,viaNr) -> + if leftButton then + case getSelection doc of + MultipleSelection _ ns vs + | (edgeNr,viaNr) `elem` vs-> + pickupMultiple ns vs doubleMousePoint state + _ -> pickupVia edgeNr viaNr doubleMousePoint state + else + do{ selectVia edgeNr viaNr state + ; ContextMenu.via theFrame state + } + Just nodeNr -> + if leftButton then + case getSelection doc of + MultipleSelection _ ns vs | nodeNr `elem` ns -> + pickupMultiple ns vs doubleMousePoint state + _ -> pickupNode nodeNr doubleMousePoint state + else + do{ selectNode nodeNr state + ; ContextMenu.node nodeNr theFrame state + } + } + +leftMouseDownWithShift :: (InfoKind n g, InfoKind e g) => + Point -> State g n e -> IO () +leftMouseDownWithShift mousePoint state = + do{ pDoc <- getDocument state + ; doc <- PD.getDocument pDoc + ; ppi <- getScreenPPI + ; let network = getNetwork doc + doubleMousePoint = screenToLogicalPoint ppi mousePoint + ; case clickedNode doubleMousePoint doc of + Nothing -> + case clickedEdge doubleMousePoint network of + Nothing -> + -- shift click in empty area = create new node + createNode doubleMousePoint state + Just i -> + selectEdge i state -- shift click on edge = select + Just j -> do -- shift click on node = create edge (if possible) + case getSelection doc of + NodeSelection i | i /= j -> + createEdge i j state + _ -> selectNode j state + } + +leftMouseDownWithMeta :: (InfoKind n g, InfoKind e g) => + Point -> State g n e -> IO () +leftMouseDownWithMeta mousePoint state = + do{ pDoc <- getDocument state + ; doc <- PD.getDocument pDoc + ; ppi <- getScreenPPI + ; let network = getNetwork doc + doubleMousePoint = screenToLogicalPoint ppi mousePoint + ; case clickedNode doubleMousePoint doc of + Just j -> do -- meta click on node = toggle whether node in selection + case getSelection doc of + NodeSelection i + | i == j -> selectNothing state + | i /= j -> selectMultiple Nothing (nub [i,j]) [] state + ViaSelection e v -> selectMultiple Nothing [j] [(e,v)] state + MultipleSelection _ ns vs + | j `elem` ns -> selectMultiple Nothing (ns\\[j]) vs state + | otherwise -> selectMultiple Nothing (j:ns) vs state + _ -> selectNode j state + Nothing -> + case clickedVia doubleMousePoint network of + Just via@(e,v) -> -- meta click on via point = toggle inclusion + case getSelection doc of + NodeSelection i -> selectMultiple Nothing [i] [(e,v)] state + ViaSelection e' v' + | e==e' && v==v' -> selectNothing state + | otherwise -> selectMultiple Nothing [] [via,(e',v')] + state + MultipleSelection _ ns vs + | via `elem` vs -> selectMultiple Nothing ns (vs\\[via]) + state + | otherwise -> selectMultiple Nothing ns (via:vs) state + _ -> selectVia e v state + Nothing -> return () + } + +leftMouseDrag :: Point -> ScrolledWindow () -> State g n e -> IO () +leftMouseDrag mousePoint canvas state = + do{ dragging <- getDragging state + ; ppi <- getScreenPPI + ; ifJust dragging $ \_ -> + do{ pDoc <- getDocument state + ; doc <- PD.getDocument pDoc + ; let doubleMousePoint = screenToLogicalPoint ppi mousePoint + ; case getSelection doc of + NodeSelection nodeNr -> + dragNode nodeNr doubleMousePoint canvas state + ViaSelection edgeNr viaNr -> + dragVia edgeNr viaNr doubleMousePoint canvas state + MultipleSelection Nothing ns vs -> + dragMultiple ns vs doubleMousePoint canvas state + MultipleSelection _ _ _ -> + dragArea doubleMousePoint state + _ -> return () + } + } + +leftMouseUp :: Point -> State g n e -> IO () +leftMouseUp mousePoint state = + do{ dragging <- getDragging state + ; ppi <- getScreenPPI + ; ifJust dragging $ \(hasMoved, offset) -> + do{ pDoc <- getDocument state + ; doc <- PD.getDocument pDoc + ; let doubleMousePoint = screenToLogicalPoint ppi mousePoint + ; case getSelection doc of + NodeSelection nodeNr -> + dropNode hasMoved nodeNr offset doubleMousePoint state + ViaSelection edgeNr viaNr -> + dropVia hasMoved edgeNr viaNr offset doubleMousePoint state + MultipleSelection Nothing ns vs -> + dropMultiple hasMoved ns vs offset doubleMousePoint state + MultipleSelection _ _ _ -> + dropArea offset doubleMousePoint state + _ -> return () + } + } + +deleteKey :: State g n e -> IO () +deleteKey state = + deleteSelection state + +backspaceKey :: State g n e -> IO () +backspaceKey state = + deleteSelection state + +f2Key :: Frame () -> State g n e -> IO () -- due for demolition +f2Key theFrame state = + renameNode theFrame state + +pressRKey :: Frame () -> State g n e -> IO () +pressRKey theFrame state = + renameNode theFrame state + +pressIKey :: (InfoKind n g, InfoKind e g) => Frame () -> State g n e -> IO () +pressIKey theFrame state = + reinfoNodeOrEdge theFrame state + +upKey :: State g n e -> IO () +upKey state = + changeNamePosition True state + +downKey :: State g n e -> IO () +downKey state = + changeNamePosition False state diff --git a/src/Graphics/Blobs/InfoKind.hs b/src/Graphics/Blobs/InfoKind.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Blobs/InfoKind.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} +module Graphics.Blobs.InfoKind where + +import Text.Parse +--import Text.XML.HaXml.XmlContent +import Text.XML.HaXml.XmlContent.Haskell + +-- | The @InfoKind@ class is a predicate that ensures we can always create +-- at least a blank (empty) information element, that we can read and +-- write them to/from the user, and that there exists some method of +-- determining the correctness of the value (completeness/consistency etc) +-- against some global type. +class (Eq a, Show a, Parse a, XmlContent a) => InfoKind a g | a -> g where + blank :: a + check :: String -> g -> a -> [String] -- returns warnings + -- ^ first arg is container label for error reporting. + -- second arg is global value + +-- A basic instance representing "no info" +instance InfoKind () () where + blank = () + check _ _ () = [] +-- Assume that info is mandatory, but not supplied a priori. +instance InfoKind a b => InfoKind (Maybe a) b where + blank = Nothing + check n _ Nothing = ["No info value stored with "++n] + check n g (Just a) = check n g a + +-- A "showType"-style class. Descriptor should always ignore its argument, +-- and return a constant string describing the type instead. +class (Show a) => Descriptor a where + descriptor :: a -> String + descriptor _ = "type descriptor was left undefined" +instance Descriptor () where + descriptor _ = "null global info type" + +-- ----------------------------------------------- +{- +instance XmlContent () where + toContents = undefined + parseContents = undefined +-} diff --git a/src/Graphics/Blobs/Math.hs b/src/Graphics/Blobs/Math.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Blobs/Math.hs @@ -0,0 +1,110 @@ +module Graphics.Blobs.Math + ( DoublePoint(..), Vector + , doublePointX, doublePointY + , intPointToDoublePoint + , doublePointToIntPoint + , translatePolar + , distancePointPoint + , distanceSegmentPoint + , subtractDoublePoint + , subtractDoublePointVector + , vectorLength + , vectorAngle + , origin + , translate + , enclosedInRectangle + ) where + +import Graphics.UI.WX(Point, point, pointX, pointY) +import Text.Parse + +{- +data DoublePoint = DoublePoint + { doublePointX :: !Double + , doublePointY :: !Double + } + deriving (Show, Eq, Read) +-} +data DoublePoint = DoublePoint !Double !Double + deriving (Show, Eq, Read) + +instance Parse DoublePoint where + parse = do { isWord "DoublePoint" + ; return DoublePoint `apply` parse `apply` parse + } + +data Vector = Vector !Double !Double + +doublePointX (DoublePoint x _) = x +doublePointY (DoublePoint _ y) = y + +origin :: DoublePoint +origin = DoublePoint 0 0 + +-- | Compute distance between two points +distancePointPoint :: DoublePoint -> DoublePoint -> Double +distancePointPoint (DoublePoint x0 y0) (DoublePoint x1 y1) = + sqrt (square (x0 - x1) + square (y0 - y1)) + +square :: Double -> Double +square d = d*d + +-- | Compute distance from a segment (as opposed to a line) to a point +-- Formulas taken from +-- +distanceSegmentPoint :: DoublePoint -> DoublePoint -> DoublePoint -> Double +distanceSegmentPoint p0 p1 p = + let v = p1 `subtractDoublePointVector` p0 + w = p `subtractDoublePointVector` p0 + c1 = dotProduct w v + c2 = dotProduct v v + in if c1 <= 0 then distancePointPoint p p0 + else if c2 <= c1 then distancePointPoint p p1 + else distanceLinePoint p0 p1 p + +-- | Compute distance from a line to a point +distanceLinePoint :: DoublePoint -> DoublePoint -> DoublePoint -> Double +distanceLinePoint (DoublePoint x0 y0) (DoublePoint x1 y1) (DoublePoint x y) = + abs ( ( (y0 - y1) * x + (x1 - x0) * y + (x0 * y1 - x1 * y0) ) / + sqrt (square (x1 - x0) + square (y1 - y0)) + ) + +subtractDoublePointVector :: DoublePoint -> DoublePoint -> Vector +subtractDoublePointVector (DoublePoint x0 y0) (DoublePoint x1 y1) = + Vector (x0 - x1) (y0 - y1) + +-- | Translate a point relative to a new origin +translate :: DoublePoint -> DoublePoint -> DoublePoint +translate (DoublePoint originX originY) (DoublePoint x y) = + DoublePoint (x+originX) (y+originY) + +subtractDoublePoint :: DoublePoint -> DoublePoint -> DoublePoint +subtractDoublePoint (DoublePoint x0 y0) (DoublePoint x1 y1) = + DoublePoint (x0 - x1) (y0 - y1) + +dotProduct :: Vector -> Vector -> Double +dotProduct (Vector v1 v2) (Vector w1 w2) = v1 * w1 + v2 * w2 + +translatePolar :: Double -> Double -> DoublePoint -> DoublePoint +translatePolar angle distance (DoublePoint x y) = + DoublePoint (x + cos angle * distance) (y + sin angle * distance) + +doublePointToIntPoint :: DoublePoint -> Point +doublePointToIntPoint (DoublePoint x y) = point (round x) (round y) + +intPointToDoublePoint :: Point -> DoublePoint +intPointToDoublePoint pt = + DoublePoint (fromIntegral (pointX pt)) (fromIntegral (pointY pt)) + +vectorAngle :: Vector -> Double +vectorAngle (Vector v1 v2) = atan2 v2 v1 + +vectorLength :: Vector -> Double +vectorLength (Vector v1 v2) = sqrt (square v1 + square v2) + +enclosedInRectangle :: DoublePoint -> DoublePoint -> DoublePoint -> Bool +enclosedInRectangle (DoublePoint x y) (DoublePoint x0 y0) (DoublePoint x1 y1) = + between x x0 x1 && between y y0 y1 + where + between i j k | j <= k = j <= i && i <= k + | otherwise = k <= i && i <= j diff --git a/src/Graphics/Blobs/Network.hs b/src/Graphics/Blobs/Network.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Blobs/Network.hs @@ -0,0 +1,579 @@ +module Graphics.Blobs.Network + ( + -- * Types + Network, Node, Edge + , NodeNr, EdgeNr, ViaNr + , networkNodes -- dangerous + , networkEdges -- dangerous + + -- * Creating and printing a network + -- , Network.empty + , empty + , dumpNetwork + + , getNodeNrs + , getNodeAssocs, setNodeAssocs + , getEdgeAssocs, setEdgeAssocs + , getCanvasSize, setCanvasSize + , getPalette, setPalette + , getGlobalInfo, setGlobalInfo + + , getNode + , getEdge + , getNodes + , getEdges + , getChildren + , getParents + , getParentMap, ParentMap + + , nodeExists, edgeExists + , findEdge, findNodeNrsByName + + , updateNode + , updateEdge + , updateVia + + , mapNodeNetwork + + , addNode, addNodes, removeNode, addNodeEx + , addEdge, addEdges, removeEdge, addEdgeWithPorts + , removeAllEdges + , newViaEdge, removeVia + + , constructNode + , getNodeInfo, getNodeName, getNodePosition, getNodeNameAbove, getNodeShape + , setNodeInfo, setNodeName, setNodePosition, setNodeNameAbove, setNodeShape + , getNodeArity + , setNodeArity + , getInfo, getName, getPosition, getNameAbove, getShape, getArity + , setInfo, setName, setPosition, setNameAbove, setShape, setArity + + , constructEdge + , getEdgeFrom, getEdgeTo, getEdgeVia, getEdgeInfo + , setEdgeFrom, setEdgeTo, setEdgeVia, setEdgeInfo + , getEdgeFromPort, getEdgeToPort + , setEdgeFromPort, setEdgeToPort + ) where + +import Graphics.Blobs.Common +import Graphics.Blobs.Math +import Graphics.Blobs.InfoKind +import qualified Graphics.Blobs.Shape as Shape +import qualified Graphics.Blobs.Palette as P + +import qualified Data.IntMap as IntMap -- hiding (map) + +data Network g n e = Network + { networkNodes :: !(IntMap.IntMap (Node n)) -- ^ maps node numbers to nodes + , networkEdges :: !(IntMap.IntMap (Edge e)) -- ^ maps edge numbers to edges + , networkPalette :: P.Palette n + , networkCanvasSize :: (Double, Double) + , networkInfo :: g + } deriving Show + +data Edge e = Edge + { edgeFrom :: !NodeNr -- ^ the number of the node where the edge starts + , edgeTo :: !NodeNr -- ^ the number of the node the edge points to + , edgeVia :: [DoublePoint] -- ^ intermediate vertices when drawing + , edgeInfo :: e + , edgeFromPort :: !PortNr -- ^ the connection port on the 'from' node + , edgeToPort :: !PortNr -- ^ the connection port on the 'to' node + } deriving (Show, Read, Eq) + +data Node n = Node + { nodePosition :: DoublePoint -- ^ the position of the node on screen + , nodeName :: !String + , nodeNameAbove :: Bool -- ^ should the name be displayed above (True) of below (False) + , nodeShape :: Either String Shape.Shape -- ^ name from palette, or shape + , nodeInfo :: n + , nodeArity :: Maybe (PortNr,PortNr) -- ^ number of in/out connection ports + } deriving (Show, Read) + +type NodeNr = Int +type EdgeNr = Int +type ViaNr = Int +type PortNr = Int + +-- | Create an empty network +empty :: (InfoKind n g, InfoKind e g) => g -> n -> e -> Network g n e +empty g _ _ = Network + { networkNodes = IntMap.empty + , networkEdges = IntMap.empty + , networkPalette = P.empty + , networkCanvasSize = (15, 9) + , networkInfo = g + } + +-- | Map a function over the nodes, possibly changes the type +-- of the Network (i.e. the kind of values stored in the +-- probability tables) +mapNodeNetwork :: InfoKind m g => + (Node n->Node m) -> Network g n e -> Network g m e +mapNodeNetwork nodeFun network = + let numberedNodes = getNodeAssocs network + newNodes = [ (nr, nodeFun node) | (nr, node) <- numberedNodes ] + in Network + { networkNodes = IntMap.fromList newNodes + , networkEdges = networkEdges network + , networkPalette = fmap (const blank) $ networkPalette network + , networkCanvasSize = networkCanvasSize network + , networkInfo = networkInfo network + } + +constructEdge :: NodeNr -> PortNr -> NodeNr -> PortNr + -> [DoublePoint] -> e -> Edge e +constructEdge fromNr fromPort toNr toPort via info = + Edge + { edgeFrom = fromNr + , edgeTo = toNr + , edgeVia = via + , edgeInfo = info + , edgeFromPort = fromPort + , edgeToPort = toPort + } + +getEdgeFrom :: Edge e -> NodeNr +getEdgeFrom = edgeFrom + +getEdgeFromPort :: Edge e -> PortNr +getEdgeFromPort = edgeFromPort + +getEdgeTo :: Edge e -> NodeNr +getEdgeTo = edgeTo + +getEdgeToPort :: Edge e -> PortNr +getEdgeToPort = edgeToPort + +getEdgeVia :: Edge e -> [DoublePoint] +getEdgeVia = edgeVia + +getEdgeInfo :: Edge e -> e +getEdgeInfo = edgeInfo + +setEdgeFrom :: NodeNr -> Edge e -> Edge e +setEdgeFrom fromNr edge = edge { edgeFrom = fromNr } + +setEdgeFromPort :: PortNr -> Edge e -> Edge e +setEdgeFromPort fromPortNr edge = edge { edgeFromPort = fromPortNr } + +setEdgeTo :: NodeNr -> Edge e -> Edge e +setEdgeTo toNr edge = edge { edgeTo = toNr } + +setEdgeToPort :: PortNr -> Edge e -> Edge e +setEdgeToPort toPortNr edge = edge { edgeToPort = toPortNr } + +setEdgeVia :: [DoublePoint] -> Edge e -> Edge e +setEdgeVia via edge = edge { edgeVia = via } + +setEdgeInfo :: e -> Edge oldInfo -> Edge e +setEdgeInfo info edge = edge { edgeInfo = info } + +constructNode :: (InfoKind n g) => + String -> DoublePoint -> Bool + -> Either String Shape.Shape -> n -> Maybe (PortNr,PortNr) -> Node n +constructNode name position nameAbove shape info arity = + Node + { nodeName = name + , nodePosition = position + , nodeNameAbove = nameAbove + , nodeShape = shape + , nodeInfo = info + , nodeArity = arity + } + +getNodeName :: Network g n e -> NodeNr -> String +getNodeName network nodeNr = nodeName (networkNodes network IntMap.! nodeNr) + +setNodeName :: NodeNr -> String -> Network g n e -> Network g n e +setNodeName nodeNr name network = + network { networkNodes = IntMap.insert nodeNr (node { nodeName = name }) (networkNodes network) } + where node = networkNodes network IntMap.! nodeNr + +getNodePosition :: Network g n e -> NodeNr -> DoublePoint +getNodePosition network nodeNr = nodePosition (networkNodes network IntMap.! nodeNr) + +setNodePosition :: NodeNr -> DoublePoint -> Network g n e -> Network g n e +setNodePosition nodeNr position network = + network { networkNodes = IntMap.insert nodeNr (node { nodePosition = position }) (networkNodes network) } + where node = networkNodes network IntMap.! nodeNr + +getNodeNameAbove :: Network g n e -> NodeNr -> Bool +getNodeNameAbove network nodeNr = nodeNameAbove (networkNodes network IntMap.! nodeNr) + +setNodeNameAbove :: NodeNr -> Bool -> Network g n e -> Network g n e +setNodeNameAbove nodeNr nameAbove network = + network { networkNodes = IntMap.insert nodeNr (node { nodeNameAbove = nameAbove }) (networkNodes network) } + where node = networkNodes network IntMap.! nodeNr + +getNodeShape :: Network g n e -> NodeNr -> Either String Shape.Shape +getNodeShape network nodeNr = nodeShape (networkNodes network IntMap.! nodeNr) + +setNodeShape :: NodeNr -> Either String Shape.Shape -> Network g n e -> Network g n e +setNodeShape nodeNr shape network = + network { networkNodes = IntMap.insert nodeNr (node { nodeShape = shape }) + (networkNodes network) } + where node = networkNodes network IntMap.! nodeNr + +getNodeInfo :: Network g n e -> NodeNr -> n +getNodeInfo network nodeNr = nodeInfo (networkNodes network IntMap.! nodeNr) + +setNodeInfo :: NodeNr -> n -> Network g n e -> Network g n e +setNodeInfo nodeNr info network = + network { networkNodes = IntMap.insert nodeNr (node { nodeInfo = info }) (networkNodes network) } + where node = networkNodes network IntMap.! nodeNr + +getNodeArity :: Network g n e -> NodeNr -> Maybe (PortNr,PortNr) +getNodeArity network nodeNr = nodeArity (networkNodes network IntMap.! nodeNr) + +setNodeArity :: NodeNr -> Maybe (PortNr,PortNr) -> Network g n e + -> Network g n e +setNodeArity nodeNr arity network = + network { networkNodes = IntMap.insert nodeNr (node { nodeArity = arity }) + (networkNodes network) } + where node = networkNodes network IntMap.! nodeNr + +getNameAbove :: Node a -> Bool +getNameAbove node = nodeNameAbove node + +getName :: Node a -> String +getName node = nodeName node + +getShape :: Node a -> Either String Shape.Shape +getShape node = nodeShape node + +getPosition :: Node a -> DoublePoint +getPosition node = nodePosition node + +getInfo :: Node a -> a +getInfo node = nodeInfo node + +getArity :: Node a -> Maybe (PortNr,PortNr) +getArity node = nodeArity node + +-- | Set whether the name should appear above (True) or below (False) the node +setNameAbove :: Bool -> Node a -> Node a +setNameAbove above node = node { nodeNameAbove = above } + +setName :: String -> Node a -> Node a +setName name node = node { nodeName = name } + +setShape :: Either String Shape.Shape -> Node a -> Node a +setShape s node = node { nodeShape = s } + +setPosition :: DoublePoint -> Node a -> Node a +setPosition position node = node { nodePosition = position } + +setInfo :: a -> Node a -> Node a +setInfo info node = node { nodeInfo = info } + +setArity :: Maybe (PortNr,PortNr) -> Node a -> Node a +setArity arity node = node { nodeArity = arity } + +-- | Get the next unused node number +getUnusedNodeNr :: Network g n e -> NodeNr +getUnusedNodeNr network | null used = 1 + | otherwise = maximum used + 1 + where + used = IntMap.keys (networkNodes network) + +-- | Get the next unused edge number +getUnusedEdgeNr :: Network g n e -> EdgeNr +getUnusedEdgeNr network | null used = 1 + | otherwise = maximum used + 1 + where + used = IntMap.keys (networkEdges network) + +-- | Get the node numbers of the parents of a given node +getParents :: Network g n e -> NodeNr -> [NodeNr] +getParents network child = + [ parent + | edge <- getEdges network + , edgeTo edge == child + , let parent = edgeFrom edge + ] + +type ParentMap = IntMap.IntMap [NodeNr] + +-- | getParents is quite expensive (see above) and so +-- we store the parent relationship in an IntMap +getParentMap :: Network g n e -> ParentMap +getParentMap network = + IntMap.fromList + [ (nodeNr, getParents network nodeNr) + | nodeNr <- getNodeNrs network + ] + +-- | Get the node numbers of the children of a given node +getChildren :: Network g n e -> NodeNr -> [NodeNr] +getChildren network parent = + [ child + | edge <- getEdges network + , edgeFrom edge == parent + , let child = edgeTo edge + ] + + +-- | Get node with given index, raises exception if node number does not exist +getNode :: NodeNr -> Network g n e -> Node n +getNode nodeNr network + | IntMap.member nodeNr nodesMap = nodesMap IntMap.! nodeNr + | otherwise = internalError "Network" "getNode" "illegal node number" + where + nodesMap = networkNodes network + +-- | Get edge with given index, raises exception if edge number does not exist +getEdge :: EdgeNr -> Network g n e -> Edge e +getEdge edgeNr network = networkEdges network IntMap.! edgeNr + +-- | Get all of the nodes in the network +getNodes :: Network g n e -> [Node n] +getNodes network = IntMap.elems (networkNodes network) + +-- | Get all of the edges in the network +getEdges :: Network g n e -> [Edge e] +getEdges network = IntMap.elems (networkEdges network) + +-- | Get all of the node numbers in the network +getNodeNrs :: Network g n e -> [NodeNr] +getNodeNrs network = IntMap.keys (networkNodes network) + +getPalette :: Network g n e -> P.Palette n +getPalette network = networkPalette network + +getCanvasSize :: Network g n e -> (Double, Double) +getCanvasSize network = networkCanvasSize network + +getGlobalInfo :: Network g n e -> g +getGlobalInfo network = networkInfo network + +-- | Find the number of an edge given start and end node number +findEdge :: NodeNr -> NodeNr -> Network g n e -> Maybe EdgeNr +findEdge fromNodeNr toNodeNr network = + let hits = IntMap.filter + (sameFromAndTo (Edge { edgeFrom = fromNodeNr + , edgeTo = toNodeNr + , edgeVia = undefined + , edgeInfo = undefined + , edgeFromPort = 0 + , edgeToPort = 0 })) + (networkEdges network) + in case IntMap.keys hits of + [key] -> Just key + _ -> Nothing + +-- | Find node numbers given a node name +findNodeNrsByName :: String -> Network g n e -> [NodeNr] +findNodeNrsByName theNodeName network = + [ nodeNr + | nodeNr <- getNodeNrs network + , getNodeName network nodeNr == theNodeName + ] + +-- | Get a list of pairs where each pair contains a node number and the corresponding node +getNodeAssocs :: Network g n e -> [(NodeNr, Node n)] +getNodeAssocs network = IntMap.assocs (networkNodes network) + +setNodeAssocs :: [(NodeNr, Node n)] -> Network g n e -> Network g n e +setNodeAssocs nodeAssocs network = + network { networkNodes = IntMap.fromList nodeAssocs } + +-- | Get a list of pairs where each pair contains a edge number and the corresponding edge +getEdgeAssocs :: Network g n e -> [(EdgeNr, Edge e)] +getEdgeAssocs network = IntMap.assocs (networkEdges network) + +setEdgeAssocs :: [(EdgeNr, Edge e)] -> Network g n e -> Network g n e +setEdgeAssocs edgeAssocs network = + network { networkEdges = IntMap.fromList edgeAssocs } + +-- | Create a string that describes the network +dumpNetwork :: InfoKind e g => Network g String e -> String +dumpNetwork network = show (getNodeAssocs network) ++ "\n" ++ show (getEdgeAssocs network) + +-- | Test for existence of a node number +nodeExists :: NodeNr -> Network g n e -> Bool +nodeExists nodeNr network = + IntMap.member nodeNr (networkNodes network) + +-- | Test for existence of an edge number +edgeExists :: EdgeNr -> Network g n e -> Bool +edgeExists edgeNr network = + IntMap.member edgeNr (networkEdges network) + +{----------------------------------- + Functions that change the network + -----------------------------------} + +-- | Add a node to the network +addNode :: InfoKind n g + => Network g n e -- ^ the network to add the node to + -> (NodeNr, Network g n e) -- ^ the number of the new node and + -- the extended network +addNode network = + addNodeEx ("Node " ++ show nodeNr) + (DoublePoint 0.0 0.0) + True + (Right Shape.circle) + blank + Nothing + network + where + nodeNr = getUnusedNodeNr network + +addNodes :: InfoKind n g => Int -> Network g n e -> ([NodeNr], Network g n e) +addNodes 0 network = ([], network) +addNodes n network1 = + let (nodeNr, network2) = addNode network1 + (nodeNrs, network3) = addNodes (n-1) network2 + in (nodeNr:nodeNrs, network3) + +addNodeEx :: InfoKind n g => + String -> DoublePoint -> Bool -> Either String Shape.Shape -> n + -> Maybe (PortNr,PortNr) + -> Network g n e -> (NodeNr, Network g n e) +addNodeEx name position labelAbove shape info arity network = + ( nodeNr + , network { networkNodes = IntMap.insert nodeNr node (networkNodes network) } + ) + where + nodeNr = getUnusedNodeNr network + node = constructNode name position labelAbove shape info arity + + +-- | Add an edge to the network. +addEdge :: InfoKind e g => NodeNr -> NodeNr -> Network g n e -> Network g n e +addEdge fromNodeNr toNodeNr network + | any (sameFromAndTo edge) edgesList || -- prohibit double edges + any (sameFromAndTo (reverseEdge edge)) edgesList = -- prohibit edges in opposite direction + network + | otherwise = + let edgeNr = getUnusedEdgeNr network + in setNodeArity fromNodeNr (updateFromArity fromArity) $ + setNodeArity toNodeNr (updateToArity toArity) $ + network { networkEdges = IntMap.insert edgeNr edge (networkEdges network) } + where + edge = constructEdge fromNodeNr fromPortNr toNodeNr toPortNr [] blank + edgesList = IntMap.elems (networkEdges network) + fromArity = getNodeArity network fromNodeNr + toArity = getNodeArity network toNodeNr + fromPortNr = 1 + (maybe 0 snd $ fromArity) + toPortNr = 1 + (maybe 0 fst $ toArity) + updateFromArity Nothing = Just (0,1) + updateFromArity (Just (n,m)) = Just (n,m+1) + updateToArity Nothing = Just (1,0) + updateToArity (Just (n,m)) = Just (n+1,m) + +-- | Add an edge to the network, with specific connection ports. +addEdgeWithPorts :: InfoKind e g => + NodeNr -> PortNr -> NodeNr -> PortNr + -> Network g n e -> Network g n e +addEdgeWithPorts fromNodeNr fromPortNr toNodeNr toPortNr network + | any (sameFromAndTo edge) edgesList || -- prohibit double edges + any (sameFromAndTo (reverseEdge edge)) edgesList = -- prohibit edges in opposite direction + network + | otherwise = + let edgeNr = getUnusedEdgeNr network + networkPlusEdge = network { networkEdges = IntMap.insert edgeNr edge (networkEdges network) } + in networkPlusEdge + where + edge = constructEdge fromNodeNr fromPortNr toNodeNr toPortNr [] blank + -- edge = Edge { edgeFrom = fromNodeNr, edgeTo = toNodeNr, edgeVia = [] + -- , edgeInfo = blank, edgeFromPort = fromPortNr + -- , edgeToPort = toPortNr } + edgesList = IntMap.elems (networkEdges network) + +addEdges :: InfoKind e g => [(NodeNr,NodeNr)] -> Network g n e -> Network g n e +addEdges edgeTuples network = + foldr (\(fromNr, toNr) net -> addEdge fromNr toNr net) network edgeTuples + +-- | Insert a new 'via' control point in the middle of an edge. +newViaEdge :: EdgeNr -> ViaNr -> DoublePoint + -> Network g n e -> Network g n e +newViaEdge edgeNr viaNr point network = + network { networkEdges = IntMap.adjust (\e->e{ edgeVia= take viaNr (edgeVia e) + ++[point] + ++drop viaNr (edgeVia e) }) + edgeNr + (networkEdges network) } + +-- | Remove node with given index, raises exception if node number does not exist. +-- This function also removes all edges that start or end in this node. +removeNode :: NodeNr -> Network g n e -> Network g n e +removeNode nodeNr network = + let involvedEdges = [ i + | (i, edge) <- getEdgeAssocs network + , edgeFrom edge == nodeNr || edgeTo edge == nodeNr + ] + networkWithoutEdges = foldr removeEdge network involvedEdges + networkWithoutNode = networkWithoutEdges { networkNodes = IntMap.delete nodeNr (networkNodes networkWithoutEdges) } + in networkWithoutNode + +-- | Remove an edge from the network. The probability table of the target node is updated: +-- the corresponding dimension is removed and all values are zeroed. +-- An exception is raised if edge number does not exist. +removeEdge :: EdgeNr -> Network g n e -> Network g n e +removeEdge edgeNr network = + setNodeArity fromNodeNr (Just (fi,fo-1)) $ + setNodeArity toNodeNr (Just (ti-1,to)) $ + network { networkEdges = IntMap.delete edgeNr (networkEdges network) } + where + (fi,fo) = maybe (0,1) id $ getNodeArity network fromNodeNr + (ti,to) = maybe (1,0) id $ getNodeArity network toNodeNr + edge = getEdge edgeNr network + fromNodeNr = getEdgeFrom edge + toNodeNr = getEdgeTo edge + + +-- | Remove all edges from the network. The probability tables of all node are zeroed. +removeAllEdges :: Network g n e -> Network g n e +removeAllEdges network = + let networkWithoutEdges = network { networkEdges = IntMap.empty } + in networkWithoutEdges + +-- | Remove a control point from an edge. +removeVia :: EdgeNr -> ViaNr -> Network g n e -> Network g n e +removeVia edgeNr viaNr network = + let remove n e = e { edgeVia = take n (edgeVia e) + ++ drop (n+1) (edgeVia e) } in + network { networkEdges = IntMap.adjust (remove viaNr) + edgeNr (networkEdges network) } + +setPalette :: P.Palette n -> Network g n e -> Network g n e +setPalette palette network = network { networkPalette = palette } + +setCanvasSize :: (Double, Double) -> Network g n e -> Network g n e +setCanvasSize canvasSize network = network { networkCanvasSize = canvasSize } + +setGlobalInfo :: g -> Network g n e -> Network g n e +setGlobalInfo info network = network { networkInfo = info } + +{----------------------------------- + Local functions + -----------------------------------} + +sameFromAndTo :: Edge e -> Edge e -> Bool +sameFromAndTo edge1 edge2 = + edgeFrom edge1 == edgeFrom edge2 && edgeTo edge1 == edgeTo edge2 + +reverseEdge :: Edge e -> Edge e +reverseEdge edge = + edge { edgeFrom = edgeTo edge, edgeTo = edgeFrom edge } + +-- | Update node with given number by applying the function to it +-- Dangerous (wrt network consistency, do not export) +updateNode :: NodeNr -> (Node n -> Node n) -> Network g n e -> Network g n e +updateNode nodeNr nodeFunction network = + let node = getNode nodeNr network in + network { networkNodes = IntMap.insert nodeNr (nodeFunction node) + (networkNodes network) } + +updateEdge :: EdgeNr -> (Edge e -> Edge e) -> Network g n e -> Network g n e +updateEdge edgeNr edgeFunction network = + network { networkEdges = IntMap.adjust edgeFunction edgeNr + (networkEdges network) } + +updateVia :: EdgeNr -> ViaNr -> DoublePoint -> Network g n e -> Network g n e +updateVia edgeNr viaNr v network = + network { networkEdges = + IntMap.adjust (\e-> e { edgeVia = take viaNr (edgeVia e) + ++[v]++drop (viaNr+1) (edgeVia e) }) + edgeNr (networkEdges network) } diff --git a/src/Graphics/Blobs/NetworkControl.hs b/src/Graphics/Blobs/NetworkControl.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Blobs/NetworkControl.hs @@ -0,0 +1,513 @@ +module Graphics.Blobs.NetworkControl + ( createNode, selectNode + , createEdge, selectEdge + , createVia, selectVia + , selectNothing, selectMultiple + , pickupNode, dragNode, dropNode + , pickupVia, dragVia, dropVia + , pickupMultiple, dragMultiple, dropMultiple + , pickupArea, dragArea, dropArea + , deleteSelection + , changeNamePosition + , changeNodeShape + , renameNode, reinfoNodeOrEdge + , reArityNode + , changeGlobalInfo + ) where + +import Graphics.Blobs.State +import Graphics.Blobs.StateUtil +import Graphics.Blobs.Network +import Graphics.Blobs.NetworkView (edgeContains) +import Graphics.Blobs.Document +import Graphics.Blobs.Common +import Graphics.Blobs.CommonIO +import Graphics.Blobs.Math +import qualified Graphics.Blobs.Shape as Shape +import qualified Graphics.Blobs.PersistentDocument as PD +import Graphics.Blobs.InfoKind +import Graphics.Blobs.Palette (shapes) +import Text.Parse +import Char (isSpace) + +import Graphics.UI.WX hiding (Selection) +import Graphics.UI.WXCore + +changeNamePosition :: Bool -> State g n e -> IO () +changeNamePosition above state = + do{ pDoc <- getDocument state + ; doc <- PD.getDocument pDoc + ; case getSelection doc of + NodeSelection nodeNr -> + do{ PD.updateDocument "move label" + (updateNetwork + (updateNode nodeNr + (setNameAbove above))) pDoc + ; repaintAll state + } + _ -> return () + } + +changeNodeShape :: InfoKind n g => String -> n -> State g n e -> IO () +changeNodeShape shapename info state = + do{ pDoc <- getDocument state + ; doc <- PD.getDocument pDoc + ; case getSelection doc of + NodeSelection nodeNr -> + do{ PD.updateDocument "change shape" + (updateNetwork + (updateNode nodeNr + (setInfo info . setShape (Left shapename)))) pDoc + ; repaintAll state + } + _ -> return () + } + +deleteSelection :: State g n e -> IO () +deleteSelection state = + do{ pDoc <- getDocument state + ; doc <- PD.getDocument pDoc + ; case getSelection doc of + NodeSelection nodeNr -> + do{ PD.updateDocument "delete node" + ( setSelection NoSelection + . updateNetwork (removeNode nodeNr) + ) pDoc + ; repaintAll state + } + EdgeSelection edgeNr -> + do{ PD.updateDocument "delete edge" + ( setSelection NoSelection + . updateNetwork (removeEdge edgeNr) + ) pDoc + ; repaintAll state + } + ViaSelection edgeNr viaNr -> + do{ PD.updateDocument "delete control point" + ( setSelection NoSelection + . updateNetwork (removeVia edgeNr viaNr) + ) pDoc + ; repaintAll state + } + _ -> return () + } + +createNode :: InfoKind n g => DoublePoint -> State g n e -> IO () +createNode mousePoint state = + do{ pDoc <- getDocument state + ; doc1 <- PD.getDocument pDoc + ; let (shape,info) = case (shapes . getPalette . getNetwork) doc1 of + [] -> (Right Shape.circle, blank) + ((s,(_,Nothing)):_) -> (Left s, blank) + ((s,(_,Just i)):_) -> (Left s, i) + ; let (nodeNr, doc2) = updateNetworkEx addNode doc1 + doc3 = updateNetwork (updateNode nodeNr (setPosition mousePoint + . setShape shape + . setInfo info)) + doc2 + doc4 = setSelection (NodeSelection nodeNr) doc3 + ; PD.setDocument "add node" doc4 pDoc + ; repaintAll state + } + +selectNothing :: State g n e -> IO () +selectNothing state = + do{ pDoc <- getDocument state + ; PD.superficialUpdateDocument (setSelection NoSelection) pDoc + ; repaintAll state + } + +selectEdge :: Int -> State g n e -> IO () +selectEdge edgeNr state = + do{ pDoc <- getDocument state + ; PD.superficialUpdateDocument (setSelection (EdgeSelection edgeNr)) pDoc + ; repaintAll state + } + +createEdge :: (InfoKind e g) => Int -> Int -> State g n e -> IO () +createEdge fromNodeNr toNodeNr state = + do{ pDoc <- getDocument state + ; PD.updateDocument "add edge" + ( setSelection (NodeSelection fromNodeNr) + . updateNetwork (addEdge fromNodeNr toNodeNr) + ) pDoc + ; repaintAll state + } + +createVia :: DoublePoint -> State g n e -> IO () +createVia mousepoint state = + do{ pDoc <- getDocument state + ; doc <- PD.getDocument pDoc + ; let network = getNetwork doc + ; case getSelection doc of + EdgeSelection edgeNr -> + do{ ifJust (edgeContains (getEdge edgeNr network) mousepoint network) + $ \viaNr-> + do{ PD.updateDocument "add control point to edge" + ( setSelection (ViaSelection edgeNr viaNr) + . updateNetwork (newViaEdge edgeNr viaNr mousepoint) + ) pDoc + ; repaintAll state + } + } + _ -> return () + } + +selectVia :: Int -> Int -> State g n e -> IO () +selectVia edgeNr viaNr state = + do{ pDoc <- getDocument state + ; PD.superficialUpdateDocument (setSelection (ViaSelection edgeNr viaNr)) + pDoc + ; repaintAll state + } + +pickupVia :: Int -> Int -> DoublePoint -> State g n e -> IO () +pickupVia edgeNr viaNr mousePoint state = + do{ pDoc <- getDocument state + ; doc <- PD.getDocument pDoc + ; let network = getNetwork doc + viaPos = (getEdgeVia (getEdge edgeNr network))!!viaNr + ; setDragging (Just (False, mousePoint `subtractDoublePoint` viaPos)) state + ; selectVia edgeNr viaNr state + } + +selectNode :: Int -> State g n e -> IO () +selectNode nodeNr state = + do{ pDoc <- getDocument state + ; PD.superficialUpdateDocument (setSelection (NodeSelection nodeNr)) pDoc + ; repaintAll state + } + +pickupNode :: Int -> DoublePoint -> State g n e -> IO () +pickupNode nodeNr mousePoint state = + do{ pDoc <- getDocument state + ; doc <- PD.getDocument pDoc + ; let network = getNetwork doc + nodePos = getNodePosition network nodeNr + ; setDragging (Just (False, mousePoint `subtractDoublePoint` nodePos)) state + ; selectNode nodeNr state + } + +dragNode :: Int -> DoublePoint -> ScrolledWindow () -> State g n e -> IO () +dragNode nodeNr mousePoint canvas state = + do{ pDoc <- getDocument state + ; doc <- PD.getDocument pDoc + ; Just (hasMoved, offset) <- getDragging state + ; let newPosition = mousePoint `subtractDoublePoint` offset + oldPosition = getNodePosition (getNetwork doc) nodeNr + ; when (newPosition /= oldPosition) $ + do{ -- The first time the node is moved we have to remember + -- the document in the undo history + ; (if not hasMoved then PD.updateDocument "move node" + else PD.superficialUpdateDocument) + (updateNetwork (updateNode nodeNr + (setPosition newPosition))) + pDoc + ; Graphics.UI.WX.repaint canvas + ; setDragging (Just (True, offset)) state + -- yes, the node has really moved + } + } + +dropNode :: Bool -> Int -> DoublePoint -> DoublePoint -> State g n e -> IO () +dropNode hasMoved nodeNr offset mousePoint state = + do{ when hasMoved $ + do{ let newPosition = mousePoint `subtractDoublePoint` offset + ; pDoc <- getDocument state + ; PD.superficialUpdateDocument + (updateNetwork (updateNode nodeNr + (setPosition newPosition))) pDoc + } + ; canvas <- getCanvas state + ; Graphics.UI.WX.repaint canvas + ; setDragging Nothing state + } + +dragVia :: Int -> Int -> DoublePoint -> ScrolledWindow () -> State g n e -> IO () +dragVia edgeNr viaNr mousePoint canvas state = + do{ pDoc <- getDocument state + ; doc <- PD.getDocument pDoc + ; Just (hasMoved, offset) <- getDragging state + ; let newPosition = mousePoint `subtractDoublePoint` offset + oldPosition = (getEdgeVia (getEdge edgeNr (getNetwork doc)))!!viaNr + ; when (newPosition /= oldPosition) $ + do{ -- The first time the point is moved we have to remember + -- the document in the undo history + ; (if not hasMoved then PD.updateDocument "move control point" + else PD.superficialUpdateDocument) + (updateNetwork (updateVia edgeNr viaNr newPosition)) + pDoc + ; Graphics.UI.WX.repaint canvas + ; setDragging (Just (True, offset)) state + -- yes, the point has really moved + } + } + +dropVia :: Bool -> Int -> Int -> DoublePoint -> DoublePoint -> State g n e -> IO () +dropVia hasMoved edgeNr viaNr offset mousePoint state = + do{ when hasMoved $ + do{ let newPosition = mousePoint `subtractDoublePoint` offset + ; pDoc <- getDocument state + ; PD.superficialUpdateDocument + (updateNetwork (updateVia edgeNr viaNr newPosition)) + pDoc + } + ; canvas <- getCanvas state + ; Graphics.UI.WX.repaint canvas + ; setDragging Nothing state + } + +selectMultiple :: Maybe (DoublePoint,DoublePoint) -> [Int] -> [(Int,Int)] + -> State g n e -> IO () +selectMultiple area nodeNrs viaNrs state = + do{ pDoc <- getDocument state + ; PD.superficialUpdateDocument + (setSelection (MultipleSelection area nodeNrs viaNrs)) + pDoc + ; repaintAll state + } + +pickupMultiple :: [Int] -> [(Int,Int)] -> DoublePoint -> State g n e -> IO () +pickupMultiple _nodeNrs _viaNrs mousePoint state = + do{ setDragging (Just (False, mousePoint)) state +-- ; selectMultiple Nothing nodeNrs viaNrs state -- already selected + } + +dragMultiple :: [Int] -> [(Int,Int)] -> DoublePoint -> ScrolledWindow () + -> State g n e -> IO () +dragMultiple nodeNrs viaNrs mousePoint canvas state = + do{ pDoc <- getDocument state + -- ; doc <- PD.getDocument pDoc + ; Just (hasMoved, origin) <- getDragging state + ; let offset = mousePoint `subtractDoublePoint` origin + ; when (mousePoint /= origin) $ + do{ -- The first time the point is moved we have to remember + -- the document in the undo history + ; (if not hasMoved then PD.updateDocument "move control point" + else PD.superficialUpdateDocument) + (updateNetwork (updateMultiple nodeNrs viaNrs offset)) + pDoc + ; Graphics.UI.WX.repaint canvas + ; setDragging (Just (True, mousePoint)) state + -- yes, the point has really moved + } + } + +updateMultiple :: [Int] -> [(Int,Int)] -> DoublePoint -> Network g n e + -> Network g n e +updateMultiple ns vs o network = + ( foldr (\n z-> updateNode n (offsetNode o) . z) id ns + . foldr (\ (e,v) z-> updateVia e v (offsetVia o e v) . z) id vs + ) network + where + offsetNode off node = setPosition (getPosition node `translate` off) node + offsetVia off edgeNr via = ((getEdgeVia (getEdge edgeNr network))!!via) + `translate` off + +dropMultiple :: Bool -> [Int] -> [(Int,Int)] -> DoublePoint -> DoublePoint + -> State g n e -> IO () +dropMultiple hasMoved nodeNrs viaNrs origin mousePoint state = + do{ when hasMoved $ + do{ pDoc <- getDocument state + ; PD.superficialUpdateDocument + (updateNetwork + (updateMultiple nodeNrs viaNrs + (mousePoint`subtractDoublePoint`origin))) + pDoc + } + ; canvas <- getCanvas state + ; Graphics.UI.WX.repaint canvas + ; setDragging Nothing state + } + +pickupArea :: DoublePoint -> State g n e -> IO () +pickupArea mousePoint state = + do{ setDragging (Just (False, mousePoint)) state + ; selectMultiple (Just (mousePoint,mousePoint)) [] [] state + } + +-- dragArea is not like dragging a selection. It does not move anything. +-- It only adds items into a multiple selection. +dragArea :: DoublePoint -> State g n e -> IO () +dragArea mousePoint state = + do{ pDoc <- getDocument state + ; doc <- PD.getDocument pDoc + ; Just (_, origin) <- getDragging state + ; let (ns,vs) = itemsEnclosedWithin mousePoint origin (getNetwork doc) + ; selectMultiple (Just (origin,mousePoint)) ns vs state + } + where + itemsEnclosedWithin p0 p1 network = + ( ( Prelude.map fst + . Prelude.filter (\ (_,n)-> enclosedInRectangle (getPosition n) p0 p1) + . getNodeAssocs ) network + , ( Prelude.concatMap (\ (i,e)-> map (\ (j,_)-> (i,j)) + (Prelude.filter + (\ (_,v)-> enclosedInRectangle + v p0 p1) + (zip [0..] (getEdgeVia e)))) + . getEdgeAssocs ) network + ) + +dropArea :: DoublePoint -> DoublePoint -> State g n e -> IO () +dropArea _origin mousePoint state = + do{ dragArea mousePoint state -- calculate enclosure area + ; pDoc <- getDocument state + ; doc <- PD.getDocument pDoc + ; case getSelection doc of + MultipleSelection _ [] [] -> + PD.superficialUpdateDocument (setSelection NoSelection) pDoc + MultipleSelection _ ns vs -> + PD.superficialUpdateDocument + (setSelection (MultipleSelection Nothing ns vs)) pDoc + _ -> return () + ; setDragging Nothing state + ; repaintAll state + } + + +renameNode :: Frame () -> State g n e -> IO () +renameNode theFrame state = + do{ pDoc <- getDocument state + ; doc <- PD.getDocument pDoc + ; let network = getNetwork doc + ; case getSelection doc of + NodeSelection nodeNr -> + do{ let oldName = getNodeName network nodeNr + ; result <- myTextDialog theFrame SingleLine + "Rename node" oldName True + ; ifJust result $ \newName -> + do{ PD.updateDocument "rename node" + (updateNetwork + (updateNode nodeNr (setName newName))) pDoc + ; repaintAll state + } + } + _ -> return () + } + +reArityNode :: Frame () -> State g n e -> IO () +reArityNode theFrame state = + do{ pDoc <- getDocument state + ; doc <- PD.getDocument pDoc + ; let network = getNetwork doc + ; case getSelection doc of + NodeSelection nodeNr -> + do{ let oldArity = getNodeArity network nodeNr + ; result <- myTextDialog theFrame SingleLine + "Change arity of node" (show oldArity) + True + ; ifJust result $ \newArity -> + -- do repaintAll state -- Until we sort out the parser + case runParser parse newArity of + (Right x, s) -> + do{ when (not (null s || all isSpace s)) $ + errorDialog theFrame "Edit warning" + ("Excess text after parsed value." + ++"\nRemaining text: "++s) + ; PD.updateDocument "change node arity" + (updateNetwork + (updateNode nodeNr (setArity x))) pDoc + ; repaintAll state + } + (Left err, s) -> errorDialog theFrame "Edit warning" + ("Cannot parse entered text." + ++"\nReason: "++err + ++"\nRemaining text: "++s) + } + _ -> return () + } + +reinfoNodeOrEdge :: (InfoKind n g, InfoKind e g) => + Frame () -> State g n e -> IO () +reinfoNodeOrEdge theFrame state = + do{ pDoc <- getDocument state + ; doc <- PD.getDocument pDoc + ; let network = getNetwork doc + ; case getSelection doc of + NodeSelection nodeNr -> + do{ let oldInfo = getNodeInfo network nodeNr + ; result <- myTextDialog theFrame MultiLine + "Edit node info" (show oldInfo) True + ; ifJust result $ \newInfo -> + -- do repaintAll state -- Until we sort out the parser + case runParser parse newInfo of + (Right x, s) -> + do{ when (not (null s || all isSpace s)) $ + errorDialog theFrame "Edit warning" + ("Excess text after parsed value." + ++"\nRemaining text: "++s) + ; case check (getNodeName network nodeNr) + (getGlobalInfo network) x of + [] -> return () + e -> errorDialog theFrame "Validity warning" + ("Validity check fails:\n" + ++unlines e) + ; PD.updateDocument "edit node info" + (updateNetwork + (updateNode nodeNr (setInfo x))) pDoc + ; repaintAll state + } + (Left err, s) -> errorDialog theFrame "Edit warning" + ("Cannot parse entered text." + ++"\nReason: "++err + ++"\nRemaining text: "++s) + } + EdgeSelection edgeNr -> + do{ let oldInfo = getEdgeInfo (getEdge edgeNr network) + ; result <- myTextDialog theFrame MultiLine + "Edit edge info" (show oldInfo) True + ; ifJust result $ \newInfo -> + -- do repaintAll state -- Until we sort out the parser + case runParser parse newInfo of + (Right x, s) -> + do{ when (not (null s || all isSpace s)) $ + errorDialog theFrame "Edit warning" + ("Excess text after parsed value." + ++"\nRemaining text: "++s) + ; case check "edge" + (getGlobalInfo network) x of + [] -> return () + e -> errorDialog theFrame "Validity warning" + ("Validity check fails:\n" + ++unlines e) + ; PD.updateDocument "edit edge info" + (updateNetwork + (updateEdge edgeNr (setEdgeInfo x))) pDoc + ; repaintAll state + } + (Left err, s) -> errorDialog theFrame "Edit warning" + ("Cannot parse entered text." + ++"\nReason: "++err + ++"\nRemaining text: "++s) + } + _ -> return () + } + +changeGlobalInfo :: (Show g, Parse g, Descriptor g) => + Frame () -> State g n e -> IO () +changeGlobalInfo theFrame state = + do{ pDoc <- getDocument state + ; doc <- PD.getDocument pDoc + ; let network = getNetwork doc + info = getGlobalInfo network + ; result <- myTextDialog theFrame MultiLine ("Edit "++descriptor info) + (show info) True + ; ifJust result $ \newInfo-> + --do repaintAll state -- Until we sort out the parser + case runParser parse newInfo of + (Right x, s) -> + do{ when (not (null s || all isSpace s)) $ + errorDialog theFrame "Edit warning" + ("Excess text after parsed value." + ++"\nRemaining text: "++s) + ; PD.updateDocument ("edit "++descriptor info) + (updateNetwork (setGlobalInfo x)) pDoc + ; repaintAll state -- no visible change? + } + (Left err, s) -> errorDialog theFrame "Edit warning" + ("Cannot parse entered text." + ++"\nReason: "++err + ++"\nRemaining text: "++s) + } + diff --git a/src/Graphics/Blobs/NetworkFile.hs b/src/Graphics/Blobs/NetworkFile.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Blobs/NetworkFile.hs @@ -0,0 +1,438 @@ +{-# LANGUAGE UndecidableInstances #-} +module Graphics.Blobs.NetworkFile where + +import qualified Graphics.Blobs.Network as N +import Graphics.Blobs.Math +import Graphics.Blobs.Common +import Graphics.Blobs.Colors +import Graphics.Blobs.Shape +import Graphics.Blobs.InfoKind +import Graphics.Blobs.Palette + +import Text.XML.HaXml.Types +import Text.XML.HaXml.Escape +import Text.XML.HaXml.Posn (noPos) +import Text.XML.HaXml.Parse hiding (element) +-- import Text.XML.HaXml.XmlContent as XML +import Text.XML.HaXml.XmlContent.Haskell as XML +import Text.XML.HaXml.Combinators (replaceAttrs) +import Text.XML.HaXml.Verbatim +import Text.XML.HaXml.TypeMapping (toDTD,toHType) +import Text.PrettyPrint.HughesPJ +import qualified Text.XML.HaXml.Pretty as Pretty +import Char +import Maybe +import Monad(when) +import List(nub,isPrefixOf) + +-- | Print the network data structure to an XML text +toString :: (InfoKind n g, InfoKind e g, XmlContent g) => + N.Network g n e -> String +toString network = render . Pretty.document $ + Document (Prolog Nothing [] (Just (toDTD (toHType network))) []) emptyST + (f (toContents network)) [] + where + f [CElem e _] = e + f _ = error "bad" -- shouldn't happen + +-- | Parses a string to the network data structure +-- Returns either an error message (Left) or the network, +-- a list of warnings (Right) and a boolean indicating whether +-- the file was an old Dazzle file +fromString :: (InfoKind n g, InfoKind e g, XmlContent g) => + String -> Either String (N.Network g n e, [String], Bool) +fromString xml = + case xmlParse' "input file" xml of + Left err -> Left err -- lexical or initial (generic) parse error + Right (Document _ _ e _) -> + case runParser parseContents [CElem e noPos] of + (Left err, _) -> Left err -- secondary (typeful) parse error + (Right v, _) -> Right (v,[],False) + +{- +-- non-XML output +toStringShow :: (Show g, Show n, Show e) => Network g n e -> String +toStringShow network = + show ( getNodeAssocs network + , getEdgeAssocs network + , getCanvasSize network + , getGlobalInfo network + ) + +fromStringShow :: (Read g, InfoKind n g, InfoKind e g) => + String -> Either String (Network g n e) +fromStringShow txt = + case reads txt of + ((tuple,[]):_) -> + let (nodeAssocs, edgeAssocs, canvasSize, globalInfo) = tuple + in Right ( setNodeAssocs nodeAssocs + . setEdgeAssocs edgeAssocs + . setCanvasSize canvasSize + $ Network.empty globalInfo undefined undefined + ) + _ -> Left "File is not a Blobs network" +-} + +--------------------------------------------------------- +-- Internal type isomorphic to (index,value) pairs +-- (but permits instances of classes) +--------------------------------------------------------- +data AssocN n = AssocN Int (N.Node n) +deAssocN :: AssocN n -> (Int,N.Node n) +deAssocN (AssocN n v) = (n,v) +data AssocE e = AssocE Int (N.Edge e) +deAssocE :: AssocE e -> (Int,N.Edge e) +deAssocE (AssocE n v) = (n,v) + +--------------------------------------------------------- +-- Convert our data type to/from an XML tree +--------------------------------------------------------- +instance (HTypeable g, HTypeable n, HTypeable e) + => HTypeable (N.Network g n e) where + toHType _ = Defined "Network" [] [Constr "Network" [] []] + -- toHType g = Defined "Network" [] [Constr "Network" [] + -- [ Tagged "Width" [String] + -- , Tagged "Height" [String] + -- , toHType (getGlobalInfo g) + -- , toHType (getPalette g) + -- , toHType (getNodeAssocs g) + -- , toHType (getEdgeAssocs g) + -- ]] +instance (InfoKind n g, InfoKind e g, XmlContent g) => + XmlContent (N.Network g n e) where + toContents network = + [CElem (Elem "Network" [] + [ simpleString "Width" (show width) + , simpleString "Height" (show height) + , makeTag "Info" (toContents netInfo) + , makeTag "Palette" (toContents (N.getPalette network)) + , makeTag "Nodes" (concatMap toContents nodeAssocs) + , makeTag "Edges" (concatMap toContents edgeAssocs) + ]) () ] + where + nodeAssocs = map (uncurry AssocN) $ N.getNodeAssocs network + edgeAssocs = map (uncurry AssocE) $ N.getEdgeAssocs network + (width, height) = N.getCanvasSize network + netInfo = N.getGlobalInfo network + parseContents = do + { inElement "Network" $ do + { w <- inElement "Width" $ fmap read XML.text + ; h <- inElement "Height" $ fmap read XML.text + ; i <- inElement "Info" $ parseContents + ; p <- inElement "Palette"$ parseContents + ; ns <- inElement "Nodes" $ many1 parseContents + ; es <- inElement "Edges" $ many1 parseContents + ; networkValid ns es + ; return ( N.setCanvasSize (w,h) + . N.setPalette p + . N.setNodeAssocs (map deAssocN ns) + . N.setEdgeAssocs (map deAssocE es) + $ N.empty i undefined undefined) + } + } + +peekAttributes :: String -> XMLParser [(String,AttValue)] +peekAttributes t = + do{ (p, e@(Elem _ as _)) <- posnElement [t] + ; reparse [CElem e p] + ; return as + } + +instance HTypeable (AssocN n) where + toHType _ = Defined "Node" [] [Constr "Node" [] []] +instance (InfoKind n g) => XmlContent (AssocN n) where + toContents (AssocN n node) = + concatMap (replaceAttrs [("id",'N':show n)]) (toContents node) + parseContents = do + { [("id",n)] <- peekAttributes "Node" + ; n' <- num n + ; node <- parseContents + ; return (AssocN n' node) + } + where num (AttValue [Left ('N':n)]) = return (read n) + num (AttValue s) = fail ("Problem reading Node ID: "++verbatim s) + +instance HTypeable (AssocE e) where + toHType _ = Defined "Edge" [] [Constr "Edge" [] []] +instance (InfoKind e g) => XmlContent (AssocE e) where + toContents (AssocE n edge) = + concatMap (replaceAttrs [("id",'E':show n)]) (toContents edge) + parseContents = do + { [("id",n)] <- peekAttributes "Edge" + ; n' <- num n + ; edge <- parseContents + ; return (AssocE n' edge) + } + where num (AttValue [Left ('E':n)]) = return (read n) + num (AttValue s) = fail ("Problem reading Edge ID: "++verbatim s) + +instance HTypeable (N.Node n) where + toHType _ = Defined "Node" [] [Constr "Node" [] []] +instance (InfoKind n g) => XmlContent (N.Node n) where + toContents node = + [ makeTag "Node" + (toContents (N.getPosition node) ++ + [ escapeString "Name" (N.getName node) + , simpleString "LabelAbove" (show (N.getNameAbove node)) + , makeTag "Shape" (toContents (N.getShape node)) + , makeTag "Info" (toContents (N.getInfo node)) + , makeTag "Arity" (toContents (N.getArity node)) + ]) + ] + parseContents = do + { inElement "Node" $ do + { p <- parseContents -- position + ; n <- inElement "Name" $ XML.text + ; a <- inElement "LabelAbove" $ fmap read XML.text + ; s <- inElement "Shape" $ parseContents + ; i <- inElement "Info" $ parseContents + ; r <- (inElement "Arity" $ parseContents) + `onFail` (return Nothing) + ; return (N.constructNode n p a s i r) + } + } + +instance HTypeable DoublePoint where + toHType _ = Defined "DoublePoint" [] [Constr "X" [] [], Constr "Y" [] []] +instance XmlContent DoublePoint where + toContents (DoublePoint x y) = + [ simpleString "X" (show x) + , simpleString "Y" (show y) + ] + parseContents = do + { x <- inElement "X" $ fmap read XML.text + ; y <- inElement "Y" $ fmap read XML.text + ; return (DoublePoint x y) + } + +instance HTypeable (N.Edge e) where + toHType _ = Defined "Edge" [] [Constr "Edge" [] []] +instance InfoKind e g => XmlContent (N.Edge e) where + toContents edge = + [ makeTag "Edge" + [ simpleString "From" (show (N.getEdgeFrom edge)) + , simpleString "To" (show (N.getEdgeTo edge)) + , makeTag "Via" (concatMap toContents (N.getEdgeVia edge)) + , makeTag "Info" (toContents (N.getEdgeInfo edge)) + , makeTag "FromPort" (toContents (N.getEdgeFromPort edge)) + , makeTag "ToPort" (toContents (N.getEdgeToPort edge)) + ] + ] + parseContents = do + { inElement "Edge" $ do + { f <- inElement "From" $ fmap read XML.text + ; t <- inElement "To" $ fmap read XML.text + ; v <- inElement "Via" $ many parseContents + ; i <- inElement "Info" $ parseContents + ; fp <- (inElement "FromPort" $ parseContents) + `onFail` (return 0) + ; tp <- (inElement "ToPort" $ parseContents) + `onFail` (return 0) + ; return (N.constructEdge f fp t tp v i) + } + } + +{- derived by DrIFT -} +instance HTypeable Colour where + toHType v = Defined "Colour" [] + [Constr "RGB" [] [toHType aa,toHType ab,toHType ac]] + where (RGB aa ab ac) = v +instance XmlContent Colour where + parseContents = do + { inElement "RGB" $ do + { aa <- parseContents + ; ab <- parseContents + ; ac <- parseContents + ; return (RGB aa ab ac) + } + } + toContents v@(RGB aa ab ac) = + [mkElemC (showConstr 0 (toHType v)) + (concat [toContents aa, toContents ab, toContents ac])] + +{- derived by DrIFT -} +instance HTypeable Shape where + toHType v = Defined "Shape" [] + [Constr "Circle" [] [toHType aa,toHType ab] + ,Constr "Polygon" [] [toHType ac,toHType ad] + ,Constr "Lines" [] [toHType ae,toHType af] + ,Constr "Composite" [] [toHType ag]] + where + (Circle aa ab) = v + (Polygon ac ad) = v + (Lines ae af) = v + (Composite ag) = v +instance XmlContent Shape where + parseContents = do + { e@(Elem t _ _) <- element ["Circle","Polygon","Lines","Composite"] + ; case t of + _ | "Polygon" `isPrefixOf` t -> interior e $ + do { ac <- parseContents + ; ad <- parseContents + ; return (Polygon ac ad) + } + | "Lines" `isPrefixOf` t -> interior e $ + do { ae <- parseContents + ; af <- parseContents + ; return (Lines ae af) + } + | "Composite" `isPrefixOf` t -> interior e $ + fmap Composite parseContents + | "Circle" `isPrefixOf` t -> interior e $ + do { aa <- parseContents + ; ab <- parseContents + ; return (Circle aa ab) + } + } + toContents v@(Circle aa ab) = + [mkElemC (showConstr 0 (toHType v)) (concat [toContents aa, + toContents ab])] + toContents v@(Polygon ac ad) = + [mkElemC (showConstr 1 (toHType v)) (concat [toContents ac, + toContents ad])] + toContents v@(Lines ae af) = + [mkElemC (showConstr 2 (toHType v)) (concat [toContents ae, + toContents af])] + toContents v@(Composite ag) = + [mkElemC (showConstr 3 (toHType v)) (toContents ag)] + +{- derived by DrIFT -} +instance HTypeable ShapeStyle where + toHType v = Defined "ShapeStyle" [] + [Constr "ShapeStyle" [] [toHType aa,toHType ab,toHType ac]] + where (ShapeStyle aa ab ac) = v +instance XmlContent ShapeStyle where + parseContents = do + { inElement "ShapeStyle" $ do + { aa <- parseContents + ; ab <- parseContents + ; ac <- parseContents + ; return (ShapeStyle aa ab ac) + } + } + toContents v@(ShapeStyle aa ab ac) = + [mkElemC (showConstr 0 (toHType v)) + (concat [toContents aa, toContents ab, toContents ac])] + +{- handwritten -} +instance HTypeable a => HTypeable (Palette a) where + toHType p = Defined "Palette" [toHType a] [Constr "Palette" [] []] + where (Palette ((_,(_,Just a)):_)) = p +instance XmlContent a => XmlContent (Palette a) where + toContents (Palette shapes) = + [ mkElemC "Palette" (concatMap toContents shapes) ] + parseContents = do + { inElement "Palette" $ fmap Palette (many1 parseContents) } + +{- +instance XmlContent a => XmlContent (Either String a) where + toContents (Left str) = [ simpleString "ShapeName" (show str) ] + toContents (Right shape) = (toContents shape) + + parseContents = do + return () -- Need to implement this +-} +---- UTILITY FUNCTIONS + +-- Abbreviations +makeTag :: String -> [Content i] -> Content i +makeTag name children = CElem (Elem name [] children) undefined + +tagWithId :: String -> String -> [Content i] -> Content i +tagWithId name identity children = + CElem (Elem name [("id", AttValue [Left identity])] children) undefined + +-- | A simple string contains no spaces or unsafe characters +simpleString :: String -> String -> Content i +simpleString tag value = + CElem (Elem tag [] [ CString False value undefined ]) undefined + +-- | The string value may contain spaces and unsafe characters +escapeString :: String -> String -> Content i +escapeString key value = + CElem ((if isSafe value then id else escape) $ + Elem key [] [ CString (any isSpace value) value undefined ]) + undefined + where + isSafe cs = all isSafeChar cs + isSafeChar c = isAlpha c || isDigit c || c `elem` "- ." + + escape :: Element i -> Element i + escape = xmlEscape stdXmlEscaper + +comment :: String -> Content i +comment s = CMisc (Comment (commentEscape s)) undefined + +-- Replace occurences of "-->" with "==>" in a string so that the string +-- becomes safe for an XML comment +commentEscape :: String -> String +commentEscape [] = [] +commentEscape ('-':'-':'>':xs) = "==>" ++ commentEscape xs +commentEscape (x:xs) = x : commentEscape xs + +--------------------------------------------------------- +-- Check whether the network read from file is valid +--------------------------------------------------------- + +networkValid :: [AssocN n] -> [AssocE e] -> XMLParser () +networkValid nodeAssocs edgeAssocs + | containsDuplicates nodeNrs = + fail "Node numbers should be unique" + | containsDuplicates edgeNrs = + fail "Edge numbers should be unique" + | otherwise = + do{ mapM_ (checkEdge nodeNrs) edgeAssocs + ; -- determine whether there are multiple edges between any two nodes + ; let multipleEdges = duplicatesBy betweenSameNodes edges + ; when (not (null multipleEdges)) $ + fail $ "There are multiple edges between the following node pairs: " ++ + commasAnd [ "(" ++ show (N.getEdgeFrom e) ++ ", " + ++ show (N.getEdgeTo e) ++ ")" + | e <- multipleEdges + ] + ; return () + } + where + nodeNrs = map (fst . deAssocN) nodeAssocs + (edgeNrs, edges) = unzip (map deAssocE edgeAssocs) + +-- Check whether edges refer to existing node numbers and whether +-- there are no edges that start and end in the same node +checkEdge :: [N.NodeNr] -> AssocE e -> XMLParser () +checkEdge nodeNrs (AssocE edgeNr edge) + | fromNr == toNr = + fail $ "Edge " ++ show edgeNr ++ ": from-node and to-node are the same" + | fromNr `notElem` nodeNrs = nonExistingNode fromNr + | toNr `notElem` nodeNrs = nonExistingNode toNr + | otherwise = return () + where + fromNr = N.getEdgeFrom edge + toNr = N.getEdgeTo edge + nonExistingNode nodeNr = + fail $ "Edge " ++ show edgeNr ++ ": refers to non-existing node " + ++ show nodeNr + +containsDuplicates :: Eq a => [a] -> Bool +containsDuplicates xs = length (nub xs) /= length xs + +-- Partial equality on edges +betweenSameNodes :: N.Edge e -> N.Edge e -> Bool +betweenSameNodes e1 e2 = + (N.getEdgeFrom e1 == N.getEdgeFrom e2 && N.getEdgeTo e1 == N.getEdgeTo e2) + || + (N.getEdgeFrom e1 == N.getEdgeTo e2 && N.getEdgeTo e1 == N.getEdgeFrom e1) + +-- Returns elements that appear more than once in a list +duplicates :: Eq a => [a] -> [a] +duplicates [] = [] +duplicates (x:xs) + | x `elem` xs = x : duplicates (filter (/= x) xs) + | otherwise = duplicates xs + +-- Returns elements that appear more than once in a list, using given Eq op +duplicatesBy :: (a->a->Bool) -> [a] -> [a] +duplicatesBy _ [] = [] +duplicatesBy eq (x:xs) + | any (eq x) xs = x : duplicatesBy eq (filter (not . eq x) xs) + | otherwise = duplicatesBy eq xs + diff --git a/src/Graphics/Blobs/NetworkUI.hs b/src/Graphics/Blobs/NetworkUI.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Blobs/NetworkUI.hs @@ -0,0 +1,435 @@ +module Graphics.Blobs.NetworkUI + ( create + , getConfig, Config + ) where + +import Graphics.Blobs.GUIEvents +import Graphics.Blobs.SafetyNet +import qualified Graphics.Blobs.State as State +import Graphics.Blobs.StateUtil +import qualified Graphics.Blobs.Network as Network +import Graphics.Blobs.NetworkView +import qualified Graphics.Blobs.NetworkFile as NetworkFile +import qualified Graphics.Blobs.Document as Document +import Graphics.Blobs.Common +import Graphics.Blobs.CommonIO +import qualified Graphics.Blobs.PersistentDocument as PD +import qualified Graphics.Blobs.PDDefaults as PD +import Graphics.Blobs.Palette +import Graphics.Blobs.InfoKind +import Graphics.Blobs.DisplayOptions +--import Text.XML.HaXml.XmlContent (XmlContent) +import Text.XML.HaXml.XmlContent.Haskell (XmlContent) +import Text.Parse +import Graphics.Blobs.Operations +import Graphics.Blobs.NetworkControl (changeGlobalInfo) + +import Graphics.UI.WX hiding (Child, upKey, downKey) +import Graphics.UI.WXCore +import Maybe + +data Config = NFC + { nfcWinDimensions :: (Int, Int, Int, Int) -- x, y, width, height + , nfcFileName :: Maybe String + , nfcSelection :: Document.Selection + } + deriving (Read, Show) + +getConfig :: State.State g n e -> IO Config +getConfig state = + do{ theFrame <- State.getNetworkFrame state + ; (x, y) <- safeGetPosition theFrame + ; winSize <- get theFrame clientSize + ; pDoc <- State.getDocument state + ; maybeFileName <- PD.getFileName pDoc + ; doc <- PD.getDocument pDoc + ; return (NFC + { nfcWinDimensions = (x, y, sizeW winSize, sizeH winSize) + , nfcFileName = maybeFileName + , nfcSelection = Document.getSelection doc + }) + } + +create :: (InfoKind n g, InfoKind e g + , XmlContent g, Parse g, Show g, Descriptor g) => + State.State g n e -> g -> n -> e -> GraphOps g n e -> IO () +create state g n e ops = + do{ theFrame <- frame [ text := "Diagram editor" + , position := pt 200 20 + , clientSize := sz 300 240 ] + ; State.setNetworkFrame theFrame state + + -- Create page setup dialog and save in state + ; pageSetupData <- pageSetupDialogDataCreate + ; initialPageSetupDialog <- pageSetupDialogCreate theFrame pageSetupData + ; objectDelete pageSetupData + ; State.setPageSetupDialog initialPageSetupDialog state + + -- Drawing area + ; let (width, height) = Network.getCanvasSize (Network.empty g n e) + ; ppi <- getScreenPPI + ; canvas <- scrolledWindow theFrame + [ virtualSize := sz (logicalToScreenX ppi width) + (logicalToScreenY ppi height) + , scrollRate := sz 10 10 + , bgcolor := wxcolor paneBackgroundColor + , fullRepaintOnResize := False + ] + ; State.setCanvas canvas state + + -- Dummy persistent document to pass around + ; pDoc <- State.getDocument state + + -- Attach handlers to drawing area + ; set canvas + [ on paint := \dc _ -> safetyNet theFrame $ paintHandler state dc + , on mouse := \p -> safetyNet theFrame $ + do mouseEvent p canvas theFrame state + --; focusOn canvas + , on keyboard := \k -> safetyNet theFrame $ + do keyboardEvent theFrame state k + --; focusOn canvas + ] + + -- File menu + ; fileMenu <- menuPane [ text := "&File" ] + ; menuItem fileMenu + [ text := "New\tCtrl+N" + , on command := safetyNet theFrame $ newItem state g n e + ] + ; menuItem fileMenu + [ text := "Open...\tCtrl+O" + , on command := safetyNet theFrame $ openItem theFrame state + ] + ; saveItem <- menuItem fileMenu + [ text := "Save\tCtrl+S" + , on command := safetyNet theFrame $ PD.save pDoc + ] + ; menuItem fileMenu + [ text := "Save as..." + , on command := safetyNet theFrame $ PD.saveAs pDoc + ] + + ; menuLine fileMenu + + ; menuItem fileMenu + [ text := "Page setup..." + , on command := safetyNet theFrame $ + do{ psd <- State.getPageSetupDialog state + ; dialogShowModal psd + ; return () + } + ] + + ; menuItem fileMenu + [ text := "Print..." + , on command := safetyNet theFrame $ + let printFun _ printInfo _ dc _ = + do { dcSetUserScale dc + (fromIntegral (sizeW (printerPPI printInfo)) + / fromIntegral (sizeW (screenPPI printInfo))) + (fromIntegral (sizeH (printerPPI printInfo)) + / fromIntegral (sizeH (screenPPI printInfo))) + ; paintHandler state dc + } + pageFun _ _ _ = (1, 1) + in + do{ psd <- State.getPageSetupDialog state + ; printDialog psd "Blobs print" pageFun printFun + } + ] + + ; menuItem fileMenu + [ text := "Print preview" + , on command := safetyNet theFrame $ + let printFun _ _ _ dc _ = paintHandler state dc + pageFun _ _ _ = (1, 1) + in + do{ psd <- State.getPageSetupDialog state + ; printPreview psd "Blobs preview" pageFun printFun + } + ] + + ; menuLine fileMenu + + ; menuItem fileMenu + [ text := "E&xit" + , on command := close theFrame + ] + + -- Edit menu + ; editMenu <- menuPane [ text := "&Edit" ] + ; undoItem <- menuItem editMenu + [ on command := safetyNet theFrame $ do PD.undo pDoc; repaintAll state ] + ; redoItem <- menuItem editMenu + [ on command := safetyNet theFrame $ do PD.redo pDoc; repaintAll state ] + ; menuLine editMenu + ; menuItem editMenu + [ text := "Edit "++descriptor g++"..." + , on command := safetyNet theFrame $ changeGlobalInfo theFrame state + ] + ; menuItem editMenu + [ text := "Change shape palette..." + , on command := safetyNet theFrame $ openPalette theFrame state + ] + + -- View menu + ; viewMenu <- menuPane [ text := "&View" ] + ; (DP opts) <- State.getDisplayOptions state + ; menuItem viewMenu + [ text := descriptor g + , checkable := True + , checked := GlobalInfo `elem` opts + , on command := safetyNet theFrame $ do + { State.changeDisplayOptions (toggle GlobalInfo) state + ; repaintAll state } ] + ; menuItem viewMenu + [ text := "Node Labels" + , checkable := True + , checked := NodeLabel `elem` opts + , on command := safetyNet theFrame $ do + { State.changeDisplayOptions (toggle NodeLabel) state + ; repaintAll state } ] + ; menuItem viewMenu + [ text := "Node Info" + , checkable := True + , checked := NodeInfo `elem` opts + , on command := safetyNet theFrame $ do + { State.changeDisplayOptions (toggle NodeInfo) state + ; repaintAll state } ] + ; menuItem viewMenu + [ text := "Edge Info" + , checkable := True + , checked := EdgeInfo `elem` opts + , on command := safetyNet theFrame $ do + { State.changeDisplayOptions (toggle EdgeInfo) state + ; repaintAll state } ] + + -- Operations menu + ; opsMenu <- menuPane [ text := "&Operations" ] + ; mapM_ (\ (name,_)-> + menuItem opsMenu + [ text := name + , on command := safetyNet theFrame $ do + { callGraphOp name ops state + ; repaintAll state } + ] + ) (ioOps ops) + + ; PD.initialise pDoc (PD.PD + { PD.document = Document.empty g n e + , PD.history = [] + , PD.future = [] + , PD.limit = Nothing + , PD.fileName = Nothing + , PD.dirty = False + , PD.saveToDisk = saveToDisk theFrame + , PD.updateUndo = PD.defaultUpdateUndo undoItem + , PD.updateRedo = PD.defaultUpdateRedo redoItem + , PD.updateSave = PD.defaultUpdateSave saveItem + , PD.updateTitleBar = PD.defaultUpdateTitlebar theFrame "Blobs" + , PD.saveChangesDialog = PD.defaultSaveChangesDialog theFrame "Blobs" + , PD.saveAsDialog = PD.defaultSaveAsDialog theFrame extensions + }) + + -- Layout the main window + ; set theFrame + [ menuBar := [ fileMenu, editMenu, viewMenu, opsMenu ] + , layout := minsize (sz 300 240) $ fill $ widget canvas + , on closing := safetyNet theFrame $ exit state + ] + + -- ; set theFrame + -- [ position := pt 200 20 + -- , clientSize := sz 300 240 + -- ] + } + +paintHandler :: (InfoKind n g, InfoKind e g, Descriptor g) => + State.State g n e -> DC () -> IO () +paintHandler state dc = + do{ pDoc <- State.getDocument state + ; doc <- PD.getDocument pDoc + ; dp <- State.getDisplayOptions state + ; drawCanvas doc dc dp + } + +extensions :: [(String, [String])] +extensions = [ ("Blobs files (.blobs)", ["*.blobs"]) ] + +mouseEvent :: (InfoKind n g, InfoKind e g, Show g, Parse g, Descriptor g) => + EventMouse -> ScrolledWindow () -> Frame () -> State.State g n e -> IO () +mouseEvent eventMouse canvas theFrame state = case eventMouse of + MouseLeftDown mousePoint mods + | shiftDown mods -> leftMouseDownWithShift mousePoint state + | metaDown mods -> leftMouseDownWithMeta mousePoint state + | otherwise -> mouseDown True mousePoint theFrame state + MouseRightDown mousePoint _ -> + mouseDown False mousePoint theFrame state + MouseLeftDrag mousePoint _ -> + leftMouseDrag mousePoint canvas state + MouseLeftUp mousePoint _ -> + leftMouseUp mousePoint state + _ -> + return () + +keyboardEvent :: (InfoKind n g, InfoKind e g) => + Frame () -> State.State g n e -> EventKey -> IO () +keyboardEvent theFrame state (EventKey theKey _ _) = + case theKey of + KeyDelete -> deleteKey state + KeyBack -> backspaceKey state + KeyF2 -> f2Key theFrame state + KeyChar 'r' -> pressRKey theFrame state + KeyChar 'i' -> pressIKey theFrame state + KeyUp -> upKey state + KeyDown -> downKey state + _ -> propagateEvent + +closeDocAndThen :: State.State g n e -> IO () -> IO () +closeDocAndThen state action = + do{ pDoc <- State.getDocument state + ; continue <- PD.isClosingOkay pDoc + ; when continue $ action + } + +newItem :: (InfoKind n g, InfoKind e g) => State.State g n e -> g -> n -> e -> IO () +newItem state g n e = + closeDocAndThen state $ + do{ pDoc <- State.getDocument state + ; PD.resetDocument Nothing (Document.empty g n e) pDoc + ; repaintAll state + } + +openItem :: (InfoKind n g, InfoKind e g, XmlContent g) => + Frame () -> State.State g n e -> IO () +openItem theFrame state = + do{ mbfname <- fileOpenDialog + theFrame + False -- change current directory + True -- allowReadOnly + "Open File" + extensions + "" "" -- no default directory or filename + ; ifJust mbfname $ \fname -> openNetworkFile fname state (Just theFrame) + } + +-- Third argument: Nothing means exceptions are ignored (used in Configuration) +-- Just f means exceptions are shown in a dialog on top of frame f +openNetworkFile :: (InfoKind n g, InfoKind e g, XmlContent g) => + String -> State.State g n e -> Maybe (Frame ()) -> IO () +openNetworkFile fname state exceptionsFrame = + closeDocAndThen state $ + flip catch + (\exc -> case exceptionsFrame of + Nothing -> return () + Just f -> errorDialog f "Open network" + ( "Error while opening '" ++ fname ++ "'. \n\n" + ++ "Reason: " ++ show exc) + ) $ + do{ contents <- strictReadFile fname + ; let errorOrNetwork = NetworkFile.fromString contents + ; case errorOrNetwork of { + Left err -> ioError (userError err); + Right (network, warnings, oldFormat) -> + do{ -- "Open" document + ; let newDoc = Document.setNetwork network (Document.empty undefined undefined undefined) + ; pDoc <- State.getDocument state + ; PD.resetDocument (if null warnings then Just fname else Nothing) + newDoc pDoc + ; applyCanvasSize state + ; when (not (null warnings)) $ + case exceptionsFrame of + Nothing -> return () + Just f -> + do{ errorDialog f "File read warnings" + ( "Warnings while reading file " ++ show fname ++ ":\n\n" + ++ unlines ( map ("* " ++) (take 10 warnings) + ++ if length warnings > 10 then ["..."] else [] + ) + ++ unlines + [ "" + , "Most likely you are reading a file that is created by a newer version of Blobs. If you save this file with" + , "this version of Blobs information may be lost. For safety the file name is set to \"untitled\" so that you do" + , "not accidentaly overwrite the file" + ] + ) + ; PD.setFileName pDoc Nothing + } + ; when oldFormat $ + do{ case exceptionsFrame of + Nothing -> return () + Just f -> + errorDialog f "File read warning" $ + unlines + [ "The file you opened has the old Blobs file format which will become obsolete in newer versions of Blobs." + , "When you save this network, the new file format will be used. To encourage you to do so the network has" + , "been marked as \"modified\"." + ] + ; PD.setDirty pDoc True + } + ; -- Redraw + ; repaintAll state + }}} + +openPalette :: (InfoKind n g, Parse n) => Frame () -> State.State g n e -> IO () +openPalette theFrame state = + do{ mbfname <- fileOpenDialog + theFrame + False -- change current directory + True -- allowReadOnly + "Open File" + [ ("Shape palettes (.blobpalette)", ["*.blobpalette"]) ] + "" "" -- no default directory or filename + ; ifJust mbfname $ \fname -> openPaletteFile fname state (Just theFrame) + } + +-- Third argument: Nothing means exceptions are ignored (used in Configuration) +-- Just f means exceptions are shown in a dialog on top of frame f +openPaletteFile :: (InfoKind n g, Parse n) => + String -> State.State g n e -> Maybe (Frame ()) -> IO () +openPaletteFile fname state exceptionsFrame = + flip catch + (\exc -> case exceptionsFrame of + Nothing -> return () + Just f -> errorDialog f "Open shape palette" + ( "Error while opening '" ++ fname ++ "'. \n\n" + ++ "Reason: " ++ show exc) + ) $ + do{ contents <- readFile fname + -- ; return () -- Dummy out for now + ; case fst (runParser parse contents) of { + Left msg -> ioError (userError ("Cannot parse shape palette file: " + ++fname++"\n\t"++msg)); + Right p -> do{ pDoc <- State.getDocument state + ; PD.updateDocument "change palette" + (Document.updateNetwork (Network.setPalette p)) + -- really ought to go through network and + -- change all nodes' stored shape. + pDoc + } + } + } + +-- | Get the canvas size from the network and change the size of +-- the widget accordingly +applyCanvasSize :: State.State g n e -> IO () +applyCanvasSize state = + do{ pDoc <- State.getDocument state + ; doc <- PD.getDocument pDoc + ; let network = Document.getNetwork doc + (width, height) = Network.getCanvasSize network + ; canvas <- State.getCanvas state + ; ppi <- getScreenPPI + ; set canvas [ virtualSize := sz (logicalToScreenX ppi width) + (logicalToScreenY ppi height) ] + } + +saveToDisk :: (InfoKind n g, InfoKind e g, XmlContent g) => + Frame () -> String -> Document.Document g n e -> IO Bool +saveToDisk theFrame fileName doc = + safeWriteFile theFrame fileName (NetworkFile.toString (Document.getNetwork doc)) + +exit :: State.State g n e -> IO () +exit state = + closeDocAndThen state $ propagateEvent diff --git a/src/Graphics/Blobs/NetworkView.hs b/src/Graphics/Blobs/NetworkView.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Blobs/NetworkView.hs @@ -0,0 +1,342 @@ +module Graphics.Blobs.NetworkView + ( drawCanvas + , clickedNode + , clickedEdge + , clickedVia + , edgeContains + ) where + +import Graphics.Blobs.Constants +import Graphics.Blobs.CommonIO +import qualified Graphics.Blobs.Network as Network +import Graphics.Blobs.Document +import Graphics.Blobs.Colors +import Graphics.Blobs.Common +import Graphics.Blobs.Palette + +import Graphics.Blobs.Math +import Graphics.UI.WX as WX hiding (Vector) +import Graphics.UI.WXCore hiding (Document, screenPPI, Colour) +import Graphics.UI.WXCore.Draw +import Maybe +import qualified Graphics.Blobs.Shape as Shape +import Graphics.Blobs.DisplayOptions +import Graphics.Blobs.InfoKind + +import Prelude hiding (catch) +import Control.Exception +import qualified Data.IntMap as IntMap + +drawCanvas :: (InfoKind n g, InfoKind e g, Descriptor g) => + Document g n e -> DC () -> DisplayOptions -> IO () +drawCanvas doc dc opt = + do{ + + -- Scale if the DC we are drawing to has a different PPI from the screen + -- Printing, nudge, nudge + ; dcPPI <- dcGetPPI dc + ; screenPPI <- getScreenPPI + ; when (dcPPI /= screenPPI) $ + dcSetUserScale dc + (fromIntegral (sizeW dcPPI ) / fromIntegral (sizeW screenPPI )) + (fromIntegral (sizeH dcPPI ) / fromIntegral (sizeH screenPPI )) + + -- Set font + ; set dc [ fontFamily := FontDefault, fontSize := 10 ] + + ; catch (reallyDrawCanvas doc screenPPI dc opt) + (h1 dc dcPPI ) + {- + (\e -> logicalText dcPPI dc (DoublePoint 50 50) + ("Exception while drawing: "++show e) + (Justify LeftJ TopJ) [] ) + -} + } + +h1 :: DC () -> Size2D Int -> SomeException -> IO () +h1 dc dcPPI e = logicalText dcPPI dc (DoublePoint 50 50) + ("Exception while drawing: "++show e) + (Justify LeftJ TopJ) [] + + +reallyDrawCanvas :: (InfoKind n g, InfoKind e g, Descriptor g) => + Document g n e -> Size -> DC () -> DisplayOptions -> IO () +reallyDrawCanvas doc ppi dc opt = + do{ + -- draw global info on diagram + ; let (width, _height) = Network.getCanvasSize network + ; when (GlobalInfo `elem` dpShowInfo opt) $ + drawLabel 0 False + (descriptor global++": "++(unwords.lines.show) global) + (DoublePoint (width/2) 1) (Justify CentreJ TopJ) + [ textColor := wxcolor kNodeLabelColour ] + -- draw edges, highlight the selected ones (if any) + ; mapM_ (\edge -> drawEdge edge []) (Network.getEdges network) + ; case theSelection of + EdgeSelection edgeNr -> do + drawEdge (Network.getEdge edgeNr network) kSELECTED_OPTIONS + ViaSelection edgeNr viaNr -> do + drawVia (Network.getEdge edgeNr network) viaNr kSELECTED_OPTIONS + MultipleSelection _ _ viaNrs -> do + mapM_ (\ (e,v)-> drawVia (Network.getEdge e network) v kSELECTED_OPTIONS) + viaNrs + _ -> return () + + -- draw nodes, highlight the selected ones (if any) + ; mapM_ (\(nodeNr, _) -> drawNode nodeNr [ ]) (Network.getNodeAssocs network) + ; case theSelection of + NodeSelection nodeNr -> + drawNode nodeNr (kSELECTED_OPTIONS + ++ [ penColor := wxcolor activeSelectionColor ]) + MultipleSelection _ nodeNrs _ -> + mapM_ (\n-> drawNode n (kSELECTED_OPTIONS + ++ [ penColor := wxcolor activeSelectionColor ])) + nodeNrs + _ -> return () + + -- multiple selection drag area rectangle + ; case theSelection of + MultipleSelection (Just (p,q)) _ _ -> + logicalRect ppi dc (doublePointX p) (doublePointY p) + (doublePointX q - doublePointX p) + (doublePointY q - doublePointY p) + [ penColor := wxcolor lightGrey + , brushKind := BrushTransparent] + _ -> return () + + -- canvas size rectangle + -- ; let (width, height) = Network.getCanvasSize (getNetwork doc) + -- ; logicalRect ppi dc 0 0 width height [brushKind := BrushTransparent] + } + where + network = getNetwork doc + theSelection = getSelection doc + (Palette palette) = Network.getPalette network + global = Network.getGlobalInfo network + + drawNode :: Int -> [Prop (DC ())] -> IO () + drawNode nodeNr options = + do{ + -- draw node + ; Shape.logicalDraw ppi dc center shape options + -- ; logicalCircle ppi dc center kNODE_RADIUS options + -- draw label + ; when (NodeLabel `elem` dpShowInfo opt) $ + drawLabel (offset above) False (Network.getName node) center + (justif above) [ textColor := wxcolor kNodeLabelColour ] + -- draw info + ; when (NodeInfo `elem` dpShowInfo opt) $ + drawLabel (offset (not above)) False (show (Network.getInfo node)) + center (justif (not above)) + [ textColor := wxcolor kNodeInfoColour ] + } + where + node = Network.getNode nodeNr network + above = Network.getNameAbove node + center = Network.getPosition node + shape = either (\name-> maybe Shape.circle fst + (Prelude.lookup name palette)) + id (Network.getShape node) + offset b = (if b then negate else id) kNODE_RADIUS + justif b = Justify CentreJ (if b then BottomJ else TopJ) + + drawLabel :: Double -> Bool -> String -> DoublePoint -> Justify + -> [Prop (DC ())] -> IO () + drawLabel voffset boxed text (DoublePoint x y) justify opts = + do{ -- draw background + when boxed $ do + { (textWidth, textHeight) <- logicalGetTextExtent ppi dc text + ; let horizontalMargin = 0.2 -- centimeters + verticalMargin = 0.01 -- centimeters + topleftY = y+voffset - case justify of + Justify _ TopJ -> 0 + Justify _ MiddleJ -> textHeight/2 + Justify _ BottomJ -> textHeight + + ; logicalRect ppi dc + (x - textWidth/2 - horizontalMargin) (topleftY) + (textWidth+2*horizontalMargin) (textHeight+2*verticalMargin) + (solidFill labelBackgroundColor) + } + -- draw text + ; logicalText ppi dc (DoublePoint x (y+voffset)) text justify opts + } + + drawEdge :: InfoKind e g => Network.Edge e -> [Prop (DC ())] -> IO () + drawEdge edge options = + do{ Shape.logicalLineSegments ppi dc (pt1:via++[pt2]) options + -- arrow on the end + ; logicalPoly ppi dc [pt2, tr1, tr2] (options ++ solidFill licorice) + -- draw info + ; when (EdgeInfo `elem` dpShowInfo opt) $ + -- logicalTextRotated ppi dc (middle via) (show info) 45 + -- [ textColor := wxcolor kEdgeInfoColour ] + drawLabel 0 False (show (Network.getEdgeInfo edge)) (middle via) + (Justify CentreJ BottomJ) + [ textColor := wxcolor kEdgeInfoColour ] + } + where + fromNode = Network.getNode (Network.getEdgeFrom edge) network + toNode = Network.getNode (Network.getEdgeTo edge) network + + fromPoint = Network.getPosition fromNode + toPoint = Network.getPosition toNode + via = Network.getEdgeVia edge + + fstEdgeVector = (head (via++[toPoint])) + `subtractDoublePointVector` fromPoint + fstTotalLen = vectorLength fstEdgeVector + fstAngle = vectorAngle fstEdgeVector + + penultimatePt = head (reverse (fromPoint:via)) + endEdgeVector = toPoint `subtractDoublePointVector` penultimatePt + endTotalLen = vectorLength endEdgeVector + endAngle = vectorAngle endEdgeVector + + middle [] = DoublePoint ((doublePointX pt1 + doublePointX pt2)/2) + ((doublePointY pt1 + doublePointY pt2)/2) + middle [p] = p + middle ps = middle (tail (reverse ps)) + + pt1 = translatePolar fstAngle kNODE_RADIUS fromPoint + pt2 = translatePolar endAngle (endTotalLen - kNODE_RADIUS) penultimatePt + + tr1 = translatePolar (endAngle + pi + pi / 6) kARROW_SIZE pt2 + tr2 = translatePolar (endAngle + pi - pi / 6) kARROW_SIZE pt2 + + drawVia :: Network.Edge e -> Network.ViaNr -> [Prop (DC ())] -> IO () + drawVia e n options = + let pt = (Network.getEdgeVia e)!!n in + do logicalCircle ppi dc pt kEDGE_CLICK_RANGE + (options ++ solidFill violet) + +solidFill :: Colour -> [Prop (DC ())] +solidFill colour = [ brushKind := BrushSolid, brushColor := wxcolor colour ] + +-- | Finds which node of the network is clicked by the mouse, if any +clickedNode :: DoublePoint -> Document g n e -> Maybe Int +clickedNode clickedPoint doc = + let network = getNetwork doc + nodeAssocs = case getSelection doc of + NodeSelection nodeNr -> [(nodeNr, Network.getNode nodeNr network)] + _ -> [] + ++ reverse (Network.getNodeAssocs network) + in case filter (\(_, node) -> node `nodeContains` clickedPoint) nodeAssocs of + [] -> Nothing + ((i, _):_) -> Just i + +nodeContains :: Network.Node n -> DoublePoint -> Bool +nodeContains node clickedPoint = + distancePointPoint (Network.getPosition node) clickedPoint + < kNODE_RADIUS + +-- | Finds which edge of the network is clicked by the mouse, if any +clickedEdge :: DoublePoint -> Network.Network g n e -> Maybe Int +clickedEdge clickedPoint network = + let assocs = Network.getEdgeAssocs network + in case filter (\(_, edge) -> isJust (edgeContains edge clickedPoint network)) assocs of + [] -> Nothing + ((i, _):_) -> Just i + +edgeContains :: Network.Edge e -> DoublePoint -> Network.Network g n e -> Maybe Int +edgeContains edge clickedPoint network = + let p0 = Network.getNodePosition network (Network.getEdgeFrom edge) + p1 = Network.getNodePosition network (Network.getEdgeTo edge) + via= Network.getEdgeVia edge + p = clickedPoint + numberedDistancesToSegments = zip [0..] $ + zipWith (\p0 p1-> distanceSegmentPoint p0 p1 p) + (p0:via) (via++[p1]) + in case [ nr | (nr,dist) <- numberedDistancesToSegments + , dist < kEDGE_CLICK_RANGE ] of + [] -> Nothing + nrs -> Just (head nrs) + +-- | Finds which 'via' control point is clicked by the mouse, if any +clickedVia :: DoublePoint -> Network.Network g n e -> Maybe (Int,Int) +clickedVia clickedPoint network = + let allVia = concatMap (\ (k,e)-> zipWith (\n v->((k,n),v)) + [0..] (Network.getEdgeVia e)) + (IntMap.toList (Network.networkEdges network)) + in case filter (\ (_,v)-> distancePointPoint v clickedPoint + < kEDGE_CLICK_RANGE) allVia of + [] -> Nothing + ((kn,_):_) -> Just kn + +-- Drawing operations in logical coordinates + +logicalCircle :: Size -> DC () -> DoublePoint -> Double -> [Prop (DC ())] -> IO () +logicalCircle ppi dc center radius options = + WX.circle dc (logicalToScreenPoint ppi center) (logicalToScreenX ppi radius) options + +logicalRect :: Size -> DC () -> Double -> Double -> Double -> Double -> [Prop (DC ())] -> IO () +logicalRect ppi dc x y width height options = + drawRect dc + (rect + (pt (logicalToScreenX ppi x) (logicalToScreenY ppi y)) + (sz (logicalToScreenX ppi width) (logicalToScreenY ppi height))) + options + +data Justify = Justify Horizontal Vertical deriving Eq +data Horizontal = LeftJ | CentreJ | RightJ deriving Eq +data Vertical = TopJ | MiddleJ | BottomJ deriving Eq + +-- can deal with multi-line text +logicalText :: Size -> DC () -> DoublePoint -> String -> Justify + -> [Prop (DC ())] -> IO () +logicalText ppi dc (DoublePoint x y) txt (Justify horiz vert) options = + do{ (width,height) <- logicalGetTextExtent ppi dc txt + ; eachLine width (startPos height) (lines txt) + } + where + startPos height = case vert of TopJ -> (x, y) + MiddleJ -> (x, y-height/2) + BottomJ -> (x, y-height) + eachLine _ _ [] = return () + eachLine maxwidth (x,y) (txt:txts) = + do{ (w,h) <- logicalGetTextExtent ppi dc txt + ; let thisX = case horiz of LeftJ -> x-maxwidth/2 + CentreJ -> x-w/2 + RightJ -> x+(maxwidth/2)-w + ; drawText dc txt (logicalToScreenPoint ppi (DoublePoint thisX y)) + options + ; eachLine maxwidth (x,y+h) txts + } + +-- currently assumes only single line of text +logicalTextRotated :: Size -> DC () -> DoublePoint -> String -> Double + -> [Prop (DC ())] -> IO () +logicalTextRotated ppi dc pos txt angle options = + draw dc txt (logicalToScreenPoint ppi pos) options + where + draw = if angle<1 && angle>(-1) then drawText + else (\a b c e -> rotatedText a b c angle e) + + +{- +logicalLine :: Size -> DC () -> DoublePoint -> DoublePoint -> [Prop (DC ())] -> IO () +logicalLine ppi dc fromPoint toPoint options = + line dc (logicalToScreenPoint ppi fromPoint) + (logicalToScreenPoint ppi toPoint) options + +logicalLineSegments :: Size -> DC () -> [DoublePoint] -> [Prop (DC ())] -> IO () +logicalLineSegments _ _ [p] options = return () +logicalLineSegments ppi dc (fromPoint:toPoint:ps) options = + do{ line dc (logicalToScreenPoint ppi fromPoint) + (logicalToScreenPoint ppi toPoint) options + ; logicalLineSegments ppi dc (toPoint:ps) options + } +-} + +logicalPoly :: Size -> DC () -> [DoublePoint] -> [Prop (DC ())] -> IO () +logicalPoly ppi dc points options = + polygon dc (map (logicalToScreenPoint ppi) points) options + +logicalGetTextExtent :: Size -> DC () -> String -> IO (Double, Double) +logicalGetTextExtent ppi dc txt = + do{ textSizes <- mapM (getTextExtent dc) (lines txt) + ; return + ( screenToLogicalX ppi (maximum (map sizeW textSizes)) + , screenToLogicalY ppi (sum (map sizeH textSizes)) + ) + } diff --git a/src/Graphics/Blobs/Operations.hs b/src/Graphics/Blobs/Operations.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Blobs/Operations.hs @@ -0,0 +1,50 @@ +module Graphics.Blobs.Operations where + +import Graphics.Blobs.InfoKind +import Graphics.Blobs.Network +import Graphics.Blobs.State +import Graphics.Blobs.Document +import qualified Graphics.Blobs.PersistentDocument as PD + +import qualified Data.IntMap as IntMap + +-- | @GraphOps@ is a data structure holding a bunch of named operations +-- on the graph network. An operation is simply executed in the I/O monad, +-- taking the entire state as argument - it is up to the action to do any +-- state updates it wants to. +data GraphOps g n e = GraphOps { ioOps :: [ (String, IOOp g n e) ] } + +callGraphOp :: String -> GraphOps g n e -> State g n e -> IO () +callGraphOp opName graphOps state = + maybe (return ()) ($ state) (Prelude.lookup opName (ioOps graphOps)) + +type PureOp g n e = -- (InfoKind n g, InfoKind e g) + (g, IntMap.IntMap (Node n), IntMap.IntMap (Edge e)) + -> (g, IntMap.IntMap (Node n), IntMap.IntMap (Edge e)) +type IOOp g n e = -- (InfoKind n g, InfoKind e g) => + State g n e + -> IO () + +-- | In general, operations can be classified into pure and I/O variants. +-- A pure operation takes a graph and returns a new graph, which is +-- stored back into the current document (can be reverted with the +-- standard 'undo' menu item), and displayed immediately. Use this +-- helper 'pureGraphOp' to turn your pure function into an I/O action +-- for the Operations menu. +pureGraphOp :: (String, PureOp g n e) -> (String, IOOp g n e) +pureGraphOp (opName,operation) = + (opName, \state-> do{ pDoc <- getDocument state + ; doc <- PD.getDocument pDoc + ; let network = getNetwork doc + g = getGlobalInfo network + n = networkNodes network + e = networkEdges network + (g',n',e') = operation (g,n,e) + network' = setNodeAssocs (IntMap.assocs n') + $ setEdgeAssocs (IntMap.assocs e') + $ setGlobalInfo g' + $ network + ; PD.updateDocument opName (setNetwork network') pDoc + } + ) + diff --git a/src/Graphics/Blobs/PDDefaults.hs b/src/Graphics/Blobs/PDDefaults.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Blobs/PDDefaults.hs @@ -0,0 +1,92 @@ +{-| Module : PDDefaults + Author : Arjan van IJzendoorn + License : do whatever you like with this + + Maintainer : afie@cs.uu.nl + + Some defaults for the field of the persistent document + record. For example, the default undo update function + changes the text of a menu item to reflect what will be + undo and disables it if there is nothing to be undone. + You might want more than the defaults if you have a + more advanced GUI. Let's say you also have a button + in a toolbar to undo, then you might want to gray out + that button, too, if there is nothing to be undone. +-} + +module Graphics.Blobs.PDDefaults where + +import Graphics.UI.WX +import Graphics.UI.WXCore(wxID_CANCEL) + +type Extensions = [(String, [String])] + +-- Update the menu item "Undo" to show which +-- action will be undone. If there is nothing +-- to undo the corresponding menu item is disabled +defaultUpdateUndo :: MenuItem () -> Bool -> String -> IO () +defaultUpdateUndo undoItem enable message = + set undoItem + [ text := "Undo " ++ message ++ "\tCtrl+Z" + , enabled := enable + ] + +defaultUpdateRedo :: MenuItem () -> Bool -> String -> IO () +defaultUpdateRedo redoItem enable message = + set redoItem + [ text := "Redo " ++ message ++ "\tCtrl+Y" + , enabled := enable + ] + +-- Enable the save item only if the document is dirty +defaultUpdateSave :: MenuItem () -> Bool -> IO () +defaultUpdateSave saveItem enable = + set saveItem [ enabled := enable ] + +-- Update the title bar: program name - document name followed by "(modified)" if +-- the document is dirty +defaultUpdateTitlebar :: Frame () -> String -> Maybe String -> Bool -> IO () +defaultUpdateTitlebar theFrame programName theFileName modified = + let newTitle = programName + ++ " - " + ++ (case theFileName of Nothing -> "untitled"; Just name -> name) + ++ (if modified then " (modified)" else "") + in set theFrame [ text := newTitle ] + +-- | defaultSaveChangesDialog shows a dialog with three buttons with corresponding +-- return values: Don't Save -> Just False, Save -> Just True +-- Cancel -> Nothing +defaultSaveChangesDialog :: Frame () -> String -> IO (Maybe Bool) +defaultSaveChangesDialog parentWindow theProgramName = + do{ d <- dialog parentWindow [text := theProgramName] + ; p <- panel d [] + ; msg <- staticText p [text := "Do you want to save the changes?"] + ; dontsaveB <- button p [text := "Don't Save"] + ; saveB <- button p [text := "Save"] + ; cancelB <- button p [text := "Cancel", identity := wxID_CANCEL ] + ; set d [layout := margin 10 $ container p $ + column 10 [ hfill $ widget msg + , row 50 [ floatBottomLeft $ widget dontsaveB + , floatBottomRight $ row 5 [ widget saveB, widget cancelB] + ] + ] + ] + -- ; set p [ defaultButton := saveB ] + ; set d [ defaultButton := saveB ] + ; showModal d $ \stop -> + do set dontsaveB [on command := stop (Just False) ] + set saveB [on command := stop (Just True) ] + set cancelB [on command := stop Nothing ] + } + +defaultSaveAsDialog :: Frame () -> Extensions -> Maybe String -> IO (Maybe String) +defaultSaveAsDialog theFrame extensions theFileName = + fileSaveDialog + theFrame + False -- remember current directory + True -- overwrite prompt + "Save file" + extensions + "" -- directory + (case theFileName of Nothing -> ""; Just name -> name) -- initial file name + diff --git a/src/Graphics/Blobs/Palette.hs b/src/Graphics/Blobs/Palette.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Blobs/Palette.hs @@ -0,0 +1,30 @@ +module Graphics.Blobs.Palette where + +import List (nub, (\\)) +-- import qualified Graphics.Blobs.Shape as Shape +import qualified Graphics.Blobs.Shape as Shape +import Text.Parse + +data Palette a = Palette [ (String, (Shape.Shape, Maybe a)) ] + deriving (Eq, Show, Read) + +shapes :: Palette a -> [ (String,(Shape.Shape,Maybe a)) ] +shapes (Palette p) = p + +join :: Eq a => Palette a -> Palette a -> Palette a +join (Palette p) (Palette q) = Palette (nub (p++q)) + +delete :: Eq a => Palette a -> Palette a -> Palette a +delete (Palette p) (Palette q) = Palette (p\\q) + +-- cannot be completely empty, always one default shape +empty :: Palette a +empty = Palette [("circle", (Shape.circle, Nothing))] + +instance Functor Palette where + fmap _ (Palette p) = Palette (map (\ (n,(s,i))-> (n,(s,Nothing))) p) + + +instance Parse a => Parse (Palette a) where + parse = do{ isWord "Palette"; fmap Palette $ parse } + diff --git a/src/Graphics/Blobs/PersistentDocument.hs b/src/Graphics/Blobs/PersistentDocument.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Blobs/PersistentDocument.hs @@ -0,0 +1,340 @@ +{-| Module : PersistentDocument + Author : Arjan van IJzendoorn + License : do whatever you like with this + + Maintainer : afie@cs.uu.nl + + The persistent document abstraction takes care of dealing + with a document you want to open from and save to disk and + that supports undo. This functionality can be used by editors + of arbitrary documents and saves you a lot of quite subtle + coding. You only need to initialise a record with things like + your document, the file name and call-back functions. After + this, the framework takes care of the hard work. The framework + is highly parametrisable but there are defaults for many + parameters. + + The features in detail: + - unlimited undo & redo buffers (or limited, if you choose to) + - undo and redo items show what will be undone / redone + (e.g. "Undo delete node") + - undo and redo items are disabled if there is nothing to undo or redo + - maintains a dirty bit that tells you whether the document has + changed with respect to the version on disk + - the save menu item can be disabled if the document is not dirty + - the title bar can be updated to show the program name, the file name + and whether the document is dirty (shown as "modified") + - when trying to close the document, the user is asked whether he/she + wants to save the changes (if needed) + - handles interaction between saving a document and the dirty bits + of the document and of the documents in the history and future + - properly handles Cancel or failure at any stage, e.g. the user + closes a dirty document with no file name, "Do you want to save + the changes" dialog is shown, user selects "Save", a Save as + dialog is opened, user selects a location that happens to be + read-only, saving fails and the closing of the document is + cancelled. +-} + +module Graphics.Blobs.PersistentDocument + ( PersistentDocument, PDRecord(..) + + -- , PersistentDocument.dummy + , dummy + , initialise + , resetDocument + + , setDocument, updateDocument + , superficialSetDocument, superficialUpdateDocument + + , getDocument + , getFileName, setFileName + , setDirty + + , undo, redo + , save, saveAs, isClosingOkay + ) where + +--import IOExts(IORef, newIORef, writeIORef, readIORef) +import Data.IORef(IORef, newIORef, writeIORef, readIORef) +import Monad(when) + +-- | A persistent document is a mutable variable. This way functions +-- operating on a document do not have to return the new value but +-- simply update it. +type PersistentDocument a = IORef (PDRecord a) + +-- | The persistent document record maintains all information needed +-- for undo, redo and file management +data PDRecord a = PD + { document :: a + + -- UNDO & REDO + , history :: [(String, Bool, a)] + -- ^ A history item contains a message (what will be undone), + -- the dirty bit and a copy of the document + , future :: [(String, Bool, a)] + -- ^ See history + , limit :: Maybe Int + -- ^ Maximum number of items of undo history. Or no limit + -- in the case of Nothing + + -- FILE MANAGEMENT + , fileName :: Maybe String + -- ^ Nothing means no file name yet (untitled) + , dirty :: Bool + -- ^ Has the document changed since saving? + + -- CALL-BACK FUNCTIONS + , updateUndo :: Bool -> String -> IO () + -- ^ This callback is called when the undo status changes. First parameter + -- means enable (True) or disable (False). Second parameter is the message + -- of the first item in the history + , updateRedo :: Bool -> String -> IO () + -- ^ See updateUndo + , updateSave :: Bool -> IO () + -- ^ This call-back is called when the save status changes. The boolean + -- indicates whether save is enabled (dirty document) or disabled (not dirty) + , updateTitleBar :: Maybe String -> Bool -> IO () + -- ^ This call-back is called when the title bar information changes: + -- file name and modified or not. + , saveToDisk :: String -> a -> IO Bool + -- ^ This callback should actually save the document to disk. It should + -- return False if saving fails (no permission, disk full...) + , saveChangesDialog :: IO (Maybe Bool) + -- ^ This call-back is called when the user should be prompted whether + -- he/she wants to save the changes or not. Results: + -- Don't Save -> Just False, Save -> Just True, Cancel -> Nothing + , saveAsDialog :: Maybe String -> IO (Maybe String) + -- ^ This call-back is called when the user should specify a + -- location and a name for the file. The parameter is the current + -- file name of the document + } + +-- | A dummy persistent document is needed because you need something to pass +-- to the command handlers of menu items BEFORE you can initialse the +-- persistent document with those menu items +dummy :: IO (PersistentDocument a) +dummy = newIORef (error $ "PersistentDocument.empty: call initialise before using " + ++ "the persistent document") + +-- | Initialise the persistent document with menu items (undo, redo, save), +-- information needed for open & save dialogs, for saving and for updating the +-- title bar +initialise :: PersistentDocument a -> PDRecord a -> IO () +initialise pDocRef pDoc = + do{ writeIORef pDocRef pDoc + ; updateGUI pDocRef + } + +-- | Clear the document and start with a given document with given file name +-- This function is typically called when you open a new document from disk +-- or start a fresh document that should replace the current document +resetDocument :: Maybe String -> a -> PersistentDocument a -> IO () +resetDocument theFileName doc pDocRef = + do{ updateIORef pDocRef (\pDoc -> pDoc + { document = doc + , history = [] + , future = [] + , fileName = theFileName + , dirty = False + }) + ; updateGUI pDocRef + } + +-- | Get the actual document stored within the persistent document +getDocument :: PersistentDocument a -> IO a +getDocument pDocRef = + do{ pDoc <- readIORef pDocRef + ; return (document pDoc) + } + +-- | Get the file name stored within the persistent document +getFileName :: PersistentDocument a -> IO (Maybe String) +getFileName pDocRef = + do{ pDoc <- readIORef pDocRef + ; return (fileName pDoc) + } + +-- | Get the file name stored within the persistent document +setFileName :: PersistentDocument a -> Maybe String -> IO () +setFileName pDocRef maybeName = + do{ pDoc <- readIORef pDocRef + ; writeIORef pDocRef (pDoc { fileName = maybeName }) + ; updateGUI pDocRef + } + +setDirty :: PersistentDocument a -> Bool -> IO () +setDirty pDocRef newDirtyBit = + do{ pDoc <- readIORef pDocRef + ; writeIORef pDocRef (pDoc { dirty = newDirtyBit }) + ; updateGUI pDocRef + } + +-- | Replace the document inside the persistent document. The current +-- document is remembered in the history list along with the given +-- message. The future list is cleared. +setDocument :: String -> a -> PersistentDocument a -> IO () +setDocument message newDoc pDocRef = + do{ pDoc <- readIORef pDocRef + ; let applyLimit = case limit pDoc of + Nothing -> id + Just nr -> take nr + newPDoc = + pDoc + { document = newDoc + , history = applyLimit $ (message,dirty pDoc,document pDoc):history pDoc + , future = [] + , dirty = True + } + ; writeIORef pDocRef newPDoc + ; updateGUI pDocRef + } + + +-- | Get document, apply function, set document +updateDocument :: String -> (a -> a) -> PersistentDocument a -> IO () +updateDocument message fun pDocRef = + do{ doc <- getDocument pDocRef + ; setDocument message (fun doc) pDocRef + } + +-- | Replace the document without remembering the old document in +-- the history. Superficial updates are useful if something as +-- volatile as a selection is part of your document. If the selection +-- changes you don't want to be able to undo it or to mark +-- the document as dirty +superficialSetDocument :: a -> PersistentDocument a -> IO () +superficialSetDocument newDoc pDocRef = + updateIORef pDocRef (\pDoc -> pDoc { document = newDoc }) + +-- | Get document, apply function, superficial set document +superficialUpdateDocument :: (a -> a) -> PersistentDocument a -> IO () +superficialUpdateDocument fun pDocRef = + do{ doc <- getDocument pDocRef + ; superficialSetDocument (fun doc) pDocRef + } + +-- | Check whether closing the document is okay. If the document +-- is dirty, the user is asked whether he/she wants to save the +-- changes. Returns False if this process is cancelled or fails +-- at any point. +isClosingOkay :: PersistentDocument a -> IO Bool +isClosingOkay pDocRef = + do{ pDoc <- readIORef pDocRef + ; if not (dirty pDoc) then return True else + do{ result <- saveChangesDialog pDoc + ; case result of + Nothing -> return False + Just True -> + do{ hasBeenSaved <- save pDocRef + ; return hasBeenSaved + } + Just False -> return True + }} + +-- | Save should be called when "Save" is selected from the file menu. +-- If there is no file name yet, this function acts as if "Save as" +-- was called. It returns False if saving is cancelled or fails. +save :: PersistentDocument a -> IO Bool +save pDocRef = + do{ pDoc <- readIORef pDocRef + ; case fileName pDoc of + Nothing -> saveAs pDocRef + Just name -> performSave name pDocRef + } + +-- | saveAs should be called when "Save As" is selected from the file menu. +-- A dialog is shown where the user can select a location to save document. +-- This function returns False if saving is cancelled or fails. +saveAs :: PersistentDocument a -> IO Bool +saveAs pDocRef = + do{ pDoc <- readIORef pDocRef + ; mbfname <- saveAsDialog pDoc (fileName pDoc) + ; case mbfname of + Just fname -> performSave fname pDocRef + Nothing -> return False + } + + +-- | The current document is stored in the future list +-- and the first element of the history list is taken +-- as the new document +undo :: PersistentDocument a -> IO () +undo pDocRef = + do{ pDoc <- readIORef pDocRef + ; when (not (null (history pDoc))) $ + do{ let (msg, newDirty, newDoc) = head (history pDoc) + newPDoc = pDoc + { document = newDoc + , dirty = newDirty + , history = tail (history pDoc) + , future = (msg, dirty pDoc, document pDoc) : future pDoc + } + ; writeIORef pDocRef newPDoc + ; updateGUI pDocRef + }} + +-- | The current document is stored in the history list +-- and the first element of the future list is taken +-- as the new document +redo :: PersistentDocument a -> IO () +redo pDocRef = + do{ pDoc <- readIORef pDocRef + ; when (not (null (future pDoc))) $ + do{ let (msg, newDirty, newDoc) = head (future pDoc) + newPDoc = pDoc + { document = newDoc + , dirty = newDirty + , future = tail (future pDoc) + , history = (msg, dirty pDoc, document pDoc) : history pDoc + } + ; writeIORef pDocRef newPDoc + ; updateGUI pDocRef + }} + +-- FUNCTIONS THAT ARE NOT EXPORTED + +updateIORef :: IORef a -> (a -> a) -> IO () +updateIORef var fun = do { x <- readIORef var; writeIORef var (fun x) } + +-- Perform the actual save to disk. If this fails False is returned +-- otherwise the file name is set and the dirty bit is cleared. The +-- dirty bits of history and future documents are set. +performSave :: String -> PersistentDocument a -> IO Bool +performSave name pDocRef = + do{ pDoc <- readIORef pDocRef + ; hasBeenSaved <- (saveToDisk pDoc) name (document pDoc) + ; if not hasBeenSaved then return False else + do{ writeIORef pDocRef (pDoc { fileName = Just name }) + ; updateDirtyBitsOnSave pDocRef + ; updateGUI pDocRef + ; return True + }} + +-- updateDirtyBitsOnSave clears the dirty bit for the +-- current document and sets the dirty bits of all +-- documents in history and future lists +updateDirtyBitsOnSave :: PersistentDocument a -> IO () +updateDirtyBitsOnSave pDocRef = + updateIORef pDocRef (\pDoc -> pDoc + { history = map makeDirty (history pDoc) + , future = map makeDirty (future pDoc) + , dirty = False + }) + where + makeDirty (msg, _, doc) = (msg, True, doc) + +-- Shorthand to call all call-backs that update the GUI +updateGUI :: PersistentDocument a -> IO () +updateGUI pDocRef = + do{ pDoc <- readIORef pDocRef + ; case history pDoc of + [] -> updateUndo pDoc False "" + ((msg, _, _):_) -> updateUndo pDoc True msg + ; case future pDoc of + [] -> updateRedo pDoc False "" + ((msg, _, _):_) -> updateRedo pDoc True msg + ; updateSave pDoc (dirty pDoc) + ; updateTitleBar pDoc (fileName pDoc) (dirty pDoc) + } diff --git a/src/Graphics/Blobs/SafetyNet.hs b/src/Graphics/Blobs/SafetyNet.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Blobs/SafetyNet.hs @@ -0,0 +1,24 @@ +module Graphics.Blobs.SafetyNet where + +import Graphics.UI.WX hiding (window) +import Prelude hiding (catch) +import Control.Exception (SomeException,Exception,catch) + + +safetyNet :: Window a -> IO b -> IO () +safetyNet window computation = + do{ catch + (do { computation; return () }) + (handler window) + ; return () + } + +handler :: Window a -> SomeException -> IO () +handler window exception = + do{ putStrLn $ "SafetyNet exception: " ++ show exception + ; errorDialog window "Exception" + ( "An exception occurred; please report the following text exactly to the makers: \n\n" + ++ show exception ++ "\n\n" + ++ "Please save the network under a different name and quit Blobs" + ) + } diff --git a/src/Graphics/Blobs/Shape.hs b/src/Graphics/Blobs/Shape.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Blobs/Shape.hs @@ -0,0 +1,177 @@ +module Graphics.Blobs.Shape + ( + Shape(..) + , ShapeStyle(..) + , circle + , logicalDraw + , logicalLineSegments + ) where + +import Graphics.Blobs.CommonIO +import qualified Graphics.UI.WX as WX +import Graphics.UI.WXCore hiding (Colour) +import Graphics.UI.WXCore.Draw +import Graphics.Blobs.Math +import Text.Parse +--import Text.XML.HaXml.XmlContent +--import NetworkFile + +import Graphics.Blobs.Colors +import Graphics.Blobs.Constants + +data Shape = + Circle { shapeStyle :: ShapeStyle, shapeRadius :: Double } + | Polygon { shapeStyle :: ShapeStyle, shapePerimeter :: [DoublePoint] } + -- centred on (0,0) + | Lines { shapeStyle :: ShapeStyle, shapePerimeter :: [DoublePoint] } + -- no fill for open shape + | Composite { shapeSegments :: [Shape] } -- drawn in given order + deriving (Eq, Show, Read) + +data ShapeStyle = ShapeStyle + { styleStrokeWidth :: Int + , styleStrokeColour :: Colour + , styleFill :: Colour + } + deriving (Eq, Show, Read) + +instance Parse Shape where + parse = oneOf + [ do{ isWord "Circle" + ; return Circle + `discard` isWord "{" `apply` field "shapeStyle" + `discard` isWord "," `apply` field "shapeRadius" + `discard` isWord "}" + } + , do{ isWord "Polygon" + ; return Polygon + `discard` isWord "{" `apply` field "shapeStyle" + `discard` isWord "," `apply` field "shapePerimeter" + `discard` isWord "}" + } + , do{ isWord "Lines" + ; return Lines + `discard` isWord "{" `apply` field "shapeStyle" + `discard` isWord "," `apply` field "shapePerimeter" + `discard` isWord "}" + } + , do{ isWord "Composite" + ; return Composite + `discard` isWord "{" `apply` field "shapeSegments" + `discard` isWord "}" + } + ] `adjustErr` (++"\nexpected a Shape (Circle,Polygon,Lines,Composite)") + +instance Parse ShapeStyle where + parse = do{ isWord "ShapeStyle" + ; return ShapeStyle + `discard` isWord "{" `apply` field "styleStrokeWidth" + `discard` isWord "," `apply` field "styleStrokeColour" + `discard` isWord "," `apply` field "styleFill" + `discard` isWord "}" + } + +{- +instance HTypeable Shape where + toHType s = Defined "Shape" [] [ Constr "Circle" [] [] + , Constr "Polygon" [] [] + , Constr "Lines" [] [] + , Constr "Composite" [] [] + ] +instance XmlContent Shape where + toContents s@(Circle{}) = + [ mkElemC "Circle" (toContents (shapeStyle s) + ++ [mkElemC "radius" (toContents (shapeRadius s))]) ] + toContents s@(Polygon{}) = + [ mkElemC "Polygon" (toContents (shapeStyle s) + ++ [mkElemC "perimeter" (concatMap toContents + (shapePerimeter s))]) ] + toContents s@(Lines{}) = + [ mkElemC "Lines" (toContents (shapeStyle s) + ++ [mkElemC "perimeter" (concatMap toContents + (shapePerimeter s))]) ] + toContents s@(Composite{}) = + [ mkElemC "Composite" (concatMap toContents (shapeSegments s)) ] + parseContents = do + { e@(Elem t _ _) <- element ["Circle","Polygon","Lines","Composite"] + ; case t of + "Circle" -> interior e $ + do{ style <- parseContents + ; r <- inElement "radius" parseContents + ; return (Circle {shapeStyle=style, shapeRadius=r}) + } + "Polygon" -> interior e $ + do{ style <- parseContents + ; p <- inElement "perimeter" $ many1 parseContents + ; return (Polygon {shapeStyle=style, shapePerimeter=p}) + } + "Lines" -> interior e $ + do{ style <- parseContents + ; p <- inElement "perimeter" $ many1 parseContents + ; return (Lines {shapeStyle=style, shapePerimeter=p}) + } + "Composite" -> interior e $ do{ ss <- many1 parseContents + ; return (Composite {shapeSegments=ss}) + } + } + +instance HTypeable ShapeStyle where + toHType s = Defined "ShapeStyle" [] [Constr "ShapeStyle" [] []] +instance XmlContent ShapeStyle where + toContents s = + [ mkElemC "ShapeStyle" + [ mkElemC "StrokeWidth" (toContents (styleStrokeWidth s)) + , mkElemC "StrokeColour" (toContents (styleStrokeColour s)) + , mkElemC "Fill" (toContents (styleFill s)) + ] + ] + parseContents = inElement "ShapeStyle" $ do + { w <- inElement "StrokeWidth" parseContents + ; c <- inElement "StrokeColour" parseContents + ; f <- inElement "Fill" parseContents + ; return (ShapeStyle { styleStrokeWidth=w, styleStrokeColour=c + , styleFill=f }) + } +-} + +logicalDraw :: Size -> DC () -> DoublePoint -> Shape -> [WX.Prop (DC ())] -> IO () +logicalDraw ppi dc centre shape options = + case shape of + Circle {} -> WX.circle dc (logicalToScreenPoint ppi centre) + (logicalToScreenX ppi (shapeRadius shape)) + (style2options (shapeStyle shape)++options) + Polygon {} -> WX.polygon dc (map (logicalToScreenPoint ppi + . translate centre) + (shapePerimeter shape)) + (style2options (shapeStyle shape)++options) + Lines {} -> logicalLineSegments ppi dc (map (translate centre) + (shapePerimeter shape)) + (style2options (shapeStyle shape)++options) + Composite {}-> mapM_ (\s-> logicalDraw ppi dc centre s options) + (shapeSegments shape) + +logicalLineSegments :: Size -> DC () -> [DoublePoint] -> [WX.Prop (DC ())] -> IO () +logicalLineSegments _ _ [_p] _options = return () +logicalLineSegments ppi dc (fromPoint:toPoint:ps) options = + do{ WX.line dc (logicalToScreenPoint ppi fromPoint) + (logicalToScreenPoint ppi toPoint) options + ; logicalLineSegments ppi dc (toPoint:ps) options + } + +circle :: Shape +circle = Circle { shapeStyle = defaultShapeStyle + , shapeRadius = kNODE_RADIUS } + +style2options :: ShapeStyle -> [WX.Prop (DC ())] +style2options sty = + [ WX.penWidth WX.:= styleStrokeWidth sty + , WX.penColor WX.:= wxcolor (styleStrokeColour sty) + , WX.brushKind WX.:= BrushSolid + , WX.brushColor WX.:= wxcolor (styleFill sty) + ] + +defaultShapeStyle :: ShapeStyle +defaultShapeStyle = + ShapeStyle { styleStrokeWidth = 1 + , styleStrokeColour = licorice + , styleFill = nodeColor } diff --git a/src/Graphics/Blobs/State.hs b/src/Graphics/Blobs/State.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Blobs/State.hs @@ -0,0 +1,108 @@ +module Graphics.Blobs.State + ( State + , Graphics.Blobs.State.empty + , ToolWindow(..) + + , getDocument + , getDragging, setDragging + , getCanvas, setCanvas + , getNetworkFrame, setNetworkFrame + , getPageSetupDialog, setPageSetupDialog + , getDisplayOptions, setDisplayOptions + , changeDisplayOptions + ) where + +import Graphics.Blobs.Document +import Graphics.Blobs.Math +import qualified Graphics.Blobs.PersistentDocument as PD +import qualified Graphics.Blobs.DisplayOptions as DisplayOptions + +import Graphics.UI.WX +import Graphics.UI.WXCore hiding (Document, ToolWindow) + +type State g n e = Var (StateRecord g n e) + +data StateRecord g n e = St + { stDocument :: PD.PersistentDocument (Document g n e) + , stDragging :: Maybe (Bool, DoublePoint) -- ^ (really moved?, offset from center of node) + , stNetworkFrame :: Frame () + , stCanvas :: ScrolledWindow () + , stPageSetupDialog :: PageSetupDialog () + , stDisplayOptions :: DisplayOptions.DisplayOptions + } + +data ToolWindow = TW + { twRepaint :: IO () + , twFrame :: Frame () + } + +empty :: IO (State g n e) +empty = + do{ dummy <- PD.dummy + + ; varCreate (St + { stDocument = dummy + , stNetworkFrame = error "State.empty: network frame has not been set" + , stDragging = Nothing + , stCanvas = error "State.empty: canvas has not been set" + , stPageSetupDialog = error "State.empty: page setup dialog has not been set" + , stDisplayOptions = DisplayOptions.standard + }) + } + +-- Getters + +getDocument :: State g n e -> IO (PD.PersistentDocument (Document g n e)) +getDocument = getFromState stDocument + +getDragging :: State g n e -> IO (Maybe (Bool, DoublePoint)) +getDragging = getFromState stDragging + +getNetworkFrame :: State g n e -> IO (Frame ()) +getNetworkFrame = getFromState stNetworkFrame + +getCanvas :: State g n e -> IO (ScrolledWindow ()) +getCanvas = getFromState stCanvas + +getPageSetupDialog :: State g n e -> IO (PageSetupDialog ()) +getPageSetupDialog = getFromState stPageSetupDialog + +getDisplayOptions :: State g n e -> IO DisplayOptions.DisplayOptions +getDisplayOptions = getFromState stDisplayOptions + +-- Setters + +setDragging :: Maybe (Bool, DoublePoint) -> State g n e -> IO () +setDragging theDragging stateRef = + varUpdate_ stateRef (\state -> state { stDragging = theDragging }) + +setNetworkFrame :: Frame () -> State g n e -> IO () +setNetworkFrame networkFrame stateRef = + varUpdate_ stateRef (\state -> state { stNetworkFrame = networkFrame }) + +setCanvas :: ScrolledWindow () -> State g n e -> IO () +setCanvas canvas stateRef = + varUpdate_ stateRef (\state -> state { stCanvas = canvas }) + +setPageSetupDialog :: PageSetupDialog () -> State g n e -> IO () +setPageSetupDialog thePageSetupDialog stateRef = + varUpdate_ stateRef (\state -> state { stPageSetupDialog = thePageSetupDialog }) + +setDisplayOptions :: DisplayOptions.DisplayOptions -> State g n e -> IO () +setDisplayOptions dp stateRef = + varUpdate_ stateRef (\state -> state { stDisplayOptions = dp }) + +changeDisplayOptions :: (DisplayOptions.DisplayOptions->DisplayOptions.DisplayOptions) -> State g n e -> IO () +changeDisplayOptions dpf stateRef = + varUpdate_ stateRef + (\state -> state { stDisplayOptions = dpf (stDisplayOptions state) }) + +-- Utility functions + +getFromState :: (StateRecord g n e -> a) -> State g n e -> IO a +getFromState selector stateRef = do + state <- varGet stateRef + return (selector state) + +varUpdate_ :: Var a -> (a -> a) -> IO () +varUpdate_ var fun = do { varUpdate var fun; return () } diff --git a/src/Graphics/Blobs/StateUtil.hs b/src/Graphics/Blobs/StateUtil.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Blobs/StateUtil.hs @@ -0,0 +1,26 @@ +module Graphics.Blobs.StateUtil + ( repaintAll + , getNetworkName + ) where + +import Graphics.Blobs.State +import Graphics.Blobs.Common +import qualified Graphics.Blobs.PersistentDocument as PD + +import Maybe +import Graphics.UI.WX + +repaintAll :: State g n e -> IO () +repaintAll state = + do{ canvas <- getCanvas state + ; Graphics.UI.WX.repaint canvas + } + +getNetworkName :: State g n e -> IO String +getNetworkName state = + do { pDoc <- getDocument state + ; mFilename <- PD.getFileName pDoc + ; case mFilename of + Just filename -> return $ removeExtension filename + Nothing -> return "Untitled" + } diff --git a/src/InfoKind.hs b/src/InfoKind.hs deleted file mode 100644 --- a/src/InfoKind.hs +++ /dev/null @@ -1,45 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE UndecidableInstances #-} -module InfoKind where - -import Text.Parse ---import Text.XML.HaXml.XmlContent -import Text.XML.HaXml.XmlContent.Haskell - --- | The @InfoKind@ class is a predicate that ensures we can always create --- at least a blank (empty) information element, that we can read and --- write them to/from the user, and that there exists some method of --- determining the correctness of the value (completeness/consistency etc) --- against some global type. -class (Eq a, Show a, Parse a, XmlContent a) => InfoKind a g | a -> g where - blank :: a - check :: String -> g -> a -> [String] -- returns warnings - -- ^ first arg is container label for error reporting. - -- second arg is global value - --- A basic instance representing "no info" -instance InfoKind () () where - blank = () - check _ _ () = [] --- Assume that info is mandatory, but not supplied a priori. -instance InfoKind a b => InfoKind (Maybe a) b where - blank = Nothing - check n _ Nothing = ["No info value stored with "++n] - check n g (Just a) = check n g a - --- A "showType"-style class. Descriptor should always ignore its argument, --- and return a constant string describing the type instead. -class (Show a) => Descriptor a where - descriptor :: a -> String - descriptor _ = "type descriptor was left undefined" -instance Descriptor () where - descriptor _ = "null global info type" - --- ----------------------------------------------- -{- -instance XmlContent () where - toContents = undefined - parseContents = undefined --} diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -2,13 +2,13 @@ {-# LANGUAGE MultiParamTypeClasses #-} module Main (main, gain) where -import NetworkUI +import qualified Graphics.Blobs.NetworkUI as NetworkUI import Graphics.UI.WX -import State -import InfoKind +import qualified Graphics.Blobs.State as State +import Graphics.Blobs.InfoKind -import Network -import Operations +import Graphics.Blobs.Network +import Graphics.Blobs.Operations --import IntMap (IntMap) import qualified Data.IntMap as IntMap import List (nub) diff --git a/src/Math.hs b/src/Math.hs deleted file mode 100644 --- a/src/Math.hs +++ /dev/null @@ -1,110 +0,0 @@ -module Math - ( DoublePoint(..), Vector - , doublePointX, doublePointY - , intPointToDoublePoint - , doublePointToIntPoint - , translatePolar - , distancePointPoint - , distanceSegmentPoint - , subtractDoublePoint - , subtractDoublePointVector - , vectorLength - , vectorAngle - , origin - , translate - , enclosedInRectangle - ) where - -import Graphics.UI.WX(Point, point, pointX, pointY) -import Text.Parse - -{- -data DoublePoint = DoublePoint - { doublePointX :: !Double - , doublePointY :: !Double - } - deriving (Show, Eq, Read) --} -data DoublePoint = DoublePoint !Double !Double - deriving (Show, Eq, Read) - -instance Parse DoublePoint where - parse = do { isWord "DoublePoint" - ; return DoublePoint `apply` parse `apply` parse - } - -data Vector = Vector !Double !Double - -doublePointX (DoublePoint x _) = x -doublePointY (DoublePoint _ y) = y - -origin :: DoublePoint -origin = DoublePoint 0 0 - --- | Compute distance between two points -distancePointPoint :: DoublePoint -> DoublePoint -> Double -distancePointPoint (DoublePoint x0 y0) (DoublePoint x1 y1) = - sqrt (square (x0 - x1) + square (y0 - y1)) - -square :: Double -> Double -square d = d*d - --- | Compute distance from a segment (as opposed to a line) to a point --- Formulas taken from --- -distanceSegmentPoint :: DoublePoint -> DoublePoint -> DoublePoint -> Double -distanceSegmentPoint p0 p1 p = - let v = p1 `subtractDoublePointVector` p0 - w = p `subtractDoublePointVector` p0 - c1 = dotProduct w v - c2 = dotProduct v v - in if c1 <= 0 then distancePointPoint p p0 - else if c2 <= c1 then distancePointPoint p p1 - else distanceLinePoint p0 p1 p - --- | Compute distance from a line to a point -distanceLinePoint :: DoublePoint -> DoublePoint -> DoublePoint -> Double -distanceLinePoint (DoublePoint x0 y0) (DoublePoint x1 y1) (DoublePoint x y) = - abs ( ( (y0 - y1) * x + (x1 - x0) * y + (x0 * y1 - x1 * y0) ) / - sqrt (square (x1 - x0) + square (y1 - y0)) - ) - -subtractDoublePointVector :: DoublePoint -> DoublePoint -> Vector -subtractDoublePointVector (DoublePoint x0 y0) (DoublePoint x1 y1) = - Vector (x0 - x1) (y0 - y1) - --- | Translate a point relative to a new origin -translate :: DoublePoint -> DoublePoint -> DoublePoint -translate (DoublePoint originX originY) (DoublePoint x y) = - DoublePoint (x+originX) (y+originY) - -subtractDoublePoint :: DoublePoint -> DoublePoint -> DoublePoint -subtractDoublePoint (DoublePoint x0 y0) (DoublePoint x1 y1) = - DoublePoint (x0 - x1) (y0 - y1) - -dotProduct :: Vector -> Vector -> Double -dotProduct (Vector v1 v2) (Vector w1 w2) = v1 * w1 + v2 * w2 - -translatePolar :: Double -> Double -> DoublePoint -> DoublePoint -translatePolar angle distance (DoublePoint x y) = - DoublePoint (x + cos angle * distance) (y + sin angle * distance) - -doublePointToIntPoint :: DoublePoint -> Point -doublePointToIntPoint (DoublePoint x y) = point (round x) (round y) - -intPointToDoublePoint :: Point -> DoublePoint -intPointToDoublePoint pt = - DoublePoint (fromIntegral (pointX pt)) (fromIntegral (pointY pt)) - -vectorAngle :: Vector -> Double -vectorAngle (Vector v1 v2) = atan2 v2 v1 - -vectorLength :: Vector -> Double -vectorLength (Vector v1 v2) = sqrt (square v1 + square v2) - -enclosedInRectangle :: DoublePoint -> DoublePoint -> DoublePoint -> Bool -enclosedInRectangle (DoublePoint x y) (DoublePoint x0 y0) (DoublePoint x1 y1) = - between x x0 x1 && between y y0 y1 - where - between i j k | j <= k = j <= i && i <= k - | otherwise = k <= i && i <= j diff --git a/src/Network.hs b/src/Network.hs deleted file mode 100644 --- a/src/Network.hs +++ /dev/null @@ -1,578 +0,0 @@ -module Network - ( - -- * Types - Network, Node, Edge - , NodeNr, EdgeNr, ViaNr - , networkNodes -- dangerous - , networkEdges -- dangerous - - -- * Creating and printing a network - , Network.empty - , dumpNetwork - - , getNodeNrs - , getNodeAssocs, setNodeAssocs - , getEdgeAssocs, setEdgeAssocs - , getCanvasSize, setCanvasSize - , getPalette, setPalette - , getGlobalInfo, setGlobalInfo - - , getNode - , getEdge - , getNodes - , getEdges - , getChildren - , getParents - , getParentMap, ParentMap - - , nodeExists, edgeExists - , findEdge, findNodeNrsByName - - , updateNode - , updateEdge - , updateVia - - , mapNodeNetwork - - , addNode, addNodes, removeNode, addNodeEx - , addEdge, addEdges, removeEdge, addEdgeWithPorts - , removeAllEdges - , newViaEdge, removeVia - - , constructNode - , getNodeInfo, getNodeName, getNodePosition, getNodeNameAbove, getNodeShape - , setNodeInfo, setNodeName, setNodePosition, setNodeNameAbove, setNodeShape - , getNodeArity - , setNodeArity - , getInfo, getName, getPosition, getNameAbove, getShape, getArity - , setInfo, setName, setPosition, setNameAbove, setShape, setArity - - , constructEdge - , getEdgeFrom, getEdgeTo, getEdgeVia, getEdgeInfo - , setEdgeFrom, setEdgeTo, setEdgeVia, setEdgeInfo - , getEdgeFromPort, getEdgeToPort - , setEdgeFromPort, setEdgeToPort - ) where - -import Common -import Math -import InfoKind -import Shape -import Palette hiding (delete) - -import qualified Data.IntMap as IntMap -- hiding (map) - -data Network g n e = Network - { networkNodes :: !(IntMap.IntMap (Node n)) -- ^ maps node numbers to nodes - , networkEdges :: !(IntMap.IntMap (Edge e)) -- ^ maps edge numbers to edges - , networkPalette :: Palette n - , networkCanvasSize :: (Double, Double) - , networkInfo :: g - } deriving Show - -data Edge e = Edge - { edgeFrom :: !NodeNr -- ^ the number of the node where the edge starts - , edgeTo :: !NodeNr -- ^ the number of the node the edge points to - , edgeVia :: [DoublePoint] -- ^ intermediate vertices when drawing - , edgeInfo :: e - , edgeFromPort :: !PortNr -- ^ the connection port on the 'from' node - , edgeToPort :: !PortNr -- ^ the connection port on the 'to' node - } deriving (Show, Read, Eq) - -data Node n = Node - { nodePosition :: DoublePoint -- ^ the position of the node on screen - , nodeName :: !String - , nodeNameAbove :: Bool -- ^ should the name be displayed above (True) of below (False) - , nodeShape :: Either String Shape -- ^ name from palette, or shape - , nodeInfo :: n - , nodeArity :: Maybe (PortNr,PortNr) -- ^ number of in/out connection ports - } deriving (Show, Read) - -type NodeNr = Int -type EdgeNr = Int -type ViaNr = Int -type PortNr = Int - --- | Create an empty network -empty :: (InfoKind n g, InfoKind e g) => g -> n -> e -> Network g n e -empty g _ _ = Network - { networkNodes = IntMap.empty - , networkEdges = IntMap.empty - , networkPalette = Palette.empty - , networkCanvasSize = (15, 9) - , networkInfo = g - } - --- | Map a function over the nodes, possibly changes the type --- of the Network (i.e. the kind of values stored in the --- probability tables) -mapNodeNetwork :: InfoKind m g => - (Node n->Node m) -> Network g n e -> Network g m e -mapNodeNetwork nodeFun network = - let numberedNodes = getNodeAssocs network - newNodes = [ (nr, nodeFun node) | (nr, node) <- numberedNodes ] - in Network - { networkNodes = IntMap.fromList newNodes - , networkEdges = networkEdges network - , networkPalette = fmap (const blank) $ networkPalette network - , networkCanvasSize = networkCanvasSize network - , networkInfo = networkInfo network - } - -constructEdge :: NodeNr -> PortNr -> NodeNr -> PortNr - -> [DoublePoint] -> e -> Edge e -constructEdge fromNr fromPort toNr toPort via info = - Edge - { edgeFrom = fromNr - , edgeTo = toNr - , edgeVia = via - , edgeInfo = info - , edgeFromPort = fromPort - , edgeToPort = toPort - } - -getEdgeFrom :: Edge e -> NodeNr -getEdgeFrom = edgeFrom - -getEdgeFromPort :: Edge e -> PortNr -getEdgeFromPort = edgeFromPort - -getEdgeTo :: Edge e -> NodeNr -getEdgeTo = edgeTo - -getEdgeToPort :: Edge e -> PortNr -getEdgeToPort = edgeToPort - -getEdgeVia :: Edge e -> [DoublePoint] -getEdgeVia = edgeVia - -getEdgeInfo :: Edge e -> e -getEdgeInfo = edgeInfo - -setEdgeFrom :: NodeNr -> Edge e -> Edge e -setEdgeFrom fromNr edge = edge { edgeFrom = fromNr } - -setEdgeFromPort :: PortNr -> Edge e -> Edge e -setEdgeFromPort fromPortNr edge = edge { edgeFromPort = fromPortNr } - -setEdgeTo :: NodeNr -> Edge e -> Edge e -setEdgeTo toNr edge = edge { edgeTo = toNr } - -setEdgeToPort :: PortNr -> Edge e -> Edge e -setEdgeToPort toPortNr edge = edge { edgeToPort = toPortNr } - -setEdgeVia :: [DoublePoint] -> Edge e -> Edge e -setEdgeVia via edge = edge { edgeVia = via } - -setEdgeInfo :: e -> Edge oldInfo -> Edge e -setEdgeInfo info edge = edge { edgeInfo = info } - -constructNode :: (InfoKind n g) => - String -> DoublePoint -> Bool - -> Either String Shape -> n -> Maybe (PortNr,PortNr) -> Node n -constructNode name position nameAbove shape info arity = - Node - { nodeName = name - , nodePosition = position - , nodeNameAbove = nameAbove - , nodeShape = shape - , nodeInfo = info - , nodeArity = arity - } - -getNodeName :: Network g n e -> NodeNr -> String -getNodeName network nodeNr = nodeName (networkNodes network IntMap.! nodeNr) - -setNodeName :: NodeNr -> String -> Network g n e -> Network g n e -setNodeName nodeNr name network = - network { networkNodes = IntMap.insert nodeNr (node { nodeName = name }) (networkNodes network) } - where node = networkNodes network IntMap.! nodeNr - -getNodePosition :: Network g n e -> NodeNr -> DoublePoint -getNodePosition network nodeNr = nodePosition (networkNodes network IntMap.! nodeNr) - -setNodePosition :: NodeNr -> DoublePoint -> Network g n e -> Network g n e -setNodePosition nodeNr position network = - network { networkNodes = IntMap.insert nodeNr (node { nodePosition = position }) (networkNodes network) } - where node = networkNodes network IntMap.! nodeNr - -getNodeNameAbove :: Network g n e -> NodeNr -> Bool -getNodeNameAbove network nodeNr = nodeNameAbove (networkNodes network IntMap.! nodeNr) - -setNodeNameAbove :: NodeNr -> Bool -> Network g n e -> Network g n e -setNodeNameAbove nodeNr nameAbove network = - network { networkNodes = IntMap.insert nodeNr (node { nodeNameAbove = nameAbove }) (networkNodes network) } - where node = networkNodes network IntMap.! nodeNr - -getNodeShape :: Network g n e -> NodeNr -> Either String Shape -getNodeShape network nodeNr = nodeShape (networkNodes network IntMap.! nodeNr) - -setNodeShape :: NodeNr -> Either String Shape -> Network g n e -> Network g n e -setNodeShape nodeNr shape network = - network { networkNodes = IntMap.insert nodeNr (node { nodeShape = shape }) - (networkNodes network) } - where node = networkNodes network IntMap.! nodeNr - -getNodeInfo :: Network g n e -> NodeNr -> n -getNodeInfo network nodeNr = nodeInfo (networkNodes network IntMap.! nodeNr) - -setNodeInfo :: NodeNr -> n -> Network g n e -> Network g n e -setNodeInfo nodeNr info network = - network { networkNodes = IntMap.insert nodeNr (node { nodeInfo = info }) (networkNodes network) } - where node = networkNodes network IntMap.! nodeNr - -getNodeArity :: Network g n e -> NodeNr -> Maybe (PortNr,PortNr) -getNodeArity network nodeNr = nodeArity (networkNodes network IntMap.! nodeNr) - -setNodeArity :: NodeNr -> Maybe (PortNr,PortNr) -> Network g n e - -> Network g n e -setNodeArity nodeNr arity network = - network { networkNodes = IntMap.insert nodeNr (node { nodeArity = arity }) - (networkNodes network) } - where node = networkNodes network IntMap.! nodeNr - -getNameAbove :: Node a -> Bool -getNameAbove node = nodeNameAbove node - -getName :: Node a -> String -getName node = nodeName node - -getShape :: Node a -> Either String Shape -getShape node = nodeShape node - -getPosition :: Node a -> DoublePoint -getPosition node = nodePosition node - -getInfo :: Node a -> a -getInfo node = nodeInfo node - -getArity :: Node a -> Maybe (PortNr,PortNr) -getArity node = nodeArity node - --- | Set whether the name should appear above (True) or below (False) the node -setNameAbove :: Bool -> Node a -> Node a -setNameAbove above node = node { nodeNameAbove = above } - -setName :: String -> Node a -> Node a -setName name node = node { nodeName = name } - -setShape :: Either String Shape -> Node a -> Node a -setShape s node = node { nodeShape = s } - -setPosition :: DoublePoint -> Node a -> Node a -setPosition position node = node { nodePosition = position } - -setInfo :: a -> Node a -> Node a -setInfo info node = node { nodeInfo = info } - -setArity :: Maybe (PortNr,PortNr) -> Node a -> Node a -setArity arity node = node { nodeArity = arity } - --- | Get the next unused node number -getUnusedNodeNr :: Network g n e -> NodeNr -getUnusedNodeNr network | null used = 1 - | otherwise = maximum used + 1 - where - used = IntMap.keys (networkNodes network) - --- | Get the next unused edge number -getUnusedEdgeNr :: Network g n e -> EdgeNr -getUnusedEdgeNr network | null used = 1 - | otherwise = maximum used + 1 - where - used = IntMap.keys (networkEdges network) - --- | Get the node numbers of the parents of a given node -getParents :: Network g n e -> NodeNr -> [NodeNr] -getParents network child = - [ parent - | edge <- getEdges network - , edgeTo edge == child - , let parent = edgeFrom edge - ] - -type ParentMap = IntMap.IntMap [NodeNr] - --- | getParents is quite expensive (see above) and so --- we store the parent relationship in an IntMap -getParentMap :: Network g n e -> ParentMap -getParentMap network = - IntMap.fromList - [ (nodeNr, getParents network nodeNr) - | nodeNr <- getNodeNrs network - ] - --- | Get the node numbers of the children of a given node -getChildren :: Network g n e -> NodeNr -> [NodeNr] -getChildren network parent = - [ child - | edge <- getEdges network - , edgeFrom edge == parent - , let child = edgeTo edge - ] - - --- | Get node with given index, raises exception if node number does not exist -getNode :: NodeNr -> Network g n e -> Node n -getNode nodeNr network - | IntMap.member nodeNr nodesMap = nodesMap IntMap.! nodeNr - | otherwise = internalError "Network" "getNode" "illegal node number" - where - nodesMap = networkNodes network - --- | Get edge with given index, raises exception if edge number does not exist -getEdge :: EdgeNr -> Network g n e -> Edge e -getEdge edgeNr network = networkEdges network IntMap.! edgeNr - --- | Get all of the nodes in the network -getNodes :: Network g n e -> [Node n] -getNodes network = IntMap.elems (networkNodes network) - --- | Get all of the edges in the network -getEdges :: Network g n e -> [Edge e] -getEdges network = IntMap.elems (networkEdges network) - --- | Get all of the node numbers in the network -getNodeNrs :: Network g n e -> [NodeNr] -getNodeNrs network = IntMap.keys (networkNodes network) - -getPalette :: Network g n e -> Palette n -getPalette network = networkPalette network - -getCanvasSize :: Network g n e -> (Double, Double) -getCanvasSize network = networkCanvasSize network - -getGlobalInfo :: Network g n e -> g -getGlobalInfo network = networkInfo network - --- | Find the number of an edge given start and end node number -findEdge :: NodeNr -> NodeNr -> Network g n e -> Maybe EdgeNr -findEdge fromNodeNr toNodeNr network = - let hits = IntMap.filter - (sameFromAndTo (Edge { edgeFrom = fromNodeNr - , edgeTo = toNodeNr - , edgeVia = undefined - , edgeInfo = undefined - , edgeFromPort = 0 - , edgeToPort = 0 })) - (networkEdges network) - in case IntMap.keys hits of - [key] -> Just key - _ -> Nothing - --- | Find node numbers given a node name -findNodeNrsByName :: String -> Network g n e -> [NodeNr] -findNodeNrsByName theNodeName network = - [ nodeNr - | nodeNr <- getNodeNrs network - , getNodeName network nodeNr == theNodeName - ] - --- | Get a list of pairs where each pair contains a node number and the corresponding node -getNodeAssocs :: Network g n e -> [(NodeNr, Node n)] -getNodeAssocs network = IntMap.assocs (networkNodes network) - -setNodeAssocs :: [(NodeNr, Node n)] -> Network g n e -> Network g n e -setNodeAssocs nodeAssocs network = - network { networkNodes = IntMap.fromList nodeAssocs } - --- | Get a list of pairs where each pair contains a edge number and the corresponding edge -getEdgeAssocs :: Network g n e -> [(EdgeNr, Edge e)] -getEdgeAssocs network = IntMap.assocs (networkEdges network) - -setEdgeAssocs :: [(EdgeNr, Edge e)] -> Network g n e -> Network g n e -setEdgeAssocs edgeAssocs network = - network { networkEdges = IntMap.fromList edgeAssocs } - --- | Create a string that describes the network -dumpNetwork :: InfoKind e g => Network g String e -> String -dumpNetwork network = show (getNodeAssocs network) ++ "\n" ++ show (getEdgeAssocs network) - --- | Test for existence of a node number -nodeExists :: NodeNr -> Network g n e -> Bool -nodeExists nodeNr network = - IntMap.member nodeNr (networkNodes network) - --- | Test for existence of an edge number -edgeExists :: EdgeNr -> Network g n e -> Bool -edgeExists edgeNr network = - IntMap.member edgeNr (networkEdges network) - -{----------------------------------- - Functions that change the network - -----------------------------------} - --- | Add a node to the network -addNode :: InfoKind n g - => Network g n e -- ^ the network to add the node to - -> (NodeNr, Network g n e) -- ^ the number of the new node and - -- the extended network -addNode network = - addNodeEx ("Node " ++ show nodeNr) - (DoublePoint 0.0 0.0) - True - (Right Shape.circle) - blank - Nothing - network - where - nodeNr = getUnusedNodeNr network - -addNodes :: InfoKind n g => Int -> Network g n e -> ([NodeNr], Network g n e) -addNodes 0 network = ([], network) -addNodes n network1 = - let (nodeNr, network2) = addNode network1 - (nodeNrs, network3) = addNodes (n-1) network2 - in (nodeNr:nodeNrs, network3) - -addNodeEx :: InfoKind n g => - String -> DoublePoint -> Bool -> Either String Shape -> n - -> Maybe (PortNr,PortNr) - -> Network g n e -> (NodeNr, Network g n e) -addNodeEx name position labelAbove shape info arity network = - ( nodeNr - , network { networkNodes = IntMap.insert nodeNr node (networkNodes network) } - ) - where - nodeNr = getUnusedNodeNr network - node = constructNode name position labelAbove shape info arity - - --- | Add an edge to the network. -addEdge :: InfoKind e g => NodeNr -> NodeNr -> Network g n e -> Network g n e -addEdge fromNodeNr toNodeNr network - | any (sameFromAndTo edge) edgesList || -- prohibit double edges - any (sameFromAndTo (reverseEdge edge)) edgesList = -- prohibit edges in opposite direction - network - | otherwise = - let edgeNr = getUnusedEdgeNr network - in setNodeArity fromNodeNr (updateFromArity fromArity) $ - setNodeArity toNodeNr (updateToArity toArity) $ - network { networkEdges = IntMap.insert edgeNr edge (networkEdges network) } - where - edge = constructEdge fromNodeNr fromPortNr toNodeNr toPortNr [] blank - edgesList = IntMap.elems (networkEdges network) - fromArity = getNodeArity network fromNodeNr - toArity = getNodeArity network toNodeNr - fromPortNr = 1 + (maybe 0 snd $ fromArity) - toPortNr = 1 + (maybe 0 fst $ toArity) - updateFromArity Nothing = Just (0,1) - updateFromArity (Just (n,m)) = Just (n,m+1) - updateToArity Nothing = Just (1,0) - updateToArity (Just (n,m)) = Just (n+1,m) - --- | Add an edge to the network, with specific connection ports. -addEdgeWithPorts :: InfoKind e g => - NodeNr -> PortNr -> NodeNr -> PortNr - -> Network g n e -> Network g n e -addEdgeWithPorts fromNodeNr fromPortNr toNodeNr toPortNr network - | any (sameFromAndTo edge) edgesList || -- prohibit double edges - any (sameFromAndTo (reverseEdge edge)) edgesList = -- prohibit edges in opposite direction - network - | otherwise = - let edgeNr = getUnusedEdgeNr network - networkPlusEdge = network { networkEdges = IntMap.insert edgeNr edge (networkEdges network) } - in networkPlusEdge - where - edge = constructEdge fromNodeNr fromPortNr toNodeNr toPortNr [] blank - -- edge = Edge { edgeFrom = fromNodeNr, edgeTo = toNodeNr, edgeVia = [] - -- , edgeInfo = blank, edgeFromPort = fromPortNr - -- , edgeToPort = toPortNr } - edgesList = IntMap.elems (networkEdges network) - -addEdges :: InfoKind e g => [(NodeNr,NodeNr)] -> Network g n e -> Network g n e -addEdges edgeTuples network = - foldr (\(fromNr, toNr) net -> addEdge fromNr toNr net) network edgeTuples - --- | Insert a new 'via' control point in the middle of an edge. -newViaEdge :: EdgeNr -> ViaNr -> DoublePoint - -> Network g n e -> Network g n e -newViaEdge edgeNr viaNr point network = - network { networkEdges = IntMap.adjust (\e->e{ edgeVia= take viaNr (edgeVia e) - ++[point] - ++drop viaNr (edgeVia e) }) - edgeNr - (networkEdges network) } - --- | Remove node with given index, raises exception if node number does not exist. --- This function also removes all edges that start or end in this node. -removeNode :: NodeNr -> Network g n e -> Network g n e -removeNode nodeNr network = - let involvedEdges = [ i - | (i, edge) <- getEdgeAssocs network - , edgeFrom edge == nodeNr || edgeTo edge == nodeNr - ] - networkWithoutEdges = foldr removeEdge network involvedEdges - networkWithoutNode = networkWithoutEdges { networkNodes = IntMap.delete nodeNr (networkNodes networkWithoutEdges) } - in networkWithoutNode - --- | Remove an edge from the network. The probability table of the target node is updated: --- the corresponding dimension is removed and all values are zeroed. --- An exception is raised if edge number does not exist. -removeEdge :: EdgeNr -> Network g n e -> Network g n e -removeEdge edgeNr network = - setNodeArity fromNodeNr (Just (fi,fo-1)) $ - setNodeArity toNodeNr (Just (ti-1,to)) $ - network { networkEdges = IntMap.delete edgeNr (networkEdges network) } - where - (fi,fo) = maybe (0,1) id $ getNodeArity network fromNodeNr - (ti,to) = maybe (1,0) id $ getNodeArity network toNodeNr - edge = getEdge edgeNr network - fromNodeNr = getEdgeFrom edge - toNodeNr = getEdgeTo edge - - --- | Remove all edges from the network. The probability tables of all node are zeroed. -removeAllEdges :: Network g n e -> Network g n e -removeAllEdges network = - let networkWithoutEdges = network { networkEdges = IntMap.empty } - in networkWithoutEdges - --- | Remove a control point from an edge. -removeVia :: EdgeNr -> ViaNr -> Network g n e -> Network g n e -removeVia edgeNr viaNr network = - let remove n e = e { edgeVia = take n (edgeVia e) - ++ drop (n+1) (edgeVia e) } in - network { networkEdges = IntMap.adjust (remove viaNr) - edgeNr (networkEdges network) } - -setPalette :: Palette n -> Network g n e -> Network g n e -setPalette palette network = network { networkPalette = palette } - -setCanvasSize :: (Double, Double) -> Network g n e -> Network g n e -setCanvasSize canvasSize network = network { networkCanvasSize = canvasSize } - -setGlobalInfo :: g -> Network g n e -> Network g n e -setGlobalInfo info network = network { networkInfo = info } - -{----------------------------------- - Local functions - -----------------------------------} - -sameFromAndTo :: Edge e -> Edge e -> Bool -sameFromAndTo edge1 edge2 = - edgeFrom edge1 == edgeFrom edge2 && edgeTo edge1 == edgeTo edge2 - -reverseEdge :: Edge e -> Edge e -reverseEdge edge = - edge { edgeFrom = edgeTo edge, edgeTo = edgeFrom edge } - --- | Update node with given number by applying the function to it --- Dangerous (wrt network consistency, do not export) -updateNode :: NodeNr -> (Node n -> Node n) -> Network g n e -> Network g n e -updateNode nodeNr nodeFunction network = - let node = getNode nodeNr network in - network { networkNodes = IntMap.insert nodeNr (nodeFunction node) - (networkNodes network) } - -updateEdge :: EdgeNr -> (Edge e -> Edge e) -> Network g n e -> Network g n e -updateEdge edgeNr edgeFunction network = - network { networkEdges = IntMap.adjust edgeFunction edgeNr - (networkEdges network) } - -updateVia :: EdgeNr -> ViaNr -> DoublePoint -> Network g n e -> Network g n e -updateVia edgeNr viaNr v network = - network { networkEdges = - IntMap.adjust (\e-> e { edgeVia = take viaNr (edgeVia e) - ++[v]++drop (viaNr+1) (edgeVia e) }) - edgeNr (networkEdges network) } diff --git a/src/NetworkControl.hs b/src/NetworkControl.hs deleted file mode 100644 --- a/src/NetworkControl.hs +++ /dev/null @@ -1,513 +0,0 @@ -module NetworkControl - ( createNode, selectNode - , createEdge, selectEdge - , createVia, selectVia - , selectNothing, selectMultiple - , pickupNode, dragNode, dropNode - , pickupVia, dragVia, dropVia - , pickupMultiple, dragMultiple, dropMultiple - , pickupArea, dragArea, dropArea - , deleteSelection - , changeNamePosition - , changeNodeShape - , renameNode, reinfoNodeOrEdge - , reArityNode - , changeGlobalInfo - ) where - -import State -import StateUtil -import Network -import NetworkView (edgeContains) -import Document -import Common -import CommonIO -import Math -import Shape -import qualified PersistentDocument as PD -import InfoKind -import Palette (shapes) -import Text.Parse -import Char (isSpace) - -import Graphics.UI.WX hiding (Selection) -import Graphics.UI.WXCore - -changeNamePosition :: Bool -> State g n e -> IO () -changeNamePosition above state = - do{ pDoc <- getDocument state - ; doc <- PD.getDocument pDoc - ; case getSelection doc of - NodeSelection nodeNr -> - do{ PD.updateDocument "move label" - (updateNetwork - (updateNode nodeNr - (setNameAbove above))) pDoc - ; repaintAll state - } - _ -> return () - } - -changeNodeShape :: InfoKind n g => String -> n -> State g n e -> IO () -changeNodeShape shapename info state = - do{ pDoc <- getDocument state - ; doc <- PD.getDocument pDoc - ; case getSelection doc of - NodeSelection nodeNr -> - do{ PD.updateDocument "change shape" - (updateNetwork - (updateNode nodeNr - (setInfo info . setShape (Left shapename)))) pDoc - ; repaintAll state - } - _ -> return () - } - -deleteSelection :: State g n e -> IO () -deleteSelection state = - do{ pDoc <- getDocument state - ; doc <- PD.getDocument pDoc - ; case getSelection doc of - NodeSelection nodeNr -> - do{ PD.updateDocument "delete node" - ( setSelection NoSelection - . updateNetwork (removeNode nodeNr) - ) pDoc - ; repaintAll state - } - EdgeSelection edgeNr -> - do{ PD.updateDocument "delete edge" - ( setSelection NoSelection - . updateNetwork (removeEdge edgeNr) - ) pDoc - ; repaintAll state - } - ViaSelection edgeNr viaNr -> - do{ PD.updateDocument "delete control point" - ( setSelection NoSelection - . updateNetwork (removeVia edgeNr viaNr) - ) pDoc - ; repaintAll state - } - _ -> return () - } - -createNode :: InfoKind n g => DoublePoint -> State g n e -> IO () -createNode mousePoint state = - do{ pDoc <- getDocument state - ; doc1 <- PD.getDocument pDoc - ; let (shape,info) = case (shapes . getPalette . getNetwork) doc1 of - [] -> (Right Shape.circle, blank) - ((s,(_,Nothing)):_) -> (Left s, blank) - ((s,(_,Just i)):_) -> (Left s, i) - ; let (nodeNr, doc2) = updateNetworkEx addNode doc1 - doc3 = updateNetwork (updateNode nodeNr (setPosition mousePoint - . setShape shape - . setInfo info)) - doc2 - doc4 = setSelection (NodeSelection nodeNr) doc3 - ; PD.setDocument "add node" doc4 pDoc - ; repaintAll state - } - -selectNothing :: State g n e -> IO () -selectNothing state = - do{ pDoc <- getDocument state - ; PD.superficialUpdateDocument (setSelection NoSelection) pDoc - ; repaintAll state - } - -selectEdge :: Int -> State g n e -> IO () -selectEdge edgeNr state = - do{ pDoc <- getDocument state - ; PD.superficialUpdateDocument (setSelection (EdgeSelection edgeNr)) pDoc - ; repaintAll state - } - -createEdge :: (InfoKind e g) => Int -> Int -> State g n e -> IO () -createEdge fromNodeNr toNodeNr state = - do{ pDoc <- getDocument state - ; PD.updateDocument "add edge" - ( setSelection (NodeSelection fromNodeNr) - . updateNetwork (addEdge fromNodeNr toNodeNr) - ) pDoc - ; repaintAll state - } - -createVia :: DoublePoint -> State g n e -> IO () -createVia mousepoint state = - do{ pDoc <- getDocument state - ; doc <- PD.getDocument pDoc - ; let network = getNetwork doc - ; case getSelection doc of - EdgeSelection edgeNr -> - do{ ifJust (edgeContains (getEdge edgeNr network) mousepoint network) - $ \viaNr-> - do{ PD.updateDocument "add control point to edge" - ( setSelection (ViaSelection edgeNr viaNr) - . updateNetwork (newViaEdge edgeNr viaNr mousepoint) - ) pDoc - ; repaintAll state - } - } - _ -> return () - } - -selectVia :: Int -> Int -> State g n e -> IO () -selectVia edgeNr viaNr state = - do{ pDoc <- getDocument state - ; PD.superficialUpdateDocument (setSelection (ViaSelection edgeNr viaNr)) - pDoc - ; repaintAll state - } - -pickupVia :: Int -> Int -> DoublePoint -> State g n e -> IO () -pickupVia edgeNr viaNr mousePoint state = - do{ pDoc <- getDocument state - ; doc <- PD.getDocument pDoc - ; let network = getNetwork doc - viaPos = (getEdgeVia (getEdge edgeNr network))!!viaNr - ; setDragging (Just (False, mousePoint `subtractDoublePoint` viaPos)) state - ; selectVia edgeNr viaNr state - } - -selectNode :: Int -> State g n e -> IO () -selectNode nodeNr state = - do{ pDoc <- getDocument state - ; PD.superficialUpdateDocument (setSelection (NodeSelection nodeNr)) pDoc - ; repaintAll state - } - -pickupNode :: Int -> DoublePoint -> State g n e -> IO () -pickupNode nodeNr mousePoint state = - do{ pDoc <- getDocument state - ; doc <- PD.getDocument pDoc - ; let network = getNetwork doc - nodePos = getNodePosition network nodeNr - ; setDragging (Just (False, mousePoint `subtractDoublePoint` nodePos)) state - ; selectNode nodeNr state - } - -dragNode :: Int -> DoublePoint -> ScrolledWindow () -> State g n e -> IO () -dragNode nodeNr mousePoint canvas state = - do{ pDoc <- getDocument state - ; doc <- PD.getDocument pDoc - ; Just (hasMoved, offset) <- getDragging state - ; let newPosition = mousePoint `subtractDoublePoint` offset - oldPosition = getNodePosition (getNetwork doc) nodeNr - ; when (newPosition /= oldPosition) $ - do{ -- The first time the node is moved we have to remember - -- the document in the undo history - ; (if not hasMoved then PD.updateDocument "move node" - else PD.superficialUpdateDocument) - (updateNetwork (updateNode nodeNr - (setPosition newPosition))) - pDoc - ; Graphics.UI.WX.repaint canvas - ; setDragging (Just (True, offset)) state - -- yes, the node has really moved - } - } - -dropNode :: Bool -> Int -> DoublePoint -> DoublePoint -> State g n e -> IO () -dropNode hasMoved nodeNr offset mousePoint state = - do{ when hasMoved $ - do{ let newPosition = mousePoint `subtractDoublePoint` offset - ; pDoc <- getDocument state - ; PD.superficialUpdateDocument - (updateNetwork (updateNode nodeNr - (setPosition newPosition))) pDoc - } - ; canvas <- getCanvas state - ; Graphics.UI.WX.repaint canvas - ; setDragging Nothing state - } - -dragVia :: Int -> Int -> DoublePoint -> ScrolledWindow () -> State g n e -> IO () -dragVia edgeNr viaNr mousePoint canvas state = - do{ pDoc <- getDocument state - ; doc <- PD.getDocument pDoc - ; Just (hasMoved, offset) <- getDragging state - ; let newPosition = mousePoint `subtractDoublePoint` offset - oldPosition = (getEdgeVia (getEdge edgeNr (getNetwork doc)))!!viaNr - ; when (newPosition /= oldPosition) $ - do{ -- The first time the point is moved we have to remember - -- the document in the undo history - ; (if not hasMoved then PD.updateDocument "move control point" - else PD.superficialUpdateDocument) - (updateNetwork (updateVia edgeNr viaNr newPosition)) - pDoc - ; Graphics.UI.WX.repaint canvas - ; setDragging (Just (True, offset)) state - -- yes, the point has really moved - } - } - -dropVia :: Bool -> Int -> Int -> DoublePoint -> DoublePoint -> State g n e -> IO () -dropVia hasMoved edgeNr viaNr offset mousePoint state = - do{ when hasMoved $ - do{ let newPosition = mousePoint `subtractDoublePoint` offset - ; pDoc <- getDocument state - ; PD.superficialUpdateDocument - (updateNetwork (updateVia edgeNr viaNr newPosition)) - pDoc - } - ; canvas <- getCanvas state - ; Graphics.UI.WX.repaint canvas - ; setDragging Nothing state - } - -selectMultiple :: Maybe (DoublePoint,DoublePoint) -> [Int] -> [(Int,Int)] - -> State g n e -> IO () -selectMultiple area nodeNrs viaNrs state = - do{ pDoc <- getDocument state - ; PD.superficialUpdateDocument - (setSelection (MultipleSelection area nodeNrs viaNrs)) - pDoc - ; repaintAll state - } - -pickupMultiple :: [Int] -> [(Int,Int)] -> DoublePoint -> State g n e -> IO () -pickupMultiple _nodeNrs _viaNrs mousePoint state = - do{ setDragging (Just (False, mousePoint)) state --- ; selectMultiple Nothing nodeNrs viaNrs state -- already selected - } - -dragMultiple :: [Int] -> [(Int,Int)] -> DoublePoint -> ScrolledWindow () - -> State g n e -> IO () -dragMultiple nodeNrs viaNrs mousePoint canvas state = - do{ pDoc <- getDocument state - -- ; doc <- PD.getDocument pDoc - ; Just (hasMoved, origin) <- getDragging state - ; let offset = mousePoint `subtractDoublePoint` origin - ; when (mousePoint /= origin) $ - do{ -- The first time the point is moved we have to remember - -- the document in the undo history - ; (if not hasMoved then PD.updateDocument "move control point" - else PD.superficialUpdateDocument) - (updateNetwork (updateMultiple nodeNrs viaNrs offset)) - pDoc - ; Graphics.UI.WX.repaint canvas - ; setDragging (Just (True, mousePoint)) state - -- yes, the point has really moved - } - } - -updateMultiple :: [Int] -> [(Int,Int)] -> DoublePoint -> Network g n e - -> Network g n e -updateMultiple ns vs o network = - ( foldr (\n z-> updateNode n (offsetNode o) . z) id ns - . foldr (\ (e,v) z-> updateVia e v (offsetVia o e v) . z) id vs - ) network - where - offsetNode off node = setPosition (getPosition node `translate` off) node - offsetVia off edgeNr via = ((getEdgeVia (getEdge edgeNr network))!!via) - `translate` off - -dropMultiple :: Bool -> [Int] -> [(Int,Int)] -> DoublePoint -> DoublePoint - -> State g n e -> IO () -dropMultiple hasMoved nodeNrs viaNrs origin mousePoint state = - do{ when hasMoved $ - do{ pDoc <- getDocument state - ; PD.superficialUpdateDocument - (updateNetwork - (updateMultiple nodeNrs viaNrs - (mousePoint`subtractDoublePoint`origin))) - pDoc - } - ; canvas <- getCanvas state - ; Graphics.UI.WX.repaint canvas - ; setDragging Nothing state - } - -pickupArea :: DoublePoint -> State g n e -> IO () -pickupArea mousePoint state = - do{ setDragging (Just (False, mousePoint)) state - ; selectMultiple (Just (mousePoint,mousePoint)) [] [] state - } - --- dragArea is not like dragging a selection. It does not move anything. --- It only adds items into a multiple selection. -dragArea :: DoublePoint -> State g n e -> IO () -dragArea mousePoint state = - do{ pDoc <- getDocument state - ; doc <- PD.getDocument pDoc - ; Just (_, origin) <- getDragging state - ; let (ns,vs) = itemsEnclosedWithin mousePoint origin (getNetwork doc) - ; selectMultiple (Just (origin,mousePoint)) ns vs state - } - where - itemsEnclosedWithin p0 p1 network = - ( ( Prelude.map fst - . Prelude.filter (\ (_,n)-> enclosedInRectangle (getPosition n) p0 p1) - . getNodeAssocs ) network - , ( Prelude.concatMap (\ (i,e)-> map (\ (j,_)-> (i,j)) - (Prelude.filter - (\ (_,v)-> enclosedInRectangle - v p0 p1) - (zip [0..] (getEdgeVia e)))) - . getEdgeAssocs ) network - ) - -dropArea :: DoublePoint -> DoublePoint -> State g n e -> IO () -dropArea _origin mousePoint state = - do{ dragArea mousePoint state -- calculate enclosure area - ; pDoc <- getDocument state - ; doc <- PD.getDocument pDoc - ; case getSelection doc of - MultipleSelection _ [] [] -> - PD.superficialUpdateDocument (setSelection NoSelection) pDoc - MultipleSelection _ ns vs -> - PD.superficialUpdateDocument - (setSelection (MultipleSelection Nothing ns vs)) pDoc - _ -> return () - ; setDragging Nothing state - ; repaintAll state - } - - -renameNode :: Frame () -> State g n e -> IO () -renameNode theFrame state = - do{ pDoc <- getDocument state - ; doc <- PD.getDocument pDoc - ; let network = getNetwork doc - ; case getSelection doc of - NodeSelection nodeNr -> - do{ let oldName = getNodeName network nodeNr - ; result <- myTextDialog theFrame SingleLine - "Rename node" oldName True - ; ifJust result $ \newName -> - do{ PD.updateDocument "rename node" - (updateNetwork - (updateNode nodeNr (setName newName))) pDoc - ; repaintAll state - } - } - _ -> return () - } - -reArityNode :: Frame () -> State g n e -> IO () -reArityNode theFrame state = - do{ pDoc <- getDocument state - ; doc <- PD.getDocument pDoc - ; let network = getNetwork doc - ; case getSelection doc of - NodeSelection nodeNr -> - do{ let oldArity = getNodeArity network nodeNr - ; result <- myTextDialog theFrame SingleLine - "Change arity of node" (show oldArity) - True - ; ifJust result $ \newArity -> - -- do repaintAll state -- Until we sort out the parser - case runParser parse newArity of - (Right x, s) -> - do{ when (not (null s || all isSpace s)) $ - errorDialog theFrame "Edit warning" - ("Excess text after parsed value." - ++"\nRemaining text: "++s) - ; PD.updateDocument "change node arity" - (updateNetwork - (updateNode nodeNr (setArity x))) pDoc - ; repaintAll state - } - (Left err, s) -> errorDialog theFrame "Edit warning" - ("Cannot parse entered text." - ++"\nReason: "++err - ++"\nRemaining text: "++s) - } - _ -> return () - } - -reinfoNodeOrEdge :: (InfoKind n g, InfoKind e g) => - Frame () -> State g n e -> IO () -reinfoNodeOrEdge theFrame state = - do{ pDoc <- getDocument state - ; doc <- PD.getDocument pDoc - ; let network = getNetwork doc - ; case getSelection doc of - NodeSelection nodeNr -> - do{ let oldInfo = getNodeInfo network nodeNr - ; result <- myTextDialog theFrame MultiLine - "Edit node info" (show oldInfo) True - ; ifJust result $ \newInfo -> - -- do repaintAll state -- Until we sort out the parser - case runParser parse newInfo of - (Right x, s) -> - do{ when (not (null s || all isSpace s)) $ - errorDialog theFrame "Edit warning" - ("Excess text after parsed value." - ++"\nRemaining text: "++s) - ; case check (getNodeName network nodeNr) - (getGlobalInfo network) x of - [] -> return () - e -> errorDialog theFrame "Validity warning" - ("Validity check fails:\n" - ++unlines e) - ; PD.updateDocument "edit node info" - (updateNetwork - (updateNode nodeNr (setInfo x))) pDoc - ; repaintAll state - } - (Left err, s) -> errorDialog theFrame "Edit warning" - ("Cannot parse entered text." - ++"\nReason: "++err - ++"\nRemaining text: "++s) - } - EdgeSelection edgeNr -> - do{ let oldInfo = getEdgeInfo (getEdge edgeNr network) - ; result <- myTextDialog theFrame MultiLine - "Edit edge info" (show oldInfo) True - ; ifJust result $ \newInfo -> - -- do repaintAll state -- Until we sort out the parser - case runParser parse newInfo of - (Right x, s) -> - do{ when (not (null s || all isSpace s)) $ - errorDialog theFrame "Edit warning" - ("Excess text after parsed value." - ++"\nRemaining text: "++s) - ; case check "edge" - (getGlobalInfo network) x of - [] -> return () - e -> errorDialog theFrame "Validity warning" - ("Validity check fails:\n" - ++unlines e) - ; PD.updateDocument "edit edge info" - (updateNetwork - (updateEdge edgeNr (setEdgeInfo x))) pDoc - ; repaintAll state - } - (Left err, s) -> errorDialog theFrame "Edit warning" - ("Cannot parse entered text." - ++"\nReason: "++err - ++"\nRemaining text: "++s) - } - _ -> return () - } - -changeGlobalInfo :: (Show g, Parse g, Descriptor g) => - Frame () -> State g n e -> IO () -changeGlobalInfo theFrame state = - do{ pDoc <- getDocument state - ; doc <- PD.getDocument pDoc - ; let network = getNetwork doc - info = getGlobalInfo network - ; result <- myTextDialog theFrame MultiLine ("Edit "++descriptor info) - (show info) True - ; ifJust result $ \newInfo-> - --do repaintAll state -- Until we sort out the parser - case runParser parse newInfo of - (Right x, s) -> - do{ when (not (null s || all isSpace s)) $ - errorDialog theFrame "Edit warning" - ("Excess text after parsed value." - ++"\nRemaining text: "++s) - ; PD.updateDocument ("edit "++descriptor info) - (updateNetwork (setGlobalInfo x)) pDoc - ; repaintAll state -- no visible change? - } - (Left err, s) -> errorDialog theFrame "Edit warning" - ("Cannot parse entered text." - ++"\nReason: "++err - ++"\nRemaining text: "++s) - } - diff --git a/src/NetworkFile.hs b/src/NetworkFile.hs deleted file mode 100644 --- a/src/NetworkFile.hs +++ /dev/null @@ -1,438 +0,0 @@ -{-# LANGUAGE UndecidableInstances #-} -module NetworkFile where - -import Network -import Math -import Common -import Colors -import Shape -import InfoKind -import Palette - -import Text.XML.HaXml.Types -import Text.XML.HaXml.Escape -import Text.XML.HaXml.Posn (noPos) -import Text.XML.HaXml.Parse hiding (element) --- import Text.XML.HaXml.XmlContent as XML -import Text.XML.HaXml.XmlContent.Haskell as XML -import Text.XML.HaXml.Combinators (replaceAttrs) -import Text.XML.HaXml.Verbatim -import Text.XML.HaXml.TypeMapping (toDTD,toHType) -import Text.PrettyPrint.HughesPJ -import qualified Text.XML.HaXml.Pretty as Pretty -import Char -import Maybe -import Monad(when) -import List(nub,isPrefixOf) - --- | Print the network data structure to an XML text -toString :: (InfoKind n g, InfoKind e g, XmlContent g) => - Network g n e -> String -toString network = render . Pretty.document $ - Document (Prolog Nothing [] (Just (toDTD (toHType network))) []) emptyST - (f (toContents network)) [] - where - f [CElem e _] = e - f _ = error "bad" -- shouldn't happen - --- | Parses a string to the network data structure --- Returns either an error message (Left) or the network, --- a list of warnings (Right) and a boolean indicating whether --- the file was an old Dazzle file -fromString :: (InfoKind n g, InfoKind e g, XmlContent g) => - String -> Either String (Network g n e, [String], Bool) -fromString xml = - case xmlParse' "input file" xml of - Left err -> Left err -- lexical or initial (generic) parse error - Right (Document _ _ e _) -> - case runParser parseContents [CElem e noPos] of - (Left err, _) -> Left err -- secondary (typeful) parse error - (Right v, _) -> Right (v,[],False) - -{- --- non-XML output -toStringShow :: (Show g, Show n, Show e) => Network g n e -> String -toStringShow network = - show ( getNodeAssocs network - , getEdgeAssocs network - , getCanvasSize network - , getGlobalInfo network - ) - -fromStringShow :: (Read g, InfoKind n g, InfoKind e g) => - String -> Either String (Network g n e) -fromStringShow txt = - case reads txt of - ((tuple,[]):_) -> - let (nodeAssocs, edgeAssocs, canvasSize, globalInfo) = tuple - in Right ( setNodeAssocs nodeAssocs - . setEdgeAssocs edgeAssocs - . setCanvasSize canvasSize - $ Network.empty globalInfo undefined undefined - ) - _ -> Left "File is not a Blobs network" --} - ---------------------------------------------------------- --- Internal type isomorphic to (index,value) pairs --- (but permits instances of classes) ---------------------------------------------------------- -data AssocN n = AssocN Int (Node n) -deAssocN :: AssocN n -> (Int,Node n) -deAssocN (AssocN n v) = (n,v) -data AssocE e = AssocE Int (Edge e) -deAssocE :: AssocE e -> (Int,Edge e) -deAssocE (AssocE n v) = (n,v) - ---------------------------------------------------------- --- Convert our data type to/from an XML tree ---------------------------------------------------------- -instance (HTypeable g, HTypeable n, HTypeable e) - => HTypeable (Network g n e) where - toHType _ = Defined "Network" [] [Constr "Network" [] []] - -- toHType g = Defined "Network" [] [Constr "Network" [] - -- [ Tagged "Width" [String] - -- , Tagged "Height" [String] - -- , toHType (getGlobalInfo g) - -- , toHType (getPalette g) - -- , toHType (getNodeAssocs g) - -- , toHType (getEdgeAssocs g) - -- ]] -instance (InfoKind n g, InfoKind e g, XmlContent g) => - XmlContent (Network g n e) where - toContents network = - [CElem (Elem "Network" [] - [ simpleString "Width" (show width) - , simpleString "Height" (show height) - , makeTag "Info" (toContents netInfo) - , makeTag "Palette" (toContents (getPalette network)) - , makeTag "Nodes" (concatMap toContents nodeAssocs) - , makeTag "Edges" (concatMap toContents edgeAssocs) - ]) () ] - where - nodeAssocs = map (uncurry AssocN) $ getNodeAssocs network - edgeAssocs = map (uncurry AssocE) $ getEdgeAssocs network - (width, height) = getCanvasSize network - netInfo = getGlobalInfo network - parseContents = do - { inElement "Network" $ do - { w <- inElement "Width" $ fmap read XML.text - ; h <- inElement "Height" $ fmap read XML.text - ; i <- inElement "Info" $ parseContents - ; p <- inElement "Palette"$ parseContents - ; ns <- inElement "Nodes" $ many1 parseContents - ; es <- inElement "Edges" $ many1 parseContents - ; networkValid ns es - ; return ( setCanvasSize (w,h) - . setPalette p - . setNodeAssocs (map deAssocN ns) - . setEdgeAssocs (map deAssocE es) - $ Network.empty i undefined undefined) - } - } - -peekAttributes :: String -> XMLParser [(String,AttValue)] -peekAttributes t = - do{ (p, e@(Elem _ as _)) <- posnElement [t] - ; reparse [CElem e p] - ; return as - } - -instance HTypeable (AssocN n) where - toHType _ = Defined "Node" [] [Constr "Node" [] []] -instance (InfoKind n g) => XmlContent (AssocN n) where - toContents (AssocN n node) = - concatMap (replaceAttrs [("id",'N':show n)]) (toContents node) - parseContents = do - { [("id",n)] <- peekAttributes "Node" - ; n' <- num n - ; node <- parseContents - ; return (AssocN n' node) - } - where num (AttValue [Left ('N':n)]) = return (read n) - num (AttValue s) = fail ("Problem reading Node ID: "++verbatim s) - -instance HTypeable (AssocE e) where - toHType _ = Defined "Edge" [] [Constr "Edge" [] []] -instance (InfoKind e g) => XmlContent (AssocE e) where - toContents (AssocE n edge) = - concatMap (replaceAttrs [("id",'E':show n)]) (toContents edge) - parseContents = do - { [("id",n)] <- peekAttributes "Edge" - ; n' <- num n - ; edge <- parseContents - ; return (AssocE n' edge) - } - where num (AttValue [Left ('E':n)]) = return (read n) - num (AttValue s) = fail ("Problem reading Edge ID: "++verbatim s) - -instance HTypeable (Node n) where - toHType _ = Defined "Node" [] [Constr "Node" [] []] -instance (InfoKind n g) => XmlContent (Node n) where - toContents node = - [ makeTag "Node" - (toContents (getPosition node) ++ - [ escapeString "Name" (getName node) - , simpleString "LabelAbove" (show (getNameAbove node)) - , makeTag "Shape" (toContents (getShape node)) - , makeTag "Info" (toContents (getInfo node)) - , makeTag "Arity" (toContents (getArity node)) - ]) - ] - parseContents = do - { inElement "Node" $ do - { p <- parseContents -- position - ; n <- inElement "Name" $ XML.text - ; a <- inElement "LabelAbove" $ fmap read XML.text - ; s <- inElement "Shape" $ parseContents - ; i <- inElement "Info" $ parseContents - ; r <- (inElement "Arity" $ parseContents) - `onFail` (return Nothing) - ; return (constructNode n p a s i r) - } - } - -instance HTypeable DoublePoint where - toHType _ = Defined "DoublePoint" [] [Constr "X" [] [], Constr "Y" [] []] -instance XmlContent DoublePoint where - toContents (DoublePoint x y) = - [ simpleString "X" (show x) - , simpleString "Y" (show y) - ] - parseContents = do - { x <- inElement "X" $ fmap read XML.text - ; y <- inElement "Y" $ fmap read XML.text - ; return (DoublePoint x y) - } - -instance HTypeable (Edge e) where - toHType _ = Defined "Edge" [] [Constr "Edge" [] []] -instance InfoKind e g => XmlContent (Edge e) where - toContents edge = - [ makeTag "Edge" - [ simpleString "From" (show (getEdgeFrom edge)) - , simpleString "To" (show (getEdgeTo edge)) - , makeTag "Via" (concatMap toContents (getEdgeVia edge)) - , makeTag "Info" (toContents (getEdgeInfo edge)) - , makeTag "FromPort" (toContents (getEdgeFromPort edge)) - , makeTag "ToPort" (toContents (getEdgeToPort edge)) - ] - ] - parseContents = do - { inElement "Edge" $ do - { f <- inElement "From" $ fmap read XML.text - ; t <- inElement "To" $ fmap read XML.text - ; v <- inElement "Via" $ many parseContents - ; i <- inElement "Info" $ parseContents - ; fp <- (inElement "FromPort" $ parseContents) - `onFail` (return 0) - ; tp <- (inElement "ToPort" $ parseContents) - `onFail` (return 0) - ; return (constructEdge f fp t tp v i) - } - } - -{- derived by DrIFT -} -instance HTypeable Colour where - toHType v = Defined "Colour" [] - [Constr "RGB" [] [toHType aa,toHType ab,toHType ac]] - where (RGB aa ab ac) = v -instance XmlContent Colour where - parseContents = do - { inElement "RGB" $ do - { aa <- parseContents - ; ab <- parseContents - ; ac <- parseContents - ; return (RGB aa ab ac) - } - } - toContents v@(RGB aa ab ac) = - [mkElemC (showConstr 0 (toHType v)) - (concat [toContents aa, toContents ab, toContents ac])] - -{- derived by DrIFT -} -instance HTypeable Shape where - toHType v = Defined "Shape" [] - [Constr "Circle" [] [toHType aa,toHType ab] - ,Constr "Polygon" [] [toHType ac,toHType ad] - ,Constr "Lines" [] [toHType ae,toHType af] - ,Constr "Composite" [] [toHType ag]] - where - (Circle aa ab) = v - (Polygon ac ad) = v - (Lines ae af) = v - (Composite ag) = v -instance XmlContent Shape where - parseContents = do - { e@(Elem t _ _) <- element ["Circle","Polygon","Lines","Composite"] - ; case t of - _ | "Polygon" `isPrefixOf` t -> interior e $ - do { ac <- parseContents - ; ad <- parseContents - ; return (Polygon ac ad) - } - | "Lines" `isPrefixOf` t -> interior e $ - do { ae <- parseContents - ; af <- parseContents - ; return (Lines ae af) - } - | "Composite" `isPrefixOf` t -> interior e $ - fmap Composite parseContents - | "Circle" `isPrefixOf` t -> interior e $ - do { aa <- parseContents - ; ab <- parseContents - ; return (Circle aa ab) - } - } - toContents v@(Circle aa ab) = - [mkElemC (showConstr 0 (toHType v)) (concat [toContents aa, - toContents ab])] - toContents v@(Polygon ac ad) = - [mkElemC (showConstr 1 (toHType v)) (concat [toContents ac, - toContents ad])] - toContents v@(Lines ae af) = - [mkElemC (showConstr 2 (toHType v)) (concat [toContents ae, - toContents af])] - toContents v@(Composite ag) = - [mkElemC (showConstr 3 (toHType v)) (toContents ag)] - -{- derived by DrIFT -} -instance HTypeable ShapeStyle where - toHType v = Defined "ShapeStyle" [] - [Constr "ShapeStyle" [] [toHType aa,toHType ab,toHType ac]] - where (ShapeStyle aa ab ac) = v -instance XmlContent ShapeStyle where - parseContents = do - { inElement "ShapeStyle" $ do - { aa <- parseContents - ; ab <- parseContents - ; ac <- parseContents - ; return (ShapeStyle aa ab ac) - } - } - toContents v@(ShapeStyle aa ab ac) = - [mkElemC (showConstr 0 (toHType v)) - (concat [toContents aa, toContents ab, toContents ac])] - -{- handwritten -} -instance HTypeable a => HTypeable (Palette a) where - toHType p = Defined "Palette" [toHType a] [Constr "Palette" [] []] - where (Palette ((_,(_,Just a)):_)) = p -instance XmlContent a => XmlContent (Palette a) where - toContents (Palette shapes) = - [ mkElemC "Palette" (concatMap toContents shapes) ] - parseContents = do - { inElement "Palette" $ fmap Palette (many1 parseContents) } - -{- -instance XmlContent a => XmlContent (Either String a) where - toContents (Left str) = [ simpleString "ShapeName" (show str) ] - toContents (Right shape) = (toContents shape) - - parseContents = do - return () -- Need to implement this --} ----- UTILITY FUNCTIONS - --- Abbreviations -makeTag :: String -> [Content i] -> Content i -makeTag name children = CElem (Elem name [] children) undefined - -tagWithId :: String -> String -> [Content i] -> Content i -tagWithId name identity children = - CElem (Elem name [("id", AttValue [Left identity])] children) undefined - --- | A simple string contains no spaces or unsafe characters -simpleString :: String -> String -> Content i -simpleString tag value = - CElem (Elem tag [] [ CString False value undefined ]) undefined - --- | The string value may contain spaces and unsafe characters -escapeString :: String -> String -> Content i -escapeString key value = - CElem ((if isSafe value then id else escape) $ - Elem key [] [ CString (any isSpace value) value undefined ]) - undefined - where - isSafe cs = all isSafeChar cs - isSafeChar c = isAlpha c || isDigit c || c `elem` "- ." - - escape :: Element i -> Element i - escape = xmlEscape stdXmlEscaper - -comment :: String -> Content i -comment s = CMisc (Comment (commentEscape s)) undefined - --- Replace occurences of "-->" with "==>" in a string so that the string --- becomes safe for an XML comment -commentEscape :: String -> String -commentEscape [] = [] -commentEscape ('-':'-':'>':xs) = "==>" ++ commentEscape xs -commentEscape (x:xs) = x : commentEscape xs - ---------------------------------------------------------- --- Check whether the network read from file is valid ---------------------------------------------------------- - -networkValid :: [AssocN n] -> [AssocE e] -> XMLParser () -networkValid nodeAssocs edgeAssocs - | containsDuplicates nodeNrs = - fail "Node numbers should be unique" - | containsDuplicates edgeNrs = - fail "Edge numbers should be unique" - | otherwise = - do{ mapM_ (checkEdge nodeNrs) edgeAssocs - ; -- determine whether there are multiple edges between any two nodes - ; let multipleEdges = duplicatesBy betweenSameNodes edges - ; when (not (null multipleEdges)) $ - fail $ "There are multiple edges between the following node pairs: " ++ - commasAnd [ "(" ++ show (getEdgeFrom e) ++ ", " - ++ show (getEdgeTo e) ++ ")" - | e <- multipleEdges - ] - ; return () - } - where - nodeNrs = map (fst . deAssocN) nodeAssocs - (edgeNrs, edges) = unzip (map deAssocE edgeAssocs) - --- Check whether edges refer to existing node numbers and whether --- there are no edges that start and end in the same node -checkEdge :: [NodeNr] -> AssocE e -> XMLParser () -checkEdge nodeNrs (AssocE edgeNr edge) - | fromNr == toNr = - fail $ "Edge " ++ show edgeNr ++ ": from-node and to-node are the same" - | fromNr `notElem` nodeNrs = nonExistingNode fromNr - | toNr `notElem` nodeNrs = nonExistingNode toNr - | otherwise = return () - where - fromNr = getEdgeFrom edge - toNr = getEdgeTo edge - nonExistingNode nodeNr = - fail $ "Edge " ++ show edgeNr ++ ": refers to non-existing node " - ++ show nodeNr - -containsDuplicates :: Eq a => [a] -> Bool -containsDuplicates xs = length (nub xs) /= length xs - --- Partial equality on edges -betweenSameNodes :: Edge e -> Edge e -> Bool -betweenSameNodes e1 e2 = - (getEdgeFrom e1 == getEdgeFrom e2 && getEdgeTo e1 == getEdgeTo e2) - || - (getEdgeFrom e1 == getEdgeTo e2 && getEdgeTo e1 == getEdgeFrom e1) - --- Returns elements that appear more than once in a list -duplicates :: Eq a => [a] -> [a] -duplicates [] = [] -duplicates (x:xs) - | x `elem` xs = x : duplicates (filter (/= x) xs) - | otherwise = duplicates xs - --- Returns elements that appear more than once in a list, using given Eq op -duplicatesBy :: (a->a->Bool) -> [a] -> [a] -duplicatesBy _ [] = [] -duplicatesBy eq (x:xs) - | any (eq x) xs = x : duplicatesBy eq (filter (not . eq x) xs) - | otherwise = duplicatesBy eq xs - diff --git a/src/NetworkUI.hs b/src/NetworkUI.hs deleted file mode 100644 --- a/src/NetworkUI.hs +++ /dev/null @@ -1,435 +0,0 @@ -module NetworkUI - ( create - , getConfig, Config - ) where - -import GUIEvents -import SafetyNet -import State -import StateUtil -import Network -import NetworkView -import NetworkFile -import Document -import Common -import CommonIO -import qualified PersistentDocument as PD -import qualified PDDefaults as PD -import Palette -import InfoKind -import DisplayOptions ---import Text.XML.HaXml.XmlContent (XmlContent) -import Text.XML.HaXml.XmlContent.Haskell (XmlContent) -import Text.Parse -import Operations -import NetworkControl (changeGlobalInfo) - -import Graphics.UI.WX hiding (Child, upKey, downKey) -import Graphics.UI.WXCore -import Maybe - -data Config = NFC - { nfcWinDimensions :: (Int, Int, Int, Int) -- x, y, width, height - , nfcFileName :: Maybe String - , nfcSelection :: Document.Selection - } - deriving (Read, Show) - -getConfig :: State g n e -> IO Config -getConfig state = - do{ theFrame <- getNetworkFrame state - ; (x, y) <- safeGetPosition theFrame - ; winSize <- get theFrame clientSize - ; pDoc <- getDocument state - ; maybeFileName <- PD.getFileName pDoc - ; doc <- PD.getDocument pDoc - ; return (NFC - { nfcWinDimensions = (x, y, sizeW winSize, sizeH winSize) - , nfcFileName = maybeFileName - , nfcSelection = getSelection doc - }) - } - -create :: (InfoKind n g, InfoKind e g - , XmlContent g, Parse g, Show g, Descriptor g) => - State g n e -> g -> n -> e -> GraphOps g n e -> IO () -create state g n e ops = - do{ theFrame <- frame [ text := "Diagram editor" - , position := pt 200 20 - , clientSize := sz 300 240 ] - ; setNetworkFrame theFrame state - - -- Create page setup dialog and save in state - ; pageSetupData <- pageSetupDialogDataCreate - ; initialPageSetupDialog <- pageSetupDialogCreate theFrame pageSetupData - ; objectDelete pageSetupData - ; setPageSetupDialog initialPageSetupDialog state - - -- Drawing area - ; let (width, height) = getCanvasSize (Network.empty g n e) - ; ppi <- getScreenPPI - ; canvas <- scrolledWindow theFrame - [ virtualSize := sz (logicalToScreenX ppi width) - (logicalToScreenY ppi height) - , scrollRate := sz 10 10 - , bgcolor := wxcolor paneBackgroundColor - , fullRepaintOnResize := False - ] - ; State.setCanvas canvas state - - -- Dummy persistent document to pass around - ; pDoc <- getDocument state - - -- Attach handlers to drawing area - ; set canvas - [ on paint := \dc _ -> safetyNet theFrame $ paintHandler state dc - , on mouse := \p -> safetyNet theFrame $ - do mouseEvent p canvas theFrame state - --; focusOn canvas - , on keyboard := \k -> safetyNet theFrame $ - do keyboardEvent theFrame state k - --; focusOn canvas - ] - - -- File menu - ; fileMenu <- menuPane [ text := "&File" ] - ; menuItem fileMenu - [ text := "New\tCtrl+N" - , on command := safetyNet theFrame $ newItem state g n e - ] - ; menuItem fileMenu - [ text := "Open...\tCtrl+O" - , on command := safetyNet theFrame $ openItem theFrame state - ] - ; saveItem <- menuItem fileMenu - [ text := "Save\tCtrl+S" - , on command := safetyNet theFrame $ PD.save pDoc - ] - ; menuItem fileMenu - [ text := "Save as..." - , on command := safetyNet theFrame $ PD.saveAs pDoc - ] - - ; menuLine fileMenu - - ; menuItem fileMenu - [ text := "Page setup..." - , on command := safetyNet theFrame $ - do{ psd <- getPageSetupDialog state - ; dialogShowModal psd - ; return () - } - ] - - ; menuItem fileMenu - [ text := "Print..." - , on command := safetyNet theFrame $ - let printFun _ printInfo _ dc _ = - do { dcSetUserScale dc - (fromIntegral (sizeW (printerPPI printInfo)) - / fromIntegral (sizeW (screenPPI printInfo))) - (fromIntegral (sizeH (printerPPI printInfo)) - / fromIntegral (sizeH (screenPPI printInfo))) - ; paintHandler state dc - } - pageFun _ _ _ = (1, 1) - in - do{ psd <- getPageSetupDialog state - ; printDialog psd "Blobs print" pageFun printFun - } - ] - - ; menuItem fileMenu - [ text := "Print preview" - , on command := safetyNet theFrame $ - let printFun _ _ _ dc _ = paintHandler state dc - pageFun _ _ _ = (1, 1) - in - do{ psd <- getPageSetupDialog state - ; printPreview psd "Blobs preview" pageFun printFun - } - ] - - ; menuLine fileMenu - - ; menuItem fileMenu - [ text := "E&xit" - , on command := close theFrame - ] - - -- Edit menu - ; editMenu <- menuPane [ text := "&Edit" ] - ; undoItem <- menuItem editMenu - [ on command := safetyNet theFrame $ do PD.undo pDoc; repaintAll state ] - ; redoItem <- menuItem editMenu - [ on command := safetyNet theFrame $ do PD.redo pDoc; repaintAll state ] - ; menuLine editMenu - ; menuItem editMenu - [ text := "Edit "++descriptor g++"..." - , on command := safetyNet theFrame $ changeGlobalInfo theFrame state - ] - ; menuItem editMenu - [ text := "Change shape palette..." - , on command := safetyNet theFrame $ openPalette theFrame state - ] - - -- View menu - ; viewMenu <- menuPane [ text := "&View" ] - ; (DP opts) <- getDisplayOptions state - ; menuItem viewMenu - [ text := descriptor g - , checkable := True - , checked := GlobalInfo `elem` opts - , on command := safetyNet theFrame $ do - { changeDisplayOptions (toggle GlobalInfo) state - ; repaintAll state } ] - ; menuItem viewMenu - [ text := "Node Labels" - , checkable := True - , checked := NodeLabel `elem` opts - , on command := safetyNet theFrame $ do - { changeDisplayOptions (toggle NodeLabel) state - ; repaintAll state } ] - ; menuItem viewMenu - [ text := "Node Info" - , checkable := True - , checked := NodeInfo `elem` opts - , on command := safetyNet theFrame $ do - { changeDisplayOptions (toggle NodeInfo) state - ; repaintAll state } ] - ; menuItem viewMenu - [ text := "Edge Info" - , checkable := True - , checked := EdgeInfo `elem` opts - , on command := safetyNet theFrame $ do - { changeDisplayOptions (toggle EdgeInfo) state - ; repaintAll state } ] - - -- Operations menu - ; opsMenu <- menuPane [ text := "&Operations" ] - ; mapM_ (\ (name,_)-> - menuItem opsMenu - [ text := name - , on command := safetyNet theFrame $ do - { callGraphOp name ops state - ; repaintAll state } - ] - ) (ioOps ops) - - ; PD.initialise pDoc (PD.PD - { PD.document = Document.empty g n e - , PD.history = [] - , PD.future = [] - , PD.limit = Nothing - , PD.fileName = Nothing - , PD.dirty = False - , PD.saveToDisk = saveToDisk theFrame - , PD.updateUndo = PD.defaultUpdateUndo undoItem - , PD.updateRedo = PD.defaultUpdateRedo redoItem - , PD.updateSave = PD.defaultUpdateSave saveItem - , PD.updateTitleBar = PD.defaultUpdateTitlebar theFrame "Blobs" - , PD.saveChangesDialog = PD.defaultSaveChangesDialog theFrame "Blobs" - , PD.saveAsDialog = PD.defaultSaveAsDialog theFrame extensions - }) - - -- Layout the main window - ; set theFrame - [ menuBar := [ fileMenu, editMenu, viewMenu, opsMenu ] - , layout := minsize (sz 300 240) $ fill $ widget canvas - , on closing := safetyNet theFrame $ exit state - ] - - -- ; set theFrame - -- [ position := pt 200 20 - -- , clientSize := sz 300 240 - -- ] - } - -paintHandler :: (InfoKind n g, InfoKind e g, Descriptor g) => - State g n e -> DC () -> IO () -paintHandler state dc = - do{ pDoc <- getDocument state - ; doc <- PD.getDocument pDoc - ; dp <- getDisplayOptions state - ; drawCanvas doc dc dp - } - -extensions :: [(String, [String])] -extensions = [ ("Blobs files (.blobs)", ["*.blobs"]) ] - -mouseEvent :: (InfoKind n g, InfoKind e g, Show g, Parse g, Descriptor g) => - EventMouse -> ScrolledWindow () -> Frame () -> State g n e -> IO () -mouseEvent eventMouse canvas theFrame state = case eventMouse of - MouseLeftDown mousePoint mods - | shiftDown mods -> leftMouseDownWithShift mousePoint state - | metaDown mods -> leftMouseDownWithMeta mousePoint state - | otherwise -> mouseDown True mousePoint theFrame state - MouseRightDown mousePoint _ -> - mouseDown False mousePoint theFrame state - MouseLeftDrag mousePoint _ -> - leftMouseDrag mousePoint canvas state - MouseLeftUp mousePoint _ -> - leftMouseUp mousePoint state - _ -> - return () - -keyboardEvent :: (InfoKind n g, InfoKind e g) => - Frame () -> State g n e -> EventKey -> IO () -keyboardEvent theFrame state (EventKey theKey _ _) = - case theKey of - KeyDelete -> deleteKey state - KeyBack -> backspaceKey state - KeyF2 -> f2Key theFrame state - KeyChar 'r' -> pressRKey theFrame state - KeyChar 'i' -> pressIKey theFrame state - KeyUp -> upKey state - KeyDown -> downKey state - _ -> propagateEvent - -closeDocAndThen :: State g n e -> IO () -> IO () -closeDocAndThen state action = - do{ pDoc <- getDocument state - ; continue <- PD.isClosingOkay pDoc - ; when continue $ action - } - -newItem :: (InfoKind n g, InfoKind e g) => State g n e -> g -> n -> e -> IO () -newItem state g n e = - closeDocAndThen state $ - do{ pDoc <- getDocument state - ; PD.resetDocument Nothing (Document.empty g n e) pDoc - ; repaintAll state - } - -openItem :: (InfoKind n g, InfoKind e g, XmlContent g) => - Frame () -> State g n e -> IO () -openItem theFrame state = - do{ mbfname <- fileOpenDialog - theFrame - False -- change current directory - True -- allowReadOnly - "Open File" - extensions - "" "" -- no default directory or filename - ; ifJust mbfname $ \fname -> openNetworkFile fname state (Just theFrame) - } - --- Third argument: Nothing means exceptions are ignored (used in Configuration) --- Just f means exceptions are shown in a dialog on top of frame f -openNetworkFile :: (InfoKind n g, InfoKind e g, XmlContent g) => - String -> State g n e -> Maybe (Frame ()) -> IO () -openNetworkFile fname state exceptionsFrame = - closeDocAndThen state $ - flip catch - (\exc -> case exceptionsFrame of - Nothing -> return () - Just f -> errorDialog f "Open network" - ( "Error while opening '" ++ fname ++ "'. \n\n" - ++ "Reason: " ++ show exc) - ) $ - do{ contents <- strictReadFile fname - ; let errorOrNetwork = NetworkFile.fromString contents - ; case errorOrNetwork of { - Left err -> ioError (userError err); - Right (network, warnings, oldFormat) -> - do{ -- "Open" document - ; let newDoc = setNetwork network (Document.empty undefined undefined undefined) - ; pDoc <- getDocument state - ; PD.resetDocument (if null warnings then Just fname else Nothing) - newDoc pDoc - ; applyCanvasSize state - ; when (not (null warnings)) $ - case exceptionsFrame of - Nothing -> return () - Just f -> - do{ errorDialog f "File read warnings" - ( "Warnings while reading file " ++ show fname ++ ":\n\n" - ++ unlines ( map ("* " ++) (take 10 warnings) - ++ if length warnings > 10 then ["..."] else [] - ) - ++ unlines - [ "" - , "Most likely you are reading a file that is created by a newer version of Blobs. If you save this file with" - , "this version of Blobs information may be lost. For safety the file name is set to \"untitled\" so that you do" - , "not accidentaly overwrite the file" - ] - ) - ; PD.setFileName pDoc Nothing - } - ; when oldFormat $ - do{ case exceptionsFrame of - Nothing -> return () - Just f -> - errorDialog f "File read warning" $ - unlines - [ "The file you opened has the old Blobs file format which will become obsolete in newer versions of Blobs." - , "When you save this network, the new file format will be used. To encourage you to do so the network has" - , "been marked as \"modified\"." - ] - ; PD.setDirty pDoc True - } - ; -- Redraw - ; repaintAll state - }}} - -openPalette :: (InfoKind n g, Parse n) => Frame () -> State g n e -> IO () -openPalette theFrame state = - do{ mbfname <- fileOpenDialog - theFrame - False -- change current directory - True -- allowReadOnly - "Open File" - [ ("Shape palettes (.blobpalette)", ["*.blobpalette"]) ] - "" "" -- no default directory or filename - ; ifJust mbfname $ \fname -> openPaletteFile fname state (Just theFrame) - } - --- Third argument: Nothing means exceptions are ignored (used in Configuration) --- Just f means exceptions are shown in a dialog on top of frame f -openPaletteFile :: (InfoKind n g, Parse n) => - String -> State g n e -> Maybe (Frame ()) -> IO () -openPaletteFile fname state exceptionsFrame = - flip catch - (\exc -> case exceptionsFrame of - Nothing -> return () - Just f -> errorDialog f "Open shape palette" - ( "Error while opening '" ++ fname ++ "'. \n\n" - ++ "Reason: " ++ show exc) - ) $ - do{ contents <- readFile fname - -- ; return () -- Dummy out for now - ; case fst (runParser parse contents) of { - Left msg -> ioError (userError ("Cannot parse shape palette file: " - ++fname++"\n\t"++msg)); - Right p -> do{ pDoc <- getDocument state - ; PD.updateDocument "change palette" - (updateNetwork (setPalette p)) - -- really ought to go through network and - -- change all nodes' stored shape. - pDoc - } - } - } - --- | Get the canvas size from the network and change the size of --- the widget accordingly -applyCanvasSize :: State g n e -> IO () -applyCanvasSize state = - do{ pDoc <- getDocument state - ; doc <- PD.getDocument pDoc - ; let network = getNetwork doc - (width, height) = getCanvasSize network - ; canvas <- getCanvas state - ; ppi <- getScreenPPI - ; set canvas [ virtualSize := sz (logicalToScreenX ppi width) - (logicalToScreenY ppi height) ] - } - -saveToDisk :: (InfoKind n g, InfoKind e g, XmlContent g) => - Frame () -> String -> Document.Document g n e -> IO Bool -saveToDisk theFrame fileName doc = - safeWriteFile theFrame fileName (NetworkFile.toString (getNetwork doc)) - -exit :: State g n e -> IO () -exit state = - closeDocAndThen state $ propagateEvent diff --git a/src/NetworkView.hs b/src/NetworkView.hs deleted file mode 100644 --- a/src/NetworkView.hs +++ /dev/null @@ -1,342 +0,0 @@ -module NetworkView - ( drawCanvas - , clickedNode - , clickedEdge - , clickedVia - , edgeContains - ) where - -import Constants -import CommonIO -import Network -import Document -import Colors -import Common -import Palette - -import Math -import Graphics.UI.WX as WX hiding (Vector) -import Graphics.UI.WXCore hiding (Document, screenPPI, Colour) -import Graphics.UI.WXCore.Draw -import Maybe -import Shape -import DisplayOptions -import InfoKind - -import Prelude hiding (catch) -import Control.Exception -import qualified Data.IntMap as IntMap - -drawCanvas :: (InfoKind n g, InfoKind e g, Descriptor g) => - Document g n e -> DC () -> DisplayOptions -> IO () -drawCanvas doc dc opt = - do{ - - -- Scale if the DC we are drawing to has a different PPI from the screen - -- Printing, nudge, nudge - ; dcPPI <- dcGetPPI dc - ; screenPPI <- getScreenPPI - ; when (dcPPI /= screenPPI) $ - dcSetUserScale dc - (fromIntegral (sizeW dcPPI ) / fromIntegral (sizeW screenPPI )) - (fromIntegral (sizeH dcPPI ) / fromIntegral (sizeH screenPPI )) - - -- Set font - ; set dc [ fontFamily := FontDefault, fontSize := 10 ] - - ; catch (reallyDrawCanvas doc screenPPI dc opt) - (h1 dc dcPPI ) - {- - (\e -> logicalText dcPPI dc (DoublePoint 50 50) - ("Exception while drawing: "++show e) - (Justify LeftJ TopJ) [] ) - -} - } - -h1 :: DC () -> Size2D Int -> SomeException -> IO () -h1 dc dcPPI e = logicalText dcPPI dc (DoublePoint 50 50) - ("Exception while drawing: "++show e) - (Justify LeftJ TopJ) [] - - -reallyDrawCanvas :: (InfoKind n g, InfoKind e g, Descriptor g) => - Document g n e -> Size -> DC () -> DisplayOptions -> IO () -reallyDrawCanvas doc ppi dc opt = - do{ - -- draw global info on diagram - ; let (width, _height) = Network.getCanvasSize network - ; when (GlobalInfo `elem` dpShowInfo opt) $ - drawLabel 0 False - (descriptor global++": "++(unwords.lines.show) global) - (DoublePoint (width/2) 1) (Justify CentreJ TopJ) - [ textColor := wxcolor kNodeLabelColour ] - -- draw edges, highlight the selected ones (if any) - ; mapM_ (\edge -> drawEdge edge []) (getEdges network) - ; case theSelection of - EdgeSelection edgeNr -> do - drawEdge (getEdge edgeNr network) kSELECTED_OPTIONS - ViaSelection edgeNr viaNr -> do - drawVia (getEdge edgeNr network) viaNr kSELECTED_OPTIONS - MultipleSelection _ _ viaNrs -> do - mapM_ (\ (e,v)-> drawVia (getEdge e network) v kSELECTED_OPTIONS) - viaNrs - _ -> return () - - -- draw nodes, highlight the selected ones (if any) - ; mapM_ (\(nodeNr, _) -> drawNode nodeNr [ ]) (getNodeAssocs network) - ; case theSelection of - NodeSelection nodeNr -> - drawNode nodeNr (kSELECTED_OPTIONS - ++ [ penColor := wxcolor activeSelectionColor ]) - MultipleSelection _ nodeNrs _ -> - mapM_ (\n-> drawNode n (kSELECTED_OPTIONS - ++ [ penColor := wxcolor activeSelectionColor ])) - nodeNrs - _ -> return () - - -- multiple selection drag area rectangle - ; case theSelection of - MultipleSelection (Just (p,q)) _ _ -> - logicalRect ppi dc (doublePointX p) (doublePointY p) - (doublePointX q - doublePointX p) - (doublePointY q - doublePointY p) - [ penColor := wxcolor lightGrey - , brushKind := BrushTransparent] - _ -> return () - - -- canvas size rectangle - -- ; let (width, height) = Network.getCanvasSize (getNetwork doc) - -- ; logicalRect ppi dc 0 0 width height [brushKind := BrushTransparent] - } - where - network = getNetwork doc - theSelection = getSelection doc - (Palette palette) = getPalette network - global = getGlobalInfo network - - drawNode :: Int -> [Prop (DC ())] -> IO () - drawNode nodeNr options = - do{ - -- draw node - ; logicalDraw ppi dc center shape options - -- ; logicalCircle ppi dc center kNODE_RADIUS options - -- draw label - ; when (NodeLabel `elem` dpShowInfo opt) $ - drawLabel (offset above) False (getName node) center - (justif above) [ textColor := wxcolor kNodeLabelColour ] - -- draw info - ; when (NodeInfo `elem` dpShowInfo opt) $ - drawLabel (offset (not above)) False (show (getInfo node)) - center (justif (not above)) - [ textColor := wxcolor kNodeInfoColour ] - } - where - node = getNode nodeNr network - above = getNameAbove node - center = getPosition node - shape = either (\name-> maybe Shape.circle fst - (Prelude.lookup name palette)) - id (getShape node) - offset b = (if b then negate else id) kNODE_RADIUS - justif b = Justify CentreJ (if b then BottomJ else TopJ) - - drawLabel :: Double -> Bool -> String -> DoublePoint -> Justify - -> [Prop (DC ())] -> IO () - drawLabel voffset boxed text (DoublePoint x y) justify opts = - do{ -- draw background - when boxed $ do - { (textWidth, textHeight) <- logicalGetTextExtent ppi dc text - ; let horizontalMargin = 0.2 -- centimeters - verticalMargin = 0.01 -- centimeters - topleftY = y+voffset - case justify of - Justify _ TopJ -> 0 - Justify _ MiddleJ -> textHeight/2 - Justify _ BottomJ -> textHeight - - ; logicalRect ppi dc - (x - textWidth/2 - horizontalMargin) (topleftY) - (textWidth+2*horizontalMargin) (textHeight+2*verticalMargin) - (solidFill labelBackgroundColor) - } - -- draw text - ; logicalText ppi dc (DoublePoint x (y+voffset)) text justify opts - } - - drawEdge :: InfoKind e g => Edge e -> [Prop (DC ())] -> IO () - drawEdge edge options = - do{ logicalLineSegments ppi dc (pt1:via++[pt2]) options - -- arrow on the end - ; logicalPoly ppi dc [pt2, tr1, tr2] (options ++ solidFill licorice) - -- draw info - ; when (EdgeInfo `elem` dpShowInfo opt) $ - -- logicalTextRotated ppi dc (middle via) (show info) 45 - -- [ textColor := wxcolor kEdgeInfoColour ] - drawLabel 0 False (show (getEdgeInfo edge)) (middle via) - (Justify CentreJ BottomJ) - [ textColor := wxcolor kEdgeInfoColour ] - } - where - fromNode = getNode (getEdgeFrom edge) network - toNode = getNode (getEdgeTo edge) network - - fromPoint = getPosition fromNode - toPoint = getPosition toNode - via = getEdgeVia edge - - fstEdgeVector = (head (via++[toPoint])) - `subtractDoublePointVector` fromPoint - fstTotalLen = vectorLength fstEdgeVector - fstAngle = vectorAngle fstEdgeVector - - penultimatePt = head (reverse (fromPoint:via)) - endEdgeVector = toPoint `subtractDoublePointVector` penultimatePt - endTotalLen = vectorLength endEdgeVector - endAngle = vectorAngle endEdgeVector - - middle [] = DoublePoint ((doublePointX pt1 + doublePointX pt2)/2) - ((doublePointY pt1 + doublePointY pt2)/2) - middle [p] = p - middle ps = middle (tail (reverse ps)) - - pt1 = translatePolar fstAngle kNODE_RADIUS fromPoint - pt2 = translatePolar endAngle (endTotalLen - kNODE_RADIUS) penultimatePt - - tr1 = translatePolar (endAngle + pi + pi / 6) kARROW_SIZE pt2 - tr2 = translatePolar (endAngle + pi - pi / 6) kARROW_SIZE pt2 - - drawVia :: Edge e -> ViaNr -> [Prop (DC ())] -> IO () - drawVia e n options = - let pt = (getEdgeVia e)!!n in - do logicalCircle ppi dc pt kEDGE_CLICK_RANGE - (options ++ solidFill violet) - -solidFill :: Colour -> [Prop (DC ())] -solidFill colour = [ brushKind := BrushSolid, brushColor := wxcolor colour ] - --- | Finds which node of the network is clicked by the mouse, if any -clickedNode :: DoublePoint -> Document g n e -> Maybe Int -clickedNode clickedPoint doc = - let network = getNetwork doc - nodeAssocs = case getSelection doc of - NodeSelection nodeNr -> [(nodeNr, getNode nodeNr network)] - _ -> [] - ++ reverse (getNodeAssocs network) - in case filter (\(_, node) -> node `nodeContains` clickedPoint) nodeAssocs of - [] -> Nothing - ((i, _):_) -> Just i - -nodeContains :: Node n -> DoublePoint -> Bool -nodeContains node clickedPoint = - distancePointPoint (getPosition node) clickedPoint - < kNODE_RADIUS - --- | Finds which edge of the network is clicked by the mouse, if any -clickedEdge :: DoublePoint -> Network g n e -> Maybe Int -clickedEdge clickedPoint network = - let assocs = getEdgeAssocs network - in case filter (\(_, edge) -> isJust (edgeContains edge clickedPoint network)) assocs of - [] -> Nothing - ((i, _):_) -> Just i - -edgeContains :: Edge e -> DoublePoint -> Network g n e -> Maybe Int -edgeContains edge clickedPoint network = - let p0 = getNodePosition network (getEdgeFrom edge) - p1 = getNodePosition network (getEdgeTo edge) - via= getEdgeVia edge - p = clickedPoint - numberedDistancesToSegments = zip [0..] $ - zipWith (\p0 p1-> distanceSegmentPoint p0 p1 p) - (p0:via) (via++[p1]) - in case [ nr | (nr,dist) <- numberedDistancesToSegments - , dist < kEDGE_CLICK_RANGE ] of - [] -> Nothing - nrs -> Just (head nrs) - --- | Finds which 'via' control point is clicked by the mouse, if any -clickedVia :: DoublePoint -> Network g n e -> Maybe (Int,Int) -clickedVia clickedPoint network = - let allVia = concatMap (\ (k,e)-> zipWith (\n v->((k,n),v)) - [0..] (getEdgeVia e)) - (IntMap.toList (networkEdges network)) - in case filter (\ (_,v)-> distancePointPoint v clickedPoint - < kEDGE_CLICK_RANGE) allVia of - [] -> Nothing - ((kn,_):_) -> Just kn - --- Drawing operations in logical coordinates - -logicalCircle :: Size -> DC () -> DoublePoint -> Double -> [Prop (DC ())] -> IO () -logicalCircle ppi dc center radius options = - WX.circle dc (logicalToScreenPoint ppi center) (logicalToScreenX ppi radius) options - -logicalRect :: Size -> DC () -> Double -> Double -> Double -> Double -> [Prop (DC ())] -> IO () -logicalRect ppi dc x y width height options = - drawRect dc - (rect - (pt (logicalToScreenX ppi x) (logicalToScreenY ppi y)) - (sz (logicalToScreenX ppi width) (logicalToScreenY ppi height))) - options - -data Justify = Justify Horizontal Vertical deriving Eq -data Horizontal = LeftJ | CentreJ | RightJ deriving Eq -data Vertical = TopJ | MiddleJ | BottomJ deriving Eq - --- can deal with multi-line text -logicalText :: Size -> DC () -> DoublePoint -> String -> Justify - -> [Prop (DC ())] -> IO () -logicalText ppi dc (DoublePoint x y) txt (Justify horiz vert) options = - do{ (width,height) <- logicalGetTextExtent ppi dc txt - ; eachLine width (startPos height) (lines txt) - } - where - startPos height = case vert of TopJ -> (x, y) - MiddleJ -> (x, y-height/2) - BottomJ -> (x, y-height) - eachLine _ _ [] = return () - eachLine maxwidth (x,y) (txt:txts) = - do{ (w,h) <- logicalGetTextExtent ppi dc txt - ; let thisX = case horiz of LeftJ -> x-maxwidth/2 - CentreJ -> x-w/2 - RightJ -> x+(maxwidth/2)-w - ; drawText dc txt (logicalToScreenPoint ppi (DoublePoint thisX y)) - options - ; eachLine maxwidth (x,y+h) txts - } - --- currently assumes only single line of text -logicalTextRotated :: Size -> DC () -> DoublePoint -> String -> Double - -> [Prop (DC ())] -> IO () -logicalTextRotated ppi dc pos txt angle options = - draw dc txt (logicalToScreenPoint ppi pos) options - where - draw = if angle<1 && angle>(-1) then drawText - else (\a b c e -> rotatedText a b c angle e) - - -{- -logicalLine :: Size -> DC () -> DoublePoint -> DoublePoint -> [Prop (DC ())] -> IO () -logicalLine ppi dc fromPoint toPoint options = - line dc (logicalToScreenPoint ppi fromPoint) - (logicalToScreenPoint ppi toPoint) options - -logicalLineSegments :: Size -> DC () -> [DoublePoint] -> [Prop (DC ())] -> IO () -logicalLineSegments _ _ [p] options = return () -logicalLineSegments ppi dc (fromPoint:toPoint:ps) options = - do{ line dc (logicalToScreenPoint ppi fromPoint) - (logicalToScreenPoint ppi toPoint) options - ; logicalLineSegments ppi dc (toPoint:ps) options - } --} - -logicalPoly :: Size -> DC () -> [DoublePoint] -> [Prop (DC ())] -> IO () -logicalPoly ppi dc points options = - polygon dc (map (logicalToScreenPoint ppi) points) options - -logicalGetTextExtent :: Size -> DC () -> String -> IO (Double, Double) -logicalGetTextExtent ppi dc txt = - do{ textSizes <- mapM (getTextExtent dc) (lines txt) - ; return - ( screenToLogicalX ppi (maximum (map sizeW textSizes)) - , screenToLogicalY ppi (sum (map sizeH textSizes)) - ) - } diff --git a/src/Operations.hs b/src/Operations.hs deleted file mode 100644 --- a/src/Operations.hs +++ /dev/null @@ -1,50 +0,0 @@ -module Operations where - -import InfoKind -import Network -import State -import Document -import qualified PersistentDocument as PD - -import qualified Data.IntMap as IntMap - --- | @GraphOps@ is a data structure holding a bunch of named operations --- on the graph network. An operation is simply executed in the I/O monad, --- taking the entire state as argument - it is up to the action to do any --- state updates it wants to. -data GraphOps g n e = GraphOps { ioOps :: [ (String, IOOp g n e) ] } - -callGraphOp :: String -> GraphOps g n e -> State g n e -> IO () -callGraphOp opName graphOps state = - maybe (return ()) ($ state) (Prelude.lookup opName (ioOps graphOps)) - -type PureOp g n e = -- (InfoKind n g, InfoKind e g) - (g, IntMap.IntMap (Node n), IntMap.IntMap (Edge e)) - -> (g, IntMap.IntMap (Node n), IntMap.IntMap (Edge e)) -type IOOp g n e = -- (InfoKind n g, InfoKind e g) => - State g n e - -> IO () - --- | In general, operations can be classified into pure and I/O variants. --- A pure operation takes a graph and returns a new graph, which is --- stored back into the current document (can be reverted with the --- standard 'undo' menu item), and displayed immediately. Use this --- helper 'pureGraphOp' to turn your pure function into an I/O action --- for the Operations menu. -pureGraphOp :: (String, PureOp g n e) -> (String, IOOp g n e) -pureGraphOp (opName,operation) = - (opName, \state-> do{ pDoc <- getDocument state - ; doc <- PD.getDocument pDoc - ; let network = getNetwork doc - g = getGlobalInfo network - n = networkNodes network - e = networkEdges network - (g',n',e') = operation (g,n,e) - network' = setNodeAssocs (IntMap.assocs n') - $ setEdgeAssocs (IntMap.assocs e') - $ setGlobalInfo g' - $ network - ; PD.updateDocument opName (setNetwork network') pDoc - } - ) - diff --git a/src/PDDefaults.hs b/src/PDDefaults.hs deleted file mode 100644 --- a/src/PDDefaults.hs +++ /dev/null @@ -1,92 +0,0 @@ -{-| Module : PDDefaults - Author : Arjan van IJzendoorn - License : do whatever you like with this - - Maintainer : afie@cs.uu.nl - - Some defaults for the field of the persistent document - record. For example, the default undo update function - changes the text of a menu item to reflect what will be - undo and disables it if there is nothing to be undone. - You might want more than the defaults if you have a - more advanced GUI. Let's say you also have a button - in a toolbar to undo, then you might want to gray out - that button, too, if there is nothing to be undone. --} - -module PDDefaults where - -import Graphics.UI.WX -import Graphics.UI.WXCore(wxID_CANCEL) - -type Extensions = [(String, [String])] - --- Update the menu item "Undo" to show which --- action will be undone. If there is nothing --- to undo the corresponding menu item is disabled -defaultUpdateUndo :: MenuItem () -> Bool -> String -> IO () -defaultUpdateUndo undoItem enable message = - set undoItem - [ text := "Undo " ++ message ++ "\tCtrl+Z" - , enabled := enable - ] - -defaultUpdateRedo :: MenuItem () -> Bool -> String -> IO () -defaultUpdateRedo redoItem enable message = - set redoItem - [ text := "Redo " ++ message ++ "\tCtrl+Y" - , enabled := enable - ] - --- Enable the save item only if the document is dirty -defaultUpdateSave :: MenuItem () -> Bool -> IO () -defaultUpdateSave saveItem enable = - set saveItem [ enabled := enable ] - --- Update the title bar: program name - document name followed by "(modified)" if --- the document is dirty -defaultUpdateTitlebar :: Frame () -> String -> Maybe String -> Bool -> IO () -defaultUpdateTitlebar theFrame programName theFileName modified = - let newTitle = programName - ++ " - " - ++ (case theFileName of Nothing -> "untitled"; Just name -> name) - ++ (if modified then " (modified)" else "") - in set theFrame [ text := newTitle ] - --- | defaultSaveChangesDialog shows a dialog with three buttons with corresponding --- return values: Don't Save -> Just False, Save -> Just True --- Cancel -> Nothing -defaultSaveChangesDialog :: Frame () -> String -> IO (Maybe Bool) -defaultSaveChangesDialog parentWindow theProgramName = - do{ d <- dialog parentWindow [text := theProgramName] - ; p <- panel d [] - ; msg <- staticText p [text := "Do you want to save the changes?"] - ; dontsaveB <- button p [text := "Don't Save"] - ; saveB <- button p [text := "Save"] - ; cancelB <- button p [text := "Cancel", identity := wxID_CANCEL ] - ; set d [layout := margin 10 $ container p $ - column 10 [ hfill $ widget msg - , row 50 [ floatBottomLeft $ widget dontsaveB - , floatBottomRight $ row 5 [ widget saveB, widget cancelB] - ] - ] - ] - -- ; set p [ defaultButton := saveB ] - ; set d [ defaultButton := saveB ] - ; showModal d $ \stop -> - do set dontsaveB [on command := stop (Just False) ] - set saveB [on command := stop (Just True) ] - set cancelB [on command := stop Nothing ] - } - -defaultSaveAsDialog :: Frame () -> Extensions -> Maybe String -> IO (Maybe String) -defaultSaveAsDialog theFrame extensions theFileName = - fileSaveDialog - theFrame - False -- remember current directory - True -- overwrite prompt - "Save file" - extensions - "" -- directory - (case theFileName of Nothing -> ""; Just name -> name) -- initial file name - diff --git a/src/Palette.hs b/src/Palette.hs deleted file mode 100644 --- a/src/Palette.hs +++ /dev/null @@ -1,29 +0,0 @@ -module Palette where - -import List (nub, (\\)) -import Shape -import Text.Parse - -data Palette a = Palette [ (String, (Shape, Maybe a)) ] - deriving (Eq, Show, Read) - -shapes :: Palette a -> [ (String,(Shape,Maybe a)) ] -shapes (Palette p) = p - -join :: Eq a => Palette a -> Palette a -> Palette a -join (Palette p) (Palette q) = Palette (nub (p++q)) - -delete :: Eq a => Palette a -> Palette a -> Palette a -delete (Palette p) (Palette q) = Palette (p\\q) - --- cannot be completely empty, always one default shape -empty :: Palette a -empty = Palette [("circle", (Shape.circle, Nothing))] - -instance Functor Palette where - fmap _ (Palette p) = Palette (map (\ (n,(s,i))-> (n,(s,Nothing))) p) - - -instance Parse a => Parse (Palette a) where - parse = do{ isWord "Palette"; fmap Palette $ parse } - diff --git a/src/PersistentDocument.hs b/src/PersistentDocument.hs deleted file mode 100644 --- a/src/PersistentDocument.hs +++ /dev/null @@ -1,339 +0,0 @@ -{-| Module : PersistentDocument - Author : Arjan van IJzendoorn - License : do whatever you like with this - - Maintainer : afie@cs.uu.nl - - The persistent document abstraction takes care of dealing - with a document you want to open from and save to disk and - that supports undo. This functionality can be used by editors - of arbitrary documents and saves you a lot of quite subtle - coding. You only need to initialise a record with things like - your document, the file name and call-back functions. After - this, the framework takes care of the hard work. The framework - is highly parametrisable but there are defaults for many - parameters. - - The features in detail: - - unlimited undo & redo buffers (or limited, if you choose to) - - undo and redo items show what will be undone / redone - (e.g. "Undo delete node") - - undo and redo items are disabled if there is nothing to undo or redo - - maintains a dirty bit that tells you whether the document has - changed with respect to the version on disk - - the save menu item can be disabled if the document is not dirty - - the title bar can be updated to show the program name, the file name - and whether the document is dirty (shown as "modified") - - when trying to close the document, the user is asked whether he/she - wants to save the changes (if needed) - - handles interaction between saving a document and the dirty bits - of the document and of the documents in the history and future - - properly handles Cancel or failure at any stage, e.g. the user - closes a dirty document with no file name, "Do you want to save - the changes" dialog is shown, user selects "Save", a Save as - dialog is opened, user selects a location that happens to be - read-only, saving fails and the closing of the document is - cancelled. --} - -module PersistentDocument - ( PersistentDocument, PDRecord(..) - - , PersistentDocument.dummy - , initialise - , resetDocument - - , setDocument, updateDocument - , superficialSetDocument, superficialUpdateDocument - - , getDocument - , getFileName, setFileName - , setDirty - - , undo, redo - , save, saveAs, isClosingOkay - ) where - ---import IOExts(IORef, newIORef, writeIORef, readIORef) -import Data.IORef(IORef, newIORef, writeIORef, readIORef) -import Monad(when) - --- | A persistent document is a mutable variable. This way functions --- operating on a document do not have to return the new value but --- simply update it. -type PersistentDocument a = IORef (PDRecord a) - --- | The persistent document record maintains all information needed --- for undo, redo and file management -data PDRecord a = PD - { document :: a - - -- UNDO & REDO - , history :: [(String, Bool, a)] - -- ^ A history item contains a message (what will be undone), - -- the dirty bit and a copy of the document - , future :: [(String, Bool, a)] - -- ^ See history - , limit :: Maybe Int - -- ^ Maximum number of items of undo history. Or no limit - -- in the case of Nothing - - -- FILE MANAGEMENT - , fileName :: Maybe String - -- ^ Nothing means no file name yet (untitled) - , dirty :: Bool - -- ^ Has the document changed since saving? - - -- CALL-BACK FUNCTIONS - , updateUndo :: Bool -> String -> IO () - -- ^ This callback is called when the undo status changes. First parameter - -- means enable (True) or disable (False). Second parameter is the message - -- of the first item in the history - , updateRedo :: Bool -> String -> IO () - -- ^ See updateUndo - , updateSave :: Bool -> IO () - -- ^ This call-back is called when the save status changes. The boolean - -- indicates whether save is enabled (dirty document) or disabled (not dirty) - , updateTitleBar :: Maybe String -> Bool -> IO () - -- ^ This call-back is called when the title bar information changes: - -- file name and modified or not. - , saveToDisk :: String -> a -> IO Bool - -- ^ This callback should actually save the document to disk. It should - -- return False if saving fails (no permission, disk full...) - , saveChangesDialog :: IO (Maybe Bool) - -- ^ This call-back is called when the user should be prompted whether - -- he/she wants to save the changes or not. Results: - -- Don't Save -> Just False, Save -> Just True, Cancel -> Nothing - , saveAsDialog :: Maybe String -> IO (Maybe String) - -- ^ This call-back is called when the user should specify a - -- location and a name for the file. The parameter is the current - -- file name of the document - } - --- | A dummy persistent document is needed because you need something to pass --- to the command handlers of menu items BEFORE you can initialse the --- persistent document with those menu items -dummy :: IO (PersistentDocument a) -dummy = newIORef (error $ "PersistentDocument.empty: call initialise before using " - ++ "the persistent document") - --- | Initialise the persistent document with menu items (undo, redo, save), --- information needed for open & save dialogs, for saving and for updating the --- title bar -initialise :: PersistentDocument a -> PDRecord a -> IO () -initialise pDocRef pDoc = - do{ writeIORef pDocRef pDoc - ; updateGUI pDocRef - } - --- | Clear the document and start with a given document with given file name --- This function is typically called when you open a new document from disk --- or start a fresh document that should replace the current document -resetDocument :: Maybe String -> a -> PersistentDocument a -> IO () -resetDocument theFileName doc pDocRef = - do{ updateIORef pDocRef (\pDoc -> pDoc - { document = doc - , history = [] - , future = [] - , fileName = theFileName - , dirty = False - }) - ; updateGUI pDocRef - } - --- | Get the actual document stored within the persistent document -getDocument :: PersistentDocument a -> IO a -getDocument pDocRef = - do{ pDoc <- readIORef pDocRef - ; return (document pDoc) - } - --- | Get the file name stored within the persistent document -getFileName :: PersistentDocument a -> IO (Maybe String) -getFileName pDocRef = - do{ pDoc <- readIORef pDocRef - ; return (fileName pDoc) - } - --- | Get the file name stored within the persistent document -setFileName :: PersistentDocument a -> Maybe String -> IO () -setFileName pDocRef maybeName = - do{ pDoc <- readIORef pDocRef - ; writeIORef pDocRef (pDoc { fileName = maybeName }) - ; updateGUI pDocRef - } - -setDirty :: PersistentDocument a -> Bool -> IO () -setDirty pDocRef newDirtyBit = - do{ pDoc <- readIORef pDocRef - ; writeIORef pDocRef (pDoc { dirty = newDirtyBit }) - ; updateGUI pDocRef - } - --- | Replace the document inside the persistent document. The current --- document is remembered in the history list along with the given --- message. The future list is cleared. -setDocument :: String -> a -> PersistentDocument a -> IO () -setDocument message newDoc pDocRef = - do{ pDoc <- readIORef pDocRef - ; let applyLimit = case limit pDoc of - Nothing -> id - Just nr -> take nr - newPDoc = - pDoc - { document = newDoc - , history = applyLimit $ (message,dirty pDoc,document pDoc):history pDoc - , future = [] - , dirty = True - } - ; writeIORef pDocRef newPDoc - ; updateGUI pDocRef - } - - --- | Get document, apply function, set document -updateDocument :: String -> (a -> a) -> PersistentDocument a -> IO () -updateDocument message fun pDocRef = - do{ doc <- getDocument pDocRef - ; setDocument message (fun doc) pDocRef - } - --- | Replace the document without remembering the old document in --- the history. Superficial updates are useful if something as --- volatile as a selection is part of your document. If the selection --- changes you don't want to be able to undo it or to mark --- the document as dirty -superficialSetDocument :: a -> PersistentDocument a -> IO () -superficialSetDocument newDoc pDocRef = - updateIORef pDocRef (\pDoc -> pDoc { document = newDoc }) - --- | Get document, apply function, superficial set document -superficialUpdateDocument :: (a -> a) -> PersistentDocument a -> IO () -superficialUpdateDocument fun pDocRef = - do{ doc <- getDocument pDocRef - ; superficialSetDocument (fun doc) pDocRef - } - --- | Check whether closing the document is okay. If the document --- is dirty, the user is asked whether he/she wants to save the --- changes. Returns False if this process is cancelled or fails --- at any point. -isClosingOkay :: PersistentDocument a -> IO Bool -isClosingOkay pDocRef = - do{ pDoc <- readIORef pDocRef - ; if not (dirty pDoc) then return True else - do{ result <- saveChangesDialog pDoc - ; case result of - Nothing -> return False - Just True -> - do{ hasBeenSaved <- save pDocRef - ; return hasBeenSaved - } - Just False -> return True - }} - --- | Save should be called when "Save" is selected from the file menu. --- If there is no file name yet, this function acts as if "Save as" --- was called. It returns False if saving is cancelled or fails. -save :: PersistentDocument a -> IO Bool -save pDocRef = - do{ pDoc <- readIORef pDocRef - ; case fileName pDoc of - Nothing -> saveAs pDocRef - Just name -> performSave name pDocRef - } - --- | saveAs should be called when "Save As" is selected from the file menu. --- A dialog is shown where the user can select a location to save document. --- This function returns False if saving is cancelled or fails. -saveAs :: PersistentDocument a -> IO Bool -saveAs pDocRef = - do{ pDoc <- readIORef pDocRef - ; mbfname <- saveAsDialog pDoc (fileName pDoc) - ; case mbfname of - Just fname -> performSave fname pDocRef - Nothing -> return False - } - - --- | The current document is stored in the future list --- and the first element of the history list is taken --- as the new document -undo :: PersistentDocument a -> IO () -undo pDocRef = - do{ pDoc <- readIORef pDocRef - ; when (not (null (history pDoc))) $ - do{ let (msg, newDirty, newDoc) = head (history pDoc) - newPDoc = pDoc - { document = newDoc - , dirty = newDirty - , history = tail (history pDoc) - , future = (msg, dirty pDoc, document pDoc) : future pDoc - } - ; writeIORef pDocRef newPDoc - ; updateGUI pDocRef - }} - --- | The current document is stored in the history list --- and the first element of the future list is taken --- as the new document -redo :: PersistentDocument a -> IO () -redo pDocRef = - do{ pDoc <- readIORef pDocRef - ; when (not (null (future pDoc))) $ - do{ let (msg, newDirty, newDoc) = head (future pDoc) - newPDoc = pDoc - { document = newDoc - , dirty = newDirty - , future = tail (future pDoc) - , history = (msg, dirty pDoc, document pDoc) : history pDoc - } - ; writeIORef pDocRef newPDoc - ; updateGUI pDocRef - }} - --- FUNCTIONS THAT ARE NOT EXPORTED - -updateIORef :: IORef a -> (a -> a) -> IO () -updateIORef var fun = do { x <- readIORef var; writeIORef var (fun x) } - --- Perform the actual save to disk. If this fails False is returned --- otherwise the file name is set and the dirty bit is cleared. The --- dirty bits of history and future documents are set. -performSave :: String -> PersistentDocument a -> IO Bool -performSave name pDocRef = - do{ pDoc <- readIORef pDocRef - ; hasBeenSaved <- (saveToDisk pDoc) name (document pDoc) - ; if not hasBeenSaved then return False else - do{ writeIORef pDocRef (pDoc { fileName = Just name }) - ; updateDirtyBitsOnSave pDocRef - ; updateGUI pDocRef - ; return True - }} - --- updateDirtyBitsOnSave clears the dirty bit for the --- current document and sets the dirty bits of all --- documents in history and future lists -updateDirtyBitsOnSave :: PersistentDocument a -> IO () -updateDirtyBitsOnSave pDocRef = - updateIORef pDocRef (\pDoc -> pDoc - { history = map makeDirty (history pDoc) - , future = map makeDirty (future pDoc) - , dirty = False - }) - where - makeDirty (msg, _, doc) = (msg, True, doc) - --- Shorthand to call all call-backs that update the GUI -updateGUI :: PersistentDocument a -> IO () -updateGUI pDocRef = - do{ pDoc <- readIORef pDocRef - ; case history pDoc of - [] -> updateUndo pDoc False "" - ((msg, _, _):_) -> updateUndo pDoc True msg - ; case future pDoc of - [] -> updateRedo pDoc False "" - ((msg, _, _):_) -> updateRedo pDoc True msg - ; updateSave pDoc (dirty pDoc) - ; updateTitleBar pDoc (fileName pDoc) (dirty pDoc) - } diff --git a/src/SafetyNet.hs b/src/SafetyNet.hs deleted file mode 100644 --- a/src/SafetyNet.hs +++ /dev/null @@ -1,24 +0,0 @@ -module SafetyNet where - -import Graphics.UI.WX hiding (window) -import Prelude hiding (catch) -import Control.Exception (SomeException,Exception,catch) - - -safetyNet :: Window a -> IO b -> IO () -safetyNet window computation = - do{ catch - (do { computation; return () }) - (handler window) - ; return () - } - -handler :: Window a -> SomeException -> IO () -handler window exception = - do{ putStrLn $ "SafetyNet exception: " ++ show exception - ; errorDialog window "Exception" - ( "An exception occurred; please report the following text exactly to the makers: \n\n" - ++ show exception ++ "\n\n" - ++ "Please save the network under a different name and quit Blobs" - ) - } diff --git a/src/Shape.hs b/src/Shape.hs deleted file mode 100644 --- a/src/Shape.hs +++ /dev/null @@ -1,170 +0,0 @@ -module Shape where - -import CommonIO -import Graphics.UI.WX as WX -import Graphics.UI.WXCore hiding (Colour) -import Graphics.UI.WXCore.Draw -import Math -import Text.Parse ---import Text.XML.HaXml.XmlContent ---import NetworkFile - -import Colors -import Constants - -data Shape = - Circle { shapeStyle :: ShapeStyle, shapeRadius :: Double } - | Polygon { shapeStyle :: ShapeStyle, shapePerimeter :: [DoublePoint] } - -- centred on (0,0) - | Lines { shapeStyle :: ShapeStyle, shapePerimeter :: [DoublePoint] } - -- no fill for open shape - | Composite { shapeSegments :: [Shape] } -- drawn in given order - deriving (Eq, Show, Read) - -data ShapeStyle = ShapeStyle - { styleStrokeWidth :: Int - , styleStrokeColour :: Colour - , styleFill :: Colour - } - deriving (Eq, Show, Read) - -instance Parse Shape where - parse = oneOf - [ do{ isWord "Circle" - ; return Circle - `discard` isWord "{" `apply` field "shapeStyle" - `discard` isWord "," `apply` field "shapeRadius" - `discard` isWord "}" - } - , do{ isWord "Polygon" - ; return Polygon - `discard` isWord "{" `apply` field "shapeStyle" - `discard` isWord "," `apply` field "shapePerimeter" - `discard` isWord "}" - } - , do{ isWord "Lines" - ; return Lines - `discard` isWord "{" `apply` field "shapeStyle" - `discard` isWord "," `apply` field "shapePerimeter" - `discard` isWord "}" - } - , do{ isWord "Composite" - ; return Composite - `discard` isWord "{" `apply` field "shapeSegments" - `discard` isWord "}" - } - ] `adjustErr` (++"\nexpected a Shape (Circle,Polygon,Lines,Composite)") - -instance Parse ShapeStyle where - parse = do{ isWord "ShapeStyle" - ; return ShapeStyle - `discard` isWord "{" `apply` field "styleStrokeWidth" - `discard` isWord "," `apply` field "styleStrokeColour" - `discard` isWord "," `apply` field "styleFill" - `discard` isWord "}" - } - -{- -instance HTypeable Shape where - toHType s = Defined "Shape" [] [ Constr "Circle" [] [] - , Constr "Polygon" [] [] - , Constr "Lines" [] [] - , Constr "Composite" [] [] - ] -instance XmlContent Shape where - toContents s@(Circle{}) = - [ mkElemC "Circle" (toContents (shapeStyle s) - ++ [mkElemC "radius" (toContents (shapeRadius s))]) ] - toContents s@(Polygon{}) = - [ mkElemC "Polygon" (toContents (shapeStyle s) - ++ [mkElemC "perimeter" (concatMap toContents - (shapePerimeter s))]) ] - toContents s@(Lines{}) = - [ mkElemC "Lines" (toContents (shapeStyle s) - ++ [mkElemC "perimeter" (concatMap toContents - (shapePerimeter s))]) ] - toContents s@(Composite{}) = - [ mkElemC "Composite" (concatMap toContents (shapeSegments s)) ] - parseContents = do - { e@(Elem t _ _) <- element ["Circle","Polygon","Lines","Composite"] - ; case t of - "Circle" -> interior e $ - do{ style <- parseContents - ; r <- inElement "radius" parseContents - ; return (Circle {shapeStyle=style, shapeRadius=r}) - } - "Polygon" -> interior e $ - do{ style <- parseContents - ; p <- inElement "perimeter" $ many1 parseContents - ; return (Polygon {shapeStyle=style, shapePerimeter=p}) - } - "Lines" -> interior e $ - do{ style <- parseContents - ; p <- inElement "perimeter" $ many1 parseContents - ; return (Lines {shapeStyle=style, shapePerimeter=p}) - } - "Composite" -> interior e $ do{ ss <- many1 parseContents - ; return (Composite {shapeSegments=ss}) - } - } - -instance HTypeable ShapeStyle where - toHType s = Defined "ShapeStyle" [] [Constr "ShapeStyle" [] []] -instance XmlContent ShapeStyle where - toContents s = - [ mkElemC "ShapeStyle" - [ mkElemC "StrokeWidth" (toContents (styleStrokeWidth s)) - , mkElemC "StrokeColour" (toContents (styleStrokeColour s)) - , mkElemC "Fill" (toContents (styleFill s)) - ] - ] - parseContents = inElement "ShapeStyle" $ do - { w <- inElement "StrokeWidth" parseContents - ; c <- inElement "StrokeColour" parseContents - ; f <- inElement "Fill" parseContents - ; return (ShapeStyle { styleStrokeWidth=w, styleStrokeColour=c - , styleFill=f }) - } --} - -logicalDraw :: Size -> DC () -> DoublePoint -> Shape -> [Prop (DC ())] -> IO () -logicalDraw ppi dc centre shape options = - case shape of - Circle {} -> WX.circle dc (logicalToScreenPoint ppi centre) - (logicalToScreenX ppi (shapeRadius shape)) - (style2options (shapeStyle shape)++options) - Polygon {} -> WX.polygon dc (map (logicalToScreenPoint ppi - . translate centre) - (shapePerimeter shape)) - (style2options (shapeStyle shape)++options) - Lines {} -> logicalLineSegments ppi dc (map (translate centre) - (shapePerimeter shape)) - (style2options (shapeStyle shape)++options) - Composite {}-> mapM_ (\s-> logicalDraw ppi dc centre s options) - (shapeSegments shape) - -logicalLineSegments :: Size -> DC () -> [DoublePoint] -> [Prop (DC ())] -> IO () -logicalLineSegments _ _ [_p] _options = return () -logicalLineSegments ppi dc (fromPoint:toPoint:ps) options = - do{ line dc (logicalToScreenPoint ppi fromPoint) - (logicalToScreenPoint ppi toPoint) options - ; logicalLineSegments ppi dc (toPoint:ps) options - } - -circle :: Shape -circle = Circle { shapeStyle = defaultShapeStyle - , shapeRadius = kNODE_RADIUS } - -style2options :: ShapeStyle -> [Prop (DC ())] -style2options sty = - [ penWidth := styleStrokeWidth sty - , penColor := wxcolor (styleStrokeColour sty) - , brushKind := BrushSolid - , brushColor := wxcolor (styleFill sty) - ] - -defaultShapeStyle :: ShapeStyle -defaultShapeStyle = - ShapeStyle { styleStrokeWidth = 1 - , styleStrokeColour = licorice - , styleFill = nodeColor } diff --git a/src/State.hs b/src/State.hs deleted file mode 100644 --- a/src/State.hs +++ /dev/null @@ -1,108 +0,0 @@ -module State - ( State - , State.empty - , ToolWindow(..) - - , getDocument - , getDragging, setDragging - , getCanvas, setCanvas - , getNetworkFrame, setNetworkFrame - , getPageSetupDialog, setPageSetupDialog - , getDisplayOptions, setDisplayOptions - , changeDisplayOptions - ) where - -import Document -import Math -import qualified PersistentDocument as PD -import DisplayOptions - -import Graphics.UI.WX -import Graphics.UI.WXCore hiding (Document, ToolWindow) - -type State g n e = Var (StateRecord g n e) - -data StateRecord g n e = St - { stDocument :: PD.PersistentDocument (Document g n e) - , stDragging :: Maybe (Bool, DoublePoint) -- ^ (really moved?, offset from center of node) - , stNetworkFrame :: Frame () - , stCanvas :: ScrolledWindow () - , stPageSetupDialog :: PageSetupDialog () - , stDisplayOptions :: DisplayOptions - } - -data ToolWindow = TW - { twRepaint :: IO () - , twFrame :: Frame () - } - -empty :: IO (State g n e) -empty = - do{ dummy <- PD.dummy - - ; varCreate (St - { stDocument = dummy - , stNetworkFrame = error "State.empty: network frame has not been set" - , stDragging = Nothing - , stCanvas = error "State.empty: canvas has not been set" - , stPageSetupDialog = error "State.empty: page setup dialog has not been set" - , stDisplayOptions = DisplayOptions.standard - }) - } - --- Getters - -getDocument :: State g n e -> IO (PD.PersistentDocument (Document g n e)) -getDocument = getFromState stDocument - -getDragging :: State g n e -> IO (Maybe (Bool, DoublePoint)) -getDragging = getFromState stDragging - -getNetworkFrame :: State g n e -> IO (Frame ()) -getNetworkFrame = getFromState stNetworkFrame - -getCanvas :: State g n e -> IO (ScrolledWindow ()) -getCanvas = getFromState stCanvas - -getPageSetupDialog :: State g n e -> IO (PageSetupDialog ()) -getPageSetupDialog = getFromState stPageSetupDialog - -getDisplayOptions :: State g n e -> IO DisplayOptions -getDisplayOptions = getFromState stDisplayOptions - --- Setters - -setDragging :: Maybe (Bool, DoublePoint) -> State g n e -> IO () -setDragging theDragging stateRef = - varUpdate_ stateRef (\state -> state { stDragging = theDragging }) - -setNetworkFrame :: Frame () -> State g n e -> IO () -setNetworkFrame networkFrame stateRef = - varUpdate_ stateRef (\state -> state { stNetworkFrame = networkFrame }) - -setCanvas :: ScrolledWindow () -> State g n e -> IO () -setCanvas canvas stateRef = - varUpdate_ stateRef (\state -> state { stCanvas = canvas }) - -setPageSetupDialog :: PageSetupDialog () -> State g n e -> IO () -setPageSetupDialog thePageSetupDialog stateRef = - varUpdate_ stateRef (\state -> state { stPageSetupDialog = thePageSetupDialog }) - -setDisplayOptions :: DisplayOptions -> State g n e -> IO () -setDisplayOptions dp stateRef = - varUpdate_ stateRef (\state -> state { stDisplayOptions = dp }) - -changeDisplayOptions :: (DisplayOptions->DisplayOptions) -> State g n e -> IO () -changeDisplayOptions dpf stateRef = - varUpdate_ stateRef - (\state -> state { stDisplayOptions = dpf (stDisplayOptions state) }) - --- Utility functions - -getFromState :: (StateRecord g n e -> a) -> State g n e -> IO a -getFromState selector stateRef = do - state <- varGet stateRef - return (selector state) - -varUpdate_ :: Var a -> (a -> a) -> IO () -varUpdate_ var fun = do { varUpdate var fun; return () } diff --git a/src/StateUtil.hs b/src/StateUtil.hs deleted file mode 100644 --- a/src/StateUtil.hs +++ /dev/null @@ -1,26 +0,0 @@ -module StateUtil - ( repaintAll - , getNetworkName - ) where - -import State -import Common -import qualified PersistentDocument as PD - -import Maybe -import Graphics.UI.WX - -repaintAll :: State g n e -> IO () -repaintAll state = - do{ canvas <- getCanvas state - ; Graphics.UI.WX.repaint canvas - } - -getNetworkName :: State g n e -> IO String -getNetworkName state = - do { pDoc <- getDocument state - ; mFilename <- PD.getFileName pDoc - ; case mFilename of - Just filename -> return $ removeExtension filename - Nothing -> return "Untitled" - } diff --git a/src/XTC.hs b/src/XTC.hs deleted file mode 100644 --- a/src/XTC.hs +++ /dev/null @@ -1,458 +0,0 @@ -{-# OPTIONS -fglasgow-exts #-} -{- - | Module : XTC - Maintainer : martijn@cs.uu.nl - - eXtended & Typed Controls for wxHaskell - - - TODO: - how to handle duplicates (up to presentation) in item lists - - check (!!) error that occured in Dazzle - - implement tSelecting and other events - - Check: instance selection etc. () or a - - Maybe it should be () to prevent subclassing (which may cause a problem - with the client data field - - Items w String?? - - value of selection when nothing selected? add Maybe? - - WxObject vs Object? --} - -module XTC ( Labeled( toLabel ), - , TValued( tValue ), - , TItems( tItems ), - , TSelection( tSelection ), - , TSelections( tSelections ), - , RadioView, mkRadioView, mkRadioViewEx - , ListView, mkListView, mkListViewEx - , MultiListView, mkMultiListView, mkMultiListViewEx - , ChoiceView, mkChoiceView, mkChoiceViewEx - , ComboView, mkComboView, mkComboViewEx - , ValueEntry, mkValueEntry, mkValueEntryEx - , change -- TODO wx should take care of this --- , ObservableVar, mkObservableVar -- temporarily disabled due to name clash - , xtc -- for testing, exported to avoid a warning in Dazzle - ) where - -import Graphics.UI.WX hiding (window, label) -import qualified Graphics.UI.WX -import Graphics.UI.WXCore hiding (label, Event) -import List -import Maybe - -class Labeled x where - toLabel :: x -> String - -instance Labeled String where - toLabel str = str - -class Selection w => TSelection x w | w -> x where - tSelection :: Attr w x - -class Selections w => TSelections x w | w -> x where - tSelections :: Attr w [x] - -class Items w String => TItems x w | w -> x where - tItems :: Attr w [x] - - --- RadioView - -data CRadioView x b - -type RadioView x b = RadioBox (CRadioView x b) - --- TODO: instance of tItems? -instance Labeled x => TSelection x (RadioView x ()) where - tSelection - = newAttr "tSelection" viewGetTSelection viewSetTSelection - -mkRadioView :: Labeled x => Window a -> Orientation -> [x] -> [Prop (RadioView x ())] -> IO (RadioView x ()) -mkRadioView window orientation viewItems props = - mkRadioViewEx window toLabel orientation viewItems props - -mkRadioViewEx :: Window a -> (x -> String) -> Orientation -> [x] -> [Prop (RadioView x ())] -> IO (RadioView x ()) -mkRadioViewEx window present orientation viewItems props = - do { model <- varCreate viewItems - ; radioView <- fmap objectCast $ radioBox window orientation (map present viewItems) [] - ; objectSetClientData radioView (return ()) (model, present) - ; set radioView props - ; return radioView - } -- cannot use mkViewEx because items must be set at creation (items is not writeable) - --- ListView - -data CListView a b - -type ListView a b = SingleListBox (CListView a b) - -instance TSelection x (ListView x ()) where - tSelection = newAttr "tSelection" viewGetTSelection viewSetTSelection - -instance TItems x (ListView x ()) where - tItems = newAttr "tItems" viewGetTItems viewSetTItems - -mkListView :: Labeled x => Window a -> [Prop (ListView x ())] -> IO (ListView x ()) -mkListView window props = mkListViewEx window toLabel props - -mkListViewEx :: Window a -> (x -> String) -> [Prop (ListView x ())] -> IO (ListView x ()) -mkListViewEx window present props = mkViewEx singleListBox window present props - - --- MultiListView - -data CMultiListView a b - -type MultiListView a b = MultiListBox (CMultiListView a b) - -instance Labeled x => TSelections x (MultiListView x ()) where - tSelections = newAttr "tSelections" multiListViewGetTSelections multiListViewSetTSelections - -instance Labeled x => TItems x (MultiListView x ()) where - tItems = newAttr "tItems" viewGetTItems viewSetTItems - -mkMultiListView :: Labeled x => Window a -> [Prop (MultiListView x ())] -> IO (MultiListView x ()) -mkMultiListView window props = mkMultiListViewEx window toLabel props - -mkMultiListViewEx :: Window a -> (x -> String) -> [Prop (MultiListView x ())] -> IO (MultiListView x ()) -mkMultiListViewEx window present props = mkViewEx multiListBox window present props - -multiListViewSetTSelections :: MultiListView x () -> [x] -> IO () -multiListViewSetTSelections (multiListView :: MultiListView x ()) selectionItems = - do { Just ((model, present) :: (Var [x], x -> String)) <- - unsafeObjectGetClientData multiListView - ; viewItems <- get model value - ; let labels = map present selectionItems - ; let indices = catMaybes [ findIndex (\it -> present it == label) viewItems - | label <- labels ] - ; set multiListView [ selections := indices ] - } - -multiListViewGetTSelections :: MultiListView x () -> IO [x] -multiListViewGetTSelections multiListView = - do { Just ((model, _) :: (Var [x], x -> String)) <- - unsafeObjectGetClientData multiListView - ; selectedIndices <- get multiListView selections - ; viewItems <- get model value - ; return (map (safeIndex "XTC.multiListViewGetTSelections" viewItems) - selectedIndices) - } - - --- ChoiceView - -data CChoiceView a b - -type ChoiceView a b = Choice (CChoiceView a b) - -instance Selecting (ChoiceView x ()) where - select = newEvent "select" choiceGetOnCommand choiceOnCommand --- Necessary because wxHaskell declares "instance Selecting (Choice ())" instead of --- "Selecting (Choice a)". TODO: let/make Daan fix this - -instance Selection (ChoiceView x ()) where - selection = newAttr "selection" choiceGetSelection choiceSetSelection --- Necessary because wxHaskell declares "instance Selection (Choice ())" instead of --- "Selection (Choice a)". - -instance TSelection x (ChoiceView x ()) where - tSelection = newAttr "tSelection" viewGetTSelection viewSetTSelection - -instance TItems x (ChoiceView x ()) where - tItems = newAttr "tItems" viewGetTItems viewSetTItems - -mkChoiceView :: Labeled x => Window a -> [Prop (ChoiceView x ())] -> IO (ChoiceView x ()) -mkChoiceView window (props :: [Prop (ChoiceView x ())]) = - mkViewEx choice window (toLabel :: x -> String) props - -mkChoiceViewEx :: Window a -> (x -> String) -> Style -> [Prop (ChoiceView x ())] -> IO (ChoiceView x ()) -mkChoiceViewEx window present stl props = - mkViewEx (\win -> choiceEx win stl) window present props - - --- ComboView - -data CComboView a b - -type ComboView a b = ComboBox (CComboView a b) - - -instance TSelection x (ComboView x ()) where - tSelection = newAttr "tSelection" viewGetTSelection viewSetTSelection - -instance TItems x (ComboView x ()) where - tItems = newAttr "tItems" viewGetTItems viewSetTItems - -mkComboView :: Labeled x => Window a -> [Prop (ComboView x ())] -> IO (ComboView x ()) -mkComboView window (props :: [Prop (ComboView x ())]) = - mkViewEx comboBox window (toLabel :: x -> String) props - -mkComboViewEx :: Window a -> (x -> String) -> Style -> [Prop (ComboView x ())] -> IO (ComboView x ()) -mkComboViewEx window present stl props = - mkViewEx (\win -> comboBoxEx win stl) window present props - - - --- generic mk function that puts a model and a present function in the client data -mkViewEx :: (parent -> [p] -> IO (Object a)) -> parent -> (x -> String) -> [Prop (WxObject b)] -> - IO (WxObject b) -mkViewEx mkView window present props = - do { model <- varCreate [] - ; view <- fmap objectCast $ mkView window [] - ; objectSetClientData view (return ()) (model, present) - ; set view props - ; return view - } - --- generic set/getTSelection for RadioView, ListView, and ChoiceView - -viewGetTSelection :: TSelection x (WxObject a) => WxObject a -> IO x -viewGetTSelection view = - do { Just ((model, _) :: (Var [x], x -> String)) <- - unsafeObjectGetClientData view - ; selectedIndex <- get view selection - ; viewItems <- get model value - ; return (safeIndex "XTC.viewGetTSelection" viewItems selectedIndex) - } - --- if non unique, set to first viewItem with same label --- selection is set to 0 if object is not found, maybe -1 is better? -viewSetTSelection :: TSelection x (WxObject a) => WxObject a -> x -> IO () -viewSetTSelection view selectionItem = - do { Just ((model, present) :: (Var [x], x -> String)) <- - unsafeObjectGetClientData view - ; viewItems <- get model value - ; let label = present selectionItem - ; let index = findLabelIndex present label viewItems - ; set view [ selection := index ] - } - where findLabelIndex :: (x -> String) -> String -> [x] -> Int - findLabelIndex present label theItems = - case findIndex (\it -> present it == label) theItems of - Just ix -> ix - Nothing -> 0 - -viewGetTItems :: TItems x (WxObject a) => WxObject a -> IO [x] -viewGetTItems view = - do { Just ((model, _) :: (Var [x], x -> String)) <- - unsafeObjectGetClientData view - ; viewItems <- get model value - ; return viewItems - } - -viewSetTItems :: TItems x (WxObject a) => WxObject a -> [x] -> IO () -viewSetTItems view viewItems = - do { Just ((model, present) :: (Var [x], x -> String)) <- - unsafeObjectGetClientData view - ; set model [ value := viewItems ] - ; set view [ items := map present viewItems ] - } - - - - - - --- ValueEntry - -class Parseable x where - parse :: String -> Maybe x - -instance Parseable String where - parse = Just - -{- When a type is instance of Read, a simple Parseable instance can be declared with readParse - e.g. for Int: instance Parseable Int where parse = readParse - -TODO: can we make this some kind of default? --} -readParse :: Read x => String -> Maybe x -readParse str = case reads str of - [(x, "")] -> Just x - _ -> Nothing - -class TValued x w | w -> x where - tValue :: Attr w (Maybe x) - -data CValueEntry x b - -type ValueEntry x b = TextCtrl (CValueEntry x b) - -instance TValued x (ValueEntry x ()) where - tValue - = newAttr "tValue" valueEntryGetTValue valueEntrySetTValue - -mkValueEntry :: (Show x, Read x) => Window b -> [ Prop (ValueEntry x ()) ] -> IO (ValueEntry x ()) -mkValueEntry window props = mkValueEntryEx window show readParse props - -mkValueEntryEx :: Window b -> (x -> String) -> (String -> Maybe x) -> [ Prop (ValueEntry x ()) ] -> IO (ValueEntry x ()) -mkValueEntryEx window present parse props = - do { valueEntry <- fmap objectCast $ textEntry window [] - ; objectSetClientData valueEntry (return ()) (present, parse) - ; set valueEntry $ props ++ [ on change := validate valueEntry ] - - ; return valueEntry - } - where validate :: ValueEntry x () -> IO () - validate valueEntry = - do { mVal <- get valueEntry tValue - ; set valueEntry [ bgcolor := case mVal of -- TODO: add property for error color? - Nothing -> lightgrey - _ -> white - ] - ; repaint valueEntry - } -- drawing a squiggly doesn't work because font metrics are not available - -valueEntryGetTValue :: ValueEntry x () -> IO (Maybe x) -valueEntryGetTValue valueEntry = - do { Just ((_, parse) :: (x -> String, String -> Maybe x)) <- unsafeObjectGetClientData valueEntry - ; valueStr <- get valueEntry text - ; return $ parse valueStr - } - -valueEntrySetTValue :: ValueEntry x () -> Maybe x -> IO () -valueEntrySetTValue valueEntry mValue = - do { Just ((present, _) :: (x -> String, String -> Maybe x)) <- unsafeObjectGetClientData valueEntry - ; case mValue of - Nothing -> return () - Just theValue -> set valueEntry [ text := present theValue ] - } - - -class Observable w where - change :: Event w (IO ()) - -instance Observable (TextCtrl a) where - change = newEvent "change" (controlGetOnText) (controlOnText) - - - --- ObservableVar - --- add variable as WxObject -{- -type Observer x = (WxObject (), x -> IO ()) - -data ObservableVar x = ObservableVar (Var [Observer x]) (Var x) - -instance Valued ObservableVar where - value - = newAttr "value" observableVarGetValue observableVarSetValue - -mkObservableVar :: x -> IO (ObservableVar x) -mkObservableVar x = - do { observersV <- variable [ value := [] ] - ; var <- variable [ value := x ] - ; return $ ObservableVar observersV var - } - -observableVarGetValue :: ObservableVar x -> IO x -observableVarGetValue (ObservableVar _ var) = get var value - -observableVarSetValue :: ObservableVar x -> x -> IO () -observableVarSetValue (ObservableVar observersV var) x = - do { myObservers <- get observersV value - ; set var [ value := x ] - ; sequence_ [ obs x | (_, obs) <- myObservers ] - } - -class Observable x w | w -> x where - observers :: Attr w [Observer x] - -instance Observable x (ObservableVar x) where - observers - = newAttr "observers" observableVarGetObservers observableVarSetObservers - -observableVarGetObservers :: ObservableVar x -> IO [Observer x] -observableVarGetObservers (ObservableVar observersV _) = get observersV value - -observableVarSetObservers :: ObservableVar x -> [Observer x] -> IO () -observableVarSetObservers (ObservableVar observersV var) myObservers = -- return () - do { set observersV [ value := myObservers ] - ; x <- get var value - ; sequence_ [ obs x | (_, obs) <- myObservers ] - } - - --- all WxObjects get the event 'change' - -class Observing w where - change :: ObservableVar x -> Event w (x -> IO ()) - -instance Observing (WxObject a) where - change observableVar - = newEvent "change" (getOnObserve observableVar) (setOnObserve observableVar) - -setOnObserve :: ObservableVar x -> Object a -> (x -> IO ()) -> IO () -setOnObserve (ObservableVar observersV var) obj observer = - do { oldObservers <- get observersV value - ; let otherObservers = filter ((/= objectCast obj) . fst) oldObservers - ; set observersV [ value := (objectCast obj, observer) : otherObservers ] - ; x <- get var value - ; observer x - } - -getOnObserve :: ObservableVar x -> Object a -> IO (x -> IO ()) -getOnObserve (ObservableVar observersV _) obj = - do { myObservers <- get observersV value - ; case lookup (objectCast obj) myObservers of - Just obs -> return obs - Nothing -> do { internalError "XTC" "getOnObserve" "object is not an observer" - ; return $ \_ -> return () - } - } --} - - --- Utility functions - -safeIndex :: String -> [a] -> Int -> a -safeIndex msg xs i - | i >= 0 && i < length xs = xs !! i - | otherwise = internalError "XTC" "safeIndex" msg - -internalError :: String -> String -> String -> a -internalError moduleName functionName errorString = - error (moduleName ++ "." ++ functionName ++ ": " ++ errorString) - - --- Test function - -xtc :: IO () -xtc = start $ - do { -- counterV <- mkObservableVar 1 - ; f <- frame [] - - - ; listV <- mkListView f [ tItems := ["sdfsdf", "fdssd"] - , enabled := True - ] - - ; choiceV <- mkChoiceView f [ tItems := ["sdfsdf", "fdssd"] - , enabled := True - ] - ; comboV <- mkComboView f [ tItems := ["sdfsdf", "fdssd"] - , enabled := True - ] - ; t <- textEntry f [] - ; ve <- mkValueEntry f [ tValue := Just True ] - -- ; set t [ on (change counterV) := \i -> set t [ text := show i ] ] - - ; bUp <- button f [ text := "increase", on command := do { s1 <- get comboV tSelection - ; s2 <- get listV text - ; print (s1,s2) - } ] -- set counterV [ value :~ (+1) ] ] - -- ; bDown <- button f [ text := "decrease", on command := set counterV [ value :~ (+ (-1::Int)) ] ] - - -- ; bChangeHandler <- button f [ text := "change handler" - -- , on command := set t [ on (change counterV) := \i -> set t [text := "<<"++show i++">>"] ]] - ; set f [ layout := column 5 [ row 5 [ Graphics.UI.WX.label "Counter value:", widget t ] - -- , hfloatCenter $ row 5 [ widget bUp, widget bDown ] - -- , hfloatCenter $ widget bChangeHandler - , widget listV - , widget choiceV - , widget comboV - , widget ve - ] - ] - - }