peakachu (empty) → 0.1

raw patch · 6 files changed

+256/−0 lines, 6 filesdep +GLUTdep +basesetup-changed

Dependencies added: GLUT, base

Files

LICENSE +32/−0
Setup.hs +3/−0
peakachu.cabal +24/−0
src/FRP/Peakachu.hs +38/−0
src/FRP/Peakachu/Backend/GLUT.hs +78/−0
src/FRP/Peakachu/Internal.hs +81/−0

+ LICENSE view

@@ -0,0 +1,32 @@+Copyright Yair Chuchem 2009.++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 Yair Chuchem nor the names of other+      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.+

+ Setup.hs view

@@ -0,0 +1,3 @@+import Distribution.Simple+main = defaultMain+

+ peakachu.cabal view

@@ -0,0 +1,24 @@+Name:                peakachu+Version:             0.1+Category:            FRP+Synopsis:            An FRP library with a GLUT backend+Description:+  An experiemental simple FRP library.+  GLUT backend included.+License:             BSD3+License-file:        LICENSE+Author:              Yair Chuchem+Maintainer:          yairchu@gmail.com+Cabal-Version:       >= 1.2+Stability:           experiemental+Build-type:          Simple++Library+  hs-Source-Dirs:      src+  Extensions:+  Build-Depends:       base >= 3 && < 5, GLUT+  Exposed-modules:     FRP.Peakachu+                       FRP.Peakachu.Backend.GLUT+                       FRP.Peakachu.Internal+  ghc-options:         -Wall+

+ src/FRP/Peakachu.hs view

@@ -0,0 +1,38 @@+{-# OPTIONS -O2 -Wall #-}++module FRP.Peakachu (+  Event, escanl, efilter,+  edrop, ereturn, ezip, ezip'+  ) where++import FRP.Peakachu.Internal (Event, escanl, efilter)+import Data.Monoid (mappend, mempty)++ezip :: Event a -> Event b -> Event (Maybe a, Maybe b)+ezip as bs =+  escanl step (Nothing, Nothing) $ fmap Left as `mappend` fmap Right bs+  where+    step (_, r) (Left l) = (Just l, r)+    step (l, _) (Right r) = (l, Just r)++ezip' :: Event a -> Event b -> Event (a, b)+ezip' as bs =+  fmap m . efilter f $ ezip as bs+  where+    f (Just _, Just _) = True+    f _ = False+    m (Just l, Just r) = (l, r)+    m _ = undefined++ereturn :: a -> Event a+ereturn x = escanl (const id) x mempty++edrop :: Integral i => i -> Event a -> Event a+edrop count =+  fmap snd .+  efilter ((== 0) . fst) .+  escanl step (count+1, undefined)+  where+    step (0, _) x = (0, x)+    step (i, _) x = (i-1, x)+

+ src/FRP/Peakachu/Backend/GLUT.hs view

@@ -0,0 +1,78 @@+{-# OPTIONS -O2 -Wall #-}++module FRP.Peakachu.Backend.GLUT (+  Image(..), UI(..), run+  ) where++import Data.Monoid (Monoid(..))+import FRP.Peakachu (ereturn)+import FRP.Peakachu.Internal (Event(..), makeCallbackEvent)+import Graphics.UI.GLUT (+  ($=), ($~), SettableStateVar, get,+  ClearBuffer(..), Key(..), KeyState(..),+  Modifiers, Position(..), GLfloat, Size(..),+  DisplayMode(..), initialDisplayMode, swapBuffers,+  createWindow, getArgsAndInitialize,+  displayCallback, keyboardMouseCallback,+  motionCallback, passiveMotionCallback,+  windowSize,+  clear, flush, mainLoop)+import Prelude hiding (repeat)++data Image = Image { runImage :: IO ()}++instance Monoid Image where+  mempty = Image $ return ()+  mappend (Image a) (Image b) = Image $ a >> b++data UI = UI {+  mouseMotionEvent :: Event (GLfloat, GLfloat),+  glutKeyboardMouseEvent :: Event (Key, KeyState, Modifiers, Position)+  }++makeCallbackEvent' ::+  SettableStateVar (Maybe b) ->+  ((a -> IO ()) -> b) ->+  IO (Event a)+makeCallbackEvent' callbackVar trans = do+  (event, callback) <- makeCallbackEvent+  callbackVar $= Just (trans callback)+  return event++createUI :: IO UI+createUI = do+  Size sx sy <- get windowSize+  glutMotionEvent <- makeCallbackEvent' motionCallback id+  glutPassiveMotionEvent <- makeCallbackEvent' passiveMotionCallback id+  glutKeyboardMouseE <-+    makeCallbackEvent' keyboardMouseCallback $+    \cb a b c d -> cb (a,b,c,d)+  let+    pixel2gl (Position px py) = (p2g sx px, - p2g sy py)+    p2g sa pa = 2 * fromIntegral pa / fromIntegral sa - 1+  return UI {+    glutKeyboardMouseEvent = glutKeyboardMouseE,+    mouseMotionEvent =+      mappend (ereturn (0, 0)) . -- is there a way to get the initial mouse position?+      fmap pixel2gl $+      mappend glutMotionEvent glutPassiveMotionEvent+  }++draw :: Image -> IO ()+draw image = do+  clear [ ColorBuffer ]+  runImage image+  swapBuffers+  flush++run :: (UI -> Event Image) -> IO ()+run programDesc = do+  _ <- getArgsAndInitialize+  initialDisplayMode $~ (DoubleBuffered:)+  createWindow "test"+  program <- fmap programDesc createUI+  mapM_ draw (initialValues program)+  addHandler program draw+  displayCallback $= return ()+  mainLoop+

+ src/FRP/Peakachu/Internal.hs view

@@ -0,0 +1,81 @@+{-# OPTIONS -O2 -Wall #-}++module FRP.Peakachu.Internal (+  Event(..), escanl, efilter,+  makeCallbackEvent+  ) where++import Control.Concurrent.MVar (+  newMVar, putMVar, readMVar, takeMVar)+import Control.Monad (when)+import Data.Monoid (Monoid(..))++data Event a = Event {+  addHandler :: (a -> IO ()) -> IO (),+  initialValues :: [a]+}++instance Functor Event where+  fmap func event =+    Event {+      addHandler = addHandler event . (. func),+      initialValues = map func (initialValues event)+    }++instance Monoid (Event a) where+  mempty =+    Event {+      addHandler = const (return ()),+      initialValues = []+    }+  mappend x y =+    Event {+      addHandler = \handler -> do+        addHandler x handler+        addHandler y handler,+      initialValues = initialValues x ++ initialValues y+    }++escanl :: (a -> b -> a) -> a -> Event b -> Event a+escanl step startVal event =+  Event {+    addHandler = \handler -> do+      accVar <- newMVar (last initValues)+      let+        srcHandler val = do+          prevAcc <- takeMVar accVar+          let newAcc = step prevAcc val+          putMVar accVar newAcc+          handler newAcc+      addHandler event srcHandler,+    initialValues = initValues+  }+  where+    initValues = scanl step startVal (initialValues event)++efilter :: (a -> Bool) -> Event a -> Event a+efilter cond event =+  Event {+    addHandler = \handler -> do+      let+        srcHandler val =+          when (cond val) (handler val)+      addHandler event srcHandler,+    initialValues = filter cond (initialValues event)+  }++makeCallbackEvent :: IO (Event a, a -> IO ())+makeCallbackEvent = do+  dstHandlersVar <- newMVar []+  let+    srcHandler val =+      mapM_ ($ val) =<< readMVar dstHandlersVar+    event =+      Event {+        addHandler = \handler ->+          takeMVar dstHandlersVar >>=+          putMVar dstHandlersVar . (handler :),+        initialValues = []+      }+  return (event, srcHandler)+