netwire であそんだ (haskell)

ちょっと前に FRP (Functional Reactive Programming) というのをよく聞いたが，使えなかったから流行らなかったのか難しいから流行らなかったのか実は流行っているのかよくわからない．

そもそも FRP 自体がよくわからなかったので netwire とかいう Haskell の FRP ライブラリーを見てみたがよくわからなかった．

インターネットで検索したら netwire + GLFW で簡単なプログラムを書いている例を発見した．

bitterharvest.hatenablog.com

が GLFW が古い？(2 系？)っぽかったので GLFW-b (3系？)で書きなおしてみた．

{-# LANGUAGE Arrows #-}
module Main where

import qualified Graphics.Rendering.OpenGL.GL as GL
import qualified Graphics.UI.GLFW as GF

import Control.Wire.Core (Wire, mkGen_, stepWire, mkPure)
import Control.Wire.Session (Session, HasTime
                            , stepSession, clockSession_, dtime)
import FRP.Netwire.Move (integral, integralWith)

import Control.Applicative ((<|>))
import Control.Arrow (returnA)
import Control.Category ((>>>), (<<<))
import Control.Monad (when, unless)
import System.Exit (exitFailure)
import System.IO (hPutStrLn, stderr)

errorCallback :: GF.ErrorCallback
errorCallback err description = hPutStrLn stderr $ show err ++ description

main :: IO ()
main = do
  isInitSuccess <- GF.init
  if isInitSuccess
     then mainproc
     else exitFailure

mainproc :: IO ()
mainproc = do
  mw <- GF.createWindow 640 480 "netwire test" Nothing Nothing
  case mw of
    Nothing -> GF.terminate >> exitFailure
    Just window -> do
      GF.makeContextCurrent mw
      mainloop window
      GF.destroyWindow window
      GF.terminate

mainloop :: GF.Window -> IO ()
mainloop w = runNetwork w clockSession_ $ bouncing w

runNetwork :: Monoid a
           => GF.Window -> Session IO s -> Wire s e IO a Double -> IO ()
runNetwork w ses wire = GF.windowShouldClose w >>= \b -> unless b $ do
  GL.clear [GL.ColorBuffer]
  (nextSes, nextWire) <- stepNetwork ses wire
  GF.swapBuffers w
  GF.pollEvents
  runNetwork w nextSes nextWire

stepNetwork :: Monoid a
            => Session IO s -> Wire s e IO a Double
            -> IO (Session IO s, Wire s e IO a Double)
stepNetwork ses wire = do
  (dt, nextSes) <- stepSession ses
  (out, nextWire) <- stepWire wire dt $ Right mempty
  case out of
    Left  _ -> return ()
    Right x -> do
      GL.renderPrimitive GL.Quads $
        mapM_ renderPoint $ generatePoints x 0 0.05
  return (nextSes, nextWire)

isKeyDown :: (Monoid e, Monoid b) => GF.Window -> GF.Key -> Wire s e IO a b
isKeyDown window k = mkGen_ $ \_ -> do
  input <- GF.getKey window k
  return $ case input of
    GF.KeyState'Pressed  -> Right mempty
    GF.KeyState'Released -> Left mempty

-- isKeyDown without output (onlyl tell inhibition)
isKeyDown' :: Monoid e => GF.Window -> GF.Key -> Wire s e IO a ()
isKeyDown' = isKeyDown

-- N.B. Need Bracket (), or it may work improperly although can be compiled
acceleration :: Monoid e => GF.Window -> Wire s e IO a Double
acceleration w =
  (isKeyDown' w GF.Key'D >>> isKeyDown' w GF.Key'A >>> pure 0)
    <|> (isKeyDown' w GF.Key'A >>> pure (-0.5))
    <|> (isKeyDown' w GF.Key'D >>> pure 0.5)
    <|> (pure 0)

velocity :: (Monad m, HasTime t s, Monoid e)
         => Wire s e m (Double, Bool) Double
velocity = integralWith bounce 0
  where bounce c v
          | c         = - v
          | otherwise = v

-- pos :: HasTime t s => GF.Window -> Wire s () IO () Double
-- pos w = integral 0 <<< acceleration w

renderPoint :: (Double, Double) -> IO ()
renderPoint (x, y) = GL.vertex $
  GL.Vertex2 (realToFrac x :: GL.GLfloat) (realToFrac y :: GL.GLfloat)

generatePoints :: Double -> Double -> Double -> [(Double, Double)]
generatePoints x y s =
  [(x - s, y - s), (x + s, y - s), (x + s, y + s), (x - s, y + s)]

integralWith' :: (Fractional a, HasTime t s)
              => (a -> (a, b)) -> a -> Wire s e m a (a, b)
integralWith' correct = loop
  where loop x' = mkPure $ \ds dx ->
          let dt = realToFrac (dtime ds)
              (x, b) = correct (x' + dt * dx)
          in  x' `seq` (Right (x', b), loop x)

maxLSide :: Double
maxLSide = -0.8

maxRSide :: Double
maxRSide = 0.8

position :: (Monad m, HasTime t s) => Wire s e m Double (Double, Bool)
position = integralWith' clamp 0

clamp :: Double -> (Double, Bool)
clamp p
  | p < maxLSide = (maxLSide * 2 - p, True)
  | p > maxRSide = (maxRSide * 2 - p, True)
  | otherwise    = (p, False)

bouncing :: HasTime t s => GF.Window -> Wire s () IO () Double
bouncing w = proc _ -> do
  rec a <- acceleration w -< ()
      v <- velocity -< (a, c)
      (p, c) <- position -< v
  returnA -< p

build-depends: base
             , netwire >= 5
             , OpenGL >= 3.0
             , GLFW-b >= 0.5.2.5

目新しいのは Wire とか Arrow 記法及び Category の合成 >>> とかだと思われる．

Wire s e m a b は何かというとこんなかんじ

つまり a が入力，b が出力である関数のようなものなので，モナドではないがアローになる．加えて新しい Wire を返すが，これはどこかで見たことがあるかも知れない．

ずばりこれだろう．

data Auto a b = Auto (a -> (b, Auto a b))

これについてはここらへんをみると幸せになれる．

blog.jle.im

Wire に Left が入力されるとそのワイヤーは抑制されてただ Left を返す．e はその抑制値の型．s はセッションで時間とかの入力．m はふつうモナドで，モナドの中であれこれしたいときに使う．

Wire はアローなので wire1 >>> wire2 みたいに合成できる．これはつまり wire1 の出力が wire2 の入力になる．新しいワイヤーは newwire1 >>> newwire2 となる．

<|> は Alternative の合成である．これは左が Right だとそれを，左が Left だと右を返す．

例えば (isKeyDown' w GF.Key'D >>> pure 0.5) <|> (pure 0) は，D キーが押されていれば (isKeyDown' が Right () を返すので，isKeyDown' w GF.Key'D >>> pure 0.5 の出力が Right 0.5 となり) 0.5 を，押されていなければ (isKeyDown' が Left mempty を返すので，isKeyDown' w GF.Key'D >>> pure 0.5 の出力が Left mempty となり) 0 を出力とする．

また Wire を平行に（？）合成したい時は liftA2 とか <$>...<*> の Applicative のやつが使える．liftA2 (+) wire1 wire2 とかやると wire1 と wire2 にそれぞれ入力値をいれてその出力を足したやつが出力になるみたいな．

なんかもっと丁寧に書こうと思ったけどやるきなくなってしまった（おしまい）