Blobs 0.1 → 0.2
raw patch · 50 files changed
+4451/−4861 lines, 50 files
Files
- Blobs.cabal +33/−1
- README.md +6/−0
- src/Colors.hs +0/−86
- src/Common.hs +0/−159
- src/CommonIO.hs +0/−339
- src/Constants.hs +0/−26
- src/ContextMenu.hs +0/−186
- src/DisplayOptions.hs +0/−16
- src/Document.hs +0/−94
- src/GUIEvents.hs +0/−192
- src/Graphics/Blobs/Colors.hs +86/−0
- src/Graphics/Blobs/Common.hs +159/−0
- src/Graphics/Blobs/CommonIO.hs +339/−0
- src/Graphics/Blobs/Constants.hs +26/−0
- src/Graphics/Blobs/ContextMenu.hs +186/−0
- src/Graphics/Blobs/DisplayOptions.hs +16/−0
- src/Graphics/Blobs/Document.hs +94/−0
- src/Graphics/Blobs/GUIEvents.hs +192/−0
- src/Graphics/Blobs/InfoKind.hs +45/−0
- src/Graphics/Blobs/Math.hs +110/−0
- src/Graphics/Blobs/Network.hs +579/−0
- src/Graphics/Blobs/NetworkControl.hs +513/−0
- src/Graphics/Blobs/NetworkFile.hs +438/−0
- src/Graphics/Blobs/NetworkUI.hs +435/−0
- src/Graphics/Blobs/NetworkView.hs +342/−0
- src/Graphics/Blobs/Operations.hs +50/−0
- src/Graphics/Blobs/PDDefaults.hs +92/−0
- src/Graphics/Blobs/Palette.hs +30/−0
- src/Graphics/Blobs/PersistentDocument.hs +340/−0
- src/Graphics/Blobs/SafetyNet.hs +24/−0
- src/Graphics/Blobs/Shape.hs +177/−0
- src/Graphics/Blobs/State.hs +108/−0
- src/Graphics/Blobs/StateUtil.hs +26/−0
- src/InfoKind.hs +0/−45
- src/Main.hs +5/−5
- src/Math.hs +0/−110
- src/Network.hs +0/−578
- src/NetworkControl.hs +0/−513
- src/NetworkFile.hs +0/−438
- src/NetworkUI.hs +0/−435
- src/NetworkView.hs +0/−342
- src/Operations.hs +0/−50
- src/PDDefaults.hs +0/−92
- src/Palette.hs +0/−29
- src/PersistentDocument.hs +0/−339
- src/SafetyNet.hs +0/−24
- src/Shape.hs +0/−170
- src/State.hs +0/−108
- src/StateUtil.hs +0/−26
- src/XTC.hs +0/−458
Blobs.cabal view
@@ -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
README.md view
@@ -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
− src/Colors.hs
@@ -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
− src/Common.hs
@@ -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 ]
− src/CommonIO.hs
@@ -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 ()- }
− src/Constants.hs
@@ -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--
− src/ContextMenu.hs
@@ -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 ()- }
− src/DisplayOptions.hs
@@ -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)
− src/Document.hs
@@ -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 }
− src/GUIEvents.hs
@@ -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
+ src/Graphics/Blobs/Colors.hs view
@@ -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
+ src/Graphics/Blobs/Common.hs view
@@ -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 ]
+ src/Graphics/Blobs/CommonIO.hs view
@@ -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 ()+ }
+ src/Graphics/Blobs/Constants.hs view
@@ -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++
+ src/Graphics/Blobs/ContextMenu.hs view
@@ -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 ()+ }
+ src/Graphics/Blobs/DisplayOptions.hs view
@@ -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)
+ src/Graphics/Blobs/Document.hs view
@@ -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 }
+ src/Graphics/Blobs/GUIEvents.hs view
@@ -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
+ src/Graphics/Blobs/InfoKind.hs view
@@ -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+-}
+ src/Graphics/Blobs/Math.hs view
@@ -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+-- <http://geometryalgorithms.com/Archive/algorithm_0102/algorithm_0102.htm>+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
+ src/Graphics/Blobs/Network.hs view
@@ -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) }
+ src/Graphics/Blobs/NetworkControl.hs view
@@ -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)+ }+
+ src/Graphics/Blobs/NetworkFile.hs view
@@ -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+
+ src/Graphics/Blobs/NetworkUI.hs view
@@ -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
+ src/Graphics/Blobs/NetworkView.hs view
@@ -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))+ )+ }
+ src/Graphics/Blobs/Operations.hs view
@@ -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+ }+ )+
+ src/Graphics/Blobs/PDDefaults.hs view
@@ -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+
+ src/Graphics/Blobs/Palette.hs view
@@ -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 }+
+ src/Graphics/Blobs/PersistentDocument.hs view
@@ -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)+ }
+ src/Graphics/Blobs/SafetyNet.hs view
@@ -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"+ )+ }
+ src/Graphics/Blobs/Shape.hs view
@@ -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 }
+ src/Graphics/Blobs/State.hs view
@@ -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 () }
+ src/Graphics/Blobs/StateUtil.hs view
@@ -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"+ }
− src/InfoKind.hs
@@ -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--}
src/Main.hs view
@@ -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)
− src/Math.hs
@@ -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--- <http://geometryalgorithms.com/Archive/algorithm_0102/algorithm_0102.htm>-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
− src/Network.hs
@@ -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) }
− src/NetworkControl.hs
@@ -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)- }-
− src/NetworkFile.hs
@@ -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-
− src/NetworkUI.hs
@@ -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
− src/NetworkView.hs
@@ -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))- )- }
− src/Operations.hs
@@ -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- }- )-
− src/PDDefaults.hs
@@ -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-
− src/Palette.hs
@@ -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 }-
− src/PersistentDocument.hs
@@ -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)- }
− src/SafetyNet.hs
@@ -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"- )- }
− src/Shape.hs
@@ -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 }
− src/State.hs
@@ -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 () }
− src/StateUtil.hs
@@ -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"- }
− src/XTC.hs
@@ -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. <Control> () or <Control> 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- ]- ]- - }