[Fencommits] fenfire-hs: move stuff to Fenfire package
Benja Fallenstein
benja.fallenstein at gmail.com
Tue Mar 13 16:04:06 EET 2007
Tue Mar 13 16:03:38 EET 2007 Benja Fallenstein <benja.fallenstein at gmail.com>
* move stuff to Fenfire package
diff -rN -u old-fenfire-hs/Cache.hs new-fenfire-hs/Cache.hs
--- old-fenfire-hs/Cache.hs 2007-03-13 16:04:04.000000000 +0200
+++ new-fenfire-hs/Cache.hs 1970-01-01 02:00:00.000000000 +0200
@@ -1,132 +0,0 @@
-{-# OPTIONS_GHC -fglasgow-exts #-}
-
-module Cache where
-
--- Copyright (c) 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 Data.Bits
-import Data.HashTable (HashTable)
-import qualified Data.HashTable as HashTable
-import Data.Int
-import Data.IORef
-import Data.Map (Map)
-import qualified Data.Map as Map
-import Data.Maybe (isJust, fromJust)
-import Data.Unique
-
-import Control.Monad (when)
-
-import System.IO.Unsafe
-import System.Mem.StableName
-
-
-class Hashable a where
- hash :: a -> Int32
-
-instance Hashable String where
- hash s = HashTable.hashString s
-
-instance Hashable Int where
- hash i = HashTable.hashInt i
-
-instance Hashable Unique where
- hash u = hash (hashUnique u)
-
-instance Hashable (StableName a) where
- hash n = hash (hashStableName n)
-
-instance (Hashable a, Hashable b) => Hashable (a,b) where
- hash (x,y) = hash x `xor` HashTable.hashInt (fromIntegral $ hash y)
-
-
-type LinkedList a = IORef (LinkedNode a)
-
-data LinkedNode a =
- LinkedNode { lnPrev :: LinkedList a, lnValue :: IORef a,
- lnNext :: LinkedList a }
- | End { lnPrev :: LinkedList a, lnNext :: LinkedList a }
-
-isEnd (LinkedNode _ _ _) = False
-isEnd (End _ _) = True
-
-newList :: IO (LinkedList a)
-newList = mdo let end = End p n
- p <- newIORef end; n <- newIORef end; list <- newIORef end
- return list
-
-newNode :: a -> IO (LinkedNode a)
-newNode x = do let err = error "Cache: access to not-yet-linked node"
- p <- newIORef err; val <- newIORef x; n <- newIORef err
- return (LinkedNode p val n)
-
-appendNode :: LinkedNode a -> LinkedList a -> IO ()
-appendNode node list = do n <- readIORef list; p <- readIORef (lnPrev n)
- writeIORef (lnNext p) node; writeIORef (lnPrev n) node
- writeIORef (lnPrev node) p; writeIORef (lnNext node) n
-
-removeFirst :: LinkedList a -> IO a
-removeFirst list = do l <- readIORef list; node <- readIORef (lnNext l)
- removeNode node
- readIORef (lnValue node)
-
-removeNode :: LinkedNode a -> IO ()
-removeNode node = do when (isEnd node) $ error "Cache: remove from empty list"
- p <- readIORef (lnPrev node); n <- readIORef (lnNext node)
- let err = error "Cache: access to unlinked node"
- writeIORef (lnPrev node) err; writeIORef (lnNext node) err
- writeIORef (lnNext p) n; writeIORef (lnPrev n) p
-
-access :: LinkedList a -> LinkedNode a -> IO ()
-access list node = do removeNode node; appendNode node list
-
-add :: a -> LinkedList a -> IO (LinkedNode a)
-add x list = do node <- newNode x; appendNode node list; return node
-
-
-byAddress :: a -> StableName a
-byAddress = unsafePerformIO . makeStableName
-
-
-type Cache key value =
- (IORef Int, Int, HashTable key (value, LinkedNode key), LinkedList key)
-
-newCache :: (Eq key, Hashable key) => Int -> Cache key value
-newCache maxsize = unsafePerformIO $ do ht <- HashTable.new (==) hash
- lru <- newList; size <- newIORef 0
- return (size, maxsize, ht, lru)
-
-cached :: (Eq k, Hashable k) => k -> Cache k v -> v -> v
-cached key (sizeRef, maxsize, cache, lru) val = unsafePerformIO $ do
- mval' <- HashTable.lookup cache key
- if isJust mval' then do
- let (val', node) = fromJust mval'
- access lru node
- --putStrLn "Cache access"
- return val'
- else do
- size <- readIORef sizeRef
- --putStrLn ("Cache add, former size " ++ show size)
- if size < maxsize then writeIORef sizeRef (size+1)
- else do dropped <- removeFirst lru
- HashTable.delete cache dropped
- node <- add key lru
- HashTable.insert cache key (val, node)
- return val
diff -rN -u old-fenfire-hs/Cairo.fhs new-fenfire-hs/Cairo.fhs
--- old-fenfire-hs/Cairo.fhs 2007-03-13 16:04:04.000000000 +0200
+++ new-fenfire-hs/Cairo.fhs 1970-01-01 02:00:00.000000000 +0200
@@ -1,205 +0,0 @@
--- For (instance (Cairo cx r, Monoid m) => Monoid (cx m)):
-{-# OPTIONS_GHC -fallow-undecidable-instances -fallow-incoherent-instances #-}
--- More, implied by the previous on GHC 6.6 but needed for earlier:
-{-# OPTIONS_GHC -fallow-overlapping-instances #-}
-module Cairo 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 Control.Applicative
-import Control.Monad
-
-import Data.Monoid (Monoid(mappend, mempty))
-import qualified Data.Word
-
-import Graphics.UI.Gtk hiding (Point, Size, Layout, Color, get, fill)
-import qualified Graphics.Rendering.Cairo as C
-import Graphics.Rendering.Cairo.Matrix (Matrix(Matrix))
-import qualified Graphics.Rendering.Cairo.Matrix as Matrix
-import Graphics.UI.Gtk.Cairo
-
-import qualified Graphics.UI.Gtk as Gtk
-
-data Color = Color Double Double Double Double deriving Show
-type Size = (Double, Double)
-type Point = (Double, Double)
-type Rect = (Matrix, Size)
-
-type Render a = C.Render a
-newtype Path = Path { renderPath :: Render () } deriving Monoid
-
-class (Applicative cx, Monoid r) =>
- Cairo cx r | cx -> r, r -> cx where
- cxAsk :: cx Rect
- cxLocal :: cx Rect -> Endo (cx a)
-
- cxWrap :: EndoM cx (Render ()) -> Endo r
- cxLocalR :: cx Rect -> Endo r
-
- cxRender :: cx (Render ()) -> r
- cxRender r = cxWrap (const r) mempty
-
-instance Monoid (Render ()) where
- mempty = return ()
- mappend = (>>)
-
-instance (Applicative m, Monoid o) => Monoid (m o) where
- mempty = pure mempty
- mappend = liftA2 mappend
-
-instance Cairo ((->) Rect) (Rect -> Render ()) where
- cxAsk = id
- cxLocal f m r = m (f r)
-
- cxWrap f ren r = f (ren r) r
- cxLocalR f ren r = ren (f r)
-
-newtype InContext a b = InContext { appContext :: a -> b } deriving Monoid
-
-instance Cairo cx r => Cairo (Comp ((->) a) cx) (InContext a r) where
- cxAsk = Comp (const cxAsk)
- cxLocal (Comp f) (Comp m) = Comp $ \a -> cxLocal (f a) (m a)
-
- cxWrap f c = InContext $ \a -> cxWrap (\ren -> (fromComp $ f ren) a)
- (c `appContext` a)
- cxLocalR f c = InContext $ \a -> cxLocalR (fromComp f a) (c `appContext` a)
-
-cxMatrix :: Cairo cx r => cx Matrix
-cxMatrix = fmap fst cxAsk
-
-cxSize :: Cairo cx r => cx Size
-cxSize = fmap snd cxAsk
-
-
-[black, gray, lightGray, white] = [Color x x x 1 | x <- [0, 0.5, 0.9, 1]]
-
-
-fill :: Cairo cx r => cx Path -> r
-fill p = cxRender $ forA2 p cxMatrix $ \p' m -> do
- renderPath p'; C.save; C.transform m; C.fill; C.restore
-
-stroke :: Cairo cx r => cx Path -> r
-stroke p = cxRender $ forA2 p cxMatrix $ \p' m -> do
- renderPath p'; C.save; C.transform m; C.stroke; C.restore
-
-paint :: Cairo cx r => r
-paint = cxRender $ pure C.paint
-
-clip :: Cairo cx r => cx Path -> Endo r
-clip p = cxWrap $ \ren -> ffor p $ \p' -> do
- C.save; renderPath p'; C.clip; ren; C.restore
-
-withSurface :: Cairo cx r => cx C.Surface -> Endo r
-withSurface s = cxWrap $ \ren -> #(C.save >> C.getMatrix >>= \m' ->
- C.setMatrix !cxMatrix >> C.setSourceSurface !s 0 0 >> C.setMatrix m' >>
- ren >> C.restore)
-
-withColor :: Cairo cx r => cx Color -> Endo r
-withColor c = cxWrap $ \ren -> ffor c $ \(Color r g b a) -> do
- C.save; C.setSourceRGBA r g b a; ren; C.restore
-
-withDash :: Cairo cx r => cx [Double] -> cx Double -> Endo r
-withDash a b = cxWrap $ \ren -> #(C.save >> C.setDash !a !b >> ren >> C.restore)
-
-transform :: Cairo cx r => cx (Endo Matrix) -> Endo r
-transform f = cxLocalR #(!f Matrix.identity * !cxMatrix, !cxSize)
-
--- | Moves a renderable by x and y.
---
-translate :: Cairo cx r => cx Double -> cx Double -> Endo r
-translate x y = transform $ liftA2 Matrix.translate x y
-
--- | Moves a renderable to the specific point p.
---
-translateTo :: Cairo cx r => cx Point -> Endo r
-translateTo p = translate x y where
- (x,y) = funzip #(Matrix.transformPoint (Matrix.invert !cxMatrix) !p)
-
--- | Rotates a renderable by angle.
---
-rotate :: Cairo cx r => cx Double -> Endo r
-rotate angle = transform $ fmap Matrix.rotate angle
-
--- | Scales a renderable by sx and sy.
---
-scale2 :: Cairo cx r => cx Double -> cx Double -> Endo r
-scale2 sx sy = transform $ liftA2 Matrix.scale sx sy
-
--- | Scales a renderable by sc.
---
-scale :: Cairo cx r => cx Double -> Endo r
-scale sc = scale2 sc sc
-
-
-between :: Cairo cx r => cx Point -> cx Point -> Endo r
-between p1 p2 = translate #(avg !x1 !x2) #(avg !y1 !y2)
- . rotate #(atan2 (!y2 - !y1) (!x2 - !x1))
- where (x1,y1) = funzip p1; (x2,y2) = funzip p2
-
-
-point :: Cairo cx r => cx Double -> cx Double -> cx Point
-point x y = #(Matrix.transformPoint !cxMatrix (!x,!y))
-
-anchor :: Cairo cx r => cx Double -> cx Double -> cx Point
-anchor x y = #(Matrix.transformPoint !cxMatrix (!x * !w, !y * !h))
- where (w,h) = funzip cxSize
-
-center :: Cairo cx r => cx Point
-center = anchor #0.5 #0.5
-
-closePath :: Cairo cx r => cx Path
-closePath = pure $ Path $ C.closePath
-
-arc :: Cairo cx r => cx Point -> cx Double -> cx Double -> cx Double -> cx Path
-arc p a b c = #(Path $ do
- let (x,y) = Matrix.transformPoint (Matrix.invert !cxMatrix) !p
- C.save; C.transform !cxMatrix; C.arc x y !a !b !c; C.restore)
-
-arcNegative :: Cairo cx r => cx Point -> cx Double -> cx Double -> cx Double ->
- cx Path
-arcNegative p a b c = #(Path $ do
- let (x,y) = Matrix.transformPoint (Matrix.invert !cxMatrix) !p
- C.save; C.transform !cxMatrix; C.arcNegative x y !a !b !c; C.restore)
-
-circle :: Cairo cx r => cx Point -> cx Double -> cx Path
-circle p r = arc p r #0 #(2*pi)
-
-curveTo :: Cairo cx r => cx Point -> cx Point -> cx Point -> cx Path
-curveTo p1 p2 p3 = forA3 p1 p2 p3 $ \(x1,y1) (x2,y2) (x3,y3) ->
- Path $ C.curveTo x1 y1 x2 y2 x3 y3
-
-moveTo :: Cairo cx r => cx Point -> cx Path
-moveTo p = ffor p $ \(x,y) -> Path $ do C.moveTo x y
-
-lineTo :: Cairo cx r => cx Point -> cx Path
-lineTo p = ffor p $ \(x,y) -> Path $ do C.lineTo x y
-
-line :: (Cairo cx r, Monoid (cx Path)) => cx Point -> cx Point -> cx Path
-line p1 p2 = moveTo p1 & lineTo p2
-
-extents :: (Cairo cx r, Monoid (cx Path)) => cx Path
-extents = moveTo (anchor #0 #0) & lineTo (anchor #0 #1) & lineTo (anchor #1 #1)
- & lineTo (anchor #1 #0) & closePath
-
-
-fromGtkColor :: Gtk.Color -> Color
-fromGtkColor (Gtk.Color r g b) = Color (f r) (f g) (f b) 1 where
- f x = fromIntegral x / fromIntegral (maxBound :: Data.Word.Word16)
diff -rN -u old-fenfire-hs/Darcs2RDF.fhs new-fenfire-hs/Darcs2RDF.fhs
--- old-fenfire-hs/Darcs2RDF.fhs 2007-03-13 16:04:04.000000000 +0200
+++ new-fenfire-hs/Darcs2RDF.fhs 1970-01-01 02:00:00.000000000 +0200
@@ -1,99 +0,0 @@
--- HaRP pattern translator produces following warnings:
-{-# OPTIONS_GHC -fno-warn-name-shadowing -fno-warn-incomplete-patterns #-}
-module Darcs2RDF 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 Prelude hiding (elem)
-import Text.XML.HaXml hiding (attr)
-import Data.Maybe
-import System.Environment (getArgs)
-
-data Patch = Patch { patchHash :: String, patchName :: String,
- patchDate :: String, patchAuthor :: String } deriving Show
-
-patches (Document _ _ (Elem "changelog" _ c) _) = map patch (elems c) where
- patch el@(Elem "patch" _ _) =
- Patch (fromJust $ attr "hash" el) (fromJust $ elem "name" el)
- (fromJust $ attr "date" el) (fromJust $ attr "author" el)
-
-triples :: String -> Patch -> String
-triples repo (Patch hash name date author) =
- "<"++repo++"> <" ++ seeAlso ++ "> <"++month++">.\n" ++
- "<"++month++"> <" ++ seeAlso ++ "> <"++day++">.\n" ++
- "<"++month++"> <" ++ label ++ "> " ++ show (take 7 date') ++ ".\n" ++
- "<"++day++"> <" ++ seeAlso ++ "> "++uri++".\n" ++
- "<"++day++"> <" ++ label ++ "> " ++ show (take 10 date') ++ ".\n" ++
- uri++" <"++label++"> " ++
- ""++show name++".\n" ++
- uri++" <foaf:author> "++authorURI ++ ".\n" ++
- (if not $ null authorName
- then authorURI++" <foaf:name> "++show authorName ++ ".\n" else "") ++
- authorURI++" <foaf:mbox> <mailto:"++authorMail ++ ">.\n" ++
- uri++ " <"++dc_date++"> \""++date'++ "\"^^<xsd:dateTime>.\n"
- where uri = "<darcs:"++hash++">"
- -- the following uses HaRP patterns
- [/ (/ authorName*, ' '*, '<', authorMail*, '>' /)
- | authorMail* /] = author
- authorURI = "<byemail:"++authorMail++">"
- [/ y@(/_,_,_,_/),m@(/_,_/),d@(/_,_/),h@(/_,_/),mi@(/_,_/),s@(/_,_/) /] = date
- date' = y++"-"++m++"-"++d++"T"++h++":"++mi++":"++s++"+0000"
- month = "ex:patches:" ++ take 7 date' ++ ":" ++ repo
- day = "ex:patches:" ++ take 10 date' ++ ":" ++ repo
- seeAlso = "http://www.w3.org/2000/01/rdf-schema#seeAlso"
- label = "http://www.w3.org/2000/01/rdf-schema#label"
- dc_date = "http://purl.org/dc/elements/1.1/date"
-
-elems :: [Content] -> [Element]
-elems (CElem e : cs) = e : elems cs
-elems (_ : cs) = elems cs
-elems [] = []
-
-attr :: String -> Element -> Maybe String
-attr name (Elem _ attrs _) = fmap getValue (lookup name attrs) where
- getValue (AttValue l) = concatMap getValue' l
- getValue' (Left s) = s
- getValue' (Right ref) = [unref ref]
-
-elem :: String -> Element -> Maybe String
-elem name (Elem _ _ cs) = findElem (elems cs) where
- findElem (Elem n _ c : _) | n == name = Just (text c)
- findElem (_ : cs') = findElem cs'
- findElem [] = Nothing
-
-unref :: Reference -> Char
-unref (RefChar c) = toEnum c
-unref (RefEntity "apos") = '\''
-unref (RefEntity "quot") = '"'
-unref (RefEntity "lt") = '<'
-unref (RefEntity "gt") = '>'
-unref (RefEntity "amp") = '&'
-unref _ = error "unimplemented reference thingie"
-
-text :: [Content] -> String
-text (CString _ s : cs) = s ++ text cs
-text (CRef r : cs) = unref r : text cs
-text (_ : _) = error "unimplemented content thingie"
-text [] = ""
-
-
-main = do [repo] <- getArgs
- xml <- getContents
- putStr "@prefix dc: <http://purl.org/dc/elements/1.1/>.\n"
- putStr $ concatMap (triples repo) $ patches $ xmlParse "stdin" xml
diff -rN -u old-fenfire-hs/Data/RDF.hs new-fenfire-hs/Data/RDF.hs
--- old-fenfire-hs/Data/RDF.hs 2007-03-13 16:04:04.000000000 +0200
+++ new-fenfire-hs/Data/RDF.hs 2007-03-13 16:04:04.000000000 +0200
@@ -19,8 +19,8 @@
-- Software Foundation, Inc., 59 Temple Place, Suite 330, Boston,
-- MA 02111-1307 USA
-import Cache
-import Utils
+import Fenfire.Cache
+import Fenfire.Utils
import Data.Map (Map)
import qualified Data.Map as Map
diff -rN -u old-fenfire-hs/FRP.fhs new-fenfire-hs/FRP.fhs
--- old-fenfire-hs/FRP.fhs 2007-03-13 16:04:04.000000000 +0200
+++ new-fenfire-hs/FRP.fhs 1970-01-01 02:00:00.000000000 +0200
@@ -1,93 +0,0 @@
-{-# OPTIONS_GHC -fallow-undecidable-instances -fallow-incoherent-instances #-}
-module FRP 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 Control.Applicative
-
-import Data.IORef
-
-import Graphics.Rendering.Cairo
-import Graphics.UI.Gtk
-
-newtype SF i o = SF { runSF :: TimeDiff -> i -> (o, SF i o) }
-
-instance Functor (SF i) where
- fmap f sf = SF $ \t i -> let (o, sf') = runSF sf t i in (f o, fmap f sf')
-
-instance Applicative (SF i) where
- pure x = SF $ \_ _ -> (x, pure x)
- f <*> a = SF $ \t i -> let (fv, f') = runSF f t i
- (av, a') = runSF a t i in (fv av, f' <*> a')
-
-input :: SF i i
-input = SF $ \_ i -> (i, input)
-
-data Input = Input { mouseX :: Double, mouseY :: Double }
-
-timeSF :: SF a Double
-timeSF = f 0 where
- f x = SF $ \t _ -> (x + t, f $ x + t)
-
-test :: SF Input (Render ())
-test = liftA2 (\i t -> do
- save; setSourceRGBA 0 0 0 1
- arc (mouseX i) (mouseY i) 50 (3*t) (3*t+2); stroke; restore) input timeSF
-
-
-main = do
- initGUI
- window <- windowNew
- windowSetTitle window "FRP test"
- windowSetDefaultSize window 700 400
-
- canvas <- drawingAreaNew
- set window [ containerChild := canvas ]
-
- time0 <- getTime
- ref <- newIORef (time0, test)
- mouse <- newIORef (100, 100)
-
- onExpose canvas $ \(Expose {}) -> do
- time' <- getTime
- (x,y) <- readIORef mouse
-
- (time, sf) <- readIORef ref
- let (ren, sf') = runSF sf (time' - time) (Input x y)
- writeIORef ref (time', sf')
-
- drawable <- widgetGetDrawWindow canvas
- renderWithDrawable drawable ren
-
- widgetQueueDraw canvas
- return True
-
- onMotionNotify canvas False $ \e -> case e of
- Motion { eventX=x, eventY=y } -> writeIORef mouse (x,y) >> return False
- _ -> return False
-
- onEnterNotify canvas $ \e -> case e of
- Crossing {eventX=x, eventY=y} -> writeIORef mouse (x,y) >> return False
- _ -> return False
-
- onDestroy window mainQuit
- widgetShowAll window
- mainGUI
diff -rN -u old-fenfire-hs/Fenfire/Cache.hs new-fenfire-hs/Fenfire/Cache.hs
--- old-fenfire-hs/Fenfire/Cache.hs 1970-01-01 02:00:00.000000000 +0200
+++ new-fenfire-hs/Fenfire/Cache.hs 2007-03-13 16:04:04.000000000 +0200
@@ -0,0 +1,132 @@
+{-# OPTIONS_GHC -fglasgow-exts #-}
+
+module Fenfire.Cache where
+
+-- Copyright (c) 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 Fenfire.Utils
+
+import Data.Bits
+import Data.HashTable (HashTable)
+import qualified Data.HashTable as HashTable
+import Data.Int
+import Data.IORef
+import Data.Map (Map)
+import qualified Data.Map as Map
+import Data.Maybe (isJust, fromJust)
+import Data.Unique
+
+import Control.Monad (when)
+
+import System.IO.Unsafe
+import System.Mem.StableName
+
+
+class Hashable a where
+ hash :: a -> Int32
+
+instance Hashable String where
+ hash s = HashTable.hashString s
+
+instance Hashable Int where
+ hash i = HashTable.hashInt i
+
+instance Hashable Unique where
+ hash u = hash (hashUnique u)
+
+instance Hashable (StableName a) where
+ hash n = hash (hashStableName n)
+
+instance (Hashable a, Hashable b) => Hashable (a,b) where
+ hash (x,y) = hash x `xor` HashTable.hashInt (fromIntegral $ hash y)
+
+
+type LinkedList a = IORef (LinkedNode a)
+
+data LinkedNode a =
+ LinkedNode { lnPrev :: LinkedList a, lnValue :: IORef a,
+ lnNext :: LinkedList a }
+ | End { lnPrev :: LinkedList a, lnNext :: LinkedList a }
+
+isEnd (LinkedNode _ _ _) = False
+isEnd (End _ _) = True
+
+newList :: IO (LinkedList a)
+newList = mdo let end = End p n
+ p <- newIORef end; n <- newIORef end; list <- newIORef end
+ return list
+
+newNode :: a -> IO (LinkedNode a)
+newNode x = do let err = error "Cache: access to not-yet-linked node"
+ p <- newIORef err; val <- newIORef x; n <- newIORef err
+ return (LinkedNode p val n)
+
+appendNode :: LinkedNode a -> LinkedList a -> IO ()
+appendNode node list = do n <- readIORef list; p <- readIORef (lnPrev n)
+ writeIORef (lnNext p) node; writeIORef (lnPrev n) node
+ writeIORef (lnPrev node) p; writeIORef (lnNext node) n
+
+removeFirst :: LinkedList a -> IO a
+removeFirst list = do l <- readIORef list; node <- readIORef (lnNext l)
+ removeNode node
+ readIORef (lnValue node)
+
+removeNode :: LinkedNode a -> IO ()
+removeNode node = do when (isEnd node) $ error "Cache: remove from empty list"
+ p <- readIORef (lnPrev node); n <- readIORef (lnNext node)
+ let err = error "Cache: access to unlinked node"
+ writeIORef (lnPrev node) err; writeIORef (lnNext node) err
+ writeIORef (lnNext p) n; writeIORef (lnPrev n) p
+
+access :: LinkedList a -> LinkedNode a -> IO ()
+access list node = do removeNode node; appendNode node list
+
+add :: a -> LinkedList a -> IO (LinkedNode a)
+add x list = do node <- newNode x; appendNode node list; return node
+
+
+byAddress :: a -> StableName a
+byAddress = unsafePerformIO . makeStableName
+
+
+type Cache key value =
+ (IORef Int, Int, HashTable key (value, LinkedNode key), LinkedList key)
+
+newCache :: (Eq key, Hashable key) => Int -> Cache key value
+newCache maxsize = unsafePerformIO $ do ht <- HashTable.new (==) hash
+ lru <- newList; size <- newIORef 0
+ return (size, maxsize, ht, lru)
+
+cached :: (Eq k, Hashable k) => k -> Cache k v -> v -> v
+cached key (sizeRef, maxsize, cache, lru) val = unsafePerformIO $ do
+ mval' <- HashTable.lookup cache key
+ if isJust mval' then do
+ let (val', node) = fromJust mval'
+ access lru node
+ --putStrLn "Cache access"
+ return val'
+ else do
+ size <- readIORef sizeRef
+ --putStrLn ("Cache add, former size " ++ show size)
+ if size < maxsize then writeIORef sizeRef (size+1)
+ else do dropped <- removeFirst lru
+ HashTable.delete cache dropped
+ node <- add key lru
+ HashTable.insert cache key (val, node)
+ return val
diff -rN -u old-fenfire-hs/Fenfire/Cairo.fhs new-fenfire-hs/Fenfire/Cairo.fhs
--- old-fenfire-hs/Fenfire/Cairo.fhs 1970-01-01 02:00:00.000000000 +0200
+++ new-fenfire-hs/Fenfire/Cairo.fhs 2007-03-13 16:04:04.000000000 +0200
@@ -0,0 +1,205 @@
+-- For (instance (Cairo cx r, Monoid m) => Monoid (cx m)):
+{-# OPTIONS_GHC -fallow-undecidable-instances -fallow-incoherent-instances #-}
+-- More, implied by the previous on GHC 6.6 but needed for earlier:
+{-# OPTIONS_GHC -fallow-overlapping-instances #-}
+module Fenfire.Cairo 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 Fenfire.Utils
+
+import Control.Applicative
+import Control.Monad
+
+import Data.Monoid (Monoid(mappend, mempty))
+import qualified Data.Word
+
+import Graphics.UI.Gtk hiding (Point, Size, Layout, Color, get, fill)
+import qualified Graphics.Rendering.Cairo as C
+import Graphics.Rendering.Cairo.Matrix (Matrix(Matrix))
+import qualified Graphics.Rendering.Cairo.Matrix as Matrix
+import Graphics.UI.Gtk.Cairo
+
+import qualified Graphics.UI.Gtk as Gtk
+
+data Color = Color Double Double Double Double deriving Show
+type Size = (Double, Double)
+type Point = (Double, Double)
+type Rect = (Matrix, Size)
+
+type Render a = C.Render a
+newtype Path = Path { renderPath :: Render () } deriving Monoid
+
+class (Applicative cx, Monoid r) =>
+ Cairo cx r | cx -> r, r -> cx where
+ cxAsk :: cx Rect
+ cxLocal :: cx Rect -> Endo (cx a)
+
+ cxWrap :: EndoM cx (Render ()) -> Endo r
+ cxLocalR :: cx Rect -> Endo r
+
+ cxRender :: cx (Render ()) -> r
+ cxRender r = cxWrap (const r) mempty
+
+instance Monoid (Render ()) where
+ mempty = return ()
+ mappend = (>>)
+
+instance (Applicative m, Monoid o) => Monoid (m o) where
+ mempty = pure mempty
+ mappend = liftA2 mappend
+
+instance Cairo ((->) Rect) (Rect -> Render ()) where
+ cxAsk = id
+ cxLocal f m r = m (f r)
+
+ cxWrap f ren r = f (ren r) r
+ cxLocalR f ren r = ren (f r)
+
+newtype InContext a b = InContext { appContext :: a -> b } deriving Monoid
+
+instance Cairo cx r => Cairo (Comp ((->) a) cx) (InContext a r) where
+ cxAsk = Comp (const cxAsk)
+ cxLocal (Comp f) (Comp m) = Comp $ \a -> cxLocal (f a) (m a)
+
+ cxWrap f c = InContext $ \a -> cxWrap (\ren -> (fromComp $ f ren) a)
+ (c `appContext` a)
+ cxLocalR f c = InContext $ \a -> cxLocalR (fromComp f a) (c `appContext` a)
+
+cxMatrix :: Cairo cx r => cx Matrix
+cxMatrix = fmap fst cxAsk
+
+cxSize :: Cairo cx r => cx Size
+cxSize = fmap snd cxAsk
+
+
+[black, gray, lightGray, white] = [Color x x x 1 | x <- [0, 0.5, 0.9, 1]]
+
+
+fill :: Cairo cx r => cx Path -> r
+fill p = cxRender $ forA2 p cxMatrix $ \p' m -> do
+ renderPath p'; C.save; C.transform m; C.fill; C.restore
+
+stroke :: Cairo cx r => cx Path -> r
+stroke p = cxRender $ forA2 p cxMatrix $ \p' m -> do
+ renderPath p'; C.save; C.transform m; C.stroke; C.restore
+
+paint :: Cairo cx r => r
+paint = cxRender $ pure C.paint
+
+clip :: Cairo cx r => cx Path -> Endo r
+clip p = cxWrap $ \ren -> ffor p $ \p' -> do
+ C.save; renderPath p'; C.clip; ren; C.restore
+
+withSurface :: Cairo cx r => cx C.Surface -> Endo r
+withSurface s = cxWrap $ \ren -> #(C.save >> C.getMatrix >>= \m' ->
+ C.setMatrix !cxMatrix >> C.setSourceSurface !s 0 0 >> C.setMatrix m' >>
+ ren >> C.restore)
+
+withColor :: Cairo cx r => cx Color -> Endo r
+withColor c = cxWrap $ \ren -> ffor c $ \(Color r g b a) -> do
+ C.save; C.setSourceRGBA r g b a; ren; C.restore
+
+withDash :: Cairo cx r => cx [Double] -> cx Double -> Endo r
+withDash a b = cxWrap $ \ren -> #(C.save >> C.setDash !a !b >> ren >> C.restore)
+
+transform :: Cairo cx r => cx (Endo Matrix) -> Endo r
+transform f = cxLocalR #(!f Matrix.identity * !cxMatrix, !cxSize)
+
+-- | Moves a renderable by x and y.
+--
+translate :: Cairo cx r => cx Double -> cx Double -> Endo r
+translate x y = transform $ liftA2 Matrix.translate x y
+
+-- | Moves a renderable to the specific point p.
+--
+translateTo :: Cairo cx r => cx Point -> Endo r
+translateTo p = translate x y where
+ (x,y) = funzip #(Matrix.transformPoint (Matrix.invert !cxMatrix) !p)
+
+-- | Rotates a renderable by angle.
+--
+rotate :: Cairo cx r => cx Double -> Endo r
+rotate angle = transform $ fmap Matrix.rotate angle
+
+-- | Scales a renderable by sx and sy.
+--
+scale2 :: Cairo cx r => cx Double -> cx Double -> Endo r
+scale2 sx sy = transform $ liftA2 Matrix.scale sx sy
+
+-- | Scales a renderable by sc.
+--
+scale :: Cairo cx r => cx Double -> Endo r
+scale sc = scale2 sc sc
+
+
+between :: Cairo cx r => cx Point -> cx Point -> Endo r
+between p1 p2 = translate #(avg !x1 !x2) #(avg !y1 !y2)
+ . rotate #(atan2 (!y2 - !y1) (!x2 - !x1))
+ where (x1,y1) = funzip p1; (x2,y2) = funzip p2
+
+
+point :: Cairo cx r => cx Double -> cx Double -> cx Point
+point x y = #(Matrix.transformPoint !cxMatrix (!x,!y))
+
+anchor :: Cairo cx r => cx Double -> cx Double -> cx Point
+anchor x y = #(Matrix.transformPoint !cxMatrix (!x * !w, !y * !h))
+ where (w,h) = funzip cxSize
+
+center :: Cairo cx r => cx Point
+center = anchor #0.5 #0.5
+
+closePath :: Cairo cx r => cx Path
+closePath = pure $ Path $ C.closePath
+
+arc :: Cairo cx r => cx Point -> cx Double -> cx Double -> cx Double -> cx Path
+arc p a b c = #(Path $ do
+ let (x,y) = Matrix.transformPoint (Matrix.invert !cxMatrix) !p
+ C.save; C.transform !cxMatrix; C.arc x y !a !b !c; C.restore)
+
+arcNegative :: Cairo cx r => cx Point -> cx Double -> cx Double -> cx Double ->
+ cx Path
+arcNegative p a b c = #(Path $ do
+ let (x,y) = Matrix.transformPoint (Matrix.invert !cxMatrix) !p
+ C.save; C.transform !cxMatrix; C.arcNegative x y !a !b !c; C.restore)
+
+circle :: Cairo cx r => cx Point -> cx Double -> cx Path
+circle p r = arc p r #0 #(2*pi)
+
+curveTo :: Cairo cx r => cx Point -> cx Point -> cx Point -> cx Path
+curveTo p1 p2 p3 = forA3 p1 p2 p3 $ \(x1,y1) (x2,y2) (x3,y3) ->
+ Path $ C.curveTo x1 y1 x2 y2 x3 y3
+
+moveTo :: Cairo cx r => cx Point -> cx Path
+moveTo p = ffor p $ \(x,y) -> Path $ do C.moveTo x y
+
+lineTo :: Cairo cx r => cx Point -> cx Path
+lineTo p = ffor p $ \(x,y) -> Path $ do C.lineTo x y
+
+line :: (Cairo cx r, Monoid (cx Path)) => cx Point -> cx Point -> cx Path
+line p1 p2 = moveTo p1 & lineTo p2
+
+extents :: (Cairo cx r, Monoid (cx Path)) => cx Path
+extents = moveTo (anchor #0 #0) & lineTo (anchor #0 #1) & lineTo (anchor #1 #1)
+ & lineTo (anchor #1 #0) & closePath
+
+
+fromGtkColor :: Gtk.Color -> Color
+fromGtkColor (Gtk.Color r g b) = Color (f r) (f g) (f b) 1 where
+ f x = fromIntegral x / fromIntegral (maxBound :: Data.Word.Word16)
diff -rN -u old-fenfire-hs/Fenfire/Darcs2RDF.fhs new-fenfire-hs/Fenfire/Darcs2RDF.fhs
--- old-fenfire-hs/Fenfire/Darcs2RDF.fhs 1970-01-01 02:00:00.000000000 +0200
+++ new-fenfire-hs/Fenfire/Darcs2RDF.fhs 2007-03-13 16:04:04.000000000 +0200
@@ -0,0 +1,99 @@
+-- HaRP pattern translator produces following warnings:
+{-# OPTIONS_GHC -fno-warn-name-shadowing -fno-warn-incomplete-patterns #-}
+module Fenfire.Darcs2RDF 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 Prelude hiding (elem)
+import Text.XML.HaXml hiding (attr)
+import Data.Maybe
+import System.Environment (getArgs)
+
+data Patch = Patch { patchHash :: String, patchName :: String,
+ patchDate :: String, patchAuthor :: String } deriving Show
+
+patches (Document _ _ (Elem "changelog" _ c) _) = map patch (elems c) where
+ patch el@(Elem "patch" _ _) =
+ Patch (fromJust $ attr "hash" el) (fromJust $ elem "name" el)
+ (fromJust $ attr "date" el) (fromJust $ attr "author" el)
+
+triples :: String -> Patch -> String
+triples repo (Patch hash name date author) =
+ "<"++repo++"> <" ++ seeAlso ++ "> <"++month++">.\n" ++
+ "<"++month++"> <" ++ seeAlso ++ "> <"++day++">.\n" ++
+ "<"++month++"> <" ++ label ++ "> " ++ show (take 7 date') ++ ".\n" ++
+ "<"++day++"> <" ++ seeAlso ++ "> "++uri++".\n" ++
+ "<"++day++"> <" ++ label ++ "> " ++ show (take 10 date') ++ ".\n" ++
+ uri++" <"++label++"> " ++
+ ""++show name++".\n" ++
+ uri++" <foaf:author> "++authorURI ++ ".\n" ++
+ (if not $ null authorName
+ then authorURI++" <foaf:name> "++show authorName ++ ".\n" else "") ++
+ authorURI++" <foaf:mbox> <mailto:"++authorMail ++ ">.\n" ++
+ uri++ " <"++dc_date++"> \""++date'++ "\"^^<xsd:dateTime>.\n"
+ where uri = "<darcs:"++hash++">"
+ -- the following uses HaRP patterns
+ [/ (/ authorName*, ' '*, '<', authorMail*, '>' /)
+ | authorMail* /] = author
+ authorURI = "<byemail:"++authorMail++">"
+ [/ y@(/_,_,_,_/),m@(/_,_/),d@(/_,_/),h@(/_,_/),mi@(/_,_/),s@(/_,_/) /] = date
+ date' = y++"-"++m++"-"++d++"T"++h++":"++mi++":"++s++"+0000"
+ month = "ex:patches:" ++ take 7 date' ++ ":" ++ repo
+ day = "ex:patches:" ++ take 10 date' ++ ":" ++ repo
+ seeAlso = "http://www.w3.org/2000/01/rdf-schema#seeAlso"
+ label = "http://www.w3.org/2000/01/rdf-schema#label"
+ dc_date = "http://purl.org/dc/elements/1.1/date"
+
+elems :: [Content] -> [Element]
+elems (CElem e : cs) = e : elems cs
+elems (_ : cs) = elems cs
+elems [] = []
+
+attr :: String -> Element -> Maybe String
+attr name (Elem _ attrs _) = fmap getValue (lookup name attrs) where
+ getValue (AttValue l) = concatMap getValue' l
+ getValue' (Left s) = s
+ getValue' (Right ref) = [unref ref]
+
+elem :: String -> Element -> Maybe String
+elem name (Elem _ _ cs) = findElem (elems cs) where
+ findElem (Elem n _ c : _) | n == name = Just (text c)
+ findElem (_ : cs') = findElem cs'
+ findElem [] = Nothing
+
+unref :: Reference -> Char
+unref (RefChar c) = toEnum c
+unref (RefEntity "apos") = '\''
+unref (RefEntity "quot") = '"'
+unref (RefEntity "lt") = '<'
+unref (RefEntity "gt") = '>'
+unref (RefEntity "amp") = '&'
+unref _ = error "unimplemented reference thingie"
+
+text :: [Content] -> String
+text (CString _ s : cs) = s ++ text cs
+text (CRef r : cs) = unref r : text cs
+text (_ : _) = error "unimplemented content thingie"
+text [] = ""
+
+
+main = do [repo] <- getArgs
+ xml <- getContents
+ putStr "@prefix dc: <http://purl.org/dc/elements/1.1/>.\n"
+ putStr $ concatMap (triples repo) $ patches $ xmlParse "stdin" xml
diff -rN -u old-fenfire-hs/Fenfire/FRP.fhs new-fenfire-hs/Fenfire/FRP.fhs
--- old-fenfire-hs/Fenfire/FRP.fhs 1970-01-01 02:00:00.000000000 +0200
+++ new-fenfire-hs/Fenfire/FRP.fhs 2007-03-13 16:04:04.000000000 +0200
@@ -0,0 +1,93 @@
+{-# OPTIONS_GHC -fallow-undecidable-instances -fallow-incoherent-instances #-}
+module Fenfire.FRP 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 Fenfire.Utils
+
+import Control.Applicative
+
+import Data.IORef
+
+import Graphics.Rendering.Cairo
+import Graphics.UI.Gtk
+
+newtype SF i o = SF { runSF :: TimeDiff -> i -> (o, SF i o) }
+
+instance Functor (SF i) where
+ fmap f sf = SF $ \t i -> let (o, sf') = runSF sf t i in (f o, fmap f sf')
+
+instance Applicative (SF i) where
+ pure x = SF $ \_ _ -> (x, pure x)
+ f <*> a = SF $ \t i -> let (fv, f') = runSF f t i
+ (av, a') = runSF a t i in (fv av, f' <*> a')
+
+input :: SF i i
+input = SF $ \_ i -> (i, input)
+
+data Input = Input { mouseX :: Double, mouseY :: Double }
+
+timeSF :: SF a Double
+timeSF = f 0 where
+ f x = SF $ \t _ -> (x + t, f $ x + t)
+
+test :: SF Input (Render ())
+test = liftA2 (\i t -> do
+ save; setSourceRGBA 0 0 0 1
+ arc (mouseX i) (mouseY i) 50 (3*t) (3*t+2); stroke; restore) input timeSF
+
+
+main = do
+ initGUI
+ window <- windowNew
+ windowSetTitle window "FRP test"
+ windowSetDefaultSize window 700 400
+
+ canvas <- drawingAreaNew
+ set window [ containerChild := canvas ]
+
+ time0 <- getTime
+ ref <- newIORef (time0, test)
+ mouse <- newIORef (100, 100)
+
+ onExpose canvas $ \(Expose {}) -> do
+ time' <- getTime
+ (x,y) <- readIORef mouse
+
+ (time, sf) <- readIORef ref
+ let (ren, sf') = runSF sf (time' - time) (Input x y)
+ writeIORef ref (time', sf')
+
+ drawable <- widgetGetDrawWindow canvas
+ renderWithDrawable drawable ren
+
+ widgetQueueDraw canvas
+ return True
+
+ onMotionNotify canvas False $ \e -> case e of
+ Motion { eventX=x, eventY=y } -> writeIORef mouse (x,y) >> return False
+ _ -> return False
+
+ onEnterNotify canvas $ \e -> case e of
+ Crossing {eventX=x, eventY=y} -> writeIORef mouse (x,y) >> return False
+ _ -> return False
+
+ onDestroy window mainQuit
+ widgetShowAll window
+ mainGUI
diff -rN -u old-fenfire-hs/Fenfire/FunctorTest.fhs new-fenfire-hs/Fenfire/FunctorTest.fhs
--- old-fenfire-hs/Fenfire/FunctorTest.fhs 1970-01-01 02:00:00.000000000 +0200
+++ new-fenfire-hs/Fenfire/FunctorTest.fhs 2007-03-13 16:04:04.000000000 +0200
@@ -0,0 +1,10 @@
+{-# OPTIONS_GHC -fallow-overlapping-instances #-}
+
+module Fenfire.FunctorTest where
+
+f x = "This is not a result value: " ++ show x
+
+foo s = f #(bar !s !s)
+bar = (+)
+
+main = putStrLn (foo [4,3,9::Integer])
diff -rN -u old-fenfire-hs/Fenfire/GtkFixes.hs new-fenfire-hs/Fenfire/GtkFixes.hs
--- old-fenfire-hs/Fenfire/GtkFixes.hs 1970-01-01 02:00:00.000000000 +0200
+++ new-fenfire-hs/Fenfire/GtkFixes.hs 2007-03-13 16:04:04.000000000 +0200
@@ -0,0 +1,102 @@
+module Fenfire.GtkFixes 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 Foreign (Ptr, FunPtr, Storable(pokeByteOff, peekByteOff), allocaBytes,
+ nullPtr, castPtr, freeHaskellFunPtr)
+import Foreign.C (CString, castCharToCChar, withCString, peekCString, CFile,
+ CSize, CInt, CUChar, CChar)
+
+import Foreign.ForeignPtr (unsafeForeignPtrToPtr)
+
+import System.Posix.IO (stdOutput)
+import System.Posix.Types (Fd)
+import System.Environment (getArgs)
+
+import Control.Monad (when, liftM)
+import Data.IORef (modifyIORef, readIORef, newIORef)
+import Control.Exception (bracket)
+
+import System.Glib.GObject
+import System.Glib.FFI
+import Graphics.UI.Gtk
+import qualified Graphics.UI.Gtk
+import Graphics.UI.Gtk.Types
+
+
+-- while Gtk2Hs actionNew needs the label:
+actionNew name maybeLabel tooltip stock = do
+ item <- maybe (return Nothing) stockLookupItem stock
+ let label' = case (maybeLabel, fmap siLabel item) of
+ (Just label, _) -> label
+ (_, Just label) -> label
+ _ -> error "actionNew: no label"
+ Graphics.UI.Gtk.actionNew name label' tooltip stock
+
+-- until Gtk2Hs gets another way to create accel groups:
+accelGroupNew :: IO AccelGroup
+accelGroupNew = uiManagerNew >>= uiManagerGetAccelGroup
+
+
+-- from Widget.hs generated from Benja's style patch to gtk2hs:
+widgetGetStyle :: WidgetClass widget => widget -> IO Style
+widgetGetStyle widget = do
+ (\(Widget arg1) -> withForeignPtr arg1 $ \argPtr1 ->
+ gtk_widget_ensure_style argPtr1) (toWidget widget)
+ makeNewGObject mkStyle $ (\(Widget arg1) -> withForeignPtr arg1 $ \argPtr1 ->
+ gtk_widget_get_style argPtr1) (toWidget widget)
+
+foreign import ccall safe " gtk_widget_ensure_style"
+ gtk_widget_ensure_style :: ((Ptr Widget) -> (IO ()))
+
+foreign import ccall safe " gtk_widget_get_style"
+ gtk_widget_get_style :: ((Ptr Widget) -> (IO (Ptr Style)))
+
+-- from Structs.hs generated from Benja's style patch to gtk2hs:
+styleGetForeground :: Style -> StateType -> IO Color
+styleGetForeground st ty = withForeignPtr (unStyle st) $ \stPtr -> do
+ peek $ advancePtr ((\hsc_ptr -> hsc_ptr `plusPtr` 12) stPtr) (fromEnum ty)
+
+styleGetBackground :: Style -> StateType -> IO Color
+styleGetBackground st ty = withForeignPtr (unStyle st) $ \stPtr ->
+ peek $ advancePtr ((\hsc_ptr -> hsc_ptr `plusPtr` 72) stPtr) (fromEnum ty)
+
+styleGetLight :: Style -> StateType -> IO Color
+styleGetLight st ty = withForeignPtr (unStyle st) $ \stPtr ->
+ peek $ advancePtr ((\hsc_ptr -> hsc_ptr `plusPtr` 132) stPtr) (fromEnum ty)
+
+styleGetMiddle :: Style -> StateType -> IO Color
+styleGetMiddle st ty = withForeignPtr (unStyle st) $ \stPtr ->
+ peek $ advancePtr ((\hsc_ptr -> hsc_ptr `plusPtr` 252) stPtr) (fromEnum ty)
+
+styleGetDark :: Style -> StateType -> IO Color
+styleGetDark st ty = withForeignPtr (unStyle st) $ \stPtr ->
+ peek $ advancePtr ((\hsc_ptr -> hsc_ptr `plusPtr` 192) stPtr) (fromEnum ty)
+
+styleGetText :: Style -> StateType -> IO Color
+styleGetText st ty = withForeignPtr (unStyle st) $ \stPtr ->
+ peek $ advancePtr ((\hsc_ptr -> hsc_ptr `plusPtr` 312) stPtr) (fromEnum ty)
+
+styleGetBase :: Style -> StateType -> IO Color
+styleGetBase st ty = withForeignPtr (unStyle st) $ \stPtr ->
+ peek $ advancePtr ((\hsc_ptr -> hsc_ptr `plusPtr` 372) stPtr) (fromEnum ty)
+
+styleGetAntiAliasing :: Style -> StateType -> IO Color
+styleGetAntiAliasing st ty = withForeignPtr (unStyle st) $ \stPtr ->
+ peek $ advancePtr ((\hsc_ptr -> hsc_ptr `plusPtr` 432) stPtr) (fromEnum ty)
diff -rN -u old-fenfire-hs/Fenfire/Irc2RDF.hs new-fenfire-hs/Fenfire/Irc2RDF.hs
--- old-fenfire-hs/Fenfire/Irc2RDF.hs 1970-01-01 02:00:00.000000000 +0200
+++ new-fenfire-hs/Fenfire/Irc2RDF.hs 2007-03-13 16:04:04.000000000 +0200
@@ -0,0 +1,152 @@
+{-# OPTIONS_GHC -fffi #-}
+module Fenfire.Irc2RDF 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 System.Time (getClockTime, toUTCTime, CalendarTime(..), ClockTime(..))
+import System.Environment (getArgs)
+import System.IO (hFlush, stdout)
+import System.IO.Unsafe (unsafeInterleaveIO)
+
+import Data.Char (toUpper, toLower)
+import Data.Char (ord)
+import Data.Bits ((.&.))
+
+import qualified Control.Exception
+
+import System.Glib.UTFString (newUTFString, readCString,
+ peekUTFString)
+import System.Glib.FFI (withCString, nullPtr, CString, CInt, Ptr)
+import System.IO.Unsafe (unsafePerformIO)
+
+foreign import ccall "g_utf8_validate" valid :: CString -> CInt ->
+ Ptr (CString) -> Bool
+
+-- XXX real toUTF isn't exported from System.Glib.UTFString
+toUTF :: String -> String
+toUTF s = unsafePerformIO $ newUTFString s >>= readCString
+
+fromUTF :: String -> String
+fromUTF s = unsafePerformIO $ Control.Exception.catch
+ (withCString s $ \cstr -> peekUTFString cstr >>= \s' ->
+ if (valid cstr (-1) nullPtr) then return s' -- force any exceptions
+ else return s )
+ (\_e -> return s) -- if any, keep the local encoding
+
+-- from gutf8.c used in g_utf8_validate
+isUnicode c' = let c = ord c' in
+ c < 0x110000 &&
+ c .&. 0xFFFFF800 /= 0xD800 &&
+ (c < 0xFDD0 || c > 0xFDEF) &&
+ c .&. 0xFFFE /= 0xFFFE
+
+-- XXX which unicode characters must be escaped?
+turtle_escaped :: Char -> String -> String
+turtle_escaped _ [] = []
+turtle_escaped c ('\\':xs) = '\\':'\\':turtle_escaped c xs
+turtle_escaped c (x:xs) | c == x
+ = '\\': c:turtle_escaped c xs
+turtle_escaped c ('\n':xs) = '\\': 'n':turtle_escaped c xs
+turtle_escaped c ('\r':xs) = '\\': 'r':turtle_escaped c xs
+turtle_escaped c ('\t':xs) = '\\': 't':turtle_escaped c xs
+turtle_escaped c ( x:xs) = x:turtle_escaped c xs
+
+main = do [root,filepath] <- getArgs
+ 'h':'t':'t':'p':':':'/':'/':_ <- return root
+ irc <- getContents
+ timestamps <- getTimeStamps
+ mapM_ (uncurry $ handle root filepath) $ zip (map fromUTF$lines irc)
+ (uniquify timestamps)
+
+getTimeStamps = do ~(TOD secs _picos) <- unsafeInterleaveIO getClockTime
+ xs <- unsafeInterleaveIO getTimeStamps
+ return (TOD secs 0:xs)
+
+uniquify [] = []
+uniquify (x:xs) = (x,Nothing):uniquify' (x,Nothing) xs
+
+uniquify' _ [] = []
+uniquify' prev (x:xs) | fst prev == x = next prev:uniquify' (next prev) xs
+ | otherwise = first x:uniquify' (first x) xs
+ where next (i,offset) = (i, Just $ maybe (2::Integer) (+1) offset)
+ first i = (i, Nothing)
+
+handle :: String -> FilePath -> String -> (ClockTime, Maybe Integer) -> IO ()
+handle root filepath line (clockTime,offset) = do
+ let (file,output) = irc2rdf root filepath (clockTime,offset) line
+ maybe (return ()) ((flip appendFile) (toUTF output)) file
+
+irc2rdf :: String -> FilePath -> (ClockTime, Maybe Integer) -> String ->
+ (Maybe FilePath,String)
+irc2rdf root filepath time = uncurry (triples root filepath time) . parse
+
+parse (':':rest) = (Just $ takeWhile (/=' ') rest,
+ parse' "" (tail $ dropWhile (/=' ') rest))
+parse rest = (Nothing, parse' "" rest)
+
+parse' acc [] = [reverse acc]
+parse' acc ['\r'] = [reverse acc]
+parse' "" (':':xs) = [reverse . dropWhile (=='\r') $ reverse xs]
+parse' acc (' ':xs) = reverse acc : parse' "" xs
+parse' acc (x:xs) = parse' (x:acc) xs
+
+triples :: String -> FilePath -> (ClockTime, Maybe Integer) ->
+ Maybe String -> [String] -> (Maybe FilePath, String)
+triples root filepath (time,offset) (Just prefix) [cmd,target,msg]
+ | map toUpper cmd == "PRIVMSG",
+ '#':channel <- map toLower target, channel `elem` ["fenfire","sioc",
+ "swig","haskell"]
+ =
+ let file = channel ++ "-" ++ day
+ uri = root ++ file ++ "#" ++ second ++ maybe "" (('.':) . show) offset
+ in
+ (
+ Just (filepath++file)
+ ,
+ "<irc://freenode/%23"++channel++"> <"++isContainerOf++"> <"++uri++">.\n"++
+ "<irc://freenode/%23"++channel++"> <"++rdftype++"> <"++forum++">.\n"++
+ "<"++uri++"> <"++created++"> "++
+ t (day++"T"++second++"Z")++"^^<"++date++">.\n"++
+ "<"++uri++"> <"++hasCreator++"> <"++creator++">.\n"++
+ "<"++uri++"> <"++hasContent++"> "++t msg++".\n"++
+ "<"++uri++"> <"++label++"> "++t ("<"++nick++"> "++msg)++".\n"++
+ "<"++uri++"> <"++rdftype++"> <"++post++">.\n"++
+ "<"++creator++"> <"++label++"> "++t nick++".\n"++
+ "<"++creator++"> <"++rdftype++"> <"++user++">.\n"
+ )
+ where t str = "\"" ++ turtle_escaped '\"' str ++ "\""
+ label = "http://www.w3.org/2000/01/rdf-schema#label"
+ rdftype = "http://www.w3.org/1999/02/22-rdf-syntax-ns#type"
+ created = "http://purl.org/dc/terms/created"
+ isContainerOf = "http://rdfs.org/sioc/ns#is_container_of"
+ hasCreator = "http://rdfs.org/sioc/ns#has_creator"
+ hasContent = "http://rdfs.org/sioc/ns#has_content"
+ date = "http://www.w3.org/2001/XMLSchema#dateTime"
+ forum = "http://rdfs.org/sioc/ns#Forum"
+ post = "http://rdfs.org/sioc/ns#Post"
+ user = "http://rdfs.org/sioc/ns#User"
+ nick = takeWhile (/='!') prefix
+ creator = "irc://freenode/"++nick++",isuser"
+ (CalendarTime y moe d h m s _ps _wd _yd _tzn _tz _isDST)
+ = toUTCTime time
+ mo = (fromEnum moe+1)
+ p n i = take (n-length (show i)) (repeat '0') ++ show i
+ day = p 4 y ++ '-':p 2 mo ++ '-':p 2 d
+ second = p 2 h ++ ':':p 2 m ++ ':':p 2 s
+triples _ _ _ _ _ = (Nothing, "")
diff -rN -u old-fenfire-hs/Fenfire/Latex2Png.hs new-fenfire-hs/Fenfire/Latex2Png.hs
--- old-fenfire-hs/Fenfire/Latex2Png.hs 1970-01-01 02:00:00.000000000 +0200
+++ new-fenfire-hs/Fenfire/Latex2Png.hs 2007-03-13 16:04:04.000000000 +0200
@@ -0,0 +1,87 @@
+
+module Fenfire.Latex2Png where
+
+-- Copyright (c) 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 System.Cmd (rawSystem)
+import System.Environment (getArgs)
+import System.Directory (getTemporaryDirectory, getCurrentDirectory,
+ setCurrentDirectory, createDirectory, getDirectoryContents, removeFile,
+ removeDirectory, doesFileExist)
+import System.IO (openTempFile, openFile, hPutStr, hClose, IOMode(..))
+import System.Exit (ExitCode(..))
+
+import Control.Monad (when)
+
+import System.Glib.UTFString (newUTFString, readCString)
+import System.IO.Unsafe (unsafePerformIO)
+
+-- XXX real toUTF isn't exported from System.Glib.UTFString
+toUTF :: String -> String
+toUTF s = unsafePerformIO $ newUTFString s >>= readCString
+
+latex content = unlines [
+ "\\documentclass[12pt]{article}",
+ "\\pagestyle{empty}",
+ "\\usepackage[utf8]{inputenc}",
+ "\\begin{document}",
+ toUTF content,
+ "\\end{document}"
+ ]
+
+withLatexPng :: String -> (Maybe FilePath -> IO a) -> IO a
+withLatexPng code block = do
+ oldCurrentDirectory <- getCurrentDirectory
+ tmp <- getTemporaryDirectory
+ let dir = tmp ++ "/latex2png" -- FIXME / and predictable name
+ createDirectory dir
+ setCurrentDirectory dir
+
+ let latexFile = "latex2png-temp"
+ writeFile (latexFile++".tex") $ latex code
+ -- FIXME set environment variables necessary for security, use rlimit
+ rawSystem "latex" ["--interaction=nonstopmode", latexFile++".tex"]
+
+ rawSystem "dvipng" ["-bgTransparent", "-Ttight", "", "--noghostscript", "-l1", latexFile++".dvi"]
+
+ let resultname = latexFile++"1.png"
+
+ haveResult <- doesFileExist resultname
+ let resultfile = if haveResult then Just resultname else Nothing
+ result <- block $ resultfile
+
+ setCurrentDirectory tmp
+ files <- getDirectoryContents dir
+ flip mapM_ files $ \filename -> do
+ let file = dir ++ "/" ++ filename -- FIXME /
+ exists <- doesFileExist file -- XXX to ignore . and ..
+ when exists $ removeFile $ file
+ removeDirectory dir
+
+ setCurrentDirectory oldCurrentDirectory
+ return result
+
+main = do
+ [code,outfile] <- getArgs
+ handle <- openFile outfile WriteMode
+
+ png <- withLatexPng code $ maybe (return "") readFile
+
+ hPutStr handle png
+ hClose handle
diff -rN -u old-fenfire-hs/Fenfire/Main.hs new-fenfire-hs/Fenfire/Main.hs
--- old-fenfire-hs/Fenfire/Main.hs 1970-01-01 02:00:00.000000000 +0200
+++ new-fenfire-hs/Fenfire/Main.hs 2007-03-13 16:04:04.000000000 +0200
@@ -0,0 +1,733 @@
+module Fenfire.Main 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 Fenfire.Utils
+import Fenfire.Cairo hiding (Path, rotate)
+import Fenfire.Vobs
+import qualified Data.RDF.Raptor as Raptor
+import Fenfire.URN5
+import Data.RDF
+import Fenfire.VanishingView
+import Fenfire
+
+import Paths_fenfire (getDataFileName)
+
+import Control.Exception
+import Control.Monad
+import Control.Monad.State
+
+import Data.IORef
+import Data.Maybe (fromJust)
+import qualified Data.List as List
+import qualified Data.Set as Set
+import qualified Data.Map as Map
+
+import Fenfire.GtkFixes
+import Graphics.UI.Gtk hiding (Color, get, disconnect, fill,
+-- GtkFixes overrides:
+ actionNew,
+ widgetGetStyle,
+ styleGetForeground, styleGetBackground,
+ styleGetLight, styleGetMiddle, styleGetDark,
+ styleGetText, styleGetBase,
+ styleGetAntiAliasing)
+import Graphics.UI.Gtk.ModelView as New
+
+import qualified Network.URI
+
+import System.Directory (canonicalizePath)
+import System.Environment (getArgs, getProgName)
+
+interpretNode :: (?graph :: Graph) => String -> Node
+interpretNode str | "<" `List.isPrefixOf` str && ">" `List.isSuffixOf` str =
+ URI $ tail $ init str
+ | isQname
+ , Just base <- Map.lookup ns (graphNamespaces ?graph) =
+ URI $ base ++ local
+ | isQname = error $ "No such namespace: \""++ns++"\""
+ | otherwise = URI str
+ where local = drop 1 $ dropWhile (/= ':') str
+ ns = takeWhile (/= ':') str
+ isQname = ns /= "" && (not $ any (`elem` local) [':', '/', '@'])
+
+openFile :: (?vs :: ViewSettings) => FilePath ->
+ IO (Maybe (Graph, FilePath))
+openFile fileName0 = do
+ dialog <- fileChooserDialogNew Nothing Nothing FileChooserActionOpen
+ [(stockCancel, ResponseCancel),
+ (stockOpen, ResponseAccept)]
+ when (fileName0 /= "") $ do fileChooserSetFilename dialog fileName0
+ return ()
+ response <- dialogRun dialog
+ widgetHide dialog
+ case response of
+ ResponseAccept -> do Just fileName <- fileChooserGetFilename dialog
+ graph <- loadGraph fileName
+ return $ Just (graph, fileName)
+ _ -> return Nothing
+
+saveFile :: Graph -> FilePath -> Bool -> IO (FilePath,Bool)
+saveFile graph fileName0 confirmSame = do
+ dialog <- fileChooserDialogNew Nothing Nothing FileChooserActionSave
+ [(stockCancel, ResponseCancel),
+ (stockSave, ResponseAccept)]
+ fileChooserSetDoOverwriteConfirmation dialog True
+ dialogSetDefaultResponse dialog ResponseAccept
+ when (fileName0 /= "") $ do fileChooserSetFilename dialog fileName0
+ return ()
+ onConfirmOverwrite dialog $ do
+ Just fileName <- fileChooserGetFilename dialog
+ if fileName == fileName0 && not confirmSame
+ then return FileChooserConfirmationAcceptFilename
+ else return FileChooserConfirmationConfirm
+ response <- dialogRun dialog
+ widgetHide dialog
+ case response of
+ ResponseAccept -> do Just fileName <- fileChooserGetFilename dialog
+ let fileName' = checkSuffix fileName
+ saveGraph graph fileName'
+ return (fileName', True)
+ _ -> return (fileName0, False)
+
+checkSuffix :: FilePath -> FilePath
+checkSuffix s | List.isSuffixOf ".turtle" s = s
+ | otherwise = s ++ ".turtle"
+
+confirmSave :: (?vs :: ViewSettings, ?pw :: Window,
+ ?views :: Views, ?uriMaker :: URIMaker) =>
+ Bool -> HandlerAction FenState ->
+ HandlerAction FenState
+confirmSave False action = action
+confirmSave True action = do
+ response <- liftIO $ do
+ dialog <- makeConfirmUnsavedDialog
+ response' <- dialogRun dialog
+ widgetHide dialog
+ return response'
+ case response of ResponseClose -> action
+ ResponseAccept -> do
+ handleAction "save"
+ saved <- get >>= return . not . fsGraphModified
+ when (saved) action
+ _ -> return ()
+
+confirmRevert :: (?vs :: ViewSettings, ?pw :: Window) =>
+ Bool -> HandlerAction FenState ->
+ HandlerAction FenState
+confirmRevert False action = action
+confirmRevert True action = do
+ response <- liftIO $ do
+ dialog <- makeConfirmRevertDialog
+ response' <- dialogRun dialog
+ widgetHide dialog
+ return response'
+ case response of ResponseClose -> action
+ _ -> return ()
+
+confirmString :: (?vs :: ViewSettings, ?pw :: Window) =>
+ String -> String -> (String -> HandlerAction FenState) ->
+ HandlerAction FenState
+confirmString title preset action = do
+ (response,text) <- liftIO $ do
+ dialog <- makeDialog title
+ [(stockCancel, ResponseCancel),
+ (stockApply, ResponseAccept)]
+ ResponseAccept
+ entry <- entryNew
+ set entry [ entryText := preset, entryActivatesDefault := True ]
+ widgetShow entry
+ vBox <- dialogGetUpper dialog
+ boxPackStart vBox entry PackNatural 0
+ response' <- dialogRun dialog
+ text' <- entryGetText entry
+ widgetHide dialog
+ return (response',text')
+ case response of ResponseAccept -> action text
+ _ -> return ()
+handleEvent :: (?vs :: ViewSettings, ?pw :: Window, ?views :: Views,
+ ?uriMaker :: URIMaker) => Handler Event FenState
+handleEvent (Key { eventModifier=_mods, eventKeyName=key }) = do
+ state <- get; let graph = fsGraph state; fileName = fsFilePath state
+ case key of
+ x | x == "Up" || x == "i" -> handleAction "up"
+ x | x == "Down" || x == "comma" -> handleAction "down"
+ x | x == "Left" || x == "j" -> handleAction "left"
+ x | x == "Right" || x == "l" -> handleAction "right"
+ "v" -> handleAction "chgview"
+ "p" -> handleAction "resetprop"
+ "O" -> handleAction "open"
+ "S" -> do (fp',saved) <- liftIO $ saveFile graph fileName False
+ let modified' = fsGraphModified state && not saved
+ put $ state { fsFilePath = fp', fsGraphModified = modified' }
+ _ -> unhandledEvent
+handleEvent _ = unhandledEvent
+
+handleAction :: (?vs :: ViewSettings, ?pw :: Window, ?views :: Views,
+ ?uriMaker :: URIMaker) => Handler String FenState
+handleAction action = do
+ state@(FenState { fsGraph = graph, fsPath = path, fsMark = mark,
+ fsFilePath = filepath, fsGraphModified = modified,
+ fsHasFocus=focus
+ }) <- get
+ let ?graph = graph in do
+ let rot@(Rotation node _) = fsRotation state
+ b f x = maybeDo (f rot x) $ \rot' -> do
+ putRotation rot'
+ modify $ \s -> s { fsGraphModified = modified }
+ n f x = do state' <- liftIO (f x state); put state'; setInterp True
+ o f x = do put (f x state); setInterp True
+ case action of
+ "up" -> b rotate (-1) ; "down" -> b rotate 1
+ "left" -> b tryMove Neg ; "right" -> b tryMove Pos
+ "nodel" -> n newNode Neg ; "noder" -> n newNode Pos
+ "connl" -> o connect Neg ; "connr" -> o connect Pos
+ "breakl"-> o disconnect Neg ; "breakr"-> o disconnect Pos
+ "rmlit" -> putGraph (delLit node graph)
+ "mark" -> putMark $ toggleMark node mark
+ "new" -> confirmSave modified $ do
+ (g', path') <- liftIO newGraph
+ put $ newState g' path' "" focus
+ "open" -> confirmSave modified $ do
+ result <- liftIO $ openFile filepath
+ maybeDo result $ \(g',fp') -> do
+ uri <- liftM URI $ liftIO $ Raptor.filenameToURI fp'
+ let ts = containsInfoTriples uri g'
+ g'' = foldr insertVirtual g' ts
+ put $ newState g'' (findStartPath uri g'') fp' focus
+ "loadURI" -> case node of
+ URI uri -> do
+ g <- liftIO $ loadGraph uri
+ let ts = containsInfoTriples (URI uri) g
+ g' = foldr insertVirtual
+ (mergeGraphs graph g) ts
+ s' = state {fsGraph=g',
+ fsUndo=(graph,path):fsUndo state,
+ fsRedo=[]}
+ put s'
+ _ -> unhandledEvent
+ "revert" | filepath /= "" -> confirmRevert modified $ do
+ g' <- liftIO $ loadGraph filepath
+ gNode <- liftM URI $ liftIO $ Raptor.filenameToURI filepath
+ let g'' = foldr insertVirtual g' $ containsInfoTriples gNode g'
+ put $ newState g'' (findStartPath gNode g'') filepath focus
+ "save" | filepath /= "" -> do
+ liftIO $ saveGraph graph filepath
+ modify $ \s -> s { fsGraphModified = False }
+ | otherwise -> handleAction "saveas"
+ "saveas"-> do
+ (fp',saved) <- liftIO $ saveFile graph filepath True
+ let modified' = modified && not saved
+ modify $ \s -> s { fsFilePath = fp', fsGraphModified = modified' }
+ "quit" -> do confirmSave modified $ liftIO mainQuit
+ "about" -> liftIO $ makeAboutDialog >>= widgetShow
+ "chgview" -> do put $ state { fsView = (fsView state + 1) `mod`
+ (length ?views) }
+ setInterp True
+ "addprop" -> do let uri = case node of URI _ -> showNode
+ (graphNamespaces graph) node
+ _ -> ""
+ confirmString "Add property" uri $ \uri' ->
+ when (uri' /= "") $ do
+ let prop' = interpretNode uri'
+ props = fsProperties state
+ put $ state { fsProperty = prop',
+ fsProperties = Set.insert prop' props }
+ "resetprop" -> when (fsProperty state /= rdfs_seeAlso) $
+ put $ state { fsProperty = rdfs_seeAlso }
+ "changeURI" -> case node of
+ URI _ -> confirmString "New URI" (showNode
+ (graphNamespaces graph) node) $ \uri' ->
+ put $ stateReplaceNode node
+ (interpretNode uri') state
+ _ -> unhandledEvent
+ "undo" | (graph',path'):undos <- fsUndo state -> do
+ put state {fsGraph=graph', fsPath=path',
+ fsUndo=undos, fsRedo=(graph,path):fsRedo state}
+ setInterp True
+ "redo" | (graph',path'):redos <- fsRedo state -> do
+ put state {fsGraph=graph', fsPath=path',
+ fsUndo=(graph,path):fsUndo state, fsRedo=redos}
+ setInterp True
+ _ -> do liftIO $ putStrLn $ "Unhandled action: " ++ action
+ unhandledEvent
+ where putGraph g = do modify $ \s ->
+ s { fsGraph=g, fsGraphModified=True,
+ fsUndo=(fsGraph s, fsPath s):fsUndo s,
+ fsRedo=[]}
+ setInterp True
+ putRotation rot = do modify $ \s -> s { fsPath = toPath' rot }
+ setInterp True
+ putMark mk = do modify $ \state -> state { fsMark=mk }
+ delLit n graph = deleteAll n rdfs_label graph
+
+makeActions actionGroup accelGroup = do
+ let actionentries =
+ [ ( "new" , Nothing, stockNew , Nothing )
+ , ( "open" , Nothing, stockOpen , Nothing )
+ , ( "save" , Nothing, stockSave , Nothing )
+ , ( "saveas" , Nothing, stockSaveAs , Just "<Ctl><Shift>S" )
+ , ( "revert" , Nothing, stockRevertToSaved , Nothing )
+ , ( "quit" , Nothing, stockQuit , Nothing )
+ , ( "about" , Nothing, stockAbout , Nothing )
+ , ( "loadURI", Just "_Load node's URI",
+ stockGoForward , Just "<Ctl>L" )
+ , ( "undo" , Nothing, stockUndo , Just "<Ctl>Z" )
+ , ( "redo" , Nothing, stockRedo , Just "<Ctl><Shift>Z" )
+ ]
+ forM actionentries $ \(name,label',stock,accel) -> do
+ action <- actionNew name label' Nothing (Just stock)
+ actionGroupAddActionWithAccel actionGroup action accel
+ actionSetAccelGroup action accelGroup
+
+updateActions actionGroup stateRef = do
+ state <- readIORef stateRef
+ let readable = fsFilePath state /= ""
+ modified = fsGraphModified state
+ view = fst $ ?views !! (fsView state)
+
+ Just save <- actionGroupGetAction actionGroup "save"
+ actionSetSensitive save modified
+ Just revert <- actionGroupGetAction actionGroup "revert"
+ actionSetSensitive revert (modified && readable)
+ Just undo <- actionGroupGetAction actionGroup "undo"
+ actionSetSensitive undo (not $ null $ fsUndo state)
+ Just redo <- actionGroupGetAction actionGroup "redo"
+ actionSetSensitive redo (not $ null $ fsRedo state)
+ Just changeView <- actionGroupGetAction actionGroup view
+ toggleActionSetActive (castToToggleAction changeView) True
+
+updatePropMenu propmenu actionGroup stateRef updateCanvas = do
+ state <- readIORef stateRef
+ Just addProp <- actionGroupGetAction actionGroup "addprop"
+
+ menu <- menuNew
+ forM (Set.toAscList $ fsProperties state) $ \prop -> do
+ item <- let ?graph = fsGraph state
+ in menuItemNewWithLabel $ getTextOrURI prop
+ onActivateLeaf item $ do
+ modifyIORef stateRef $ \state' -> state' {fsProperty=prop}
+ updateCanvas False
+ menuShellAppend menu item
+ widgetShow item
+ sep <- separatorMenuItemNew
+ menuShellAppend menu sep
+ widgetShow sep
+ item <- actionCreateMenuItem addProp
+ menuShellAppend menu $ castToMenuItem item
+
+ menuItemSetSubmenu propmenu menu
+
+makeBindings actionGroup bindings = do
+ let bindingentries =
+ [ ("noder" , Just "_New node to right" ,
+ stockMediaForward , Just "n" )
+ , ("nodel" , Just "N_ew node to left" ,
+ stockMediaRewind , Just "<Shift>N" )
+ , ("breakr" , Just "_Break connection to right" ,
+ stockGotoLast , Just "b" )
+ , ("breakl" , Just "B_reak connection to left" ,
+ stockGotoFirst , Just "<Shift>B" )
+ , ("mark" , Just "Toggle _mark" ,
+ stockOk , Just "m" )
+ , ("connr" , Just "_Connect marked to right" ,
+ stockGoForward , Just "c" )
+ , ("connl" , Just "C_onnect marked to left" ,
+ stockGoBack , Just "<Shift>C" )
+ , ("rmlit" , Just "Remove _literal text" ,
+ stockStrikethrough , Just "<Alt>BackSpace" )
+ , ("addprop", Just "_Add property" ,
+ stockAdd , Just "<Ctl>P" )
+ , ("changeURI", Just "Change node's _URI" ,
+ stockRefresh , Just "u" )
+ ]
+ forM bindingentries $ \(name,label',stock,accel) -> do
+ action <- actionNew name label' Nothing (Just stock)
+ actionGroupAddActionWithAccel actionGroup action accel
+ actionSetAccelGroup action bindings
+
+makeMenus actionGroup root propmenu = addAll root menu where
+ menu = [m "_File" [a "new", a "open", a "loadURI", sep,
+ a "save", a "saveas", a "revert", sep,
+ a "quit"],
+ m "_Edit" [a "undo", a "redo", sep,
+ return propmenu, sep,
+ a "noder", a "nodel", sep,
+ a "breakr", a "breakl", sep,
+ a "mark", a "connr", a "connl", sep,
+ a "changeURI", a "rmlit"],
+ m "_View" (map (a . fst) ?views),
+ m "_Help" [a "about"]]
+ addAll parent items = mapM_ (menuShellAppend parent) =<< sequence items
+ m :: String -> [IO MenuItem] -> IO MenuItem
+ m name children = do item <- menuItemNewWithMnemonic name
+ menu' <- menuNew
+ addAll menu' children
+ menuItemSetSubmenu item menu'
+ return item
+ sep = liftM castToMenuItem separatorMenuItemNew
+ a name = do Just action <- actionGroupGetAction actionGroup name
+ item <- actionCreateMenuItem action
+ return (castToMenuItem item)
+
+makeToolbarItems actionGroup toolbar = do
+ forM_ ["new", "open", "save", "", "undo", "redo",""] $ \name ->
+ if name == "" then do
+ item <- separatorToolItemNew
+ toolbarInsert toolbar item (-1)
+ else do
+ Just action <- actionGroupGetAction actionGroup name
+ item <- actionCreateToolItem action
+ toolbarInsert toolbar (castToToolItem item) (-1)
+
+handleException :: Control.Exception.Exception -> IO ()
+handleException e = do
+ dialog <- makeMessageDialog "Exception in event" (show e)
+ dialogRun dialog
+ widgetHide dialog
+
+
+main :: IO ()
+main = do
+
+ uriMaker <- newURIMaker
+
+ -- initial state:
+
+ args <- initGUI
+
+ window <- windowNew
+ style <- widgetGetStyle window
+
+ bgColor <- styleGetBackground style StateSelected
+ blurBgColor <- styleGetBackground style StateActive
+ focusColor <- styleGetBase style StateSelected
+ blurColor <- styleGetBase style StateActive
+ textColor <- styleGetText style StateSelected
+ blurTextColor <- styleGetText style StateActive
+
+ canvasBgColor <- styleGetBackground style StateNormal
+
+ let alpha x (Color r g b a) = Color r g b (x*a)
+
+ let ?vs = ViewSettings { hiddenProps=[rdfs_label], maxCenter=3 }
+ ?uriMaker = uriMaker in let
+ ?views = [("Wheel view", vanishingView 20 30
+ (alpha 0.7 $ fromGtkColor bgColor)
+ (alpha 0.7 $ fromGtkColor blurBgColor)
+ (fromGtkColor focusColor) (fromGtkColor blurColor)
+ (fromGtkColor textColor) (fromGtkColor blurTextColor)),
+ ("Presentation view", presentationView)] in do
+
+ let view s = snd (?views !! fsView s) s
+
+ stateRef <- case args of
+ [] -> do
+ (g, rot) <- newGraph
+ newIORef $ newState g rot "" False
+ xs -> do
+ let f x | List.isPrefixOf "http:" x = return x
+ | otherwise = canonicalizePath x
+ fileName:fileNames <- mapM f xs
+ g' <- loadGraph fileName
+ gs <- mapM loadGraph fileNames
+ uri <- Raptor.filenameToURI fileName
+ uris <- mapM Raptor.filenameToURI fileNames
+ let ts = concatMap (uncurry containsInfoTriples) $
+ (URI uri, g') : zip (map URI uris) gs
+ graph = foldr insertVirtual (foldl mergeGraphs g' gs) ts
+ newIORef $ newState graph (findStartPath (URI uri) graph) fileName False
+
+ -- start:
+
+ makeWindow window canvasBgColor view stateRef
+ widgetShowAll window
+
+ mainGUI
+
+makeWindow window canvasBgColor view stateRef = do
+
+ -- main window:
+
+ let ?pw = window in mdo
+ logo <- getDataFileName "data-files/icon16.png"
+ Control.Exception.catch (windowSetIconFromFile window logo)
+ (\e -> putStr ("Opening "++logo++" failed: ") >> print e)
+ windowSetTitle window "Fenfire"
+ windowSetDefaultSize window 800 550
+
+ -- textview for editing:
+
+ textView <- textViewNew
+ textViewSetAcceptsTab textView False
+ textViewSetWrapMode textView WrapWordChar
+
+ -- this needs to be called whenever the node or its text changes:
+ let stateChanged _ state@(FenState { fsPath=Path n _, fsGraph=g }) = do
+ buf <- textBufferNew Nothing
+ textBufferSetText buf (let ?graph=g in maybe "" id $ getText n)
+ afterBufferChanged buf $ do
+ start <- textBufferGetStartIter buf
+ end <- textBufferGetEndIter buf
+ text <- textBufferGetText buf start end True
+ s@(FenState { fsGraph = g' }) <- readIORef stateRef
+ let g'' = setText n text g' -- buf corresponds to n, not to n'
+
+ writeIORef stateRef $
+ s { fsGraph=g'', fsGraphModified=True, fsRedo=[],
+ fsUndo=(fsGraph s, fsPath s):(fsUndo s) }
+ updateActions actionGroup stateRef
+ updateCanvas True
+
+ textViewSetBuffer textView buf
+ updatePropMenu propmenu actionGroup stateRef updateCanvas
+ New.listStoreClear propList
+ forM_ (Set.toAscList $ fsProperties state) $ \prop ->
+ let ?graph = g in
+ New.listStoreAppend propList (prop, getTextOrURI prop)
+ let activeIndex = List.elemIndex (fsProperty state)
+ (Set.toAscList $ fsProperties state)
+ maybe (return ()) (New.comboBoxSetActive combo) activeIndex
+
+ updateActions actionGroup stateRef
+
+ -- canvas for view:
+
+ (canvas, updateCanvas, canvasAction) <-
+ vobCanvas stateRef view handleEvent handleAction
+ stateChanged handleException (fromGtkColor canvasBgColor) 0.5
+
+ onFocusIn canvas $ \_event -> do
+ modifyIORef stateRef $ \s -> s { fsHasFocus = True }
+ forM_ bindingActions $ actionConnectAccelerator
+ updateCanvas True
+ return True
+ onFocusOut canvas $ \_event -> do
+ modifyIORef stateRef $ \s -> s { fsHasFocus = False }
+ forM_ bindingActions $ actionDisconnectAccelerator
+ updateCanvas True
+ return True
+
+ -- action widgets:
+
+ accelGroup <- accelGroupNew
+ windowAddAccelGroup window accelGroup
+ -- bindings are active only when the canvas has the focus:
+ bindings <- accelGroupNew
+ windowAddAccelGroup window bindings
+ -- fake bindings aren't used
+ fake <- accelGroupNew
+
+ actionGroup <- actionGroupNew "main"
+ bindingGroup <- actionGroupNew "bindings"
+
+ makeActions actionGroup accelGroup
+ makeBindings bindingGroup bindings
+ makeBindings actionGroup fake
+
+ actions <- actionGroupListActions actionGroup
+ bindingActions <- actionGroupListActions bindingGroup
+
+ forM_ (actions ++ bindingActions) $ \action -> do
+ name <- actionGetName action
+ onActionActivate action $ canvasAction name >> return ()
+
+ viewActs <- forM (zip [0..] ?views) $ \(index, (name, _view)) -> do
+ action <- radioActionNew name name Nothing Nothing index
+ actionGroupAddAction actionGroup action
+ onActionActivate action $ do
+ i <- radioActionGetCurrentValue action
+ state <- readIORef stateRef
+ when (i /= fsView state) $ do
+ writeIORef stateRef $ state { fsView = i }
+ updateCanvas True
+ return action
+
+ forM_ (tail viewActs) $ \x -> radioActionSetGroup x (head viewActs)
+ toggleActionSetActive (toToggleAction $ head viewActs) True
+
+ -- user interface widgets:
+
+ menubar <- menuBarNew
+ propmenu <- menuItemNewWithMnemonic "Set _property"
+ makeMenus actionGroup menubar propmenu
+
+ toolbar <- toolbarNew
+ makeToolbarItems actionGroup toolbar
+
+ propList <- New.listStoreNew []
+ combo <- New.comboBoxNew
+ set combo [ New.comboBoxModel := Just propList
+ , New.comboBoxFocusOnClick := False ]
+ renderer <- New.cellRendererTextNew
+ New.cellLayoutPackStart combo renderer True
+ New.cellLayoutSetAttributes combo renderer propList $ \row ->
+ [ New.cellText := snd row ]
+ New.onChanged combo $ do
+ active <- New.comboBoxGetActive combo
+ case active of
+ Nothing -> return ()
+ Just i -> do
+ (prop,_name) <- listStoreGetValue propList i
+ state' <- readIORef stateRef
+ writeIORef stateRef $ state' {fsProperty=prop}
+ when (fsProperty state' /= prop) $ updateCanvas False
+
+ comboLabel <- labelNew (Just "Property: ")
+
+ comboVBox <- hBoxNew False 0
+ boxPackStart comboVBox comboLabel PackNatural 0
+ boxPackStart comboVBox combo PackNatural 0
+
+ comboAlign <- alignmentNew 0.5 0.5 1 0
+ containerAdd comboAlign comboVBox
+
+ combotool <- toolItemNew
+ containerAdd combotool comboAlign
+ toolbarInsert toolbar combotool (-1)
+
+ sepItem <- separatorToolItemNew
+ toolbarInsert toolbar sepItem (-1)
+
+ Just addpropAction <- actionGroupGetAction actionGroup "addprop"
+ addpropItem <- actionCreateToolItem addpropAction
+ toolbarInsert toolbar (castToToolItem addpropItem) (-1)
+
+ -- layout:
+
+ canvasFrame <- frameNew
+ set canvasFrame [ containerChild := canvas
+ , frameShadowType := ShadowIn
+ ]
+
+ textViewFrame <- frameNew
+ set textViewFrame [ containerChild := textView
+ , frameShadowType := ShadowIn
+ ]
+
+ paned <- vPanedNew
+ panedAdd1 paned canvasFrame
+ panedAdd2 paned textViewFrame
+
+ vBox <- vBoxNew False 0
+ boxPackStart vBox menubar PackNatural 0
+ boxPackStart vBox toolbar PackNatural 0
+ boxPackStart vBox paned PackGrow 0
+ containerSetFocusChain vBox [toWidget paned]
+
+ set paned [ panedPosition := 380, panedChildResize textViewFrame := False ]
+
+ set window [ containerChild := vBox ]
+
+ -- start:
+
+ startState <- readIORef stateRef
+ stateChanged (startState { fsProperties = Set.empty }) startState
+
+ widgetGrabFocus canvas
+
+ onDelete window $ \_event -> canvasAction "quit"
+
+
+makeAboutDialog :: (?pw :: Window) => IO AboutDialog
+makeAboutDialog = do
+ dialog <- aboutDialogNew
+ logoFilename <- getDataFileName "data-files/logo.svg"
+ pixbuf <- Control.Exception.catch (pixbufNewFromFile logoFilename)
+ (\e -> return $ Left (undefined, show e))
+ logo <- case pixbuf of Left (_,msg) -> do
+ putStr ("Opening "++logoFilename++" failed: ")
+ putStrLn msg
+ return Nothing
+ Right pixbuf' -> return . Just =<<
+ pixbufScaleSimple pixbuf'
+ 200 (floor (200*(1.40::Double)))
+ InterpHyper
+ set dialog [ aboutDialogName := "Fenfire"
+ , aboutDialogVersion := "alpha version"
+ , aboutDialogCopyright := "Licensed under GNU GPL v2 or later"
+ , aboutDialogComments :=
+ "An application for notetaking and RDF graph browsing."
+ , aboutDialogLogo := logo
+ , aboutDialogWebsite := "http://fenfire.org"
+ , aboutDialogAuthors := ["Benja Fallenstein", "Tuukka Hastrup"]
+ , windowTransientFor := ?pw
+ ]
+ onResponse dialog $ \_response -> widgetHide dialog
+ return dialog
+
+makeDialog :: (?pw :: Window) => String -> [(String, ResponseId)] ->
+ ResponseId -> IO Dialog
+makeDialog title buttons preset = do
+ dialog <- dialogNew
+ set dialog [ windowTitle := title
+ , windowTransientFor := ?pw
+ , windowModal := True
+ , windowDestroyWithParent := True
+ , dialogHasSeparator := False
+ ]
+ mapM_ (uncurry $ dialogAddButton dialog) buttons
+ dialogSetDefaultResponse dialog preset
+ return dialog
+
+makeConfirmUnsavedDialog :: (?pw :: Window) => IO Dialog
+makeConfirmUnsavedDialog = do
+ makeDialog "Confirm unsaved changes"
+ [("_Discard changes", ResponseClose),
+ (stockCancel, ResponseCancel),
+ (stockSave, ResponseAccept)]
+ ResponseAccept
+
+makeConfirmRevertDialog :: (?pw :: Window) => IO Dialog
+makeConfirmRevertDialog = do
+ makeDialog "Confirm revert"
+ [(stockCancel, ResponseCancel),
+ (stockRevertToSaved,ResponseClose)]
+ ResponseCancel
+
+makeMessageDialog primary secondary = do
+ dialog <- dialogNew
+ set dialog [ windowTitle := primary
+ , windowModal := True
+ , containerBorderWidth := 6
+ , dialogHasSeparator := False
+ ]
+ image' <- imageNewFromStock stockDialogError iconSizeDialog
+ set image' [ miscYalign := 0.0 ]
+ label' <- labelNew $ Just $ "<span weight=\"bold\" size=\"larger\">"++
+ escapeMarkup primary++"</span>\n\n"++escapeMarkup secondary
+ set label' [ labelUseMarkup := True
+ , labelWrap := True
+ , labelSelectable := True
+ , miscYalign := 0.0
+ ]
+ hBox <- hBoxNew False 0
+ set hBox [ boxSpacing := 12
+ , containerBorderWidth := 6
+ ]
+ boxPackStart hBox image' PackNatural 0
+ boxPackStart hBox label' PackNatural 0
+
+ vBox <- dialogGetUpper dialog
+ set vBox [ boxSpacing := 12 ]
+ boxPackStart vBox hBox PackNatural 0
+
+ dialogAddButton dialog stockOk ResponseAccept
+ widgetShowAll hBox
+ return dialog
diff -rN -u old-fenfire-hs/Fenfire/URN5.hs new-fenfire-hs/Fenfire/URN5.hs
--- old-fenfire-hs/Fenfire/URN5.hs 1970-01-01 02:00:00.000000000 +0200
+++ new-fenfire-hs/Fenfire/URN5.hs 2007-03-13 16:04:04.000000000 +0200
@@ -0,0 +1,36 @@
+module Fenfire.URN5 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 Data.IORef
+import System.Random (randomRIO)
+
+type URIMaker = (String, IORef Integer)
+
+newURIMaker :: IO URIMaker
+newURIMaker = do rand <- sequence [randomRIO (0,63) | _ <- [1..27::Int]]
+ let chars = ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ "+-"
+ ref <- newIORef 1
+ return ("urn:urn-5:" ++ map (chars !!) rand, ref)
+
+newURI :: (?uriMaker :: URIMaker) => IO String
+newURI = do let (base, ref) = ?uriMaker
+ i <- readIORef ref; writeIORef ref (i+1)
+ return (base ++ ":_" ++ show i)
+
diff -rN -u old-fenfire-hs/Fenfire/Utils.hs new-fenfire-hs/Fenfire/Utils.hs
--- old-fenfire-hs/Fenfire/Utils.hs 1970-01-01 02:00:00.000000000 +0200
+++ new-fenfire-hs/Fenfire/Utils.hs 2007-03-13 16:04:04.000000000 +0200
@@ -0,0 +1,171 @@
+-- For (instance MonadReader w m => MonadReader w (MaybeT m)) in GHC 6.6:
+{-# OPTIONS_GHC -fglasgow-exts -fallow-undecidable-instances -fallow-overlapping-instances #-}
+module Fenfire.Utils 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 Control.Applicative
+import Control.Monad
+import Control.Monad.List
+import Control.Monad.Reader
+import Control.Monad.State
+import Control.Monad.Trans
+import Control.Monad.Writer (WriterT(..), MonadWriter(..), execWriterT)
+
+import Data.Maybe (fromMaybe)
+import Data.Monoid (Monoid(..))
+
+import qualified System.Time
+
+
+-- just what the rhs says, a function from a type to itself
+type Endo a = a -> a
+
+type EndoM m a = a -> m a
+type Op a = a -> a -> a
+
+type Time = Double -- seconds since the epoch
+type TimeDiff = Double -- in seconds
+
+
+avg :: Fractional a => Op a
+avg x y = (x+y)/2
+
+
+infixl 9 !?
+
+(!?) :: [a] -> Int -> Maybe a
+l !? i | i < 0 = Nothing
+ | i >= length l = Nothing
+ | otherwise = Just (l !! i)
+
+
+maybeReturn :: MonadPlus m => Maybe a -> m a
+maybeReturn = maybe mzero return
+
+returnEach :: MonadPlus m => [a] -> m a
+returnEach = msum . map return
+
+maybeDo :: Monad m => Maybe a -> (a -> m ()) -> m ()
+maybeDo m f = maybe (return ()) f m
+
+
+getTime :: IO Time
+getTime = do (System.Time.TOD secs picosecs) <- System.Time.getClockTime
+ return $ fromInteger secs + fromInteger picosecs / (10**(3*4))
+
+
+(&) :: Monoid m => m -> m -> m
+(&) = mappend
+
+
+funzip :: Functor f => f (a,b) -> (f a, f b)
+funzip x = (fmap fst x, fmap snd x)
+
+ffor :: Functor f => f a -> (a -> b) -> f b
+ffor = flip fmap
+
+for :: [a] -> (a -> b) -> [b]
+for = flip map
+
+forA2 :: Applicative f => f a -> f b -> (a -> b -> c) -> f c
+forA2 x y f = liftA2 f x y
+
+forA3 :: Applicative f => f a -> f b -> f c -> (a -> b -> c -> d) -> f d
+forA3 a b c f = liftA3 f a b c
+
+
+newtype Comp f g a = Comp { fromComp :: f (g a) }
+
+instance (Functor f, Functor g) => Functor (Comp f g) where
+ fmap f (Comp m) = Comp (fmap (fmap f) m)
+
+instance (Applicative f, Applicative g) => Applicative (Comp f g) where
+ pure = Comp . pure . pure
+ Comp f <*> Comp x = Comp $ forA2 f x (<*>)
+
+
+newtype BreadthT m a = BreadthT { runBreadthT :: WriterT [BreadthT m ()] m a }
+
+scheduleBreadthT :: Monad m => BreadthT m a -> BreadthT m ()
+scheduleBreadthT m = BreadthT $ tell [m >> return ()]
+
+execBreadthT :: Monad m => BreadthT m a -> m ()
+execBreadthT m = do rest <- execWriterT (runBreadthT m)
+ when (not $ null rest) $ execBreadthT (sequence_ rest)
+
+instance Monad m => Monad (BreadthT m) where
+ return = BreadthT . return
+ m >>= f = BreadthT (runBreadthT m >>= runBreadthT . f)
+
+instance MonadTrans BreadthT where
+ lift = BreadthT . lift
+
+instance MonadState s m => MonadState s (BreadthT m) where
+ get = lift $ get
+ put = lift . put
+
+instance MonadWriter w m => MonadWriter w (BreadthT m) where
+ tell = lift . tell
+ listen m = BreadthT $ WriterT $ do
+ ((x,w),w') <- listen $ runWriterT (runBreadthT m)
+ return ((x,w'),w)
+ pass m = BreadthT $ WriterT $ pass $ do
+ ((x,f),w) <- runWriterT (runBreadthT m)
+ return ((x,w),f)
+
+
+newtype MaybeT m a = MaybeT { runMaybeT :: m (Maybe a) }
+
+instance Monad m => Monad (MaybeT m) where
+ return x = MaybeT $ return (Just x)
+ m >>= f = MaybeT $ do x <- runMaybeT m
+ maybe (return Nothing) (runMaybeT . f) x
+ fail _ = mzero
+
+instance MonadTrans MaybeT where
+ lift m = MaybeT $ do x <- m; return (Just x)
+
+instance Monad m => MonadPlus (MaybeT m) where
+ mzero = MaybeT $ return Nothing
+ mplus m n = MaybeT $ do
+ x <- runMaybeT m; maybe (runMaybeT n) (return . Just) x
+
+instance MonadReader r m => MonadReader r (MaybeT m) where
+ ask = lift ask
+ local f m = MaybeT $ local f (runMaybeT m)
+
+instance MonadWriter w m => MonadWriter w (MaybeT m) where
+ tell = lift . tell
+ listen m = MaybeT $ do (x,w) <- listen $ runMaybeT m
+ return $ maybe Nothing (\x' -> Just (x',w)) x
+ pass m = MaybeT $ pass $ do
+ x <- runMaybeT m; return $ maybe (Nothing,id) (\(y,f) -> (Just y,f)) x
+
+callMaybeT :: Monad m => MaybeT m a -> MaybeT m (Maybe a)
+callMaybeT = lift . runMaybeT
+
+
+instance MonadWriter w m => MonadWriter w (ListT m) where
+ tell = lift . tell
+ listen m = ListT $ do (xs,w) <- listen $ runListT m
+ return [(x,w) | x <- xs]
+ pass m = ListT $ pass $ do -- not ideal impl, but makes 'censor' work
+ ps <- runListT m
+ return $ if null ps then ([], id) else (map fst ps, snd (head ps))
diff -rN -u old-fenfire-hs/Fenfire/VanishingView.fhs new-fenfire-hs/Fenfire/VanishingView.fhs
--- old-fenfire-hs/Fenfire/VanishingView.fhs 1970-01-01 02:00:00.000000000 +0200
+++ new-fenfire-hs/Fenfire/VanishingView.fhs 2007-03-13 16:04:04.000000000 +0200
@@ -0,0 +1,163 @@
+module Fenfire.VanishingView 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 Fenfire.Utils
+import Fenfire.Cairo hiding (Path, rotate)
+import Fenfire.Vobs
+import Data.RDF
+import Fenfire
+
+import Control.Monad
+import Control.Monad.Reader
+import Control.Monad.State
+import Control.Monad.Writer
+
+import Data.Monoid
+import Data.Set (Set)
+import qualified Data.Set as Set
+
+vanishingView :: (?vs :: ViewSettings) => Int -> Int -> Color -> Color ->
+ Color -> Color ->
+ Color -> Color -> FenState -> Vob Node
+vanishingView depth maxnodes bgColor blurBgColor focusColor blurColor
+ textColor blurTextColor
+ state@(FenState {fsGraph=graph, fsPath=path, fsMark=mark,
+ fsHasFocus=focus}) =
+ let ?graph = graph in result where
+ startRotation :: (?graph :: Graph) => Rotation
+ startRotation = fsRotation state
+ result :: (?graph :: Graph) => Vob Node
+ result = runVanishing depth maxnodes view where
+ -- place the center of the view and all subtrees in both directions
+ view = do placeNode (if focus then Just (bgColor, focusColor, textColor)
+ else Just (blurBgColor, blurColor, blurTextColor))
+ startRotation
+ let Rotation n _ = startRotation in visitNode n
+ forM_ [Pos, Neg] $ \dir -> do
+ placeConns startRotation dir True
+ -- place all subtrees in xdir
+ placeConns rotation xdir placeFirst = withDepthIncreased 1 $ do
+ when placeFirst $ placeConn rotation xdir
+ forM_ [-1, 1] $ \ydir -> do
+ placeConns' rotation xdir ydir
+ -- place rest of the subtrees in (xdir, ydir)
+ placeConns' rotation xdir ydir = withDepthIncreased 1 $
+ maybeDo (rotate rotation ydir) $ \rotation' -> do
+ withAngleChanged (fromIntegral ydir * mul xdir pi / 14) $ do
+ placeConn rotation' xdir
+ placeConns' rotation' xdir ydir
+ -- place one subtree
+ placeConn rotation@(Rotation n1 _) dir = withDepthIncreased 1 $
+ maybeDo (toPath rotation dir) $ \path'@(Path _ [Conn prop _ n2]) -> do
+ let rotation' = fromPath (rev path')
+ scale' <- getScale
+ withCenterMoved dir (280 * (scale'**3)) $ do
+ ifUnvisited n2 $ placeNode Nothing rotation'
+ let (nl,nr) = if dir==Pos then (n1,n2) else (n2,n1)
+ addVob $ between (center @@ nl) (center @@ nr) $ ownSize $
+ centerVob $ scale #scale' $ propView prop
+ addVob $ useFgColor $ stroke $
+ line (center @@ nl) (center @@ nr)
+ ifUnvisited n2 $ visitNode n2 >> do
+ placeConns rotation' dir True
+ withDepthIncreased 3 $
+ placeConns rotation' (rev dir) False
+ -- place one node view
+ placeNode cols (Rotation node _) = do
+ scale' <- getScale
+ let f vob = case bg of Nothing -> vob
+ Just c -> setFgColor fg $
+ setBgColor c vob
+ markColor = if node `Set.member` mark then Just (Color 1 0 0 1)
+ else Nothing
+ bg = combine (fmap (\(_,b,_) -> b) cols) markColor
+ fg = maybe (Color 0 0 0 1) (\(_,_,c) -> c) cols
+ combine Nothing c = c
+ combine c Nothing = c
+ combine (Just c1) (Just c2) = Just $ interpolate 0.5 c1 c2
+ g vob = case cols of Nothing -> vob
+ Just (a,_,_) -> frame a & vob
+ where (w,h) = defaultSize vob
+ frame c = withColor #c $ fill $
+ moveTo (point #(0-10) #(0-10)) &
+ lineTo (point #(w+10) #(0-10)) &
+ lineTo (point #(w+10) #(h+10)) &
+ lineTo (point #(0-10) #(h+10)) &
+ closePath
+ placeVob $ ownSize $ scale #scale' $ keyVob node $ g $
+ f (useBgColor (fill extents) & pad 5 (nodeView node)) &
+ useFgColor (stroke extents)
+
+ getScale :: VV Double
+ getScale = do d <- asks vvDepth; return (0.97 ** fromIntegral d)
+
+
+data VVState = VVState { vvDepth :: Int, vvMaxDepth :: Int, vvMaxNodes :: Int,
+ vvX :: Double, vvY :: Double, vvAngle :: Double }
+
+type VV a = ReaderT VVState (BreadthT (StateT (Set Node)
+ (Writer (Dual (Vob Node))))) a
+
+runVanishing :: Int -> Int -> VV () -> Vob Node
+runVanishing maxdepth maxnodes vv = comb (0,0) $ \cx ->
+ let (w,h) = rcSize cx
+ in getDual $ execWriter $ flip execStateT Set.empty $ execBreadthT $
+ runReaderT vv $ VVState 0 maxdepth maxnodes (w/2) (h/2) 0
+
+-- |Execute the passed action with the recursion depth increased by
+-- the given amount of steps, if it is still smaller than the maximum
+-- recursion depth.
+--
+withDepthIncreased :: Int -> VV () -> VV ()
+withDepthIncreased n m = do
+ state <- ask; let state' = state { vvDepth = vvDepth state + n }
+ if vvDepth state' >= vvMaxDepth state' then return () else
+ lift $ scheduleBreadthT $ flip runReaderT state' $ do
+ visited <- get
+ when (Set.size visited <= (4 * vvMaxNodes state') `div` 3) m
+
+visitNode :: Node -> VV ()
+visitNode n = modify (Set.insert n)
+
+ifUnvisited :: Node -> VV () -> VV ()
+ifUnvisited n m = do visited <- get
+ when (not $ n `Set.member` visited) m
+
+addVob :: Vob Node -> VV ()
+addVob vob = do d <- asks vvDepth; md <- asks vvMaxDepth
+ mn <- asks vvMaxNodes; visited <- get
+ let x = (fromIntegral (md - d) / fromIntegral (md+2))
+ vob' = if Set.size visited >= mn then invisibleVob vob
+ else fade x vob
+ tell (Dual vob')
+
+placeVob :: Vob Node -> VV ()
+placeVob vob = do
+ state <- ask
+ addVob $ translate #(vvX state) #(vvY state) $ centerVob vob
+
+withCenterMoved :: Dir -> Double -> VV () -> VV ()
+withCenterMoved dir distance = local f where
+ distance' = mul dir distance
+ f s = s { vvX = vvX s + distance' * cos (vvAngle s),
+ vvY = vvY s + distance' * sin (vvAngle s) }
+
+withAngleChanged :: Double -> VV () -> VV ()
+withAngleChanged delta = local $ \s -> s { vvAngle = vvAngle s + delta }
diff -rN -u old-fenfire-hs/Fenfire/VobTest.fhs new-fenfire-hs/Fenfire/VobTest.fhs
--- old-fenfire-hs/Fenfire/VobTest.fhs 1970-01-01 02:00:00.000000000 +0200
+++ new-fenfire-hs/Fenfire/VobTest.fhs 2007-03-13 16:04:04.000000000 +0200
@@ -0,0 +1,174 @@
+module Fenfire.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 Fenfire.Utils
+import Fenfire.Cairo
+import Fenfire.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
+ (\_ -> return ())
+ (\_ _ -> return ())
+ (\_ -> return ())
+ lightGray 3
+
+ set window [ containerChild := canvas ]
+
+ onDestroy window mainQuit
+ widgetShowAll window
+ mainGUI
diff -rN -u old-fenfire-hs/Fenfire/Vobs.fhs new-fenfire-hs/Fenfire/Vobs.fhs
--- old-fenfire-hs/Fenfire/Vobs.fhs 1970-01-01 02:00:00.000000000 +0200
+++ new-fenfire-hs/Fenfire/Vobs.fhs 2007-03-13 16:04:04.000000000 +0200
@@ -0,0 +1,457 @@
+{-# OPTIONS_GHC -fallow-overlapping-instances #-}
+module Fenfire.Vobs 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 Fenfire.Utils
+
+import Fenfire.Cairo
+
+import Fenfire.Latex2Png
+import qualified Fenfire.Cache as Cache
+
+import Data.IORef
+import System.IO.Unsafe (unsafePerformIO)
+import qualified System.Time
+
+import Control.Applicative
+import Control.Monad.Reader
+import Control.Monad.Trans (liftIO, MonadIO)
+
+import Graphics.UI.Gtk hiding (Point, Size, Layout, Color, get, fill)
+import qualified Graphics.Rendering.Cairo as C
+import Graphics.Rendering.Cairo.Matrix (Matrix(Matrix))
+import qualified Graphics.Rendering.Cairo.Matrix as Matrix
+import Graphics.UI.Gtk.Cairo
+
+import Data.List (intersect)
+import Data.Map (Map, keys, fromList, toList, insert, empty)
+import qualified Data.Map as Map
+import Data.Maybe (fromMaybe, isJust)
+import Data.Monoid (Monoid(mempty, mappend, mconcat))
+
+import Control.Monad (when)
+import Control.Monad.State
+import Control.Monad.Reader
+
+import qualified Control.Exception
+
+type Scene k = Map k (Maybe (Matrix, Size))
+data Vob k = Vob { defaultSize :: Size,
+ vobScene :: RenderContext k -> Scene k,
+ renderVob :: RenderContext k -> Render () }
+
+type Cx k = MaybeT (Reader (RenderContext k))
+
+runCx :: RenderContext k -> Cx k a -> Maybe a
+runCx cx m = runReader (runMaybeT m) cx
+
+data RenderContext k = RenderContext {
+ rcRect :: Rect, rcScene :: Scene k, rcFade :: Double,
+ rcFgColor :: Color, rcBgColor :: Color, rcFadeColor :: Color }
+
+rcMatrix = fst . rcRect; rcSize = snd . rcRect
+
+type View s k = s -> Vob k
+type Handler e s = e -> HandlerAction s
+
+type HandlerAction s = StateT s (StateT (Bool, Bool) IO) ()
+
+
+instance Ord k => Monoid (Vob k) where
+ mempty = Vob (0,0) (const Map.empty) (const $ return ())
+ mappend (Vob (w1,h1) sc1 r1) (Vob (w2,h2) sc2 r2) = Vob (w,h) sc r where
+ (w,h) = (max w1 w2, max h1 h2)
+ sc cx = Map.union (sc1 cx) (sc2 cx)
+ r cx = r1 cx >> r2 cx
+
+instance Functor (Cx k) where fmap = liftM
+instance Applicative (Cx k) where
+ pure = return
+ (<*>) = ap
+
+instance Ord k => Cairo (Cx k) (Vob k) where
+ cxAsk = asks rcRect
+
+ cxLocal rect m = do rect' <- rect; local (\cx -> cx { rcRect = rect' }) m
+
+ cxWrap f (Vob size sc ren) =
+ Vob size sc $ \cx -> maybeDo (runCx cx $ f $ ren cx) id
+
+ cxLocalR rect (Vob size sc ren) = Vob size
+ (\cx -> let msc = liftM sc (upd cx)
+ in Map.mapWithKey (\k _ -> msc >>= (Map.! k)) (sc cx))
+ (\cx -> maybe (return ()) ren (upd cx))
+ where upd cx = do rect' <- runCx cx rect
+ return $ cx { rcRect = rect' }
+
+
+defaultWidth (Vob (w,_) _ _) = w
+defaultHeight (Vob (_,h) _ _) = h
+
+
+setInterp :: Bool -> HandlerAction s
+setInterp interp = lift $ modify $ \(_,handled) -> (interp, handled)
+
+unhandledEvent :: HandlerAction s
+unhandledEvent = lift $ modify $ \(interp,_) -> (interp, False)
+
+runHandler handleEvent state event = do
+ (((), state'), (interpolate', handled)) <-
+ runStateT (runStateT (handleEvent event) state) (False, True)
+ return (state',interpolate',handled)
+
+
+(@@) :: Ord k => Cx k a -> k -> Cx k a -- pronounce as 'of'
+(@@) x key = do cx <- ask
+ rect <- maybeReturn =<< Map.lookup key (rcScene cx)
+ local (\_ -> cx { rcRect = rect }) x
+
+
+changeSize :: Ord k => Endo Size -> Endo (Vob k)
+changeSize f vob = vob { defaultSize = f $ defaultSize vob }
+
+changeContext :: Ord k => Endo (RenderContext k) -> Endo (Vob k)
+changeContext f (Vob s sc r) = Vob s (sc . f) (r . f)
+
+changeRect :: Ord k => Endo Rect -> Endo (Vob k)
+changeRect f = changeContext (\cx -> cx { rcRect = f $ rcRect cx })
+
+ownSize :: Ord k => Endo (Vob k)
+ownSize vob = changeRect (\(m,_) -> (m, defaultSize vob)) vob
+
+invisibleVob :: Ord k => Endo (Vob k)
+invisibleVob = cxWrap (const mempty)
+
+
+comb :: Size -> (RenderContext k -> Vob k) -> Vob k
+comb size f =
+ Vob size (\cx -> vobScene (f cx) cx) (\cx -> renderVob (f cx) cx)
+
+renderable :: Ord k => Size -> Render () -> Vob k
+renderable size ren = Vob size (const Map.empty) $ \cx -> do
+ do C.save; C.transform (rcMatrix cx); ren; C.restore
+
+
+keyVob :: Ord k => k -> Endo (Vob k)
+keyVob key vob = vob {
+ vobScene = \cx -> Map.insert key (Just $ rcRect cx) (vobScene vob cx),
+ renderVob = \cx ->
+ maybeDo (maybeReturn =<< (Map.lookup key $ rcScene cx)) $ \rect ->
+ renderVob vob $ cx { rcRect = rect } }
+
+showAtKey :: Ord k => k -> Endo (Vob k)
+showAtKey key vob = vob {
+ vobScene = \cx -> let mrect = maybeReturn =<< Map.lookup key (rcScene cx)
+ mcx = fmap (\rect' -> cx { rcRect=rect' }) mrect
+ msc = liftM (vobScene vob) mcx
+ in Map.mapWithKey (\k _ -> msc >>= (Map.! k))
+ (vobScene vob cx),
+ renderVob = \cx ->
+ maybeDo (maybeReturn =<< (Map.lookup key $ rcScene cx)) $ \rect ->
+ renderVob vob $ cx { rcRect = rect } }
+
+
+rectBox :: Ord k => Endo (Vob k)
+rectBox vob = useBgColor (fill extents) & clip extents vob &
+ useFgColor (stroke extents)
+
+vbox :: Ord k => [Vob k] -> Vob k
+vbox vobs = mconcat [translate #0 #y $ ownSize v | (v,y) <- zip vobs ys] where
+ ys = scanl (+) 0 $ map defaultHeight $ init vobs
+
+
+pangoContext :: PangoContext
+pangoContext = unsafePerformIO $ do
+ context <- cairoCreateContext Nothing
+ desc <- contextGetFontDescription context
+ fontDescriptionSetFamily desc "Sans"
+ fontDescriptionSetSize desc (fromInteger 10)
+ contextSetFontDescription context desc
+ return context
+
+
+label :: Ord k => String -> Vob k
+label s = unsafePerformIO $ do
+ layout <- layoutText pangoContext s
+ (PangoRectangle _ _ w1 h1, PangoRectangle _ _ w2 h2)
+ <- layoutGetExtents layout
+ let w = max w1 w2; h = max h1 h2
+ return $ renderable (realToFrac w, realToFrac h) $ showLayout layout
+
+multiline :: Ord k => Bool -> Int -> String -> Vob k
+multiline useTextWidth widthInChars s = unsafePerformIO $ do
+ layout <- layoutText pangoContext s
+ layoutSetWrap layout WrapPartialWords
+ desc <- contextGetFontDescription pangoContext
+ lang <- languageFromString s
+ (FontMetrics {approximateCharWidth=cw, ascent=ascent', descent=descent'})
+ <- contextGetMetrics pangoContext desc lang
+ let w1 = fromIntegral widthInChars * cw
+ h1 = ascent' + descent'
+ layoutSetWidth layout (Just w1)
+ (PangoRectangle _ _ w2 h2, PangoRectangle _ _ w3 h3)
+ <- layoutGetExtents layout
+ let w = if useTextWidth then max w2 w3 else w1
+ h = maximum [h1, h2, h3]
+ return $ renderable (realToFrac w, realToFrac h) $ showLayout layout
+
+getSurfaceSize :: C.Surface -> IO (Int,Int)
+getSurfaceSize surface = do
+ w <- C.renderWith surface $ C.imageSurfaceGetWidth surface
+ h <- C.renderWith surface $ C.imageSurfaceGetHeight surface
+ return (w,h)
+
+createImageSurfaceFromPNG :: FilePath -> IO C.Surface
+createImageSurfaceFromPNG file =
+ C.withImageSurfaceFromPNG file $ \surface -> do
+ (w,h) <- getSurfaceSize surface
+ surface' <- C.createImageSurface C.FormatARGB32 w h
+ C.renderWith surface' $ do
+ C.setSourceSurface surface 0 0
+ C.rectangle 0 0 (realToFrac w) (realToFrac h)
+ C.fill
+ return surface'
+
+-- image :: Ord k => FilePath -> Vob k
+image file = {- unsafePerformIO $ -} do
+ surface <- createImageSurfaceFromPNG file
+ (w,h) <- getSurfaceSize surface
+ return $ changeSize (const (realToFrac w, realToFrac h)) $
+ withSurface #surface $ fill extents
+
+latexCache :: Cache.Cache String (Vob k)
+latexCache = Cache.newCache 10000
+
+latex :: Ord k => String -> Vob k
+latex code = Cache.cached code latexCache $ unsafePerformIO $ do
+ withLatexPng code $ maybe (return $ setFgColor (Color 0.7 0.5 0.1 1)
+ $ useFgColor $ multiline False 20 code)
+ ({- return . -} image)
+
+fadedColor :: Ord k => Endo (Cx k Color)
+fadedColor c = liftM3 interpolate (asks rcFade) (asks rcFadeColor) c
+
+setFgColor :: Ord k => Color -> Endo (Vob k)
+setFgColor c = changeContext $ \cx -> cx { rcFgColor = c }
+
+setBgColor :: Ord k => Color -> Endo (Vob k)
+setBgColor c = changeContext $ \cx -> cx { rcBgColor = c }
+
+useFgColor :: Ord k => Endo (Vob k)
+useFgColor = withColor (fadedColor $ asks rcFgColor)
+
+useBgColor :: Ord k => Endo (Vob k)
+useBgColor = withColor (fadedColor $ asks rcBgColor)
+
+useFadeColor :: Ord k => Endo (Vob k)
+useFadeColor = withColor (asks rcFadeColor)
+
+fade :: Ord k => Double -> Endo (Vob k)
+fade a = changeContext $ \cx -> cx { rcFade = rcFade cx * a }
+
+
+centerVob :: Ord k => Endo (Vob k)
+centerVob vob = translate (pure (-w/2)) (pure (-h/2)) vob
+ where (w,h) = defaultSize vob
+
+
+pad4 :: Ord k => Double -> Double -> Double -> Double -> Endo (Vob k)
+pad4 x1 x2 y1 y2 vob =
+ changeSize (const (x1+w+x2, y1+h+y2)) $
+ changeRect (\(m,(w',h')) -> (f m, (w'-x1-x2, h'-y1-y2))) vob
+ where (w,h) = defaultSize vob; f = Matrix.translate x1 y1
+
+pad2 :: Ord k => Double -> Double -> Endo (Vob k)
+pad2 x y = pad4 x x y y
+
+pad :: Ord k => Double -> Endo (Vob k)
+pad pixels = pad2 pixels pixels
+
+scaleVob :: Ord k => Double -> Endo (Vob k)
+scaleVob sc vob = scale #sc $ vob { defaultSize = (sc*w, sc*h) } where
+ (w,h) = defaultSize vob
+
+
+class Interpolate a where
+ interpolate :: Double -> Op a
+
+instance Interpolate Double where
+ interpolate fract x y = (1-fract)*x + fract*y
+
+instance Interpolate Color where
+ interpolate fract (Color r g b a) (Color r' g' b' a') =
+ Color (i r r') (i g g') (i b b') (i a a') where
+ i = interpolate fract
+
+instance Interpolate Matrix where
+ interpolate fract (Matrix u v w x y z) (Matrix u' v' w' x' y' z') =
+ Matrix (i u u') (i v v') (i w w') (i x x') (i y y') (i z z') where
+ i = interpolate fract
+
+interpolateScene :: Ord k => Double -> Op (Scene k)
+interpolateScene fract sc1 sc2 =
+ fromList [(key, liftM2 f (sc1 Map.! key) (sc2 Map.! key))
+ | key <- interpKeys] where
+ interpKeys = intersect (keys sc1) (keys sc2)
+ f (m1,(w1,h1)) (m2,(w2,h2)) = (i m1 m2, (j w1 w2, j h1 h2))
+ i x y = interpolate fract x y
+ -- don't bounce width and height, it usually doesn't look good:
+ j x y = interpolate (max 0 $ min 1 $ fract) x y
+
+
+isInterpUseful :: Ord k => Scene k -> Scene k -> Bool
+isInterpUseful sc1 sc2 =
+ not $ all same [(sc1 Map.! key, sc2 Map.! key) | key <- interpKeys]
+ where same (a,b) = all (\d -> abs d < 5) $ zipWith (-) (values a) (values b)
+ values (Just (Matrix a b c d e f, (w,h))) = [a,b,c,d,e,f,w,h]
+ values Nothing = error "shouldn't happen"
+ interpKeys = intersect (getKeys sc1) (getKeys sc2)
+ getKeys sc = [k | k <- keys sc, isJust (sc Map.! k)]
+
+instance Show Modifier where
+ show Shift = "Shift"
+ show Control = "Control"
+ show Alt = "Alt"
+ show Apple = "Apple"
+ show Compose = "Compose"
+
+timeDbg :: MonadIO m => String -> Endo (m ())
+timeDbg s act | False = do out s; act; out s
+ | otherwise = act
+ where out t = liftIO $ do time <- System.Time.getClockTime
+ putStrLn $ s ++ " " ++ t ++ "\t" ++ show time
+
+
+linearFract :: Double -> (Double, Bool)
+linearFract x = if (x<1) then (x,True) else (1,False)
+
+bounceFract :: Double -> (Double, Bool)
+bounceFract x = (y,cont) where -- ported from AbstractUpdateManager.java
+ x' = x + x*x
+ y = 1 - cos (2 * pi * n * x') * exp (-x' * r)
+ cont = -(x + x*x)*r >= log 0.02
+ (n,r) = (0.4, 2)
+
+
+
+type Anim a = Time -> (Scene a, Bool) -- bool is whether to re-render
+
+interpAnim :: Ord a => Time -> TimeDiff -> Scene a -> Scene a -> Anim a
+interpAnim startTime interpDuration sc1 sc2 time =
+ if continue then (interpolateScene fract sc1 sc2, True) else (sc2, False)
+ where (fract, continue) = bounceFract ((time-startTime) / interpDuration)
+
+noAnim scene = const (scene, False)
+
+
+vobCanvas :: Ord b => IORef a -> View a b -> Handler Event a ->
+ Handler c a -> (a -> a -> IO ()) ->
+ (Control.Exception.Exception -> IO ()) ->
+ Color -> TimeDiff ->
+ IO (DrawingArea, Bool -> IO (), c -> IO Bool)
+vobCanvas stateRef view eventHandler actionHandler stateChanged
+ handleException bgColor animTime = do
+ canvas <- drawingAreaNew
+
+ widgetSetCanFocus canvas True
+
+ animRef <- newIORef (mempty, Map.empty, noAnim Map.empty)
+
+ let getWH = do (cw, ch) <- widgetGetSize canvas
+ return (fromIntegral cw, fromIntegral ch)
+
+ getVob = do state <- readIORef stateRef
+ return $ useFadeColor paint & view state
+
+ getRenderContext sc = do
+ size <- getWH; return $ RenderContext {
+ rcScene=sc, rcRect=(Matrix.identity, size), rcFade=1,
+ rcFgColor=black, rcBgColor=white, rcFadeColor=bgColor }
+
+ updateAnim interpolate' = mdo
+ (vob,scene,_) <- readIORef animRef
+ vob' <- getVob
+
+ rc' <- getRenderContext scene'
+ let scene' = vobScene vob' rc'
+
+ time <- scene' `seq` getTime
+
+ let anim' = if interpolate' && isInterpUseful scene scene'
+ then interpAnim time animTime scene scene'
+ else noAnim scene'
+
+ writeIORef animRef (vob', scene', anim')
+
+ widgetQueueDraw canvas
+
+ handle handler event = do
+ state <- readIORef stateRef
+ Control.Exception.catch
+ (do (state', interpolate', handled) <-
+ runHandler handler state event
+
+ when handled $ do writeIORef stateRef state'
+ stateChanged state state'
+ updateAnim interpolate'
+
+ return handled )
+ (\e -> do
+ putStr ("Exception in event: ") >> print e
+ writeIORef stateRef state
+ stateChanged state state -- XXX how to write this?
+
+ handleException e
+ return True )
+
+ handleEvent = handle eventHandler
+
+ handleAction = handle actionHandler
+
+ onRealize canvas $ mdo vob <- getVob; rc <- getRenderContext scene
+ let scene = vobScene vob rc
+ writeIORef animRef (vob, scene, noAnim scene)
+
+ onConfigure canvas $ \_event -> do updateAnim False; return True
+
+ onKeyPress canvas $ \event -> do
+ let Key {eventModifier=mods,eventKeyName=key,eventKeyChar=char} = event
+ putStrLn $ show mods++" "++key++" ("++show char++")"
+
+ handleEvent event
+
+ onButtonPress canvas $ \(Button {}) -> do
+ widgetGrabFocus canvas
+ return True
+
+ onExpose canvas $ \(Expose {}) -> do
+ drawable <- widgetGetDrawWindow canvas
+
+ (vob, _, anim) <- readIORef animRef; time <- getTime
+ let (scene, rerender) = anim time
+ rc <- getRenderContext scene
+
+ renderWithDrawable drawable $ timeDbg "redraw" $ renderVob vob rc
+
+ if rerender then widgetQueueDraw canvas else return ()
+
+ return True
+
+ return (canvas, updateAnim, handleAction)
diff -rN -u old-fenfire-hs/Fenfire.fhs new-fenfire-hs/Fenfire.fhs
--- old-fenfire-hs/Fenfire.fhs 2007-03-13 16:04:04.000000000 +0200
+++ new-fenfire-hs/Fenfire.fhs 2007-03-13 16:04:04.000000000 +0200
@@ -19,12 +19,12 @@
-- Software Foundation, Inc., 59 Temple Place, Suite 330, Boston,
-- MA 02111-1307 USA
-import qualified Cache
-import Cairo hiding (rotate, Path)
-import Vobs
-import Utils
+import qualified Fenfire.Cache as Cache
+import Fenfire.Cairo hiding (rotate, Path)
+import Fenfire.Vobs
+import Fenfire.Utils
import qualified Data.RDF.Raptor as Raptor
-import URN5
+import Fenfire.URN5
import Data.RDF
import qualified Data.Map as Map
diff -rN -u old-fenfire-hs/FunctorTest.fhs new-fenfire-hs/FunctorTest.fhs
--- old-fenfire-hs/FunctorTest.fhs 2007-03-13 16:04:04.000000000 +0200
+++ new-fenfire-hs/FunctorTest.fhs 1970-01-01 02:00:00.000000000 +0200
@@ -1,10 +0,0 @@
-{-# OPTIONS_GHC -fallow-overlapping-instances #-}
-
-module FunctorTest where
-
-f x = "This is not a result value: " ++ show x
-
-foo s = f #(bar !s !s)
-bar = (+)
-
-main = putStrLn (foo [4,3,9::Integer])
diff -rN -u old-fenfire-hs/GtkFixes.hs new-fenfire-hs/GtkFixes.hs
--- old-fenfire-hs/GtkFixes.hs 2007-03-13 16:04:04.000000000 +0200
+++ new-fenfire-hs/GtkFixes.hs 1970-01-01 02:00:00.000000000 +0200
@@ -1,102 +0,0 @@
-module GtkFixes 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 Foreign (Ptr, FunPtr, Storable(pokeByteOff, peekByteOff), allocaBytes,
- nullPtr, castPtr, freeHaskellFunPtr)
-import Foreign.C (CString, castCharToCChar, withCString, peekCString, CFile,
- CSize, CInt, CUChar, CChar)
-
-import Foreign.ForeignPtr (unsafeForeignPtrToPtr)
-
-import System.Posix.IO (stdOutput)
-import System.Posix.Types (Fd)
-import System.Environment (getArgs)
-
-import Control.Monad (when, liftM)
-import Data.IORef (modifyIORef, readIORef, newIORef)
-import Control.Exception (bracket)
-
-import System.Glib.GObject
-import System.Glib.FFI
-import Graphics.UI.Gtk
-import qualified Graphics.UI.Gtk
-import Graphics.UI.Gtk.Types
-
-
--- while Gtk2Hs actionNew needs the label:
-actionNew name maybeLabel tooltip stock = do
- item <- maybe (return Nothing) stockLookupItem stock
- let label' = case (maybeLabel, fmap siLabel item) of
- (Just label, _) -> label
- (_, Just label) -> label
- _ -> error "actionNew: no label"
- Graphics.UI.Gtk.actionNew name label' tooltip stock
-
--- until Gtk2Hs gets another way to create accel groups:
-accelGroupNew :: IO AccelGroup
-accelGroupNew = uiManagerNew >>= uiManagerGetAccelGroup
-
-
--- from Widget.hs generated from Benja's style patch to gtk2hs:
-widgetGetStyle :: WidgetClass widget => widget -> IO Style
-widgetGetStyle widget = do
- (\(Widget arg1) -> withForeignPtr arg1 $ \argPtr1 ->
- gtk_widget_ensure_style argPtr1) (toWidget widget)
- makeNewGObject mkStyle $ (\(Widget arg1) -> withForeignPtr arg1 $ \argPtr1 ->
- gtk_widget_get_style argPtr1) (toWidget widget)
-
-foreign import ccall safe " gtk_widget_ensure_style"
- gtk_widget_ensure_style :: ((Ptr Widget) -> (IO ()))
-
-foreign import ccall safe " gtk_widget_get_style"
- gtk_widget_get_style :: ((Ptr Widget) -> (IO (Ptr Style)))
-
--- from Structs.hs generated from Benja's style patch to gtk2hs:
-styleGetForeground :: Style -> StateType -> IO Color
-styleGetForeground st ty = withForeignPtr (unStyle st) $ \stPtr -> do
- peek $ advancePtr ((\hsc_ptr -> hsc_ptr `plusPtr` 12) stPtr) (fromEnum ty)
-
-styleGetBackground :: Style -> StateType -> IO Color
-styleGetBackground st ty = withForeignPtr (unStyle st) $ \stPtr ->
- peek $ advancePtr ((\hsc_ptr -> hsc_ptr `plusPtr` 72) stPtr) (fromEnum ty)
-
-styleGetLight :: Style -> StateType -> IO Color
-styleGetLight st ty = withForeignPtr (unStyle st) $ \stPtr ->
- peek $ advancePtr ((\hsc_ptr -> hsc_ptr `plusPtr` 132) stPtr) (fromEnum ty)
-
-styleGetMiddle :: Style -> StateType -> IO Color
-styleGetMiddle st ty = withForeignPtr (unStyle st) $ \stPtr ->
- peek $ advancePtr ((\hsc_ptr -> hsc_ptr `plusPtr` 252) stPtr) (fromEnum ty)
-
-styleGetDark :: Style -> StateType -> IO Color
-styleGetDark st ty = withForeignPtr (unStyle st) $ \stPtr ->
- peek $ advancePtr ((\hsc_ptr -> hsc_ptr `plusPtr` 192) stPtr) (fromEnum ty)
-
-styleGetText :: Style -> StateType -> IO Color
-styleGetText st ty = withForeignPtr (unStyle st) $ \stPtr ->
- peek $ advancePtr ((\hsc_ptr -> hsc_ptr `plusPtr` 312) stPtr) (fromEnum ty)
-
-styleGetBase :: Style -> StateType -> IO Color
-styleGetBase st ty = withForeignPtr (unStyle st) $ \stPtr ->
- peek $ advancePtr ((\hsc_ptr -> hsc_ptr `plusPtr` 372) stPtr) (fromEnum ty)
-
-styleGetAntiAliasing :: Style -> StateType -> IO Color
-styleGetAntiAliasing st ty = withForeignPtr (unStyle st) $ \stPtr ->
- peek $ advancePtr ((\hsc_ptr -> hsc_ptr `plusPtr` 432) stPtr) (fromEnum ty)
diff -rN -u old-fenfire-hs/Irc2RDF.hs new-fenfire-hs/Irc2RDF.hs
--- old-fenfire-hs/Irc2RDF.hs 2007-03-13 16:04:04.000000000 +0200
+++ new-fenfire-hs/Irc2RDF.hs 1970-01-01 02:00:00.000000000 +0200
@@ -1,152 +0,0 @@
-{-# OPTIONS_GHC -fffi #-}
-module Irc2RDF 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 System.Time (getClockTime, toUTCTime, CalendarTime(..), ClockTime(..))
-import System.Environment (getArgs)
-import System.IO (hFlush, stdout)
-import System.IO.Unsafe (unsafeInterleaveIO)
-
-import Data.Char (toUpper, toLower)
-import Data.Char (ord)
-import Data.Bits ((.&.))
-
-import qualified Control.Exception
-
-import System.Glib.UTFString (newUTFString, readCString,
- peekUTFString)
-import System.Glib.FFI (withCString, nullPtr, CString, CInt, Ptr)
-import System.IO.Unsafe (unsafePerformIO)
-
-foreign import ccall "g_utf8_validate" valid :: CString -> CInt ->
- Ptr (CString) -> Bool
-
--- XXX real toUTF isn't exported from System.Glib.UTFString
-toUTF :: String -> String
-toUTF s = unsafePerformIO $ newUTFString s >>= readCString
-
-fromUTF :: String -> String
-fromUTF s = unsafePerformIO $ Control.Exception.catch
- (withCString s $ \cstr -> peekUTFString cstr >>= \s' ->
- if (valid cstr (-1) nullPtr) then return s' -- force any exceptions
- else return s )
- (\_e -> return s) -- if any, keep the local encoding
-
--- from gutf8.c used in g_utf8_validate
-isUnicode c' = let c = ord c' in
- c < 0x110000 &&
- c .&. 0xFFFFF800 /= 0xD800 &&
- (c < 0xFDD0 || c > 0xFDEF) &&
- c .&. 0xFFFE /= 0xFFFE
-
--- XXX which unicode characters must be escaped?
-turtle_escaped :: Char -> String -> String
-turtle_escaped _ [] = []
-turtle_escaped c ('\\':xs) = '\\':'\\':turtle_escaped c xs
-turtle_escaped c (x:xs) | c == x
- = '\\': c:turtle_escaped c xs
-turtle_escaped c ('\n':xs) = '\\': 'n':turtle_escaped c xs
-turtle_escaped c ('\r':xs) = '\\': 'r':turtle_escaped c xs
-turtle_escaped c ('\t':xs) = '\\': 't':turtle_escaped c xs
-turtle_escaped c ( x:xs) = x:turtle_escaped c xs
-
-main = do [root,filepath] <- getArgs
- 'h':'t':'t':'p':':':'/':'/':_ <- return root
- irc <- getContents
- timestamps <- getTimeStamps
- mapM_ (uncurry $ handle root filepath) $ zip (map fromUTF$lines irc)
- (uniquify timestamps)
-
-getTimeStamps = do ~(TOD secs _picos) <- unsafeInterleaveIO getClockTime
- xs <- unsafeInterleaveIO getTimeStamps
- return (TOD secs 0:xs)
-
-uniquify [] = []
-uniquify (x:xs) = (x,Nothing):uniquify' (x,Nothing) xs
-
-uniquify' _ [] = []
-uniquify' prev (x:xs) | fst prev == x = next prev:uniquify' (next prev) xs
- | otherwise = first x:uniquify' (first x) xs
- where next (i,offset) = (i, Just $ maybe (2::Integer) (+1) offset)
- first i = (i, Nothing)
-
-handle :: String -> FilePath -> String -> (ClockTime, Maybe Integer) -> IO ()
-handle root filepath line (clockTime,offset) = do
- let (file,output) = irc2rdf root filepath (clockTime,offset) line
- maybe (return ()) ((flip appendFile) (toUTF output)) file
-
-irc2rdf :: String -> FilePath -> (ClockTime, Maybe Integer) -> String ->
- (Maybe FilePath,String)
-irc2rdf root filepath time = uncurry (triples root filepath time) . parse
-
-parse (':':rest) = (Just $ takeWhile (/=' ') rest,
- parse' "" (tail $ dropWhile (/=' ') rest))
-parse rest = (Nothing, parse' "" rest)
-
-parse' acc [] = [reverse acc]
-parse' acc ['\r'] = [reverse acc]
-parse' "" (':':xs) = [reverse . dropWhile (=='\r') $ reverse xs]
-parse' acc (' ':xs) = reverse acc : parse' "" xs
-parse' acc (x:xs) = parse' (x:acc) xs
-
-triples :: String -> FilePath -> (ClockTime, Maybe Integer) ->
- Maybe String -> [String] -> (Maybe FilePath, String)
-triples root filepath (time,offset) (Just prefix) [cmd,target,msg]
- | map toUpper cmd == "PRIVMSG",
- '#':channel <- map toLower target, channel `elem` ["fenfire","sioc",
- "swig","haskell"]
- =
- let file = channel ++ "-" ++ day
- uri = root ++ file ++ "#" ++ second ++ maybe "" (('.':) . show) offset
- in
- (
- Just (filepath++file)
- ,
- "<irc://freenode/%23"++channel++"> <"++isContainerOf++"> <"++uri++">.\n"++
- "<irc://freenode/%23"++channel++"> <"++rdftype++"> <"++forum++">.\n"++
- "<"++uri++"> <"++created++"> "++
- t (day++"T"++second++"Z")++"^^<"++date++">.\n"++
- "<"++uri++"> <"++hasCreator++"> <"++creator++">.\n"++
- "<"++uri++"> <"++hasContent++"> "++t msg++".\n"++
- "<"++uri++"> <"++label++"> "++t ("<"++nick++"> "++msg)++".\n"++
- "<"++uri++"> <"++rdftype++"> <"++post++">.\n"++
- "<"++creator++"> <"++label++"> "++t nick++".\n"++
- "<"++creator++"> <"++rdftype++"> <"++user++">.\n"
- )
- where t str = "\"" ++ turtle_escaped '\"' str ++ "\""
- label = "http://www.w3.org/2000/01/rdf-schema#label"
- rdftype = "http://www.w3.org/1999/02/22-rdf-syntax-ns#type"
- created = "http://purl.org/dc/terms/created"
- isContainerOf = "http://rdfs.org/sioc/ns#is_container_of"
- hasCreator = "http://rdfs.org/sioc/ns#has_creator"
- hasContent = "http://rdfs.org/sioc/ns#has_content"
- date = "http://www.w3.org/2001/XMLSchema#dateTime"
- forum = "http://rdfs.org/sioc/ns#Forum"
- post = "http://rdfs.org/sioc/ns#Post"
- user = "http://rdfs.org/sioc/ns#User"
- nick = takeWhile (/='!') prefix
- creator = "irc://freenode/"++nick++",isuser"
- (CalendarTime y moe d h m s _ps _wd _yd _tzn _tz _isDST)
- = toUTCTime time
- mo = (fromEnum moe+1)
- p n i = take (n-length (show i)) (repeat '0') ++ show i
- day = p 4 y ++ '-':p 2 mo ++ '-':p 2 d
- second = p 2 h ++ ':':p 2 m ++ ':':p 2 s
-triples _ _ _ _ _ = (Nothing, "")
diff -rN -u old-fenfire-hs/Latex2Png.hs new-fenfire-hs/Latex2Png.hs
--- old-fenfire-hs/Latex2Png.hs 2007-03-13 16:04:04.000000000 +0200
+++ new-fenfire-hs/Latex2Png.hs 1970-01-01 02:00:00.000000000 +0200
@@ -1,87 +0,0 @@
-
-module Latex2Png where
-
--- Copyright (c) 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 System.Cmd (rawSystem)
-import System.Environment (getArgs)
-import System.Directory (getTemporaryDirectory, getCurrentDirectory,
- setCurrentDirectory, createDirectory, getDirectoryContents, removeFile,
- removeDirectory, doesFileExist)
-import System.IO (openTempFile, openFile, hPutStr, hClose, IOMode(..))
-import System.Exit (ExitCode(..))
-
-import Control.Monad (when)
-
-import System.Glib.UTFString (newUTFString, readCString)
-import System.IO.Unsafe (unsafePerformIO)
-
--- XXX real toUTF isn't exported from System.Glib.UTFString
-toUTF :: String -> String
-toUTF s = unsafePerformIO $ newUTFString s >>= readCString
-
-latex content = unlines [
- "\\documentclass[12pt]{article}",
- "\\pagestyle{empty}",
- "\\usepackage[utf8]{inputenc}",
- "\\begin{document}",
- toUTF content,
- "\\end{document}"
- ]
-
-withLatexPng :: String -> (Maybe FilePath -> IO a) -> IO a
-withLatexPng code block = do
- oldCurrentDirectory <- getCurrentDirectory
- tmp <- getTemporaryDirectory
- let dir = tmp ++ "/latex2png" -- FIXME / and predictable name
- createDirectory dir
- setCurrentDirectory dir
-
- let latexFile = "latex2png-temp"
- writeFile (latexFile++".tex") $ latex code
- -- FIXME set environment variables necessary for security, use rlimit
- rawSystem "latex" ["--interaction=nonstopmode", latexFile++".tex"]
-
- rawSystem "dvipng" ["-bgTransparent", "-Ttight", "", "--noghostscript", "-l1", latexFile++".dvi"]
-
- let resultname = latexFile++"1.png"
-
- haveResult <- doesFileExist resultname
- let resultfile = if haveResult then Just resultname else Nothing
- result <- block $ resultfile
-
- setCurrentDirectory tmp
- files <- getDirectoryContents dir
- flip mapM_ files $ \filename -> do
- let file = dir ++ "/" ++ filename -- FIXME /
- exists <- doesFileExist file -- XXX to ignore . and ..
- when exists $ removeFile $ file
- removeDirectory dir
-
- setCurrentDirectory oldCurrentDirectory
- return result
-
-main = do
- [code,outfile] <- getArgs
- handle <- openFile outfile WriteMode
-
- png <- withLatexPng code $ maybe (return "") readFile
-
- hPutStr handle png
- hClose handle
diff -rN -u old-fenfire-hs/Main.hs new-fenfire-hs/Main.hs
--- old-fenfire-hs/Main.hs 2007-03-13 16:04:04.000000000 +0200
+++ new-fenfire-hs/Main.hs 1970-01-01 02:00:00.000000000 +0200
@@ -1,733 +0,0 @@
-module Main 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 hiding (Path, rotate)
-import Vobs
-import qualified Data.RDF.Raptor as Raptor
-import URN5
-import Data.RDF
-import VanishingView
-import Fenfire
-
-import Paths_fenfire (getDataFileName)
-
-import Control.Exception
-import Control.Monad
-import Control.Monad.State
-
-import Data.IORef
-import Data.Maybe (fromJust)
-import qualified Data.List as List
-import qualified Data.Set as Set
-import qualified Data.Map as Map
-
-import GtkFixes
-import Graphics.UI.Gtk hiding (Color, get, disconnect, fill,
--- GtkFixes overrides:
- actionNew,
- widgetGetStyle,
- styleGetForeground, styleGetBackground,
- styleGetLight, styleGetMiddle, styleGetDark,
- styleGetText, styleGetBase,
- styleGetAntiAliasing)
-import Graphics.UI.Gtk.ModelView as New
-
-import qualified Network.URI
-
-import System.Directory (canonicalizePath)
-import System.Environment (getArgs, getProgName)
-
-interpretNode :: (?graph :: Graph) => String -> Node
-interpretNode str | "<" `List.isPrefixOf` str && ">" `List.isSuffixOf` str =
- URI $ tail $ init str
- | isQname
- , Just base <- Map.lookup ns (graphNamespaces ?graph) =
- URI $ base ++ local
- | isQname = error $ "No such namespace: \""++ns++"\""
- | otherwise = URI str
- where local = drop 1 $ dropWhile (/= ':') str
- ns = takeWhile (/= ':') str
- isQname = ns /= "" && (not $ any (`elem` local) [':', '/', '@'])
-
-openFile :: (?vs :: ViewSettings) => FilePath ->
- IO (Maybe (Graph, FilePath))
-openFile fileName0 = do
- dialog <- fileChooserDialogNew Nothing Nothing FileChooserActionOpen
- [(stockCancel, ResponseCancel),
- (stockOpen, ResponseAccept)]
- when (fileName0 /= "") $ do fileChooserSetFilename dialog fileName0
- return ()
- response <- dialogRun dialog
- widgetHide dialog
- case response of
- ResponseAccept -> do Just fileName <- fileChooserGetFilename dialog
- graph <- loadGraph fileName
- return $ Just (graph, fileName)
- _ -> return Nothing
-
-saveFile :: Graph -> FilePath -> Bool -> IO (FilePath,Bool)
-saveFile graph fileName0 confirmSame = do
- dialog <- fileChooserDialogNew Nothing Nothing FileChooserActionSave
- [(stockCancel, ResponseCancel),
- (stockSave, ResponseAccept)]
- fileChooserSetDoOverwriteConfirmation dialog True
- dialogSetDefaultResponse dialog ResponseAccept
- when (fileName0 /= "") $ do fileChooserSetFilename dialog fileName0
- return ()
- onConfirmOverwrite dialog $ do
- Just fileName <- fileChooserGetFilename dialog
- if fileName == fileName0 && not confirmSame
- then return FileChooserConfirmationAcceptFilename
- else return FileChooserConfirmationConfirm
- response <- dialogRun dialog
- widgetHide dialog
- case response of
- ResponseAccept -> do Just fileName <- fileChooserGetFilename dialog
- let fileName' = checkSuffix fileName
- saveGraph graph fileName'
- return (fileName', True)
- _ -> return (fileName0, False)
-
-checkSuffix :: FilePath -> FilePath
-checkSuffix s | List.isSuffixOf ".turtle" s = s
- | otherwise = s ++ ".turtle"
-
-confirmSave :: (?vs :: ViewSettings, ?pw :: Window,
- ?views :: Views, ?uriMaker :: URIMaker) =>
- Bool -> HandlerAction FenState ->
- HandlerAction FenState
-confirmSave False action = action
-confirmSave True action = do
- response <- liftIO $ do
- dialog <- makeConfirmUnsavedDialog
- response' <- dialogRun dialog
- widgetHide dialog
- return response'
- case response of ResponseClose -> action
- ResponseAccept -> do
- handleAction "save"
- saved <- get >>= return . not . fsGraphModified
- when (saved) action
- _ -> return ()
-
-confirmRevert :: (?vs :: ViewSettings, ?pw :: Window) =>
- Bool -> HandlerAction FenState ->
- HandlerAction FenState
-confirmRevert False action = action
-confirmRevert True action = do
- response <- liftIO $ do
- dialog <- makeConfirmRevertDialog
- response' <- dialogRun dialog
- widgetHide dialog
- return response'
- case response of ResponseClose -> action
- _ -> return ()
-
-confirmString :: (?vs :: ViewSettings, ?pw :: Window) =>
- String -> String -> (String -> HandlerAction FenState) ->
- HandlerAction FenState
-confirmString title preset action = do
- (response,text) <- liftIO $ do
- dialog <- makeDialog title
- [(stockCancel, ResponseCancel),
- (stockApply, ResponseAccept)]
- ResponseAccept
- entry <- entryNew
- set entry [ entryText := preset, entryActivatesDefault := True ]
- widgetShow entry
- vBox <- dialogGetUpper dialog
- boxPackStart vBox entry PackNatural 0
- response' <- dialogRun dialog
- text' <- entryGetText entry
- widgetHide dialog
- return (response',text')
- case response of ResponseAccept -> action text
- _ -> return ()
-handleEvent :: (?vs :: ViewSettings, ?pw :: Window, ?views :: Views,
- ?uriMaker :: URIMaker) => Handler Event FenState
-handleEvent (Key { eventModifier=_mods, eventKeyName=key }) = do
- state <- get; let graph = fsGraph state; fileName = fsFilePath state
- case key of
- x | x == "Up" || x == "i" -> handleAction "up"
- x | x == "Down" || x == "comma" -> handleAction "down"
- x | x == "Left" || x == "j" -> handleAction "left"
- x | x == "Right" || x == "l" -> handleAction "right"
- "v" -> handleAction "chgview"
- "p" -> handleAction "resetprop"
- "O" -> handleAction "open"
- "S" -> do (fp',saved) <- liftIO $ saveFile graph fileName False
- let modified' = fsGraphModified state && not saved
- put $ state { fsFilePath = fp', fsGraphModified = modified' }
- _ -> unhandledEvent
-handleEvent _ = unhandledEvent
-
-handleAction :: (?vs :: ViewSettings, ?pw :: Window, ?views :: Views,
- ?uriMaker :: URIMaker) => Handler String FenState
-handleAction action = do
- state@(FenState { fsGraph = graph, fsPath = path, fsMark = mark,
- fsFilePath = filepath, fsGraphModified = modified,
- fsHasFocus=focus
- }) <- get
- let ?graph = graph in do
- let rot@(Rotation node _) = fsRotation state
- b f x = maybeDo (f rot x) $ \rot' -> do
- putRotation rot'
- modify $ \s -> s { fsGraphModified = modified }
- n f x = do state' <- liftIO (f x state); put state'; setInterp True
- o f x = do put (f x state); setInterp True
- case action of
- "up" -> b rotate (-1) ; "down" -> b rotate 1
- "left" -> b tryMove Neg ; "right" -> b tryMove Pos
- "nodel" -> n newNode Neg ; "noder" -> n newNode Pos
- "connl" -> o connect Neg ; "connr" -> o connect Pos
- "breakl"-> o disconnect Neg ; "breakr"-> o disconnect Pos
- "rmlit" -> putGraph (delLit node graph)
- "mark" -> putMark $ toggleMark node mark
- "new" -> confirmSave modified $ do
- (g', path') <- liftIO newGraph
- put $ newState g' path' "" focus
- "open" -> confirmSave modified $ do
- result <- liftIO $ openFile filepath
- maybeDo result $ \(g',fp') -> do
- uri <- liftM URI $ liftIO $ Raptor.filenameToURI fp'
- let ts = containsInfoTriples uri g'
- g'' = foldr insertVirtual g' ts
- put $ newState g'' (findStartPath uri g'') fp' focus
- "loadURI" -> case node of
- URI uri -> do
- g <- liftIO $ loadGraph uri
- let ts = containsInfoTriples (URI uri) g
- g' = foldr insertVirtual
- (mergeGraphs graph g) ts
- s' = state {fsGraph=g',
- fsUndo=(graph,path):fsUndo state,
- fsRedo=[]}
- put s'
- _ -> unhandledEvent
- "revert" | filepath /= "" -> confirmRevert modified $ do
- g' <- liftIO $ loadGraph filepath
- gNode <- liftM URI $ liftIO $ Raptor.filenameToURI filepath
- let g'' = foldr insertVirtual g' $ containsInfoTriples gNode g'
- put $ newState g'' (findStartPath gNode g'') filepath focus
- "save" | filepath /= "" -> do
- liftIO $ saveGraph graph filepath
- modify $ \s -> s { fsGraphModified = False }
- | otherwise -> handleAction "saveas"
- "saveas"-> do
- (fp',saved) <- liftIO $ saveFile graph filepath True
- let modified' = modified && not saved
- modify $ \s -> s { fsFilePath = fp', fsGraphModified = modified' }
- "quit" -> do confirmSave modified $ liftIO mainQuit
- "about" -> liftIO $ makeAboutDialog >>= widgetShow
- "chgview" -> do put $ state { fsView = (fsView state + 1) `mod`
- (length ?views) }
- setInterp True
- "addprop" -> do let uri = case node of URI _ -> showNode
- (graphNamespaces graph) node
- _ -> ""
- confirmString "Add property" uri $ \uri' ->
- when (uri' /= "") $ do
- let prop' = interpretNode uri'
- props = fsProperties state
- put $ state { fsProperty = prop',
- fsProperties = Set.insert prop' props }
- "resetprop" -> when (fsProperty state /= rdfs_seeAlso) $
- put $ state { fsProperty = rdfs_seeAlso }
- "changeURI" -> case node of
- URI _ -> confirmString "New URI" (showNode
- (graphNamespaces graph) node) $ \uri' ->
- put $ stateReplaceNode node
- (interpretNode uri') state
- _ -> unhandledEvent
- "undo" | (graph',path'):undos <- fsUndo state -> do
- put state {fsGraph=graph', fsPath=path',
- fsUndo=undos, fsRedo=(graph,path):fsRedo state}
- setInterp True
- "redo" | (graph',path'):redos <- fsRedo state -> do
- put state {fsGraph=graph', fsPath=path',
- fsUndo=(graph,path):fsUndo state, fsRedo=redos}
- setInterp True
- _ -> do liftIO $ putStrLn $ "Unhandled action: " ++ action
- unhandledEvent
- where putGraph g = do modify $ \s ->
- s { fsGraph=g, fsGraphModified=True,
- fsUndo=(fsGraph s, fsPath s):fsUndo s,
- fsRedo=[]}
- setInterp True
- putRotation rot = do modify $ \s -> s { fsPath = toPath' rot }
- setInterp True
- putMark mk = do modify $ \state -> state { fsMark=mk }
- delLit n graph = deleteAll n rdfs_label graph
-
-makeActions actionGroup accelGroup = do
- let actionentries =
- [ ( "new" , Nothing, stockNew , Nothing )
- , ( "open" , Nothing, stockOpen , Nothing )
- , ( "save" , Nothing, stockSave , Nothing )
- , ( "saveas" , Nothing, stockSaveAs , Just "<Ctl><Shift>S" )
- , ( "revert" , Nothing, stockRevertToSaved , Nothing )
- , ( "quit" , Nothing, stockQuit , Nothing )
- , ( "about" , Nothing, stockAbout , Nothing )
- , ( "loadURI", Just "_Load node's URI",
- stockGoForward , Just "<Ctl>L" )
- , ( "undo" , Nothing, stockUndo , Just "<Ctl>Z" )
- , ( "redo" , Nothing, stockRedo , Just "<Ctl><Shift>Z" )
- ]
- forM actionentries $ \(name,label',stock,accel) -> do
- action <- actionNew name label' Nothing (Just stock)
- actionGroupAddActionWithAccel actionGroup action accel
- actionSetAccelGroup action accelGroup
-
-updateActions actionGroup stateRef = do
- state <- readIORef stateRef
- let readable = fsFilePath state /= ""
- modified = fsGraphModified state
- view = fst $ ?views !! (fsView state)
-
- Just save <- actionGroupGetAction actionGroup "save"
- actionSetSensitive save modified
- Just revert <- actionGroupGetAction actionGroup "revert"
- actionSetSensitive revert (modified && readable)
- Just undo <- actionGroupGetAction actionGroup "undo"
- actionSetSensitive undo (not $ null $ fsUndo state)
- Just redo <- actionGroupGetAction actionGroup "redo"
- actionSetSensitive redo (not $ null $ fsRedo state)
- Just changeView <- actionGroupGetAction actionGroup view
- toggleActionSetActive (castToToggleAction changeView) True
-
-updatePropMenu propmenu actionGroup stateRef updateCanvas = do
- state <- readIORef stateRef
- Just addProp <- actionGroupGetAction actionGroup "addprop"
-
- menu <- menuNew
- forM (Set.toAscList $ fsProperties state) $ \prop -> do
- item <- let ?graph = fsGraph state
- in menuItemNewWithLabel $ getTextOrURI prop
- onActivateLeaf item $ do
- modifyIORef stateRef $ \state' -> state' {fsProperty=prop}
- updateCanvas False
- menuShellAppend menu item
- widgetShow item
- sep <- separatorMenuItemNew
- menuShellAppend menu sep
- widgetShow sep
- item <- actionCreateMenuItem addProp
- menuShellAppend menu $ castToMenuItem item
-
- menuItemSetSubmenu propmenu menu
-
-makeBindings actionGroup bindings = do
- let bindingentries =
- [ ("noder" , Just "_New node to right" ,
- stockMediaForward , Just "n" )
- , ("nodel" , Just "N_ew node to left" ,
- stockMediaRewind , Just "<Shift>N" )
- , ("breakr" , Just "_Break connection to right" ,
- stockGotoLast , Just "b" )
- , ("breakl" , Just "B_reak connection to left" ,
- stockGotoFirst , Just "<Shift>B" )
- , ("mark" , Just "Toggle _mark" ,
- stockOk , Just "m" )
- , ("connr" , Just "_Connect marked to right" ,
- stockGoForward , Just "c" )
- , ("connl" , Just "C_onnect marked to left" ,
- stockGoBack , Just "<Shift>C" )
- , ("rmlit" , Just "Remove _literal text" ,
- stockStrikethrough , Just "<Alt>BackSpace" )
- , ("addprop", Just "_Add property" ,
- stockAdd , Just "<Ctl>P" )
- , ("changeURI", Just "Change node's _URI" ,
- stockRefresh , Just "u" )
- ]
- forM bindingentries $ \(name,label',stock,accel) -> do
- action <- actionNew name label' Nothing (Just stock)
- actionGroupAddActionWithAccel actionGroup action accel
- actionSetAccelGroup action bindings
-
-makeMenus actionGroup root propmenu = addAll root menu where
- menu = [m "_File" [a "new", a "open", a "loadURI", sep,
- a "save", a "saveas", a "revert", sep,
- a "quit"],
- m "_Edit" [a "undo", a "redo", sep,
- return propmenu, sep,
- a "noder", a "nodel", sep,
- a "breakr", a "breakl", sep,
- a "mark", a "connr", a "connl", sep,
- a "changeURI", a "rmlit"],
- m "_View" (map (a . fst) ?views),
- m "_Help" [a "about"]]
- addAll parent items = mapM_ (menuShellAppend parent) =<< sequence items
- m :: String -> [IO MenuItem] -> IO MenuItem
- m name children = do item <- menuItemNewWithMnemonic name
- menu' <- menuNew
- addAll menu' children
- menuItemSetSubmenu item menu'
- return item
- sep = liftM castToMenuItem separatorMenuItemNew
- a name = do Just action <- actionGroupGetAction actionGroup name
- item <- actionCreateMenuItem action
- return (castToMenuItem item)
-
-makeToolbarItems actionGroup toolbar = do
- forM_ ["new", "open", "save", "", "undo", "redo",""] $ \name ->
- if name == "" then do
- item <- separatorToolItemNew
- toolbarInsert toolbar item (-1)
- else do
- Just action <- actionGroupGetAction actionGroup name
- item <- actionCreateToolItem action
- toolbarInsert toolbar (castToToolItem item) (-1)
-
-handleException :: Control.Exception.Exception -> IO ()
-handleException e = do
- dialog <- makeMessageDialog "Exception in event" (show e)
- dialogRun dialog
- widgetHide dialog
-
-
-main :: IO ()
-main = do
-
- uriMaker <- newURIMaker
-
- -- initial state:
-
- args <- initGUI
-
- window <- windowNew
- style <- widgetGetStyle window
-
- bgColor <- styleGetBackground style StateSelected
- blurBgColor <- styleGetBackground style StateActive
- focusColor <- styleGetBase style StateSelected
- blurColor <- styleGetBase style StateActive
- textColor <- styleGetText style StateSelected
- blurTextColor <- styleGetText style StateActive
-
- canvasBgColor <- styleGetBackground style StateNormal
-
- let alpha x (Color r g b a) = Color r g b (x*a)
-
- let ?vs = ViewSettings { hiddenProps=[rdfs_label], maxCenter=3 }
- ?uriMaker = uriMaker in let
- ?views = [("Wheel view", vanishingView 20 30
- (alpha 0.7 $ fromGtkColor bgColor)
- (alpha 0.7 $ fromGtkColor blurBgColor)
- (fromGtkColor focusColor) (fromGtkColor blurColor)
- (fromGtkColor textColor) (fromGtkColor blurTextColor)),
- ("Presentation view", presentationView)] in do
-
- let view s = snd (?views !! fsView s) s
-
- stateRef <- case args of
- [] -> do
- (g, rot) <- newGraph
- newIORef $ newState g rot "" False
- xs -> do
- let f x | List.isPrefixOf "http:" x = return x
- | otherwise = canonicalizePath x
- fileName:fileNames <- mapM f xs
- g' <- loadGraph fileName
- gs <- mapM loadGraph fileNames
- uri <- Raptor.filenameToURI fileName
- uris <- mapM Raptor.filenameToURI fileNames
- let ts = concatMap (uncurry containsInfoTriples) $
- (URI uri, g') : zip (map URI uris) gs
- graph = foldr insertVirtual (foldl mergeGraphs g' gs) ts
- newIORef $ newState graph (findStartPath (URI uri) graph) fileName False
-
- -- start:
-
- makeWindow window canvasBgColor view stateRef
- widgetShowAll window
-
- mainGUI
-
-makeWindow window canvasBgColor view stateRef = do
-
- -- main window:
-
- let ?pw = window in mdo
- logo <- getDataFileName "data-files/icon16.png"
- Control.Exception.catch (windowSetIconFromFile window logo)
- (\e -> putStr ("Opening "++logo++" failed: ") >> print e)
- windowSetTitle window "Fenfire"
- windowSetDefaultSize window 800 550
-
- -- textview for editing:
-
- textView <- textViewNew
- textViewSetAcceptsTab textView False
- textViewSetWrapMode textView WrapWordChar
-
- -- this needs to be called whenever the node or its text changes:
- let stateChanged _ state@(FenState { fsPath=Path n _, fsGraph=g }) = do
- buf <- textBufferNew Nothing
- textBufferSetText buf (let ?graph=g in maybe "" id $ getText n)
- afterBufferChanged buf $ do
- start <- textBufferGetStartIter buf
- end <- textBufferGetEndIter buf
- text <- textBufferGetText buf start end True
- s@(FenState { fsGraph = g' }) <- readIORef stateRef
- let g'' = setText n text g' -- buf corresponds to n, not to n'
-
- writeIORef stateRef $
- s { fsGraph=g'', fsGraphModified=True, fsRedo=[],
- fsUndo=(fsGraph s, fsPath s):(fsUndo s) }
- updateActions actionGroup stateRef
- updateCanvas True
-
- textViewSetBuffer textView buf
- updatePropMenu propmenu actionGroup stateRef updateCanvas
- New.listStoreClear propList
- forM_ (Set.toAscList $ fsProperties state) $ \prop ->
- let ?graph = g in
- New.listStoreAppend propList (prop, getTextOrURI prop)
- let activeIndex = List.elemIndex (fsProperty state)
- (Set.toAscList $ fsProperties state)
- maybe (return ()) (New.comboBoxSetActive combo) activeIndex
-
- updateActions actionGroup stateRef
-
- -- canvas for view:
-
- (canvas, updateCanvas, canvasAction) <-
- vobCanvas stateRef view handleEvent handleAction
- stateChanged handleException (fromGtkColor canvasBgColor) 0.5
-
- onFocusIn canvas $ \_event -> do
- modifyIORef stateRef $ \s -> s { fsHasFocus = True }
- forM_ bindingActions $ actionConnectAccelerator
- updateCanvas True
- return True
- onFocusOut canvas $ \_event -> do
- modifyIORef stateRef $ \s -> s { fsHasFocus = False }
- forM_ bindingActions $ actionDisconnectAccelerator
- updateCanvas True
- return True
-
- -- action widgets:
-
- accelGroup <- accelGroupNew
- windowAddAccelGroup window accelGroup
- -- bindings are active only when the canvas has the focus:
- bindings <- accelGroupNew
- windowAddAccelGroup window bindings
- -- fake bindings aren't used
- fake <- accelGroupNew
-
- actionGroup <- actionGroupNew "main"
- bindingGroup <- actionGroupNew "bindings"
-
- makeActions actionGroup accelGroup
- makeBindings bindingGroup bindings
- makeBindings actionGroup fake
-
- actions <- actionGroupListActions actionGroup
- bindingActions <- actionGroupListActions bindingGroup
-
- forM_ (actions ++ bindingActions) $ \action -> do
- name <- actionGetName action
- onActionActivate action $ canvasAction name >> return ()
-
- viewActs <- forM (zip [0..] ?views) $ \(index, (name, _view)) -> do
- action <- radioActionNew name name Nothing Nothing index
- actionGroupAddAction actionGroup action
- onActionActivate action $ do
- i <- radioActionGetCurrentValue action
- state <- readIORef stateRef
- when (i /= fsView state) $ do
- writeIORef stateRef $ state { fsView = i }
- updateCanvas True
- return action
-
- forM_ (tail viewActs) $ \x -> radioActionSetGroup x (head viewActs)
- toggleActionSetActive (toToggleAction $ head viewActs) True
-
- -- user interface widgets:
-
- menubar <- menuBarNew
- propmenu <- menuItemNewWithMnemonic "Set _property"
- makeMenus actionGroup menubar propmenu
-
- toolbar <- toolbarNew
- makeToolbarItems actionGroup toolbar
-
- propList <- New.listStoreNew []
- combo <- New.comboBoxNew
- set combo [ New.comboBoxModel := Just propList
- , New.comboBoxFocusOnClick := False ]
- renderer <- New.cellRendererTextNew
- New.cellLayoutPackStart combo renderer True
- New.cellLayoutSetAttributes combo renderer propList $ \row ->
- [ New.cellText := snd row ]
- New.onChanged combo $ do
- active <- New.comboBoxGetActive combo
- case active of
- Nothing -> return ()
- Just i -> do
- (prop,_name) <- listStoreGetValue propList i
- state' <- readIORef stateRef
- writeIORef stateRef $ state' {fsProperty=prop}
- when (fsProperty state' /= prop) $ updateCanvas False
-
- comboLabel <- labelNew (Just "Property: ")
-
- comboVBox <- hBoxNew False 0
- boxPackStart comboVBox comboLabel PackNatural 0
- boxPackStart comboVBox combo PackNatural 0
-
- comboAlign <- alignmentNew 0.5 0.5 1 0
- containerAdd comboAlign comboVBox
-
- combotool <- toolItemNew
- containerAdd combotool comboAlign
- toolbarInsert toolbar combotool (-1)
-
- sepItem <- separatorToolItemNew
- toolbarInsert toolbar sepItem (-1)
-
- Just addpropAction <- actionGroupGetAction actionGroup "addprop"
- addpropItem <- actionCreateToolItem addpropAction
- toolbarInsert toolbar (castToToolItem addpropItem) (-1)
-
- -- layout:
-
- canvasFrame <- frameNew
- set canvasFrame [ containerChild := canvas
- , frameShadowType := ShadowIn
- ]
-
- textViewFrame <- frameNew
- set textViewFrame [ containerChild := textView
- , frameShadowType := ShadowIn
- ]
-
- paned <- vPanedNew
- panedAdd1 paned canvasFrame
- panedAdd2 paned textViewFrame
-
- vBox <- vBoxNew False 0
- boxPackStart vBox menubar PackNatural 0
- boxPackStart vBox toolbar PackNatural 0
- boxPackStart vBox paned PackGrow 0
- containerSetFocusChain vBox [toWidget paned]
-
- set paned [ panedPosition := 380, panedChildResize textViewFrame := False ]
-
- set window [ containerChild := vBox ]
-
- -- start:
-
- startState <- readIORef stateRef
- stateChanged (startState { fsProperties = Set.empty }) startState
-
- widgetGrabFocus canvas
-
- onDelete window $ \_event -> canvasAction "quit"
-
-
-makeAboutDialog :: (?pw :: Window) => IO AboutDialog
-makeAboutDialog = do
- dialog <- aboutDialogNew
- logoFilename <- getDataFileName "data-files/logo.svg"
- pixbuf <- Control.Exception.catch (pixbufNewFromFile logoFilename)
- (\e -> return $ Left (undefined, show e))
- logo <- case pixbuf of Left (_,msg) -> do
- putStr ("Opening "++logoFilename++" failed: ")
- putStrLn msg
- return Nothing
- Right pixbuf' -> return . Just =<<
- pixbufScaleSimple pixbuf'
- 200 (floor (200*(1.40::Double)))
- InterpHyper
- set dialog [ aboutDialogName := "Fenfire"
- , aboutDialogVersion := "alpha version"
- , aboutDialogCopyright := "Licensed under GNU GPL v2 or later"
- , aboutDialogComments :=
- "An application for notetaking and RDF graph browsing."
- , aboutDialogLogo := logo
- , aboutDialogWebsite := "http://fenfire.org"
- , aboutDialogAuthors := ["Benja Fallenstein", "Tuukka Hastrup"]
- , windowTransientFor := ?pw
- ]
- onResponse dialog $ \_response -> widgetHide dialog
- return dialog
-
-makeDialog :: (?pw :: Window) => String -> [(String, ResponseId)] ->
- ResponseId -> IO Dialog
-makeDialog title buttons preset = do
- dialog <- dialogNew
- set dialog [ windowTitle := title
- , windowTransientFor := ?pw
- , windowModal := True
- , windowDestroyWithParent := True
- , dialogHasSeparator := False
- ]
- mapM_ (uncurry $ dialogAddButton dialog) buttons
- dialogSetDefaultResponse dialog preset
- return dialog
-
-makeConfirmUnsavedDialog :: (?pw :: Window) => IO Dialog
-makeConfirmUnsavedDialog = do
- makeDialog "Confirm unsaved changes"
- [("_Discard changes", ResponseClose),
- (stockCancel, ResponseCancel),
- (stockSave, ResponseAccept)]
- ResponseAccept
-
-makeConfirmRevertDialog :: (?pw :: Window) => IO Dialog
-makeConfirmRevertDialog = do
- makeDialog "Confirm revert"
- [(stockCancel, ResponseCancel),
- (stockRevertToSaved,ResponseClose)]
- ResponseCancel
-
-makeMessageDialog primary secondary = do
- dialog <- dialogNew
- set dialog [ windowTitle := primary
- , windowModal := True
- , containerBorderWidth := 6
- , dialogHasSeparator := False
- ]
- image' <- imageNewFromStock stockDialogError iconSizeDialog
- set image' [ miscYalign := 0.0 ]
- label' <- labelNew $ Just $ "<span weight=\"bold\" size=\"larger\">"++
- escapeMarkup primary++"</span>\n\n"++escapeMarkup secondary
- set label' [ labelUseMarkup := True
- , labelWrap := True
- , labelSelectable := True
- , miscYalign := 0.0
- ]
- hBox <- hBoxNew False 0
- set hBox [ boxSpacing := 12
- , containerBorderWidth := 6
- ]
- boxPackStart hBox image' PackNatural 0
- boxPackStart hBox label' PackNatural 0
-
- vBox <- dialogGetUpper dialog
- set vBox [ boxSpacing := 12 ]
- boxPackStart vBox hBox PackNatural 0
-
- dialogAddButton dialog stockOk ResponseAccept
- widgetShowAll hBox
- return dialog
diff -rN -u old-fenfire-hs/Makefile new-fenfire-hs/Makefile
--- old-fenfire-hs/Makefile 2007-03-13 16:04:04.000000000 +0200
+++ new-fenfire-hs/Makefile 2007-03-13 16:04:04.000000000 +0200
@@ -50,8 +50,11 @@
darcs.nt: darcs2rdf _darcs/inventory
darcs changes --xml | ./dist/build/darcs2rdf/darcs2rdf "http://antti-juhani.kaijanaho.fi/darcs/fenfire-hs/" > darcs.nt
+configure:
+ runhaskell Setup.hs configure --user --prefix ~/inst
+
clean:
- rm -f $(PREPROCESSED) *.p_hi *.hi *.i *.chi Raptor.h Raptor_stub.* *.p_o *.o $(TARGETS)
+ runhaskell Setup.hs clean
# __attribute__ needs to be a no-op until c2hs learns to parse them in raptor.h
%.hs: %.chs
diff -rN -u old-fenfire-hs/URN5.hs new-fenfire-hs/URN5.hs
--- old-fenfire-hs/URN5.hs 2007-03-13 16:04:04.000000000 +0200
+++ new-fenfire-hs/URN5.hs 1970-01-01 02:00:00.000000000 +0200
@@ -1,36 +0,0 @@
-module URN5 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 Data.IORef
-import System.Random (randomRIO)
-
-type URIMaker = (String, IORef Integer)
-
-newURIMaker :: IO URIMaker
-newURIMaker = do rand <- sequence [randomRIO (0,63) | _ <- [1..27::Int]]
- let chars = ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ "+-"
- ref <- newIORef 1
- return ("urn:urn-5:" ++ map (chars !!) rand, ref)
-
-newURI :: (?uriMaker :: URIMaker) => IO String
-newURI = do let (base, ref) = ?uriMaker
- i <- readIORef ref; writeIORef ref (i+1)
- return (base ++ ":_" ++ show i)
-
diff -rN -u old-fenfire-hs/Utils.hs new-fenfire-hs/Utils.hs
--- old-fenfire-hs/Utils.hs 2007-03-13 16:04:04.000000000 +0200
+++ new-fenfire-hs/Utils.hs 1970-01-01 02:00:00.000000000 +0200
@@ -1,171 +0,0 @@
--- For (instance MonadReader w m => MonadReader w (MaybeT m)) in GHC 6.6:
-{-# OPTIONS_GHC -fglasgow-exts -fallow-undecidable-instances -fallow-overlapping-instances #-}
-module Utils 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 Control.Applicative
-import Control.Monad
-import Control.Monad.List
-import Control.Monad.Reader
-import Control.Monad.State
-import Control.Monad.Trans
-import Control.Monad.Writer (WriterT(..), MonadWriter(..), execWriterT)
-
-import Data.Maybe (fromMaybe)
-import Data.Monoid (Monoid(..))
-
-import qualified System.Time
-
-
--- just what the rhs says, a function from a type to itself
-type Endo a = a -> a
-
-type EndoM m a = a -> m a
-type Op a = a -> a -> a
-
-type Time = Double -- seconds since the epoch
-type TimeDiff = Double -- in seconds
-
-
-avg :: Fractional a => Op a
-avg x y = (x+y)/2
-
-
-infixl 9 !?
-
-(!?) :: [a] -> Int -> Maybe a
-l !? i | i < 0 = Nothing
- | i >= length l = Nothing
- | otherwise = Just (l !! i)
-
-
-maybeReturn :: MonadPlus m => Maybe a -> m a
-maybeReturn = maybe mzero return
-
-returnEach :: MonadPlus m => [a] -> m a
-returnEach = msum . map return
-
-maybeDo :: Monad m => Maybe a -> (a -> m ()) -> m ()
-maybeDo m f = maybe (return ()) f m
-
-
-getTime :: IO Time
-getTime = do (System.Time.TOD secs picosecs) <- System.Time.getClockTime
- return $ fromInteger secs + fromInteger picosecs / (10**(3*4))
-
-
-(&) :: Monoid m => m -> m -> m
-(&) = mappend
-
-
-funzip :: Functor f => f (a,b) -> (f a, f b)
-funzip x = (fmap fst x, fmap snd x)
-
-ffor :: Functor f => f a -> (a -> b) -> f b
-ffor = flip fmap
-
-for :: [a] -> (a -> b) -> [b]
-for = flip map
-
-forA2 :: Applicative f => f a -> f b -> (a -> b -> c) -> f c
-forA2 x y f = liftA2 f x y
-
-forA3 :: Applicative f => f a -> f b -> f c -> (a -> b -> c -> d) -> f d
-forA3 a b c f = liftA3 f a b c
-
-
-newtype Comp f g a = Comp { fromComp :: f (g a) }
-
-instance (Functor f, Functor g) => Functor (Comp f g) where
- fmap f (Comp m) = Comp (fmap (fmap f) m)
-
-instance (Applicative f, Applicative g) => Applicative (Comp f g) where
- pure = Comp . pure . pure
- Comp f <*> Comp x = Comp $ forA2 f x (<*>)
-
-
-newtype BreadthT m a = BreadthT { runBreadthT :: WriterT [BreadthT m ()] m a }
-
-scheduleBreadthT :: Monad m => BreadthT m a -> BreadthT m ()
-scheduleBreadthT m = BreadthT $ tell [m >> return ()]
-
-execBreadthT :: Monad m => BreadthT m a -> m ()
-execBreadthT m = do rest <- execWriterT (runBreadthT m)
- when (not $ null rest) $ execBreadthT (sequence_ rest)
-
-instance Monad m => Monad (BreadthT m) where
- return = BreadthT . return
- m >>= f = BreadthT (runBreadthT m >>= runBreadthT . f)
-
-instance MonadTrans BreadthT where
- lift = BreadthT . lift
-
-instance MonadState s m => MonadState s (BreadthT m) where
- get = lift $ get
- put = lift . put
-
-instance MonadWriter w m => MonadWriter w (BreadthT m) where
- tell = lift . tell
- listen m = BreadthT $ WriterT $ do
- ((x,w),w') <- listen $ runWriterT (runBreadthT m)
- return ((x,w'),w)
- pass m = BreadthT $ WriterT $ pass $ do
- ((x,f),w) <- runWriterT (runBreadthT m)
- return ((x,w),f)
-
-
-newtype MaybeT m a = MaybeT { runMaybeT :: m (Maybe a) }
-
-instance Monad m => Monad (MaybeT m) where
- return x = MaybeT $ return (Just x)
- m >>= f = MaybeT $ do x <- runMaybeT m
- maybe (return Nothing) (runMaybeT . f) x
- fail _ = mzero
-
-instance MonadTrans MaybeT where
- lift m = MaybeT $ do x <- m; return (Just x)
-
-instance Monad m => MonadPlus (MaybeT m) where
- mzero = MaybeT $ return Nothing
- mplus m n = MaybeT $ do
- x <- runMaybeT m; maybe (runMaybeT n) (return . Just) x
-
-instance MonadReader r m => MonadReader r (MaybeT m) where
- ask = lift ask
- local f m = MaybeT $ local f (runMaybeT m)
-
-instance MonadWriter w m => MonadWriter w (MaybeT m) where
- tell = lift . tell
- listen m = MaybeT $ do (x,w) <- listen $ runMaybeT m
- return $ maybe Nothing (\x' -> Just (x',w)) x
- pass m = MaybeT $ pass $ do
- x <- runMaybeT m; return $ maybe (Nothing,id) (\(y,f) -> (Just y,f)) x
-
-callMaybeT :: Monad m => MaybeT m a -> MaybeT m (Maybe a)
-callMaybeT = lift . runMaybeT
-
-
-instance MonadWriter w m => MonadWriter w (ListT m) where
- tell = lift . tell
- listen m = ListT $ do (xs,w) <- listen $ runListT m
- return [(x,w) | x <- xs]
- pass m = ListT $ pass $ do -- not ideal impl, but makes 'censor' work
- ps <- runListT m
- return $ if null ps then ([], id) else (map fst ps, snd (head ps))
diff -rN -u old-fenfire-hs/VanishingView.fhs new-fenfire-hs/VanishingView.fhs
--- old-fenfire-hs/VanishingView.fhs 2007-03-13 16:04:04.000000000 +0200
+++ new-fenfire-hs/VanishingView.fhs 1970-01-01 02:00:00.000000000 +0200
@@ -1,163 +0,0 @@
-module VanishingView 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 hiding (Path, rotate)
-import Vobs
-import Data.RDF
-import Fenfire
-
-import Control.Monad
-import Control.Monad.Reader
-import Control.Monad.State
-import Control.Monad.Writer
-
-import Data.Monoid
-import Data.Set (Set)
-import qualified Data.Set as Set
-
-vanishingView :: (?vs :: ViewSettings) => Int -> Int -> Color -> Color ->
- Color -> Color ->
- Color -> Color -> FenState -> Vob Node
-vanishingView depth maxnodes bgColor blurBgColor focusColor blurColor
- textColor blurTextColor
- state@(FenState {fsGraph=graph, fsPath=path, fsMark=mark,
- fsHasFocus=focus}) =
- let ?graph = graph in result where
- startRotation :: (?graph :: Graph) => Rotation
- startRotation = fsRotation state
- result :: (?graph :: Graph) => Vob Node
- result = runVanishing depth maxnodes view where
- -- place the center of the view and all subtrees in both directions
- view = do placeNode (if focus then Just (bgColor, focusColor, textColor)
- else Just (blurBgColor, blurColor, blurTextColor))
- startRotation
- let Rotation n _ = startRotation in visitNode n
- forM_ [Pos, Neg] $ \dir -> do
- placeConns startRotation dir True
- -- place all subtrees in xdir
- placeConns rotation xdir placeFirst = withDepthIncreased 1 $ do
- when placeFirst $ placeConn rotation xdir
- forM_ [-1, 1] $ \ydir -> do
- placeConns' rotation xdir ydir
- -- place rest of the subtrees in (xdir, ydir)
- placeConns' rotation xdir ydir = withDepthIncreased 1 $
- maybeDo (rotate rotation ydir) $ \rotation' -> do
- withAngleChanged (fromIntegral ydir * mul xdir pi / 14) $ do
- placeConn rotation' xdir
- placeConns' rotation' xdir ydir
- -- place one subtree
- placeConn rotation@(Rotation n1 _) dir = withDepthIncreased 1 $
- maybeDo (toPath rotation dir) $ \path'@(Path _ [Conn prop _ n2]) -> do
- let rotation' = fromPath (rev path')
- scale' <- getScale
- withCenterMoved dir (280 * (scale'**3)) $ do
- ifUnvisited n2 $ placeNode Nothing rotation'
- let (nl,nr) = if dir==Pos then (n1,n2) else (n2,n1)
- addVob $ between (center @@ nl) (center @@ nr) $ ownSize $
- centerVob $ scale #scale' $ propView prop
- addVob $ useFgColor $ stroke $
- line (center @@ nl) (center @@ nr)
- ifUnvisited n2 $ visitNode n2 >> do
- placeConns rotation' dir True
- withDepthIncreased 3 $
- placeConns rotation' (rev dir) False
- -- place one node view
- placeNode cols (Rotation node _) = do
- scale' <- getScale
- let f vob = case bg of Nothing -> vob
- Just c -> setFgColor fg $
- setBgColor c vob
- markColor = if node `Set.member` mark then Just (Color 1 0 0 1)
- else Nothing
- bg = combine (fmap (\(_,b,_) -> b) cols) markColor
- fg = maybe (Color 0 0 0 1) (\(_,_,c) -> c) cols
- combine Nothing c = c
- combine c Nothing = c
- combine (Just c1) (Just c2) = Just $ interpolate 0.5 c1 c2
- g vob = case cols of Nothing -> vob
- Just (a,_,_) -> frame a & vob
- where (w,h) = defaultSize vob
- frame c = withColor #c $ fill $
- moveTo (point #(0-10) #(0-10)) &
- lineTo (point #(w+10) #(0-10)) &
- lineTo (point #(w+10) #(h+10)) &
- lineTo (point #(0-10) #(h+10)) &
- closePath
- placeVob $ ownSize $ scale #scale' $ keyVob node $ g $
- f (useBgColor (fill extents) & pad 5 (nodeView node)) &
- useFgColor (stroke extents)
-
- getScale :: VV Double
- getScale = do d <- asks vvDepth; return (0.97 ** fromIntegral d)
-
-
-data VVState = VVState { vvDepth :: Int, vvMaxDepth :: Int, vvMaxNodes :: Int,
- vvX :: Double, vvY :: Double, vvAngle :: Double }
-
-type VV a = ReaderT VVState (BreadthT (StateT (Set Node)
- (Writer (Dual (Vob Node))))) a
-
-runVanishing :: Int -> Int -> VV () -> Vob Node
-runVanishing maxdepth maxnodes vv = comb (0,0) $ \cx ->
- let (w,h) = rcSize cx
- in getDual $ execWriter $ flip execStateT Set.empty $ execBreadthT $
- runReaderT vv $ VVState 0 maxdepth maxnodes (w/2) (h/2) 0
-
--- |Execute the passed action with the recursion depth increased by
--- the given amount of steps, if it is still smaller than the maximum
--- recursion depth.
---
-withDepthIncreased :: Int -> VV () -> VV ()
-withDepthIncreased n m = do
- state <- ask; let state' = state { vvDepth = vvDepth state + n }
- if vvDepth state' >= vvMaxDepth state' then return () else
- lift $ scheduleBreadthT $ flip runReaderT state' $ do
- visited <- get
- when (Set.size visited <= (4 * vvMaxNodes state') `div` 3) m
-
-visitNode :: Node -> VV ()
-visitNode n = modify (Set.insert n)
-
-ifUnvisited :: Node -> VV () -> VV ()
-ifUnvisited n m = do visited <- get
- when (not $ n `Set.member` visited) m
-
-addVob :: Vob Node -> VV ()
-addVob vob = do d <- asks vvDepth; md <- asks vvMaxDepth
- mn <- asks vvMaxNodes; visited <- get
- let x = (fromIntegral (md - d) / fromIntegral (md+2))
- vob' = if Set.size visited >= mn then invisibleVob vob
- else fade x vob
- tell (Dual vob')
-
-placeVob :: Vob Node -> VV ()
-placeVob vob = do
- state <- ask
- addVob $ translate #(vvX state) #(vvY state) $ centerVob vob
-
-withCenterMoved :: Dir -> Double -> VV () -> VV ()
-withCenterMoved dir distance = local f where
- distance' = mul dir distance
- f s = s { vvX = vvX s + distance' * cos (vvAngle s),
- vvY = vvY s + distance' * sin (vvAngle s) }
-
-withAngleChanged :: Double -> VV () -> VV ()
-withAngleChanged delta = local $ \s -> s { vvAngle = vvAngle s + delta }
diff -rN -u old-fenfire-hs/VobTest.fhs new-fenfire-hs/VobTest.fhs
--- old-fenfire-hs/VobTest.fhs 2007-03-13 16:04:04.000000000 +0200
+++ new-fenfire-hs/VobTest.fhs 1970-01-01 02:00:00.000000000 +0200
@@ -1,174 +0,0 @@
-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
- (\_ -> return ())
- (\_ _ -> return ())
- (\_ -> return ())
- lightGray 3
-
- set window [ containerChild := canvas ]
-
- onDestroy window mainQuit
- widgetShowAll window
- mainGUI
diff -rN -u old-fenfire-hs/Vobs.fhs new-fenfire-hs/Vobs.fhs
--- old-fenfire-hs/Vobs.fhs 2007-03-13 16:04:04.000000000 +0200
+++ new-fenfire-hs/Vobs.fhs 1970-01-01 02:00:00.000000000 +0200
@@ -1,457 +0,0 @@
-{-# OPTIONS_GHC -fallow-overlapping-instances #-}
-module Vobs 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 Latex2Png
-import Cache
-
-import Data.IORef
-import System.IO.Unsafe (unsafePerformIO)
-import qualified System.Time
-
-import Control.Applicative
-import Control.Monad.Reader
-import Control.Monad.Trans (liftIO, MonadIO)
-
-import Graphics.UI.Gtk hiding (Point, Size, Layout, Color, get, fill)
-import qualified Graphics.Rendering.Cairo as C
-import Graphics.Rendering.Cairo.Matrix (Matrix(Matrix))
-import qualified Graphics.Rendering.Cairo.Matrix as Matrix
-import Graphics.UI.Gtk.Cairo
-
-import Data.List (intersect)
-import Data.Map (Map, keys, fromList, toList, insert, empty)
-import qualified Data.Map as Map
-import Data.Maybe (fromMaybe, isJust)
-import Data.Monoid (Monoid(mempty, mappend, mconcat))
-
-import Control.Monad (when)
-import Control.Monad.State
-import Control.Monad.Reader
-
-import qualified Control.Exception
-
-type Scene k = Map k (Maybe (Matrix, Size))
-data Vob k = Vob { defaultSize :: Size,
- vobScene :: RenderContext k -> Scene k,
- renderVob :: RenderContext k -> Render () }
-
-type Cx k = MaybeT (Reader (RenderContext k))
-
-runCx :: RenderContext k -> Cx k a -> Maybe a
-runCx cx m = runReader (runMaybeT m) cx
-
-data RenderContext k = RenderContext {
- rcRect :: Rect, rcScene :: Scene k, rcFade :: Double,
- rcFgColor :: Color, rcBgColor :: Color, rcFadeColor :: Color }
-
-rcMatrix = fst . rcRect; rcSize = snd . rcRect
-
-type View s k = s -> Vob k
-type Handler e s = e -> HandlerAction s
-
-type HandlerAction s = StateT s (StateT (Bool, Bool) IO) ()
-
-
-instance Ord k => Monoid (Vob k) where
- mempty = Vob (0,0) (const Map.empty) (const $ return ())
- mappend (Vob (w1,h1) sc1 r1) (Vob (w2,h2) sc2 r2) = Vob (w,h) sc r where
- (w,h) = (max w1 w2, max h1 h2)
- sc cx = Map.union (sc1 cx) (sc2 cx)
- r cx = r1 cx >> r2 cx
-
-instance Functor (Cx k) where fmap = liftM
-instance Applicative (Cx k) where
- pure = return
- (<*>) = ap
-
-instance Ord k => Cairo (Cx k) (Vob k) where
- cxAsk = asks rcRect
-
- cxLocal rect m = do rect' <- rect; local (\cx -> cx { rcRect = rect' }) m
-
- cxWrap f (Vob size sc ren) =
- Vob size sc $ \cx -> maybeDo (runCx cx $ f $ ren cx) id
-
- cxLocalR rect (Vob size sc ren) = Vob size
- (\cx -> let msc = liftM sc (upd cx)
- in Map.mapWithKey (\k _ -> msc >>= (Map.! k)) (sc cx))
- (\cx -> maybe (return ()) ren (upd cx))
- where upd cx = do rect' <- runCx cx rect
- return $ cx { rcRect = rect' }
-
-
-defaultWidth (Vob (w,_) _ _) = w
-defaultHeight (Vob (_,h) _ _) = h
-
-
-setInterp :: Bool -> HandlerAction s
-setInterp interp = lift $ modify $ \(_,handled) -> (interp, handled)
-
-unhandledEvent :: HandlerAction s
-unhandledEvent = lift $ modify $ \(interp,_) -> (interp, False)
-
-runHandler handleEvent state event = do
- (((), state'), (interpolate', handled)) <-
- runStateT (runStateT (handleEvent event) state) (False, True)
- return (state',interpolate',handled)
-
-
-(@@) :: Ord k => Cx k a -> k -> Cx k a -- pronounce as 'of'
-(@@) x key = do cx <- ask
- rect <- maybeReturn =<< Map.lookup key (rcScene cx)
- local (\_ -> cx { rcRect = rect }) x
-
-
-changeSize :: Ord k => Endo Size -> Endo (Vob k)
-changeSize f vob = vob { defaultSize = f $ defaultSize vob }
-
-changeContext :: Ord k => Endo (RenderContext k) -> Endo (Vob k)
-changeContext f (Vob s sc r) = Vob s (sc . f) (r . f)
-
-changeRect :: Ord k => Endo Rect -> Endo (Vob k)
-changeRect f = changeContext (\cx -> cx { rcRect = f $ rcRect cx })
-
-ownSize :: Ord k => Endo (Vob k)
-ownSize vob = changeRect (\(m,_) -> (m, defaultSize vob)) vob
-
-invisibleVob :: Ord k => Endo (Vob k)
-invisibleVob = cxWrap (const mempty)
-
-
-comb :: Size -> (RenderContext k -> Vob k) -> Vob k
-comb size f =
- Vob size (\cx -> vobScene (f cx) cx) (\cx -> renderVob (f cx) cx)
-
-renderable :: Ord k => Size -> Render () -> Vob k
-renderable size ren = Vob size (const Map.empty) $ \cx -> do
- do C.save; C.transform (rcMatrix cx); ren; C.restore
-
-
-keyVob :: Ord k => k -> Endo (Vob k)
-keyVob key vob = vob {
- vobScene = \cx -> Map.insert key (Just $ rcRect cx) (vobScene vob cx),
- renderVob = \cx ->
- maybeDo (maybeReturn =<< (Map.lookup key $ rcScene cx)) $ \rect ->
- renderVob vob $ cx { rcRect = rect } }
-
-showAtKey :: Ord k => k -> Endo (Vob k)
-showAtKey key vob = vob {
- vobScene = \cx -> let mrect = maybeReturn =<< Map.lookup key (rcScene cx)
- mcx = fmap (\rect' -> cx { rcRect=rect' }) mrect
- msc = liftM (vobScene vob) mcx
- in Map.mapWithKey (\k _ -> msc >>= (Map.! k))
- (vobScene vob cx),
- renderVob = \cx ->
- maybeDo (maybeReturn =<< (Map.lookup key $ rcScene cx)) $ \rect ->
- renderVob vob $ cx { rcRect = rect } }
-
-
-rectBox :: Ord k => Endo (Vob k)
-rectBox vob = useBgColor (fill extents) & clip extents vob &
- useFgColor (stroke extents)
-
-vbox :: Ord k => [Vob k] -> Vob k
-vbox vobs = mconcat [translate #0 #y $ ownSize v | (v,y) <- zip vobs ys] where
- ys = scanl (+) 0 $ map defaultHeight $ init vobs
-
-
-pangoContext :: PangoContext
-pangoContext = unsafePerformIO $ do
- context <- cairoCreateContext Nothing
- desc <- contextGetFontDescription context
- fontDescriptionSetFamily desc "Sans"
- fontDescriptionSetSize desc (fromInteger 10)
- contextSetFontDescription context desc
- return context
-
-
-label :: Ord k => String -> Vob k
-label s = unsafePerformIO $ do
- layout <- layoutText pangoContext s
- (PangoRectangle _ _ w1 h1, PangoRectangle _ _ w2 h2)
- <- layoutGetExtents layout
- let w = max w1 w2; h = max h1 h2
- return $ renderable (realToFrac w, realToFrac h) $ showLayout layout
-
-multiline :: Ord k => Bool -> Int -> String -> Vob k
-multiline useTextWidth widthInChars s = unsafePerformIO $ do
- layout <- layoutText pangoContext s
- layoutSetWrap layout WrapPartialWords
- desc <- contextGetFontDescription pangoContext
- lang <- languageFromString s
- (FontMetrics {approximateCharWidth=cw, ascent=ascent', descent=descent'})
- <- contextGetMetrics pangoContext desc lang
- let w1 = fromIntegral widthInChars * cw
- h1 = ascent' + descent'
- layoutSetWidth layout (Just w1)
- (PangoRectangle _ _ w2 h2, PangoRectangle _ _ w3 h3)
- <- layoutGetExtents layout
- let w = if useTextWidth then max w2 w3 else w1
- h = maximum [h1, h2, h3]
- return $ renderable (realToFrac w, realToFrac h) $ showLayout layout
-
-getSurfaceSize :: C.Surface -> IO (Int,Int)
-getSurfaceSize surface = do
- w <- C.renderWith surface $ C.imageSurfaceGetWidth surface
- h <- C.renderWith surface $ C.imageSurfaceGetHeight surface
- return (w,h)
-
-createImageSurfaceFromPNG :: FilePath -> IO C.Surface
-createImageSurfaceFromPNG file =
- C.withImageSurfaceFromPNG file $ \surface -> do
- (w,h) <- getSurfaceSize surface
- surface' <- C.createImageSurface C.FormatARGB32 w h
- C.renderWith surface' $ do
- C.setSourceSurface surface 0 0
- C.rectangle 0 0 (realToFrac w) (realToFrac h)
- C.fill
- return surface'
-
--- image :: Ord k => FilePath -> Vob k
-image file = {- unsafePerformIO $ -} do
- surface <- createImageSurfaceFromPNG file
- (w,h) <- getSurfaceSize surface
- return $ changeSize (const (realToFrac w, realToFrac h)) $
- withSurface #surface $ fill extents
-
-latexCache :: Cache.Cache String (Vob k)
-latexCache = Cache.newCache 10000
-
-latex :: Ord k => String -> Vob k
-latex code = Cache.cached code latexCache $ unsafePerformIO $ do
- withLatexPng code $ maybe (return $ setFgColor (Color 0.7 0.5 0.1 1)
- $ useFgColor $ multiline False 20 code)
- ({- return . -} image)
-
-fadedColor :: Ord k => Endo (Cx k Color)
-fadedColor c = liftM3 interpolate (asks rcFade) (asks rcFadeColor) c
-
-setFgColor :: Ord k => Color -> Endo (Vob k)
-setFgColor c = changeContext $ \cx -> cx { rcFgColor = c }
-
-setBgColor :: Ord k => Color -> Endo (Vob k)
-setBgColor c = changeContext $ \cx -> cx { rcBgColor = c }
-
-useFgColor :: Ord k => Endo (Vob k)
-useFgColor = withColor (fadedColor $ asks rcFgColor)
-
-useBgColor :: Ord k => Endo (Vob k)
-useBgColor = withColor (fadedColor $ asks rcBgColor)
-
-useFadeColor :: Ord k => Endo (Vob k)
-useFadeColor = withColor (asks rcFadeColor)
-
-fade :: Ord k => Double -> Endo (Vob k)
-fade a = changeContext $ \cx -> cx { rcFade = rcFade cx * a }
-
-
-centerVob :: Ord k => Endo (Vob k)
-centerVob vob = translate (pure (-w/2)) (pure (-h/2)) vob
- where (w,h) = defaultSize vob
-
-
-pad4 :: Ord k => Double -> Double -> Double -> Double -> Endo (Vob k)
-pad4 x1 x2 y1 y2 vob =
- changeSize (const (x1+w+x2, y1+h+y2)) $
- changeRect (\(m,(w',h')) -> (f m, (w'-x1-x2, h'-y1-y2))) vob
- where (w,h) = defaultSize vob; f = Matrix.translate x1 y1
-
-pad2 :: Ord k => Double -> Double -> Endo (Vob k)
-pad2 x y = pad4 x x y y
-
-pad :: Ord k => Double -> Endo (Vob k)
-pad pixels = pad2 pixels pixels
-
-scaleVob :: Ord k => Double -> Endo (Vob k)
-scaleVob sc vob = scale #sc $ vob { defaultSize = (sc*w, sc*h) } where
- (w,h) = defaultSize vob
-
-
-class Interpolate a where
- interpolate :: Double -> Op a
-
-instance Interpolate Double where
- interpolate fract x y = (1-fract)*x + fract*y
-
-instance Interpolate Color where
- interpolate fract (Color r g b a) (Color r' g' b' a') =
- Color (i r r') (i g g') (i b b') (i a a') where
- i = interpolate fract
-
-instance Interpolate Matrix where
- interpolate fract (Matrix u v w x y z) (Matrix u' v' w' x' y' z') =
- Matrix (i u u') (i v v') (i w w') (i x x') (i y y') (i z z') where
- i = interpolate fract
-
-interpolateScene :: Ord k => Double -> Op (Scene k)
-interpolateScene fract sc1 sc2 =
- fromList [(key, liftM2 f (sc1 Map.! key) (sc2 Map.! key))
- | key <- interpKeys] where
- interpKeys = intersect (keys sc1) (keys sc2)
- f (m1,(w1,h1)) (m2,(w2,h2)) = (i m1 m2, (j w1 w2, j h1 h2))
- i x y = interpolate fract x y
- -- don't bounce width and height, it usually doesn't look good:
- j x y = interpolate (max 0 $ min 1 $ fract) x y
-
-
-isInterpUseful :: Ord k => Scene k -> Scene k -> Bool
-isInterpUseful sc1 sc2 =
- not $ all same [(sc1 Map.! key, sc2 Map.! key) | key <- interpKeys]
- where same (a,b) = all (\d -> abs d < 5) $ zipWith (-) (values a) (values b)
- values (Just (Matrix a b c d e f, (w,h))) = [a,b,c,d,e,f,w,h]
- values Nothing = error "shouldn't happen"
- interpKeys = intersect (getKeys sc1) (getKeys sc2)
- getKeys sc = [k | k <- keys sc, isJust (sc Map.! k)]
-
-instance Show Modifier where
- show Shift = "Shift"
- show Control = "Control"
- show Alt = "Alt"
- show Apple = "Apple"
- show Compose = "Compose"
-
-timeDbg :: MonadIO m => String -> Endo (m ())
-timeDbg s act | False = do out s; act; out s
- | otherwise = act
- where out t = liftIO $ do time <- System.Time.getClockTime
- putStrLn $ s ++ " " ++ t ++ "\t" ++ show time
-
-
-linearFract :: Double -> (Double, Bool)
-linearFract x = if (x<1) then (x,True) else (1,False)
-
-bounceFract :: Double -> (Double, Bool)
-bounceFract x = (y,cont) where -- ported from AbstractUpdateManager.java
- x' = x + x*x
- y = 1 - cos (2 * pi * n * x') * exp (-x' * r)
- cont = -(x + x*x)*r >= log 0.02
- (n,r) = (0.4, 2)
-
-
-
-type Anim a = Time -> (Scene a, Bool) -- bool is whether to re-render
-
-interpAnim :: Ord a => Time -> TimeDiff -> Scene a -> Scene a -> Anim a
-interpAnim startTime interpDuration sc1 sc2 time =
- if continue then (interpolateScene fract sc1 sc2, True) else (sc2, False)
- where (fract, continue) = bounceFract ((time-startTime) / interpDuration)
-
-noAnim scene = const (scene, False)
-
-
-vobCanvas :: Ord b => IORef a -> View a b -> Handler Event a ->
- Handler c a -> (a -> a -> IO ()) ->
- (Control.Exception.Exception -> IO ()) ->
- Color -> TimeDiff ->
- IO (DrawingArea, Bool -> IO (), c -> IO Bool)
-vobCanvas stateRef view eventHandler actionHandler stateChanged
- handleException bgColor animTime = do
- canvas <- drawingAreaNew
-
- widgetSetCanFocus canvas True
-
- animRef <- newIORef (mempty, Map.empty, noAnim Map.empty)
-
- let getWH = do (cw, ch) <- widgetGetSize canvas
- return (fromIntegral cw, fromIntegral ch)
-
- getVob = do state <- readIORef stateRef
- return $ useFadeColor paint & view state
-
- getRenderContext sc = do
- size <- getWH; return $ RenderContext {
- rcScene=sc, rcRect=(Matrix.identity, size), rcFade=1,
- rcFgColor=black, rcBgColor=white, rcFadeColor=bgColor }
-
- updateAnim interpolate' = mdo
- (vob,scene,_) <- readIORef animRef
- vob' <- getVob
-
- rc' <- getRenderContext scene'
- let scene' = vobScene vob' rc'
-
- time <- scene' `seq` getTime
-
- let anim' = if interpolate' && isInterpUseful scene scene'
- then interpAnim time animTime scene scene'
- else noAnim scene'
-
- writeIORef animRef (vob', scene', anim')
-
- widgetQueueDraw canvas
-
- handle handler event = do
- state <- readIORef stateRef
- Control.Exception.catch
- (do (state', interpolate', handled) <-
- runHandler handler state event
-
- when handled $ do writeIORef stateRef state'
- stateChanged state state'
- updateAnim interpolate'
-
- return handled )
- (\e -> do
- putStr ("Exception in event: ") >> print e
- writeIORef stateRef state
- stateChanged state state -- XXX how to write this?
-
- handleException e
- return True )
-
- handleEvent = handle eventHandler
-
- handleAction = handle actionHandler
-
- onRealize canvas $ mdo vob <- getVob; rc <- getRenderContext scene
- let scene = vobScene vob rc
- writeIORef animRef (vob, scene, noAnim scene)
-
- onConfigure canvas $ \_event -> do updateAnim False; return True
-
- onKeyPress canvas $ \event -> do
- let Key {eventModifier=mods,eventKeyName=key,eventKeyChar=char} = event
- putStrLn $ show mods++" "++key++" ("++show char++")"
-
- handleEvent event
-
- onButtonPress canvas $ \(Button {}) -> do
- widgetGrabFocus canvas
- return True
-
- onExpose canvas $ \(Expose {}) -> do
- drawable <- widgetGetDrawWindow canvas
-
- (vob, _, anim) <- readIORef animRef; time <- getTime
- let (scene, rerender) = anim time
- rc <- getRenderContext scene
-
- renderWithDrawable drawable $ timeDbg "redraw" $ renderVob vob rc
-
- if rerender then widgetQueueDraw canvas else return ()
-
- return True
-
- return (canvas, updateAnim, handleAction)
diff -rN -u old-fenfire-hs/fenfire.cabal new-fenfire-hs/fenfire.cabal
--- old-fenfire-hs/fenfire.cabal 2007-03-13 16:04:04.000000000 +0200
+++ new-fenfire-hs/fenfire.cabal 2007-03-13 16:04:04.000000000 +0200
@@ -17,53 +17,53 @@
Data-Files: data-files/logo.svg data-files/icon16.png
Executable: fenfire
-Main-Is: Main.hs
-Other-Modules: Fenfire, Vobs, Data.RDF, Cache, Cairo, Utils, Data.RDF.Raptor, FunctorSugar,
- GtkFixes, VanishingView, Main
+Main-Is: Fenfire/Main.hs
+Other-Modules: Fenfire, Fenfire.Vobs, Data.RDF, Fenfire.Cache, Fenfire.Cairo, Fenfire.Utils, Data.RDF.Raptor, FunctorSugar,
+ Fenfire.GtkFixes, Fenfire.VanishingView, Fenfire.Main
GHC-Options: -fglasgow-exts -hide-package haskell98 -Wall
-fno-warn-unused-imports -fno-warn-missing-signatures
- -fno-warn-orphans -main-is Main.main
+ -fno-warn-orphans -main-is Fenfire.Main.main
Extra-Libraries: raptor
Executable: functortest
-Main-Is: FunctorTest.hs
-Other-Modules: FunctorTest, FunctorSugar
+Main-Is: Fenfire/FunctorTest.hs
+Other-Modules: Fenfire.FunctorTest, FunctorSugar
GHC-Options: -fglasgow-exts -hide-package haskell98 -Wall
-fno-warn-unused-imports -fno-warn-missing-signatures
- -fno-warn-orphans -main-is FunctorTest.main
+ -fno-warn-orphans -main-is Fenfire.FunctorTest.main
Executable: vobtest
-Main-Is: VobTest.hs
-Other-Modules: VobTest, Vobs, Cairo, Utils, FunctorSugar
+Main-Is: Fenfire/VobTest.hs
+Other-Modules: Fenfire.VobTest, Fenfire.Vobs, Fenfire.Cairo, Fenfire.Utils, FunctorSugar
GHC-Options: -fglasgow-exts -hide-package haskell98 -Wall
-fno-warn-unused-imports -fno-warn-missing-signatures
- -fno-warn-orphans -main-is VobTest.main
+ -fno-warn-orphans -main-is Fenfire.VobTest.main
Executable: frptest
-Main-Is: FRP.hs
-Other-Modules: FRP, Utils, FunctorSugar
+Main-Is: Fenfire/FRP.hs
+Other-Modules: Fenfire.FRP, Fenfire.Utils, FunctorSugar
GHC-Options: -fglasgow-exts -hide-package haskell98 -Wall
-fno-warn-unused-imports -fno-warn-missing-signatures
- -fno-warn-orphans -main-is FRP.main
+ -fno-warn-orphans -main-is Fenfire.FRP.main
Executable: darcs2rdf
-Main-Is: Darcs2RDF.hs
-Other-Modules: Darcs2RDF, FunctorSugar
+Main-Is: Fenfire/Darcs2RDF.hs
+Other-Modules: Fenfire.Darcs2RDF, FunctorSugar
GHC-Options: -fglasgow-exts -hide-package haskell98 -Wall
-fno-warn-unused-imports -fno-warn-missing-signatures
- -fno-warn-orphans -main-is Darcs2RDF.main
+ -fno-warn-orphans -main-is Fenfire.Darcs2RDF.main
Executable: irc2rdf
-Main-Is: Irc2RDF.hs
-Other-Modules: Irc2RDF
+Main-Is: Fenfire/Irc2RDF.hs
+Other-Modules: Fenfire.Irc2RDF
GHC-Options: -fglasgow-exts -hide-package haskell98 -Wall
-fno-warn-unused-imports -fno-warn-missing-signatures
- -fno-warn-orphans -main-is Irc2RDF.main
+ -fno-warn-orphans -main-is Fenfire.Irc2RDF.main
Executable: latex2png
-Main-Is: Latex2Png.hs
-Other-Modules: Latex2Png
+Main-Is: Fenfire/Latex2Png.hs
+Other-Modules: Fenfire.Latex2Png
GHC-Options: -fglasgow-exts -hide-package haskell98 -Wall
-fno-warn-unused-imports -fno-warn-missing-signatures
- -fno-warn-orphans -main-is Latex2Png.main
+ -fno-warn-orphans -main-is Fenfire.Latex2Png.main
More information about the Fencommits
mailing list