module SWWx(wxTop) where

import Graphics.UI.WXCore (getTextExtent, frameCenter, bitmapCreateEmpty, dcBufferWithRef,
	frameDefaultStyle, wxMAXIMIZE_BOX, wxRESIZE_BORDER, wxFULLSCREEN_ALL, wxFULLSCREEN_NOCAPTION,
	wxFULLSCREEN_NOBORDER, wxFULLSCREEN_NOMENUBAR, wxFULLSCREEN_NOTOOLBAR, wxFULLSCREEN_NOSTATUSBAR,
	windowSetFocus, cursorCreateFromStock, wxCURSOR_NONE, windowSetCursor,
	pageSetupDialog, printDialog
	)
import Char
import System

import Graphics.UI.WX hiding (Align)

import SWSlide hiding (frame)
import qualified SWSlide (frame)
import SWDc
import SWWxRender
import SWTasks
import SWCache

version = "SlideWare version 0.1 -- 2005-03-23"

fullStyle = wxFULLSCREEN_ALL
	-- frameDefaultStyle .-. wxMAXIMIZE_BOX .-. wxRESIZE_BORDER .+. wxFULLSCREEN_ALL

frameFixedFull :: [Prop (Frame ())]  -> IO (Frame ())
frameFixedFull props
  = do
	f <- frameEx fullStyle props objectNull
--	windowSetFocus f
	return f

noCursor :: Window a -> IO ()
noCursor win = do
    cursor <- cursorCreateFromStock wxCURSOR_NONE
    windowSetCursor win cursor
    return ()

data Flags = Flags {
	fullScreen :: Bool,
	printSlides :: Bool
	}
dfltFlags = Flags { 
	fullScreen = True,
	printSlides = False
	}

decodeFlags :: Flags -> [String] -> (Flags, [String])
decodeFlags f (('-':flag):args) = decodeFlags (decodeFlag f flag) args
decodeFlags f args = (f, args)

decodeFlag f "b" = f { fullScreen = False }
decodeFlag f "-no-full-screen" = f { fullScreen = False }
decodeFlag f "-print" = f { printSlides = True }
decodeFlag f flag = error ("bad flag " ++ flag)

wxTop pss = start $
    do	putStrLn version
	args <- getArgs
	let (flags, args') = decodeFlags dfltFlags args
	let num =
		case args' of
		[arg] | all isDigit arg -> read arg
		_ -> 1
	    picts = if null pss then [t ""]
		    else if printSlides flags then map last pss
		    else concat pss
	putStrLn (show (length picts) ++ " slides")
	if printSlides flags then do
	    wxPrint picts
	    exitWith ExitSuccess
	 else
	    wxDisplay flags num picts

wxDisplay flags num picts = do
	let startPage = min len num - 1
	    len = length picts
	vfirst <- varCreate True
	vno <- varCreate startPage
	frm <- (if fullScreen flags then frameFixedFull else frameFixed) [ text := "SlideWare" ]
	tq <- mkTaskQueue frm
	ch <- mkCache 100
	let fullRect = rect (pt 0 0) (sz (round screenW) (round screenH))
	    redraw dc rect = do
--		windowSetFocus frm
--		noCursor frm
		first <- varGet vfirst
		when first $ do
--		    windowSetFocus frm
		    when (fullScreen flags) $ frameCenter frm
--		    noCursor frm
		    varSet vfirst False
		no <- varGet vno
		iobm <- makePage dc no
		bm <- iobm
		drawBitmap dc bm (pt 0 0) False []
		preRender dc (no+1)
		preRender dc (no+2)
		preRender dc (no-1)
		preRender dc (no-2)
		preRender dc (no+3)
	    preRender dc no =
		when (0 <= no && no < len) $ do
		    iobm <- makePage dc no
		    later tq (do iobm; return ())
		    return ()
	    makePage :: DC a -> Int -> IO (IO (Bitmap ()))
	    makePage dc no = do
		mbm <- findC no ch
		case mbm of
		 Just bm -> do
		    putStrLn ("page " ++ show no ++ " found")
		    return (return bm)
		 Nothing -> do
		    putStrLn ("page " ++ show no ++ " not found, rendering")
		    iobm <- drawInBitmap dc fullRect $
			\ mdc -> renderPict mdc (picts!!no)
		    let rest :: IO (Bitmap ())
			rest = do
			    bm <- iobm
			    putStrLn ("rendering done")
			    cache no bm ch
			    return bm
		    return rest

	pan <- panel frm [ on paint := redraw ]

	let addNo a = do
		no <- varGet vno
		print ("addNo", a, no)
		let no' = no + a
		when (0 <= no' && no' < len) $
		    varSet vno no'
		repaint pan

	windowSetFocus pan
       	set frm [ layout := minsize (sz (round screenW) (round screenH)) $ widget pan ]
        set pan [on click           := const $ addNo 1
                ,on clickRight      := const $ addNo (-1)
                ,on (charKey 'q')   := close frm
		,on (charKey ' ')   := addNo 1
		,on (charKey '\b')  := addNo (-1)
		,on (charKey 'n')   := addNo 1
		,on (charKey 'p')   := addNo (-1)
                ]

wxPrint picts = do
    let pageFun pgInfo prInfo sz = (1, length picts)
	printFun pgInfo prInfo siz dc no = do
	    let sx = fromIntegral (sizeW siz) / clientW
		sy = fromIntegral (sizeH siz) / clientH
		s = min sx sy
		pict = picts !! (no-1)
--	    putStrLn ("print page " ++ show no ++ " " ++ show siz ++ " scale=" ++ show (s,sx,sy) ++ "\n" ++ show pgInfo ++ "\n" ++ show prInfo ++ "\n")
	    renderPictPrint s dc (SWSlide.frame pict)

    f <- frame [text := "Print slides"]                               
    -- Create a pageSetup dialog with an initial margin
    pageSetup <- pageSetupDialog f 15
    printDialog pageSetup "Print slides" pageFun printFun