diff --git a/Gtk2HsSetup.hs b/Gtk2HsSetup.hs --- a/Gtk2HsSetup.hs +++ b/Gtk2HsSetup.hs @@ -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 diff --git a/demo/calc/Calc.hs b/demo/calc/Calc.hs new file mode 100644 --- /dev/null +++ b/demo/calc/Calc.hs @@ -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` ("" ++ result ++ "") + 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 diff --git a/demo/calc/CalcModel.hs b/demo/calc/CalcModel.hs new file mode 100644 --- /dev/null +++ b/demo/calc/CalcModel.hs @@ -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' diff --git a/demo/calc/Makefile b/demo/calc/Makefile new file mode 100644 --- /dev/null +++ b/demo/calc/Makefile @@ -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 diff --git a/demo/calc/calc.glade b/demo/calc/calc.glade new file mode 100644 --- /dev/null +++ b/demo/calc/calc.glade @@ -0,0 +1,374 @@ + + + + + + + 4 + True + Calculator + GTK_WINDOW_TOPLEVEL + GTK_WIN_POS_CENTER + False + True + False + + + + True + False + 4 + + + + True + <big>0</big> + False + True + GTK_JUSTIFY_RIGHT + False + False + 1 + 0.5 + 0 + 0 + + + 0 + False + False + + + + + + True + 5 + 4 + True + 4 + 4 + + + + True + True + . + True + GTK_RELIEF_NORMAL + + + + + 2 + 3 + 4 + 5 + + + + + + True + True + 0 + True + GTK_RELIEF_NORMAL + + + + + 0 + 2 + 4 + 5 + + + + + + True + True + 1 + True + GTK_RELIEF_NORMAL + + + + + 0 + 1 + 3 + 4 + + + + + + True + True + 2 + True + GTK_RELIEF_NORMAL + + + + + 1 + 2 + 3 + 4 + + + + + + True + True + 4 + True + GTK_RELIEF_NORMAL + + + + + 0 + 1 + 2 + 3 + + + + + + True + True + 5 + True + GTK_RELIEF_NORMAL + + + + + 1 + 2 + 2 + 3 + + + + + + True + True + 7 + True + GTK_RELIEF_NORMAL + + + + + 0 + 1 + 1 + 2 + + + + + + True + True + 8 + True + GTK_RELIEF_NORMAL + + + + + 1 + 2 + 1 + 2 + + + + + + True + True + 3 + True + GTK_RELIEF_NORMAL + + + + + 2 + 3 + 3 + 4 + + + + + + True + True + 6 + True + GTK_RELIEF_NORMAL + + + + + 2 + 3 + 2 + 3 + + + + + + True + True + 9 + True + GTK_RELIEF_NORMAL + + + + + 2 + 3 + 1 + 2 + + + + + + True + True + ÷ + True + GTK_RELIEF_NORMAL + + + + + 1 + 2 + 0 + 1 + + + + + + True + True + × + True + GTK_RELIEF_NORMAL + + + + + 2 + 3 + 0 + 1 + + + + + + True + True + - + True + GTK_RELIEF_NORMAL + + + + + 3 + 4 + 0 + 1 + + + + + + True + True + + + True + GTK_RELIEF_NORMAL + + + + + 3 + 4 + 1 + 3 + + + + + + True + True + = + True + GTK_RELIEF_NORMAL + + + + + + + 3 + 4 + 3 + 5 + + + + + + 45 + 40 + True + True + AC + True + GTK_RELIEF_NORMAL + + + + + 0 + 1 + 0 + 1 + fill + + + + + + 0 + True + True + + + + + + + diff --git a/demo/glade/GladeTest.hs b/demo/glade/GladeTest.hs new file mode 100644 --- /dev/null +++ b/demo/glade/GladeTest.hs @@ -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 diff --git a/demo/glade/Makefile b/demo/glade/Makefile new file mode 100644 --- /dev/null +++ b/demo/glade/Makefile @@ -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 diff --git a/demo/glade/simple.glade b/demo/glade/simple.glade new file mode 100644 --- /dev/null +++ b/demo/glade/simple.glade @@ -0,0 +1,115 @@ + + + + + + + True + window1 + GTK_WINDOW_TOPLEVEL + GTK_WIN_POS_NONE + False + True + False + + + + 6 + True + False + 0 + + + + True + A simple dialog created in Glade + False + False + GTK_JUSTIFY_LEFT + False + False + 0.5 + 0.5 + 0 + 0 + + + 0 + True + True + + + + + + True + True + GTK_RELIEF_NORMAL + + + + True + 0.5 + 0.5 + 0 + 0 + + + + True + False + 2 + + + + True + gtk-apply + 4 + 0.5 + 0.5 + 0 + 0 + + + 0 + False + False + + + + + + True + Press me! + True + False + GTK_JUSTIFY_LEFT + False + False + 0.5 + 0.5 + 0 + 0 + + + 0 + False + False + + + + + + + + + 0 + True + True + + + + + + + diff --git a/demo/noughty/Cross.png b/demo/noughty/Cross.png new file mode 100644 Binary files /dev/null and b/demo/noughty/Cross.png differ diff --git a/demo/noughty/License b/demo/noughty/License new file mode 100644 --- /dev/null +++ b/demo/noughty/License @@ -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. diff --git a/demo/noughty/Makefile b/demo/noughty/Makefile new file mode 100644 --- /dev/null +++ b/demo/noughty/Makefile @@ -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 diff --git a/demo/noughty/Nought.png b/demo/noughty/Nought.png new file mode 100644 Binary files /dev/null and b/demo/noughty/Nought.png differ diff --git a/demo/noughty/Noughty.hs b/demo/noughty/Noughty.hs new file mode 100644 --- /dev/null +++ b/demo/noughty/Noughty.hs @@ -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 diff --git a/demo/noughty/NoughtyGlade.hs b/demo/noughty/NoughtyGlade.hs new file mode 100644 --- /dev/null +++ b/demo/noughty/NoughtyGlade.hs @@ -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 () + } diff --git a/demo/noughty/noughty.glade b/demo/noughty/noughty.glade new file mode 100644 --- /dev/null +++ b/demo/noughty/noughty.glade @@ -0,0 +1,398 @@ + + + + + + + Noughty + GTK_WINDOW_TOPLEVEL + GTK_WIN_POS_NONE + False + False + False + True + False + False + GDK_WINDOW_TYPE_HINT_NORMAL + GDK_GRAVITY_NORTH_WEST + True + False + + + + True + False + 0 + + + + True + GTK_PACK_DIRECTION_LTR + GTK_PACK_DIRECTION_LTR + + + + True + _Game + True + + + + + + + True + _New Game + True + + + + + + + True + + + + + + True + _Quit + True + + + + + + + + + 0 + False + False + + + + + + 10 + True + 5 + 5 + False + 0 + 0 + + + + True + + + 0 + 5 + 1 + 2 + fill + fill + + + + + + True + + + 1 + 2 + 0 + 5 + fill + fill + + + + + + True + + + 3 + 4 + 0 + 5 + fill + fill + + + + + + 100 + 100 + True + GTK_RELIEF_NONE + False + + + + True + 0.5 + 0.5 + 0 + 0 + + + + + 0 + 1 + 0 + 1 + + + + + + 100 + 100 + True + GTK_RELIEF_NONE + False + + + + True + 0.5 + 0.5 + 0 + 0 + + + + + 2 + 3 + 0 + 1 + + + + + + 100 + 100 + True + GTK_RELIEF_NONE + False + + + + True + 0.5 + 0.5 + 0 + 0 + + + + + 4 + 5 + 0 + 1 + + + + + + 100 + 100 + True + GTK_RELIEF_NONE + False + + + + True + 0.5 + 0.5 + 0 + 0 + + + + + 0 + 1 + 2 + 3 + + + + + + 100 + 100 + True + GTK_RELIEF_NONE + False + + + + True + 0.5 + 0.5 + 0 + 0 + + + + + 2 + 3 + 2 + 3 + + + + + + 100 + 100 + True + GTK_RELIEF_NONE + False + + + + True + 0.5 + 0.5 + 0 + 0 + + + + + 4 + 5 + 2 + 3 + + + + + + 100 + 100 + True + GTK_RELIEF_NONE + False + + + + True + 0.5 + 0.5 + 0 + 0 + + + + + 0 + 1 + 4 + 5 + + + + + + 100 + 100 + True + GTK_RELIEF_NONE + False + + + + True + 0.5 + 0.5 + 0 + 0 + + + + + 2 + 3 + 4 + 5 + + + + + + 100 + 100 + True + GTK_RELIEF_NONE + False + + + + True + 0.5 + 0.5 + 0 + 0 + + + + + 4 + 5 + 4 + 5 + + + + + + True + + + 0 + 5 + 3 + 4 + fill + fill + + + + + 0 + True + True + + + + + + True + False + + + 0 + False + False + + + + + + + diff --git a/demo/profileviewer/Makefile b/demo/profileviewer/Makefile new file mode 100644 --- /dev/null +++ b/demo/profileviewer/Makefile @@ -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 diff --git a/demo/profileviewer/ParseProfile.hs b/demo/profileviewer/ParseProfile.hs new file mode 100644 --- /dev/null +++ b/demo/profileviewer/ParseProfile.hs @@ -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" diff --git a/demo/profileviewer/ProfileViewer.glade b/demo/profileviewer/ProfileViewer.glade new file mode 100644 --- /dev/null +++ b/demo/profileviewer/ProfileViewer.glade @@ -0,0 +1,426 @@ + + + + + + + True + GHC timing profile viewer + GTK_WINDOW_TOPLEVEL + GTK_WIN_POS_NONE + False + 650 + 400 + True + False + + + + True + False + 0 + + + + True + + + + True + _File + True + + + + + + + True + gtk-open + True + + + + + + True + + + + + + True + gtk-quit + True + + + + + + + + + + True + _View + True + + + + + + + True + All entries + True + True + + + + + + True + Only entries with 0.1% or more + True + False + allEntries + + + + + + True + Only entries with 0.5% or more + True + False + allEntries + + + + + + True + Only entries with 1% or more + True + False + allEntries + + + + + + True + Only entries with 5% or more + True + False + allEntries + + + + + + True + Only entries with 10% or more + True + False + allEntries + + + + + + True + Only entries with 50% or more + True + False + allEntries + + + + + + + + + + True + _Help + True + + + + + + + True + _About + True + + + + + + + + + 0 + False + False + + + + + + 5 + True + 4 + 2 + False + 2 + 10 + + + + True + <b>Total time</b> + False + True + GTK_JUSTIFY_RIGHT + False + False + 1 + 0.5 + 0 + 0 + + + 0 + 1 + 2 + 3 + fill + + + + + + + True + <b>Total alloc</b> + False + True + GTK_JUSTIFY_LEFT + False + False + 1 + 0.5 + 0 + 0 + + + 0 + 1 + 3 + 4 + fill + + + + + + + True + True + + False + False + GTK_JUSTIFY_LEFT + False + True + 0 + 0.5 + 0 + 0 + + + 1 + 2 + 0 + 1 + expand|shrink|fill + + + + + + + True + True + + False + False + GTK_JUSTIFY_LEFT + False + True + 0 + 0.5 + 0 + 0 + + + 1 + 2 + 2 + 3 + fill + + + + + + + True + True + + False + False + GTK_JUSTIFY_LEFT + False + True + 0 + 0.5 + 0 + 0 + + + 1 + 2 + 3 + 4 + fill + + + + + + + True + <b>Report</b> + False + True + GTK_JUSTIFY_RIGHT + False + False + 1 + 0.5 + 0 + 0 + + + 0 + 1 + 0 + 1 + fill + + + + + + + True + <b>Command</b> + False + True + GTK_JUSTIFY_RIGHT + False + False + 1 + 0.5 + 0 + 0 + + + 0 + 1 + 1 + 2 + fill + + + + + + + True + + False + False + GTK_JUSTIFY_LEFT + True + False + 0 + 0 + 0 + 0 + + + 1 + 2 + 1 + 2 + fill + + + + + + 0 + False + False + + + + + + True + True + GTK_POLICY_AUTOMATIC + GTK_POLICY_AUTOMATIC + GTK_SHADOW_NONE + GTK_CORNER_TOP_LEFT + + + + True + True + True + True + False + True + + + + + 0 + True + True + + + + + + True + True + + + 0 + False + False + + + + + + + diff --git a/demo/profileviewer/ProfileViewer.gladep b/demo/profileviewer/ProfileViewer.gladep new file mode 100644 --- /dev/null +++ b/demo/profileviewer/ProfileViewer.gladep @@ -0,0 +1,8 @@ + + + + + ProfileViewer + profileviewer + FALSE + diff --git a/demo/profileviewer/ProfileViewer.hs b/demo/profileviewer/ProfileViewer.hs new file mode 100644 --- /dev/null +++ b/demo/profileviewer/ProfileViewer.hs @@ -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 diff --git a/demo/scaling/London_Eye.jpg b/demo/scaling/London_Eye.jpg new file mode 100644 Binary files /dev/null and b/demo/scaling/London_Eye.jpg differ diff --git a/demo/scaling/Makefile b/demo/scaling/Makefile new file mode 100644 --- /dev/null +++ b/demo/scaling/Makefile @@ -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 diff --git a/demo/scaling/Mountains.jpg b/demo/scaling/Mountains.jpg new file mode 100644 Binary files /dev/null and b/demo/scaling/Mountains.jpg differ diff --git a/demo/scaling/Scaling.hs b/demo/scaling/Scaling.hs new file mode 100644 --- /dev/null +++ b/demo/scaling/Scaling.hs @@ -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 " + +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 diff --git a/demo/scaling/Stones.jpg b/demo/scaling/Stones.jpg new file mode 100644 Binary files /dev/null and b/demo/scaling/Stones.jpg differ diff --git a/demo/scaling/scaling.glade b/demo/scaling/scaling.glade new file mode 100644 --- /dev/null +++ b/demo/scaling/scaling.glade @@ -0,0 +1,197 @@ + + + + + + 5 + Scale + False + True + GDK_WINDOW_TYPE_HINT_DIALOG + False + + + True + GDK_POINTER_MOTION_MASK | GDK_POINTER_MOTION_HINT_MASK | GDK_BUTTON_PRESS_MASK | GDK_BUTTON_RELEASE_MASK | GDK_ENTER_NOTIFY_MASK + 2 + + + + + + True + + + True + Width: + + + + + True + + + 1 + + + + + 2 + + + + + True + + + True + Height: + + + + + True + + + 1 + + + + + 3 + + + + + + + + + + + True + GDK_POINTER_MOTION_MASK | GDK_POINTER_MOTION_HINT_MASK | GDK_BUTTON_PRESS_MASK | GDK_BUTTON_RELEASE_MASK | GDK_ENTER_NOTIFY_MASK + GTK_BUTTONBOX_END + + + + + + + + + False + GTK_PACK_END + + + + + + + 5 + Seam Carve + False + True + GDK_WINDOW_TYPE_HINT_DIALOG + False + + + True + GDK_POINTER_MOTION_MASK | GDK_POINTER_MOTION_HINT_MASK | GDK_BUTTON_PRESS_MASK | GDK_BUTTON_RELEASE_MASK | GDK_ENTER_NOTIFY_MASK + 2 + + + True + + + True + Gradient Count: + 16 + + + + + True + + + 1 + + + + + 1 + + + + + True + + + True + Width: + 16 + + + + + True + + + 1 + + + + + 2 + + + + + True + + + True + Height: + 16 + + + + + True + + + 1 + + + + + 3 + + + + + + + + + + + True + GDK_POINTER_MOTION_MASK | GDK_POINTER_MOTION_HINT_MASK | GDK_BUTTON_PRESS_MASK | GDK_BUTTON_RELEASE_MASK | GDK_ENTER_NOTIFY_MASK + GTK_BUTTONBOX_END + + + + + + + + + False + GTK_PACK_END + + + + + + diff --git a/glade.cabal b/glade.cabal --- a/glade.cabal +++ b/glade.cabal @@ -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, diff --git a/hierarchy.list b/hierarchy.list new file mode 100644 --- /dev/null +++ b/hierarchy.list @@ -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, '. In case this +# function is not specified, the is converted to +# gtk__get_type where is 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 '. Such types are only produces if +# --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 +