Image.hs

module Controller.Menu.File.Export.Image (eventHandler)
    where

import Control.Monad (foldM,foldM_,when)
import Control.Monad.Trans (liftIO)
import Control.Applicative ((<$>))
import Foreign (Ptr,malloc,peek,nullPtr)
import qualified Graphics.UI.WXCore as WXC
import Config (imageExportParameters)
import Controller (Controller,onGridView,onView,getFromConfig,setOnConfig)
import View.Component.Grid (getColumnValues,numDataRows,numDataColumns
                           ,getColumnLabel,getRowLabel)
import Controller.Menu.File.Export.ImageParameters 
    (Parameters(..),fileTypeList,fileTypeFromInt,intFromFileType)
import Controller.Dialog (saveFileDialog,previewImage,warning)
import View.Dialog.Complex (Layout (..),Widget (..),Modifier (..)
                           ,showDialog,cancelButton)
import Util (justWhen)
import Util.FileType (fromFilePath,wildcard,bitmapType,unknownFileTypeIn)
import Util.Color (toWXColor)
import I18n (__)

data Action = Export | Preview

eventHandler :: Controller ()
eventHandler = getFromConfig imageExportParameters >>= eventHandlerWith

eventHandlerWith :: Parameters -> Controller ()
eventHandlerWith storedParams = do
  result <- onView $ showDialog (__ "Export") dialog storedParams
  justWhen result $ \(params,action) -> 
      case action of
        Export -> 
            do saveFile <- saveFileDialog (__ "Export") wildcard
               setOnConfig $ \c -> c {imageExportParameters = params}
               case saveFile of
                 Nothing -> eventHandlerWith params
                 Just file -> writeImage params file
        Preview -> 
            do showPreview params
               setOnConfig $ \c -> c {imageExportParameters = params}
               eventHandlerWith params

dialog :: Layout Parameters Action
dialog =
    let setFontSize p s = p {fontPointSize = s}
        setFontColor p c = p {fontColor = c}
        setBackgroundColor p c = p {backgroundColor = c}
        setPadding p pa = p {padding = pa}
        setRowLineWidth p w = p {rowLineWidth = w}
        setColLineWidth p w = p {colLineWidth = w}
        setFileType p f = p {fileType = fileTypeFromInt f}
    in
      Modifier Margin $ Column
        [ Grid [[ Label $ __ "Font size (pt)"
                , Widget $ Spinner 1 maxBound fontPointSize setFontSize]
               ,[ Label $ __ "Font color"
                , Widget $ ColorButton fontColor setFontColor]
               ,[ Label $ __ "Background color"
                , Widget $ ColorButton backgroundColor setBackgroundColor]
               ,[ Label $ __ "Padding (px)"
                , Widget $ Spinner 0 maxBound padding setPadding]
               ,[ Label $ __ "Line width (horizontal) (px)"
                , Widget $ Spinner 0 maxBound rowLineWidth setRowLineWidth]
               ,[ Label $ __ "Line width (vertical) (px)"
                , Widget $ Spinner 0 maxBound colLineWidth setColLineWidth]
               ,[ Label $ __ "File type"
                , Widget $ Choice fileTypeList 
                             (intFromFileType . fileType) setFileType]
               ]
        , Modifier Center $ Row 
                       [ Widget $ DefaultButton (__ "&Export") Export
                       , Widget $ Button (__ "&Preview") Preview
                       , cancelButton]
        ]


showPreview :: Parameters -> Controller ()
showPreview params = do
  size <- getImageSize params
  (bitmap,dc) <- liftIO $ getBitmapAndDC params size
  exportTable params dc
  previewImage bitmap

writeImage :: Parameters -> FilePath -> Controller ()
writeImage params filepath = 
    case bmpType of
      Nothing -> warning $ unknownFileTypeIn filepath
      Just bmpType -> 
        do size <- getImageSize params
           (bitmap,dc) <- liftIO $ getBitmapAndDC params size
           exportTable params dc  
           image <- liftIO $ WXC.imageCreateFromBitmap bitmap  
           _ <- liftIO $ WXC.imageSaveFile image filepath bmpType
           return ()
    where
      bmpType = case fileType params of
                  Nothing -> bitmapType <$> fromFilePath filepath
                  Just ext -> Just $ bitmapType ext

getImageSize :: Parameters -> Controller (Int,Int)
getImageSize params = do
  (_,dc) <- liftIO $ getBitmapAndDC params (1,1)
  rows <- onGridView numDataRows
  cols <- onGridView numDataColumns

  colWidth <- sum <$> mapM (getColumnWidth params dc) [0..cols-1]
  rowHeight <- (*) rows <$> getRowHeight params dc

  colLabelHeight <- getRowHeight params dc
  rowLabelWidth <- exportRowLabels params dc

  let colLineWidth' = colLineWidth params * (cols - 1)
      rowLineHeigth = rowLineWidth params * (rows - 1)

  return ( rowLabelWidth + colWidth + colLineWidth'
         , colLabelHeight + rowHeight + rowLineHeigth)

exportTable :: Parameters -> WXC.DC a -> Controller ()
exportTable params dc = do
  cols <- onGridView numDataColumns
  
  fstWidth <- exportRowLabels params dc
  foldM_ (\xOffset col -> do 
            x <- nextXOffset params dc xOffset col
            exportColumn params dc x col
            return x
         ) (padding params + fstWidth + (colLineWidth params)) [0..cols-1]

  withPenWidth dc (rowLineWidth params) $ drawRowLines params dc
  withPenWidth dc (colLineWidth params) $ drawColumnLines params dc fstWidth

exportRowLabels :: Parameters -> WXC.DC a -> Controller Int
exportRowLabels params dc = do
  rows <- onGridView numDataRows
  width <- foldM (\m row -> do
                    label <- onGridView $ getRowLabel row
                    (width,_) <- liftIO $ textExtent dc label
                    y <- textYOffset params dc $ row + 1
                    liftIO $ WXC.dcDrawText dc label $ WXC.pt (padding params) y
                    return $ max m width
                 ) 0 [0..rows-1]
  return $ width + (padding params * 2)

exportColumn :: Parameters -> WXC.DC a -> Int -> Int -> Controller ()
exportColumn params dc xOffset i = do
  values <- onGridView $ getColumnValues i
  rows <- onGridView numDataRows
  exportLabel

  mapM_ (\(row,value) -> do
           y <- textYOffset params dc $ row + 1
           liftIO $ WXC.dcDrawText dc value $ WXC.pt xOffset y
        ) $ zip [0..rows-1] values
    where
      exportLabel = do
        label <- onGridView $ getColumnLabel i 
        liftIO $ WXC.dcDrawText dc label $ WXC.pt xOffset $ padding params
               
drawRowLines :: Parameters -> WXC.DC a -> Controller ()
drawRowLines params dc = do
  dcWidth <- WXC.sizeW <$> (liftIO $ WXC.dcGetSize dc)
  rows <- onGridView numDataRows
  mapM_ (\row -> do 
           y <- lineYOffset params dc row
           liftIO $ WXC.dcDrawLine dc (WXC.pt 0 y) (WXC.pt dcWidth y)
        ) [1..rows]

drawColumnLines :: Parameters -> WXC.DC a -> Int -> Controller ()
drawColumnLines params dc xOffset = do
  dcHeight <- WXC.sizeH <$> (liftIO $ WXC.dcGetSize dc)
  cols <- onGridView numDataColumns
  foldM_ (\x col -> do 
            liftIO $ WXC.dcDrawLine dc (WXC.pt x 0) (WXC.pt x dcHeight)
            nextXOffset params dc x col
         ) (xOffset + (colLineWidth params `div` 2)) [1..cols]

textYOffset,lineYOffset :: Parameters -> WXC.DC a -> Int -> Controller Int
textYOffset params dc row = 
    liftIO $ do
      charHeight <- WXC.dcGetCharHeight dc
      let paddings = ((2 * row) + 1) * (padding params)
          lines = rowLineWidth params * row
          textHeights = row * charHeight
      return $ paddings + textHeights + lines

lineYOffset params dc row = do
  y <- textYOffset params dc row
  return $ y - (padding params) - (rowLineWidth params `div` 2)

nextXOffset :: Parameters -> WXC.DC a -> Int -> Int -> Controller Int
nextXOffset params dc x i = 
    if i == 0 then return x
    else do width <- getColumnWidth params dc $ i - 1
            return $ x + width + (colLineWidth params)

getRowHeight :: Parameters -> WXC.DC a -> Controller Int
getRowHeight params dc = do
  charHeight <- liftIO $ WXC.dcGetCharHeight dc
  return $ charHeight + (padding params * 2)  

getColumnWidth :: Parameters -> WXC.DC a -> Int -> Controller Int
getColumnWidth params dc i = do
  (labelWidth,_) <- onGridView (getColumnLabel i) >>= liftIO . textExtent dc
  values <- onGridView $ getColumnValues i
  maxWidth <- foldM (\m value -> 
                     do (w,_) <- liftIO $ textExtent dc value
                        return $ max m w) labelWidth values
  return $ (padding params * 2) + maxWidth

getWidthPtr,getHeightPtr :: IO (Ptr Int)
getWidthPtr = malloc
getHeightPtr = malloc

textExtent :: WXC.DC a -> String -> IO (Int,Int)
textExtent dc s = do
  font <- WXC.dcGetFont dc
  widthPtr <- getWidthPtr
  heightPtr <- getHeightPtr
  WXC.dcGetTextExtent dc s widthPtr heightPtr nullPtr nullPtr font
  width <- peek widthPtr
  height <- peek heightPtr
  return (width,height)

getBitmapAndDC :: Parameters -> (Int,Int) -> IO (WXC.Bitmap (),WXC.MemoryDC ())
getBitmapAndDC params (width,height) = do
  bitmap <- WXC.bitmapCreateEmpty (WXC.sz width height) (-1)
  dc <- WXC.memoryDCCreateWithBitmap bitmap
  font <- WXC.fontCreate (fontPointSize params) WXC.wxDEFAULT 
          WXC.wxNORMAL WXC.wxNORMAL False "" WXC.wxFONTENCODING_SYSTEM
  bgBrush <- WXC.brushCreateFromColour 
             (toWXColor $ backgroundColor params) WXC.wxSOLID
  WXC.dcSetBackground dc bgBrush
  WXC.dcSetFont dc font
  WXC.dcSetTextForeground dc $ toWXColor $ fontColor params
  WXC.dcClear dc
  return (bitmap,dc)

withPenWidth :: WXC.DC a -> Int -> Controller () -> Controller ()
withPenWidth dc width f = 
    when (width > 0) $ liftIO (setPenWidth dc width) 
             >> f >> liftIO (setPenWidth dc 1)
    where
      setPenWidth dc width = do
        pen <- WXC.dcGetPen dc
        WXC.penSetWidth pen width 
        WXC.dcSetPen dc pen