-- -----------------------------------------------------------------------
--
-- $Source: /repository/uni/htk/widgets/ScrollBar.hs,v $
--
-- HTk - a GUI toolkit for Haskell  -  (c) Universitaet Bremen
--
-- $Revision: 1.5 $ from $Date: 2002/02/21 14:37:49 $  
-- Last modification by $Author: cxl $
--
-- -----------------------------------------------------------------------

---
-- HTk's <strong>scrollbar</strong> widget.<br>
-- 
-- A scroll bar is a widget which controls scrolling.
--
module ScrollBar (

  HasScroller(..),
  ScrollBar,
  newScrollBar,

  ScrollUnit(..),

  Slider(..),
  HasSlider(..),

  ScrollBarElem(..),
  activateScrollBarElem,
  getActivatedElem,

  Fraction,
  fraction,
  identify,
  setView

) where

import Core
import BaseClasses(Widget)
import Configuration
import Geometry
import Resources
import Destructible
import Slider
import Char
import Computation
import Synchronized
import ReferenceVariables
import Packer
import Tooltip
import GUIValue
import List(dropWhile, takeWhile)
import Char(isSpace)


-- -----------------------------------------------------------------------
-- fraction type
-- -----------------------------------------------------------------------

---
-- Fractions are floating point values between 0 and 1 representing
-- relative positions within the scrolled range.
type Fraction = Double

---
-- Internal.
instance GUIValue (Fraction, Fraction) where
---
-- Internal.
  cdefault = (0.0, 0.0)

---
-- Internal.
instance Show (Fraction, Fraction) where
---
-- Internal.
  showsPrec d (f1, f2) r = show f1 ++ " " ++ show f2 ++ r

---
-- Internal.
instance Read (Fraction, Fraction) where
---
-- Internal.
   readsPrec p b = 
     case readsPrec p b of
       [(x,xs)] -> case readsPrec p xs of
                      [(y,ys)] -> [((x,y),ys)]
                      _        -> []
       _        -> []


-- -----------------------------------------------------------------------
-- classes
-- -----------------------------------------------------------------------

---
-- Scrollable widgets instantiate <code>class HasScroller</code>.
class Widget w => HasScroller w where
---
-- <code>True</code> for widgets that are scrollable in the given
-- orientation.
  isWfOrientation :: w -> Orientation -> Bool
---
-- Associates a scrollbar with a scrollable widget.
  scrollbar       :: Orientation -> ScrollBar -> Config w
---
-- Positions the scrolled widget so the give <code>Fraction</code> is
-- off-screen to the left.
  moveto          :: Orientation -> w -> Fraction -> IO ()
---
-- Scrolls the associated widget by n pages or units (depending on the
-- given <code>ScrollUnit</code>).
  scroll          :: Orientation -> w -> Int -> ScrollUnit -> IO ()
---
-- Returns two fractions between 0 and 1 that describe the amount of
-- the widget off-screen to the left and the amount of the widget visible.
  view            :: Orientation -> w -> IO (Fraction, Fraction)


  isWfOrientation _ _ = True

  scrollbar Horizontal sc w | isWfOrientation w Horizontal =
    do
      cset sc "command" (TkCommand (varname w ++ " xview"))
      execTclScript [tkDeclScrollVar w]
      cset w "xscrollcommand" (TkCommand (varname sc ++ " set"))
      execTclScript [tkDeclScrollVar sc]
      return w
  scrollbar Vertical sc w | isWfOrientation w Vertical =
    do
      cset sc "command" (TkCommand (varname w ++ " yview"))
      execTclScript [tkDeclScrollVar w]
      cset w "yscrollcommand" (TkCommand (varname sc ++ " set"))
      execTclScript [tkDeclScrollVar sc]
      return w
  scrollbar _ _ w = return w

  moveto ax w f | isWfOrientation w ax =
    execMethod w (\nm -> [tkMoveTo ax nm f])
  moveto _ _ _ = done

  scroll ax w num what | isWfOrientation w ax =
    execMethod w (\nm -> [tkScroll ax nm num what])
  scroll ax w num what = done

  view ax w = evalMethod w (tkView ax)


-- -----------------------------------------------------------------------
-- datatype
-- -----------------------------------------------------------------------

---
-- The <code>ScrollBar</code> datatype.
newtype ScrollBar = ScrollBar GUIOBJECT deriving Eq


-- -----------------------------------------------------------------------
-- constructor
-- -----------------------------------------------------------------------

---
-- Constructs a new scrollbar widget and returns a handler.
-- @param par     - the parent widget, which has to be a container widget
--                  (an instance of <code>class Container</code>).
-- @param cnf     - the list of configuration options for this scrollbar.
-- @return result - A scrollbar widget.
newScrollBar :: Container par => par -> [Config ScrollBar] -> IO ScrollBar
newScrollBar par cnf =
  do
    w <- createGUIObject (toGUIObject par) SCROLLBAR scrollbarMethods 
    configure (ScrollBar w) cnf


-- -----------------------------------------------------------------------
-- ScrollBar configuration options
-- -----------------------------------------------------------------------

---
-- Internal.
instance GUIObject ScrollBar where 
---
-- Internal.
  toGUIObject (ScrollBar w) = w
---
-- Internal.
  cname _ = "ScrollBar"

---
-- A scrollbar widget can be destroyed.
instance Destroyable ScrollBar where
---
-- Destroys a scrollbar widget.
  destroy = destroy . toGUIObject

---
-- A scrollbar widget has standard widget properties
-- (concerning focus, cursor).
instance Widget ScrollBar 

---
-- A scrollbar widget has a configureable border.
instance HasBorder ScrollBar

---
-- A scrollbar widget has a background and activebackground
-- (regarding slider) colour.
instance HasColour ScrollBar where
---
-- Internal.
  legalColourID w "bg" = True
  legalColourID w "activebackground" = True -- regards slider actually
  legalColourID w _ = False

---
-- A scrollbar widget is a stateful widget, it can be enabled or
-- disabled.
instance HasEnable ScrollBar

---
-- You can specify the width of a scrollbar.
instance HasSize ScrollBar where
---
-- Dummy.
  height _ w = return w
---
-- Dummy.
  getHeight w = return cdefault

---
-- The scrollbar has a configureable slider component.
instance HasSlider ScrollBar

---
-- The scrollbars orientation can be <code>Horizontal</code> or
-- <code>Vertical</code>.
instance HasOrientation ScrollBar

---
-- A scrollbar can have a tooltip.
instance HasTooltip ScrollBar


-- -----------------------------------------------------------------------
-- ScrollBar commands
-- -----------------------------------------------------------------------

---
-- Sets the active element (which can be arrow1, arrow2 or slider).
-- @param sc      - the concerned scrollbar.
-- @param elem    - the element to activate.
-- @return result - None.
activateScrollBarElem :: ScrollBar -> ScrollBarElem -> IO ()
activateScrollBarElem sc elem =
  execMethod sc (\nm -> [tkActivate nm elem])

---
-- Gets the active element (arrow1, arrow2 or slider).
-- @param sc      - the concerned scrollbar.
-- @return result - <code>Just [elem]</code> if an element is active,
--                  otherwise <code>Nothing</code>.
getActivatedElem :: ScrollBar -> IO (Maybe ScrollBarElem)
getActivatedElem sc =
  do
    e <- evalMethod sc (\nm -> [tkGetActivate nm])
    case dropWhile isSpace e of
      "" -> return Nothing
      x -> return (Just (read x))

---
-- Returns a fraction between 0 and 1 indicating the relative location
-- of the given position in the through.
-- @param sc      - the concerned scrollbar.
-- @param pos     - the conderned position.
-- @return result - The fraction indicating the relative location in the
--                  through.
fraction :: ScrollBar -> Position -> IO Fraction
fraction sc pos@(x, y) = evalMethod sc (\nm -> [tkFraction nm x y])

---
-- Returns the <code>ScrollBarElem</code> to indicate what is under
-- the given position.
-- @param sc      - the concerned scrollbar.
-- @param pos     - the concerned position.
-- @return result - <code>Just [elem]</code> if <code>[elem]</code> is
--                  under the given position, otherwise
--                  <code>Nothing</code>.
identify :: ScrollBar -> Position -> IO (Maybe ScrollBarElem)
identify sc pos@(x, y) =
  do
    e <- evalMethod sc (\nm -> [tkIdentify nm x y])
    case dropWhile (isSpace) e of
      "" -> return Nothing
      x -> return (Just (read x))

---
-- Sets the scrollbar parameters.
-- @param sc      - the concerned scrollbar.
-- @param first   - fraction between 0 and 1 representing the relative
--                  position of the top left of the display.
-- @param last    - fraction between 0 and 1 representing the relative
--                  position of the bottom right of the display.
-- @return result - None.
setView :: ScrollBar -> Fraction -> Fraction -> IO ()
setView sc first last = execMethod sc (\nm -> [tkSet nm first last])


-- -----------------------------------------------------------------------
-- ScrollBar elem
-- -----------------------------------------------------------------------

---
-- The <code>ScrollBarElem</code> datatype - representing the elements
-- of the scrollbar.
data ScrollBarElem = 
    Arrow1
  | Trough1
  | ScrollBarSlider
  | Trough2
  | Arrow2
  deriving (Eq,Ord,Enum)

---
-- Internal.
instance GUIValue ScrollBarElem where
---
-- Internal.
  cdefault = ScrollBarSlider

---
-- Internal.
instance Read ScrollBarElem where
---
-- Internal.
  readsPrec p b =
    case dropWhile (isSpace) b of
       'a':'r':'r':'o':'w':'1':xs -> [(Arrow1,xs)]
       't':'r':'o':'u':'g':'h':'1':xs -> [(Trough1,xs)]
       's':'l':'i':'d':'e':'r':xs -> [(ScrollBarSlider,xs)]
       't':'r':'o':'u':'g':'h':'2':xs -> [(Trough2,xs)]
       'a':'r':'r':'o':'w':'2':xs -> [(Arrow2,xs)]
       _ -> []

---
-- Internal.
instance Show ScrollBarElem where
---
-- Internal.
  showsPrec d p r = 
     (case p of 
         Arrow1 -> "arrow1"
         Trough1 -> "trough1"
         ScrollBarSlider -> "slider"
         Trough2 -> "trough2"
         Arrow2 -> "arrow2"
       ) ++ r


-- -----------------------------------------------------------------------
-- scroll unit
-- -----------------------------------------------------------------------

---
-- The <code>ScrollUnit</code> datatype - units for scrolling operations.
data ScrollUnit = Units | Pages

---
-- Internal.
instance GUIValue ScrollUnit where
---
-- Internal.
  cdefault = Units

---
-- Internal.
instance Read ScrollUnit where
---
-- Internal.
   readsPrec p b =
     case dropWhile (isSpace) b of
        'u':'n':'i':'t':'s':xs -> [(Units,xs)]
        'p':'a':'g':'e':'s':xs -> [(Pages,xs)]
        _ -> []

---
-- Internal.
instance Show ScrollUnit where
---
-- Internal.
   showsPrec d p r = 
      (case p of 
          Units -> "units"
          Pages -> "pages"
        ) ++ r


-- -----------------------------------------------------------------------
-- Scrollbar methods
-- -----------------------------------------------------------------------

scrollbarMethods = defMethods { cleanupCmd = tkCleanupScrollBar,
                                createCmd = tkCreateScrollBar }


-- -----------------------------------------------------------------------
-- Tk commands
-- -----------------------------------------------------------------------

tkCreateScrollBar :: ObjectName -> ObjectKind -> ObjectName -> ObjectID ->
                     [ConfigOption] -> TclScript
tkCreateScrollBar pnm kind name oid confs =
  tkDeclVar ("sv" ++ show oid) (show name) ++ 
  (createCmd defMethods) pnm kind name oid confs 
{-# INLINE tkCreateScrollBar #-}

tkCleanupScrollBar :: ObjectID -> ObjectName -> TclScript
tkCleanupScrollBar oid _ = tkUndeclVar ("sv" ++ show oid)
{-# INLINE tkCleanupScrollBar #-}

varname :: GUIObject w => w -> String
varname w = (tkDeclScrollVar w) ++ "; $sv" ++ ((show .getObjectNo . toGUIObject) w)
{-# INLINE varname #-}

tkDeclScrollVar :: GUIObject w => w -> String
tkDeclScrollVar w = "global sv" ++ ((show .getObjectNo . toGUIObject) w)
{-# INLINE tkDeclScrollVar #-}

tkScroll :: Orientation -> ObjectName -> Int -> ScrollUnit -> TclCmd
tkScroll ax nm no what = show nm ++ " " ++ oshow ax ++ "view scroll " ++ show no ++ " " ++ show what
{-# INLINE tkScroll #-}

-- added Oct. '01, still experimental (ludi)
tkView :: Orientation -> ObjectName -> TclScript
tkView ax nm = [show nm ++ " " ++ oshow ax ++ "view"]
{-# INLINE tkView #-}

tkMoveTo :: Orientation -> ObjectName -> Fraction -> String
tkMoveTo ax nm f = show nm ++ " " ++ oshow ax ++ "view moveto " ++ show f
{-# INLINE tkMoveTo #-}
 
tkActivate :: ObjectName -> ScrollBarElem -> String
tkActivate nm e = show nm ++ " activate " ++ show e 
{-# INLINE tkActivate #-}
 
tkGetActivate :: ObjectName -> String
tkGetActivate nm = show nm ++ " activate" 
{-# INLINE tkGetActivate #-}
 
tkFraction :: ObjectName -> Distance -> Distance -> String
tkFraction nm x y = show nm ++ " fraction " ++ show x ++ " " ++ show y 
{-# INLINE tkFraction #-}
 
tkIdentify :: ObjectName -> Distance -> Distance -> String
tkIdentify nm x y = show nm ++ " identify " ++ show x ++ " " ++ show y 
{-# INLINE tkIdentify #-}
 
tkSet :: ObjectName -> Fraction -> Fraction -> String
tkSet nm x y = show nm ++ " set " ++ show x ++ " " ++ show y 
{-# INLINE tkSet #-}

oshow Horizontal = "x"
oshow Vertical   = "y"