-- | A simple drag and drop field.
module HTk.Toolkit.Notepad (

  Notepad,
  NotepadItem,

  newNotepad,
  createNotepadItem,
  getFreeItemPosition,
  getItemValue,

  ScrollType(..),

  module HTk.Toolkit.Name,
  setName,

  updNotepadScrollRegion,
  selectAll,
  deselectAll,
  selectItem,
  selectAnotherItem,
  selectItemsWithin,
  deselectItem,
  getItems,
  getSelectedItems,
  isNotepadItemSelected,
  deleteItem,
  clearNotepad,
  undoLastMotion,

  bindNotepadEv, {- :: Notepad a -> IO (Event (NotepadEvent a), IO ())  -}
  NotepadEvent(..),

  NotepadExportItem(..),
  NotepadState,
  exportNotepadState,
  importNotepadState,

  module HTk.Toolkit.CItem

) where

import Data.Maybe
import qualified Data.Map as Map

import Util.Computation

import Events.Events
import Events.Channels
import Events.Synchronized

import Reactor.ReferenceVariables

import HTk.Toplevel.HTk
import HTk.Canvasitems.CanvasItemAux
import HTk.Toolkit.ScrollBox
import HTk.Toolkit.Name
import qualified Events.Examples as Examples (watch)
import HTk.Kernel.Core
import HTk.Toolkit.CItem

getCoords :: EventInfo -> IO (Distance, Distance)
getCoords eventInfo = return (x eventInfo, y eventInfo)

char_px = 8


-------------------
-- Notepad items --
-------------------

-- type

-- | The @NotepadItem@ datatype.
data NotepadItem a =
  NotepadItem { it_img :: ImageItem,                              -- image
                it_img_size :: Size,                      -- size of image
                it_txt :: TextItem,                      -- displayed name
                it_val :: Ref a,                                  -- value
                it_long_name_bg :: Ref (Maybe Rectangle), -- long names bg
                it_bg :: Ref (Maybe (Rectangle, Rectangle)) }
                                                         -- bg if selected

-- handler for enter events
enteredItem :: CItem c => Notepad c -> NotepadItem c -> IO ()
enteredItem notepad item =
  synchronize item
    (do
       v <- getRef (it_val item)
       nm <- getName v
       let fullnm = full nm
       it_txt item # text fullnm
       mlast_bg <- getRef (it_long_name_bg item)
       case mlast_bg of
         Nothing -> do
                      Just (x1, y1, x2, y2) <-
                        bbox (canvas notepad) (it_txt item)
                      (_, (sizex, _)) <- getScrollRegion (canvas notepad)
                      let dx = if x1 < 0 then -x1 + 6
                               else if x2 > sizex then (sizex - x2)
                                       else 0
                      moveItem (it_txt item) dx 0
                      b <- isNotepadItemSelected notepad item
                      rect <- createRectangle (canvas notepad)
                                (coord [(x1 - 5 + dx, y1 - 1),
                                        (x2 + 5 + dx, y2 + 1)] :
                                 (if b then [filling "blue",
                                             outline "blue"]
                                  else [filling "white",
                                        outline "black"]))
                      putItemOnTop rect
                      putItemOnTop (it_txt item)
                      setRef (it_long_name_bg item) (Just rect)
         _ -> done
       done)

text_gap :: Int
text_gap = 11

-- handler for leave events
leftItem :: CItem c => Notepad c -> NotepadItem c -> IO ()
leftItem notepad item =
  synchronize item
    (do
       (x, y) <- getPosition item
       let (Distance iwidth, Distance iheight) = img_size notepad
       it_txt item # position (x, y + Distance (div iheight 2 + text_gap))
       let (Distance dx, _) = img_size notepad
           len = div (dx + 80) char_px
       v <- getRef (it_val item)
       nm <- getName v
       let shortnm = short nm len
       it_txt item # text shortnm
       mlast_bg <- getRef (it_long_name_bg item)
       case mlast_bg of
         Just last_bg -> destroy last_bg >>
                         setRef (it_long_name_bg item) Nothing
         _ -> done
       done)


-- constructor

-- | Creates a new notepad item and returns a handler.
createNotepadItem :: CItem c => c
   -- ^ the notepad item\'s value.
   -> Notepad c
   -- ^ the concerned notepad.
   -> Bool
   -- ^ @True@ if the notepad\'s
   -- scrollregion should be updated.
   ->
   [Config (NotepadItem c)]
   -- ^ the list of configuration options for this notepad
   -- item.
   ->
   IO (NotepadItem c)
   -- ^ A notepad item.
createNotepadItem val notepad updscrollregion cnf =
  do
    pho <- getIcon val
    img <- createImageItem (canvas notepad) [coord [(-200, -200)],
                                             photo pho]
    let (Distance dx, _) = img_size notepad
        len = div (dx + 80) char_px
    nm <- getName val
    txt <- createTextItem (canvas notepad) [coord [(-200, -200)],
                                            font (Helvetica, 10 :: Int),
                                            text (short nm len)]
    itemval <- newRef val
    itemsel <- newRef Nothing
    lnbg <- newRef Nothing
    let item = NotepadItem { it_img = img,
                             it_img_size = (img_size notepad),
                             it_txt = txt,
                             it_val = itemval,
                             it_long_name_bg = lnbg,
                             it_bg = itemsel }
    foldl (>>=) (return item) cnf


    (entered, _) <- bindSimple item Enter
    (left, _) <- bindSimple item Leave
    _ <- spawnEvent (forever ((entered >>>
                            (do st <- getIntState notepad
                                (if st /= Mov then
                                   do
                                      last <- getRef (entered_item notepad)
                                      if not (isJust last)
                                        then do setRef (entered_item notepad)
                                                       (Just item)
                                                enteredItem notepad item
                                        else if fromJust last /= item
                                               then do leftItem notepad
                                                                (fromJust last)
                                                       setRef
                                                         (entered_item notepad)
                                                         (Just item)
                                                       enteredItem notepad item
                                               else done
                                 else done)) ) +>
                         (left >>>
                            (do st <- getIntState notepad
                                (if st /= Mov then
                                   do
                                      last <- getRef (entered_item notepad)
                                      setRef (entered_item notepad) Nothing
                                      if isJust last
                                        then leftItem notepad (fromJust last)
                                        else done
                                 else done)))))

    addItemToState notepad item
    if updscrollregion then updNotepadScrollRegion notepad else done
    return item

-- | Returns a free item position on the notepad.
getFreeItemPosition :: CItem c => Notepad c
   -- ^ the concerned notepad.
   -> IO Position
   -- ^ the free position on the notepad.
getFreeItemPosition notepad =
   let num_cols = 4
       (Distance iwidth, Distance iheight) = img_size notepad
       dy_n = Distance (div iheight 2)
       dy_s = Distance (div iheight 2 + 18)
       dx = Distance (max (div iwidth 2) 40)

       overlaps (x, y) (item : items) =
         do
           (ix, iy) <- getPosition item
           (if (( (x - dx   >= ix - dx   && x - dx   <= ix + dx)   ||
                  (x + dx   >  ix - dx   && x + dx   <  ix + dx)     ) &&
                ( (y - dy_n >= iy - dy_n && y - dy_n <= iy + dy_s) ||
                  (y + dy_s >  iy - dy_n && y + dy_s <  iy + dy_s)   )) then
              return True
            else overlaps (x, y) items)
       overlaps _ _ = return False
   in do
        items <- getRef (items notepad)
        let getPos pos@(x, y) =
              do
                b <- overlaps pos items
                (if b then
                   getPos (if x + 2 * dx + 10 > 10 + dx + (num_cols * 2 * dx)
                             then (10 + dx, y + dy_s + dy_n + 10)
                             else (x + 2 * dx + 10, y))
                 else return pos)
        getPos (10 + dx, 10 + dy_n)

-- | Gets the value from a notepad item.
getItemValue :: NotepadItem a -> IO a
getItemValue item = getRef (it_val item)


-- instances --

-- | Internal.
instance Eq (NotepadItem a) where
  item1 == item2 = it_img item1 == it_img item2

-- | Internal.
instance GUIObject (NotepadItem a) where
  toGUIObject item = toGUIObject (it_img item)
  cname _ = "NotepadItem"

-- | You can synchronize on a notepad item.
instance Synchronized (NotepadItem a) where
  -- Synchronizes on a notepad item.
  synchronize item = synchronize (toGUIObject (it_img item))

-- | A notepad item has a position on the associated notepad.
instance HasPosition (NotepadItem a) where
  -- Sets the notepad item\'s position.
  position p@(x, y) item =
    itemPositionD2 p (it_img item) >>
    let (Distance iwidth, Distance iheight) = it_img_size item
    in itemPositionD2 (x, y + Distance (div iheight 2 + text_gap))
                      (it_txt item) >>
       return item
  -- Gets the notepad item\'s position.
  getPosition item = getItemPositionD2 (it_img item)

-- | A notepad item can be destroyed.
instance Destroyable (NotepadItem a) where
  -- Destroys a notepad item.
  destroy item =
    do
      destroy (it_img item)
      destroy (it_txt item)
      mrects <- getRef (it_bg item)
      case mrects of
        Just (rect1, rect2) -> destroy rect1 >> destroy rect2
        _ -> done

-- | (Re-)sets the name of a notepad item.
setName :: CItem c => NotepadItem c -> Name -> IO ()
setName item nm =
  do
    let (Distance dx, _) = it_img_size item
        len = div (dx + 80) char_px
    it_txt item # text (short nm len)
    done


--------------------------------------------------------------------------
-- notepad events
--------------------------------------------------------------------------

-- | Binds a listener for notepad events to the notepad and returns
-- a corresponding event and an unbind action.
bindNotepadEv :: Notepad a
   -- ^ the concerned notepad.
   -> IO (Event (NotepadEvent a), IO ())
   -- ^ A pair of (event, unbind action).
bindNotepadEv np =
  do
    ch <- newChannel
    setRef (event_queue np) (Just ch)
    return (receive ch, setRef (event_queue np) Nothing)

-- | The @NotepadEvent@ datatype.
data NotepadEvent a =
    Dropped (NotepadItem a, [NotepadItem a])     -- ^ Drop event.
  | Selected (NotepadItem a)                     -- ^ Selection event.
  | Deselected (NotepadItem a)                   -- ^ Deselection event.
  | Doubleclick (NotepadItem a)                  -- ^ Doubleclick event.
  | Rightclick [NotepadItem a]                   -- ^ Rightclick event.
  | ReleaseSelection                             -- ^ Buttonrelease after a selection.
  | ReleaseMovement EventInfo                    -- ^ Buttonrelease after a movement.

sendEv :: Notepad a -> NotepadEvent a -> IO ()
sendEv np ev =
  do
    mch <- getRef (event_queue np)
    case mch of
      Just ch -> syncNoWait (send ch ev)
      _ -> done


--------------------------------------------------------------------------
-- Notepad type
--------------------------------------------------------------------------

-- | The @Notepad@ datatype.
data Notepad a =
  Notepad { -- main canvas widget
            canvas :: Canvas,

            -- scrollbox if scrolled
            scrollbox :: Maybe (ScrollBox Canvas),

            -- size of item images
            img_size :: Size,

            -- contained items
            items :: Ref ([NotepadItem a]),

            -- selected items
            selected_items :: Ref ([NotepadItem a]),

            -- entered item (mouse over item)
            entered_item :: Ref (Maybe (NotepadItem a)),

            -- undo last motion action (needed for drag and drop with
            --                          other widgets)
            undo_last_motion :: Ref UndoMotion,

            -- entered item when other items dragged /
            -- rectangles (highlight)
            drop_item :: (Ref (Maybe (NotepadItem a, Rectangle,
                                      Rectangle))),

            -- event queue
            event_queue :: Ref (Maybe (Channel (NotepadEvent a))),

            -- clean up when destroyed
            clean_up :: [IO ()],

            -- notepad state
            npstate :: Ref IntState }

data IntState = Norm | Mov deriving Eq

setIntState :: Notepad a -> IntState -> IO ()
setIntState np st = setRef (npstate np) st

getIntState :: Notepad a -> IO IntState
getIntState np = getRef (npstate np)

-- | The @ScrollType@ datatype.
data ScrollType = Scrolled | NotScrolled deriving Eq

data UndoMotion = ToPerform (IO ()) | Performed


-- state --

addItemToState :: Notepad a -> NotepadItem a -> IO ()
addItemToState notepad item =
  do
    notepaditems <- getRef (items notepad)
    setRef (items notepad) (item : notepaditems)

highlight :: Canvas -> NotepadItem a -> IO ()
highlight cnv item =
  do
    let (Distance iwidth, Distance iheight) = it_img_size item
    it_txt item # filling "white"
    s <- getRef (it_bg item)
    case s of
      Nothing -> do
                   (x, y) <- getPosition item
                   rect1 <- createRectangle cnv
                              [filling "blue", outline "blue"]
                   putItemAtBottom rect1
                   rect1 # coord [(x - Distance (div iwidth 2 + 1),
                                   y - Distance (div iheight 2 + 1)),
                                  (x + Distance (div iwidth 2),
                                   y + Distance (div iheight 2))]
                   rect2 <- createRectangle cnv
                              [filling "blue", outline "blue"]
                   putItemAtBottom rect2
                   rect2 #
                     coord [(x - Distance
                                   (max (div iwidth 2 + 40) 40),
                                    y + Distance (div iheight 2 + 4)),
                                   (x + Distance
                                          (max (div iwidth 2 + 40) 40),
                                    y + Distance
                                          (div iheight 2 + 18))]
                   setRef (it_bg item) (Just (rect1, rect2))
      Just _  -> done

deHighlight :: NotepadItem a -> IO ()
deHighlight item =
  do
    it_txt item # filling "black"
    s <- getRef (it_bg item)
    case s of
      Just (rect1, rect2) ->
        destroy rect1 >> destroy rect2 >> setRef (it_bg item) Nothing
      _ -> done

-- | Selects a specific notepad item.
selectItem :: Notepad a
   -- ^ the concerned notepad.
   -> NotepadItem a
   -- ^ the concerned notepad item.
   -> IO ()
   -- ^ None.
selectItem np item =
  do
    deselectAll np
    highlight (canvas np) item
    selecteditems <- getRef (selected_items np)
    setRef (selected_items np) (item : selecteditems)
    sendEv np (Selected item)

-- | Adds an item to the notepad\'s selection.
selectAnotherItem :: Notepad a
   -- ^ the concerned notepad.
   -> NotepadItem a
   -- ^ the concerned notepad item.
   -> IO ()
   -- ^ None.
selectAnotherItem np item =
  do
    highlight (canvas np) item
    selecteditems <- getRef (selected_items np)
    setRef (selected_items np) (item : selecteditems)
    sendEv np (Selected item)

-- | Deselects a notepad item.
deselectItem :: Notepad a
   -- ^ the concerned notepad.
   -> NotepadItem a
   -- ^ the concerned notepad item.
   -> IO ()
   -- ^ None.
deselectItem np item =
  do
    deHighlight item
    selecteditems <- getRef (selected_items np)
    setRef (selected_items np) (filter ((/=) item) selecteditems)
    sendEv np (Deselected item)

-- | Selects all items inside the notepad.
selectAll :: Notepad a
   -- ^ the concerned notepad.
   -> IO ()
   -- ^ None.
selectAll np =
  do
    notepaditems <- getRef (items np)
    mapM (highlight (canvas np)) notepaditems
    mapM (\item -> do
                     b <- isNotepadItemSelected np item
                     if b then done else sendEv np (Selected item))
         notepaditems
    setRef (selected_items np) notepaditems

-- | Deselects all items inside the notepad.
deselectAll :: Notepad a
   -- ^ the concerned notepad.
   -> IO ()
   -- ^ None.
deselectAll np =
  do
    notepaditems <- getRef (items np)
    selecteditems <- getRef (selected_items np)
    mapM deHighlight selecteditems
    mapM (\item -> do
                     b <- isNotepadItemSelected np item
                     if b then sendEv np (Deselected item) else done)
         notepaditems
    setRef (selected_items np) []

-- | Deletes an item from a notepad.
deleteItem :: CItem c => Notepad c
   -- ^ the concerned notepad.
   -> NotepadItem c
   -- ^ the concerned notepad item.
   -> IO ()
   -- ^ None.
deleteItem np item =
  synchronize np
    (do
       notepaditems <- getRef (items np)
       selecteditems <- getRef (selected_items np)
       entereditem <- getRef (entered_item np)
       (if isJust entereditem then setRef (entered_item np) Nothing >>
                                   leftItem np (fromJust entereditem)
        else done)
       setRef (items np) (filter ((/=) item) notepaditems)
       setRef (selected_items np) (filter ((/=) item) selecteditems)
       destroy item)

-- | Deletes all items from a notepad.
clearNotepad :: Notepad a
   -- ^ the concerned notepad.
   -> IO ()
   -- ^ None.
clearNotepad np =
  do
    notepaditems <- getRef (items np)
    mapM destroy notepaditems
    setRef (items np) []
    setRef (selected_items np) []

-- | Internal (for use with GenGUI).
undoLastMotion :: Notepad a -> IO ()
undoLastMotion np =
  synchronize np (do
                    act <- getRef (undo_last_motion np)
                    case act of
                      ToPerform act' -> setRef (undo_last_motion np)
                                               Performed >>
                                        act'
                      _ -> done)

-- | @True@ if the given notepad item is selected.
isNotepadItemSelected :: Notepad a
   -- ^ the concerned notepad.
   -> NotepadItem a
   -- ^ the concerned notepad item.
   -> IO Bool
   -- ^ @True@ if the given notepad item is
   -- selected, otherwise @False@.
isNotepadItemSelected np item =
  do
    selecteditems <- getRef (selected_items np)
    return (any ((==) item) selecteditems)

-- | Selects all items within the specified region.
selectItemsWithin :: Position
   -- ^ the upper left coordinate of the region.
   -> Position
   -- ^ the lower right coordinate of the region.
   -> Notepad a
   -- ^ the concerned notepad.
   -> IO ()
   -- ^ None.
selectItemsWithin p1@(x0, y0) p2@(x1, y1) np =
  do
    notepaditems <- getRef (items np)
    let within :: Position -> Bool
        within (x, y)  =
          ((x0 <= x && x <= x1) || (x1 <= x && x <= x0)) &&
          ((y0 <= y && y <= y1) || (y1 <= y && y <= y0))
    mapM (\ item -> do
                      pos <- getPosition item
                      b <- isNotepadItemSelected np item
                      (if within pos then
                         if b then done else selectAnotherItem np item
                       else
                         if b then deselectItem np item else done))
         notepaditems
    done

-- | Gets the items from a notepad.
getItems :: Notepad a
   -- ^ the concerned notepad.
   -> IO [NotepadItem a]
   -- ^ A list of the contained notepad items.
getItems np = getRef (items np)

-- | Gets the selected items from a notepad.
getSelectedItems :: Notepad a
   -- ^ the concerned notepad.
   -> IO [NotepadItem a]
   -- ^ A list of the selected notepad items.
getSelectedItems np = getRef (selected_items np)

getView :: Notepad a -> IO (Distance, Distance, Distance, Distance)
getView np =
  do (dx_norm, dx_displ_norm) <- view Horizontal (canvas np)
     (dy_norm, dy_displ_norm) <- view Vertical (canvas np)
     (_, (Distance sizex, Distance sizey)) <- getScrollRegion (canvas np)
     let p1_x = Distance (round (dx_norm * fromInteger (toInteger sizex)))
         p1_y = Distance (round (dy_norm * fromInteger (toInteger sizey)))
         p2_x = p1_x + Distance (round (dx_displ_norm *
                                        fromInteger (toInteger sizex)))
         p2_y = p1_y + Distance (round (dy_displ_norm *
                                        fromInteger (toInteger sizey)))
     return (p1_x, p1_y, p2_x, p2_y)


--------------------------------------------------------------------------
-- notepad construction
--------------------------------------------------------------------------

-- | Constructs a new notepad and returns a handler.
newNotepad :: (CItem c, Container par) =>
   par
   -- ^ the parent widget (which has to be a container
   -- widget).
   -> ScrollType
   -- ^ the scrolltype for this notepad.
   -> Size
   -- ^ the size of the notepad items images for this
   -- notepad.
   -> Maybe (NotepadState c)
   -- ^ an optional previous notepad state to recover.
   ->
   [Config (Notepad c)]
   -- ^ the list of configuration options for this notepad.
   -> IO (Notepad c)
   -- ^ A notepad.
newNotepad par scrolltype imgsize mstate cnf =
  do
    let scrolled = (scrolltype == Scrolled)
    notepaditemsref <- newRef []
    selecteditemsref <- newRef []
    entereditemref <- newRef Nothing
    dropref <- newRef Nothing
    ulm <- newRef Performed
    evq <- newRef Nothing
    nps <- newRef Norm
    (cnv, notepad) <- if scrolled then
                        do
                          (scrollbox, cnv) <-
                            newScrollBox par (\p -> newCanvas p []) []
                          return (cnv,
                                  Notepad { canvas = cnv,
                                            scrollbox = Just scrollbox,
                                            img_size = imgsize,
                                            items = notepaditemsref,
                                            selected_items =
                                              selecteditemsref,
                                            entered_item = entereditemref,
                                            drop_item = dropref,
                                            event_queue = evq,
                                            undo_last_motion = ulm,
                                            clean_up = [],
                                            npstate = nps  })
                      else
                        do
                          cnv <- newCanvas par []
                          return (cnv,
                                  Notepad { canvas = cnv,
                                            scrollbox = Nothing,
                                            img_size = imgsize,
                                            items = notepaditemsref,
                                            selected_items =
                                              selecteditemsref,
                                            entered_item = entereditemref,
                                            drop_item = dropref,
                                            event_queue = evq,
                                            undo_last_motion = ulm,
                                            clean_up = [],
                                            npstate = nps })

    (click, _) <- bind cnv [WishEvent [] (ButtonPress (Just 1))]
    (rightclick, _) <- bind cnv
                            [WishEvent [] (ButtonPress (Just 2))]
    (motion', _) <- bind cnv [WishEvent [] Motion]
    (motion, _) <- Examples.watch motion'
    (clickmotion', _) <- bind cnv [WishEvent [Button1] Motion]
    (clickmotion, _) <- Examples.watch clickmotion'
    (doubleclick, _) <- bind cnv [WishEvent [Double]
                                            (ButtonPress (Just 1))]
    (shiftclick, _) <- bind cnv [WishEvent [Shift]
                                           (ButtonPress (Just 1))]
    (release, _) <- bind cnv [WishEvent [] (ButtonRelease (Just 1))]
    (leave, _) <- bindSimple cnv Leave

    stopListening <- newChannel

    let getD :: IO (Distance, Distance)
        getD = do
                 (dx_norm, dx_displ_norm) <- view Horizontal cnv
                 (dy_norm, _) <- view Vertical cnv
                 (_, (Distance sizex, Distance sizey)) <-
                   getScrollRegion cnv
                 return (Distance (round (dx_norm *
                                          fromInteger (toInteger sizex))),
                         Distance (round (dy_norm *
                                          fromInteger (toInteger sizey))))

        addToTag :: CanvasTag -> NotepadItem a -> IO ()
        addToTag tag item =
          do
            it_img item # tags [tag]
            it_txt item # tags [tag]
            rects <- getRef (it_bg item)
            case rects of
              Nothing            -> done
              Just(rect1, rect2) -> do
                                      rect1 # tags [tag]
                                      rect2 # tags [tag]
                                      done

        createTagFromSelection :: Notepad a -> IO CanvasTag
        createTagFromSelection notepad =
          do
            notepaditems <- getRef (items notepad)
            selecteditems <- getRef (selected_items notepad)
            tag <- createCanvasTag (canvas notepad) []
            mapM (addToTag tag) selecteditems
            return tag

        selectByRectangle :: Distance -> Distance -> Position ->
                             Rectangle -> Event ()
        selectByRectangle dx dy pos rect =
          let selectByRectangle' :: Position -> Rectangle -> Event ()
              selectByRectangle' pos@(x, y) rect =
                (do
                   (x1, y1) <- clickmotion >>>= getCoords
                   always (rect # coord [(x + dx, y + dy),
                                         (x1 + dx, y1 + dy)])
                   always (selectItemsWithin (x + dx, y + dy)
                                             (x1 + dx, y1 + dy) notepad)
                   selectByRectangle' pos rect) +>
                (do
                   ev_inf <- release
                   always (do
                             (dx, dy) <- getD
                             (x1,y1) <- getCoords ev_inf
                             sendEv notepad ReleaseSelection
                             selectItemsWithin (x + dx, y + dy)
                                               (x1 + dx, y1 + dy) notepad
                             destroy rect))
          in selectByRectangle' pos rect


        checkPositions :: [NotepadItem a] -> IO (Distance, Distance)
        checkPositions (item : items) =
          do
            let (Distance iwidth, Distance iheight) = it_img_size item
            (Distance x, Distance y) <- getPosition item
            (Distance dx, Distance dy) <- checkPositions items

            (_, (Distance sizex, Distance sizey)) <-
              getScrollRegion (canvas notepad)

            let min_x = x - (max (div iwidth 2 + 30) 40)
                min_y = y - (div iheight 2 + 1)

                dx' = max dx (-min_x)
                    {-if dx < 0 then min min_x dx
                      else if dx == 0 then
                             if min_x < 0 then min_x
                             else if max_x > sizex then max_x - sizex
                                  else 0
                           else if dx > 0 then
                                  max dx (max_x - sizex)
                                else 0-}
                dy' = max dy (-min_y)
                    {-if dy < 0 then min min_y dy
                      else if dy == 0 then
                             if min_y < 0 then min_y
                             else if max_y > sizey then max_y - sizey
                                  else 0
                           else if dy > 0 then
                                  max dy (max_y - sizey)
                                else 0-}

            return (Distance dx', Distance dy')
        checkPositions [] = return (Distance 0, Distance 0)

{-
        checkPositions :: [NotepadItem a] -> IO (Distance, Distance)
        checkPositions (item : items) =
          do
            let (Distance iwidth, Distance iheight) = it_img_size item
            (Distance x, Distance y) <- getPosition item
            (Distance dx, Distance dy) <- checkPositions items
            (_, (Distance sizex, Distance sizey)) <-
              getScrollRegion (canvas notepad)
            let min_x = x - (max (div iwidth 2 + 30) 40)
                max_x = x + (max (div iwidth 2 + 30) 40)
                min_y = y - (div iheight 2 + 1)
                max_y = y + (div iheight 2 + 18)

                dx' = if dx < 0 then min min_x dx
                      else if dx == 0 then
                             if min_x < 0 then min_x
                             else if max_x > sizex then max_x - sizex
                                  else 0
                           else if dx > 0 then
                                  max dx (max_x - sizex)
                                else 0
                dy' = if dy < 0 then min min_y dy
                      else if dy == 0 then
                             if min_y < 0 then min_y
                             else if max_y > sizey then max_y - sizey
                                  else 0
                           else if dy > 0 then
                                  max dy (max_y - sizey)
                                else 0

            return (Distance dx', Distance dy')
        checkPositions [] = return (Distance 0, Distance 0)
-}

        grid_x :: Int
        grid_x = 10
        grid_y :: Int
        grid_y = 10

        checkDropZones :: CItem a =>
                          Map.Map (Int, Int) [NotepadItem a] ->
                          Notepad a -> Distance -> Distance -> IO ()
        checkDropZones it_map notepad x@(Distance ix) y@(Distance iy) =
          let doSet item =
                do
                  (x, y) <- getPosition item
                  let (Distance iwidth, Distance iheight) =
                        it_img_size item
                  rect1 <- createRectangle (canvas notepad)
                             [coord [(x - Distance (div iwidth 2 + 1),
                                      y - Distance (div iheight 2 + 1)),
                                     (x + Distance (div iwidth 2),
                                      y + Distance (div iheight 2))],
                              filling "yellow", outline "yellow"]
                  putItemAtBottom rect1
                  rect2 <- createRectangle (canvas notepad)
                             [coord [(x - Distance
                                            (max (div iwidth 2 + 40) 40),
                                      y + Distance (div iheight 2)),
                                     (x + Distance
                                            (max (div iwidth 2 + 40) 40),
                                      y + Distance (div iheight 2 + 18))],
                              filling "yellow", outline "yellow"]
                  putItemAtBottom rect2
                  setRef (drop_item notepad) (Just (item, rect1, rect2))

              setDropRef item =
                do
                   drop <- getRef (drop_item notepad)
                   case drop of
                     Nothing -> doSet item
                     Just (ditem, rect1, rect2) ->
                       if item == ditem then done
                       else destroy rect1 >> destroy rect2 >> doSet item

              inDropZone item =
                do
                  (x_it, y_it) <- getPosition (it_img item)
                  return (if x_it - 30 < x && x_it + 30 > x &&
                             y_it - 10 < y && y_it + 30 > y then True
                          else False)

              checkDropZones' (item : items) =
                do
                  b <- inDropZone item
                  (if b then setDropRef item else checkDropZones' items)
              checkDropZones' [] =
                do
                  maybeitem <- getRef (drop_item notepad)
                  case maybeitem of
                    Just (_, rect1, rect2) ->
                      destroy rect1 >> destroy rect2 >>
                      setRef (drop_item notepad) Nothing
                    Nothing -> done

          in do (_, (Distance sizex, Distance sizey)) <-
                  getScrollRegion (canvas notepad)
                let idx@(idx_x, idx_y) = (div ix (div sizex grid_x), div iy (div sizey grid_y))
                    items = (Map.findWithDefault [] idx it_map)
                checkDropZones' items

        buildMap :: CItem a => Notepad a -> IO (Map.Map (Int, Int) [NotepadItem a])
        buildMap notepad =
          do notepaditems <- getRef (items notepad)
             selecteditems <- getRef (selected_items notepad)
             let nonselecteditems =
                   filter (\item -> not(any ((==) item) selecteditems))
                          notepaditems
             fmref <- newRef Map.empty
             let add (idx_x, idx_y) notepaditem =
                   if idx_x >= 0 && idx_x < grid_x &&
                      idx_y >= 0 && idx_y < grid_y then
                     do fm <- getRef fmref
                        let mnotepaditems = Map.lookup (idx_x, idx_y) fm
                        let nufm = case mnotepaditems of
                                     Just notepaditems ->
                                       Map.insert (idx_x, idx_y)
                                         (notepaditem : notepaditems) fm
                                     _ -> Map.insert (idx_x, idx_y)
                                                  [notepaditem] fm
                        setRef fmref nufm
                   else done
                 getCenterIndex notepaditem =
                   do (_, (Distance sizex, Distance sizey)) <-
                        getScrollRegion (canvas notepad)
                      (Distance x, Distance y) <- getPosition notepaditem
                      return (div x (div sizex grid_x),
                              div y (div sizey grid_y))
                 addNotepadItem notepaditem =
                   do idx@(idx_x, idx_y) <- getCenterIndex notepaditem
                      add idx notepaditem
                      add (idx_x - 1, idx_y    ) notepaditem
                      add (idx_x - 1, idx_y - 1) notepaditem
                      add (idx_x    , idx_y - 1) notepaditem
                      add (idx_x + 1, idx_y - 1) notepaditem
                      add (idx_x + 1, idx_y    ) notepaditem
                      add (idx_x + 1, idx_y + 1) notepaditem
                      add (idx_x    , idx_y + 1) notepaditem
                      add (idx_x - 1, idx_y + 1) notepaditem
             mapM addNotepadItem nonselecteditems
             getRef fmref

        moveSelectedItems it_map rpos@(rootx, rooty) (x0, y0) t =
             (do
                (x, y) <- clickmotion >>>= getCoords
                always (do
                          (dx, dy) <- getD
                          checkDropZones it_map notepad (x + dx) (y + dy)
                          setRef (undo_last_motion notepad)
                                 (ToPerform (moveItem t (rootx - x0)
                                                        (rooty - y0)))
                          moveItem t (x - x0) (y - y0))
                moveSelectedItems it_map rpos (x, y) t)
          +> (do
                ev_inf <- release
                always (do
                          sendEv notepad (ReleaseMovement ev_inf)
                          drop <- getRef dropref
                          case drop of
                            Just (item, rect1, rect2) ->
                              do
                                act <- getRef (undo_last_motion notepad)
                                case act of
                                  Performed -> done
                                  _ -> do
                                         undoLastMotion notepad
                                         selecteditems <-
                                           getRef selecteditemsref
                                         sendEv notepad
                                                (Dropped (item,
                                                          selecteditems))
                                setRef dropref Nothing
                                destroy rect1
                                destroy rect2
                            _ -> do
                                   selecteditems <-
                                     getRef selecteditemsref
                                   (dx, dy) <-
                                     checkPositions selecteditems
--                                   moveItem t (-dx) (-dy)))
                                   moveItem t dx dy
                                   updNotepadScrollRegion notepad))

        checkEnteredItem (x, y) =
          let overItem item =
                do
                  (dx, dy) <- getD
                  (x_it, y_it) <- getPosition (it_img item)
                  return (if x_it - 30 < x + dx && x_it + 30 > x + dx &&
                             y_it - 10 < y + dy && y_it + 30 > y + dy then True
                          else False)
              checkItems (item : items) =
                do
                  b <- overItem item
                  (if b then setRef entereditemref (Just item)
                   else checkItems items)
              checkItems _  = setRef entereditemref Nothing
          in synchronize notepad
               (do
                  last <- getRef entereditemref
                  items <- getRef notepaditemsref
                  checkItems items
                  new <- getRef entereditemref
                  (if isJust last then
                     if isJust new then
                       if fromJust last == fromJust new then done
                       else
                         leftItem notepad (fromJust last) >>
                         enteredItem notepad (fromJust new)
                     else
                       leftItem notepad (fromJust last)
                   else
                     if isJust new then
                       enteredItem notepad (fromJust new)
                     else
                       done))

        listenNotepad :: Event ()
        listenNotepad =
             (leave >> always (do
                                 mentereditem <- getRef entereditemref
                                 (if isJust mentereditem then
                                    leftItem notepad
                                             (fromJust mentereditem) >>
                                    setRef entereditemref Nothing
                                  else done)) >>
                       listenNotepad)
-- -----
{-
          +> (do
                (x, y) <- motion >>>= getCoords
                always (checkEnteredItem (x, y))
                listenNotepad)
-}
-- -------

          +> (do
                (x, y) <- click >>>= getCoords
                always
                  (do
                     entereditem <- getRef entereditemref
                     case entereditem of
                       Nothing -> do
                                    deselectAll notepad
                                    (dx, dy) <- getD
                                    rect <- createRectangle cnv
                                              [coord [(x + dx, y + dy),
                                                      (x + dx, y + dy)]]
                                    sync
                                      (selectByRectangle dx dy (x, y)
                                                         rect)
                                    done
                       Just item ->
                         do
                           leftItem notepad item
                           b <- isNotepadItemSelected notepad item
                           if b then done else selectItem notepad item
                           t <- createTagFromSelection notepad
                           sync (do mp <- always (buildMap notepad)
                                    always (setIntState notepad Mov)
                                    moveSelectedItems mp (x, y) (x, y) t
                                    always (setIntState notepad Norm))
                           done)
                listenNotepad)
          +> (do
                (x, y) <- rightclick >>>= getCoords
                always
                  (do
                     entereditem <- getRef entereditemref
                     case entereditem of
                       Nothing -> do
                                    deselectAll notepad
                                    sendEv notepad (Rightclick [])
                       Just entereditem ->
                         do
                           b <- isNotepadItemSelected notepad
                                                      entereditem
                           (if b then
                              do
                                selecteditems <- getRef selecteditemsref
                                sendEv notepad (Rightclick selecteditems)
                            else
                              do
                                selectItem notepad entereditem
                                sendEv notepad
                                       (Rightclick [entereditem])))
                listenNotepad)
          +> (doubleclick >> do
                               always (do
                                         entereditem <-
                                           getRef entereditemref
                                         case entereditem of
                                           Just item ->
                                             sendEv notepad
                                                    (Doubleclick item)
                                           _ -> done)
                               listenNotepad)
          +> (shiftclick >> do
                              always (do
                                        entereditem <-
                                          getRef entereditemref
                                        case entereditem of
                                          Just item ->
                                            do
                                              b <- isNotepadItemSelected
                                                     notepad item
                                              (if b then
                                                 deselectItem notepad
                                                              item
                                               else
                                                 selectAnotherItem
                                                   notepad item)
                                          _ -> done)
                              listenNotepad)
          +> (release >> listenNotepad)  -- avoid cueing of release events
          +> receive stopListening

    _ <- spawnEvent listenNotepad
    foldl (>>=) (return notepad) cnf
    case mstate of
      Just state -> importNotepadState notepad state
      _ -> done
    return notepad

updNotepadScrollRegion :: Notepad a -> IO ()
updNotepadScrollRegion np =
  let getMax (item : items) mx my =
        do (x, y) <- getPosition item
           let nux = max x mx
               nuy = max y my
           getMax items nux nuy
      getMax _ mx my = return (mx, my)
  in do (x1, y1, x2, y2) <- getView np
        items <- getItems np
        (x, y) <- getMax items 0 0
        np # size (x + 80, y + 40)
        done

-- instances --

-- | Internal.
instance GUIObject (Notepad a) where
  toGUIObject np =
    case (scrollbox np) of Nothing -> toGUIObject (canvas np)
                           Just box -> toGUIObject box
  cname _ = "Notepad"

-- | A notepad can be destroyed.
instance Destroyable (Notepad a) where
  -- Destroys a notepad.
  destroy = destroy . toGUIObject          -- TD : clean up !!!

-- | A notepad has standard widget properties
-- (concerning focus, cursor).
instance Widget (Notepad a)

-- | You can synchronize on a notepad object.
instance Synchronized (Notepad a) where
  -- Synchronizes on a notepad object.
  synchronize w = synchronize (toGUIObject w)

-- | A notepad has a configureable border.
instance HasBorder (Notepad a)

-- | A notepad has a configureable background colour.
instance HasColour (Notepad a) where
  legalColourID np = hasBackGroundColour (canvas np)
  setColour notepad cid col =
    setColour (canvas notepad) cid col >> return notepad
  getColour np cid = getColour (canvas np) cid

-- | A notepad has a configureable size.
instance HasSize (Notepad a) where
  -- Sets the notepad\'s width.
  width s np =
    do
      (_, (_, sizey)) <- getScrollRegion (canvas np)
      canvas np # scrollRegion ((0, 0), (s, sizey))
      if isJust (scrollbox np) then done else canvas np # width s >> done
      return np
  -- Gets the notepad\'s width.
  getWidth np = getWidth (canvas np)
  -- Sets the notepad\'s height.
  height s np =
    do
      (_, (sizex, _)) <- getScrollRegion (canvas np)
      canvas np # scrollRegion ((0, 0), (sizex, s))
      (if (isJust (scrollbox np)) then done
       else canvas np # height s >> done)
      return np
  -- Gets the notepad\'s height.
  getHeight np = getHeight (canvas np)


-- -----------------------------------------------------------------------
-- state import / export
-- -----------------------------------------------------------------------

-- | The @NotepadExportItem@ datatype.
data CItem c => NotepadExportItem c =
  NotepadExportItem { val :: c,
                      pos :: Position,
                      selected :: Bool }

type NotepadState c = [NotepadExportItem c]

-- | Exports a notepad\'s state.
exportNotepadState :: CItem c => Notepad c
   -- ^ the concerned notepad.
   -> IO (NotepadState c)
   -- ^ The notepad\'s state.
exportNotepadState np =
  synchronize np (do
                    items' <- getRef (items np)
                    exportNotepadState' np items')
  where exportNotepadState' :: CItem c => Notepad c -> [NotepadItem c] ->
                               IO (NotepadState c)
        exportNotepadState' np (item : items) =
          do
            val' <- getRef (it_val item)
            pos <- getPosition (it_img item)
            is_selected <- isNotepadItemSelected np item
            rest <- exportNotepadState' np items
            return (NotepadExportItem { val = val',
                                        pos = pos,
                                        selected = is_selected } : rest)
        exportNotepadState' _ _ = return []

-- | Imports a notepad\'s state.
importNotepadState :: CItem c => Notepad c
   -- ^ the concerned notepad.
   -> NotepadState c
   -> IO ()
   -- ^ None.
importNotepadState np st =
  synchronize np (do
                    clearNotepad np
                    addItems np st
                    updNotepadScrollRegion np)
  where addItems :: CItem c => Notepad c -> NotepadState c -> IO ()
        addItems np (it : items) =
          do
            new_it <- createNotepadItem (val it) np False
                                        [position (pos it)]
            if selected it then selectAnotherItem np new_it else done
            addItems np items
        addItems _ _ = done