module GraphEdit where


-- GraphEdit by Chris Dornan
-- Developed from TkGofer variant by T. Schwinn
-- Itself based on TK-TCL 'graph' from J. K. Ousterhout


-- left mouse button  : create node
-- right mouse button : move node
-- `1`                : select first node for connection
-- `2`                : select second node for connection


import Tcl


type Pos    = (Int,Int)                      

type Status = GUIRef State

data State  = St [Edge] (Maybe Node) (Maybe Node) (Maybe Node)
--               edges    1st node     hi' node   moving node

type Edge   = (CLine,Pos,Pos)

data Node   = Nd COval Pos



graphEdit :: GUI ()
graphEdit =
     do	top <- window []
	title top "Graph Editor"
	st <- newState (St [] Nothing Nothing Nothing)
	c  <- canvas top []
	bindxy c "<1>"               (node c st)
	bind   c "<Key-1>"           (startEdge st)
	bind   c "<Key-2>"           (endEdge c st)
	bind   c "<3>"               (startMove st)
	bindxy c "<B3-Motion>"       (moveIt    st)
	bind   c "<ButtonRelease-3>" (finMove   st)
	focus c
        packAdd c []


-- put nodes & edges -----------------------------------------------------

node :: Canvas -> Status -> (Int,Int) -> GUI ()
node can st (x,y) = 
     do	o <- coval can (x-10 , y-10) (x+10 , y+10) [ outline "black" 
                                               , fill "white"
                                               ]
	bind o "<Enter>" (enterNode st o)
	bind o "<Leave>" (leaveNode st)
	return ()

startEdge :: Status -> GUI ()
startEdge st = 
     do	St es mbf mbh mbm <- readState st
	case mbf of
	  Just(Nd ov _) -> cset ov [fill "white"]
	  _             -> return ()
	case mbh of
	  Just(Nd ov _) -> cset ov [fill "red"]
	  _             -> return ()
	writeState st (St es mbh mbh mbm)

endEdge :: Canvas -> Status -> GUI ()
endEdge c st = 
     do	St es mbf mbh mbm <- readState st
	case (mbf,mbh) of
	  (Just(Nd f_ov _),Just(Nd h_ov h_p)) ->
	     do ~((f_x,f_y):_) <- getCoords f_ov
		let f_p = (f_x+10,f_y+10)
		l <- cline c [ f_p, h_p] []
		lowerObject l Nothing
                writeState st (St ((l,f_p,h_p):es) mbf mbh mbm)
	  _ -> return ()


-- highlight node --------------------------------------------------------

enterNode :: Status -> COval -> GUI ()
enterNode st g =  
     do	St es mbf mbh mbm <- readState st
	~((x,y):_) <- getCoords g
	let p = (x+10,y+10)
	case mbh of
	  Just(Nd ov _) -> setcol ov "white"
	  Nothing       -> return ()
	writeState st (St es mbf (Just(Nd g p)) mbm)
	setcol g "black"
     where
	setcol ov col =
	     do c <- cget ov fill
		if c=="red" then return () else cset ov [fill col]

leaveNode :: Status -> GUI ()
leaveNode st = 
     do St es mbf mbh mbm <- readState st
	case mbh of
	  Nothing -> return ()
	  Just(Nd ov _) ->
	     do	c <- cget ov fill
		if c == "black" then cset ov [fill "white"] else return ()
		writeState st (St es mbf Nothing mbm)
               

-- move node and adjacent edges ------------------------------------------

startMove :: Status -> GUI ()
startMove st =
     do St es mbf mbh _ <- readState st
	writeState st (St es mbf mbh mbh)

moveIt :: Status -> (Int,Int) -> GUI ()
moveIt rf (x',y') = 
     do St es mbf mbh mbm <- readState rf
	case mbm of
	  Nothing -> return ()
	  Just (Nd ov (x,y)) ->
	     do moveObject ov (x'-x , y'-y)
		let es'  = map (cvt (x,y)) es
		    mbf' = chg ov mbf
		    mbh' = chg ov mbh
		    st'  = St (map snd es') mbf' mbh' (Just(Nd ov p'))
		mapM_ scoord es'
		writeState rf st'
     where
	chg ov Nothing = Nothing
	chg ov (Just(Nd ov0 p0)) =
		case ov== ov0 of
		  True  -> Just(Nd ov0 p')
		  False -> Just(Nd ov0 p0)

	cvt p (e,q,r) = (q==p||r==p,(e,f q,f r))
	     where
		f s = if s==p then p' else s

	scoord (True,(e,q,r)) = setCoords e [q,r]
	scoord _ = return ()

	p' = (x',y')

finMove :: Status -> GUI ()
finMove st =
     do St es mbf mbh _ <- readState st
	writeState st (St es mbf mbh Nothing)

