[Fencommits] fenserve: add demo for showing some RDF. not very comprehensible but it's a start =)
Benja Fallenstein
benja.fallenstein at gmail.com
Mon Mar 26 03:50:26 EEST 2007
Mon Mar 26 03:48:58 EEST 2007 Benja Fallenstein <benja.fallenstein at gmail.com>
* add demo for showing some RDF. not very comprehensible but it's a start =)
diff -rN -u old-fenserve/FenServe.hs new-fenserve/FenServe.hs
--- old-fenserve/FenServe.hs 2007-03-26 03:50:26.000000000 +0300
+++ new-fenserve/FenServe.hs 2007-03-26 03:50:26.000000000 +0300
@@ -268,12 +268,17 @@
-- Running executable resources
--------------------------------------------------------------------------
-imports = ["Fenfire.RDF", "HAppS hiding (Handler, query)",
+imports = ["Fenfire.RDF",
+ "Fenfire.Utils ((!?), Endo, maybeDo, BreadthT, scheduleBreadthT, execBreadthT)",
+ "HAppS hiding (Handler, query)",
"PagePrelude", "Storm", "FenServe",
- "Control.Monad", "Data.Maybe",
+ "Control.Monad", "Control.Monad.State",
+ "Control.Monad.Writer hiding (Endo,Any)",
+ "Control.Monad.Reader", "Data.Maybe",
"qualified Data.ByteString as ByteString",
"qualified Data.List as List",
- "qualified Data.Map as Map"]
+ "qualified Data.Map as Map",
+ "qualified Data.Set as Set"]
codeCache :: IORef (Map BlockId Handler)
codeCache = unsafePerformIO $ newIORef Map.empty
diff -rN -u old-fenserve/vanishing-demo.page new-fenserve/vanishing-demo.page
--- old-fenserve/vanishing-demo.page 1970-01-01 02:00:00.000000000 +0200
+++ new-fenserve/vanishing-demo.page 2007-03-26 03:50:26.000000000 +0300
@@ -0,0 +1,195 @@
+-- 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
+
+data ViewSettings = ViewSettings { hiddenProps :: [Node], maxCenter :: Int }
+
+data Rotation = Rotation { rotationNode :: Node, rotationOffs :: Int }
+ deriving (Eq, Show)
+
+ffFromPath :: (?vs :: ViewSettings, ?graph :: Graph) => Path -> Rotation
+ffFromPath path@(Path node (Conn _ dir _ : _)) = fromMaybe (Rotation node 0) $ do
+ let c = conns node dir
+ i <- List.elemIndex path c
+ return $ Rotation node (i - min (length c `div` 2) (maxCenter ?vs))
+ffFromPath (Path node []) = Rotation node 0
+
+toPath :: (?vs :: ViewSettings, ?graph :: Graph) =>
+ Rotation -> Dir -> Maybe Path
+toPath (Rotation node r) dir = let c = conns node dir in
+ c !? (min (length c `div` 2) (maxCenter ?vs) + r)
+
+toPath' rot@(Rotation node _) =
+ head $ catMaybes [toPath rot Pos, toPath rot Neg, Just $ Path node []]
+
+dc_date = IRI "http://purl.org/dc/elements/1.1/date"
+dcterms_created = IRI "http://purl.org/dc/terms/created"
+
+iquery :: (Pattern pat r, ?graph :: Graph) => pat -> r
+iquery pat = query pat ?graph
+
+conns :: (?vs :: ViewSettings, ?graph :: Graph) => Node -> Dir -> [Path]
+conns node dir = result where
+ result = map (\(prop, node') -> Path node [Conn prop dir node']) sorted
+ sorted = List.sortBy cmp' list
+ query' (x,p,y) = case dir of Pos -> iquery (x,p,y); Neg -> iquery (y,p,x)
+ list = [(p,n) | p <- query' (node, X, Any),
+ not (p `elem` hiddenProps ?vs),
+ n <- query' (node, p, X) ]
+ cmp n1 n2 | Just d1 <- f n1, Just d2 <- f n2 = compare d1 d2 where
+ f n = msum [g dc_date n, g dcterms_created n]
+ g prop n = iquery (n, prop, X) :: Maybe Node
+ cmp n1 n2 = compare (getText n1) (getText n2)
+ cmp' (p1,n1) (p2,n2) = catOrds (cmp p1 p2) (cmp n1 n2)
+ catOrds EQ o = o; catOrds o _ = o
+
+rotate :: (?vs :: ViewSettings, ?graph :: Graph) =>
+ Rotation -> Int -> Maybe Rotation
+rotate (Rotation n r) dir = let rot = Rotation n (r+dir) in do
+ guard $ any isJust [toPath rot d | d <- [Pos, Neg]]; return rot
+
+move :: (?vs :: ViewSettings, ?graph :: Graph) =>
+ Rotation -> Dir -> Maybe Rotation
+move rot dir = do path <- toPath rot dir
+ return $ ffFromPath (rev path)
+
+dc = "http://purl.org/dc/elements/1.1/"
+dc_title = IRI $ dc ++ "title"
+
+getText :: (?graph :: Graph) => Node -> Maybe String
+getText n = listToMaybe $ catMaybes $ map f $ iquery (n, dc_title, X) where
+ f (Literal s _) = Just s; f _ = Nothing
+
+getTextOrIRI :: (?graph :: Graph) => Node -> String
+getTextOrIRI n = fromMaybe (showNode (graphNamespaces ?graph) n) (getText n)
+
+setText :: Node -> String -> Endo Graph
+setText n t = update (n, rdfs_label, Literal t Plain)
+
+
+vanishingView :: (?vs :: ViewSettings) => Int -> Int -> Graph -> Path -> HTML
+vanishingView depth maxnodes graph path =
+ let ?graph = graph in result where
+ startRotation :: (?graph :: Graph) => Rotation
+ startRotation = ffFromPath path
+ result :: (?graph :: Graph) => HTML
+ result = runVanishing depth maxnodes view where
+ -- place the center of the view and all subtrees in both directions
+ view = do placeNode 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' = ffFromPath (rev path')
+ scale' <- getScale
+ withCenterMoved dir (280 * (scale'**3)) $ do
+ ifUnvisited n2 $ placeNode 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 (Rotation node _) = do
+ placeVob (pcdata $ getTextOrIRI node)
+
+ getScale :: VV Double
+ getScale = do d <- asks vvDepth; return (0.97 ** fromIntegral d)
+
+instance Monoid HTML where
+ mempty = HTML ""
+ mappend (HTML x) (HTML y) = HTML (x ++ y)
+
+data VVState = VVState { vvDepth :: Int, vvMaxDepth :: Int, vvMaxNodes :: Int,
+ vvX :: Double, vvY :: Double, vvAngle :: Double }
+
+type VV a = ReaderT VVState (BreadthT (StateT (Set.Set Node)
+ (Writer (Dual HTML)))) a
+
+runVanishing :: Int -> Int -> VV () -> HTML
+runVanishing maxdepth maxnodes vv =
+ let (w,h) = (750,500)
+ 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 :: HTML -> 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 :: HTML -> VV ()
+placeVob vob = do
+ state <- ask
+ let style="left: "++(show $ vvX state)++"; top: "++(show $ vvY state)++
+ ";border: 2px solid black; position:absolute; "++
+ "background-color: #ccc; width: 10em; padding: 3"
+ addVob $ <div style=style><% vob %></div>
+
+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 }
+
+handler req = do
+ Right (FileEntry r) <- getEntry ["testdata","blog"]
+ graph <- readGraph (bID r)
+ let ?vs = ViewSettings { hiddenProps=[rdfs_label], maxCenter=3 } in
+ pageHandler (vanishingView 20 30 graph (Path (IRI "ex:post") [])) req
+
More information about the Fencommits
mailing list