module SWWxRender(renderPict, renderPictPrint) where
import IO
import Char(isAlphaNum)

import Data.IORef

import Graphics.UI.WXCore -- (dcWithFontStyle, getFullTextExtent, frameCenter, wxFONTENCODING_DEFAULT, dcDrawRectangle)
import Graphics.UI.WX as WX hiding (Align)

import SWSlide(fontSize, screenW, screenH, clientW, clientH, remNext, gapSize)
import SWPict


data Env = Env {
	eFontSize :: Number,
	eScale :: Number,
	eColor :: Color,
	eLineWidth :: Number
	}

startEnv = Env {
	eFontSize = SWSlide.fontSize,
	eScale = 1.0,
	eColor = black,
	eLineWidth = 1.0
	}
eFontSizeScaled :: Env -> Int
eFontSizeScaled e = round (eFontSize e * eScale e)
eLineWidthScaled :: Env -> Int
eLineWidthScaled e = round (eLineWidth e * eScale e)

renderPict :: DC a -> Pict -> IO ()
renderPict dc pict = do
--    print ("input",pict)
    bpict <- addBBox dc startEnv pict
    let bpict' = updBBox (offst ((screenW - clientW) / 2) ((screenH - clientH) / 2)) bpict
--    print ("render",bpict')
    renderAll False dc startEnv (0, 0) bpict'

renderPictPrint :: Number -> DC a -> Pict -> IO ()
renderPictPrint s dc pict = do
    let e = startEnv { eScale = s }
    bpict <- addBBox dc e pict
    renderAll True dc e (0, 0) bpict

dpt fx fy = pt (round fx) (round fy)

renderAll :: Bool -> DC a -> Env -> (Number, Number) -> BPict -> IO ()
renderAll printing dc e xy@(x, y) (Box bb pict) = do
    let xy'@(x', y') = (x + bbLeft bb, y + bbTop bb)
--    putStrLn ("render " ++ show pict); hFlush stdout
    case pict of
	Many bps -> mapM_ (renderAll printing dc e xy') bps
	Text f s -> do
		let p = dpt x' y'
--		print (s, p, (mkFontStyle e (faceToFSW f)), eColor e)
		dcWithFontStyle dc (mkFontStyle e (faceToFSW f)) $
		 drawText dc s p [ textColor := eColor e]
		return ()
	Frame b p -> do
		let rect = Rect { rectLeft = round x',
				  rectTop = round y',
				  rectWidth = round (bbWidth bb),
				  rectHeight = round (bbHeight bb) }
		case b of
		 FRectFill ->
		    drawRect dc rect [color := eColor e, bgcolor := eColor e]
		 FRectFrame -> do
		    renderAll printing dc e xy (Box bb p)
		    frameRect dc rect [color := eColor e, penWidth := eLineWidthScaled e]
		 FOvalFill ->
		    dcWith dc [color := eColor e, bgcolor := eColor e] (dcDrawEllipse dc rect)
		 FOvalFrame ->
		    dcWith dc [color := eColor e{-, bgcolor := eColor e-}] (dcDrawEllipticArc dc rect 0 360)
	Inset l t r b p ->
		renderAll printing dc e xy' (Box (adjustInset l t r b bb) p)
	Colorize c p -> do
		renderAll printing dc (e { eColor = colorOf c }) xy (Box bb p)
	Label s p -> do
		renderAll printing dc e xy (Box bb p)
	Scale s p -> do
		renderAll printing dc (e { eScale = eScale e * s }) xy (Box bb p)
	Ghost _ -> return ()
	LineWidth w p -> do
--		print ("LineWidth", w, (Box bb p))
		renderAll printing dc (e { eLineWidth = w }) xy (Box bb p)
	DLine a1 a2 (RPoint x1 y1) (RPoint x2 y2) ->
		drawArrow dc a1 a2 (x'+x1) (y'+y1) (x'+x2) (y'+y2) (eColor e) (eLineWidthScaled e)
	BitMapFile file -> do
		bm <- bitmapCreateFromFile file
		drawBitmap dc bm (dpt x' y') False []
		bitmapDelete bm
	DPolygon b ps -> do
		(if b then WX.polygon else WX.polyline) dc [ dpt (x'+x) (y'+y) | RPoint x y <- ps ]
			[color := eColor e, penWidth := eLineWidthScaled e, bgcolor := eColor e]
	_ -> error ("renderPict: " ++ show pict)

drawArrow dc a1 a2 x1 y1 x2 y2 c w = do
    let delta = pi / 10
	len = gapSize * 2 / 3
	ahead x1 y1 x2 y2 = do
	    let dx = x2 - x1
		dy = y2 - y1
		a = atan2 dy dx
		aline t x y = line (x - len * cos t) (y - len * sin t) x y
	    aline (a + delta) x2 y2
	    aline (a - delta) x2 y2
	line x1 y1 x2 y2 = do
		WX.line dc (dpt x1 y1) (dpt x2 y2) [color := c, penWidth := w]
    when a2 $ ahead x1 y1 x2 y2
    when a1 $ ahead x2 y2 x1 y1
    line x1 y1 x2 y2

addBBox :: DC a -> Env -> Pict -> IO BPict
addBBox dc e Next = error "addBBox Next"
addBBox dc e p@(Text f s) = dcWithFontStyle dc (mkFontStyle e (faceToFSW f)) $
    do
	let s' = if null s then " " else s	-- getFullTextExtent totally broken on empty strings
	(sz, descent, leading) <- getFullTextExtent dc s'
	let w = if null s then 0 else fromIntegral (sizeW sz)
	    h = fromIntegral (sizeH sz)
	    l = h - fromIntegral descent
--	print ("addBBox descent", descent, descent')
	return $
	    Box (BBox {	bbTop = 0,
			bbLeft = 0,
			bbWidth = w,
			bbHeight = h,
			bbTopLine = l,
			bbBottomLine = l
		     }) p
addBBox dc e (Frame b p) = do
    Box bb p' <- addBBox dc e p
    return (Box bb (Frame b p'))
addBBox dc e (Inset l t r b p) = do
    Box bb p' <- addBBox dc e p
    let s = eScale e
    return (Box (adjustInset (-l * s) (-t * s) (-r * s) (-b * s) bb) p')
addBBox dc e (Append hv (Spacing sp : ps)) = appPs dc e hv (sp * eScale e) ps
addBBox dc e (Append hv bps) = appPs dc e hv 0 bps
addBBox dc e (Para h w ps) = do
    let ps' = normTexts ps
--    print ("para1", ps)
--    print ("para2", ps')
    bps <- mapM (addBBox dc e) ps'
    sp <- addBBox dc e (Text F_N " ")
    return (makeLines [sp] h (w * eScale e) bps [])
addBBox dc e (Spacing _) = error "addBBox Spacing"
addBBox dc e (Superimpose _ _ []) = return (Box (zBBox 0 0) (Many []))
addBBox dc e (Superimpose h v ps) = do
    bps <- mapM (addBBox dc e) ps
    let	mw = maximum (map (bbWidth . bbox) bps)
        (mh, ul) =
	    case v of
	    Vbl ->
		let mbl = maximum (map (bbBottomLine . bbox) bps)
		    mubl = maximum (map (\ bp -> bbHeight (bbox bp) - bbBottomLine (bbox bp)) bps)
		in  (mbl + mubl, mbl)
	    Vtl -> 
		let mtl = maximum (map (bbTopLine . bbox) bps)
		    mutl = maximum (map (\ bp -> bbHeight (bbox bp) - bbTopLine (bbox bp)) bps)
		in  (mtl + mutl, mtl)
	    _ -> (maximum (map (bbHeight . bbox) bps), 0)
	bb = lBBox mw mh (maximum (map (bbTopLine . bbox) bps)) (maximum (map (bbBottomLine . bbox) bps))
	bps' = map move bps
	move bp = updBBox (offst (moveH bb) (moveV bb)) bp where bb = bbox bp
	moveH bb =
	    case h of
	    Hl -> 0
	    Hc -> (mw - bbWidth bb) / 2
	    Hr -> mw - bbWidth bb
	moveV bb =
	    case v of
	    Vt -> 0
	    Vc -> (mh - bbHeight bb) / 2
	    Vb -> mh - bbHeight bb
	    Vbl -> ul - bbBottomLine bb
	    Vtl -> ul - bbTopLine bb
    return (Box bb (many bps'))
addBBox dc e (Blank w h) = do
    let s = eScale e
    return (Box (zBBox (s*w) (s*h)) (Many []))
addBBox dc e (Scale s p) = do
    Box bb p' <- addBBox dc (e { eScale = eScale e * s }) p
    return (Box bb (Scale s p'))
addBBox dc e (Colorize c p) = do
    Box bb p' <- addBBox dc e p
    return (Box bb (Colorize c p'))
addBBox dc e (LineWidth w p) = do
    Box bb p' <- addBBox dc e p
    return (Box bb (LineWidth w p'))
addBBox dc e (Ghost p) = do
    Box bb p' <- addBBox dc e p
    return (Box bb (Ghost p'))
addBBox dc e (Label s p) = do
    Box bb p' <- addBBox dc e p
    return (Box bb (Label s p'))
addBBox dc e (Line a1 a2 p1 p2) = do
    xy1@(RPoint x1 y1) <- computePoint dc e p1
    xy2@(RPoint x2 y2) <- computePoint dc e p2
    let bb = zBBox (max x1 x2) (max y1 y2)
    return (Box bb (DLine a1 a2 xy1 xy2))
addBBox dc e (Polygon b ps) = do
    ps' <- mapM (computePoint dc e) ps
    let bb = zBBox (maximum [ x | RPoint x _ <- ps' ]) (maximum [ y | RPoint _ y <- ps' ])
    return (Box bb (DPolygon b ps'))
addBBox dc e p@(BitMapFile file) = do
    bm <- bitmapCreateFromFile file
    w <- bitmapGetWidth bm
    h <- bitmapGetHeight bm
    bitmapDelete bm
    return (Box (zBBox (fromIntegral w) (fromIntegral h)) p)
  `catch`
    \ _ -> addBBox dc e (Text F_N ("Bitmap not found:" ++ file))
addBBox dc e p = error ("addBBox " ++ show p)

computePoint :: DC a -> Env -> PPoint -> IO RPoint
computePoint dc e (Find h v lbl p) = do
    bp <- addBBox dc e (remNext p)
    case findLblB 0 0 lbl bp of
     Nothing -> do
	putStrLn ("label " ++ lbl ++ " not found")
	return (RPoint 0 0)
     Just (Box bb _) ->
	let x =
		case h of
		Hl -> bbLeft bb
		Hc -> bbLeft bb + bbWidth bb / 2
		Hr -> bbLeft bb + bbWidth bb
	    y =
		case v of
		Vt -> bbTop bb
		Vc -> bbTop bb + bbHeight bb / 2
		Vb -> bbTop bb + bbHeight bb
		Vtl -> bbTop bb + bbTopLine bb
		Vbl -> bbTop bb + bbBottomLine bb
	in  return (RPoint x y)
computePoint dc e (Offset dx dy p) = do
    RPoint x y <- computePoint dc e p
    return $ RPoint (x+dx) (y+dy)
computePoint dc e (Turn p1 a p2) = do
    RPoint x1 y1 <- computePoint dc e p1
    RPoint x2 y2 <- computePoint dc e p2
    let dx = x2 - x1
	dy = y2 - y1
	t = atan2 dy dx + a
	l = sqrt (dx*dx + dy*dy)
    return $ RPoint (x1 + l * cos t) (y1 + l * sin t)
computePoint dc e (ScaleP p1 s p2) = do
    RPoint x1 y1 <- computePoint dc e p1
    RPoint x2 y2 <- computePoint dc e p2
    let dx = x2 - x1
	dy = y2 - y1
	t = atan2 dy dx
	l = s * sqrt (dx*dx + dy*dy)
    return $ RPoint (x1 + l * cos t) (y1 + l * sin t)
computePoint dc e (SetLength p1 s p2) = do
    RPoint x1 y1 <- computePoint dc e p1
    RPoint x2 y2 <- computePoint dc e p2
    let dx = x2 - x1
	dy = y2 - y1
	t = atan2 dy dx
	l = s
    return $ RPoint (x1 + l * cos t) (y1 + l * sin t)

findLblB :: Number -> Number -> String -> BPict -> Maybe BPict
findLblB x y lbl (Box bb p) = findLbl (offst x y bb) lbl p

findLblB' bb lbl bp = findLblB (bbLeft bb) (bbTop bb) lbl bp

findLbl bb lbl (Many bps) = head ([ j | j@(Just _) <- map (findLblB' bb lbl) bps ] ++ [Nothing])
findLbl bb lbl (Frame _ p) = findLbl bb lbl p
findLbl bb lbl (Inset _ _ _ _ p) = findLbl bb lbl p
findLbl bb lbl (Scale _ p) = findLbl bb lbl p
findLbl bb lbl (Colorize _ p) = findLbl bb lbl p
findLbl bb lbl (LineWidth _ p) = findLbl bb lbl p
findLbl bb lbl (Label s p) =
   if lbl == s then
	Just (Box bb p)
   else
	findLbl bb lbl p
findLbl bb lbl (Ghost p) = findLbl bb lbl p
findLbl bb lbl _ = Nothing

zBBox w h = BBox { bbTop = 0, bbLeft = 0, bbWidth = w, bbHeight = h,
		   bbTopLine = h, bbBottomLine = h }

lBBox w h tl bl = BBox { bbTop = 0, bbLeft = 0, bbWidth = w, bbHeight = h,
		         bbTopLine = tl, bbBottomLine = bl }

appPs dc e hv s ps = do
    bps <- mapM (addBBox dc e) ps
    return (appBPs hv s bps)

appBPs hv s [] = Box (zBBox 0 0) (Many [])
appBPs hv s bps =
    let n = length bps
	mw = maximum (map (bbWidth . bbox) bps)
        (mh, ul) =
	    case hv of
	    H Vbl ->
		let mbl = maximum (map (bbBottomLine . bbox) bps)
		    mubl = maximum (map (\ bp -> bbHeight (bbox bp) - bbBottomLine (bbox bp)) bps)
		in  (mbl + mubl, mbl)
	    H Vtl -> 
		let mtl = maximum (map (bbTopLine . bbox) bps)
		    mutl = maximum (map (\ bp -> bbHeight (bbox bp) - bbTopLine (bbox bp)) bps)
		in  (mtl + mutl, mtl)
	    _ -> (maximum (map (bbHeight . bbox) bps), 0)
	sw = sum (map (bbWidth . bbox) bps) + (fromIntegral n - 1) * s
	sh = sum (map (bbHeight . bbox) bps) + (fromIntegral n - 1) * s
	(w, h, tl, bl) = if isV hv then
			     let lbb = bbox (last bps')
			     in  (mw, sh, bbTopLine (bbox (head bps)), bbTop lbb + bbBottomLine lbb)
			 else
			     (sw, mh, ul, ul)
	bb = lBBox w h tl bl
	bps' = if isV hv then vmove 0 bps else hmove 0 bps
	isV (V _) = True
	isV (H _) = False
	hmove dx xs = if null xs then [] else let bp=head xs; bps=tail xs in
	    let bb = bbox bp
	    in  updBBox (offst dx (halign bb)) bp : hmove (dx + bbWidth bb + s) bps
--	vmove dy [] = []
--	vmode dy (bp:bps) =
	vmove dy xs = if null xs then [] else let bp=head xs; bps=tail xs in
	    let bb = bbox bp
	    in  updBBox (offst (valign bb) dy) bp : vmove (dy + bbHeight bb + s) bps
	valign bb =
	    case hv of
	    V Hl -> 0
	    V Hc -> (mw - bbWidth bb) / 2
	    V Hr ->  mw - bbWidth bb
	halign bb =
	    case hv of
	    H Vt -> 0
	    H Vc -> (mh - bbHeight bb) / 2
	    H Vb ->  mh - bbHeight bb
	    H Vbl -> ul - bbBottomLine bb
	    H Vtl -> ul - bbTopLine bb
	    a -> error ("halign " ++ show a)
    in  Box bb (many bps')

bbox (Box b _) = b

unBox (Box _ p) = p

updBBox f (Box bb p) = Box (f bb) p

{-
many [bp] = bp
many ps = concatMap unMany ps
  where unMany (Many bps) = bps
	unMany bp = [bp]
many bps = Many (filter (not . empty) bps)
  where empty (Box _ (Many [])) = True
	empty _ = False
-}
many bps = Many bps

normTexts ps = concatMap normOne (joinSameTexts ps)
  where normOne (Text f s) = map (Text f) (words s)
        normOne p = [p] -- XXX go deeper
	needsSpaceS (c:_) = not (isPunct c)
	needsSpaceS _ = False
	joinSameTexts (Text f1 s1 : Text f2 s2 : ts) | f1 == f2 = joinSameTexts (Text f1 (s1++sp++s2) : ts)
	    where sp = if needsSpaceS s2 then " " else ""
	joinSameTexts (t : ts) = t : joinSameTexts ts
	joinSameTexts [] = []

isPunct c = c `elem` "',. :;-?!)"

makeLines sp h w [] [] = Box (zBBox 0 0) (Many [])
makeLines sp h w [] bps = appBPs (V h) 0 (reverse bps)
makeLines sp h w ps bps =
    let (bp, ps') = makeLine sp w ps
    in  makeLines sp h w ps' (bp:bps)

makeLine sp w ps = make (swidths wps) wps ps'
  where (wps, ps') = take1AndPunct ps
	make :: Number -> [BPict] -> [BPict] -> (BPict, [BPict])
	make cw ups ps@(p:_) | cw' < w = make cw' (wps++sp++ups) ps'
			where cw' = cw + swidths (wps++sp)
			      (wps, ps') = take1AndPunct ps
	make cw ups ps = (appBPs (H Vbl) 0 (reverse ups), ps)
	take1AndPunct (p:p'@(Box _ (Text _ (c:_))):ps) | isPunct c = ([p',p], ps)
	take1AndPunct (p:ps) = ([p], ps)
	swidths ps = sum (map (bbWidth . bbox) ps)

--offst :: BPict -> BPict
--- XXX update bbDescent
offst dx dy bb = bb { bbLeft = bbLeft bb + dx, bbTop = bbTop bb + dy }
grow dx dy bb = bb { bbWidth = bbWidth bb + dx, bbHeight = bbHeight bb + dy }

adjustInset l t r b bb = undefined

mkFontStyle :: Env -> (FontFamily, FontShape, FontWeight, String) -> FontStyle
mkFontStyle env (family, shape, weight, sFamily) = FontStyle {
	_fontSize = eFontSizeScaled env,
	_fontFamily = family,
	_fontShape = shape,
	_fontWeight = weight,
	_fontUnderline = False,
	_fontFace = sFamily,
	_fontEncoding = wxFONTENCODING_DEFAULT
	}

--faceToFSW _ = (FontSwiss, ShapeNormal, WeightNormal, "")

faceToFSW F_N = (FontSwiss, ShapeNormal, WeightNormal, "")
faceToFSW F_B = (FontSwiss, ShapeNormal, WeightBold, "")
faceToFSW F_I = (FontSwiss, ShapeItalic, WeightNormal, "")
faceToFSW F_BI = (FontSwiss, ShapeItalic, WeightBold, "")
--faceToFSW F_TT = (FontModern, ShapeNormal, WeightNormal, "")
--faceToFSW F_BTT = (FontModern, ShapeNormal, WeightBold, "")
faceToFSW F_TT = (FontModern, ShapeNormal, WeightNormal, tt_font)
faceToFSW F_BTT = (FontModern, ShapeNormal, WeightBold, tt_font)
faceToFSW F_RT = (FontRoman, ShapeNormal, WeightNormal, "")
faceToFSW F_RBT = (FontRoman, ShapeNormal, WeightBold, "")
faceToFSW F_RIT = (FontRoman, ShapeItalic, WeightNormal, "")
faceToFSW F_SY = (FontSwiss, ShapeNormal, WeightNormal, "symbol")

tt_font = "Courier"  --"lucidatypewriter"

colorOf "black" = black
colorOf "darkgrey" = darkgrey
colorOf "dimgrey" = dimgrey
colorOf "mediumgrey" = mediumgrey
colorOf "grey" = grey
colorOf "lightgrey" = lightgrey
colorOf "white" = white
colorOf "red" = red
colorOf "green" = green
colorOf "blue" = blue
colorOf "cyan" = cyan
colorOf "magenta" = magenta
colorOf "yellow" = yellow
colorOf s =
    case reads s of
    [((r,g,b), "")] -> rgb r g b
    _ -> black

frameRect dc r props = WX.polyline dc ps props
  where ps = [pt l       t,
	      pt (l + w) t,
	      pt (l + w) (t + h),
	      pt l       (t + h),
	      pt l       t
	     ]
	Rect { rectLeft = l, rectTop = t, rectWidth = w, rectHeight = h } = r