bitterharvest’s diary

A Bitter Harvestは小説の題名。作者は豪州のPeter Yeldham。苦闘の末に勝ちえた偏見からの解放は命との引換になったという悲しい物語

Lego BotsをHaskellで動かす-Netwireに実装する(2)

6.Netwireに実装する(続き)

修士課程の院生が、Raspberry PiにNetwireの5.0.0の版がインストールできることを教えてくれた(5.0.1はprofunctorがインストールできない)。そこで、5か月前に書いた記事(Lego BotsをHaskellで動かす-Netwireに実装する)の続きを説明しようと思う。しかし、動いたという説明だけなので、この機会を利用して関連の話(脱線)をしてみたい。

Functional Reactive Programming (FRP) の説明をしているとき、プログラミング言語はよくもここまで進化してきたなと思うことが多くなってきた。 FRPプログラミング言語の進化の中で重要な貢献をしているように思うが、その中で最も大きなものは時間を連続的に扱えるようにしたことだと思う。これにより、空間と同じように扱うことができるようになった。すなわち、時空間を4次元のベクトル空間として扱えるようにし、圏論の枠組みの中で素直に扱えるようになった。プログラミング的な概念にも大きな変化をもたらしたと思う。これは、過去、現在、未来を時間として同じように扱えるようにしたことだと思う。

プログラミング言語も日々進化しているが、人間の遺伝子も同じだという説を唱えている人たちがいる。グレゴリー・コクランとヘンリー・ハーベンディングが書いた『一万年の進化爆発』(訳は古川奈々子)がそれである。20世紀の社会科学では、人類の進化は大昔(アフリカから世界各地に拡散した5万年前)に停止したと考えられていた。これに対して、彼らは、通念とは異なり、人類は大きな変化に会うたびに遺伝子を新しい環境に適合するように変化させてきたと説いている。狩猟採取時代から農業社会に変化したときは、食物が変化したことで消化器系の遺伝子に進化が起きたであろうことを、平等な社会から階層社会に変化したことから性格を定める遺伝子が変化したであろうことなど、具体的な例と大胆な推察を交えて説明している。また、今とは逆で、このとき、身長は10cmも小さくなったそうである。

ネアンデルタール人と出会った時の進化についても彼らは記述している。人類とネアンデルタール人の間に交配があったという事実が分かる前の記述なのだが、彼らの推論の精密さには驚嘆させられる。ネアンデルタール人との関係は、スヴァンテ・ペーボ著『ネアンデルタール人は私たちと交配した』(野中香方子訳)に詳しい説明がある。

今日の大学生を見ていると、大きな変化を感じることができる。目に見えて分かるのは身長が高くなっていることである。また、学生センターから会議などを通じて学生の相談事例の説明があるが、精神的に悩んでいる学生が多くなってきているようにも感じている。これは、身長の変化のように視覚でとらえることができないので、分かりにくいのだが、一つの大きな変化ではないかとこの数年考えている。産業社会から情報社会へと変化する中で、遺伝子に変化が生じて、来るべき時代に適合しようとしているのではないかと、一万年の進化爆発の本を読んで推察した。果たしてどうであろうか。

さて、本題に移ろう。Functional Reactive Programmingは大きなスタック空間を必要とする。Raspberry Piでは、この空間はデフォルトでは8MBになっているので、不十分である。そこで、プログラムをコンパイルするとき、この空間を増やせるようにする必要がある。これには、コンパイルするときに-rtsoptsを付加する。

ghc -- make LineTraceCarByNetwire.hs BrickPi.o tick.o -rtsopts

また、実行するときは、+RTS -Ksizeを付加する。例えば、スタック空間を100MBにしたければ次のようにする。

./LineTraceCarByNetwire +RTS -K100M

プログラムを再掲しておこう。詳しい説明は、前の記事を読んでほしい。

{-# LANGUAGE Arrows, ForeignFunctionInterface #-}

--
-- ghc make LineTraceCarByNetwire.hs BrickPi.o tick.o -rtsopts
-- ./LineTraceCarByNetwire +RTS -K100M
--

import Control.Wire
import FRP.Netwire
import BrickHs
import System.IO
import Control.Monad.IO.Class

data Light = Black | White deriving (Show, Eq)

highSpeed = 200
lowSpeed = 50

car :: (HasTime t s) => Wire s () IO (Light, Light) ()
car  = proc (left, right) -> do
  _ <- motors -< (left, right) 
  t <- time -< ()
  _ <- delay 50000 -< t
  _ <- updateValues -< ()
  _ <- updateValues -< ()
  _ <- updateValues -< ()
  (left1, right1) <- lineSensors -< ()
  car -< (left1, right1)

updateValues :: Wire s () IO a Bool
updateValues = mkGen_ $ \_ -> do
  result <- brickPiUpdateValues
  print ("brickPiUpdateValues:" ++ (show result))
  return $ if result == 0 then Right True else if result == -1 then Right False else Left ()

getValue ::  Int -> Wire s () IO a Light
getValue a = mkGen_ $ \_ -> do
  value <- getSensor a
  print ("getSensor:" ++ (show value))
  return $ if value > 450 then Right Black else Right White

lineSensors :: Wire s () IO a (Light, Light)
lineSensors = proc _ -> do
  left <- getValue port_4 -< ()
  right <- getValue port_1 -< ()
  returnA -< (left, right)

setValue ::   Int -> Int -> Wire s () IO a ()
setValue p v = mkGen_ $ \_ -> do
  _ <- setMotorSpeed p v 
  print ("setMotorSpeed:" ++ (show p) ++ ", " ++ (show v))
  return $ Right ()

motors :: Wire s () IO (Light, Light) ()
motors = proc (left, right) -> do
  case (left, right) of
    (White, White) -> do
      _ <- setValue port_c highSpeed -< ()
      _ <- setValue port_b highSpeed -< ()
      returnA -< ()
    (Black, White) -> do
      _ <- setValue port_c lowSpeed -< ()
      _ <- setValue port_b highSpeed -< ()
      returnA -< ()
    (White, Black) -> do
      _ <- setValue port_c highSpeed -< ()
      _ <- setValue port_b lowSpeed -< ()
      returnA -< ()
    (_, _) -> do
      _ <- setValue port_c lowSpeed -< ()
      _ <- setValue port_b lowSpeed -< ()
      returnA -< ()

setup :: Wire s () IO a Bool
setup = mkGen_ $ \_ -> do
  result <- brickPiSetup
  print ("setup:" ++ (show result))
  return $ if result == 0 then Right True else Left ()

setAddr :: Int -> Int -> Wire s () IO a ()
setAddr p v = mkGen_ $ \_ -> do
  _ <- setAddress p v 
  return $ Right ()

setType :: Int -> Int -> Wire s () IO a ()
setType p v = mkGen_ $ \_ -> do
  _ <- setSensorType p v 
  return $ Right ()

setEnable :: Int -> Int -> Wire s () IO a ()
setEnable p v = mkGen_ $ \_ -> do
  _ <- setMotorEnable p v 
  return $ Right ()

setupSensors :: Wire s () IO a ()
setupSensors = mkGen_ $ \_ -> do
  result <- brickPiSetupSensors 
  print ("setupSensors:" ++ (show result))
  return $ Right ()

initialize :: (HasTime t s)  => Wire s () IO a ()
initialize = proc _ -> do
  result <- setup -< ()
  case result of
    True -> do
      _ <- setAddr 0 1 -< ()
      _ <- setAddr 1 2 -< ()
      _ <- setType port_4 type_sensor_light_on -< ()  -- left Sensor (White=355, Black=563)
      _ <- setType port_1 type_sensor_light_on -< ()    -- right Sensor
      _ <- setEnable port_c 1 -< ()                     -- left Motor
      _ <- setEnable port_b 1 -< ()                     -- right Sensor
      _ <- setupSensors -< ()
      t <- time -< ()
      _ <- delay 10000 -< t
      _ <- updateValues -< ()
      returnA -< ()
  returnA -< ()

main1 :: (HasTime t s) => Wire s () IO a ()
main1 = proc _ -> do
  _ <- initialize -< ()
  car  -< (White, White)

main :: IO () 
main = do
  testWireM liftIO  clockSession_ main1