INblobs-0.1.1: src/Document.hs

{-| 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
    , RuleName
    , ActiveCanvas(..) 
    , Selection(..)
    , empty
    , getNetwork,       setNetwork, unsafeSetNetwork
    , getPalette,       setPalette
    , getSelection,     setSelection
    , getRules,         setRules

    , updateNetwork, updateNetworkEx
    , joinPalette
    , updateRules
    , selectNetwork
    , updateSelNetwork, updateSelNetworkEx
    , removeMappingElemWithNode
    , show'
    ) where

import Network hiding (empty)
import INRule
import INRules hiding (empty) 
import InfoKind
import Math
import Ports
import Palette hiding (delete, empty)
import qualified Network (empty)
import qualified INRules (empty) 
import qualified Palette (empty)

import Data.Maybe

{--------------------------------------------------
 -- TYPES
 --------------------------------------------------}

data Document g n e = Document
    { docNetwork        :: Network g n e
    , docPalette        :: Palette n          -- ^ the current 'Palette'
    , docSelection      :: Selection
    , docRules          :: INRules g n e
    } deriving Show

type RuleName = String
data ActiveCanvas = Net | LHS RuleName | RHS RuleName deriving (Show, Eq, Read)

data Selection
    = NoSelection
    | NodeSelection ActiveCanvas Int (Maybe PortName)
    | EdgeSelection ActiveCanvas Int
    | ViaSelection  ActiveCanvas Int Int
    | MultipleSelection ActiveCanvas 
                        (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
    , docPalette    = Palette.empty
    , docSelection  = NoSelection
    , docRules      = INRules.empty g n e
    }

{--------------------------------------------------
 -- GETTERS
 --------------------------------------------------}

getNetwork              :: Document g n e -> Network g n e
getPalette              :: Document g n e -> Palette n
getSelection            :: Document g n e -> Selection
getRules                :: Document g n e -> INRules g n e

getNetwork              doc = docNetwork   doc
getPalette              doc = docPalette   doc
getSelection            doc = docSelection doc
getRules                doc = docRules     doc

{--------------------------------------------------
 -- SETTERS
 --------------------------------------------------}

-- | setNetwork clears the selection because the node may not exist
--   in the new network
setNetwork :: Network g n e -> Document g n e -> Document g n e
setNetwork theNetwork doc =
    doc { docNetwork = theNetwork
        , docSelection = NoSelection
        }

setPalette :: Palette n -> Document g n e -> Document g n e
setPalette thePalette doc = doc { docPalette = thePalette }

setSelection :: Selection -> Document g n e -> Document g n e
setSelection theSelection doc = doc { docSelection = theSelection }

setRules :: INRules g n e -> Document g n e -> Document g n e
setRules theRules doc = doc {docRules = theRules}

updateNetwork :: (Network g n e -> Network g n e)
                 -> Document g n e -> Document g n e
updateNetwork networkFun doc
    = unsafeSetNetwork (networkFun (getNetwork doc))
    $ doc

updateNetworkEx :: (Network g n e -> (b, 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
       )

joinPalette :: (Eq n) => Palette n -> Document g n e -> Document g n e
joinPalette palette doc = doc { docPalette = join (getPalette doc) palette }

updateRules :: (INRules g n e -> INRules g n e) 
               -> Document g n e -> Document g n e
updateRules rulesFun doc = doc { docRules = rulesFun $ docRules doc }

-- | Doesn't clear the selection
unsafeSetNetwork :: Network g n e -> Document g n e -> Document g n e
unsafeSetNetwork theNetwork doc = doc { docNetwork = theNetwork }

-- | Given a document and the active canvas this function selects 
-- the corresponding network.
selectNetwork :: Document g n e -> ActiveCanvas -> Network g n e
selectNetwork doc canvas =
   case canvas of
      Net          -> getNetwork doc
      LHS ruleName -> fromMaybe (erro ruleName)
                       $ getLHS `fromRule` ruleName $ getRules doc
      RHS ruleName -> fromMaybe (erro ruleName) 
                       $ getRHS `fromRule` ruleName $ getRules doc
   where erro ruleName = error $ "This shouldn't happen because << "
                               ++ ruleName ++ " >> must be a rule."

-- | Given a document and the active canvas this function updates 
-- the corresponding network accordingly the the updater network 
-- function given as an argument.
updateSelNetwork :: (Network g n e -> Network g n e)
                    -> ActiveCanvas -> Document g n e -> Document g n e
updateSelNetwork netFunc canvas doc =
   case canvas of 
      Net          -> updateNetwork netFunc doc
      LHS ruleName -> updateRules (updateRule ruleName $ updateLHS netFunc) doc
      RHS ruleName -> updateRules (updateRule ruleName $ updateRHS netFunc) doc

updateSelNetworkEx :: (Network g n e -> (b, Network g n e))
                      -> ActiveCanvas -> Document g n e -> (b, Document g n e)
updateSelNetworkEx networkFun canvas doc =
    let (result, newNetwork) = networkFun (selectNetwork doc canvas)
    in ( result
       , case canvas of
            Net          -> unsafeSetNetwork newNetwork doc
            LHS ruleName -> updateRules (updateRule ruleName 
                                           $ setLHS newNetwork) doc
            RHS ruleName -> updateRules (updateRule ruleName 
                                           $ setRHS newNetwork) doc
       )

removeMappingElemWithNode :: ActiveCanvas -> NodeNr -> Document g n e -> Document g n e
removeMappingElemWithNode canv nodeNr = 
     case canv of
        Net -> id
        LHS rule -> updateRules $ updateRule rule $ updateMapping $ filter $ (/= nodeNr) . fst
        RHS rule -> updateRules $ updateRule rule $ updateMapping $ filter $ (/= nodeNr) . snd

show' :: ActiveCanvas -> String
show' Net        = "net"
show' (LHS rule) = "rule " ++ rule ++ "'s LHS"
show' (RHS rule) = "rule " ++ rule ++ "'s RHS"