~ubuntu-branches/ubuntu/trusty/carettah/trusty

module Main where
import System.Environment
import System.Mem
import System.IO
import System.Console.GetOpt
import System.Exit
import Data.Time
import Data.Maybe
import Data.Version (showVersion)
import System.FilePath ((</>),(<.>))
import System.Directory (copyFile)
import Control.Monad
import Control.Monad.Reader
import qualified Graphics.UI.Gtk as G
import qualified Graphics.Rendering.Cairo as C
import qualified Text.Pandoc as P
import System.CWiid
--
import Config
import Render
import WrapPaths

markdown :: String -> P.Pandoc
markdown = P.readMarkdown P.def{ P.readerStandalone = True }

splitBlocks :: P.Pandoc -> [[P.Block]]
splitBlocks (P.Pandoc _ blocks) = go blocks
  where go (P.Header 1 _ h:xs) =
          let (b1, b2) = break check xs
          in (P.Header 1 P.nullAttr h:b1):go b2
        go _ = []
        check (P.Header 1 _ _) = True
        check _ = False

backgroundTop :: [P.Block] -> [P.Block]
backgroundTop blocks = filter go blocks ++ filter (not . go) blocks
  where go (P.Para [P.Image [P.Str "background"] _]) = True
        go _ = False

inlinesToString :: [P.Inline] -> String
inlinesToString = foldr go ""
  where go (P.Str s) a = s ++ a
        go P.Space a = ' ' : a
        go x _ = show x

-- 二枚目以降のスライドをRender
blockToSlide :: [P.Block] -> [Double -> C.Render Double]
blockToSlide = map go
  where
    ag = alphaBackG gCfg
    tty = textTitleY gCfg
    tts = textTitleSize gCfg
    tcx = textContextX gCfg
    tcs = textContextSize gCfg
    tcbs = textCodeBlockSize gCfg
    tcbo = textCodeBlockOfs gCfg
    go :: P.Block -> Double -> C.Render Double
    go (P.Para [P.Image [P.Str "background"] (pngfile, _)]) =
      \y -> renderPngFit ag pngfile >> return y
    go (P.Para [P.Image [P.Str "inline"] (pngfile, _)]) =
      \y -> renderPngInline (CCenter, CPosition y) (CFit, CFit) 
            1 pngfile
    go (P.Header 1 _ strs) =
      \y -> renderLayoutM (CCenter, CPosition tty) tts (inlinesToString strs) >> return y
    go (P.BulletList plains) = \y -> yposSequence y $ map go' plains
      where
        go' [P.Plain strs] =
          \ypos -> renderLayoutM (CPosition tcx, CPosition ypos) tcs ("☆ " ++ inlinesToString strs)
        go' x = error $ show x -- 一部のみをサポート
    go (P.CodeBlock attr ss) = \y ->
      renderLayoutG attr (CPosition $ tcx + tcbo, CPosition y) tcbs ss
    go (P.Para strs) =
      \y -> renderLayoutM (CPosition tcx, CPosition y) tcs (inlinesToString strs)
    go x = error $ show x -- 一部のみをサポート

-- スライド表紙をRender
coverSlide :: [P.Block] -> [Double -> C.Render Double]
coverSlide = map go
  where
    ag = alphaBackG gCfg
    ttcy = textTitleCoverY gCfg
    ttcs = textTitleCoverSize gCfg
    tccy = textContextCoverY gCfg
    tccs = textContextCoverSize gCfg
    go :: P.Block -> Double -> C.Render Double
    go (P.Para [P.Image [P.Str "background"] (pngfile, _)]) =
      \y -> renderPngFit ag pngfile >> return y
    go (P.Header 1 _ strs) =
      \y -> renderLayoutM (CCenter, CPosition ttcy) ttcs (inlinesToString strs) >> return y
    go (P.Para strs) =
      \y -> renderLayoutM (CCenter, CPosition tccy) tccs (inlinesToString strs) >> return y
    go x = error $ show x -- 一部のみをサポート

updateCanvas :: G.DrawingArea -> IO ()
updateCanvas canvas = do
  n <- queryCarettahState page
  s <- queryCarettahState slides
  win <- G.widgetGetDrawWindow canvas
  (width, height) <- G.widgetGetSize canvas
  G.renderWithDrawable win $
    renderSlide s n width height
  updateRenderdTime
  performGC

options :: [OptDescr (Options -> Options)]
options =
  [ Option "w"     ["wiimote"]
    (NoArg (\ opts -> opts { optWiimote = True }))
    "use wiimote"
  , Option "o"     ["output-filename"]
    (OptArg ((\ f opts -> opts { optPdfOutput = Just f }) . fromMaybe "output.pdf")
     "FILE")
    "output PDF_FILE"
  , Option "t"     ["time"]
    (OptArg ((\ f opts -> opts { optTime = Just $ read f }) . fromMaybe "5")
     "TIME(minute)")
    "set presentation time with minutes"
  , Option "i"     ["info"]
    (NoArg (\ opts -> opts { optSlideInfo = True }))
    "show slide infomation"
  , Option "n"     ["new-slide"]
    (NoArg (\ opts -> opts { optNewTemp = True }))
    "create a new slide file and open it"
  ]

carettahOpts :: [String] -> IO (Options, [String])
carettahOpts argv =
  let header = "\ncarettah version " ++ showVersion wrapVersion ++ "\n" ++
               "Usage: carettah [OPTION...] FILE"
  in case getOpt Permute options argv of
    (_,[],[] ) -> hPutStrLn stderr (usageInfo header options) >> exitSuccess
    (o,n,[]  ) -> return (foldl (flip id) defaultOptions o, n)
    (_,_,errs) -> hPutStrLn stderr (concat errs ++ usageInfo header options) >> exitFailure

outputPDF :: String -> IO ()
outputPDF pdf = do
  s <- queryCarettahState slides
  let iw = canvasW gCfg
      ih = canvasH gCfg
      dw = toDouble iw
      dh = toDouble ih
  C.withPDFSurface pdf dw dh $ flip C.renderWith . sequence_ $
    fmap (\a -> renderSlide s a iw ih >> C.showPage) [0..(length s - 1)]

startPresentation :: Bool -> Double -> IO ()
startPresentation wiiOn presenTime = do
  -- setup
  setWiiHandle wiiOn
  updateSpeechMinutes $ const presenTime
  -- start GUI
  void G.initGUI
  window <- G.windowNew
  canvas <- G.drawingAreaNew
  G.widgetSetSizeRequest window (canvasW gCfg) (canvasH gCfg)
  -- key event
  void $ window `G.on` G.keyPressEvent $ G.tryEvent $ do
    keyName <- G.eventKeyName
    liftIO $
      case keyName of
        "f" -> G.windowFullscreen window
        "F" -> G.windowUnfullscreen window
        "q" -> G.widgetDestroy window
        "j" -> nextPage >> G.widgetQueueDraw canvas
        "k" -> prevPage >> G.widgetQueueDraw canvas
        "g" -> topPage >> G.widgetQueueDraw canvas
        "G" -> endPage >> G.widgetQueueDraw canvas
        "r" -> do md <- queryCarettahState markdownFname
                  loadMarkdown md
                  curPage >> G.widgetQueueDraw canvas
        _   -> return ()
  void $ G.onDestroy window G.mainQuit
  void $ G.onExpose canvas $ const (updateCanvas canvas >> return True)
  void $ G.timeoutAdd (do rtime <- queryCarettahState renderdTime
                          ntime <- getCurrentTime
                          let dtime :: Double
                              dtime = (fromRational . toRational) $
                                      diffUTCTime ntime rtime
                          if dtime > 5 then G.widgetQueueDraw canvas >>
                                            return True else do
                            bf <- queryCarettahState wiiBtnFlag
                            af <- updateWiiBtnFlag
                            let bs = af `diffCwiidBtnFlag` bf
                                go b | b == cwiidBtnA = nextPage >> G.widgetQueueDraw canvas
                                     | b == cwiidBtnB = prevPage >> G.widgetQueueDraw canvas
                                     | b == cwiidBtnUp = topPage >> G.widgetQueueDraw canvas
                                     | b == cwiidBtnDown = endPage >> G.widgetQueueDraw canvas
                                     | b == cwiidBtnPlus = G.windowFullscreen window
                                     | b == cwiidBtnMinus = G.windowUnfullscreen window
                                     | otherwise = return ()
                            go bs
                            return True) 50
  G.set window [G.containerChild G.:= canvas]
  G.widgetShowAll window
  updateStartTime
  updateRenderdTime
  G.mainGUI

loadMarkdown :: String -> IO ()
loadMarkdown fn = do
  s <- readFile fn
  let z = zip (coverSlide:repeat blockToSlide) (splitBlocks $ markdown s)
  updateSlides $ const $ map (\p -> fst p . backgroundTop $ snd p) z

main :: IO ()
main = do
  -- init
  updateStartTime
  updateRenderdTime
  -- getopts
  (opts, filen:_) <- carettahOpts =<< getArgs
  -- create file if -n option
  case opts of
    (Options {optNewTemp = True}) ->
      do tf <- wrapGetDataFileName $ "data" </> "turtle" <.> "png"
         copyFile tf ("turtle" <.> "png")
         df <- wrapGetDataFileName $ "data" </> "debian" <.> "png"
         copyFile df ("debian" <.> "png")
         writeFile filen ns
           where ns = "\
\# Presentation Title\n\
\![background](debian.png)\n\n\
\Your Name\n\n\
\# Slide Title\n\
\* item1\n\
\* item2\n\
\* item3\n\n\
\![inline](turtle.png)\n"
    _ -> return ()
  -- setup slide
  updateMarkdownFname $ const filen
  loadMarkdown filen
  -- start
  case opts of
    (Options {optSlideInfo = True}) ->
      do s <- queryCarettahState slides
         putStrLn $ "Page: " ++ show (length s)
    (Options {optPdfOutput = Just pdf}) ->
      outputPDF pdf
    (Options {optWiimote = wiiOn, optTime = Just presenTime}) ->
      startPresentation wiiOn presenTime
    _ -> error "NOTREACHED"