glade 0.11.0 → 0.11.1
raw patch · 28 files changed
+3653/−9 lines, 28 filesnew-uploaderbinary-addedPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
Files
- Gtk2HsSetup.hs +1/−1
- demo/calc/Calc.hs +64/−0
- demo/calc/CalcModel.hs +150/−0
- demo/calc/Makefile +11/−0
- demo/calc/calc.glade +374/−0
- demo/glade/GladeTest.hs +26/−0
- demo/glade/Makefile +11/−0
- demo/glade/simple.glade +115/−0
- demo/noughty/Cross.png binary
- demo/noughty/License +29/−0
- demo/noughty/Makefile +18/−0
- demo/noughty/Nought.png binary
- demo/noughty/Noughty.hs +196/−0
- demo/noughty/NoughtyGlade.hs +160/−0
- demo/noughty/noughty.glade +398/−0
- demo/profileviewer/Makefile +11/−0
- demo/profileviewer/ParseProfile.hs +113/−0
- demo/profileviewer/ProfileViewer.glade +426/−0
- demo/profileviewer/ProfileViewer.gladep +8/−0
- demo/profileviewer/ProfileViewer.hs +185/−0
- demo/scaling/London_Eye.jpg binary
- demo/scaling/Makefile +16/−0
- demo/scaling/Mountains.jpg binary
- demo/scaling/Scaling.hs +763/−0
- demo/scaling/Stones.jpg binary
- demo/scaling/scaling.glade +197/−0
- glade.cabal +40/−8
- hierarchy.list +341/−0
Gtk2HsSetup.hs view
@@ -455,7 +455,7 @@ -- existance of a .chs module may not depend on some CPP condition. extractDeps :: ModDep -> IO ModDep extractDeps md@ModDep { mdLocation = Nothing } = return md-extractDeps md@ModDep { mdLocation = Just f } = withFileContents f $ \con -> do+extractDeps md@ModDep { mdLocation = Just f } = withUTF8FileContents f $ \con -> do let findImports acc (('{':'#':xs):xxs) = case (dropWhile ((==) ' ') xs) of ('i':'m':'p':'o':'r':'t':' ':ys) -> case simpleParse (takeWhile ((/=) '#') ys) of
+ demo/calc/Calc.hs view
@@ -0,0 +1,64 @@+module Main where++import Graphics.UI.Gtk+import Graphics.UI.Gtk.Glade++import Data.IORef++import qualified CalcModel as Calc++main = do+ initGUI+ + -- load up the glade file+ calcXmlM <- xmlNew "calc.glade"+ let calcXml = case calcXmlM of+ (Just calcXml) -> calcXml+ Nothing -> error "can't find the glade file \"calc.glade\" \+ \in the current directory"+ + -- get a handle on a some widgets from the glade file+ window <- xmlGetWidget calcXml castToWindow "calcwindow"+ display <- xmlGetWidget calcXml castToLabel "display"+ + -- a list of the names of the buttons and the actions associated with them+ let buttonNamesAndOperations = numbericButtons ++ otherButtons+ numbericButtons = [ ("num-" ++ show n, Calc.enterDigit n)+ | n <- [0..9] ]+ otherButtons =+ [("decimal", Calc.enterDecimalPoint)+ ,("op-plus", Calc.enterBinOp Calc.plus)+ ,("op-minus", Calc.enterBinOp Calc.minus)+ ,("op-times", Calc.enterBinOp Calc.times)+ ,("op-divide", Calc.enterBinOp Calc.divide)+ ,("equals", Calc.evaluate)+ ,("clear", \_ -> Just ("0", Calc.clearCalc))]+ + -- action to do when a button corresponding to a calculator operation gets+ -- pressed: we update the calculator state and display the new result.+ -- These calculator operations can return Nothing for when the operation+ -- makes no sense, we do nothing in this case.+ calcRef <- newIORef Calc.clearCalc+ let calcOperation operation = do+ calc <- readIORef calcRef+ case operation calc of+ Nothing -> return ()+ Just (result, calc') -> do+ display `labelSetLabel` ("<big>" ++ result ++ "</big>")+ writeIORef calcRef calc'++ -- get a reference to a button from the glade file and attach the+ -- handler for when the button is pressed+ connectButtonToOperation name operation = do+ button <- xmlGetWidget calcXml castToButton name+ button `onClicked` calcOperation operation+ + -- connect up all the buttons with their actions.+ mapM_ (uncurry connectButtonToOperation) buttonNamesAndOperations+ + -- make the program exit when the main window is closed+ window `onDestroy` mainQuit+ + -- show everything and run the main loop+ widgetShowAll window+ mainGUI
+ demo/calc/CalcModel.hs view
@@ -0,0 +1,150 @@+-- A simple push button calcualtor without operator precedence++module CalcModel (+ Number,+ Calc,+ BinOp, plus, minus, times, divide,+ clearCalc, enterDigit, enterDecimalPoint, enterBinOp, evaluate+ ) where++import Char (isDigit)+import Monad (when)+import Numeric (showGFloat)++-- we could change this to rational+type Number = Double++data Calc = Calc {+ number :: [Digit],+ operator :: BinOp,+ total :: Number,+ resetOnNum :: Bool -- a state flag, after pressing '=', if we enter an+ } -- operator then we're carrying on the previous+ -- calculation, otherwise we should start a new one.++data Digit = Digit Int -- in range [0..9]+ | DecimalPoint+ deriving Eq++data BinOp = BinOp (Number -> Number -> Number)++plus, minus, times, divide :: BinOp+plus = BinOp (+)+minus = BinOp (-)+times = BinOp (*)+divide = BinOp (/)++clearCalc :: Calc+clearCalc = Calc {+ number = [],+ operator = plus,+ total = 0,+ resetOnNum = True+ }++-- Maybe for the case when the operation makes no sense+enterDigit :: Int -> Calc -> Maybe (String, Calc)+enterDigit digit calc+ | digit `elem` [0..9]+ && not (number calc == [] && digit == 0)+ = let newNumber = number calc ++ [Digit digit]+ in if resetOnNum calc+ then Just (show newNumber,+ calc {+ number = newNumber,+ total = 0,+ resetOnNum = False+ })+ else Just (show newNumber, calc { number = newNumber })+ | otherwise = Nothing++enterDecimalPoint :: Calc -> Maybe (String, Calc)+enterDecimalPoint calc+ | DecimalPoint `notElem` number calc+ = let newNumber = number calc ++ [DecimalPoint]+ in if resetOnNum calc+ then Just (show newNumber,+ calc {+ number = newNumber,+ total = 0,+ resetOnNum = False+ })+ else Just (show newNumber, calc { number = newNumber })+ | otherwise = Nothing++enterBinOp :: BinOp -> Calc -> Maybe (String, Calc)+enterBinOp binop calc =+ let newTotal = (case operator calc of BinOp op -> op)+ (total calc)+ (digitsToNumber (number calc))+ in Just (showNumber newTotal,+ Calc {+ number = [],+ operator = binop,+ total = newTotal,+ resetOnNum = False+ })++evaluate :: Calc -> Maybe (String, Calc)+evaluate calc = + let newTotal = (case operator calc of BinOp op -> op)+ (total calc)+ (digitsToNumber (number calc))+ in Just (showNumber newTotal,+ Calc {+ number = [],+ operator = plus,+ total = newTotal,+ resetOnNum = True+ })++instance Show Digit where+ show (Digit n) = show n+ show DecimalPoint = "."+ showList = showString . concatMap show++digitsToNumber :: [Digit] -> Number+digitsToNumber [] = 0+digitsToNumber digits@(DecimalPoint:_) = digitsToNumber (Digit 0:digits)+digitsToNumber digits | last digits == DecimalPoint+ = digitsToNumber (init digits)+ | otherwise = read (show digits) --CHEAT!++precision = Just 5 --digits of precision, or Nothing for as much as possible++showNumber :: Number -> String+showNumber num =+ if '.' `elem` numStr then stripTrailingZeros numStr+ else numStr+ where numStr = showGFloat precision num ""+ stripTrailingZeros =+ reverse+ . (\str -> if head str == '.' then tail str else str)+ . dropWhile (\c -> c=='0')+ . reverse++testProg :: IO ()+testProg = do+ evalLoop clearCalc+ + where evalLoop :: Calc -> IO ()+ evalLoop calc = do+ putStr "calc> "+ line <- getLine+ when (line /= "q") $ do+ result <- case line of+ [digit] | isDigit digit+ -> return $ enterDigit (read [digit]) calc + "." -> return $ enterDecimalPoint calc+ "+" -> return $ enterBinOp plus calc+ "-" -> return $ enterBinOp minus calc+ "*" -> return $ enterBinOp times calc+ "/" -> return $ enterBinOp divide calc+ "=" -> return $ evaluate calc+ "c" -> return $ Just ("0",clearCalc)+ _ -> do putStrLn "invalid input"+ return Nothing+ case result of+ Nothing -> evalLoop calc+ Just (display, calc') -> do putStrLn display+ evalLoop calc'
+ demo/calc/Makefile view
@@ -0,0 +1,11 @@++PROG = calc+SOURCES = Calc.hs CalcModel.hs++$(PROG) : $(SOURCES)+ $(HC) --make $< -o $@ $(HCFLAGS)++clean:+ rm -f $(SOURCES:.hs=.hi) $(SOURCES:.hs=.o) $(PROG)++HC=ghc
+ demo/calc/calc.glade view
@@ -0,0 +1,374 @@+<?xml version="1.0" standalone="no"?> <!--*- mode: xml -*-->+<!DOCTYPE glade-interface SYSTEM "http://glade.gnome.org/glade-2.0.dtd">++<glade-interface>++<widget class="GtkWindow" id="calcwindow">+ <property name="border_width">4</property>+ <property name="visible">True</property>+ <property name="title" translatable="yes">Calculator</property>+ <property name="type">GTK_WINDOW_TOPLEVEL</property>+ <property name="window_position">GTK_WIN_POS_CENTER</property>+ <property name="modal">False</property>+ <property name="resizable">True</property>+ <property name="destroy_with_parent">False</property>++ <child>+ <widget class="GtkVBox" id="vbox1">+ <property name="visible">True</property>+ <property name="homogeneous">False</property>+ <property name="spacing">4</property>++ <child>+ <widget class="GtkLabel" id="display">+ <property name="visible">True</property>+ <property name="label" translatable="yes"><big>0</big></property>+ <property name="use_underline">False</property>+ <property name="use_markup">True</property>+ <property name="justify">GTK_JUSTIFY_RIGHT</property>+ <property name="wrap">False</property>+ <property name="selectable">False</property>+ <property name="xalign">1</property>+ <property name="yalign">0.5</property>+ <property name="xpad">0</property>+ <property name="ypad">0</property>+ </widget>+ <packing>+ <property name="padding">0</property>+ <property name="expand">False</property>+ <property name="fill">False</property>+ </packing>+ </child>++ <child>+ <widget class="GtkTable" id="table1">+ <property name="visible">True</property>+ <property name="n_rows">5</property>+ <property name="n_columns">4</property>+ <property name="homogeneous">True</property>+ <property name="row_spacing">4</property>+ <property name="column_spacing">4</property>++ <child>+ <widget class="GtkButton" id="decimal">+ <property name="visible">True</property>+ <property name="can_focus">True</property>+ <property name="label" translatable="yes">.</property>+ <property name="use_underline">True</property>+ <property name="relief">GTK_RELIEF_NORMAL</property>+ <accelerator key="period" modifiers="0" signal="clicked"/>+ <accelerator key="KP_Decimal" modifiers="0" signal="clicked"/>+ </widget>+ <packing>+ <property name="left_attach">2</property>+ <property name="right_attach">3</property>+ <property name="top_attach">4</property>+ <property name="bottom_attach">5</property>+ </packing>+ </child>++ <child>+ <widget class="GtkButton" id="num-0">+ <property name="visible">True</property>+ <property name="can_focus">True</property>+ <property name="label" translatable="yes">0</property>+ <property name="use_underline">True</property>+ <property name="relief">GTK_RELIEF_NORMAL</property>+ <accelerator key="0" modifiers="0" signal="clicked"/>+ <accelerator key="KP_0" modifiers="0" signal="clicked"/>+ </widget>+ <packing>+ <property name="left_attach">0</property>+ <property name="right_attach">2</property>+ <property name="top_attach">4</property>+ <property name="bottom_attach">5</property>+ </packing>+ </child>++ <child>+ <widget class="GtkButton" id="num-1">+ <property name="visible">True</property>+ <property name="can_focus">True</property>+ <property name="label" translatable="yes">1</property>+ <property name="use_underline">True</property>+ <property name="relief">GTK_RELIEF_NORMAL</property>+ <accelerator key="1" modifiers="0" signal="clicked"/>+ <accelerator key="KP_1" modifiers="0" signal="clicked"/>+ </widget>+ <packing>+ <property name="left_attach">0</property>+ <property name="right_attach">1</property>+ <property name="top_attach">3</property>+ <property name="bottom_attach">4</property>+ </packing>+ </child>++ <child>+ <widget class="GtkButton" id="num-2">+ <property name="visible">True</property>+ <property name="can_focus">True</property>+ <property name="label" translatable="yes">2</property>+ <property name="use_underline">True</property>+ <property name="relief">GTK_RELIEF_NORMAL</property>+ <accelerator key="2" modifiers="0" signal="clicked"/>+ <accelerator key="KP_2" modifiers="0" signal="clicked"/>+ </widget>+ <packing>+ <property name="left_attach">1</property>+ <property name="right_attach">2</property>+ <property name="top_attach">3</property>+ <property name="bottom_attach">4</property>+ </packing>+ </child>++ <child>+ <widget class="GtkButton" id="num-4">+ <property name="visible">True</property>+ <property name="can_focus">True</property>+ <property name="label" translatable="yes">4</property>+ <property name="use_underline">True</property>+ <property name="relief">GTK_RELIEF_NORMAL</property>+ <accelerator key="4" modifiers="0" signal="clicked"/>+ <accelerator key="KP_4" modifiers="0" signal="clicked"/>+ </widget>+ <packing>+ <property name="left_attach">0</property>+ <property name="right_attach">1</property>+ <property name="top_attach">2</property>+ <property name="bottom_attach">3</property>+ </packing>+ </child>++ <child>+ <widget class="GtkButton" id="num-5">+ <property name="visible">True</property>+ <property name="can_focus">True</property>+ <property name="label" translatable="yes">5</property>+ <property name="use_underline">True</property>+ <property name="relief">GTK_RELIEF_NORMAL</property>+ <accelerator key="5" modifiers="0" signal="clicked"/>+ <accelerator key="KP_5" modifiers="0" signal="clicked"/>+ </widget>+ <packing>+ <property name="left_attach">1</property>+ <property name="right_attach">2</property>+ <property name="top_attach">2</property>+ <property name="bottom_attach">3</property>+ </packing>+ </child>++ <child>+ <widget class="GtkButton" id="num-7">+ <property name="visible">True</property>+ <property name="can_focus">True</property>+ <property name="label" translatable="yes">7</property>+ <property name="use_underline">True</property>+ <property name="relief">GTK_RELIEF_NORMAL</property>+ <accelerator key="7" modifiers="0" signal="clicked"/>+ <accelerator key="KP_7" modifiers="0" signal="clicked"/>+ </widget>+ <packing>+ <property name="left_attach">0</property>+ <property name="right_attach">1</property>+ <property name="top_attach">1</property>+ <property name="bottom_attach">2</property>+ </packing>+ </child>++ <child>+ <widget class="GtkButton" id="num-8">+ <property name="visible">True</property>+ <property name="can_focus">True</property>+ <property name="label" translatable="yes">8</property>+ <property name="use_underline">True</property>+ <property name="relief">GTK_RELIEF_NORMAL</property>+ <accelerator key="8" modifiers="0" signal="clicked"/>+ <accelerator key="KP_8" modifiers="0" signal="clicked"/>+ </widget>+ <packing>+ <property name="left_attach">1</property>+ <property name="right_attach">2</property>+ <property name="top_attach">1</property>+ <property name="bottom_attach">2</property>+ </packing>+ </child>++ <child>+ <widget class="GtkButton" id="num-3">+ <property name="visible">True</property>+ <property name="can_focus">True</property>+ <property name="label" translatable="yes">3</property>+ <property name="use_underline">True</property>+ <property name="relief">GTK_RELIEF_NORMAL</property>+ <accelerator key="3" modifiers="0" signal="clicked"/>+ <accelerator key="KP_3" modifiers="0" signal="clicked"/>+ </widget>+ <packing>+ <property name="left_attach">2</property>+ <property name="right_attach">3</property>+ <property name="top_attach">3</property>+ <property name="bottom_attach">4</property>+ </packing>+ </child>++ <child>+ <widget class="GtkButton" id="num-6">+ <property name="visible">True</property>+ <property name="can_focus">True</property>+ <property name="label" translatable="yes">6</property>+ <property name="use_underline">True</property>+ <property name="relief">GTK_RELIEF_NORMAL</property>+ <accelerator key="6" modifiers="0" signal="clicked"/>+ <accelerator key="KP_6" modifiers="0" signal="clicked"/>+ </widget>+ <packing>+ <property name="left_attach">2</property>+ <property name="right_attach">3</property>+ <property name="top_attach">2</property>+ <property name="bottom_attach">3</property>+ </packing>+ </child>++ <child>+ <widget class="GtkButton" id="num-9">+ <property name="visible">True</property>+ <property name="can_focus">True</property>+ <property name="label" translatable="yes">9</property>+ <property name="use_underline">True</property>+ <property name="relief">GTK_RELIEF_NORMAL</property>+ <accelerator key="9" modifiers="0" signal="clicked"/>+ <accelerator key="KP_9" modifiers="0" signal="clicked"/>+ </widget>+ <packing>+ <property name="left_attach">2</property>+ <property name="right_attach">3</property>+ <property name="top_attach">1</property>+ <property name="bottom_attach">2</property>+ </packing>+ </child>++ <child>+ <widget class="GtkButton" id="op-divide">+ <property name="visible">True</property>+ <property name="can_focus">True</property>+ <property name="label" translatable="yes">÷</property>+ <property name="use_underline">True</property>+ <property name="relief">GTK_RELIEF_NORMAL</property>+ <accelerator key="KP_Divide" modifiers="0" signal="clicked"/>+ <accelerator key="slash" modifiers="0" signal="clicked"/>+ </widget>+ <packing>+ <property name="left_attach">1</property>+ <property name="right_attach">2</property>+ <property name="top_attach">0</property>+ <property name="bottom_attach">1</property>+ </packing>+ </child>++ <child>+ <widget class="GtkButton" id="op-times">+ <property name="visible">True</property>+ <property name="can_focus">True</property>+ <property name="label" translatable="yes">×</property>+ <property name="use_underline">True</property>+ <property name="relief">GTK_RELIEF_NORMAL</property>+ <accelerator key="KP_Multiply" modifiers="0" signal="clicked"/>+ <accelerator key="asterisk" modifiers="0" signal="clicked"/>+ </widget>+ <packing>+ <property name="left_attach">2</property>+ <property name="right_attach">3</property>+ <property name="top_attach">0</property>+ <property name="bottom_attach">1</property>+ </packing>+ </child>++ <child>+ <widget class="GtkButton" id="op-minus">+ <property name="visible">True</property>+ <property name="can_focus">True</property>+ <property name="label" translatable="yes">-</property>+ <property name="use_underline">True</property>+ <property name="relief">GTK_RELIEF_NORMAL</property>+ <accelerator key="minus" modifiers="0" signal="clicked"/>+ <accelerator key="KP_Subtract" modifiers="0" signal="clicked"/>+ </widget>+ <packing>+ <property name="left_attach">3</property>+ <property name="right_attach">4</property>+ <property name="top_attach">0</property>+ <property name="bottom_attach">1</property>+ </packing>+ </child>++ <child>+ <widget class="GtkButton" id="op-plus">+ <property name="visible">True</property>+ <property name="can_focus">True</property>+ <property name="label" translatable="yes">+</property>+ <property name="use_underline">True</property>+ <property name="relief">GTK_RELIEF_NORMAL</property>+ <accelerator key="plus" modifiers="0" signal="clicked"/>+ <accelerator key="KP_Add" modifiers="0" signal="clicked"/>+ </widget>+ <packing>+ <property name="left_attach">3</property>+ <property name="right_attach">4</property>+ <property name="top_attach">1</property>+ <property name="bottom_attach">3</property>+ </packing>+ </child>++ <child>+ <widget class="GtkButton" id="equals">+ <property name="visible">True</property>+ <property name="can_focus">True</property>+ <property name="label" translatable="yes">=</property>+ <property name="use_underline">True</property>+ <property name="relief">GTK_RELIEF_NORMAL</property>+ <accelerator key="equal" modifiers="0" signal="clicked"/>+ <accelerator key="Return" modifiers="0" signal="clicked"/>+ <accelerator key="KP_Equal" modifiers="0" signal="clicked"/>+ <accelerator key="KP_Enter" modifiers="0" signal="clicked"/>+ </widget>+ <packing>+ <property name="left_attach">3</property>+ <property name="right_attach">4</property>+ <property name="top_attach">3</property>+ <property name="bottom_attach">5</property>+ </packing>+ </child>++ <child>+ <widget class="GtkButton" id="clear">+ <property name="width_request">45</property>+ <property name="height_request">40</property>+ <property name="visible">True</property>+ <property name="can_focus">True</property>+ <property name="label" translatable="yes">AC</property>+ <property name="use_underline">True</property>+ <property name="relief">GTK_RELIEF_NORMAL</property>+ <accelerator key="Delete" modifiers="0" signal="clicked"/>+ <accelerator key="BackSpace" modifiers="0" signal="clicked"/>+ </widget>+ <packing>+ <property name="left_attach">0</property>+ <property name="right_attach">1</property>+ <property name="top_attach">0</property>+ <property name="bottom_attach">1</property>+ <property name="x_options">fill</property>+ <property name="y_options"></property>+ </packing>+ </child>+ </widget>+ <packing>+ <property name="padding">0</property>+ <property name="expand">True</property>+ <property name="fill">True</property>+ </packing>+ </child>+ </widget>+ </child>+</widget>++</glade-interface>
+ demo/glade/GladeTest.hs view
@@ -0,0 +1,26 @@+module Main where++import Graphics.UI.Gtk+import Graphics.UI.Gtk.Glade++main = do+ initGUI+ + -- load up the glade file+ dialogXmlM <- xmlNew "simple.glade"+ let dialogXml = case dialogXmlM of+ (Just dialogXml) -> dialogXml+ Nothing -> error "can't find the glade file \"simple.glade\" \+ \in the current directory"+ + -- get a handle on a couple widgets from the glade file+ window <- xmlGetWidget dialogXml castToWindow "window1"+ button <- xmlGetWidget dialogXml castToButton "button1"+ + -- do something with the widgets, just to prove it works+ button `onClicked` putStrLn "button pressed!"+ window `onDestroy` mainQuit+ + -- show everything+ widgetShowAll window+ mainGUI
+ demo/glade/Makefile view
@@ -0,0 +1,11 @@++PROG = gladetest+SOURCES = GladeTest.hs++$(PROG) : $(SOURCES)+ $(HC) --make $< -o $@ $(HCFLAGS)++clean:+ rm -f $(SOURCES:.hs=.hi) $(SOURCES:.hs=.o) $(PROG)++HC=ghc
+ demo/glade/simple.glade view
@@ -0,0 +1,115 @@+<?xml version="1.0" standalone="no"?> <!--*- mode: xml -*-->+<!DOCTYPE glade-interface SYSTEM "http://glade.gnome.org/glade-2.0.dtd">++<glade-interface>++<widget class="GtkWindow" id="window1">+ <property name="visible">True</property>+ <property name="title" translatable="yes">window1</property>+ <property name="type">GTK_WINDOW_TOPLEVEL</property>+ <property name="window_position">GTK_WIN_POS_NONE</property>+ <property name="modal">False</property>+ <property name="resizable">True</property>+ <property name="destroy_with_parent">False</property>++ <child>+ <widget class="GtkVBox" id="vbox1">+ <property name="border_width">6</property>+ <property name="visible">True</property>+ <property name="homogeneous">False</property>+ <property name="spacing">0</property>++ <child>+ <widget class="GtkLabel" id="label1">+ <property name="visible">True</property>+ <property name="label" translatable="yes">A simple dialog created in Glade</property>+ <property name="use_underline">False</property>+ <property name="use_markup">False</property>+ <property name="justify">GTK_JUSTIFY_LEFT</property>+ <property name="wrap">False</property>+ <property name="selectable">False</property>+ <property name="xalign">0.5</property>+ <property name="yalign">0.5</property>+ <property name="xpad">0</property>+ <property name="ypad">0</property>+ </widget>+ <packing>+ <property name="padding">0</property>+ <property name="expand">True</property>+ <property name="fill">True</property>+ </packing>+ </child>++ <child>+ <widget class="GtkButton" id="button1">+ <property name="visible">True</property>+ <property name="can_focus">True</property>+ <property name="relief">GTK_RELIEF_NORMAL</property>++ <child>+ <widget class="GtkAlignment" id="alignment1">+ <property name="visible">True</property>+ <property name="xalign">0.5</property>+ <property name="yalign">0.5</property>+ <property name="xscale">0</property>+ <property name="yscale">0</property>++ <child>+ <widget class="GtkHBox" id="hbox1">+ <property name="visible">True</property>+ <property name="homogeneous">False</property>+ <property name="spacing">2</property>++ <child>+ <widget class="GtkImage" id="image1">+ <property name="visible">True</property>+ <property name="stock">gtk-apply</property>+ <property name="icon_size">4</property>+ <property name="xalign">0.5</property>+ <property name="yalign">0.5</property>+ <property name="xpad">0</property>+ <property name="ypad">0</property>+ </widget>+ <packing>+ <property name="padding">0</property>+ <property name="expand">False</property>+ <property name="fill">False</property>+ </packing>+ </child>++ <child>+ <widget class="GtkLabel" id="label2">+ <property name="visible">True</property>+ <property name="label" translatable="yes">Press me!</property>+ <property name="use_underline">True</property>+ <property name="use_markup">False</property>+ <property name="justify">GTK_JUSTIFY_LEFT</property>+ <property name="wrap">False</property>+ <property name="selectable">False</property>+ <property name="xalign">0.5</property>+ <property name="yalign">0.5</property>+ <property name="xpad">0</property>+ <property name="ypad">0</property>+ </widget>+ <packing>+ <property name="padding">0</property>+ <property name="expand">False</property>+ <property name="fill">False</property>+ </packing>+ </child>+ </widget>+ </child>+ </widget>+ </child>+ </widget>+ <packing>+ <property name="padding">0</property>+ <property name="expand">True</property>+ <property name="fill">True</property>+ </packing>+ </child>+ </widget>+ </child>+</widget>++</glade-interface>
+ demo/noughty/Cross.png view
binary file changed (absent → 8439 bytes)
+ demo/noughty/License view
@@ -0,0 +1,29 @@+Copyright (c) 2006, Wouter Swierstra+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are+met:++* Redistributions of source code must retain the above copyright+notice, this list of conditions and the following disclaimer.++* Redistributions in binary form must reproduce the above copyright+notice, this list of conditions and the following disclaimer in the+documentation and/or other materials provided with the distribution.++* Neither the name of the University of Nottingham nor the names of+its contributors may be used to endorse or promote products derived+from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ demo/noughty/Makefile view
@@ -0,0 +1,18 @@++PROGS = noughty noughty-glade+SOURCES = Noughty.hs NoughtyGlade.hs++all : $(PROGS)++noughty : Noughty.hs+ $(HC_RULE)++noughty-glade : NoughtyGlade.hs+ $(HC_RULE)++HC_RULE = $(HC) --make $< -o $@ $(HCFLAGS)++clean:+ rm -f $(SOURCES:.hs=.hi) $(SOURCES:.hs=.o) $(PROGS)++HC=ghc
+ demo/noughty/Nought.png view
binary file changed (absent → 8311 bytes)
+ demo/noughty/Noughty.hs view
@@ -0,0 +1,196 @@+-- Copyright (c) 2006, Wouter Swierstra+-- All rights reserved.+-- This code is released under the BSD license+-- included in this distribution++-- Imports++import IO+import Maybe+import List+import Graphics.UI.Gtk hiding (Cross)+import Data.IORef+import Control.Monad++-- Players, boards and some useful pure functions++data Player = Nought | Blank | Cross deriving (Ord, Eq, Show)++next :: Player -> Player+next Nought = Cross+next Blank = Blank+next Cross = Nought++type Board = [[Player]]++size :: Int+size = 3++empty :: Board+empty = replicate size (replicate size Blank)++move :: Int -> Player -> Board -> Maybe Board+move n p b = case y of+ Blank -> Just (chop size (xs ++ (p : ys)))+ _ -> Nothing+ where+ (xs,y:ys) = splitAt n (concat b)++chop :: Int -> [a] -> [[a]]+chop n [] = []+chop n xs = take n xs : chop n (drop n xs)++diag :: [[a]] -> [a]+diag xss = [xss !! n !! n | n <- [0 .. length xss - 1]]++full :: Board -> Bool+full b = all (all (/= Blank)) b++wins :: Player -> Board -> Bool+wins p b = any (all (== p)) b+ || any (all (== p)) (transpose b)+ || all (== p) (diag b)+ || all (== p) (diag (reverse b))++won :: Board -> Bool+won b = wins Nought b || wins Cross b++-- The state and GUI++data State = State {+ board :: Board,+ turn :: Player+}++data GUI = GUI {+ disableBoard :: IO (),+ resetBoard :: IO (),+ setSquare :: Int -> Player -> IO (),+ setStatus :: String -> IO ()+}++-- reset the game+reset gui (State board turn) = do+ setStatus gui "Player Cross: make your move."+ resetBoard gui+ return (State empty Cross)++-- when a square is clicked on, try to make a move.+-- if the square is already occupied, nothing happens+-- otherwise, update the board, let the next player make his move,+-- and check whether someone has won or the board is full.+occupy gui square st@(State board player) = do+ case move square player board of+ Nothing -> return st+ Just newBoard -> do+ setSquare gui square player+ handleMove gui newBoard player+ return (State newBoard (next player))++-- check whether a board is won or full+handleMove gui board player+ | wins player board = do+ setStatus gui ("Player " ++ show player ++ " wins!")+ disableBoard gui+ | full board = do+ setStatus gui "It's a draw."+ disableBoard gui+ | otherwise = do+ setStatus gui ("Player " ++ show (next player) ++ ": make your move")++main = do+ initGUI+ window <- windowNew+ window `onDestroy` mainQuit+ set window [ windowTitle := "Noughty"+ , windowResizable := False ]+ label <- labelNew (Just "Player Cross: make your move.")+ vboxOuter <- vBoxNew False 0+ vboxInner <- vBoxNew False 5++-- Add an initial board to the inner vBox and make the menu bar+ (squares, images) <- addFieldsTo vboxInner+ (mb,newGame,quit) <- makeMenuBar++ -- Construct the GUI actions that abstracts from the actual widgets+ gui <- guiActions squares images label++ -- Initialize the state+ state <- newIORef State { board = empty, turn = Cross }+ let modifyState f = readIORef state >>= f >>= writeIORef state++ -- Add action handlers+ onActivateLeaf quit mainQuit+ onActivateLeaf newGame $ modifyState $ reset gui+ zipWithM_ (\square i ->+ onPressed square $ modifyState $ occupy gui i)+ squares [0..8]++ -- Assemble the bits+ set vboxOuter [ containerChild := mb+ , containerChild := vboxInner ]+ set vboxInner [ containerChild := label+ , containerBorderWidth := 10 ]+ set window [ containerChild := vboxOuter ]++ widgetShowAll window+ mainGUI++guiActions buttons images label = do+ noughtPic <- pixbufNewFromFile "Nought.png"+ crossPic <- pixbufNewFromFile "Cross.png"+ return GUI {+ disableBoard = mapM_ (flip widgetSetSensitivity False) buttons,+ resetBoard = do+ mapM_ (\i -> imageClear i >> widgetQueueDraw i) images+ mapM_ (flip widgetSetSensitivity True) buttons,+ setSquare = \ i player ->+ case player of+ Cross -> set (images !! i) [ imagePixbuf := crossPic ]+ Nought-> set (images !! i) [ imagePixbuf := noughtPic ],+ setStatus = labelSetText label}++makeMenuBar = do+ mb <- menuBarNew+ fileMenu <- menuNew+ newGame <- menuItemNewWithMnemonic "_New Game"+ quit <- menuItemNewWithMnemonic "_Quit"+ file <- menuItemNewWithMnemonic "_Game"+ menuShellAppend fileMenu newGame+ menuShellAppend fileMenu quit+ menuItemSetSubmenu file fileMenu+ containerAdd mb file+ return (mb,newGame,quit)++addFieldsTo container = do+ table <- tableNew 5 5 False+ buttons@[b0,b1,b2,b3,b4,b5,b6,b7,b8] <- replicateM 9 squareNew+ images <- replicateM 9 imageNew+ zipWithM_ containerAdd buttons images+ tableAttachDefaults table b0 0 1 0 1+ tableAttachDefaults table b1 2 3 0 1+ tableAttachDefaults table b2 4 5 0 1+ tableAttachDefaults table b3 0 1 2 3+ tableAttachDefaults table b4 2 3 2 3+ tableAttachDefaults table b5 4 5 2 3+ tableAttachDefaults table b6 0 1 4 5+ tableAttachDefaults table b7 2 3 4 5+ tableAttachDefaults table b8 4 5 4 5+ vline1 <- vSeparatorNew+ vline2 <- vSeparatorNew+ hline1 <- hSeparatorNew+ hline2 <- hSeparatorNew+ tableAttachDefaults table vline1 1 2 0 5+ tableAttachDefaults table vline2 3 4 0 5+ tableAttachDefaults table hline1 0 5 1 2+ tableAttachDefaults table hline2 0 5 3 4+ tableSetRowSpacings table 0+ tableSetColSpacings table 0+ containerAdd container table+ return (buttons, images)++squareNew = do+ square <- buttonNew+ widgetSetSizeRequest square 100 100+ set square [ widgetCanFocus := False, buttonRelief := ReliefNone]+ return square
+ demo/noughty/NoughtyGlade.hs view
@@ -0,0 +1,160 @@+-- Copyright (c) 2006, Wouter Swierstra+-- All rights reserved.+-- This code is released under the BSD license+-- included in this distribution++-- Imports++import IO+import Maybe+import List+import Graphics.UI.Gtk hiding (Cross)+import Graphics.UI.Gtk.Glade+import Data.IORef+import Control.Monad++-- Players, boards and some useful pure functions++data Player = Nought | Blank | Cross deriving (Ord, Eq, Show)++next :: Player -> Player+next Nought = Cross+next Blank = Blank+next Cross = Nought++type Board = [[Player]]++size :: Int+size = 3++empty :: Board+empty = replicate size (replicate size Blank)++move :: Int -> Player -> Board -> Maybe Board+move n p b = case y of+ Blank -> Just (chop size (xs ++ (p : ys)))+ _ -> Nothing+ where+ (xs,y:ys) = splitAt n (concat b)++chop :: Int -> [a] -> [[a]]+chop n [] = []+chop n xs = take n xs : chop n (drop n xs)++diag :: [[a]] -> [a]+diag xss = [xss !! n !! n | n <- [0 .. length xss - 1]]++full :: Board -> Bool+full b = all (all (/= Blank)) b++wins :: Player -> Board -> Bool+wins p b = any (all (== p)) b+ || any (all (== p)) (transpose b)+ || all (== p) (diag b)+ || all (== p) (diag (reverse b))++won :: Board -> Bool+won b = wins Nought b || wins Cross b++-- The state and GUI++data State = State {+ board :: Board,+ turn :: Player+}++data GUI = GUI {+ disableBoard :: IO (),+ resetBoard :: IO (),+ setSquare :: Int -> Player -> IO (),+ setStatus :: String -> IO ()+}++-- reset the game+reset gui (State board turn) = do+ setStatus gui "Player Cross: make your move."+ resetBoard gui+ return (State empty Cross)++-- when a square is clicked on, try to make a move.+-- if the square is already occupied, nothing happens+-- otherwise, update the board, let the next player make his move,+-- and check whether someone has won or the board is full.+occupy gui square st@(State board player) = do+ case move square player board of+ Nothing -> return st+ Just newBoard -> do+ setSquare gui square player+ handleMove gui newBoard player+ return (State newBoard (next player))++-- check whether a board is won or full+handleMove gui board player+ | wins player board = do+ setStatus gui ("Player " ++ show player ++ " wins!")+ disableBoard gui+ | full board = do+ setStatus gui "It's a draw."+ disableBoard gui+ | otherwise = do+ setStatus gui ("Player " ++ show (next player) ++ ": make your move")++main = do+ initGUI++ -- Extract widgets from the glade xml file+ Just xml <- xmlNew "noughty.glade"++ window <- xmlGetWidget xml castToWindow "window"+ window `onDestroy` mainQuit++ newGame <- xmlGetWidget xml castToMenuItem "newGame"+ quit <- xmlGetWidget xml castToMenuItem "quit"++ squares <- flip mapM [1..9] $ \n -> do+ square <- xmlGetWidget xml castToButton ("button" ++ show n)+ -- we set this in the glde file but it doesn't seem to work there.+ set square [ widgetCanFocus := False ]+ return square++ images <- flip mapM [1..9] $ \n -> do+ xmlGetWidget xml castToImage ("image" ++ show n)++ statusbar <- xmlGetWidget xml castToStatusbar "statusbar"+ ctx <- statusbarGetContextId statusbar "state"+ statusbarPush statusbar ctx "Player Cross: make your move."++ -- Construct the GUI actions that abstracts from the actual widgets+ gui <- guiActions squares images statusbar ctx++ -- Initialize the state+ state <- newIORef State { board = empty, turn = Cross }+ let modifyState f = readIORef state >>= f >>= writeIORef state++ -- Add action handlers+ onActivateLeaf quit mainQuit+ onActivateLeaf newGame $ modifyState $ reset gui+ zipWithM_ (\square i ->+ onPressed square $ modifyState $ occupy gui i)+ squares [0..8]++ widgetShowAll window+ mainGUI++guiActions buttons images statusbar ctx = do+ noughtPic <- pixbufNewFromFile "Nought.png"+ crossPic <- pixbufNewFromFile "Cross.png"+ return GUI {+ disableBoard = mapM_ (flip widgetSetSensitivity False) buttons,+ resetBoard = do+ mapM_ (\i -> imageClear i >> widgetQueueDraw i) images+ mapM_ (flip widgetSetSensitivity True) buttons,+ setSquare = \ i player ->+ case player of+ Cross -> set (images !! i) [ imagePixbuf := crossPic ]+ Nought-> set (images !! i) [ imagePixbuf := noughtPic ],+ setStatus = \msg -> do+ statusbarPop statusbar ctx+ statusbarPush statusbar ctx msg+ return ()+ }
+ demo/noughty/noughty.glade view
@@ -0,0 +1,398 @@+<?xml version="1.0" standalone="no"?> <!--*- mode: xml -*-->+<!DOCTYPE glade-interface SYSTEM "http://glade.gnome.org/glade-2.0.dtd">++<glade-interface>++<widget class="GtkWindow" id="window">+ <property name="title" translatable="yes">Noughty</property>+ <property name="type">GTK_WINDOW_TOPLEVEL</property>+ <property name="window_position">GTK_WIN_POS_NONE</property>+ <property name="modal">False</property>+ <property name="resizable">False</property>+ <property name="destroy_with_parent">False</property>+ <property name="decorated">True</property>+ <property name="skip_taskbar_hint">False</property>+ <property name="skip_pager_hint">False</property>+ <property name="type_hint">GDK_WINDOW_TYPE_HINT_NORMAL</property>+ <property name="gravity">GDK_GRAVITY_NORTH_WEST</property>+ <property name="focus_on_map">True</property>+ <property name="urgency_hint">False</property>++ <child>+ <widget class="GtkVBox" id="vbox1">+ <property name="visible">True</property>+ <property name="homogeneous">False</property>+ <property name="spacing">0</property>++ <child>+ <widget class="GtkMenuBar" id="menubar1">+ <property name="visible">True</property>+ <property name="pack_direction">GTK_PACK_DIRECTION_LTR</property>+ <property name="child_pack_direction">GTK_PACK_DIRECTION_LTR</property>++ <child>+ <widget class="GtkMenuItem" id="menuitem1">+ <property name="visible">True</property>+ <property name="label" translatable="yes">_Game</property>+ <property name="use_underline">True</property>++ <child>+ <widget class="GtkMenu" id="menuitem1_menu">++ <child>+ <widget class="GtkMenuItem" id="newGame">+ <property name="visible">True</property>+ <property name="label" translatable="yes">_New Game</property>+ <property name="use_underline">True</property>+ <accelerator key="n" modifiers="GDK_CONTROL_MASK" signal="activate"/>+ </widget>+ </child>++ <child>+ <widget class="GtkSeparatorMenuItem" id="separatormenuitem1">+ <property name="visible">True</property>+ </widget>+ </child>++ <child>+ <widget class="GtkMenuItem" id="quit">+ <property name="visible">True</property>+ <property name="label" translatable="yes">_Quit</property>+ <property name="use_underline">True</property>+ </widget>+ </child>+ </widget>+ </child>+ </widget>+ </child>+ </widget>+ <packing>+ <property name="padding">0</property>+ <property name="expand">False</property>+ <property name="fill">False</property>+ </packing>+ </child>++ <child>+ <widget class="GtkTable" id="table1">+ <property name="border_width">10</property>+ <property name="visible">True</property>+ <property name="n_rows">5</property>+ <property name="n_columns">5</property>+ <property name="homogeneous">False</property>+ <property name="row_spacing">0</property>+ <property name="column_spacing">0</property>++ <child>+ <widget class="GtkHSeparator" id="hseparator1">+ <property name="visible">True</property>+ </widget>+ <packing>+ <property name="left_attach">0</property>+ <property name="right_attach">5</property>+ <property name="top_attach">1</property>+ <property name="bottom_attach">2</property>+ <property name="x_options">fill</property>+ <property name="y_options">fill</property>+ </packing>+ </child>++ <child>+ <widget class="GtkVSeparator" id="vseparator1">+ <property name="visible">True</property>+ </widget>+ <packing>+ <property name="left_attach">1</property>+ <property name="right_attach">2</property>+ <property name="top_attach">0</property>+ <property name="bottom_attach">5</property>+ <property name="x_options">fill</property>+ <property name="y_options">fill</property>+ </packing>+ </child>++ <child>+ <widget class="GtkVSeparator" id="vseparator2">+ <property name="visible">True</property>+ </widget>+ <packing>+ <property name="left_attach">3</property>+ <property name="right_attach">4</property>+ <property name="top_attach">0</property>+ <property name="bottom_attach">5</property>+ <property name="x_options">fill</property>+ <property name="y_options">fill</property>+ </packing>+ </child>++ <child>+ <widget class="GtkButton" id="button1">+ <property name="width_request">100</property>+ <property name="height_request">100</property>+ <property name="visible">True</property>+ <property name="relief">GTK_RELIEF_NONE</property>+ <property name="focus_on_click">False</property>++ <child>+ <widget class="GtkImage" id="image1">+ <property name="visible">True</property>+ <property name="xalign">0.5</property>+ <property name="yalign">0.5</property>+ <property name="xpad">0</property>+ <property name="ypad">0</property>+ </widget>+ </child>+ </widget>+ <packing>+ <property name="left_attach">0</property>+ <property name="right_attach">1</property>+ <property name="top_attach">0</property>+ <property name="bottom_attach">1</property>+ </packing>+ </child>++ <child>+ <widget class="GtkButton" id="button2">+ <property name="width_request">100</property>+ <property name="height_request">100</property>+ <property name="visible">True</property>+ <property name="relief">GTK_RELIEF_NONE</property>+ <property name="focus_on_click">False</property>++ <child>+ <widget class="GtkImage" id="image2">+ <property name="visible">True</property>+ <property name="xalign">0.5</property>+ <property name="yalign">0.5</property>+ <property name="xpad">0</property>+ <property name="ypad">0</property>+ </widget>+ </child>+ </widget>+ <packing>+ <property name="left_attach">2</property>+ <property name="right_attach">3</property>+ <property name="top_attach">0</property>+ <property name="bottom_attach">1</property>+ </packing>+ </child>++ <child>+ <widget class="GtkButton" id="button3">+ <property name="width_request">100</property>+ <property name="height_request">100</property>+ <property name="visible">True</property>+ <property name="relief">GTK_RELIEF_NONE</property>+ <property name="focus_on_click">False</property>++ <child>+ <widget class="GtkImage" id="image3">+ <property name="visible">True</property>+ <property name="xalign">0.5</property>+ <property name="yalign">0.5</property>+ <property name="xpad">0</property>+ <property name="ypad">0</property>+ </widget>+ </child>+ </widget>+ <packing>+ <property name="left_attach">4</property>+ <property name="right_attach">5</property>+ <property name="top_attach">0</property>+ <property name="bottom_attach">1</property>+ </packing>+ </child>++ <child>+ <widget class="GtkButton" id="button4">+ <property name="width_request">100</property>+ <property name="height_request">100</property>+ <property name="visible">True</property>+ <property name="relief">GTK_RELIEF_NONE</property>+ <property name="focus_on_click">False</property>++ <child>+ <widget class="GtkImage" id="image4">+ <property name="visible">True</property>+ <property name="xalign">0.5</property>+ <property name="yalign">0.5</property>+ <property name="xpad">0</property>+ <property name="ypad">0</property>+ </widget>+ </child>+ </widget>+ <packing>+ <property name="left_attach">0</property>+ <property name="right_attach">1</property>+ <property name="top_attach">2</property>+ <property name="bottom_attach">3</property>+ </packing>+ </child>++ <child>+ <widget class="GtkButton" id="button5">+ <property name="width_request">100</property>+ <property name="height_request">100</property>+ <property name="visible">True</property>+ <property name="relief">GTK_RELIEF_NONE</property>+ <property name="focus_on_click">False</property>++ <child>+ <widget class="GtkImage" id="image5">+ <property name="visible">True</property>+ <property name="xalign">0.5</property>+ <property name="yalign">0.5</property>+ <property name="xpad">0</property>+ <property name="ypad">0</property>+ </widget>+ </child>+ </widget>+ <packing>+ <property name="left_attach">2</property>+ <property name="right_attach">3</property>+ <property name="top_attach">2</property>+ <property name="bottom_attach">3</property>+ </packing>+ </child>++ <child>+ <widget class="GtkButton" id="button6">+ <property name="width_request">100</property>+ <property name="height_request">100</property>+ <property name="visible">True</property>+ <property name="relief">GTK_RELIEF_NONE</property>+ <property name="focus_on_click">False</property>++ <child>+ <widget class="GtkImage" id="image6">+ <property name="visible">True</property>+ <property name="xalign">0.5</property>+ <property name="yalign">0.5</property>+ <property name="xpad">0</property>+ <property name="ypad">0</property>+ </widget>+ </child>+ </widget>+ <packing>+ <property name="left_attach">4</property>+ <property name="right_attach">5</property>+ <property name="top_attach">2</property>+ <property name="bottom_attach">3</property>+ </packing>+ </child>++ <child>+ <widget class="GtkButton" id="button7">+ <property name="width_request">100</property>+ <property name="height_request">100</property>+ <property name="visible">True</property>+ <property name="relief">GTK_RELIEF_NONE</property>+ <property name="focus_on_click">False</property>++ <child>+ <widget class="GtkImage" id="image7">+ <property name="visible">True</property>+ <property name="xalign">0.5</property>+ <property name="yalign">0.5</property>+ <property name="xpad">0</property>+ <property name="ypad">0</property>+ </widget>+ </child>+ </widget>+ <packing>+ <property name="left_attach">0</property>+ <property name="right_attach">1</property>+ <property name="top_attach">4</property>+ <property name="bottom_attach">5</property>+ </packing>+ </child>++ <child>+ <widget class="GtkButton" id="button8">+ <property name="width_request">100</property>+ <property name="height_request">100</property>+ <property name="visible">True</property>+ <property name="relief">GTK_RELIEF_NONE</property>+ <property name="focus_on_click">False</property>++ <child>+ <widget class="GtkImage" id="image8">+ <property name="visible">True</property>+ <property name="xalign">0.5</property>+ <property name="yalign">0.5</property>+ <property name="xpad">0</property>+ <property name="ypad">0</property>+ </widget>+ </child>+ </widget>+ <packing>+ <property name="left_attach">2</property>+ <property name="right_attach">3</property>+ <property name="top_attach">4</property>+ <property name="bottom_attach">5</property>+ </packing>+ </child>++ <child>+ <widget class="GtkButton" id="button9">+ <property name="width_request">100</property>+ <property name="height_request">100</property>+ <property name="visible">True</property>+ <property name="relief">GTK_RELIEF_NONE</property>+ <property name="focus_on_click">False</property>++ <child>+ <widget class="GtkImage" id="image9">+ <property name="visible">True</property>+ <property name="xalign">0.5</property>+ <property name="yalign">0.5</property>+ <property name="xpad">0</property>+ <property name="ypad">0</property>+ </widget>+ </child>+ </widget>+ <packing>+ <property name="left_attach">4</property>+ <property name="right_attach">5</property>+ <property name="top_attach">4</property>+ <property name="bottom_attach">5</property>+ </packing>+ </child>++ <child>+ <widget class="GtkHSeparator" id="hseparator2">+ <property name="visible">True</property>+ </widget>+ <packing>+ <property name="left_attach">0</property>+ <property name="right_attach">5</property>+ <property name="top_attach">3</property>+ <property name="bottom_attach">4</property>+ <property name="x_options">fill</property>+ <property name="y_options">fill</property>+ </packing>+ </child>+ </widget>+ <packing>+ <property name="padding">0</property>+ <property name="expand">True</property>+ <property name="fill">True</property>+ </packing>+ </child>++ <child>+ <widget class="GtkStatusbar" id="statusbar">+ <property name="visible">True</property>+ <property name="has_resize_grip">False</property>+ </widget>+ <packing>+ <property name="padding">0</property>+ <property name="expand">False</property>+ <property name="fill">False</property>+ </packing>+ </child>+ </widget>+ </child>+</widget>++</glade-interface>
+ demo/profileviewer/Makefile view
@@ -0,0 +1,11 @@++PROG = profileviewer+SOURCES = ProfileViewer.hs ParseProfile.hs++$(PROG) : $(SOURCES)+ $(HC) --make $< -o $@ $(HCFLAGS)++clean:+ rm -f $(SOURCES:.hs=.hi) $(SOURCES:.hs=.o) $(PROG)++HC=ghc
+ demo/profileviewer/ParseProfile.hs view
@@ -0,0 +1,113 @@+-- Copyright (c) 2004 Duncan Coutts+-- This library is liscenced under the GNU General Public License version 2+-- or (at your option) any later version.++-- This is a not-terribly-clever parser for ghc's time profile log files.++module ParseProfile (+ Profile(..),+ ProfileNode(..),+ parseProfileFile,+ pruneOnThreshold+) where++import Char+import Maybe (catMaybes)++data Profile = Profile {+ title :: String,+ command :: String,+ totalTime :: Float,+ totalAlloc :: Integer, --can be several GB+ breakdown :: ProfileNode+ }++data ProfileNode = ProfileNode {+ costCentre :: String,+ moduleName :: String,+ entries :: !Int,+ individualTime :: !Int, --scaled by 10+ individualAlloc :: !Int, --scaled by 10+ inheritedTime :: !Int, --scaled by 10+ inheritedAlloc :: !Int, --scaled by 10+ children :: [ProfileNode]+ }++pruneOnThreshold :: Int -> ProfileNode -> Maybe ProfileNode+pruneOnThreshold threshold node+ | inheritedTime node >= threshold+ || inheritedAlloc node >= threshold =+ let children' = catMaybes $ map (pruneOnThreshold threshold) (children node)+ in Just $ node { children = children' }+ | otherwise = Nothing+++parseProfileFile :: String -> IO Profile+parseProfileFile filename = do+ content <- readFile filename+ let (titleLine:_:commandLine:_:timeLine:allocLine:theRest) = lines content+ profileDetail = dropWhile (\line -> take 4 line /= "MAIN") theRest+ return $ Profile {+ title = dropWhile isSpace titleLine,+ command = dropWhile isSpace commandLine,+ totalTime = read $ words timeLine !! 3,+ totalAlloc = read $ filter (/=',') $ words allocLine !! 3,+ breakdown = parseProfile profileDetail+ }++-- intermediate form+data ProfileEntry = ProfileEntry {+ depth :: !Int,+ ecostCentre :: String,+ emoduleName :: String,+ eentries :: !Int,+ eindividualTime :: !Int, --scaled by 10+ eindividualAlloc :: !Int, --scaled by 10+ einheritedTime :: !Int, --scaled by 10+ einheritedAlloc :: !Int --scaled by 10+ }++parseProfile :: [String] -> ProfileNode+parseProfile file =+ case (profileEntriesToProfile [] 0 . map parseProfileEntry) file of+ ([profile],[]) -> profile+ _ -> error "multiple top level entries"++parseProfileEntry :: String -> ProfileEntry+parseProfileEntry line =+ let depth = length (takeWhile (==' ') line)+ in case words line of+ [costCentre, moduleName, _, entries,+ individualTime, individualAlloc,+ inheritedTime, inheritedAlloc] ->+ ProfileEntry {+ depth = depth,+ ecostCentre = costCentre,+ emoduleName = moduleName,+ eentries = read entries,+ eindividualTime = floor $ (read individualTime) * 10,+ eindividualAlloc = floor $ (read individualAlloc) * 10,+ einheritedTime = floor $ (read inheritedTime) * 10,+ einheritedAlloc = floor $ (read inheritedAlloc) * 10 + }+ _ -> error $ "bad profile line:\n\t" ++ line++profileEntriesToProfile :: [ProfileNode] -> Int -> [ProfileEntry] -> ([ProfileNode], [ProfileEntry])+profileEntriesToProfile acum curDepth [] = (acum, [])+profileEntriesToProfile acum curDepth (entry:entries)+ | depth entry == curDepth =+ let (children, remaining) = profileEntriesToProfile+ [] (depth entry + 1) entries+ curNode = ProfileNode {+ costCentre = ecostCentre entry,+ moduleName = emoduleName entry,+ entries = eentries entry,+ individualTime = eindividualTime entry,+ individualAlloc = eindividualAlloc entry,+ inheritedTime = einheritedTime entry,+ inheritedAlloc = einheritedAlloc entry,+ children = children+ }+ in profileEntriesToProfile (curNode:acum) (depth entry) remaining+ | depth entry < curDepth = (acum, entry:entries) --we're done for this level+ | otherwise = error "bad indentation in file"
+ demo/profileviewer/ProfileViewer.glade view
@@ -0,0 +1,426 @@+<?xml version="1.0" standalone="no"?> <!--*- mode: xml -*-->+<!DOCTYPE glade-interface SYSTEM "http://glade.gnome.org/glade-2.0.dtd">++<glade-interface>++<widget class="GtkWindow" id="mainWindow">+ <property name="visible">True</property>+ <property name="title" translatable="yes">GHC timing profile viewer</property>+ <property name="type">GTK_WINDOW_TOPLEVEL</property>+ <property name="window_position">GTK_WIN_POS_NONE</property>+ <property name="modal">False</property>+ <property name="default_width">650</property>+ <property name="default_height">400</property>+ <property name="resizable">True</property>+ <property name="destroy_with_parent">False</property>++ <child>+ <widget class="GtkVBox" id="vbox1">+ <property name="visible">True</property>+ <property name="homogeneous">False</property>+ <property name="spacing">0</property>++ <child>+ <widget class="GtkMenuBar" id="menubar1">+ <property name="visible">True</property>++ <child>+ <widget class="GtkMenuItem" id="menuitem1">+ <property name="visible">True</property>+ <property name="label" translatable="yes">_File</property>+ <property name="use_underline">True</property>++ <child>+ <widget class="GtkMenu" id="menuitem1_menu">++ <child>+ <widget class="GtkImageMenuItem" id="openMenuItem">+ <property name="visible">True</property>+ <property name="label">gtk-open</property>+ <property name="use_stock">True</property>+ </widget>+ </child>++ <child>+ <widget class="GtkMenuItem" id="separatormenuitem1">+ <property name="visible">True</property>+ </widget>+ </child>++ <child>+ <widget class="GtkImageMenuItem" id="quitMenuItem">+ <property name="visible">True</property>+ <property name="label">gtk-quit</property>+ <property name="use_stock">True</property>+ </widget>+ </child>+ </widget>+ </child>+ </widget>+ </child>++ <child>+ <widget class="GtkMenuItem" id="view1">+ <property name="visible">True</property>+ <property name="label" translatable="yes">_View</property>+ <property name="use_underline">True</property>++ <child>+ <widget class="GtkMenu" id="view1_menu">++ <child>+ <widget class="GtkRadioMenuItem" id="allEntries">+ <property name="visible">True</property>+ <property name="label" translatable="yes">All entries</property>+ <property name="use_underline">True</property>+ <property name="active">True</property>+ </widget>+ </child>++ <child>+ <widget class="GtkRadioMenuItem" id="0.1%Entries">+ <property name="visible">True</property>+ <property name="label" translatable="yes">Only entries with 0.1% or more</property>+ <property name="use_underline">True</property>+ <property name="active">False</property>+ <property name="group">allEntries</property>+ </widget>+ </child>++ <child>+ <widget class="GtkRadioMenuItem" id="0.5%Entries">+ <property name="visible">True</property>+ <property name="label" translatable="yes">Only entries with 0.5% or more</property>+ <property name="use_underline">True</property>+ <property name="active">False</property>+ <property name="group">allEntries</property>+ </widget>+ </child>++ <child>+ <widget class="GtkRadioMenuItem" id="1%Entries">+ <property name="visible">True</property>+ <property name="label" translatable="yes">Only entries with 1% or more</property>+ <property name="use_underline">True</property>+ <property name="active">False</property>+ <property name="group">allEntries</property>+ </widget>+ </child>++ <child>+ <widget class="GtkRadioMenuItem" id="5%Entries">+ <property name="visible">True</property>+ <property name="label" translatable="yes">Only entries with 5% or more</property>+ <property name="use_underline">True</property>+ <property name="active">False</property>+ <property name="group">allEntries</property>+ </widget>+ </child>++ <child>+ <widget class="GtkRadioMenuItem" id="10%Entries">+ <property name="visible">True</property>+ <property name="label" translatable="yes">Only entries with 10% or more</property>+ <property name="use_underline">True</property>+ <property name="active">False</property>+ <property name="group">allEntries</property>+ </widget>+ </child>++ <child>+ <widget class="GtkRadioMenuItem" id="50%Entries">+ <property name="visible">True</property>+ <property name="label" translatable="yes">Only entries with 50% or more</property>+ <property name="use_underline">True</property>+ <property name="active">False</property>+ <property name="group">allEntries</property>+ </widget>+ </child>+ </widget>+ </child>+ </widget>+ </child>++ <child>+ <widget class="GtkMenuItem" id="menuitem4">+ <property name="visible">True</property>+ <property name="label" translatable="yes">_Help</property>+ <property name="use_underline">True</property>++ <child>+ <widget class="GtkMenu" id="menuitem4_menu">++ <child>+ <widget class="GtkMenuItem" id="aboutMenuItem">+ <property name="visible">True</property>+ <property name="label" translatable="yes">_About</property>+ <property name="use_underline">True</property>+ </widget>+ </child>+ </widget>+ </child>+ </widget>+ </child>+ </widget>+ <packing>+ <property name="padding">0</property>+ <property name="expand">False</property>+ <property name="fill">False</property>+ </packing>+ </child>++ <child>+ <widget class="GtkTable" id="table1">+ <property name="border_width">5</property>+ <property name="visible">True</property>+ <property name="n_rows">4</property>+ <property name="n_columns">2</property>+ <property name="homogeneous">False</property>+ <property name="row_spacing">2</property>+ <property name="column_spacing">10</property>++ <child>+ <widget class="GtkLabel" id="label4">+ <property name="visible">True</property>+ <property name="label" translatable="yes"><b>Total time</b></property>+ <property name="use_underline">False</property>+ <property name="use_markup">True</property>+ <property name="justify">GTK_JUSTIFY_RIGHT</property>+ <property name="wrap">False</property>+ <property name="selectable">False</property>+ <property name="xalign">1</property>+ <property name="yalign">0.5</property>+ <property name="xpad">0</property>+ <property name="ypad">0</property>+ </widget>+ <packing>+ <property name="left_attach">0</property>+ <property name="right_attach">1</property>+ <property name="top_attach">2</property>+ <property name="bottom_attach">3</property>+ <property name="x_options">fill</property>+ <property name="y_options"></property>+ </packing>+ </child>++ <child>+ <widget class="GtkLabel" id="label4">+ <property name="visible">True</property>+ <property name="label" translatable="yes"><b>Total alloc</b></property>+ <property name="use_underline">False</property>+ <property name="use_markup">True</property>+ <property name="justify">GTK_JUSTIFY_LEFT</property>+ <property name="wrap">False</property>+ <property name="selectable">False</property>+ <property name="xalign">1</property>+ <property name="yalign">0.5</property>+ <property name="xpad">0</property>+ <property name="ypad">0</property>+ </widget>+ <packing>+ <property name="left_attach">0</property>+ <property name="right_attach">1</property>+ <property name="top_attach">3</property>+ <property name="bottom_attach">4</property>+ <property name="x_options">fill</property>+ <property name="y_options"></property>+ </packing>+ </child>++ <child>+ <widget class="GtkLabel" id="titleLabel">+ <property name="visible">True</property>+ <property name="can_focus">True</property>+ <property name="label" translatable="yes"></property>+ <property name="use_underline">False</property>+ <property name="use_markup">False</property>+ <property name="justify">GTK_JUSTIFY_LEFT</property>+ <property name="wrap">False</property>+ <property name="selectable">True</property>+ <property name="xalign">0</property>+ <property name="yalign">0.5</property>+ <property name="xpad">0</property>+ <property name="ypad">0</property>+ </widget>+ <packing>+ <property name="left_attach">1</property>+ <property name="right_attach">2</property>+ <property name="top_attach">0</property>+ <property name="bottom_attach">1</property>+ <property name="x_options">expand|shrink|fill</property>+ <property name="y_options"></property>+ </packing>+ </child>++ <child>+ <widget class="GtkLabel" id="totalTimeLabel">+ <property name="visible">True</property>+ <property name="can_focus">True</property>+ <property name="label" translatable="yes"></property>+ <property name="use_underline">False</property>+ <property name="use_markup">False</property>+ <property name="justify">GTK_JUSTIFY_LEFT</property>+ <property name="wrap">False</property>+ <property name="selectable">True</property>+ <property name="xalign">0</property>+ <property name="yalign">0.5</property>+ <property name="xpad">0</property>+ <property name="ypad">0</property>+ </widget>+ <packing>+ <property name="left_attach">1</property>+ <property name="right_attach">2</property>+ <property name="top_attach">2</property>+ <property name="bottom_attach">3</property>+ <property name="x_options">fill</property>+ <property name="y_options"></property>+ </packing>+ </child>++ <child>+ <widget class="GtkLabel" id="totalAllocLabel">+ <property name="visible">True</property>+ <property name="can_focus">True</property>+ <property name="label" translatable="yes"></property>+ <property name="use_underline">False</property>+ <property name="use_markup">False</property>+ <property name="justify">GTK_JUSTIFY_LEFT</property>+ <property name="wrap">False</property>+ <property name="selectable">True</property>+ <property name="xalign">0</property>+ <property name="yalign">0.5</property>+ <property name="xpad">0</property>+ <property name="ypad">0</property>+ </widget>+ <packing>+ <property name="left_attach">1</property>+ <property name="right_attach">2</property>+ <property name="top_attach">3</property>+ <property name="bottom_attach">4</property>+ <property name="x_options">fill</property>+ <property name="y_options"></property>+ </packing>+ </child>++ <child>+ <widget class="GtkLabel" id="label11">+ <property name="visible">True</property>+ <property name="label" translatable="yes"><b>Report</b></property>+ <property name="use_underline">False</property>+ <property name="use_markup">True</property>+ <property name="justify">GTK_JUSTIFY_RIGHT</property>+ <property name="wrap">False</property>+ <property name="selectable">False</property>+ <property name="xalign">1</property>+ <property name="yalign">0.5</property>+ <property name="xpad">0</property>+ <property name="ypad">0</property>+ </widget>+ <packing>+ <property name="left_attach">0</property>+ <property name="right_attach">1</property>+ <property name="top_attach">0</property>+ <property name="bottom_attach">1</property>+ <property name="x_options">fill</property>+ <property name="y_options"></property>+ </packing>+ </child>++ <child>+ <widget class="GtkLabel" id="label12">+ <property name="visible">True</property>+ <property name="label" translatable="yes"><b>Command</b></property>+ <property name="use_underline">False</property>+ <property name="use_markup">True</property>+ <property name="justify">GTK_JUSTIFY_RIGHT</property>+ <property name="wrap">False</property>+ <property name="selectable">False</property>+ <property name="xalign">1</property>+ <property name="yalign">0.5</property>+ <property name="xpad">0</property>+ <property name="ypad">0</property>+ </widget>+ <packing>+ <property name="left_attach">0</property>+ <property name="right_attach">1</property>+ <property name="top_attach">1</property>+ <property name="bottom_attach">2</property>+ <property name="x_options">fill</property>+ <property name="y_options"></property>+ </packing>+ </child>++ <child>+ <widget class="GtkLabel" id="commandLabel">+ <property name="visible">True</property>+ <property name="label" translatable="yes"></property>+ <property name="use_underline">False</property>+ <property name="use_markup">False</property>+ <property name="justify">GTK_JUSTIFY_LEFT</property>+ <property name="wrap">True</property>+ <property name="selectable">False</property>+ <property name="xalign">0</property>+ <property name="yalign">0</property>+ <property name="xpad">0</property>+ <property name="ypad">0</property>+ </widget>+ <packing>+ <property name="left_attach">1</property>+ <property name="right_attach">2</property>+ <property name="top_attach">1</property>+ <property name="bottom_attach">2</property>+ <property name="x_options">fill</property>+ <property name="y_options"></property>+ </packing>+ </child>+ </widget>+ <packing>+ <property name="padding">0</property>+ <property name="expand">False</property>+ <property name="fill">False</property>+ </packing>+ </child>++ <child>+ <widget class="GtkScrolledWindow" id="scrolledwindow1">+ <property name="visible">True</property>+ <property name="can_focus">True</property>+ <property name="hscrollbar_policy">GTK_POLICY_AUTOMATIC</property>+ <property name="vscrollbar_policy">GTK_POLICY_AUTOMATIC</property>+ <property name="shadow_type">GTK_SHADOW_NONE</property>+ <property name="window_placement">GTK_CORNER_TOP_LEFT</property>++ <child>+ <widget class="GtkTreeView" id="mainView">+ <property name="visible">True</property>+ <property name="can_focus">True</property>+ <property name="headers_visible">True</property>+ <property name="rules_hint">True</property>+ <property name="reorderable">False</property>+ <property name="enable_search">True</property>+ </widget>+ </child>+ </widget>+ <packing>+ <property name="padding">0</property>+ <property name="expand">True</property>+ <property name="fill">True</property>+ </packing>+ </child>++ <child>+ <widget class="GtkStatusbar" id="statusbar">+ <property name="visible">True</property>+ <property name="has_resize_grip">True</property>+ </widget>+ <packing>+ <property name="padding">0</property>+ <property name="expand">False</property>+ <property name="fill">False</property>+ </packing>+ </child>+ </widget>+ </child>+</widget>++</glade-interface>
+ demo/profileviewer/ProfileViewer.gladep view
@@ -0,0 +1,8 @@+<?xml version="1.0" standalone="no"?> <!--*- mode: xml -*-->+<!DOCTYPE glade-project SYSTEM "http://glade.gnome.org/glade-project-2.0.dtd">++<glade-project>+ <name>ProfileViewer</name>+ <program_name>profileviewer</program_name>+ <gnome_support>FALSE</gnome_support>+</glade-project>
+ demo/profileviewer/ProfileViewer.hs view
@@ -0,0 +1,185 @@+-- Copyright (c) 2004 Duncan Coutts+-- This program is liscenced under the GNU General Public License version 2+-- or (at your option) any later version.++-- This is a slightly larger demo that combines use of glade, the file chooser+-- dialog, program state (IORefs) and use of the mogul tree view wrapper+-- interface. ++-- The program is a simple viewer for the log files that ghc produces when you+-- do time profiling. The parser is not very clever so loading large files can+-- take several seconds.++-- TODO: The gui will appear to hang when loading files. We should use threads+-- to keep the gui responsive.++module Main where++import Graphics.UI.Gtk+import Graphics.UI.Gtk.Glade+import Graphics.UI.Gtk.ModelView as New++import ParseProfile++import Data.Maybe (isJust, fromJust)+import Control.Monad (when)+import Data.List (unfoldr, intersperse)+import qualified Data.Tree as Tree+import System.Environment (getArgs)+import Data.IORef++main :: IO ()+main = do+ -- our global state+ thresholdVar <- newIORef 0 --current cuttoff/threshhold value+ profileVar <- newIORef Nothing --holds the current profile data structure+ + -- initialisation stuff+ initGUI++ Just dialogXml <- xmlNew "ProfileViewer.glade"++ -- get a handle on a various objects from the glade file+ mainWindow <- xmlGetWidget dialogXml castToWindow "mainWindow"+ onDestroy mainWindow mainQuit++ mainView <- xmlGetWidget dialogXml castToTreeView "mainView"++ titleLabel <- xmlGetWidget dialogXml castToLabel "titleLabel"+ commandLabel <- xmlGetWidget dialogXml castToLabel "commandLabel"+ totalTimeLabel <- xmlGetWidget dialogXml castToLabel "totalTimeLabel"+ totalAllocLabel <- xmlGetWidget dialogXml castToLabel "totalAllocLabel"+ + -- create the tree model+ store <- New.treeStoreNew []+ New.treeViewSetModel mainView store++ let createTextColumn name field = do+ column <- New.treeViewColumnNew+ New.treeViewAppendColumn mainView column+ New.treeViewColumnSetTitle column name+ cell <- New.cellRendererTextNew+ New.treeViewColumnPackStart column cell True+ New.cellLayoutSetAttributes column cell store+ (\record -> [New.cellText := field record])++ -- create the various columns in both the model and view+ createTextColumn "Cost Centre" costCentre+ createTextColumn "Module" moduleName+ createTextColumn "Entries" (show.entries)+ createTextColumn "Individual %time" (show.(/10).fromIntegral.individualTime)+ createTextColumn "Individual %alloc" (show.(/10).fromIntegral.individualAlloc)+ createTextColumn "Inherited %time" (show.(/10).fromIntegral.inheritedTime)+ createTextColumn "Inherited %alloc" (show.(/10).fromIntegral.inheritedAlloc)++ -- this action clears the tree model and then populates it with the+ -- profile contained in the profileVar, taking into account the current+ -- threshold value kept in the thresholdVar + let repopulateTreeStore = do+ profile <- readIORef profileVar+ maybe (return ()) repopulateTreeStore' profile++ repopulateTreeStore' profile = do+ New.treeStoreClear store++ titleLabel `labelSetText` (title profile)+ commandLabel `labelSetText` (command profile)+ totalTimeLabel `labelSetText` (show (totalTime profile) ++ " sec")+ totalAllocLabel `labelSetText` (formatNumber (totalAlloc profile) ++ " bytes")+ + threshold <- readIORef thresholdVar+ let node = if threshold > 0+ then pruneOnThreshold threshold (breakdown profile)+ else Just (breakdown profile)+ toTree :: ProfileNode -> Tree.Tree ProfileNode+ toTree = Tree.unfoldTree (\node -> (node, children node))+ case node of+ Nothing -> return ()+ Just node -> New.treeStoreInsertTree store [] 0 (toTree node)++ -- associate actions with the menus+ + -- the open menu item, opens a file dialog and then loads and displays+ -- the the profile (unless the user cancleled the dialog)+ openMenuItem <- xmlGetWidget dialogXml castToMenuItem "openMenuItem"+ openMenuItem `onActivateLeaf` do+ filename <- openFileDialog mainWindow+ when (isJust filename)+ (do profile <- parseProfileFile (fromJust filename)+ writeIORef profileVar (Just profile)+ repopulateTreeStore)++ quitMenuItem <- xmlGetWidget dialogXml castToMenuItem "quitMenuItem"+ quitMenuItem `onActivateLeaf` mainQuit+ + aboutMenuItem <- xmlGetWidget dialogXml castToMenuItem "aboutMenuItem"+ aboutMenuItem `onActivateLeaf` showAboutDialog mainWindow+ + -- each menu item in the "View" menu sets the thresholdVar and re-displays+ -- the current profile+ let doThresholdMenuItem threshold itemName = do+ menuItem <- xmlGetWidget dialogXml castToMenuItem itemName+ menuItem `onActivateLeaf` do writeIORef thresholdVar threshold+ repopulateTreeStore+ mapM_ (uncurry doThresholdMenuItem)+ [(0, "allEntries"), (1, "0.1%Entries"), (5, "0.5%Entries"), (10, "1%Entries"),+ (50, "5%Entries"), (100, "10%Entries"), (500, "50%Entries")]++ -- Check the command line to see if a profile file was given+ commands <- getArgs+ when (not (null commands))+ (do profile <- parseProfileFile (head commands)+ writeIORef profileVar (Just profile)+ repopulateTreeStore)++ -- The final step is to display the main window and run the main loop+ widgetShowAll mainWindow+ mainGUI+++-- display a standard file open dialog+openFileDialog :: Window -> IO (Maybe String)+openFileDialog parentWindow = do+ dialog <- fileChooserDialogNew+ (Just "Open Profile... ")+ (Just parentWindow)+ FileChooserActionOpen+ [("gtk-cancel", ResponseCancel)+ ,("gtk-open", ResponseAccept)]+ widgetShow dialog+ response <- dialogRun dialog+ widgetHide dialog+ case response of+ ResponseAccept -> fileChooserGetFilename dialog+ _ -> return Nothing++-- just to display a number using thousand seperators+-- eg "3,456,235,596"+formatNumber :: Integer -> String+formatNumber =+ reverse . concat . intersperse ","+ . unfoldr (\l -> case splitAt 3 l of+ ([], _) -> Nothing+ p -> Just p)+ . reverse . show++showAboutDialog :: Window -> IO ()+showAboutDialog parent = do+ -- create the about dialog+ aboutDialog <- aboutDialogNew++ -- set some attributes+ set aboutDialog [+ aboutDialogName := "profileviewer",+ aboutDialogVersion := "0.2",+ aboutDialogCopyright := "Duncan Coutts",+ aboutDialogComments := "A viewer for GHC time profiles.",+ aboutDialogWebsite := "http://haskell.org/gtk2hs/"+ ]++ -- make the about dialog appear above the main window+ windowSetTransientFor aboutDialog parent++ -- make the dialog non-modal. When the user closes the dialog destroy it.+ afterResponse aboutDialog $ \_ -> widgetDestroy aboutDialog+ widgetShow aboutDialog
+ demo/scaling/London_Eye.jpg view
binary file changed (absent → 36373 bytes)
+ demo/scaling/Makefile view
@@ -0,0 +1,16 @@++PROG = scaling+SOURCES = Scaling.hs+#HCFLAGS = -prof -auto-all+# use -fglasgow-exts since older ghc versions don't know about FlexibleContexts+HCFLAGS = -O3 -fglasgow-exts+#HCFLAGS = -O3 -fvia-C -optc-O3+#HCFLAGS = -O0 -keep-hc-file -keep-s-files -fvia-C++$(PROG) : $(SOURCES)+ $(HC) --make $< -o $@ $(HCFLAGS)++clean:+ rm -f $(SOURCES:.hs=.hi) $(SOURCES:.hs=.o) $(PROG)++HC=ghc
+ demo/scaling/Mountains.jpg view
binary file changed (absent → 29680 bytes)
+ demo/scaling/Scaling.hs view
@@ -0,0 +1,763 @@+{-# OPTIONS -O #-}+ --- {-# OPTIONS_GHC -XFlexibleContexts #-} see Makefile+-- Author: Pawel Bulkowski (pawelb16@gmail.com)+-- Thanks to Michal Palka for teaching me Haskell+-- Photos by: Magdalena Niedziela+-- based on other gtk2hs example applications+-- the code is public domain+import Graphics.UI.Gtk+import Graphics.UI.Gtk.Gdk.EventM++import Data.Array.MArray+import Data.Array.IO+--import Data.Array.IO.Internals+import Data.Array.Storable+import Data.Bits+import Data.Word+import Data.Maybe+import Data.IORef+import Data.Ord+import Control.Monad ( when, unless, liftM )+import Control.Monad.Trans ( liftIO )+import Control.Monad.ST+import Data.Array.Base ( unsafeWrite, unsafeRead ) +import Graphics.UI.Gtk+import Graphics.UI.Gtk.Glade+import Graphics.UI.Gtk.ModelView as New +import Graphics.UI.Gtk.Gdk.GC (gcNew)+import CPUTime+import System.Environment ( getArgs )+import System.Directory ( doesFileExist )+type ArrayType = IOUArray+--type ArrayType = StorableArray++-- The state and GUI++data ImageState = Empty|NonEmpty+data State = State {+ pb :: Pixbuf,+ is :: ImageState+}++ +main = do+ args <- getArgs+ case args of+ [fName] -> do+ exists <- doesFileExist fName+ if exists then runGUI fName else+ putStrLn ("File "++fName++" not found.")+ _ -> putStrLn "Usage: scaling <image.jpg>"+ +runGUI fName = do + initGUI++ window <- windowNew+ window `onDestroy` mainQuit+ set window [ windowTitle := "Scaling"+ , windowResizable := True ]+ label <- labelNew (Just "Content Aware Image Scaling")+ vboxOuter <- vBoxNew False 0+ vboxInner <- vBoxNew False 5+ + (mb,miOpen,miSave,miScale, miGradient, miSeamCarve, miQuit) <- makeMenuBar+ canvas <- drawingAreaNew+ containerAdd vboxInner canvas+ + + -- Assemble the bits+ set vboxOuter [ containerChild := mb+ , containerChild := vboxInner ]+ set vboxInner [ containerChild := label+ , containerBorderWidth := 10 ]+ set window [ containerChild := vboxOuter ]+ + -- create the Pixbuf+ pb <- pixbufNew ColorspaceRgb False 8 256 256+ -- Initialize the state+ state <- newIORef State { pb = pb, is = Empty }+ let modifyState f = readIORef state >>= f >>= writeIORef state++ canvas `onSizeRequest` return (Requisition 256 256)+ ++ -- Add action handlers+ onActivateLeaf miQuit mainQuit+-- onActivateLeaf miOpen $ modifyState $ reset gui+ onActivateLeaf miOpen $ modifyState $ loadImageDlg canvas window+ onActivateLeaf miSave $ modifyState $ saveImageDlg canvas window+ onActivateLeaf miScale $ modifyState $ scaleImageDlg canvas window+ onActivateLeaf miGradient $ modifyState $ gradientImageDlg canvas window+ onActivateLeaf miSeamCarve $ modifyState $ seamCarveImageDlg canvas window++ modifyState (loadImage canvas window fName)+ + canvas `on` exposeEvent $ updateCanvas state+ boxPackStartDefaults vboxInner canvas+ widgetShowAll window+ mainGUI++ return ()++ --uncomment for ghc < 6.8.3+--instance Show Rectangle where+-- show (Rectangle x y w h) = "x="++show x++", y="++show y+++-- ", w="++show w++", h="++show h++";"++updateCanvas :: IORef State -> EventM EExpose Bool+updateCanvas rstate = do+ region <- eventRegion+ win <- eventWindow+ liftIO $ do+ state <- readIORef rstate+ let (State pb is) = state+ gc <- gcNew win+ width <- pixbufGetWidth pb+ height <- pixbufGetHeight pb+ pbregion <- regionRectangle (Rectangle 0 0 width height)+ regionIntersect region pbregion+ rects <- regionGetRectangles region+ putStrLn ("redrawing: "++show rects)+ (flip mapM_) rects $ \(Rectangle x y w h) -> do+ drawPixbuf win gc pb x y x y w h RgbDitherNone 0 0+ return True++{-# INLINE doFromTo #-}+-- do the action for [from..to], ie it's inclusive.+doFromTo :: Int -> Int -> (Int -> IO ()) -> IO ()+doFromTo from to action =+ let loop n | n > to = return ()+ | otherwise = do action n+ loop (n+1)+ in loop from++-- do the action for [to..from], ie it's inclusive.+{-# INLINE doFromToDown #-}+doFromToDown :: Int -> Int -> (Int -> IO ()) -> IO ()+doFromToDown from to action =+ let loop n | n < to = return ()+ | otherwise = do action n+ loop (n-1)+ in loop from++-- do the action for [from..to] with step, ie it's inclusive.+{-# INLINE doFromToStep #-}+doFromToStep :: Int -> Int -> Int -> (Int -> IO ()) -> IO ()+doFromToStep from to step action =+ let loop n | n > to = return ()+ | otherwise = do action n+ loop (n+step)+ in loop from+ +--forM = flip mapM+ +makeMenuBar = do+ mb <- menuBarNew+ fileMenu <- menuNew+ open <- menuItemNewWithMnemonic "_Open"+ save <- menuItemNewWithMnemonic "_Save"+ scale <- menuItemNewWithMnemonic "_Scale"+ gradient <- menuItemNewWithMnemonic "_Gradient"+ seamCarve <- menuItemNewWithMnemonic "Seam _Carve"+ quit <- menuItemNewWithMnemonic "_Quit"+ file <- menuItemNewWithMnemonic "_File"+ menuShellAppend fileMenu open+ menuShellAppend fileMenu save+ menuShellAppend fileMenu scale+ menuShellAppend fileMenu gradient+ menuShellAppend fileMenu seamCarve+ menuShellAppend fileMenu quit+ menuItemSetSubmenu file fileMenu+ containerAdd mb file+ return (mb,open,save,scale,gradient,seamCarve,quit)++loadImageDlg canvas window (State pb is) = do+ putStrLn ("loadImage")+ ret <- openFileDialog window+ case ret of+ Just (filename) -> (loadImage canvas window filename (State pb is))+ Nothing -> return (State pb is)+++loadImage canvas window filename (State pb is) = do+ putStrLn ("loadImage")+ pxb <- pixbufNewFromFile filename+ width <- pixbufGetWidth pxb+ height <- pixbufGetHeight pxb+ widgetSetSizeRequest canvas width height+ widgetQueueDraw canvas+-- updateCanvas canvas pxb+ return (State pxb NonEmpty)++ +saveImageDlg canvas window (State pb is) = do+ putStrLn ("saveImage")+ ret <- openFileDialog window+ case ret of+ Just (filename) -> do+ pixbufSave pb filename "png" []+ return (State pb is)+ Nothing -> return (State pb is)++scaleImageDlg canvas window (State pb is) = do+ putStrLn ("scaleImage")+ + origWidth <- pixbufGetWidth pb+ origHeight <- pixbufGetHeight pb+ ret <- scaleDialog window origWidth origHeight++ let update w h = do+ putStrLn ("seamCarveImage::update w: "++show w++" h: "++show h)+ --scalePixbuf :: Pixbuf -> Int -> Int -> IO Pixbuf+ pxb <- scalePixbuf pb w h+ width <- pixbufGetWidth pxb+ height <- pixbufGetHeight pxb+ widgetSetSizeRequest canvas width height+ widgetQueueDraw canvas+ --updateCanvas canvas pxb+ return (State pxb NonEmpty)++ case ret of+ Nothing -> return (State pb NonEmpty)+ Just (w,h) -> (update w h)+ +gradientImageDlg canvas window (State pb is) = do+ putStrLn ("gradientImageDlg")+ --scalePixbuf :: Pixbuf -> Int -> Int -> IO Pixbuf+ pxb <- gradientPixbuf pb+ width <- pixbufGetWidth pxb+ height <- pixbufGetHeight pxb+ widgetSetSizeRequest canvas width height+ widgetQueueDraw canvas+-- updateCanvas canvas pxb+ return (State pxb NonEmpty)+ +seamCarveImageDlg canvas window (State pb is) = do+ origWidth <- pixbufGetWidth pb+ origHeight <- pixbufGetHeight pb+ ret <- seamCarveDialog window origWidth origHeight 2++ let update w h grdCnt = do+ putStrLn ("seamCarveImageDlg::update w: "++show w++" h: "++show h)+ --scalePixbuf :: Pixbuf -> Int -> Int -> IO Pixbuf+ --pxb <- scalePixbuf pb w h+ cpuStart <- getCPUTime+ pxb <- seamCarvePixbuf pb w h grdCnt+ cpuEnd <- getCPUTime+ putStrLn ("seamCarveImageDlg::cpu time: "++show ((fromIntegral (cpuEnd-cpuStart) :: Double) /1e12))+ width <- pixbufGetWidth pxb+ height <- pixbufGetHeight pxb+ widgetSetSizeRequest canvas width height+ widgetQueueDraw canvas+ --updateCanvas canvas pxb+ return (State pxb NonEmpty)++ case ret of+ Nothing -> return (State pb NonEmpty)+ Just (w,h,grdCnt) -> (update w h grdCnt)++ +scaleDialog :: Window -> Int -> Int-> IO (Maybe (Int, Int))+scaleDialog parent width height = do++ Just xml <- xmlNew "scaling.glade" ++ dia <- xmlGetWidget xml castToDialog "dialogScale"+ dialogAddButton dia stockCancel ResponseCancel+ dialogAddButton dia stockOk ResponseOk+ entryWidth <- xmlGetWidget xml castToEntry "entryScalingWidth" + entryHeight <- xmlGetWidget xml castToEntry "entryScalingHeight" + entrySetText entryWidth (show width)+ entrySetText entryHeight (show height)+ res <- dialogRun dia+ widthStr <- entryGetText entryWidth+ heightStr <- entryGetText entryHeight+ widgetDestroy dia+ putStrLn ("scaleDialog width: "++show width++" height: "++show height)+ case res of+ ResponseOk -> return (Just (read widthStr,read heightStr))+ _ -> return Nothing++seamCarveDialog :: Window -> Int -> Int -> Int -> IO (Maybe (Int, Int, Int))+seamCarveDialog parent width height grdCnt= do++ Just xml <- xmlNew "scaling.glade" ++ dia <- xmlGetWidget xml castToDialog "dialogSeamCarve"+ dialogAddButton dia stockCancel ResponseCancel+ dialogAddButton dia stockOk ResponseOk+ entryWidth <- xmlGetWidget xml castToEntry "entryWidth" + entryHeight <- xmlGetWidget xml castToEntry "entryHeight" + entryGrdCnt <- xmlGetWidget xml castToEntry "entryGrdCnt" + entrySetText entryWidth (show width)+ entrySetText entryHeight (show height)+ entrySetText entryGrdCnt (show grdCnt)+ res <- dialogRun dia+ widthStr <- entryGetText entryWidth+ heightStr <- entryGetText entryHeight+ grdCntStr <- entryGetText entryGrdCnt+ widgetDestroy dia+ putStrLn ("scaleDialog width: "++show width++" height: "++show height++" grdCnt: "++show grdCnt)+ case res of+ ResponseOk -> return (Just (read widthStr,read heightStr, read grdCntStr))+ _ -> return Nothing++ +openFileDialog :: Window -> IO (Maybe String)+openFileDialog parentWindow = do+ dialog <- fileChooserDialogNew+ (Just "Open Profile... ")+ (Just parentWindow)+ FileChooserActionOpen+ [("gtk-cancel", ResponseCancel)+ ,("gtk-open", ResponseAccept)]+ widgetShow dialog+ response <- dialogRun dialog+ widgetHide dialog+ case response of+ ResponseAccept -> fileChooserGetFilename dialog+ _ -> return Nothing++--simple pixbuf scaling+scalePixbuf :: Pixbuf -> Int -> Int -> IO Pixbuf+scalePixbuf pb newWidth newHeight = do+ width <- pixbufGetWidth pb+ height <- pixbufGetHeight pb+ row <- pixbufGetRowstride pb+ chan <- pixbufGetNChannels pb+ bits <- pixbufGetBitsPerSample pb+ pbData <- (pixbufGetPixels pb :: IO (PixbufData Int Word8))+ pbn <- pixbufNew ColorspaceRgb False 8 newWidth newHeight+ pbnData <- (pixbufGetPixels pbn :: IO (PixbufData Int Word8))+ newRow <- pixbufGetRowstride pbn+ putStrLn ("bytes per row: "++show row++", channels per pixel: "++show chan+++ ", bits per sample: "++show bits)+ putStrLn ("width: "++show width++", height: "++show height++", newWidth: "++show newWidth++", newHeight: "++show newHeight++" bytes per row new: "++show newRow)+ + + let stepX = (fromIntegral width) / (fromIntegral newWidth) :: Double+ let stepY = (fromIntegral height) / (fromIntegral newHeight) :: Double++ doFromTo 0 (newHeight-1) $ \y -> do+ let y1 = truncate ((fromIntegral y) * stepY)+ doFromTo 0 (newWidth-1) $ \x -> do+ let x1 = truncate ((fromIntegral x) * stepX)+ let off = (x1*chan+y1*row)+ let offNew = (x*chan+y*newRow)+ --putStrLn ("x: "++show x++", y: "++show y++" x1: "++show x1++", y1: "++show y1++" off:"++show off++" offNew:"++show offNew)+ r <- unsafeRead pbData (off)+ g <- unsafeRead pbData (1+off)+ b <- unsafeRead pbData (2+off)+ unsafeWrite pbnData (offNew) r+ unsafeWrite pbnData (1+offNew) g+ unsafeWrite pbnData (2+offNew) b+ return pbn+++{-# INLINE arrmove #-}+arrmove :: (Ix i, MArray a e IO) => a i e -> Int -> Int -> Int -> IO ()+arrmove arr src dst size = do++ --putStrLn("arrmove "++show src++" "++show dst++" "++show size)+ doFromTo 0 (size-1) $ \x -> do+ --forM [0..(size-1)] $ \x -> do+ v <- unsafeRead arr (src+x)+ unsafeWrite arr (dst+x) v+ --putStrLn("arrmove2 "++show src++" "++show dst++" "++show size)+ return ()++ +{-# INLINE arrmovesd #-}+arrmovesd :: (Ix b, MArray a c IO) => a b c -> a b c -> Int -> Int -> Int -> IO ()+arrmovesd arrsrc arrdst src dst size = do+ doFromTo 0 (size-1) $ \x -> do+ --forM [0..(size-1)] $ \x -> do+ v <- unsafeRead arrsrc (src+x)+ unsafeWrite arrdst (dst+x) v+ return ()++{-# INLINE arrmoven #-}+arrmoven :: (Ix i, MArray a e IO) => a i e -> Int -> Int -> Int -> Int -> Int -> IO ()+arrmoven arr src dst size w n = do+ --putStrLn("arrmoven "++show src++" "++show dst++" "++show size++" "++show w++" "++show n)+ doFromToStep 0 ((n-1)*w) w $ \yoff -> do+ arrmove arr (src+yoff) (dst+yoff) size+ return ()++-- content Aware scaling+--TODO!+seamCarvePixbuf :: Pixbuf -> Int -> Int -> Int -> IO Pixbuf+seamCarvePixbuf pb newWidth newHeight grdCnt = do+ width <- pixbufGetWidth pb+ height <- pixbufGetHeight pb+ row <- pixbufGetRowstride pb+ chan <- pixbufGetNChannels pb+ bits <- pixbufGetBitsPerSample pb+ pbData <- (pixbufGetPixels pb :: IO (PixbufData Int Word8))+ --pbn <- pixbufNew ColorspaceRgb False 8 newWidth newHeight+ pbn <- pixbufNew ColorspaceRgb False 8 newWidth newHeight+ pbnData <- (pixbufGetPixels pbn :: IO (PixbufData Int Word8))+ newRow <- pixbufGetRowstride pbn+ putStrLn ("bytes per row: "++show row++", channels per pixel: "++show chan+++ ", bits per sample: "++show bits)+ putStrLn ("width: "++show width++", height: "++show height++", newWidth: "++show newWidth++", newHeight: "++show newHeight++" bytes per row new: "++show newRow)++ tmpPB <- pixbufCopy pb+ tmpData <- (pixbufGetPixels tmpPB) :: IO (PixbufData Int Word8)+ ----double gradient+ + let computeSrcPic pb cnt | cnt <= 0 = do pixbufCopy pb+ | cnt > 0 = do+ pb <- computeSrcPic pb (cnt-1)+ gradientPixbuf pb++ --computing gradient but one more gradient+ --will be compute later by gradientArray function + tmpPB2 <- computeSrcPic tmpPB (grdCnt-1)+ tmpData2 <- (pixbufGetPixels tmpPB2) :: IO (PixbufData Int Word8)++ -- array to store x coord of removed pixels+ coordArr <- newArray (0, (max width height)) 0 :: IO (ArrayType Int Int) + + let removeVPixel pixData x y w = do+ --unsafeWrite pixData (0+x*chan+y*row) 255+ --unsafeWrite pixData (1+x*chan+y*row) 255+ --unsafeWrite pixData (2+x*chan+y*row) 255+ --store x-coord of removed pixel+ unsafeWrite coordArr y x+ arrmove pixData ((x+1)*chan+y*row) (x*chan+y*row) ((w-x-1)*chan)+ return () + + let removeHPixel pixData x y h = do+ --putStrLn("removeHPixel "++show x++" "++show y++" "++show h)+ --store y-coord of removed pixel+ unsafeWrite coordArr y x+ --putStrLn("removeHPixel1.5 "++show x++" "++show y++" "++show h)+ arrmoven pixData (y*chan+(x+1)*row) (y*chan+x*row) chan row (h-x-1)+ --putStrLn("removeHPixel2 "++show x++" "++show y++" "++show h)+ return () + + let removeVGrdPixel grdData x y w = do+ arrmove grdData (x+1+y*width) (x+y*width) (w-x-1)+ return ()+ + let removeHGrdPixel grdData x y h = do+ --putStrLn("removeHGrdPixel "++show x++" "++show y++" "++show h)+ arrmoven grdData (y+(x+1)*width) (y+x*width) 1 width (h-x-1)+ --putStrLn("removeHGrdPixel2 "++show x++" "++show y++" "++show h)+ return ()+ + let vPixIndex x y chan row = (x*chan)+(y*row)+ let hPixIndex x y chan row = (y*chan)+(x*row)++ -- possibly it can be made shorted+ let removeSeam pixIndex rmPixel rmGrdPixel seamArr grdArr x y w = do+ rmPixel tmpData x y w+ rmPixel tmpData2 x y w+ rmGrdPixel grdArr x y w+ unless (y == 0) $ do+ v0 <- if x==0 then return 0x7fffffff else unsafeRead seamArr (pixIndex (x-1) y 1 width)+ v1 <- unsafeRead seamArr (pixIndex x y 1 width)+ v2 <- if x==(w-1) then return 0x7fffffff else unsafeRead seamArr (pixIndex (x+1) y 1 width)+ let nextX | v0 < v1 && v0 < v2 = (x-1)+ | v2 < v1 = (x+1) + | True = x+ removeSeam pixIndex rmPixel rmGrdPixel seamArr grdArr nextX (y-1) w++ -- possibly it can be update to be more general+ let updateGradientArray pixIndex grdArr y w h = unless (y == -1) $ do+ x <- unsafeRead coordArr y+ unless (x == 0) $ do+ g <- pixelGradient pixIndex tmpData2 row chan w h (x-1) y+ unsafeWrite grdArr (pixIndex (x-1) y 1 width) g+ unless (y == 0) $ do+ g <- pixelGradient pixIndex tmpData2 row 1 w h (x-1) (y-1)+ unsafeWrite grdArr (pixIndex (x-1) (y-1) 1 width) g+ unless (y == (h-1)) $ do+ g <- pixelGradient pixIndex tmpData2 row 1 w h (x-1) (y+1)+ unsafeWrite grdArr (pixIndex (x-1) (y+1) 1 width) g+ g <- pixelGradient pixIndex tmpData2 row 1 w h x y+ unsafeWrite grdArr (pixIndex x y 1 width) g+ unless (y == 0) $ do+ g <- pixelGradient pixIndex tmpData2 row 1 w h x (y-1)+ unsafeWrite grdArr (pixIndex x (y-1) 1 width) g+ g <- pixelGradient pixIndex tmpData2 row 1 w h x (y+1)+ unless (y == (h-1)) $ do+ g <- pixelGradient pixIndex tmpData2 row 1 w h x (y+1)+ unsafeWrite grdArr (pixIndex x (y+1) 1 width) g+ updateGradientArray pixIndex grdArr (y-1) w h+ return ()+ + let findMinVal pixIndex seamArr w h = do+ v <- unsafeRead seamArr (pixIndex 0 (h-1) 1 width)+ xRef <- newIORef (v :: Int, 0 :: Int)+ --let modifyState f = readIORef state >>= f >>= writeIORef state+ doFromTo 1 (w-1) $ \x -> do+ --putStrLn("findMinVal loop x: "++show x++" (h-1): "++show (h-1))+ v <- unsafeRead seamArr (pixIndex x (h-1) 1 width)+ (mval, m) <- readIORef xRef+ writeIORef xRef (if v < mval then (v, x) else (mval, m))+ (mval, m) <- readIORef xRef+ + putStrLn("w: " ++show w++ " minSeam: " ++ show mval ++ " at: "++show m) + return m++ grdArr <- gradientArray tmpPB2 width height+ + let removeVSeam w = do+ seamArr <- (computeVSeamArray grdArr width height w)+ m <- findMinVal vPixIndex seamArr w (height-1)+ removeSeam vPixIndex removeVPixel removeVGrdPixel seamArr grdArr m (height-1) w+ updateGradientArray vPixIndex grdArr (height-1) w height+ return ()++ let removeHSeam h = do+ seamArr <- (computeHSeamArray grdArr width height h)+ m <- findMinVal hPixIndex seamArr h (width-1)+ removeSeam hPixIndex removeHPixel removeHGrdPixel seamArr grdArr m (width-1) h+ updateGradientArray hPixIndex grdArr (width-1) h width+ return ()+ + --let nextX | v0 < v1 && v0 < v2 = (x-1)+ -- | v2 < v1 = (x+1) + -- | True = x+ + let grdSeam w h | w > newWidth && h > newHeight = do+ --putStrLn("grdSeam: "++show w++" "++show h)+ vSeamArr <- (computeVSeamArray grdArr width height w)+ mv <- findMinVal vPixIndex vSeamArr w (height-1)+ hSeamArr <- (computeHSeamArray grdArr width height h)+ mh <- findMinVal hPixIndex hSeamArr h (width-1)+ if mv < mh+ then do+ removeSeam vPixIndex removeVPixel removeVGrdPixel vSeamArr grdArr mv (height-1) w+ updateGradientArray vPixIndex grdArr (height-1) w height+ grdSeam (w-1) h+ else do+ removeSeam hPixIndex removeHPixel removeHGrdPixel hSeamArr grdArr mh (width-1) h+ updateGradientArray hPixIndex grdArr (width-1) h width+ grdSeam w (h-1)+ | w > newWidth = do+ --putStrLn("grdSeam2: "++show w++" "++show h)+ removeVSeam w+ grdSeam (w-1) h+ + | h > newHeight = do+ --putStrLn("grdSeam3: "++show w++" "++show h)+ removeHSeam h+ grdSeam w (h-1)+ | True = do+ return ()+ + -- remove/add seams+ --doFromToDown width (newWidth+1) $ \w -> do+ -- removeVSeam w+ + --doFromToDown height (newHeight+1) $ \h -> do+ -- removeHSeam h+ + grdSeam width height+ + + doFromTo 0 (newHeight-1) $ \y -> do+ arrmovesd tmpData pbnData (y*row) (y*newRow) newRow+ + return pbn++-- compute the gradient map+gradientPixbuf :: Pixbuf -> IO Pixbuf+gradientPixbuf pb = do+ width <- pixbufGetWidth pb+ height <- pixbufGetHeight pb+ row <- pixbufGetRowstride pb+ chan <- pixbufGetNChannels pb+ bits <- pixbufGetBitsPerSample pb+ pbData <- (pixbufGetPixels pb :: IO (PixbufData Int Word8))+ pbn <- pixbufNew ColorspaceRgb False 8 width height+ pbnData <- (pixbufGetPixels pbn :: IO (PixbufData Int Word8))+ putStrLn ("bytes per row: "++show row++", channels per pixel: "++show chan++", bits per sample: "++show bits)+ putStrLn ("width: "++show width++", height: "++show height)+ + let getpix x y c = do+ case (x < 1 || x >= width || y < 1 || y >= height) of+ True -> return 0+ False -> (unsafeRead pbData (c+x*chan+y*row))+ + let gradient x y c = do+ let convM = liftM fromIntegral+ blah a b = convM (getpix a b c)+ v00 <- blah (x-1) (y-1)+ v10 <- blah x (y-1)+ v20 <- blah (x+1) (y-1)+ v01 <- blah (x-1) y+ v21 <- blah (x+1) y+ v02 <- blah (x-1) (y+1)+ v12 <- blah x (y+1)+ v22 <- blah (x+1) (y+1)+ + let gx = abs ((v20-v00)+2*(v21-v01)+(v22-v02))+ let gy = abs ((v02-v00)+2*(v12-v10)+(v22-v20))+ let g = (gx + gy)::Int+ --let g8 = (shiftR g 3)+ let g8 = if g > 255 then 255 else g+ return (fromIntegral(g8) :: Word8)++ let totalGradient x y = do+ rg <- gradient x y 0+ gg <- gradient x y 1+ bg <- gradient x y 2+ let g = rg + gg + bg+ return ((fromIntegral g)::Word8)+ ++ doFromTo 0 (height-1) $ \y -> do+ let offY = y*row+ doFromTo 0 (width-1) $ \x -> do+ let offX = x*chan+ doFromTo 0 2 $ \c -> do+ let off = offY+offX + c+ --putStrLn ("x: "++show x++", y: "++show y++" off:"++show off)+ --v <- (totalGradient x y)+ v <- (gradient x y c)+ unsafeWrite pbnData (off) v+ return pbn++-- compute gradient fo single pixel+{-# INLINE pixelGradient #-}+pixelGradient :: (Int -> Int -> Int -> Int -> Int) -> (PixbufData Int Word8) -> Int -> Int -> Int -> Int -> Int -> Int -> (IO Word16)+pixelGradient pixIndex pbData row chan w h x y = do+ + let getpix x y c = do+ case (x < 0 || x >= w || y < 0 || y >= h) of+ True -> return 0+ False -> (unsafeRead pbData (c+(pixIndex x y chan row)))+ --False -> (unsafeRead pbData (c+x*chan+y*row))++ let gradient x y c = do+ let convM = liftM fromIntegral+ blah a b = convM (getpix a b c)+ v00 <- blah (x-1) (y-1)+ v10 <- blah x (y-1)+ v20 <- blah (x+1) (y-1)+ v01 <- blah (x-1) y+ v21 <- blah (x+1) y+ v02 <- blah (x-1) (y+1)+ v12 <- blah x (y+1)+ v22 <- blah (x+1) (y+1)+ + let gx = abs ((v20-v00)+2*(v21-v01)+(v22-v02))+ let gy = abs ((v02-v00)+2*(v12-v10)+(v22-v20))+ let g = (gx + gy)::Int+ --let g8 = (shiftR g 3)+ let g8 = if g > 255 then 255 else g+ return (fromIntegral(g8) :: Word8)+ + + let gradient x y c = do+ let convM = liftM fromIntegral+ blah a b = convM (getpix a b c)+ v00 <- blah (x-1) (y-1)+ v10 <- blah x (y-1)+ v20 <- blah (x+1) (y-1)+ v01 <- blah (x-1) y+ v21 <- blah (x+1) y+ v02 <- blah (x-1) (y+1)+ v12 <- blah x (y+1)+ v22 <- blah (x+1) (y+1)+ let gx = abs ((v20-v00)+2*(v21-v01)+(v22-v02))+ let gy = abs ((v02-v00)+2*(v12-v10)+(v22-v20))+ let g = gx + gy+ return (g :: Int)++ rg <- gradient x y 0+ gg <- gradient x y 1+ bg <- gradient x y 2+ let g = rg + gg + bg+ return ((fromIntegral g) :: Word16)++ +-- compute the gradient map+gradientArray :: Pixbuf -> Int -> Int -> IO (ArrayType Int Word16)+gradientArray pb w h = do+ width <- pixbufGetWidth pb+ height <- pixbufGetHeight pb+ row <- pixbufGetRowstride pb+ chan <- pixbufGetNChannels pb+ bits <- pixbufGetBitsPerSample pb+ pbData <- (pixbufGetPixels pb :: IO (PixbufData Int Word8))+ grdArr <- newArray (0, width * height) 0+ putStrLn ("bytes per row: "++show row++", channels per pixel: "++show chan++", bits per sample: "++show bits)+ putStrLn ("width: "++show width++", height: "++show height)++ let vPixIndex x y chan row = x*chan+y*row+ + doFromTo 0 (h-1) $ \y -> do+ let offY = y*width+ doFromTo 0 (w-1) $ \x -> do+ let off = x + offY+ --v <- (totalGradient x y)+ v <- (pixelGradient vPixIndex pbData row chan w h x y)+ unsafeWrite grdArr (off) v+ --putStrLn ("x: "++show x++" y: "++show y++" v: "++show v)+ return grdArr++computeVSeamArray :: (ArrayType Int Word16) -> Int -> Int -> Int -> IO (ArrayType Int Int)+computeVSeamArray grdArr width height currentWidth = do+ + seamArr <- newArray (0, width * height) 0+ --grdArr <- gradientArr+ + doFromTo 0 (currentWidth-1) $ \x -> do+ v <- unsafeRead grdArr x+ unsafeWrite seamArr x (fromIntegral v :: Int)+ + doFromTo 1 (height-1) $ \y -> do+ let offY = y*width+ let prevOffY = offY-width+ doFromTo 1 (currentWidth-2) $ \x -> do+ p1 <- unsafeRead seamArr ((x-1)+prevOffY)+ p2 <- unsafeRead seamArr (x+prevOffY)+ p3 <- unsafeRead seamArr ((x+1)+prevOffY)+ v <- unsafeRead grdArr (x+offY)+ unsafeWrite seamArr (x+offY) ((fromIntegral v :: Int) +(min(min p1 p2) p3))+ p2l <- unsafeRead seamArr (0+prevOffY)+ p3l <- unsafeRead seamArr (1+prevOffY)+ vl <- unsafeRead grdArr (0+offY)+ unsafeWrite seamArr (0+offY) ((fromIntegral vl)+(min p2l p3l))+ p1r <- unsafeRead seamArr (currentWidth-2+prevOffY)+ p2r <- unsafeRead seamArr (currentWidth-1+prevOffY)+ vr <- unsafeRead grdArr (currentWidth-1+offY)+ unsafeWrite seamArr (currentWidth-1+offY) ((fromIntegral vr :: Int) +(min p1r p2r))+ + return seamArr++computeHSeamArray :: (ArrayType Int Word16) -> Int -> Int -> Int -> IO (ArrayType Int Int)+computeHSeamArray grdArr width height currentHeight = do+ + seamArr <- newArray (0, width * height) 0+ --grdArr <- gradientArr+ + doFromTo 0 (currentHeight-1) $ \y -> do+ v <- unsafeRead grdArr (y*width)+ unsafeWrite seamArr (y*width) (fromIntegral v :: Int)+ + doFromTo 1 (width-1) $ \x -> do+ doFromTo 1 (currentHeight-2) $ \y -> do+ let offY = y*width+ let prevOffY = offY-width+ let nextOffY = offY+width+ p1 <- unsafeRead seamArr (x-1+prevOffY)+ p2 <- unsafeRead seamArr (x-1+offY)+ p3 <- unsafeRead seamArr (x-1+nextOffY)+ v <- unsafeRead grdArr (x+offY)+ unsafeWrite seamArr (x+offY) ((fromIntegral v :: Int) +(min(min p1 p2) p3))+ p2l <- unsafeRead seamArr (x-1+0)+ p3l <- unsafeRead seamArr (x-1+width)+ vl <- unsafeRead grdArr (x+0)+ unsafeWrite seamArr (x+0) ((fromIntegral vl)+(min p2l p3l))+ p1r <- unsafeRead seamArr (x-1+((currentHeight-2)*width))+ p2r <- unsafeRead seamArr (x-1+((currentHeight-1)*width))+ vr <- unsafeRead grdArr (x+((currentHeight-1)*width))+ unsafeWrite seamArr (x+((currentHeight-1)*width)) ((fromIntegral vr :: Int) +(min p1r p2r))+ + return seamArr
+ demo/scaling/Stones.jpg view
binary file changed (absent → 23258 bytes)
+ demo/scaling/scaling.glade view
@@ -0,0 +1,197 @@+<?xml version="1.0" encoding="UTF-8" standalone="no"?>+<!DOCTYPE glade-interface SYSTEM "glade-2.0.dtd">+<!--Generated with glade3 3.0.2 on Sun Dec 14 03:54:14 2008 by btronic@EVO8-->+<glade-interface>+ <widget class="GtkDialog" id="dialogScale">+ <property name="border_width">5</property>+ <property name="title" translatable="yes">Scale</property>+ <property name="resizable">False</property>+ <property name="modal">True</property>+ <property name="type_hint">GDK_WINDOW_TYPE_HINT_DIALOG</property>+ <property name="has_separator">False</property>+ <child internal-child="vbox">+ <widget class="GtkVBox" id="dialog-vbox2">+ <property name="visible">True</property>+ <property name="events">GDK_POINTER_MOTION_MASK | GDK_POINTER_MOTION_HINT_MASK | GDK_BUTTON_PRESS_MASK | GDK_BUTTON_RELEASE_MASK | GDK_ENTER_NOTIFY_MASK</property>+ <property name="spacing">2</property>+ <child>+ <placeholder/>+ </child>+ <child>+ <widget class="GtkHBox" id="hbox2">+ <property name="visible">True</property>+ <child>+ <widget class="GtkLabel" id="label1">+ <property name="visible">True</property>+ <property name="label" translatable="yes">Width:</property>+ </widget>+ </child>+ <child>+ <widget class="GtkEntry" id="entryScalingWidth">+ <property name="visible">True</property>+ </widget>+ <packing>+ <property name="position">1</property>+ </packing>+ </child>+ </widget>+ <packing>+ <property name="position">2</property>+ </packing>+ </child>+ <child>+ <widget class="GtkHBox" id="hbox3">+ <property name="visible">True</property>+ <child>+ <widget class="GtkLabel" id="label2">+ <property name="visible">True</property>+ <property name="label" translatable="yes">Height:</property>+ </widget>+ </child>+ <child>+ <widget class="GtkEntry" id="entryScalingHeight">+ <property name="visible">True</property>+ </widget>+ <packing>+ <property name="position">1</property>+ </packing>+ </child>+ </widget>+ <packing>+ <property name="position">3</property>+ </packing>+ </child>+ <child>+ <placeholder/>+ </child>+ <child>+ <placeholder/>+ </child>+ <child internal-child="action_area">+ <widget class="GtkHButtonBox" id="dialog-action_area2">+ <property name="visible">True</property>+ <property name="events">GDK_POINTER_MOTION_MASK | GDK_POINTER_MOTION_HINT_MASK | GDK_BUTTON_PRESS_MASK | GDK_BUTTON_RELEASE_MASK | GDK_ENTER_NOTIFY_MASK</property>+ <property name="layout_style">GTK_BUTTONBOX_END</property>+ <child>+ <placeholder/>+ </child>+ <child>+ <placeholder/>+ </child>+ </widget>+ <packing>+ <property name="expand">False</property>+ <property name="pack_type">GTK_PACK_END</property>+ </packing>+ </child>+ </widget>+ </child>+ </widget>+ <widget class="GtkDialog" id="dialogSeamCarve">+ <property name="border_width">5</property>+ <property name="title" translatable="yes">Seam Carve</property>+ <property name="resizable">False</property>+ <property name="modal">True</property>+ <property name="type_hint">GDK_WINDOW_TYPE_HINT_DIALOG</property>+ <property name="has_separator">False</property>+ <child internal-child="vbox">+ <widget class="GtkVBox" id="dialog-vbox3">+ <property name="visible">True</property>+ <property name="events">GDK_POINTER_MOTION_MASK | GDK_POINTER_MOTION_HINT_MASK | GDK_BUTTON_PRESS_MASK | GDK_BUTTON_RELEASE_MASK | GDK_ENTER_NOTIFY_MASK</property>+ <property name="spacing">2</property>+ <child>+ <widget class="GtkHBox" id="hbox5">+ <property name="visible">True</property>+ <child>+ <widget class="GtkLabel" id="label5">+ <property name="visible">True</property>+ <property name="label" translatable="yes">Gradient Count:</property>+ <property name="width_chars">16</property>+ </widget>+ </child>+ <child>+ <widget class="GtkEntry" id="entryGrdCnt">+ <property name="visible">True</property>+ </widget>+ <packing>+ <property name="position">1</property>+ </packing>+ </child>+ </widget>+ <packing>+ <property name="position">1</property>+ </packing>+ </child>+ <child>+ <widget class="GtkHBox" id="hbox1">+ <property name="visible">True</property>+ <child>+ <widget class="GtkLabel" id="label3">+ <property name="visible">True</property>+ <property name="label" translatable="yes">Width:</property>+ <property name="width_chars">16</property>+ </widget>+ </child>+ <child>+ <widget class="GtkEntry" id="entryWidth">+ <property name="visible">True</property>+ </widget>+ <packing>+ <property name="position">1</property>+ </packing>+ </child>+ </widget>+ <packing>+ <property name="position">2</property>+ </packing>+ </child>+ <child>+ <widget class="GtkHBox" id="hbox4">+ <property name="visible">True</property>+ <child>+ <widget class="GtkLabel" id="label4">+ <property name="visible">True</property>+ <property name="label" translatable="yes">Height:</property>+ <property name="width_chars">16</property>+ </widget>+ </child>+ <child>+ <widget class="GtkEntry" id="entryHeight">+ <property name="visible">True</property>+ </widget>+ <packing>+ <property name="position">1</property>+ </packing>+ </child>+ </widget>+ <packing>+ <property name="position">3</property>+ </packing>+ </child>+ <child>+ <placeholder/>+ </child>+ <child>+ <placeholder/>+ </child>+ <child internal-child="action_area">+ <widget class="GtkHButtonBox" id="dialog-action_area3">+ <property name="visible">True</property>+ <property name="events">GDK_POINTER_MOTION_MASK | GDK_POINTER_MOTION_HINT_MASK | GDK_BUTTON_PRESS_MASK | GDK_BUTTON_RELEASE_MASK | GDK_ENTER_NOTIFY_MASK</property>+ <property name="layout_style">GTK_BUTTONBOX_END</property>+ <child>+ <placeholder/>+ </child>+ <child>+ <placeholder/>+ </child>+ </widget>+ <packing>+ <property name="expand">False</property>+ <property name="pack_type">GTK_PACK_END</property>+ </packing>+ </child>+ </widget>+ </child>+ </widget>+</glade-interface>
glade.cabal view
@@ -1,6 +1,6 @@ Name: glade-Version: 0.11.0-License: GPL+Version: 0.11.1+License: LGPL-2.1 License-file: COPYING Copyright: (c) 2001-2010 The Gtk2Hs Team Author: Manuel M T Chakravarty@@ -17,17 +17,49 @@ Category: Graphics Tested-With: GHC == 6.12.1+Extra-Source-Files: Gtk2HsSetup.hs+ hierarchy.list -x-Types-File: Graphics/UI/Gtk/Glade/Types.chs-x-Types-ModName: Graphics.UI.Gtk.Glade.Types-x-Types-Forward: *Graphics.UI.GtkInternals+x-Types-File: Graphics/UI/Gtk/Glade/Types.chs+x-Types-ModName: Graphics.UI.Gtk.Glade.Types+x-Types-Forward: *Graphics.UI.GtkInternals x-Types-Destructor: objectUnrefFromMainloop-Extra-Source-Files: Gtk2HsSetup.hs+x-Types-Hierarchy: hierarchy.list +Data-Dir: demo+Data-Files: calc/calc.glade+ calc/Calc.hs+ calc/CalcModel.hs+ calc/Makefile+ + glade/GladeTest.hs+ glade/Makefile+ glade/simple.glade+ + noughty/Cross.png+ noughty/License+ noughty/Makefile+ noughty/Nought.png+ noughty/noughty.glade+ noughty/NoughtyGlade.hs+ noughty/Noughty.hs+ + profileviewer/Makefile+ profileviewer/ParseProfile.hs+ profileviewer/ProfileViewer.glade+ profileviewer/ProfileViewer.gladep+ profileviewer/ProfileViewer.hs+ + scaling/London_Eye.jpg+ scaling/Makefile+ scaling/Mountains.jpg+ scaling/scaling.glade+ scaling/Scaling.hs+ scaling/Stones.jpg+ Source-Repository head type: darcs- location: http://code.haskell.org/gtk2hs/- subdir: glade+ location: http://code.haskell.org/glade/ Library build-depends: base >= 4 && < 5, array, containers, haskell98, mtl,
+ hierarchy.list view
@@ -0,0 +1,341 @@+# This list is the result of a copy-and-paste from the GtkObject hierarchy+# html documentation. Deprecated widgets are uncommented. Some additional+# object have been defined at the end of the copied list.++# The Gtk prefix of every object is removed, the other prefixes are+# kept. The indentation implies the object hierarchy. In case the+# type query function cannot be derived from the name or the type name+# is different, an alternative name and type query function can be+# specified by appending 'as typename, <query_func>'. In case this+# function is not specified, the <name> is converted to+# gtk_<name'>_get_type where <name'> is <name> where each upperscore+# letter is converted to an underscore and lowerletter. The underscore+# is omitted if an upperscore letter preceeded: GtkHButtonBox ->+# gtk_hbutton_box_get_type. The generation of a type can be+# conditional by appending 'if <tag>'. Such types are only produces if+# --tag=<tag> is given on the command line of TypeGenerator.+++ GObject + GdkDrawable + GdkWindow as DrawWindow, gdk_window_object_get_type+# GdkDrawableImplX11+# GdkWindowImplX11+ GdkPixmap+ GdkGLPixmap if gtkglext+ GdkGLWindow if gtkglext+ GdkColormap+ GdkScreen if gtk-2.2+ GdkDisplay if gtk-2.2+ GdkVisual+ GdkDevice+ GtkSettings+ GtkTextBuffer+ GtkSourceBuffer if sourceview+ GtkSourceBuffer if gtksourceview2+ GtkTextTag+ GtkSourceTag if sourceview+ GtkTextTagTable+ GtkSourceTagTable if sourceview+ GtkStyle+ GtkRcStyle+ GdkDragContext+ GdkPixbuf+ GdkPixbufAnimation+ GdkPixbufSimpleAnim+ GdkPixbufAnimationIter+ GtkTextChildAnchor+ GtkTextMark+ GtkSourceMarker if sourceview+ GtkSourceMark if gtksourceview2+ GtkObject+ GtkWidget+ GtkMisc+ GtkLabel+ GtkAccelLabel+ GtkTipsQuery if deprecated+ GtkArrow+ GtkImage+ GtkContainer+ WebKitWebView as WebView, webkit_web_view_get_type if webkit + GtkBin+ GtkAlignment+ GtkFrame+ GtkAspectFrame+ GtkButton+ GtkToggleButton+ GtkCheckButton+ GtkRadioButton+ GtkColorButton if gtk-2.4+ GtkFontButton if gtk-2.4+ GtkOptionMenu if deprecated+ GtkItem+ GtkMenuItem+ GtkCheckMenuItem+ GtkRadioMenuItem+ GtkTearoffMenuItem+ GtkImageMenuItem+ GtkSeparatorMenuItem+ GtkListItem if deprecated+# GtkTreeItem+ GtkWindow+ GtkDialog+ GtkAboutDialog if gtk-2.6+ GtkColorSelectionDialog+ GtkFileSelection+ GtkFileChooserDialog if gtk-2.4+ GtkFontSelectionDialog+ GtkInputDialog+ GtkMessageDialog+ GtkPlug if plugNsocket+ GtkEventBox+ GtkHandleBox+ GtkScrolledWindow+ GtkViewport+ GtkExpander if gtk-2.4+ GtkComboBox if gtk-2.4+ GtkComboBoxEntry if gtk-2.4+ GtkToolItem if gtk-2.4+ GtkToolButton if gtk-2.4+ GtkMenuToolButton if gtk-2.6+ GtkToggleToolButton if gtk-2.4+ GtkRadioToolButton if gtk-2.4+ GtkSeparatorToolItem if gtk-2.4+ GtkMozEmbed if mozembed+ VteTerminal as Terminal if vte+ GtkBox+ GtkButtonBox+ GtkHButtonBox+ GtkVButtonBox+ GtkVBox+ GtkColorSelection+ GtkFontSelection+ GtkFileChooserWidget if gtk-2.4+ GtkHBox+ GtkCombo if deprecated+ GtkFileChooserButton if gtk-2.6+ GtkStatusbar+ GtkCList if deprecated+ GtkCTree if deprecated+ GtkFixed+ GtkPaned+ GtkHPaned+ GtkVPaned+ GtkIconView if gtk-2.6+ GtkLayout+ GtkList if deprecated+ GtkMenuShell+ GtkMenu+ GtkMenuBar+ GtkNotebook+# GtkPacker+ GtkSocket if plugNsocket+ GtkTable+ GtkTextView+ GtkSourceView if sourceview+ GtkSourceView if gtksourceview2+ GtkToolbar+ GtkTreeView+ GtkCalendar+ GtkCellView if gtk-2.6+ GtkDrawingArea+ GtkEntry+ GtkSpinButton+ GtkRuler+ GtkHRuler+ GtkVRuler+ GtkRange+ GtkScale+ GtkHScale+ GtkVScale+ GtkScrollbar+ GtkHScrollbar+ GtkVScrollbar+ GtkSeparator+ GtkHSeparator+ GtkVSeparator+ GtkInvisible+# GtkOldEditable+# GtkText+ GtkPreview if deprecated+# Progress is deprecated, ProgressBar contains everything necessary+# GtkProgress+ GtkProgressBar+ GtkAdjustment+ GtkIMContext+ GtkIMMulticontext+ GtkItemFactory if deprecated+ GtkTooltips+ +# These object were added by hand because they do not show up in the hierarchy+# chart.+# These are derived from GtkObject:+ GtkTreeViewColumn+ GtkCellRenderer+ GtkCellRendererPixbuf+ GtkCellRendererText+ GtkCellRendererCombo if gtk-2.6+ GtkCellRendererToggle+ GtkCellRendererProgress if gtk-2.6+ GtkFileFilter if gtk-2.4+ GtkBuilder if gtk-2.12+# These are actually interfaces, but all objects that implement it are at+# least GObjects.+ GtkCellLayout if gtk-2.4+ GtkTreeSortable if gtk-2.4+ GtkTooltip if gtk-2.12+# These are derived from GObject:+ GtkStatusIcon if gtk-2.10+ GtkTreeSelection+ GtkTreeModel+ GtkTreeStore+ GtkListStore+ GtkTreeModelSort+ GtkTreeModelFilter if gtk-2.4+ GtkIconFactory+ GtkIconTheme+ GtkSizeGroup+ GtkClipboard if gtk-2.2+ GtkAccelGroup+ GtkAccelMap if gtk-2.4+ GtkEntryCompletion if gtk-2.4+ GtkAction if gtk-2.4+ GtkToggleAction if gtk-2.4+ GtkRadioAction if gtk-2.4+ GtkActionGroup if gtk-2.4+ GtkUIManager if gtk-2.4+ GtkWindowGroup+ GtkSourceLanguage if sourceview+ GtkSourceLanguage if gtksourceview2+ GtkSourceLanguagesManager if sourceview+ GtkSourceLanguageManager if gtksourceview2+ GladeXML as GladeXML, glade_xml_get_type if libglade+ GConfClient as GConf if gconf+# These ones are actualy interfaces, but interface implementations are GObjects+ GtkEditable+ GtkSourceStyle as SourceStyleObject if gtksourceview2+ GtkSourceStyleScheme if sourceview+ GtkSourceStyleScheme if gtksourceview2+ GtkSourceStyleSchemeManager if gtksourceview2+ GtkFileChooser if gtk-2.4+## This now became a GObject in version 2:+ GdkGC as GC, gdk_gc_get_type+## These are Pango structures+ PangoContext as PangoContext, pango_context_get_type if pango+ PangoLayout as PangoLayoutRaw, pango_layout_get_type if pango+ PangoFont as Font, pango_font_get_type if pango+ PangoFontFamily as FontFamily, pango_font_family_get_type if pango+ PangoFontFace as FontFace, pango_font_face_get_type if pango+ PangoFontMap as FontMap, pango_font_face_get_type if pango+ PangoFontset as FontSet, pango_fontset_get_type if pango+## This type is only available for PANGO_ENABLE_BACKEND compiled source+## PangoFontsetSimple as FontSetSimple, pango_fontset_simple_get_type++## GtkGlExt classes+ GdkGLContext if gtkglext+ GdkGLConfig if gtkglext+ GdkGLDrawable if gtkglext++## GnomeVFS classes+ GnomeVFSVolume as Volume, gnome_vfs_volume_get_type if gnomevfs+ GnomeVFSDrive as Drive, gnome_vfs_drive_get_type if gnomevfs+ GnomeVFSVolumeMonitor as VolumeMonitor, gnome_vfs_volume_monitor_get_type if gnomevfs++## GIO classes+# Note on all the "as" clauses: the prefix G is unfortunate since it leads+# to two consecutive upper case letters which are not translated with an+# underscore each (e.g. GConf -> gconf, GtkHButtonBox -> gtk_hbutton_box).+# GUnixMountMonitor as UnixMountMonitor, g_unix_mount_monitor_get_type if gio+ GOutputStream as OutputStream, g_output_stream_get_type if gio+ GFilterOutputStream as FilterOutputStream, g_filter_output_stream_get_type if gio+ GDataOutputStream as DataOutputStream, g_data_output_stream_get_type if gio+ GBufferedOutputStream as BufferedOutputStream, g_buffered_output_stream_get_type if gio+# GUnixOutputStream as UnixOutputStream, g_unix_output_stream_get_type if gio+ GFileOutputStream as FileOutputStream, g_file_output_stream_get_type if gio+ GMemoryOutputStream as MemoryOutputStream, g_memory_output_stream_get_type if gio+ GInputStream as InputStream, g_input_stream_get_type if gio+# GUnixInputStream as UnixInputStream, g_unix_input_stream_get_type if gio+ GMemoryInputStream as MemoryInputStream, g_memory_input_stream_get_type if gio+ GFilterInputStream as FilterInputStream, g_filter_input_stream_get_type if gio+ GBufferedInputStream as BufferedInputStream, g_buffered_input_stream_get_type if gio+ GDataInputStream as DataInputStream, g_data_input_stream_get_type if gio+ GFileInputStream as FileInputStream, g_file_input_stream_get_type if gio+# GDesktopAppInfo as DesktopAppInfo, g_desktop_app_info_get_type if gio+ GFileMonitor as FileMonitor, g_file_monitor_get_type if gio+ GVfs as Vfs, g_vfs_get_type if gio+ GMountOperation as MountOperation, g_mount_operation_get_type if gio+ GThemedIcon as ThemedIcon, g_themed_icon_get_type if gio+ GEmblem as Emblem, g_emblem_get_type if gio+ GEmblemedIcon as EmblemedIcon, g_emblemed_icon_get_type if gio+ GFileEnumerator as FileEnumerator, g_file_enumerator_get_type if gio+ GFilenameCompleter as FilenameCompleter, g_filename_completer_get_type if gio+ GFileIcon as FileIcon, g_file_icon_get_type if gio+ GVolumeMonitor as VolumeMonitor, g_volume_monitor_get_type if gio+ GCancellable as Cancellable, g_cancellable_get_type if gio+ GSimpleAsyncResult as SimpleAsyncResult, g_async_result_get_type if gio+ GFileInfo as FileInfo, g_file_info_get_type if gio+ GAppLaunchContext as AppLaunchContext, g_app_launch_context_get_type if gio+## these are actually GInterfaces+ GIcon as Icon, g_icon_get_type if gio+ GSeekable as Seekable, g_seekable_get_type if gio+ GAppInfo as AppInfo, g_app_info_get_type if gio+ GVolume as Volume, g_volume_get_type if gio+ GAsyncResult as AsyncResult, g_async_result_get_type if gio+ GLoadableIcon as LoadableIcon, g_loadable_icon_get_type if gio+ GDrive as Drive, g_drive_get_type if gio+ GFile noEq as File, g_file_get_type if gio+ GMount as Mount, g_mount_get_type if gio++## GStreamer classes+ GstObject as Object, gst_object_get_type if gstreamer+ GstPad as Pad, gst_pad_get_type if gstreamer+ GstGhostPad as GhostPad, gst_ghost_pad_get_type if gstreamer+ GstPluginFeature as PluginFeature, gst_plugin_feature_get_type if gstreamer+ GstElementFactory as ElementFactory, gst_element_factory_get_type if gstreamer+ GstTypeFindFactory as TypeFindFactory, gst_type_find_factory_get_type if gstreamer+ GstIndexFactory as IndexFactory, gst_index_factory_get_type if gstreamer+ GstElement as Element, gst_element_get_type if gstreamer+ GstBin as Bin, gst_bin_get_type if gstreamer+ GstPipeline as Pipeline, gst_pipeline_get_type if gstreamer+ GstImplementsInterface as ImplementsInterface, gst_implements_interface_get_type if gstreamer+ GstTagSetter as TagSetter, gst_tag_setter_get_type if gstreamer+ GstBaseSrc as BaseSrc, gst_base_src_get_type if gstreamer+ GstPushSrc as PushSrc, gst_push_src_get_type if gstreamer+ GstBaseSink as BaseSink, gst_base_sink_get_type if gstreamer+ GstBaseTransform as BaseTransform, gst_base_transform_get_type if gstreamer+ GstPlugin as Plugin, gst_plugin_get_type if gstreamer+ GstRegistry as Registry, gst_registry_get_type if gstreamer+ GstBus as Bus, gst_bus_get_type if gstreamer+ GstClock as Clock, gst_clock_get_type if gstreamer+ GstAudioClock as AudioClock, gst_audio_clock_get_type if gstreamer+ GstSystemClock as SystemClock, gst_system_clock_get_type if gstreamer+ GstNetClientClock as NetClientClock, gst_net_client_clock_get_type if gstreamer+ GstIndex as Index, gst_index_get_type if gstreamer+ GstPadTemplate as PadTemplate, gst_pad_template_get_type if gstreamer+ GstTask as Task, gst_task_get_type if gstreamer+ GstXML as XML, gst_xml_get_type if gstreamer+ GstChildProxy as ChildProxy, gst_child_proxy_get_type if gstreamer+ GstCollectPads as CollectPads, gst_collect_pads_get_type if gstreamer+## these are actually GInterfaces+ GstURIHandler as URIHandler, gst_uri_handler_get_type if gstreamer+ GstAdapter as Adapter, gst_adapter_get_type if gstreamer+ GstController as Controller, gst_controller_get_type if gstreamer++ WebKitWebFrame as WebFrame, webkit_web_frame_get_type if webkit + WebKitWebSettings as WebSettings, webkit_web_settings_get_type if webkit+ WebKitNetworkRequest as NetworkRequest, webkit_network_request_get_type if webkit+ WebKitNetworkResponse as NetworkResponse, webkit_network_response_get_type if webkit+ WebKitDownload as Download, webkit_download_get_type if webkit+ WebKitWebBackForwardList as WebBackForwardList, webkit_web_back_forward_list_get_type if webkit+ WebKitWebHistoryItem as WebHistoryItem, webkit_web_history_item_get_type if webkit+ WebKitWebInspector as WebInspector, webkit_web_inspector_get_type if webkit+ WebKitHitTestResult as HitTestResult, webkit_hit_test_result_get_type if webkit+ WebKitSecurityOrigin as SecurityOrigin, webkit_security_origin_get_type if webkit+ WebKitSoupAuthDialog as SoupAuthDialog, webkit_soup_auth_dialog_get_type if webkit+ WebKitWebDatabase as WebDatabase, webkit_web_database_get_type if webkit+ WebKitWebDataSource as WebDataSource, webkit_web_data_source_get_type if webkit+ WebKitWebNavigationAction as WebNavigationAction, webkit_web_navigation_action_get_type if webkit+ WebKitWebPolicyDecision as WebPolicyDecision, webkit_web_policy_decision_get_type if webkit+ WebKitWebResource as WebResource, webkit_web_resource_get_type if webkit+ WebKitWebWindowFeatures as WebWindowFeatures, webkit_web_window_features_get_type if webkit+