Cairo.hs

module Lseed.Renderer.Cairo where

import Graphics.UI.Gtk hiding (fill)
import Graphics.Rendering.Cairo
import Control.Monad
import Control.Concurrent
import Data.IORef
import Data.Maybe
import Lseed.Data
import Lseed.Data.Functions
import Lseed.Constants
import Lseed.Geometry
import Lseed.StipeInfo
import Text.Printf
import System.Time
import qualified Data.Map as M
import Data.List
import Data.Ord
import System.Time

colors :: [ (Double, Double, Double) ]
colors = cycle $ [ (r,g,b) | r <- [0.0,0.4], b <- [0.0, 0.4], g <- [1.0,0.6,0.8]]

pngDailyObserver :: FilePath -> Observer
pngDailyObserver filename = nullObserver {
	obGrowingState = \scGen -> do
		ScreenContent garden angle timeInfo mbMessage <-
			scGen `fmap` getClockTime 
		let (w,h) = (800,600)
		let h' = fromIntegral h / fromIntegral w

		let (xLeft,xRight,xHeight) = gardenOffset garden
		    scaleY = h'*(1-groundLevel)/xHeight
		    scaleX = 1/(max 1 xRight - min 0 xLeft)
		    scaleXY = minimum [1, scaleX, scaleY]
		    shiftX = min 0 xLeft 

		withImageSurface FormatRGB24 w h $ \sur -> do
			renderWith sur $ do
				-- Set up coordinates
				translate 0 (fromIntegral h)
				scale 1 (-1)
				scale (fromIntegral w) (fromIntegral w)
				translate 0 groundLevel
				setLineWidth stipeWidth

				preserve $ do
					scale scaleXY scaleXY
					translate (-shiftX) 0
					render angle garden

				maybe (return ()) (renderMessage angle h') mbMessage
				renderTimeInfo timeInfo
				renderStats h' garden
			surfaceWriteToPNG sur filename
	}

pngObserver :: IO Observer
pngObserver = return $ nullObserver {
	obFinished = \garden -> do
		let (w,h) = (400,400)
		withImageSurface FormatRGB24 w h $ \sur -> do
			renderWith sur $ do
				-- Set up coordinates
				translate 0 (fromIntegral h)
				scale 1 (-1)
				scale (fromIntegral w) (fromIntegral w)
				translate (-0.5) 0
				scale 2 2
				translate 0 groundLevel
				setLineWidth stipeWidth

				render (pi/3) (annotateGarden (pi/3) garden)
			surfaceWriteToPNG sur "/dev/fd/1"
	}

cairoObserver :: IO Observer
cairoObserver = do
	initGUI

	-- global renderer state
	currentGardenRef <- newIORef (const (ScreenContent [] (pi/2) "No time yet" Nothing))

	-- widgets
	canvas <- drawingAreaNew

	window <- windowNew
	set window [windowDefaultWidth := 800, windowDefaultHeight := 600,
	      containerChild := canvas, containerBorderWidth := 0]
	widgetShowAll window

	-- Make gtk and haskell threading compatible
	timeoutAdd (yield >> return True) 50
	
	-- a thread for our GUI
	forkIO $ mainGUI

	-- The actual drawing function
	onExpose canvas$ \e -> do scGen <- readIORef currentGardenRef
				  ScreenContent garden angle timeInfo mbMessage <-
						scGen `fmap` getClockTime 
				  s <- clockTimeToDouble `fmap` getClockTime
				  dwin <- widgetGetDrawWindow canvas
				  (w,h) <- drawableGetSize dwin
				  let h' = fromIntegral h / fromIntegral w

				  let (xLeft,xRight,xHeight) = gardenOffset garden
				      scaleY = h'*(1-groundLevel)/xHeight
				      scaleX = 1/(max 1 xRight - min 0 xLeft)
				      scaleXY = minimum [1, scaleX, scaleY]
				      shiftX = min 0 xLeft 

				  renderWithDrawable dwin $ do
					-- Set up coordinates
					translate 0 (fromIntegral h)
					scale 1 (-1)
					scale (fromIntegral w) (fromIntegral w)
					translate 0 groundLevel

					preserve $ do
						scale scaleXY scaleXY
						translate (-shiftX) 0
						render angle (windy s garden)
					maybe (return ()) (renderMessage angle h') mbMessage
					renderTimeInfo timeInfo
					renderStats h' garden
		                  return True

	timeoutAdd (widgetQueueDraw canvas >> return True) 20

	return $ nullObserver
		{ obGrowingState = \scGen -> do
			writeIORef currentGardenRef scGen
			widgetQueueDraw canvas
		, obShutdown = mainQuit
		}

render :: Double -> AnnotatedGarden -> Render ()
render angle garden = do
	-- TODO the following can be optimized to run allKindsOfStuffWithAngle only once.
	-- by running it here. This needs modification to lightenGarden and mapLine
	renderSky angle
	--mapM_ renderLightedPoly (lightPolygons angle (gardenToLines garden))

	--mapM_ renderLightedLine (lightenLines angle (gardenToLines garden))
	--mapM_ renderLine (gardenToLines garden)
	--mapM_ renderLightedPlanted garden

	mapM_ renderPlanted garden

	renderGround

	--renderInfo garden

renderPlanted :: AnnotatedPlanted -> Render ()
renderPlanted planted = preserve $ do
	translate (plantPosition planted) 0
	setLineCap LineCapRound
	let c = colors !! fromIntegral (plantOwner planted)
	renderPlant (Just (renderFlag (take 10 (plantOwnerName planted))))
	            c (phenotype planted)

renderFlag :: String -> Render ()
renderFlag text = preserve $ do
	scale 1 (-1)
	setFontSize (groundLevel/2)
	ext <- textExtents text

	preserve $ do
		translate (stipeWidth) (groundLevel/2)
		rectangle 0
			  (textExtentsYbearing ext + groundLevel/2)
			  (textExtentsXadvance ext)
			  (-textExtentsYbearing ext - groundLevel/2 - groundLevel/2)
		setSourceRGB 1 1 1
		fill

		setSourceRGB 0 0 0
		showText text

	setLineWidth (groundLevel/10)
	setSourceRGB 0 0 0
	moveTo 0 0
	lineTo (stipeWidth + textExtentsXadvance ext) 0
	stroke


-- | Renders a plant, or part of a plant, with a given colour. If the Render
-- argument is given, it is drawn at the end of the plant, if there are no
-- branches, or passed to exactly one branch.
renderPlant :: (Maybe (Render ())) -> (Double,Double,Double) -> AnnotatedPlant -> Render ()	
renderPlant leaveR color@(r,g,b) (Plant si len ang ut ps) = preserve $ do
	rotate ang
	withLinearPattern 0 0 0 (len * stipeLength) $ \pat -> do
		let darkenByBegin = 1/(1 + (siSubLength si)/15)
		let darkenByEnd = 1/(1 + (siSubLength si - siLength si)/15)
		patternAddColorStopRGB pat 0
			(darkenByBegin*r) (darkenByBegin*g) (darkenByBegin*b) 
		patternAddColorStopRGB pat 1
			(darkenByEnd*r) (darkenByEnd*g) (darkenByEnd*b) 
		setSource pat
		--setLineWidth (stipeWidth*(0.5 + 0.5 * sqrt (siSubLength si)))
		setLineWidth stipeWidth
		moveTo 0 0
		lineTo 0 (len * stipeLength)
		stroke
	translate 0 (len * stipeLength)
	if null ps
	 then fromMaybe (return ()) leaveR
	 else sequence_ $ zipWith (\r p -> renderPlant r color p)
	                         (leaveR : repeat Nothing)
				 ps
	case siGrowth si of
	  GrowingSeed done -> do
	  	setSourceRGB 1 1 0
	  	arc 0 0 (done * blossomSize/2) 0 (2*pi)
		fill
	  _ -> return ()
		
renderLightedPlanted :: AnnotatedPlanted -> Render ()
renderLightedPlanted planted = preserve $ do
	translate (plantPosition planted) 0
	renderLightedPlant (phenotype planted)

renderLightedPlant :: AnnotatedPlant -> Render ()	
renderLightedPlant (Plant si len ang ut ps) = preserve $ do
	rotate ang
	moveTo 0 0
	lineTo 0 (len * stipeLength)
	let normalized = siLight si / (len * stipeLength)
	when (normalized > 0) $ do
		--liftIO $ print normalized
		setLineWidth (2*stipeWidth)
		setSourceRGBA 1 1 0 normalized
		stroke
	translate 0 (len * stipeLength)
	mapM_ renderLightedPlant ps
		
{- Line based rendering deprecated

renderLine (l@((x1,y1),(x2,y2)), _) = do
	setSourceRGB 0 1 0 
	setLineWidth (0.5*stipeWidth)
	moveTo x1 y1
	lineTo x2 y2
	stroke
	
renderLightedLine (l@((x1,y1),(x2,y2)), _, intensity) = do
	moveTo x1 y1
	lineTo x2 y2
	let normalized = intensity / lineLength l
	when (normalized > 0) $ do
		setLineWidth (1.5*stipeWidth)
		setSourceRGBA 1 1 0 normalized
		strokePreserve
	setSourceRGB 0 1 0 
	setLineWidth (0.5*stipeWidth)
	stroke
-}
	
renderLightedPoly ((x1,y1),(x2,y2),(x3,y3),(x4,y4), intensity) = do
	when (intensity > 0) $ do
		moveTo x1 y1
		lineTo x2 y2
		lineTo x3 y3
		lineTo x4 y4
		closePath
		setSourceRGB 0 0 intensity
		fill

renderInfo garden = do
	forM_ garden $ \planted -> do
		let x = plantPosition planted
		{-
		let text1 = printf "Light: %.2f" $
				siSubLight . pData . phenotype $ planted
		-}
		let text1 = plantOwnerName planted
		let text2 = printf "Size: %.2f" $
				siSubLength . pData . phenotype $ planted
		preserve $ do
			scale 1 (-1)
			setSourceRGB 0 0 0
			setFontSize (groundLevel/2)
			moveTo x (0.9*groundLevel)
			showText text2
			moveTo x (0.5*groundLevel)
			showText text1

renderTimeInfo timeStr = preserve $ do
		scale 1 (-1)
		setSourceRGB 0 0 0
		setFontSize (groundLevel/2)
		moveTo 0 (0.5*groundLevel)
		showText timeStr

renderMessage angle h text = preserve $ do
		scale 1 (-1)
		setSourceRGB 0 0 0
		translate (0.5) (2.5*groundLevel - h) 
		setFontSize (groundLevel)

		let bullet = " * "
		ext <- textExtents (text ++ bullet)

		rectangle (-0.25)
			  (textExtentsYbearing ext + groundLevel)
			  (0.5)
			  (-textExtentsYbearing ext - groundLevel - groundLevel)
		setSourceRGB 1 1 1
		fillPreserve
		clip

		let textWidth = textExtentsXbearing ext + textExtentsXadvance ext
		    textCount = ceiling $ 0.5/textWidth
		    scroll = 3 * (angle + pi/2)/(2*pi)
		    scroll' = scroll - fromIntegral (floor scroll)
		    scrollDist = fromIntegral textCount * textWidth
		translate (-0.25 - scroll' * scrollDist) 0

		setSourceRGB 0 0 0
		showText $ intercalate bullet $ replicate (2*textCount) text

renderStats h garden = do
	let owernerscore = foldr (\p -> M.insertWith (+) (plantOwnerName p) (plantLength (phenotype p))) M.empty garden

	setFontSize (groundLevel/2)
	let texts = map (\(n,s) -> printf "%s: %.1f" (take 20 n) s) $
			reverse $
			sortBy (comparing snd) $
		        (M.toList owernerscore)
	unless (null texts) $ preserve $ do
		scale 1 (-1)
		translate 0 (1.5*groundLevel - h) 
		
		textE <- mapM (\t -> (,) t `fmap` textExtents t) texts

		let totalHeight = groundLevel/4 + fromIntegral (length texts) * (1.0*groundLevel/2)
		let totalWidth = maximum $ map (\x -> textExtentsXadvance (snd x)) textE

		rectangle 0
			  (-1.0*groundLevel/2)
			  totalWidth
			  (totalHeight)
		setSourceRGB 1 1 1
		fill

		forM_ texts $ \text -> do
			setSourceRGB 0 0 0
			moveTo 0 0
			showText text
			translate 0 (1.0*groundLevel/2)



renderSky :: Angle -> Render ()
renderSky angle = do
	-- Clear Background
	setSourceRGB  0 0 (sin angle)
	paint

renderGround :: Render ()
renderGround = do
	setSourceRGB (140/255) (80/255) (21/255)
	rectangle (-1) 0 3 (-(1+groundLevel))
        fill

-- | Wrapper that calls 'save' and 'restore' before and after the argument
preserve :: Render () -> Render ()
preserve r = save >> r >> restore

clockTimeToDouble (TOD s p) = fromIntegral s + fromIntegral p/(1000*1000*1000*1000)