module SWSlide(
	Slides, getSlides,
	PictTrans, PColor, Number,
	PPoint, Pict,
	Hpos(..), Vpos(..), FrameType(..),
	frame, fill, scale, next, lineWidth,
	t, tt, btt, it, bt, bit, rt, rbt, rit, sy,
	bitmap,
	offset, turn, scalep, setLength, polygon, polyline, oval, ovalFrame,
	superimpose, find,
	colorize, blank, inset,
	----
	vAppend, hAppend,
	para,
	pageParaL, pageParaC, pageParaR,
	pageParaSL, pageParaSC, pageParaSR,
	paraL, paraC, paraR,
	paraSL, paraSR, paraSC,
	slide, slideCenter, slideTitle, slideTitleCenter,
	gapSize, lineSep,
	clientW, clientH,
	screenW, screenH,
	spacing, -- XXX
	fontSize,
	titleLessPage,
	CItem,
	pageItemL, pageItemBulletL, pageSubitemL,
	pageItem, pageItemBullet, pageSubitem,
	ghost, label, launder, launderPrefix,
	line, arrow, rarrow, darrow,
	----
	remNext,
	p -- XXX
	) where

import SWPict

gapSize :: Number
gapSize = fontSize

lineSep :: Number
lineSep = 2

clientW :: Number
clientW = 984

clientH :: Number
clientH = 728

titleH :: Number
titleH = 100  -- XXX

screenW :: Number
screenW = 1024

screenH :: Number
screenH = 768

fontSize :: Number
fontSize = 26 -- 32

titleLessPage :: Pict
titleLessPage = blank clientW (clientH - titleH)

titleArea :: Pict
titleArea = blank clientW titleH

-----------

type SlideT = Slides ()

-- public
slide :: [Pict] -> SlideT
slide ps = mkSlide Nothing Vt ps

-- public
slideCenter :: [Pict] -> SlideT
slideCenter ps = mkSlide Nothing Vc ps

-- public
slideTitle :: (IsPict t) => t -> [Pict] -> SlideT
slideTitle t ps = mkSlide (Just (toPict t)) Vt ps

-- public
slideTitleCenter :: (IsPict t) => t -> [Pict] -> SlideT
slideTitleCenter t ps = mkSlide (Just (toPict t)) Vc ps

mkSlide :: Maybe Pict -> Vpos -> [Pict] -> SlideT
mkSlide Nothing v ps = addSlide $
        superimpose Hc v [vAppend Hc (spacing gapSize : ps),
			   blank clientW clientH]
mkSlide (Just t) v ps = addSlide $
	vAppend Hc [
	    superimpose Hc Vc [mkTitle t, titleArea],
	    superimpose Hc v [vAppend Hc (spacing gapSize : ps),
			       titleLessPage]
	]

mkTitle s = colorize "(0,140,0)" (scale 1.2 s)

next :: Pict
next = Next

-----------

vAppend :: Hpos -> [Pict] -> Pict
vAppend h ps = append (V h) ps

hAppend :: Vpos -> [Pict] -> Pict
hAppend v ps = append (H v) ps

-----------

para :: Hpos -> Bool -> Number -> [Pict] -> Pict
para h fill w ps = mkPagePara h fill w ps

-- public
--pageParaL :: [Pict] -> Pict
--pageParaL ps = mkPagePara Hl False clientW ps

-- public
pageParaL :: (CPagePara t) => t
pageParaL = para' Hl False clientW []

-- public
pageParaC :: (CPagePara t) => t
pageParaC = para' Hc False clientW []

-- public
pageParaR :: (CPagePara t) => t
pageParaR = para' Hr False clientW []

-- public
pageParaSL :: (CPagePara t) => t
pageParaSL = para' Hl True clientW []

-- public
pageParaSC :: (CPagePara t) => t
pageParaSC = para' Hc True clientW []

-- public
pageParaSR :: (CPagePara t) => t
pageParaSR = para' Hr True clientW []

-- public
paraL :: (CPagePara t) => Number -> t
paraL w = para' Hl False w []

-- public
paraC :: (CPagePara t) => Number -> t
paraC w = para' Hc False w []

-- public
paraR :: (CPagePara t) => Number -> t
paraR w = para' Hr False w []

-- public
paraSL :: (CPagePara t) => Number -> t
paraSL w = para' Hl True w []

-- public
paraSR :: (CPagePara t) => Number -> t
paraSR w = para' Hr True w []

-- public
paraSC :: (CPagePara t) => Number -> t
paraSC w = para' Hc True w []

class IsPict a where
    toPict :: a -> Pict

instance IsPict Pict where
    toPict p = p

instance (IsChar c) => IsPict [c] where
    toPict s = t (map toChar s)

class IsChar c where
    toChar :: c -> Char

instance IsChar Char where
    toChar c = c

class CPagePara t where
    para' :: Hpos -> Bool -> Number -> [Pict] -> t

instance CPagePara Pict where
    para' h b s us = mkPagePara h b s (reverse us)

instance (CPagePara t, IsPict a) => CPagePara (a -> t) where
    para' h b s us = \ a -> para' h b s (toPict a : us)

mkPagePara :: Hpos -> Bool -> Number -> [Pict] -> Pict
mkPagePara h b s us = if b then p else superimpose h Vt [p, scale 1 $ blank s 0]
  where p = ppara h s us

-----------

p :: Pict -> Pict
p x = x

-----------

itemL w lPad bul xs = hAppend Vtl [spacing (gapSize / 2), lPad, bul,
			           mkPagePara Hl False (w - gapSize / 2 - bulletWidth) xs]

pageItemL xs = itemL clientW empty bullet xs
pageItemBulletL bul xs = itemL clientW empty bul xs
pageSubitemL xs = itemL clientW (blank (2 * gapSize) 0) oBullet xs

bullet = superimpose Hc Vc [disk (gapSize / 2), blank 0 gapSize]
oBullet = superimpose Hc Vc [circle (gapSize / 2), blank 0 gapSize]

disk d = Frame FOvalFill $ Blank d d
circle d = Frame FOvalFrame $ Blank d d

bulletWidth = gapSize / 2	-- XXX

empty = blank 0 0

class CItem t where
    item' :: Number -> Pict -> Pict -> [Pict] -> t

instance CItem Pict where
    item' w lPad bul us = itemL w lPad bul (reverse us)

instance (CItem t, IsPict a) => CItem (a -> t) where
    item' w lPad bul us = \ a -> item' w lPad bul (toPict a : us)

pageItem :: (CItem t) => t
pageItem = item' clientW empty bullet []

pageItemBullet :: (CItem t) => Pict -> t
pageItemBullet bul = item' clientW empty bul []

pageSubitem :: (CItem t) => t
pageSubitem = item' (clientW - 2 * gapSize) (blank (2 * gapSize) 0) oBullet []


-----------

line (p1, p2) = Line False False p1 p2
arrow (p1, p2) = Line False True p1 p2
rarrow (p1, p2) = Line True False p1 p2
darrow (p1, p2) = Line True True p1 p2

-----------

data Slides a = Slides a [[Pict]]

instance Monad Slides where
    return x = Slides x []
    Slides x ps >>= f =
	let (Slides y ps') = f x
	in  Slides y (ps ++ ps')

addSlide :: Pict -> Slides ()
addSlide p = Slides () [expandSlide p]

getSlides :: Slides a -> [[Pict]]
getSlides (Slides _ pss) = pss

expandSlide :: Pict -> [Pict]
expandSlide p = expand 0
  where expand n =
	    let (n', p') = run n (copy p)
	    in  if n' < 0 then remNext p' : expand (n+1) else [remNext p']

run :: Integer -> M Pict -> (Integer, Pict)
run i (M f) = f i

newtype M a = M { unM :: Integer -> (Integer, a) }

instance Monad M where
    return x = M $ \ i -> (i, x)
    M x >>= f = M $ \ i ->
	let (i', y) = x i
	in  unM (f y) i'

decr :: M ()
decr = M $ \ i -> (i-1, ())

isDone :: M Bool
isDone = M $ \ i -> (i, i < 0)

copy :: Pict -> M Pict
---- Text
copy (Frame b p) = do
    p' <- copyG p
    return (Frame b p')
copy (Scale s p) = do
    p' <- copyG p
    return (Scale s p')
copy (Append hv ps) = do
    ps' <- mapM copyG ps
    return (Append hv ps')
copy (Para sh s ps) = do
    ps' <- mapM copyG ps
    return (Para sh s ps')
---- Spacing
copy (Superimpose h v ps) = do
    ps' <- mapM copyG ps
    return (Superimpose h v ps')
copy (Colorize c p) = do
    p' <- copyG p
    return (Colorize c p')
---- Blank
copy (Many ps) = error "copy"
copy Next = do
    decr
    return Next
copy (Label s p) = do
    p' <- copyG p
    return (Label s p')
copy (LineWidth w p) = do
    p' <- copyG p
    return (LineWidth w p')
copy (Inset l t r b p) = do
    p' <- copyG p
    return (Inset l t r b p')
-- BitMapFile
copy (Line b1 b2 p1 p2) = do
    p1' <- copyP p1
    p2' <- copyP p2
    return $ Line b1 b2 p1' p2'
copy (Polygon b ps) = do
    ps' <- mapM copyP ps
    return $ Polygon b ps'
copy p =
    return p

{-
copyP (Find h v s p) = do
    p' <- copy p
    return $ Find h s v p'
copyP (Offset dx dy p) = do
    p' <- copyP p
    return $ Offset dx dy p'
-}
copyP p = return p		-- XXX

copyG p = do
    done <- isDone
    p' <- copy p
    return $ if done then ghost p' else p'

remNext :: Pict -> Pict
remNext p =
    case remNextM False p of
    Nothing -> error "remNext"
    Just p -> p

remNextM :: Bool -> Pict -> Maybe Pict
---- Text
remNextM g (Frame b p) = do
    p' <- remNextM g p
    return (Frame b p)
remNextM g (Scale s p) = do
    p' <- remNextM g p
    return (Scale s p')
remNextM g (Append hv ps) = do
    ps' <- remNextListM g ps
    return (Append hv ps')
remNextM g (Para sh s ps) = do
    ps' <- remNextListM g ps
    return (Para sh s ps')
---- Spacing
remNextM g (Superimpose h v ps) = do
    ps' <- remNextListM g ps
    return (Superimpose h v ps')
remNextM g (Colorize c p) = do
    p' <- remNextM g p
    return (Colorize c p')
---- Blank
remNextM g (Many ps) = error "remNextM g"
remNextM g Next = Nothing
remNextM g (Ghost p) = do
    p' <- remNextM True p
    return $ if g then p' else Ghost p'
remNextM g (Label s p) = do
    p' <- remNextM g p
    return (Label s p')
remNextM g (LineWidth w p) = do
    p' <- remNextM g p
    return (LineWidth w p')
remNextM g (Polygon b ps) = do
    ps' <- mapM (remNextMP g) ps
    return (Polygon b ps')
remNextM g (Inset l t r b p) = do
    p' <- remNextM g p
    return (Inset l t r b p')
-- BitMapFile
remNextM g p =
    return p

remNextMP g p = return p	-- XXX

remNextListM g [] = return []
remNextListM g (p:ps) =
    case remNextM g p of
    Nothing -> remNextListM g ps
    Just p' -> do
	ps' <- remNextListM g ps
	return (p':ps')

launder = launderPrefix ""

launderPrefix :: String -> Pict -> Pict
---- Text
launderPrefix pre (Frame b p) =
    let p' = launderPrefix pre p
    in  (Frame b p)
launderPrefix pre (Scale s p) =
    let p' = launderPrefix pre p
    in  (Scale s p')
launderPrefix pre (Append hv ps) =
    let ps' = map (launderPrefix pre) ps
    in  (Append hv ps')
launderPrefix pre (Para sh s ps) =
    let ps' = map (launderPrefix pre) ps
    in  (Para sh s ps')
---- Spacing
launderPrefix pre (Superimpose h v ps) =
    let ps' = map (launderPrefix pre) ps
    in  (Superimpose h v ps')
launderPrefix pre (Colorize c p) =
    let p' = launderPrefix pre p
    in  (Colorize c p')
---- Blank
launderPrefix pre (Many ps) = error "launderPrefix pre"
launderPrefix pre Next = Next
launderPrefix pre (Ghost p) =
    let p' = launderPrefix pre p
    in  Ghost p'
launderPrefix pre (Label s p) =
    let p' = launderPrefix pre p
    in  if isPrefix pre s then
	    p'
	else
	    Label s p'
launderPrefix pre (LineWidth w p) =
    let p' = launderPrefix pre p
    in  (LineWidth w p')
launderPrefix pre (Inset l t r b p) =
    let p' = launderPrefix pre p
    in  (Inset l t r b p')
-- Polygon
-- BitMapFile
launderPrefix pre p = p

isPrefix "" s = True
isPrefix (p:ps) (c:cs) | p == c = isPrefix ps cs
isPrefix _ _ = False