fenfire-0.1: _darcs/pristine/VobTest.fhs
module VobTest where
-- Copyright (c) 2006-2007, Benja Fallenstein, Tuukka Hastrup
-- This file is part of Fenfire.
--
-- Fenfire is free software; you can redistribute it and/or modify it under
-- the terms of the GNU General Public License as published by
-- the Free Software Foundation; either version 2 of the License, or
-- (at your option) any later version.
--
-- Fenfire is distributed in the hope that it will be useful, but WITHOUT
-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General
-- Public License for more details.
--
-- You should have received a copy of the GNU General
-- Public License along with Fenfire; if not, write to the Free
-- Software Foundation, Inc., 59 Temple Place, Suite 330, Boston,
-- MA 02111-1307 USA
import Utils
import Cairo
import Vobs
import qualified Data.List
import Data.Map (fromList)
import Data.Maybe (fromJust)
import Data.IORef
import Data.Monoid hiding (Endo)
import Control.Applicative
import Control.Monad.State
import Graphics.UI.Gtk hiding (Point, Size, Layout, Color, get, fill)
import System.Environment (getArgs)
type Info = (String, Double, Double)
type Data = [(String,[Info])]
--myVob1 :: Vob (String, Int)
--myVob1 = keyVob "1" $ rectBox $ pad 5 $ multiline False 20 "Hello World!"
myVob2 :: Vob (String, Int)
myVob2 = mempty --keyVob "2" $ rectBox $ label "Foo bar baz"
{-
myScene1 :: String -> Data -> Vob (String, Int)
myScene1 t d = mconcat [ stroke $ line (center @@ "1") (center @@ "2"),
translate #50 #100 $ myVob2,
translate #250 #150 $ myVob1 t d ]
-}
myScene2 :: String -> Data -> Vob (String, Int)
myScene2 t d = translate #350 #400 $ rotate #(-pi/15) $ scale #1.5 $
changeSize (\(w,h) -> (w-30, h)) $ myVob1 t d
myVob1 :: String -> Data -> Vob (String, Int)
myVob1 t d = keyVob ("vob",1) $ {-ownSize $ resize (250, 250) $-}
pad 20 $ daisy t info where
info = fromJust (Data.List.lookup t d)
setSize :: Cx (String, Int) Double -> Cx (String, Int) Double ->
Endo (Vob (String, Int))
setSize w h = cxLocalR #(!cxMatrix, (!w, !h))
daisy :: String -> [(String, Double, Double)] -> Vob (String, Int)
daisy target distractors =
mconcat [withDash #[4] #0 $
stroke (circle center #(inner + !w * radius))
| radius <- [0, 1/4, 9/16, 1]]
& mconcat [(translateTo center $
rotate #(((fromIntegral i)::Double) * angle) $
translate #inner #0 $ setSize w h $
daisyLeaf (distractors !! i))
& translateTo (center @@ (name i,-1))
(centerVob $ label $ name i)
| i <- [0..n-1]]
& translateTo center (centerVob $ label target)
where
inner = 20.0 :: Double
size = #(uncurry min !cxSize)
w = #((!size - inner)/2); h = #(!w / 20)
n = length distractors
name i = case distractors !! i of (r,_,_) -> r
angle :: Double
angle = (2.0*pi) / fromIntegral n
likelihood correct total p = (p ** correct) * ((1 - p) ** (total - correct))
fractions :: Int -> [Double]
fractions n = [fromIntegral i / fromIntegral n | i <- [0..n]]
normalize :: [Double] -> [Double]
normalize xs = map (/s) xs where s = sum xs
accumulate :: [Double] -> [Double]
accumulate = scanl (+) 0
table :: Int -> (Double -> Double) -> [Double]
table steps f = [f (fromIntegral i / len) | i <- [0..steps-1]] where
len = fromIntegral (steps - 1)
{-
untable :: [Double] -> (Double -> Double)
untable vals = f where
nvals = fromIntegral (length vals) :: Double; offs = 1 / nvals
f x = interpolate fract (vals !! idx) (vals !! idx+1) where
idx = floor (x / offs); fract = x/offs - fromIntegral idx
-}
invert :: [Double] -> (Double -> Double)
invert ys = \y -> if y < head ys then 0 else val y 0 ys where
val v i (x:x':xs) | x <= v && v < x' = i + offs * (v-x) / (x'-x)
| otherwise = val v (i+offs) (x':xs)
val _ _ _ = 1
offs = 1 / fromIntegral (length ys - 1) :: Double
denormalize :: [Double] -> [Double]
denormalize xs = map (* len) xs where len = fromIntegral $ length xs
daisyLeaf :: (String, Double, Double) -> Vob (String, Int)
daisyLeaf (name, correct, total) =
withColor #color (fill shape) & stroke shape & mconcat pointVobs
& translateTo (anchor #(correct/total) #0)
(ownSize $ keyVob (name,-1) mempty)
where
n = 40
fracts = fractions n
pointsA = zip fracts ys where
ys = denormalize $ normalize [likelihood correct total p | p <- fracts]
pointsB = zip xs ys where
xs = map f fracts
f = invert $ accumulate $ normalize [likelihood correct total p | p <- fracts]
ys = denormalize $ normalize [likelihood correct total p | p <- xs]
points' = pointsB
points = points' ++ reverse (map (\(x,y) -> (x,-y)) points')
pointKeys = [(name, i) | i <- [0..2*n+1]]
pointVobs = flip map (zip points pointKeys) $ \((x,y),k) ->
translateTo (anchor #x #y) (keyVob k mempty)
path = [anchor #0 #0 @@ k | k <- pointKeys]
shape = moveTo (head path) & mconcat (map lineTo $ tail path) & closePath
color = interpolate (correct/total) (Color 1 0 0 0.5) (Color 0 1 0 0.5)
main = do
args <- getArgs
let fname = if length args == 0 then "DaisyData.txt" else head args
testdata <- readFile fname >>= return . (read :: String -> Data)
initGUI
window <- windowNew
windowSetTitle window "Vob test"
windowSetDefaultSize window 700 400
stateRef <- newIORef (fst $ head testdata)
let view state = myVob1 state testdata
handle _event = do t <- get; let ts = map fst testdata
let i = fromJust $ Data.List.elemIndex t ts
i' = if i+1 >= length ts then 0 else i+1
put (ts !! i')
setInterp True
(canvas, _updateCanvas, _canvasAction) <- vobCanvas stateRef view handle
(const $ return ())
(const $ return ())
lightGray 3
set window [ containerChild := canvas ]
onDestroy window mainQuit
widgetShowAll window
mainGUI