[Fencommits] fenfire-hs: A presentation view
Benja Fallenstein
benja.fallenstein at gmail.com
Thu Feb 15 15:54:22 EET 2007
Thu Feb 15 14:37:33 EET 2007 Benja Fallenstein <benja.fallenstein at gmail.com>
* A presentation view
diff -rN -u old-fenfire-hs-1/Fenfire.fhs new-fenfire-hs-1/Fenfire.fhs
--- old-fenfire-hs-1/Fenfire.fhs 2007-02-15 15:54:22.000000000 +0200
+++ new-fenfire-hs-1/Fenfire.fhs 2007-02-15 15:54:22.000000000 +0200
@@ -32,11 +32,12 @@
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Data.Tree as Tree
+import Data.List (intersperse)
import qualified Data.List
import Data.Set (Set)
import Data.IORef
import Data.Maybe (fromJust, isJust, isNothing, catMaybes)
-import Data.Monoid(Monoid(mconcat), Dual(Dual), getDual)
+import Data.Monoid(Monoid(mempty, mconcat), Dual(Dual), getDual)
import Control.Applicative
import Control.Monad (when, guard, msum)
@@ -63,7 +64,7 @@
data ViewSettings = ViewSettings { hiddenProps :: [Node] }
data FenState = FenState { fsRotation :: Rotation, fsMark :: Mark,
fsFilePath :: FilePath, fsGraphModified :: Bool,
- fsHasFocus :: Bool }
+ fsHasFocus :: Bool, fsView :: Int }
data Rotation = Rotation Graph Node Int deriving (Eq, Show)
@@ -248,6 +249,21 @@
+presentationView :: (?vs :: ViewSettings) => View FenState Node
+presentationView state = cursor & vob where
+ Rotation graph node _ = fsRotation state
+ children = map snd (conns graph node Pos)
+ selected = fmap (\(_,Rotation _ n _) -> n) $
+ getConn (fsRotation state) Pos
+ f sc n = keyVob n $ useFgColor $ pad 5 $ scaleVob sc $
+ multiline True 70 $ maybe (show n) id (getText graph n)
+ cursor = flip (maybe mempty) selected $ \n ->
+ showAtKey n $ keyVob (PlainLiteral "CURSOR") $ rectBox mempty
+ space = changeSize (const (0, 20)) mempty
+ vob = pad 30 $ vbox $ intersperse space $ f 3 node : map (f 2) children
+
+
+
tryMove :: (?vs :: ViewSettings) => Rotation -> Dir -> Maybe Rotation
tryMove rot@(Rotation g n r) dir = maybe rot' Just (move rot dir) where
rot' | r == nearest = Nothing
@@ -396,7 +412,8 @@
checkSuffix s | Data.List.isSuffixOf ".nt" s = s
| otherwise = s ++ ".nt"
-confirmSave :: (?vs :: ViewSettings, ?pw :: Window, ?uriMaker :: URIMaker) =>
+confirmSave :: (?vs :: ViewSettings, ?pw :: Window,
+ ?views :: [View FenState Node], ?uriMaker :: URIMaker) =>
Bool -> HandlerAction FenState ->
HandlerAction FenState
confirmSave False action = action
@@ -427,9 +444,10 @@
_ -> return ()
newState :: Rotation -> FilePath -> Bool -> FenState
-newState rot fp focus = FenState rot Set.empty fp False focus
+newState rot fp focus = FenState rot Set.empty fp False focus 0
handleEvent :: (?vs :: ViewSettings, ?pw :: Window,
+ ?views :: [View FenState Node],
?uriMaker :: URIMaker) => Handler Event FenState
handleEvent (Key { eventModifier=_mods, eventKeyName=key }) = do
state <- get; let rot = fsRotation state; fileName = fsFilePath state
@@ -438,6 +456,7 @@
x | x == "Down" || x == "comma" -> handleAction "down"
x | x == "Left" || x == "j" -> handleAction "left"
x | x == "Right" || x == "l" -> handleAction "right"
+ "v" -> handleAction "chgview"
"O" -> handleAction "open"
"S" -> do (fp',saved) <- liftIO $ saveFile rot fileName False
let modified' = fsGraphModified state && not saved
@@ -445,13 +464,14 @@
_ -> unhandledEvent
handleEvent _ = unhandledEvent
-handleAction :: (?vs :: ViewSettings, ?pw :: Window,
+handleAction :: (?vs :: ViewSettings, ?pw :: Window,
+ ?views :: [View FenState Node],
?uriMaker :: URIMaker) => Handler String FenState
handleAction action = do
- FenState { fsRotation = rot@(Rotation graph node _), fsMark = mark,
- fsFilePath = filepath, fsGraphModified = modified,
- fsHasFocus=focus
- } <- get
+ state@(FenState { fsRotation = rot@(Rotation graph node _), fsMark = mark,
+ fsFilePath = filepath, fsGraphModified = modified,
+ fsHasFocus=focus
+ }) <- get
let m f x = maybeDo (f rot x) putRotation
b f x = maybeDo (f rot x) $ \rot' -> do
putRotation rot'
@@ -485,6 +505,9 @@
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
_ -> unhandledEvent
where putRotation rot = do modify $ \state -> state { fsRotation=rot,
fsGraphModified=True }
@@ -588,26 +611,19 @@
uriMaker <- newURIMaker
let ?vs = ViewSettings { hiddenProps=[rdfs_label] }
- ?uriMaker = uriMaker in do
+ ?uriMaker = uriMaker in let
+ ?views = [vanishingView 20 30
+ (Color 0.7 0.7 0.8 0.7) (Color 0.7 0.7 0.7 0.7)
+ (Color 0.93 0.93 1 1) (Color 0.93 0.93 0.93 1),
+ presentationView] in do
-- initial state:
args <- initGUI
- window <- windowNew
- style <- widgetGetStyle window
-
- bgColor <- styleGetBackground StateSelected style
- blurBgColor <- styleGetBackground StateActive style
- focusColor <- styleGetBase StateSelected style
- blurColor <- styleGetBase StateActive style
- textColor <- styleGetText StateSelected style
- blurTextColor <- styleGetText StateActive style
-
let view = vanishingView 20 30
- (fromGtkColor bgColor) (fromGtkColor blurBgColor)
- (fromGtkColor focusColor) (fromGtkColor blurColor)
- (fromGtkColor textColor) (fromGtkColor blurTextColor)
+ (Color 0.7 0.7 0.8 0.7) (Color 0.7 0.7 0.7 0.7)
+ (Color 0.93 0.93 1 1) (Color 0.93 0.93 0.93 1)
stateRef <- case args of
[] -> do
@@ -725,15 +741,15 @@
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]
+ 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 ]
+ set window [ containerChild := vBox ]
-- start:
diff -rN -u old-fenfire-hs-1/Vobs.fhs new-fenfire-hs-1/Vobs.fhs
--- old-fenfire-hs-1/Vobs.fhs 2007-02-15 15:54:21.000000000 +0200
+++ new-fenfire-hs-1/Vobs.fhs 2007-02-15 15:54:22.000000000 +0200
@@ -41,7 +41,7 @@
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))
+import Data.Monoid (Monoid(mempty, mappend, mconcat))
import Control.Monad (when)
import Control.Monad.State
@@ -151,13 +151,28 @@
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
@@ -232,6 +247,10 @@
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
More information about the Fencommits
mailing list