diff --git a/COPYING b/COPYING new file mode 100644 --- /dev/null +++ b/COPYING @@ -0,0 +1,25 @@ +Copyright (c) 2009 Conal Elliott +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. +2. 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. +3. The names of the authors may not be used to endorse or promote products + derived from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``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 AUTHORS 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/GtkTV.cabal b/GtkTV.cabal new file mode 100644 --- /dev/null +++ b/GtkTV.cabal @@ -0,0 +1,32 @@ +Name: GtkTV +Version: 0.0.0 +Cabal-Version: >= 1.2 +Synopsis: +Category: Gtk-based GUIs for Tangible Values +Description: + GtkTV is a very small library that extends the TV (tangible value) + framework with graphical user interfaces, using gtk2hs. + . + © 2007 by Conal Elliott; BSD3 license. +Author: Conal Elliott +Maintainer: conal@conal.net +Homepage: http://haskell.org/haskellwiki/GtkTV +Package-Url: http://code.haskell.org/~conal/code/GtkTV +Copyright: (c) 2009 by Conal Elliott +License: BSD3 +License-File: COPYING +Stability: experimental +build-type: Simple + +extra-source-files: + examples/test + +Library + hs-Source-Dirs: src + Extensions: + Build-Depends: base<5, time, gtk, TypeCompose>=0.6.5, TV + Exposed-Modules: + Interface.TV.Gtk + ghc-options: -Wall + +-- ghc-prof-options: -prof -auto-all diff --git a/Makefile b/Makefile new file mode 100644 --- /dev/null +++ b/Makefile @@ -0,0 +1,1 @@ +include ../cho-home-cabal-make.inc diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,3 @@ +#!/usr/bin/env runhaskell +> import Distribution.Simple +> main = defaultMain diff --git a/examples/test.hs b/examples/test.hs new file mode 100644 --- /dev/null +++ b/examples/test.hs @@ -0,0 +1,78 @@ +-- {-# LANGUAGE #-} +{-# OPTIONS_GHC -Wall #-} +---------------------------------------------------------------------- +-- | +-- Module : test +-- Copyright : (c) Conal Elliott 2009 +-- License : GPL-3 +-- +-- Maintainer : conal@conal.net +-- Stability : experimental +-- +-- Test GtkTV +---------------------------------------------------------------------- + +import Data.Lambda (lambda) -- or use oLambda +import Data.Pair (pair) -- or use iPair, oPair + +import Interface.TV +import Interface.TV.Gtk + + +{-------------------------------------------------------------------- + Tests +--------------------------------------------------------------------} + +i1 :: In R +i1 = iTitle "size" $ sliderRI (0,10) 3 + +i2 :: In Bool +i2 = iTitle "happy" $ toggleI False + +i3 :: In (R, Bool) +i3 = iPair i1 i2 + +i4 :: In Int +i4 = iTitle "cookies" $ sliderII (0,10) 5 + +testI :: Show a => In a -> IO () +testI i = runOut (oLambda i textO) "test" show + +t1,t2,t3,t4,t5 :: IO () +t1 = testI i1 +t2 = testI i2 +t3 = testI i3 +t4 = testI i4 +t5 = testI (pair i1 i4) + +-- t5 = runUI TextureIn "Gtk.hs" print +-- t6 = runUI TextureIn "/home/conal/Pictures/phone pics/Image002.jpg" print + +-- WORKING HERE: curried function. + +o6 :: Out (R -> Bool -> String) +o6 = lambda i1 $ lambda i2 $ textO + +t6 :: IO () +t6 = runOut o6 "currying" (\ a b -> show (a,b)) + +{- + +t7 = testI TextureIn 0 + +{- +tryTex str = do allInit + loadTexture' str >>= print + IL.showErrors + showGLErrors + +t8 = tryTex "/home/conal/Haskell/gadget/src/marble-256.png" +t9 = tryTex "/home/conal/cabal/nehe-tuts-0.1.1/Data/NeHe.bmp" +-} + +main = t6 + +-- With a bogus file, I get errors. With a legit file I get no errors and +-- texture 0. Hm! Could 0 be correct? Try applying the texture. + +-} diff --git a/src/Interface/TV/Gtk.hs b/src/Interface/TV/Gtk.hs new file mode 100644 --- /dev/null +++ b/src/Interface/TV/Gtk.hs @@ -0,0 +1,246 @@ +{-# LANGUAGE RecursiveDo, MultiParamTypeClasses #-} +{-# OPTIONS_GHC -Wall #-} +---------------------------------------------------------------------- +-- | +-- Module : Interface.TV.Gtk +-- Copyright : (c) Conal Elliott 2009 +-- License : BSD3 +-- +-- Maintainer : conal@conal.net +-- Stability : experimental +-- +-- Gtk-based GUIs in the TV (tangible value) framework +---------------------------------------------------------------------- + +module Interface.TV.Gtk where + +import Control.Applicative (liftA2,(<$>)) +import Control.Monad (when) +import Data.IORef +import Data.Maybe (fromMaybe) + +import Data.Time (getCurrentTime,utctDayTime) + +import Data.Title +import Data.Pair +import Data.Lambda + +import Interface.TV.Input +import Interface.TV.Output + +import Graphics.UI.Gtk -- as Gtk + +type In = Input MkI +type Out = Output MkI MkO + + -- IPrim :: src a -> Input src a + -- OPrim :: snk a -> Output src snk a + + +-- Make a input UI. +newtype MkI a = MkI { unMkI :: MkI' a } + +-- Representation type for 'MkI'. Takes a change call-back and produces a widget and a +-- polling operation and a clean-up action. +type MkI' a = IO () -> IO (Widget, IO a, IO ()) + +-- Make an output UI. +newtype MkO a = MkO { unMkO :: MkO' a } + +-- Representation type for 'MkO'. Give a widget and a way to send it new +-- info to disply and a clean-up action. +type MkO' a = IO (Widget, OI a, IO ()) + +-- | Sink of information +type OI a = a -> IO () + +-- | Add post-processing +result :: (b -> b') -> ((a -> b) -> (a -> b')) +result = (.) + + +runOut :: Out a -> String -> a -> IO () +runOut out name a = do + initGUI + (wid,sink,cleanup) <- unMkO (output out) + sink a + window <- windowNew + set window [ windowDefaultWidth := 200 -- , windowDefaultHeight := 200 + -- , containerBorderWidth := 10 + , containerChild := wid + , windowFocusOnMap := True -- helpful? + , windowTitle := name + ] + onDestroy window (cleanup >> mainQuit) + widgetShowAll window + mainGUI + return () + + +data Orient = Horizontal | Vertical deriving (Read,Show) + +boxNew :: Orient -> Bool -> Int -> IO Box +boxNew Vertical = boxer vBoxNew +boxNew Horizontal = boxer hBoxNew + +boxer :: BoxClass box => (a -> b -> IO box) -> (a -> b -> IO Box) +boxer = (result.result.fmap) toBox + +instance Pair MkI where + pair (MkI ia) (MkI ob) = MkI $ \ refresh -> + do box <- boxNew Horizontal True 10 + (wa,geta,cleana) <- ia refresh + (wb,getb,cleanb) <- ob refresh + set box [ containerChild := wa , containerChild := wb ] + return (toWidget box, liftA2 (,) geta getb, cleana >> cleanb) + +instance Pair MkO where + pair (MkO oa) (MkO ob) = MkO $ + do box <- boxNew Horizontal True 10 + (wa,snka,cleana) <- oa + (wb,snkb,cleanb) <- ob + set box [ containerChild := wa , containerChild := wb ] + return (toWidget box, \ (a,b) -> snka a >> snkb b, cleana >> cleanb) + +instance Title_f MkI where + title_f str (MkI ia) = MkI $ \ refresh -> + do (widget,geta,cleana) <- ia refresh + frame <- frameNew + set frame [ frameLabel := str + -- , frameShadowType := ShadowEtchedOut + , containerChild := widget ] + return (toWidget frame, geta, cleana) + +instance Title_f MkO where + title_f str (MkO oa) = MkO $ + do (widget,sink,clean) <- oa + frame <- frameNew + set frame [ frameLabel := str + -- , frameShadowType := ShadowEtchedOut + , containerChild := widget ] + return (toWidget frame, sink, clean) + +instance Lambda MkI MkO where + lambda (MkI ia) (MkO ob) = MkO $ + mdo box <- boxNew Vertical True 10 + reff <- newIORef (error "mkLambda: no function yet") + let update = do f <- readIORef reff + a <- geta -- note loop + snkb (f a) + (wa,geta,cleana) <- ia update + (wb,snkb,cleanb) <- ob + set box [ containerChild := wa , containerChild := wb ] + return ( toWidget box + , \ f -> writeIORef reff f >> update + , cleana >> cleanb) + + +primMkI :: MkI' a -> In a +primMkI = iPrim . MkI + +primMkO :: MkO' a -> Out a +primMkO = oPrim . MkO + +type R = Float + +-- TODO: Consider using R == Double (for constant folding), while really +-- being float on the GLSL side. + +sliderRI :: (R,R) -> R -> In R +sliderRI = sliderGIn realToFrac realToFrac 0.01 5 + +sliderII :: (Int,Int) -> Int -> In Int +sliderII = sliderGIn fromIntegral round 1 0 + +-- Generalized slider. Gtk's scaling widgets work with Double, so this +-- adapter takes some initial params for conversion. Only fires when a +-- value really changes. +sliderGIn :: Eq a => (a -> Double) -> (Double -> a) -> a -> Int + -> (a,a) -> a -> In a +sliderGIn toD fromD step digits + (lo,hi) a0 = primMkI $ \ refresh -> + let changeTo getter new = + do old <- getter + -- putStrLn $ "(old,new) ==" ++ show (old,new) + when (old /= new) refresh + in + do w <- hScaleNewWithRange (toD lo) (toD hi) (toD step) + set w [ rangeValue := toD a0, scaleDigits := digits ] + -- Unlike wxHaskell, I guess call-backs aren't attributes in gtk2hs. + let getter = fromD <$> get w rangeValue + onRangeChangeValue w (\ _ x -> changeTo getter (fromD x) >> return False) + -- TODO: experiment with return False vs True + return (toWidget w, getter, return ()) + + +toggleI :: Bool -> In Bool +toggleI start = primMkI $ \ refresh -> + do w <- checkButtonNew + toggleButtonSetActive w start + onToggled w refresh + return (toWidget w, toggleButtonGetActive w, return ()) + +toggleO :: Out Bool +toggleO = primMkO $ + do w <- checkButtonNew + return (toWidget w, toggleButtonSetActive w, return ()) + +mkFileName :: FilePath -> In FilePath +mkFileName start = primMkI $ \ refresh -> + do w <- fileChooserButtonNew "Select file" FileChooserActionOpen + fileChooserSetFilename w start + onCurrentFolderChanged w refresh + -- fileChooserGetFilename w >>= print -- testing + return ( toWidget w + , fromMaybe start <$> fileChooserGetFilename w + , return () ) + +-- mkTextureI :: GlTexture -> In GlTexture +-- mkTextureI = error "mkTexture: not yet implemented" + +-- mkTexture start refresh (BaseG oi) = do ... +-- mkTexture _ _ _ = error "mkTexture: not BaseG" + +-- onEntryActivate :: EntryClass ec => ec -> IO () -> IO (ConnectId ec) + +textI :: String -> In String +textI start = primMkI $ \ refresh -> + do entry <- entryNew + entrySetText entry start + onEntryActivate entry refresh + return (toWidget entry, entryGetText entry, return ()) + + +textO :: Out String +textO = primMkO $ + do entry <- entryNew + return (toWidget entry, entrySetText entry, return ()) + +-- textO = primMkO $ +-- do lab <- labelNew Nothing +-- return (toWidget lab, labelSetText lab) + +-- | A clock that reports time in seconds and updates at the given period +-- (in seconds). +clockDtI :: R -> In R +clockDtI period = primMkI $ \ refresh -> + do start <- time + timeout <- timeoutAddFull (refresh >> return True) + priorityDefaultIdle (round (period * 1000)) + w <- vBoxNew True 0 -- size 0 box + return (toWidget w, subtract start <$> time, timeoutRemove timeout) + + +-- Deactivating the clock's timeout during clean-up prevents it from +-- running when gtk starts up again. Particularly useful in ghci, where +-- restarting gtk is commonplace. + + +-- | A clock that updates every 1/60 second +clockI :: In R +clockI = clockDtI (1/60) + +-- Get the time since midnight, in seconds +time :: IO R +time = (fromRational . toRational . utctDayTime) <$> getCurrentTime +