Zenn
Open10

Haskell atom

Haskell
組み込み
bunnyhopper_isolatedbunnyhopper_isolated

Atomモナドではatomで階層構造に追加したか否かで実行可能かどうかが変わった記憶がある。例えばcondはatomのdo記法の外で使ってもコンパイルは通ったが実行されなかったような、、、このあたりの内部をもっと読み解きたい。

bunnyhopper_isolatedbunnyhopper_isolated

やはりそうだった。
以下はex_turnOffとOnを繰り返すが、

code
ledBlink :: Atom ()
ledBlink = do
  onTimer <- timer "onTimer"
  offTimer <- timer "offTimer"
  state <- bool "state" False

  atom "turnOn" $ do
    cond $ not_ (value state) &&. timerDone offTimer
    state <== true
    call "ex_turnOn"
    startTimer onTimer 3
  
  atom "turnOff" $ do
    cond $ value state &&. timerDone onTimer
    state <== false
    call "ex_turnOff"
    startTimer offTimer 5

以下はOnをCall後は動かない。ビルドは通ってしまう。

code
ledBlink :: Atom ()
ledBlink = do
  onTimer <- timer "onTimer"
  offTimer <- timer "offTimer"
  state <- bool "state" False

  atom "turnOn" $ do
    cond $ not_ (value state) &&. timerDone offTimer
    state <== true
    call "ex_turnOn"
    startTimer onTimer 3
  
  atom "turnOff" $ do
    cond $ value state &&. timerDone onTimer
    state <== false
    call "ex_turnOff"
    startTimer offTimer 5

  cond $ not_ (value state)
  call "ex_just_print"
bunnyhopper_isolatedbunnyhopper_isolated

以下のように最後のcondをatomで囲ってしまえば動く。

code
ledBlink :: Atom ()
ledBlink = do
  onTimer <- timer "onTimer"
  offTimer <- timer "offTimer"
  state <- bool "state" False

  atom "turnOn" $ do
    cond $ not_ (value state) &&. timerDone offTimer
    state <== true
    call "ex_turnOn"
    startTimer onTimer 3
  

  atom "turnOff" $ do
    cond $ value state &&. timerDone onTimer
    state <== false
    call "ex_turnOff"
    startTimer offTimer 5

  atom "justPrint" $ do
    cond $ not_ (value state)
    call "ex_just_print"
bunnyhopper_isolatedbunnyhopper_isolated

改良版。1つのatomにまとめた。

Main.hs
ledBlink :: Atom ()
ledBlink = do
  atom "toggle" $ do
    state <- bool "state" False
    toggleTimer <- timer "toggleTimer"
    cond $ timerDone toggleTimer
    startTimer toggleTimer $ mux (value state) 5 3
    callMux (value state) "ex_turnOff" "ex_turnOn"
    state <== not_ (value state)


callMux:: E Bool -> Name -> Name -> Atom()
callMux c n1 n2 = do
    atom "callmux_true"  $ do
        cond c
        call n1
    atom "callmux_false"  $ do
        cond $ not_ c
        call n2
bunnyhopper_isolatedbunnyhopper_isolated

.hsと.cを分けた基礎として使えるコード

pre.c
#include <stdio.h>
#include <unistd.h>

void ex_turnOn() {
    printf("on\n");
}
void ex_just_print() {
    printf("hey\n");
}

void ex_turnOff() {
    printf("off\n");
}
post.c
int main(void) {
    while (true) {
        atom_tick();
        sleep(1);
    }
    return 0;
}
Main.hs
module Main (main) where

import Language.Atom
import Language.Atom.Unit
import GHC.Word
import Data.Int

ledBlink :: Atom ()
ledBlink = do
  onTimer <- timer "onTimer"
  offTimer <- timer "offTimer"
  state <- bool "state" False

  atom "turnOn" $ do
    cond $ not_ (value state) &&. timerDone offTimer
    state <== true
    call "ex_turnOn"
    startTimer onTimer 3
  

  atom "turnOff" $ do
    cond $ value state &&. timerDone onTimer
    state <== false
    call "ex_turnOff"
    startTimer offTimer 5

  atom "justPrint" $ do
    cond $ not_ (value state)
    call "ex_just_print"


main :: IO ()
main = do
  preCode <- readFile "pre.c"
  postCode <- readFile "post.c"
  let atomCfg = defaults { cFuncName = "atom_tick"
                         , cStateName = "state_example"
                         , cCode = prePostCode
                         , hCode = prePostHeader
                         , cRuleCoverage = False
                         }
      prePostCode _ _ _= (preCode, postCode)
      prePostHeader _ _ _= ("","")
  (sched, _, _, _, _) <- compile "atom_example" atomCfg ledBlink
  putStrLn $ reportSchedule sched
bunnyhopper_isolatedbunnyhopper_isolated

配列と要素参照

Main.hs
ledBlink :: Atom ()
ledBlink = do
  let x = word8' "g_x"
  arr1 <- array "arr1" [1, 2, 3]
  i <- word8 "i" 0

  atom "justPrint" $ do
    x <== arr1 !. (value i)
    i <== mod_ ((value i) + 1) 3
    call "ex_just_print"
bunnyhopper_isolatedbunnyhopper_isolated

actionでC言語関数を直接呼び出すような例。引数つけて関数呼び出しが可能となる。

Main.hs
ledBlink :: Atom ()
ledBlink = do
  let x = word8' "g_x"
  arr1 <- array "arr1" [1, 2, 3]
  i <- word8 "i" 0

  atom "justPrint" $ do
    x <== arr1 !. (value i)
    i <== mod_ ((value i) + 1) 3
    call "ex_just_print" 
    action act_str1 []
    action act_str2 [ue (value i)]

act_str1:: [String] -> String
act_str1 _ = "printf(\"hello\\n\")"

act_str2:: [String] -> String
act_str2 xs = "printf(\"action: %d\\n\", " ++ (xs !! 0) ++")"
bunnyhopper_isolatedbunnyhopper_isolated

ロータリーエンコーダのA相B相の変化から変位を求めるコード。haskellのcaseなどの条件分岐機構が使えないのでmuxで代用した。

Main.hs
getChange :: E Word8 -> E Word8 -> E Word8 -> E Word8 -> E Word64
getChange aw_bef bw_bef aw bw = let
    bef = (aw_bef ==. 1, bw_bef ==. 1)
    aft = (aw ==. 1, bw ==. 1)
    isSt1 (x, y) = not_ x &&. not_ y
    isSt2 (x, y) = not_ x &&.      y
    isSt3 (x, y) =      x &&.      y
    isSt4 (x, y) =      x &&. not_ y
    patForward =  (isSt1 bef &&. isSt2 aft)
              ||. (isSt2 bef &&. isSt3 aft)
              ||. (isSt3 bef &&. isSt4 aft)
              ||. (isSt4 bef &&. isSt1 aft)
    patBackward =   (isSt1 bef &&. isSt4 aft)
                ||. (isSt2 bef &&. isSt1 aft)
                ||. (isSt3 bef &&. isSt2 aft)
                ||. (isSt4 bef &&. isSt3 aft)
    val_f = mux patForward 1 0
    val_b = mux patBackward (-1) 0
  in val_f + val_b