-- -----------------------------------------------------------------------
--
-- $Source: /repository/uni/htk/components/BitMap.hs,v $
--
-- HTk - a GUI toolkit for Haskell  -  (c) Universitaet Bremen
--
-- $Revision: 1.7 $ from $Date: 2002/04/23 21:16:59 $  
-- Last modification by $Author: cxl $
--
-- -----------------------------------------------------------------------


---
-- This module provides access to bitmap resources.
module BitMap (

  BitMap,
  newBitMap,

  BitMapHandle(..),
  HasBitMap(..),
  BitMapDesignator(..),

  errmap, 
  gray50, 
  gray25, 
  hourglass, 
  info, 
  questhead, 
  question, 
  warning,

  setBitMapHandle,
  getBitMapHandle,
  stringToBitMapHandle

) where

import GUIValue
import Core
import BaseClasses(Widget)
import Configuration
import Char(isDigit)
import Computation
import Synchronized
import Destructible
import Packer


-- -----------------------------------------------------------------------
-- BitMap designators
-- -----------------------------------------------------------------------

---
-- The <code>BitMapHandle</code> datatype - a handle for a bitmap
-- resource.
data BitMapHandle =
          Predefined String 
        | BitMapHandle BitMap 
        | BitMapFile String

---
-- Internal.
class BitMapDesignator d where
---
-- Internal.
  toBitMap :: d -> BitMapHandle

---
-- Internal.
instance BitMapDesignator BitMapHandle where
---
-- Internal.
  toBitMap = id

---
-- Internal.
instance BitMapDesignator BitMap where
---
-- Internal.
  toBitMap h = BitMapHandle h

---
-- A string is a handle for a bitmap file.
instance BitMapDesignator [Char] where
  toBitMap h = BitMapFile h


-- -----------------------------------------------------------------------
-- BitMap'ed widgets
-- -----------------------------------------------------------------------

---
-- Containers for bitmaps instantiate the <code>class HasBitMap</code>.
class GUIObject w => HasBitMap w where
  bitmap          :: BitMapDesignator d => d -> Config w
  getBitMap       :: w -> IO BitMapHandle
  bitmap d w      = setBitMapHandle w "bitmap" (toBitMap d) True 
  getBitMap w     = getBitMapHandle w "bitmap"


-- -----------------------------------------------------------------------
-- type BitMap 
-- -----------------------------------------------------------------------

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


-- -----------------------------------------------------------------------
-- commands
-- -----------------------------------------------------------------------

---
-- Constructs a new bitmap object and returns a handler.<br>
-- The bitmap object can be packed like a widget, then it is implicitely
-- displayed inside a label widget.
-- @param cnf - the list of configuration options for this bitmap  object.
-- @return result - A bitmap object.
newBitMap :: [Config BitMap] -> IO BitMap
newBitMap confs =
  do
    w <- createWidget ROOT LABEL 
    configure (BitMapWDG w) confs


-- -----------------------------------------------------------------------
-- predefined Tk BitMaps
-- -----------------------------------------------------------------------

---
-- A handle for the predefined "error" bitmap.
errmap :: BitMapHandle
errmap = Predefined "error" 

---
-- A handle for the predefined "gray50" bitmap.
gray50 :: BitMapHandle
gray50 = Predefined "gray50" 

---
-- A handle for the predefined "gray25" bitmap.
gray25 :: BitMapHandle
gray25 = Predefined "gray25" 

---
-- A handle for the predefined "hourglass" bitmap.
hourglass :: BitMapHandle
hourglass = Predefined "hourglass"

---
-- A handle for the predefined "info" bitmap.
info :: BitMapHandle
info = Predefined "info" 

---
-- A handle for the predefined "questhead" bitmap.
questhead :: BitMapHandle
questhead = Predefined "questhead"

---
-- A handle for the predefined "question" bitmap.
question :: BitMapHandle
question = Predefined "question" 

---
-- A handle for the predefined "warning" bitmap.
warning :: BitMapHandle
warning = Predefined "warning"


-- -----------------------------------------------------------------------
-- configuration options
-- -----------------------------------------------------------------------

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

---
-- A bitmap object can be destroyed.
instance Destroyable BitMap where
---
-- Destroys a bitmap object.
  destroy = destroy . toGUIObject

---
-- A bitmap object has standard widget properties
-- (concerning focus, cursor / if implicitely displayed inside a label
-- widget).
instance Widget BitMap

---
-- A bitmap object has a configureable border (if implicitely displayed
-- inside a label widget).
instance HasBorder BitMap

---
-- A bitmap object has a configureable foreground and background colour
-- (if implicitely displayed inside a label widget).
instance HasColour BitMap where 
  legalColourID = hasForeGroundColour

---
-- You can specify the size of the containing label, if the bitmap is
-- implicitely displayed inside a label widget.
instance HasSize BitMap

---
-- Bitmaps can be read from files.
instance HasFile BitMap where
---
-- Specifies the bitmap's file path.
  filename fname w =
    execTclScript [tkBitMapCreate no fname] >> cset w "image" no
    where no = getObjectNo (toGUIObject w)
---
-- Gets the bitmap's file name.
  getFileName w = evalTclScript [tkGetBitMapFile no]
    where no = getObjectNo (toGUIObject w)

---
-- You can synchronize on a bitmap object.
instance Synchronized BitMap where
---
-- Synchronizes on a bitmap object.
  synchronize (BitMapWDG w) = synchronize w


-- -----------------------------------------------------------------------
-- auxiliary functions
-- -----------------------------------------------------------------------

---
-- Internal.
setBitMapHandle :: GUIObject w => w -> ConfigID -> BitMapHandle ->
                   Bool -> IO w
setBitMapHandle w cnm (Predefined d) _ = cset w cnm d 
setBitMapHandle w cnm (BitMapFile f) _ = cset w cnm ('@':f)
setBitMapHandle w _ (BitMapHandle h) True =
  cset w "image" (getObjectNo (toGUIObject h))
setBitMapHandle w cnm (BitMapHandle h) False =
  do
    fname <- getFileName h
    setBitMapHandle w cnm (BitMapFile fname) False
    return w
{- 
   the last parameter determines whether integer numbers are acceptable
   as bitmap denotations or not. If not, we use the corresponding file
   name associated with the widget! Numbers are allowed for labels and
   buttons, but not for windows!
-}

---
-- Internal.
getBitMapHandle :: GUIObject w => w -> ConfigID -> IO BitMapHandle
getBitMapHandle w cnm = cget w cnm >>= stringToBitMapHandle

---
-- Internal.
stringToBitMapHandle :: String -> IO BitMapHandle
stringToBitMapHandle "" = return (Predefined "")
stringToBitMapHandle ('@':tl) = return (BitMapFile tl)          
stringToBitMapHandle (str @ (x:tl)) | isDigit x = 
  lookupGUIObject (read str)      >>= return . BitMapHandle . BitMapWDG 
stringToBitMapHandle str = return (Predefined str)


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

tkBitMapCreate :: Int -> String -> String
tkBitMapCreate no f = "image create bitmap " ++ show no ++ " -file " ++ show f
{-# INLINE tkBitMapCreate #-}

tkGetBitMapFile :: Int -> String
tkGetBitMapFile no = (show no) ++ " cget -file "
{-# INLINE tkGetBitMapFile #-}