ocaml implementation of http://www.blue.sky.or.jp/grass/

(* Original implementation by @ytomino: https://gist.github.com/ytomino/1113165 ) ( Forked by @youz: https://gist.github.com/youz/99d41967e08b8dde8a9199efdb36bee0 ) ( Forked again by @woodrush: https://gist.github.com/woodrush/3d85a6569ef3c85b63bfaf9211881af6 *) type token = T_w | T_W | T_v | EOF;;

let rec scan s i = ( let length = String.length s in if i >= length then length, EOF else match s.[i] with | 'W' -> i + 1, T_W | 'w' -> i + 1, T_w | 'v' -> i + 1, T_v | '\xef' -> (* Ｗ : EF BC B7, ｖ : EF BD 96, ｗ : EF BD 97 *) if i + 2 >= length then length, EOF else begin match s.[i + 1] with | '\xbc' -> begin match s.[i + 2] with | '\xb7' -> i + 3, T_W | _ -> scan s (i + 3) end | '\xbd' -> begin match s.[i + 2] with | '\x96' -> i + 3, T_v | '\x97' -> i + 3, T_w | _ -> scan s (i + 3) end | _ -> scan s (i + 3) end | _ -> scan s (i + 1) );;

type value = Value of char option * (value -> value);;

let interpret stack source = ( let rec interpret stack source ((index, token) as position) = ( let rec apply stack f a = ( match stack with | s :: sr -> if a = 1 then ( let Value (, func) = List.nth stack (f - 1) in func s ) else if f = 1 then ( let Value (, func) = s in let arg = List.nth stack (a - 1) in func arg ) else ( apply sr (f - 1) (a - 1) ) | [] -> raise (Failure "Stack underflow!\n") ) in let rec read target source ((index, token) as position) n = ( if token = target then ( read target source (scan source index) (n + 1) ) else ( position, n ) ) in let rec read_body source position body = ( let position, f = read T_W source position 0 in if f = 0 then (position, List.rev body) else let position, a = read T_w source position 0 in read_body source position ((f, a) :: body) ) in match token with | EOF -> (* 最後に来たらApply(1,1)して終了 ) let _ = apply stack 1 1 in () | T_w -> ( 関数定義 ) let position, argc = read T_w source position 0 in let position, body = read_body source position [] in let rec bind n stack arg = ( let stack = arg :: stack in if n = 1 then ( let rec loop stack body = ( match body with | [] -> List.hd stack | (f, a) :: [] -> apply stack f a | (f, a) :: br -> loop ((apply stack f a) :: stack) br ) in loop stack body ) else ( Value (None, bind (n - 1) stack) ) ) in let r = Value (None, bind argc stack) in interpret (r :: stack) source position | T_W -> ( 関数適用 ) let position, f = read T_W source position 0 in let position, a = read T_w source position 0 in let r = apply stack f a in interpret (r :: stack) source position | T_v -> interpret stack source (scan source index) ( skip *) ) in let find_first s = ( let rec loop s i = ( let (j, t) as r = scan s i in match t with | T_w | EOF -> r | _ -> loop s j ) in loop s 0 ) in interpret stack source (find_first source) );;

let true_f = Value (None, fun x -> Value (None, fun _ -> x));; let false_f = Value (None, fun _ -> Value (None, fun y -> y));;

let char_f x = Value (Some x, fun y -> match y with | Value (Some y, _) -> if x = y then true_f else false_f | _ -> false_f);;

let init_stack = [ Value (None, function | Value (Some c, _) as a -> print_char c; flush stdout; a | _ -> raise (Failure "In primitive out, argument is not char!\n")); Value (None, function | Value (Some c, _) -> char_f (char_of_int ((int_of_char c + 1) mod 256)) | _ -> raise (Failure "In primitive succ, argument is not char!\n")); char_f 'w'; Value (None, fun x -> try char_f (input_char stdin) with End_of_file -> x)];;

let read_all filename = ( let f = open_in_bin filename in let size = in_channel_length f in let result = really_input_string f size in close_in f; result );;

let filename = Sys.argv.(1) in interpret init_stack (read_all filename);;