OCamlでBefungeインタプリタを実装してみた

2011-12-13 プログラミング

なぜかふと思い立って、BefungeのインタプリタをOCamlで実装してしまいました。
Befungeってどんな言語？　というと、↓がHello,worldのソースファイルになるような言語です。
ちなみにこのソースはWikipediaのものをそのままお借りしています。

v @_       v
>0"!dlroW"v 
v  :#     <
>" ,olleH" v
   ^       <

WP-Codeboxでハイライトされない……
まぁ、さすがにこんなところまでサポートしてないですよね。
Brainfu*kはあるみたいですが。

さて、このプログラムがどう実行されるかというと、基本は左上から右へと読み進めていきます。
で、>だの<だの^だのvだのは矢印を表していて、その向きに実行する方向を変えてしまう、という機能を持っています。例えば一番左上がvなので、いきなり下向きに実行することになります。その真下の文字は>なので、今度は右向きに実行していきます。
0から9までの数字や、ダブルクォーテーションが出てから次にダブルクォーテーションが出てくるまでの文字は、その文字をスタックに積んでいきます。(実際には数字はその数を、文字はそのアスキーコードを、ですが)
まぁそんなこんなでぐるぐる周り、|や_が条件分岐(スタックトップによって実行する方向を変える)だったりしつつ、最終的に@に辿り着くと実行が終了する、という仕組みになっています。
詳しい解説はRoute 477さんのサイトが大変わかりやすいので、どんな言語か気になる方はこちらを読まれるとよいと思います。
つまるところ、Befungeではソースを二次元的に読まないといけないわけですね。
わけがわからないよ。

ちなみにもっとわけがわからないことに、この言語は動的にプログラムを書き換える仕組みを持っています。
スタックから数字を3つポップして、ふたつの数字が指すアドレスにみっつめの数字が表す文字を書き込む、と言った動作ですね。
一時期流行った(?)自己書き換えプログラムが実現できるわけです。
A・Iが止まらなくなったりはしないと思いますが、なかなか面白そうな機能です。
これで記号を書き換えて制御フローが変わっていくとか、頭が爆発しそうですね。

Wikipediaによると、Befungeは1993年にChris Pressey氏によって作られた後、1998年にFunge-98として仕様が改定されているようです。
Funge-98のドキュメントは見つかったものの、こちらはマルチスレッドやら2次元以上のサポートやら大幅に仕様が拡大されているそうです。
出来れば簡単そうなBefunge-93で実装したい……と思って探したものの、Befunge-93の仕様は公式も邦訳もリンク切れしてしまっているようです。
仕方ないので、Wikipediaの仕様準拠で実装しました。

方法としてはとても素直に、カーソルをレコードで、スタックをリストで、プログラムの格納メモリを2次元配列で、それぞれ表現しています。
実行も、evalで@が来るまでひたすら再帰するだけ。
ノリだけで書き始めたら2時間ちょっとで書き終わりました。
もともとコンパイルするのが難しい言語、ということで実装されているそうですが、確かにこれはコンパイルが難しそうです……というか可能なんでしょうか？
ソースの方はそこそこ長いので最後にまとめておきます。

ところで、「ocaml　befunge」でGoogle検索かけてもほとんど記事が出てこない、ということは、このネタをOCamlでやった人って実はほとんどいないんでしょうかね？
……ネタとして古過ぎるから、という気もしますが。
個人的には面白い言語だと思うので、暇があったらFunge98の方もすこし見てみたいところ。

実装に当たっては、Route 477さんを大変参考にさせて頂きました。
ここに乗っているサンプルコードの幾つかが動かないのですが、スタックが空の場合のpop操作は許すのかな……？
またリンクを辿っていけるFunge DownloadsにはちゃんとしたBe-funge93インタプリタ(デバッガ付き！)もあるようなので、OCaml使えない人もこちらを使ってみると面白いと思います。
Windows95とか書いてあるので、Windows7なんかでちゃんと動作するかは不明ですが。

以下ソースです。
多分コードを読めば分かると思いますが、トップレベルでrun_fileにファイル名を渡せば実行できます。
一応scan_from_stringで文字列をメモリに読み込ませてrunさせることも出来ます。ま、2次元でも難しいコードをトップレベルで記述するのは相当難しいと思いますが。
毎度のことながら、煮るなり焼くなり改造するなりお好きにして頂いて結構です。
HelloWorldとサンプルのアドベンチャーゲームを回しただけなのでバグがあるかもしれませんが、ご了承ください。

(* Befunge93 Interpriter 
 * 2011/12/13 @kokuyouwind
 *)
 
(* Defined Symbols and Memory Size*)
let null = '\000'
let col = 80
let row = 25 
 
(* Cursor *)
type cursor_direct =
    LEFT | RIGHT | UP | DOWN
type cursor_mode =
    EVAL | STR
type cursor =
    {x:int; y:int; dir:cursor_direct; mode:cursor_mode}
let loop_x x =
  if x <  then col - 1
  else if x >= col then 
  else x
let loop_y y =
  if y <  then row - 1
  else if y >= row then 
  else y
let next cur =
  let (x,y) =
    match cur.dir with
      LEFT ->
    (cur.x-1,cur.y)
    | RIGHT ->
    (cur.x+1,cur.y)
    | UP ->
    (cur.x,cur.y-1)
    | DOWN ->
    (cur.x,cur.y+1)
  in
  let x = loop_x x in
  let y = loop_y y in
    {x=x; y=y; dir=cur.dir; mode=cur.mode}
let get cur mem =
  mem.(cur.x).(cur.y)
let ch_dir cur dir =
  {x=cur.x; y=cur.y; dir=dir; mode=cur.mode}
let switch cur =
  let cur =
    match cur.mode with
    EVAL ->
      {x=cur.x; y=cur.y; dir=cur.dir; mode=STR}
      | STR ->
      {x=cur.x; y=cur.y; dir=cur.dir; mode=EVAL}
  in
    next cur
 
(* Stack *)
type stack = int list
let push d stk =
  d::stk
let push_char c stk =
  (Char.code c)::stk
let push_int i stk =
  (Char.code i - 48)::stk
let pop = function
    h::t -> (h,t)
  | _ -> failwith "pop empty stack"
let pop2 = function
    h1::h2::t -> (h1,h2,t)
  | _ -> failwith "pop empty stack"
 
(* Program Scaner *)
let scan stream =
  let memory = Array.make_matrix col row null in
  let x = ref  in
  let y = ref  in
    try
      while true do
    memory.(!x).(!y) <- Stream.next stream;
    if memory.(!x).(!y)='\n' then (
      memory.(!x).(!y) <- null;
      x := ;
      y := !y + 1
    ) else (
      x := !x + 1
    );
    if !x >= col then (
      ignore (read_line ());
      x := ;
      y := !y + 1
    );
    if !y >= row then (
      raise Stream.Failure
    )
      done;
      failwith "unreachable"
    with Stream.Failure ->
      memory
let scan_from_string str =
  scan (Stream.of_string str)
let scan_from_channel ichan =
  scan (Stream.of_channel ichan)
 
(* eval *)
let rec eval mem st cur =
  match cur.mode, get cur mem with
      STR,'"' -> (* "によってハイライトが狂っているので修正 *)
    eval mem st (switch cur)
    | STR,c ->
    eval mem (push_char c st) (next cur)
    | EVAL,'<' ->
    let cur = ch_dir cur LEFT in
      eval mem st (next cur)
    | EVAL,'>' ->
    let cur = ch_dir cur RIGHT in
      eval mem st (next cur)
    | EVAL,'^' ->
    let cur = ch_dir cur UP in
      eval mem st (next cur)
    | EVAL,'v' ->
    let cur = ch_dir cur DOWN in
      eval mem st (next cur)
    | EVAL,'_' ->
    let (x,st) = pop st in
    let dir = 
      if x =  then RIGHT
      else LEFT
    in
    let cur = ch_dir cur dir in
      eval mem st (next cur)
    | EVAL,'|' ->
    let (x,st) = pop st in
    let dir = 
      if x =  then DOWN
      else UP
    in
    let cur = ch_dir cur dir in
      eval mem st (next cur)
    | EVAL,' ' ->
    eval mem st (next cur)
    | EVAL,'#' ->
    eval mem st (next (next cur))
    | EVAL,'@' ->
    ()
    | EVAL,c when c >= '' && c <= '9' ->
    eval mem (push_int c st) (next cur)
    | EVAL,'"' -> (* "によってハイライトが狂っているので修正 *)
    eval mem st (switch cur)
    | EVAL,'&' ->
    let d = read_int () in
      eval mem (push d st) (next cur)
    | EVAL,'~' ->
    let s = read_line () in
    let c = String.get s  in
      eval mem (push_char c st) (next cur)
    | EVAL,'.' ->
    let (x,st) = pop st in
    let () = print_int x in
    let () = print_char ' ' in
      eval mem st (next cur)
    | EVAL,',' ->
    let (x,st) = pop st in
    let () = print_char (Char.chr x) in
      eval mem st (next cur)
    | EVAL,'+' ->
    let (y,x,st) = pop2 st in
      eval mem (push (x + y) st) (next cur)
    | EVAL,'-' ->
    let (y,x,st) = pop2 st in
      eval mem (push (x - y) st) (next cur)
    | EVAL,'*' ->
    let (y,x,st) = pop2 st in
      eval mem (push (x * y) st) (next cur)
    | EVAL,'/' ->
    let (y,x,st) = pop2 st in
      eval mem (push (x / y) st) (next cur)
    | EVAL,'%' ->
    let (y,x,st) = pop2 st in
      eval mem (push (x mod y) st) (next cur)
    | EVAL,'`' ->
    let (y,x,st) = pop2 st in
    let st =
      if x > y then push 1 st
      else push  st
    in
      eval mem st (next cur)
    | EVAL,'!' ->
    let (x,st) = pop st in
    let st =
      if x =  then push 1 st
      else push  st
    in
      eval mem st (next cur)
    | EVAL,':' ->
    let (x,st) = pop st in
    let st = push x (push x st) in
      eval mem st (next cur)
    | EVAL,'\\' ->
    let (y,x,st) = pop2 st in
    let st = push x (push y st) in
      eval mem st (next cur)
    | EVAL,'$' ->
    let (_,st) = pop st in
      eval mem st (next cur)
    | EVAL,'g' ->
    let (y,x,st) = pop2 st in
    let c = mem.(x).(y) in
      eval mem (push_char c st) (next cur)
    | EVAL,'p' ->
    let (y,x,st) = pop2 st in
    let (v,st) = pop st in
      mem.(x).(y) <- Char.chr v;
      eval mem st (next cur)
    | _,_ -> failwith "unknown symbol"
 
let run memory =
  let stack = [] in
  let cursor = {x=;y=;dir=RIGHT;mode=EVAL} in
    eval memory stack cursor
 
let run_file file =
  let ichan = open_in file in
  let memory = scan_from_channel ichan in
    close_in ichan;
    run memory
 
 
(* Dump *)
let dump memory =
  for y =  to row-1 do
    for x =  to col-1 do
      if memory.(x).(y) != null then
    print_char memory.(x).(y)
    done;
    print_char '\n'
  done