[Gtk2hs-commit] gtk2hs/demo/calc Calc.hs,NONE,1.1 CalcModel.hs,NONE,1.1 Makefile,NONE,1.1 calc.glade

SourceForge Headquarters 225 Broadway Suite 1600 San Diego, CA 92101 +1 (858) 422-6466

Update of /cvsroot/gtk2hs/gtk2hs/demo/calc
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv5080/demo/calc

Added Files:
	Calc.hs CalcModel.hs Makefile calc.glade 
Log Message:
Add a simple calculator demo.

--- NEW FILE: calc.glade ---
<?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">&lt;big&gt;0&lt;/big&gt;</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>

--- NEW FILE: CalcModel.hs ---
-- 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 num == [] then "0" else num)
  . reverse
  . dropWhile (\c -> c=='0' || c=='.') --strip trailing 0's
  . reverse 
  . (\num -> showGFloat precision num "")

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'

--- NEW FILE: Makefile ---

PROG  = calc
SOURCES = Calc.hs CalcModel.hs
PACKAGES = glade

$(PROG) : $(SOURCES)
	ghc --make $< -o $@ $(HCFLAGS) $(HCEXTRAFLAGS)

HCEXTRAFLAGS = $(if $(HCNEEDSPACKAGE), $(addprefix -package ,$(PACKAGES)))

clean:
	rm -f $(SOURCES:.hs=.hi) $(SOURCES:.hs=.o) $(PROG)

--- NEW FILE: Calc.hs ---
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

[Gtk2hs-commit] gtk2hs/demo/calc Calc.hs,NONE,1.1 CalcModel.hs,NONE,1.1 Makefile,NONE,1.1 calc.glade

[Gtk2hs-commit] gtk2hs/demo/calc Calc.hs,NONE,1.1 CalcModel.hs,NONE,1.1 Makefile,NONE,1.1 calc.glade,NONE,1.1